File:
[LON-CAPA] /
loncom /
interface /
loncommon.pm
Revision
1.194:
download - view:
text,
annotated -
select for diffs
Sat Jul 3 18:55:16 2004 UTC (19 years, 11 months ago) by
raeburn
Branches:
MAIN
CVS tags:
HEAD
Disable trapping of form parameters present in request when page was generated. Intent is to retrieve these and pass them along in any support request generated using help support form. Trapping disabled pending further discussion.
1: # The LearningOnline Network with CAPA
2: # a pile of common routines
3: #
4: # $Id: loncommon.pm,v 1.194 2004/07/03 18:55:16 raeburn Exp $
5: #
6: # Copyright Michigan State University Board of Trustees
7: #
8: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
9: #
10: # LON-CAPA is free software; you can redistribute it and/or modify
11: # it under the terms of the GNU General Public License as published by
12: # the Free Software Foundation; either version 2 of the License, or
13: # (at your option) any later version.
14: #
15: # LON-CAPA is distributed in the hope that it will be useful,
16: # but WITHOUT ANY WARRANTY; without even the implied warranty of
17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18: # GNU General Public License for more details.
19: #
20: # You should have received a copy of the GNU General Public License
21: # along with LON-CAPA; if not, write to the Free Software
22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
23: #
24: # /home/httpd/html/adm/gpl.txt
25: #
26: # http://www.lon-capa.org/
27: #
28:
29: # Makes a table out of the previous attempts
30: # Inputs result_from_symbread, user, domain, course_id
31: # Reads in non-network-related .tab files
32:
33: # POD header:
34:
35: =pod
36:
37: =head1 NAME
38:
39: Apache::loncommon - pile of common routines
40:
41: =head1 SYNOPSIS
42:
43: Common routines for manipulating connections, student answers,
44: domains, common Javascript fragments, etc.
45:
46: =head1 OVERVIEW
47:
48: A collection of commonly used subroutines that don't have a natural
49: home anywhere else. This collection helps remove
50: redundancy from other modules and increase efficiency of memory usage.
51:
52: =cut
53:
54: # End of POD header
55: package Apache::loncommon;
56:
57: use strict;
58: use Apache::lonnet();
59: use GDBM_File;
60: use POSIX qw(strftime mktime);
61: use Apache::Constants qw(:common :http :methods);
62: use Apache::lonmsg();
63: use Apache::lonmenu();
64: use Apache::lonlocal;
65: use HTML::Entities;
66:
67: my $readit;
68:
69: ##
70: ## Global Variables
71: ##
72:
73: # ----------------------------------------------- Filetypes/Languages/Copyright
74: my %language;
75: my %supported_language;
76: my %cprtag;
77: my %scprtag;
78: my %fe; my %fd;
79: my %category_extensions;
80:
81: # ---------------------------------------------- Designs
82:
83: my %designhash;
84:
85: # ---------------------------------------------- Thesaurus variables
86: #
87: # %Keywords:
88: # A hash used by &keyword to determine if a word is considered a keyword.
89: # $thesaurus_db_file
90: # Scalar containing the full path to the thesaurus database.
91:
92: my %Keywords;
93: my $thesaurus_db_file;
94:
95: #
96: # Initialize values from language.tab, copyright.tab, filetypes.tab,
97: # thesaurus.tab, and filecategories.tab.
98: #
99: BEGIN {
100: # Variable initialization
101: $thesaurus_db_file = $Apache::lonnet::perlvar{'lonTabDir'}."/thesaurus.db";
102: #
103: unless ($readit) {
104: # ------------------------------------------------------------------- languages
105: {
106: my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}.
107: '/language.tab';
108: if ( open(my $fh,"<$langtabfile") ) {
109: while (<$fh>) {
110: next if /^\#/;
111: chomp;
112: my ($key,$two,$country,$three,$enc,$val,$sup)=(split(/\t/,$_));
113: $language{$key}=$val.' - '.$enc;
114: if ($sup) {
115: $supported_language{$key}=$sup;
116: }
117: }
118: close($fh);
119: }
120: }
121: # ------------------------------------------------------------------ copyrights
122: {
123: my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.
124: '/copyright.tab';
125: if ( open (my $fh,"<$copyrightfile") ) {
126: while (<$fh>) {
127: next if /^\#/;
128: chomp;
129: my ($key,$val)=(split(/\s+/,$_,2));
130: $cprtag{$key}=$val;
131: }
132: close($fh);
133: }
134: }
135: # ------------------------------------------------------------------ source copyrights
136: {
137: my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.
138: '/source_copyright.tab';
139: if ( open (my $fh,"<$sourcecopyrightfile") ) {
140: while (<$fh>) {
141: next if /^\#/;
142: chomp;
143: my ($key,$val)=(split(/\s+/,$_,2));
144: $scprtag{$key}=$val;
145: }
146: close($fh);
147: }
148: }
149:
150: # -------------------------------------------------------------- domain designs
151:
152: my $filename;
153: my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';
154: opendir(DIR,$designdir);
155: while ($filename=readdir(DIR)) {
156: my ($domain)=($filename=~/^(\w+)\./);
157: {
158: my $designfile = $designdir.'/'.$filename;
159: if ( open (my $fh,"<$designfile") ) {
160: while (<$fh>) {
161: next if /^\#/;
162: chomp;
163: my ($key,$val)=(split(/\=/,$_));
164: if ($val) { $designhash{$domain.'.'.$key}=$val; }
165: }
166: close($fh);
167: }
168: }
169:
170: }
171: closedir(DIR);
172:
173:
174: # ------------------------------------------------------------- file categories
175: {
176: my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}.
177: '/filecategories.tab';
178: if ( open (my $fh,"<$categoryfile") ) {
179: while (<$fh>) {
180: next if /^\#/;
181: chomp;
182: my ($extension,$category)=(split(/\s+/,$_,2));
183: push @{$category_extensions{lc($category)}},$extension;
184: }
185: close($fh);
186: }
187:
188: }
189: # ------------------------------------------------------------------ file types
190: {
191: my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}.
192: '/filetypes.tab';
193: if ( open (my $fh,"<$typesfile") ) {
194: while (<$fh>) {
195: next if (/^\#/);
196: chomp;
197: my ($ending,$emb,$descr)=split(/\s+/,$_,3);
198: if ($descr ne '') {
199: $fe{$ending}=lc($emb);
200: $fd{$ending}=$descr;
201: }
202: }
203: close($fh);
204: }
205: }
206: &Apache::lonnet::logthis(
207: "<font color=yellow>INFO: Read file types</font>");
208: $readit=1;
209: } # end of unless($readit)
210:
211: }
212:
213: ###############################################################
214: ## HTML and Javascript Helper Functions ##
215: ###############################################################
216:
217: =pod
218:
219: =head1 HTML and Javascript Functions
220:
221: =over 4
222:
223: =item * browser_and_searcher_javascript ()
224:
225: X<browsing, javascript>X<searching, javascript>Returns a string
226: containing javascript with two functions, C<openbrowser> and
227: C<opensearcher>. Returned string does not contain E<lt>scriptE<gt>
228: tags.
229:
230: =item * openbrowser(formname,elementname,only,omit) [javascript]
231:
232: inputs: formname, elementname, only, omit
233:
234: formname and elementname indicate the name of the html form and name of
235: the element that the results of the browsing selection are to be placed in.
236:
237: Specifying 'only' will restrict the browser to displaying only files
238: with the given extension. Can be a comma separated list.
239:
240: Specifying 'omit' will restrict the browser to NOT displaying files
241: with the given extension. Can be a comma separated list.
242:
243: =item * opensearcher(formname, elementname) [javascript]
244:
245: Inputs: formname, elementname
246:
247: formname and elementname specify the name of the html form and the name
248: of the element the selection from the search results will be placed in.
249:
250: =cut
251:
252: sub browser_and_searcher_javascript {
253: my $resurl=&lastresurl();
254: return <<END;
255: var editbrowser = null;
256: function openbrowser(formname,elementname,only,omit,titleelement) {
257: var url = '$resurl/?';
258: if (editbrowser == null) {
259: url += 'launch=1&';
260: }
261: url += 'catalogmode=interactive&';
262: url += 'mode=edit&';
263: url += 'form=' + formname + '&';
264: if (only != null) {
265: url += 'only=' + only + '&';
266: }
267: if (omit != null) {
268: url += 'omit=' + omit + '&';
269: }
270: if (titleelement != null) {
271: url += 'titleelement=' + titleelement + '&';
272: }
273: url += 'element=' + elementname + '';
274: var title = 'Browser';
275: var options = 'scrollbars=1,resizable=1,menubar=0';
276: options += ',width=700,height=600';
277: editbrowser = open(url,title,options,'1');
278: editbrowser.focus();
279: }
280: var editsearcher;
281: function opensearcher(formname,elementname,titleelement) {
282: var url = '/adm/searchcat?';
283: if (editsearcher == null) {
284: url += 'launch=1&';
285: }
286: url += 'catalogmode=interactive&';
287: url += 'mode=edit&';
288: url += 'form=' + formname + '&';
289: if (titleelement != null) {
290: url += 'titleelement=' + titleelement + '&';
291: }
292: url += 'element=' + elementname + '';
293: var title = 'Search';
294: var options = 'scrollbars=1,resizable=1,menubar=0';
295: options += ',width=700,height=600';
296: editsearcher = open(url,title,options,'1');
297: editsearcher.focus();
298: }
299: END
300: }
301:
302: sub lastresurl {
303: if ($ENV{'environment.lastresurl'}) {
304: return $ENV{'environment.lastresurl'}
305: } else {
306: return '/res';
307: }
308: }
309:
310: sub storeresurl {
311: my $resurl=&Apache::lonnet::clutter(shift);
312: unless ($resurl=~/^\/res/) { return 0; }
313: $resurl=~s/\/$//;
314: &Apache::lonnet::put('environment',{'lastresurl' => $resurl});
315: &Apache::lonnet::appenv('environment.lastresurl' => $resurl);
316: return 1;
317: }
318:
319: sub studentbrowser_javascript {
320: unless (
321: (($ENV{'request.course.id'}) &&
322: (&Apache::lonnet::allowed('srm',$ENV{'request.course.id'})))
323: || ($ENV{'request.role'}=~/^(au|dc|su)/)
324: ) { return ''; }
325: return (<<'ENDSTDBRW');
326: <script type="text/javascript" language="Javascript" >
327: var stdeditbrowser;
328: function openstdbrowser(formname,uname,udom,roleflag) {
329: var url = '/adm/pickstudent?';
330: var filter;
331: eval('filter=document.'+formname+'.'+uname+'.value;');
332: if (filter != null) {
333: if (filter != '') {
334: url += 'filter='+filter+'&';
335: }
336: }
337: url += 'form=' + formname + '&unameelement='+uname+
338: '&udomelement='+udom;
339: if (roleflag) { url+="&roles=1"; }
340: var title = 'Student_Browser';
341: var options = 'scrollbars=1,resizable=1,menubar=0';
342: options += ',width=700,height=600';
343: stdeditbrowser = open(url,title,options,'1');
344: stdeditbrowser.focus();
345: }
346: </script>
347: ENDSTDBRW
348: }
349:
350: sub selectstudent_link {
351: my ($form,$unameele,$udomele)=@_;
352: if ($ENV{'request.course.id'}) {
353: unless (&Apache::lonnet::allowed('srm',$ENV{'request.course.id'})) {
354: return '';
355: }
356: return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele.
357: '","'.$udomele.'");'."'>".&mt('Select User')."</a>";
358: }
359: if ($ENV{'request.role'}=~/^(au|dc|su)/) {
360: return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele.
361: '","'.$udomele.'",1);'."'>".&mt('Select User')."</a>";
362: }
363: return '';
364: }
365:
366: sub coursebrowser_javascript {
367: my ($domainfilter)=@_;
368: return (<<ENDSTDBRW);
369: <script type="text/javascript" language="Javascript" >
370: var stdeditbrowser;
371: function opencrsbrowser(formname,uname,udom,desc) {
372: var url = '/adm/pickcourse?';
373: var filter;
374: if (filter != null) {
375: if (filter != '') {
376: url += 'filter='+filter+'&';
377: }
378: }
379: var domainfilter='$domainfilter';
380: if (domainfilter != null) {
381: if (domainfilter != '') {
382: url += 'domainfilter='+domainfilter+'&';
383: }
384: }
385: url += 'form=' + formname + '&cnumelement='+uname+
386: '&cdomelement='+udom+
387: '&cnameelement='+desc;
388: var title = 'Course_Browser';
389: var options = 'scrollbars=1,resizable=1,menubar=0';
390: options += ',width=700,height=600';
391: stdeditbrowser = open(url,title,options,'1');
392: stdeditbrowser.focus();
393: }
394: </script>
395: ENDSTDBRW
396: }
397:
398: sub selectcourse_link {
399: my ($form,$unameele,$udomele,$desc)=@_;
400: return "<a href='".'javascript:opencrsbrowser("'.$form.'","'.$unameele.
401: '","'.$udomele.'","'.$desc.'");'."'>".&mt('Select Course')."</a>";
402: }
403:
404: =pod
405:
406: =item * linked_select_forms(...)
407:
408: linked_select_forms returns a string containing a <script></script> block
409: and html for two <select> menus. The select menus will be linked in that
410: changing the value of the first menu will result in new values being placed
411: in the second menu. The values in the select menu will appear in alphabetical
412: order.
413:
414: linked_select_forms takes the following ordered inputs:
415:
416: =over 4
417:
418: =item * $formname, the name of the <form> tag
419:
420: =item * $middletext, the text which appears between the <select> tags
421:
422: =item * $firstdefault, the default value for the first menu
423:
424: =item * $firstselectname, the name of the first <select> tag
425:
426: =item * $secondselectname, the name of the second <select> tag
427:
428: =item * $hashref, a reference to a hash containing the data for the menus.
429:
430: =back
431:
432: Below is an example of such a hash. Only the 'text', 'default', and
433: 'select2' keys must appear as stated. keys(%menu) are the possible
434: values for the first select menu. The text that coincides with the
435: first menu value is given in $menu{$choice1}->{'text'}. The values
436: and text for the second menu are given in the hash pointed to by
437: $menu{$choice1}->{'select2'}.
438:
439: my %menu = ( A1 => { text =>"Choice A1" ,
440: default => "B3",
441: select2 => {
442: B1 => "Choice B1",
443: B2 => "Choice B2",
444: B3 => "Choice B3",
445: B4 => "Choice B4"
446: }
447: },
448: A2 => { text =>"Choice A2" ,
449: default => "C2",
450: select2 => {
451: C1 => "Choice C1",
452: C2 => "Choice C2",
453: C3 => "Choice C3"
454: }
455: },
456: A3 => { text =>"Choice A3" ,
457: default => "D6",
458: select2 => {
459: D1 => "Choice D1",
460: D2 => "Choice D2",
461: D3 => "Choice D3",
462: D4 => "Choice D4",
463: D5 => "Choice D5",
464: D6 => "Choice D6",
465: D7 => "Choice D7"
466: }
467: }
468: );
469:
470: =cut
471:
472: sub linked_select_forms {
473: my ($formname,
474: $middletext,
475: $firstdefault,
476: $firstselectname,
477: $secondselectname,
478: $hashref
479: ) = @_;
480: my $second = "document.$formname.$secondselectname";
481: my $first = "document.$formname.$firstselectname";
482: # output the javascript to do the changing
483: my $result = '';
484: $result.="<script>\n";
485: $result.="var select2data = new Object();\n";
486: $" = '","';
487: my $debug = '';
488: foreach my $s1 (sort(keys(%$hashref))) {
489: $result.="select2data.d_$s1 = new Object();\n";
490: $result.="select2data.d_$s1.def = new String('".
491: $hashref->{$s1}->{'default'}."');\n";
492: $result.="select2data.d_$s1.values = new Array(";
493: my @s2values = sort(keys( %{ $hashref->{$s1}->{'select2'} } ));
494: $result.="\"@s2values\");\n";
495: $result.="select2data.d_$s1.texts = new Array(";
496: my @s2texts;
497: foreach my $value (@s2values) {
498: push @s2texts, $hashref->{$s1}->{'select2'}->{$value};
499: }
500: $result.="\"@s2texts\");\n";
501: }
502: $"=' ';
503: $result.= <<"END";
504:
505: function select1_changed() {
506: // Determine new choice
507: var newvalue = "d_" + $first.value;
508: // update select2
509: var values = select2data[newvalue].values;
510: var texts = select2data[newvalue].texts;
511: var select2def = select2data[newvalue].def;
512: var i;
513: // out with the old
514: for (i = 0; i < $second.options.length; i++) {
515: $second.options[i] = null;
516: }
517: // in with the nuclear
518: for (i=0;i<values.length; i++) {
519: $second.options[i] = new Option(values[i]);
520: $second.options[i].value = values[i];
521: $second.options[i].text = texts[i];
522: if (values[i] == select2def) {
523: $second.options[i].selected = true;
524: }
525: }
526: }
527: </script>
528: END
529: # output the initial values for the selection lists
530: $result .= "<select size=\"1\" name=\"$firstselectname\" onchange=\"select1_changed()\">\n";
531: foreach my $value (sort(keys(%$hashref))) {
532: $result.=" <option value=\"$value\" ";
533: $result.=" selected=\"true\" " if ($value eq $firstdefault);
534: $result.=">".&mt($hashref->{$value}->{'text'})."</option>\n";
535: }
536: $result .= "</select>\n";
537: my %select2 = %{$hashref->{$firstdefault}->{'select2'}};
538: $result .= $middletext;
539: $result .= "<select size=\"1\" name=\"$secondselectname\">\n";
540: my $seconddefault = $hashref->{$firstdefault}->{'default'};
541: foreach my $value (sort(keys(%select2))) {
542: $result.=" <option value=\"$value\" ";
543: $result.=" selected=\"true\" " if ($value eq $seconddefault);
544: $result.=">".&mt($select2{$value})."</option>\n";
545: }
546: $result .= "</select>\n";
547: # return $debug;
548: return $result;
549: } # end of sub linked_select_forms {
550:
551: =pod
552:
553: =item * help_open_topic($topic, $text, $stayOnPage, $width, $height)
554:
555: Returns a string corresponding to an HTML link to the given help
556: $topic, where $topic corresponds to the name of a .tex file in
557: /home/httpd/html/adm/help/tex, with underscores replaced by
558: spaces.
559:
560: $text will optionally be linked to the same topic, allowing you to
561: link text in addition to the graphic. If you do not want to link
562: text, but wish to specify one of the later parameters, pass an
563: empty string.
564:
565: $stayOnPage is a value that will be interpreted as a boolean. If true,
566: the link will not open a new window. If false, the link will open
567: a new window using Javascript. (Default is false.)
568:
569: $width and $height are optional numerical parameters that will
570: override the width and height of the popped up window, which may
571: be useful for certain help topics with big pictures included.
572:
573: =cut
574:
575: sub help_open_topic {
576: my ($topic, $text, $stayOnPage, $width, $height) = @_;
577: $text = "" if (not defined $text);
578: $stayOnPage = 0 if (not defined $stayOnPage);
579: if ($ENV{'browser.interface'} eq 'textual' ||
580: $ENV{'environment.remote'} eq 'off' ) {
581: $stayOnPage=1;
582: }
583: $width = 350 if (not defined $width);
584: $height = 400 if (not defined $height);
585: my $filename = $topic;
586: $filename =~ s/ /_/g;
587:
588: my $template = "";
589: my $link;
590:
591: $topic=~s/\W/\_/g;
592:
593: if (!$stayOnPage)
594: {
595: $link = "javascript:void(open('/adm/help/${filename}.hlp', 'Help_for_$topic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";
596: }
597: else
598: {
599: $link = "/adm/help/${filename}.hlp";
600: }
601:
602: # Add the text
603: if ($text ne "")
604: {
605: $template .=
606: "<table bgcolor='#3333AA' cellspacing='1' cellpadding='1' border='0'><tr>".
607: "<td bgcolor='#5555FF'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
608: }
609:
610: # Add the graphic
611: my $title = &mt('Online Help');
612: $template .= <<"ENDTEMPLATE";
613: <a href="$link" title="$title"><image src="/adm/help/gif/smallHelp.gif" border="0" alt="(Help: $topic)" /></a>
614: ENDTEMPLATE
615: if ($text ne '') { $template.='</td></tr></table>' };
616: return $template;
617:
618: }
619:
620: # This is a quicky function for Latex cheatsheet editing, since it
621: # appears in at least four places
622: sub helpLatexCheatsheet {
623: my $other = shift;
624: my $addOther = '';
625: if ($other) {
626: $addOther = Apache::loncommon::help_open_topic($other, shift,
627: undef, undef, 600) .
628: '</td><td>';
629: }
630: return '<table><tr><td>'.
631: $addOther .
632: &Apache::loncommon::help_open_topic("Greek_Symbols",'Greek Symbols',
633: undef,undef,600)
634: .'</td><td>'.
635: &Apache::loncommon::help_open_topic("Other_Symbols",'Other Symbols',
636: undef,undef,600)
637: .'</td></tr></table>';
638: }
639:
640: sub help_open_menu {
641: my ($color,$topic,$component_help,$function,$faq,$bug,$stayOnPage,$width,$height,$text) = @_;
642: $text = "" if (not defined $text);
643: $stayOnPage = 0 if (not defined $stayOnPage);
644: if ($ENV{'browser.interface'} eq 'textual' ||
645: $ENV{'environment.remote'} eq 'off' ) {
646: $stayOnPage=1;
647: }
648: $width = 620 if (not defined $width);
649: $height = 600 if (not defined $height);
650: my $link='';
651: my $title = &mt('Choose your help');
652: my $origurl = $ENV{'REQUEST_URI'};
653: my $timestamp = time;
654: # if ($ENV{'request.course.fn'}) {
655: # open(FILE,">$ENV{'request.course.fn'}.formdata");
656: # &get_unprocessed_cgi($ENV{'QUERY_STRING'},undef);
657: # foreach (keys %ENV) {
658: # if ($_ =~ m/^form\.(.+)$/) {
659: # if (ref($ENV{$_}) eq 'ARRAY') {
660: # my $valstr = join(",",@{$ENV{$_}});
661: # print FILE "$1 = $valstr\n";
662: # } else {
663: # print FILE "$1 = $ENV{$_}\n";
664: # }
665: # }
666: # }
667: # close(FILE);
668: # }
669: foreach (\$color,\$function,\$topic,\$component_help,\$faq,\$bug,\$origurl) {
670: $$_ = &Apache::lonnet::escape($$_);
671: }
672:
673: if (!$stayOnPage)
674: {
675: $link = "javascript:helpMenu('open')";
676: }
677: else
678: {
679: $link = "javascript:helpMenu('display')";
680: }
681: my $banner_link = "/adm/helpmenu?page=banner&color=$color&function=$function&topic=$topic&component_help=$component_help&faq=$faq&bug=$bug&origurl=$origurl&stamp=$timestamp";
682: my $details_link = "/adm/helpmenu?page=body&color=$color&function=$function&topic=$topic&component_help=$component_help&faq=$faq&bug=$bug&origurl=$origurl&stamp=$timestamp";
683: my $template .= <<"ENDTEMPLATE";
684: <script>
685: function helpMenu(caller) {
686: if (caller == 'open') {
687: newWindow = window.open("","helpmenu","HEIGHT=$height,WIDTH=$width,resize=yes,scrollbars=yes" )
688: caller = newWindow.document
689: } else {
690: caller = this.document
691: }
692: caller.write("<html><head><title>LON-CAPA Help Menu</title><meta http-equiv='pragma' content='no-cache'></head>")
693: caller.write("<frameset rows='105,*' border='0'><frame name='bannerframe' src='$banner_link'><frame name='bodyframe' src='$details_link'></frameset>")
694: caller.write("</html>")
695: caller.close()
696: if (caller == newWindow.document) {
697: caller.focus()
698: }
699: }
700: </script>
701: <a href="$link" title="$title"><image src="/adm/lonMisc/smallFAQ.gif" border="0" alt="(Help Menu)" /></a>
702: ENDTEMPLATE
703: return $template;
704: }
705:
706: sub help_open_bug {
707: my ($topic, $text, $stayOnPage, $width, $height) = @_;
708: unless ($ENV{'user.adv'}) { return ''; }
709: unless ($Apache::lonnet::perlvar{'BugzillaHost'}) { return ''; }
710: $text = "" if (not defined $text);
711: $stayOnPage = 0 if (not defined $stayOnPage);
712: if ($ENV{'browser.interface'} eq 'textual' ||
713: $ENV{'environment.remote'} eq 'off' ) {
714: $stayOnPage=1;
715: }
716: $width = 600 if (not defined $width);
717: $height = 600 if (not defined $height);
718:
719: $topic=~s/\W+/\+/g;
720: my $link='';
721: my $template='';
722: my $url=$Apache::lonnet::perlvar{'BugzillaHost'}.'enter_bug.cgi?product=LON-CAPA&bug_file_loc='.
723: &Apache::lonnet::escape($ENV{'REQUEST_URI'}).'&component='.$topic;
724: if (!$stayOnPage)
725: {
726: $link = "javascript:void(open('$url', 'Bugzilla', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";
727: }
728: else
729: {
730: $link = $url;
731: }
732: # Add the text
733: if ($text ne "")
734: {
735: $template .=
736: "<table bgcolor='#AA3333' cellspacing='1' cellpadding='1' border='0'><tr>".
737: "<td bgcolor='#FF5555'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
738: }
739:
740: # Add the graphic
741: my $title = &mt('Report a Bug');
742: $template .= <<"ENDTEMPLATE";
743: <a href="$link" title="$title"><image src="/adm/lonMisc/smallBug.gif" border="0" alt="(Bug: $topic)" /></a>
744: ENDTEMPLATE
745: if ($text ne '') { $template.='</td></tr></table>' };
746: return $template;
747:
748: }
749:
750: sub help_open_faq {
751: my ($topic, $text, $stayOnPage, $width, $height) = @_;
752: unless ($ENV{'user.adv'}) { return ''; }
753: unless ($Apache::lonnet::perlvar{'FAQHost'}) { return ''; }
754: $text = "" if (not defined $text);
755: $stayOnPage = 0 if (not defined $stayOnPage);
756: if ($ENV{'browser.interface'} eq 'textual' ||
757: $ENV{'environment.remote'} eq 'off' ) {
758: $stayOnPage=1;
759: }
760: $width = 350 if (not defined $width);
761: $height = 400 if (not defined $height);
762:
763: $topic=~s/\W+/\+/g;
764: my $link='';
765: my $template='';
766: my $url=$Apache::lonnet::perlvar{'FAQHost'}.'/fom/cache/'.$topic.'.html';
767: if (!$stayOnPage)
768: {
769: $link = "javascript:void(open('$url', 'FAQ-O-Matic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";
770: }
771: else
772: {
773: $link = $url;
774: }
775:
776: # Add the text
777: if ($text ne "")
778: {
779: $template .=
780: "<table bgcolor='#337733' cellspacing='1' cellpadding='1' border='0'><tr>".
781: "<td bgcolor='#448844'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
782: }
783:
784: # Add the graphic
785: my $title = &mt('View the FAQ');
786: $template .= <<"ENDTEMPLATE";
787: <a href="$link" title="$title"><image src="/adm/lonMisc/smallFAQ.gif" border="0" alt="(FAQ: $topic)" /></a>
788: ENDTEMPLATE
789: if ($text ne '') { $template.='</td></tr></table>' };
790: return $template;
791:
792: }
793:
794: ###############################################################
795: ###############################################################
796:
797: =pod
798:
799: =item * csv_translate($text)
800:
801: Translate $text to allow it to be output as a 'comma separated values'
802: format.
803:
804: =cut
805:
806: ###############################################################
807: ###############################################################
808: sub csv_translate {
809: my $text = shift;
810: $text =~ s/\"/\"\"/g;
811: $text =~ s/\n//g;
812: return $text;
813: }
814:
815:
816: ###############################################################
817: ###############################################################
818:
819: =pod
820:
821: =item * define_excel_formats
822:
823: Define some commonly used Excel cell formats.
824:
825: Currently supported formats:
826:
827: =over 4
828:
829: =item header
830:
831: =item bold
832:
833: =item h1
834:
835: =item h2
836:
837: =item h3
838:
839: =item date
840:
841: =back
842:
843: Inputs: $workbook
844:
845: Returns: $format, a hash reference.
846:
847: =cut
848:
849: ###############################################################
850: ###############################################################
851: sub define_excel_formats {
852: my ($workbook) = @_;
853: my $format;
854: $format->{'header'} = $workbook->add_format(bold => 1,
855: bottom => 1,
856: align => 'center');
857: $format->{'bold'} = $workbook->add_format(bold=>1);
858: $format->{'h1'} = $workbook->add_format(bold=>1, size=>18);
859: $format->{'h2'} = $workbook->add_format(bold=>1, size=>16);
860: $format->{'h3'} = $workbook->add_format(bold=>1, size=>14);
861: $format->{'date'} = $workbook->add_format(num_format=>
862: 'mmm d yyyy hh:mm AM/PM');
863: return $format;
864: }
865:
866: ###############################################################
867: ###############################################################
868:
869: =pod
870:
871: =item * change_content_javascript():
872:
873: This and the next function allow you to create small sections of an
874: otherwise static HTML page that you can update on the fly with
875: Javascript, even in Netscape 4.
876:
877: The Javascript fragment returned by this function (no E<lt>scriptE<gt> tag)
878: must be written to the HTML page once. It will prove the Javascript
879: function "change(name, content)". Calling the change function with the
880: name of the section
881: you want to update, matching the name passed to C<changable_area>, and
882: the new content you want to put in there, will put the content into
883: that area.
884:
885: B<Note>: Netscape 4 only reserves enough space for the changable area
886: to contain room for the original contents. You need to "make space"
887: for whatever changes you wish to make, and be B<sure> to check your
888: code in Netscape 4. This feature in Netscape 4 is B<not> powerful;
889: it's adequate for updating a one-line status display, but little more.
890: This script will set the space to 100% width, so you only need to
891: worry about height in Netscape 4.
892:
893: Modern browsers are much less limiting, and if you can commit to the
894: user not using Netscape 4, this feature may be used freely with
895: pretty much any HTML.
896:
897: =cut
898:
899: sub change_content_javascript {
900: # If we're on Netscape 4, we need to use Layer-based code
901: if ($ENV{'browser.type'} eq 'netscape' &&
902: $ENV{'browser.version'} =~ /^4\./) {
903: return (<<NETSCAPE4);
904: function change(name, content) {
905: doc = document.layers[name+"___escape"].layers[0].document;
906: doc.open();
907: doc.write(content);
908: doc.close();
909: }
910: NETSCAPE4
911: } else {
912: # Otherwise, we need to use semi-standards-compliant code
913: # (technically, "innerHTML" isn't standard but the equivalent
914: # is really scary, and every useful browser supports it
915: return (<<DOMBASED);
916: function change(name, content) {
917: element = document.getElementById(name);
918: element.innerHTML = content;
919: }
920: DOMBASED
921: }
922: }
923:
924: =pod
925:
926: =item * changable_area($name, $origContent):
927:
928: This provides a "changable area" that can be modified on the fly via
929: the Javascript code provided in C<change_content_javascript>. $name is
930: the name you will use to reference the area later; do not repeat the
931: same name on a given HTML page more then once. $origContent is what
932: the area will originally contain, which can be left blank.
933:
934: =cut
935:
936: sub changable_area {
937: my ($name, $origContent) = @_;
938:
939: if ($ENV{'browser.type'} eq 'netscape' &&
940: $ENV{'browser.version'} =~ /^4\./) {
941: # If this is netscape 4, we need to use the Layer tag
942: return "<ilayer width='100%' id='${name}___escape' overflow='none'><layer width='100%' id='$name' overflow='none'>$origContent</layer></ilayer>";
943: } else {
944: return "<span id='$name'>$origContent</span>";
945: }
946: }
947:
948: =pod
949:
950: =back
951:
952: =cut
953:
954: ###############################################################
955: ## Home server <option> list generating code ##
956: ###############################################################
957:
958: =pod
959:
960: =head1 Home Server option list generating code
961:
962: =over 4
963:
964: =item * get_domains()
965:
966: Returns an array containing each of the domains listed in the hosts.tab
967: file.
968:
969: =cut
970:
971: #-------------------------------------------
972: sub get_domains {
973: # The code below was stolen from "The Perl Cookbook", p 102, 1st ed.
974: my @domains;
975: my %seen;
976: foreach (sort values(%Apache::lonnet::hostdom)) {
977: push (@domains,$_) unless $seen{$_}++;
978: }
979: return @domains;
980: }
981:
982: # ------------------------------------------
983:
984: sub domain_select {
985: my ($name,$value,$multiple)=@_;
986: my %domains=map {
987: $_ => $_.' '.$Apache::lonnet::domaindescription{$_}
988: } &get_domains;
989: if ($multiple) {
990: $domains{''}=&mt('Any domain');
991: return &multiple_select_form($name,$value,4,%domains);
992: } else {
993: return &select_form($name,$value,%domains);
994: }
995: }
996:
997: sub multiple_select_form {
998: my ($name,$value,$size,%hash)=@_;
999: my %selected = map { $_ => 1 } ref($value)?@{$value}:($value);
1000: my $output='';
1001: if (! defined($size)) {
1002: $size = 4;
1003: if (scalar(keys(%hash))<4) {
1004: $size = scalar(keys(%hash));
1005: }
1006: }
1007: $output.="\n<select name='$name' size='$size' multiple='1'>";
1008: foreach (sort(keys(%hash))) {
1009: $output.='<option value="'.$_.'" ';
1010: $output.='selected ' if ($selected{$_});
1011: $output.='>'.$hash{$_}."</option>\n";
1012: }
1013: $output.="</select>\n";
1014: return $output;
1015: }
1016:
1017: #-------------------------------------------
1018:
1019: =pod
1020:
1021: =item * select_form($defdom,$name,%hash)
1022:
1023: Returns a string containing a <select name='$name' size='1'> form to
1024: allow a user to select options from a hash option_name => displayed text.
1025: See lonrights.pm for an example invocation and use.
1026:
1027: =cut
1028:
1029: #-------------------------------------------
1030: sub select_form {
1031: my ($def,$name,%hash) = @_;
1032: my $selectform = "<select name=\"$name\" size=\"1\">\n";
1033: my @keys;
1034: if (exists($hash{'select_form_order'})) {
1035: @keys=@{$hash{'select_form_order'}};
1036: } else {
1037: @keys=sort(keys(%hash));
1038: }
1039: foreach (@keys) {
1040: $selectform.="<option value=\"$_\" ".
1041: ($_ eq $def ? 'selected' : '').
1042: ">".&mt($hash{$_})."</option>\n";
1043: }
1044: $selectform.="</select>";
1045: return $selectform;
1046: }
1047:
1048: sub gradeleveldescription {
1049: my $gradelevel=shift;
1050: my %gradelevels=(0 => 'Not specified',
1051: 1 => 'Grade 1',
1052: 2 => 'Grade 2',
1053: 3 => 'Grade 3',
1054: 4 => 'Grade 4',
1055: 5 => 'Grade 5',
1056: 6 => 'Grade 6',
1057: 7 => 'Grade 7',
1058: 8 => 'Grade 8',
1059: 9 => 'Grade 9',
1060: 10 => 'Grade 10',
1061: 11 => 'Grade 11',
1062: 12 => 'Grade 12',
1063: 13 => 'Grade 13',
1064: 14 => '100 Level',
1065: 15 => '200 Level',
1066: 16 => '300 Level',
1067: 17 => '400 Level',
1068: 18 => 'Graduate Level');
1069: return &mt($gradelevels{$gradelevel});
1070: }
1071:
1072: sub select_level_form {
1073: my ($deflevel,$name)=@_;
1074: unless ($deflevel) { $deflevel=0; }
1075: my $selectform = "<select name=\"$name\" size=\"1\">\n";
1076: for (my $i=0; $i<=18; $i++) {
1077: $selectform.="<option value=\"$i\" ".
1078: ($i==$deflevel ? 'selected' : '').
1079: ">".&gradeleveldescription($i)."</option>\n";
1080: }
1081: $selectform.="</select>";
1082: return $selectform;
1083: }
1084:
1085: #-------------------------------------------
1086:
1087: =pod
1088:
1089: =item * select_dom_form($defdom,$name,$includeempty)
1090:
1091: Returns a string containing a <select name='$name' size='1'> form to
1092: allow a user to select the domain to preform an operation in.
1093: See loncreateuser.pm for an example invocation and use.
1094:
1095: If the $includeempty flag is set, it also includes an empty choice ("no domain
1096: selected");
1097:
1098: =cut
1099:
1100: #-------------------------------------------
1101: sub select_dom_form {
1102: my ($defdom,$name,$includeempty) = @_;
1103: my @domains = get_domains();
1104: if ($includeempty) { @domains=('',@domains); }
1105: my $selectdomain = "<select name=\"$name\" size=\"1\">\n";
1106: foreach (@domains) {
1107: $selectdomain.="<option value=\"$_\" ".
1108: ($_ eq $defdom ? 'selected' : '').
1109: ">$_</option>\n";
1110: }
1111: $selectdomain.="</select>";
1112: return $selectdomain;
1113: }
1114:
1115: #-------------------------------------------
1116:
1117: =pod
1118:
1119: =item * get_library_servers($domain)
1120:
1121: Returns a hash which contains keys like '103l3' and values like
1122: 'kirk.lite.msu.edu'. All of the keys will be for machines in the
1123: given $domain.
1124:
1125: =cut
1126:
1127: #-------------------------------------------
1128: sub get_library_servers {
1129: my $domain = shift;
1130: my %library_servers;
1131: foreach (keys(%Apache::lonnet::libserv)) {
1132: if ($Apache::lonnet::hostdom{$_} eq $domain) {
1133: $library_servers{$_} = $Apache::lonnet::hostname{$_};
1134: }
1135: }
1136: return %library_servers;
1137: }
1138:
1139: #-------------------------------------------
1140:
1141: =pod
1142:
1143: =item * home_server_option_list($domain)
1144:
1145: returns a string which contains an <option> list to be used in a
1146: <select> form input. See loncreateuser.pm for an example.
1147:
1148: =cut
1149:
1150: #-------------------------------------------
1151: sub home_server_option_list {
1152: my $domain = shift;
1153: my %servers = &get_library_servers($domain);
1154: my $result = '';
1155: foreach (sort keys(%servers)) {
1156: $result.=
1157: '<option value="'.$_.'">'.$_.' '.$servers{$_}."</option>\n";
1158: }
1159: return $result;
1160: }
1161:
1162: =pod
1163:
1164: =back
1165:
1166: =cut
1167:
1168: ###############################################################
1169: ## Decoding User Agent ##
1170: ###############################################################
1171:
1172: =pod
1173:
1174: =head1 Decoding the User Agent
1175:
1176: =over 4
1177:
1178: =item * &decode_user_agent()
1179:
1180: Inputs: $r
1181:
1182: Outputs:
1183:
1184: =over 4
1185:
1186: =item * $httpbrowser
1187:
1188: =item * $clientbrowser
1189:
1190: =item * $clientversion
1191:
1192: =item * $clientmathml
1193:
1194: =item * $clientunicode
1195:
1196: =item * $clientos
1197:
1198: =back
1199:
1200: =back
1201:
1202: =cut
1203:
1204: ###############################################################
1205: ###############################################################
1206: sub decode_user_agent {
1207: my @browsertype=split(/\&/,$Apache::lonnet::perlvar{"lonBrowsDet"});
1208: my %mathcap=split(/\&/,$$Apache::lonnet::perlvar{"lonMathML"});
1209: my $httpbrowser=$ENV{"HTTP_USER_AGENT"};
1210: my $clientbrowser='unknown';
1211: my $clientversion='0';
1212: my $clientmathml='';
1213: my $clientunicode='0';
1214: for (my $i=0;$i<=$#browsertype;$i++) {
1215: my ($bname,$match,$notmatch,$vreg,$minv,$univ)=split(/\:/,$browsertype[$i]);
1216: if (($httpbrowser=~/$match/i) && ($httpbrowser!~/$notmatch/i)) {
1217: $clientbrowser=$bname;
1218: $httpbrowser=~/$vreg/i;
1219: $clientversion=$1;
1220: $clientmathml=($clientversion>=$minv);
1221: $clientunicode=($clientversion>=$univ);
1222: }
1223: }
1224: my $clientos='unknown';
1225: if (($httpbrowser=~/linux/i) ||
1226: ($httpbrowser=~/unix/i) ||
1227: ($httpbrowser=~/ux/i) ||
1228: ($httpbrowser=~/solaris/i)) { $clientos='unix'; }
1229: if (($httpbrowser=~/vax/i) ||
1230: ($httpbrowser=~/vms/i)) { $clientos='vms'; }
1231: if ($httpbrowser=~/next/i) { $clientos='next'; }
1232: if (($httpbrowser=~/mac/i) ||
1233: ($httpbrowser=~/powerpc/i)) { $clientos='mac'; }
1234: if ($httpbrowser=~/win/i) { $clientos='win'; }
1235: if ($httpbrowser=~/embed/i) { $clientos='pda'; }
1236: return ($httpbrowser,$clientbrowser,$clientversion,$clientmathml,
1237: $clientunicode,$clientos,);
1238: }
1239:
1240: ###############################################################
1241: ## Authentication changing form generation subroutines ##
1242: ###############################################################
1243: ##
1244: ## All of the authform_xxxxxxx subroutines take their inputs in a
1245: ## hash, and have reasonable default values.
1246: ##
1247: ## formname = the name given in the <form> tag.
1248: #-------------------------------------------
1249:
1250: =pod
1251:
1252: =head1 Authentication Routines
1253:
1254: =over 4
1255:
1256: =item * authform_xxxxxx
1257:
1258: The authform_xxxxxx subroutines provide javascript and html forms which
1259: handle some of the conveniences required for authentication forms.
1260: This is not an optimal method, but it works.
1261:
1262: See loncreateuser.pm for invocation and use examples.
1263:
1264: =over 4
1265:
1266: =item * authform_header
1267:
1268: =item * authform_authorwarning
1269:
1270: =item * authform_nochange
1271:
1272: =item * authform_kerberos
1273:
1274: =item * authform_internal
1275:
1276: =item * authform_filesystem
1277:
1278: =back
1279:
1280: =back
1281:
1282: =cut
1283:
1284: #-------------------------------------------
1285: sub authform_header{
1286: my %in = (
1287: formname => 'cu',
1288: kerb_def_dom => '',
1289: @_,
1290: );
1291: $in{'formname'} = 'document.' . $in{'formname'};
1292: my $result='';
1293:
1294: #---------------------------------------------- Code for upper case translation
1295: my $Javascript_toUpperCase;
1296: unless ($in{kerb_def_dom}) {
1297: $Javascript_toUpperCase =<<"END";
1298: switch (choice) {
1299: case 'krb': currentform.elements[choicearg].value =
1300: currentform.elements[choicearg].value.toUpperCase();
1301: break;
1302: default:
1303: }
1304: END
1305: } else {
1306: $Javascript_toUpperCase = "";
1307: }
1308:
1309: my $radioval = "'nochange'";
1310: if (exists($in{'curr_authtype'}) &&
1311: defined($in{'curr_authtype'}) &&
1312: $in{'curr_authtype'} ne '') {
1313: $radioval = "'$in{'curr_authtype'}arg'";
1314: }
1315: my $argfield = 'null';
1316: if ( grep/^mode$/,(keys %in) ) {
1317: if ($in{'mode'} eq 'modifycourse') {
1318: if ( grep/^curr_authtype$/,(keys %in) ) {
1319: $radioval = "'$in{'curr_authtype'}'";
1320: }
1321: if ( grep/^curr_autharg$/,(keys %in) ) {
1322: unless ($in{'curr_autharg'} eq '') {
1323: $argfield = "'$in{'curr_autharg'}'";
1324: }
1325: }
1326: }
1327: }
1328:
1329: $result.=<<"END";
1330: var current = new Object();
1331: current.radiovalue = $radioval;
1332: current.argfield = $argfield;
1333:
1334: function changed_radio(choice,currentform) {
1335: var choicearg = choice + 'arg';
1336: // If a radio button in changed, we need to change the argfield
1337: if (current.radiovalue != choice) {
1338: current.radiovalue = choice;
1339: if (current.argfield != null) {
1340: currentform.elements[current.argfield].value = '';
1341: }
1342: if (choice == 'nochange') {
1343: current.argfield = null;
1344: } else {
1345: current.argfield = choicearg;
1346: switch(choice) {
1347: case 'krb':
1348: currentform.elements[current.argfield].value =
1349: "$in{'kerb_def_dom'}";
1350: break;
1351: default:
1352: break;
1353: }
1354: }
1355: }
1356: return;
1357: }
1358:
1359: function changed_text(choice,currentform) {
1360: var choicearg = choice + 'arg';
1361: if (currentform.elements[choicearg].value !='') {
1362: $Javascript_toUpperCase
1363: // clear old field
1364: if ((current.argfield != choicearg) && (current.argfield != null)) {
1365: currentform.elements[current.argfield].value = '';
1366: }
1367: current.argfield = choicearg;
1368: }
1369: set_auth_radio_buttons(choice,currentform);
1370: return;
1371: }
1372:
1373: function set_auth_radio_buttons(newvalue,currentform) {
1374: var i=0;
1375: while (i < currentform.login.length) {
1376: if (currentform.login[i].value == newvalue) { break; }
1377: i++;
1378: }
1379: if (i == currentform.login.length) {
1380: return;
1381: }
1382: current.radiovalue = newvalue;
1383: currentform.login[i].checked = true;
1384: return;
1385: }
1386: END
1387: return $result;
1388: }
1389:
1390: sub authform_authorwarning{
1391: my $result='';
1392: $result='<i>'.
1393: &mt('As a general rule, only authors or co-authors should be '.
1394: 'filesystem authenticated '.
1395: '(which allows access to the server filesystem).')."</i>\n";
1396: return $result;
1397: }
1398:
1399: sub authform_nochange{
1400: my %in = (
1401: formname => 'document.cu',
1402: kerb_def_dom => 'MSU.EDU',
1403: @_,
1404: );
1405: my $result = &mt('[_1] Do not change login data',
1406: '<input type="radio" name="login" value="nochange" '.
1407: 'checked="checked" onclick="'.
1408: "javascript:changed_radio('nochange',$in{'formname'});".'" />');
1409: return $result;
1410: }
1411:
1412: sub authform_kerberos{
1413: my %in = (
1414: formname => 'document.cu',
1415: kerb_def_dom => 'MSU.EDU',
1416: kerb_def_auth => 'krb4',
1417: @_,
1418: );
1419: my ($check4,$check5,$krbarg);
1420: if ($in{'kerb_def_auth'} eq 'krb5') {
1421: $check5 = " checked=\"on\"";
1422: } else {
1423: $check4 = " checked=\"on\"";
1424: }
1425: $krbarg = $in{'kerb_def_dom'};
1426:
1427: my $krbcheck = "";
1428: if ( grep/^curr_authtype$/,(keys %in) ) {
1429: if ($in{'curr_authtype'} =~ m/^krb/) {
1430: $krbcheck = " checked=\"on\"";
1431: if ( grep/^curr_autharg$/,(keys %in) ) {
1432: $krbarg = $in{'curr_autharg'};
1433: }
1434: }
1435: }
1436:
1437: my $jscall = "javascript:changed_radio('krb',$in{'formname'});";
1438: my $result .= &mt
1439: ('[_1] Kerberos authenticated with domain [_2] '.
1440: '[_3] Version 4 [_4] Version 5',
1441: '<input type="radio" name="login" value="krb" '.
1442: 'onclick="'.$jscall.'" onchange="'.$jscall.'"'.$krbcheck.' />',
1443: '<input type="text" size="10" name="krbarg" '.
1444: 'value="'.$krbarg.'" '.
1445: 'onchange="'.$jscall.'" />',
1446: '<input type="radio" name="krbver" value="4" '.$check4.' />',
1447: '<input type="radio" name="krbver" value="5" '.$check5.' />');
1448: return $result;
1449: }
1450:
1451: sub authform_internal{
1452: my %args = (
1453: formname => 'document.cu',
1454: kerb_def_dom => 'MSU.EDU',
1455: @_,
1456: );
1457:
1458: my $intcheck = "";
1459: my $intarg = 'value=""';
1460: if ( grep/^curr_authtype$/,(keys %args) ) {
1461: if ($args{'curr_authtype'} eq 'int') {
1462: $intcheck = " checked=\"on\"";
1463: if ( grep/^curr_autharg$/,(keys %args) ) {
1464: $intarg = "value=\"$args{'curr_autharg'}\"";
1465: }
1466: }
1467: }
1468:
1469: my $jscall = "javascript:changed_radio('int',$args{'formname'});";
1470: my $result.=&mt
1471: ('[_1] Internally authenticated (with initial password [_2])',
1472: '<input type="radio" name="login" value="int" '.$intcheck.
1473: ' onchange="'.$jscall.'" onclick="'.$jscall.'" />',
1474: '<input type="text" size="10" name="intarg" '.$intarg.
1475: ' onchange="'.$jscall.'" />');
1476: return $result;
1477: }
1478:
1479: sub authform_local{
1480: my %in = (
1481: formname => 'document.cu',
1482: kerb_def_dom => 'MSU.EDU',
1483: @_,
1484: );
1485:
1486: my $loccheck = "";
1487: my $locarg = 'value=""';
1488: if ( grep/^curr_authtype$/,(keys %in) ) {
1489: if ($in{'curr_authtype'} eq 'loc') {
1490: $loccheck = " checked=\"on\"";
1491: if ( grep/^curr_autharg$/,(keys %in) ) {
1492: $locarg = "value=\"$in{'curr_autharg'}\"";
1493: }
1494: }
1495: }
1496:
1497: my $jscall = "javascript:changed_radio('loc',$in{'formname'});";
1498: my $result.=&mt('[_1] Local Authentication with argument [_2]',
1499: '<input type="radio" name="login" value="loc" '.$loccheck.
1500: ' onchange="'.$jscall.'" onclick="'.$jscall.'" />',
1501: '<input type="text" size="10" name="locarg" '.$locarg.
1502: ' onchange="'.$jscall.'" />');
1503: return $result;
1504: }
1505:
1506: sub authform_filesystem{
1507: my %in = (
1508: formname => 'document.cu',
1509: kerb_def_dom => 'MSU.EDU',
1510: @_,
1511: );
1512: my $jscall = "javascript:changed_radio('fsys',$in{'formname'});";
1513: my $result.= &mt
1514: ('[_1] Filesystem Authenticated (with initial password [_2])',
1515: '<input type="radio" name="login" value="fsys" '.
1516: 'onchange="'.$jscall.'" onclick="'.$jscall.'" />',
1517: '<input type="text" size="10" name="fsysarg" value="" '.
1518: 'onchange="'.$jscall.'" />');
1519: return $result;
1520: }
1521:
1522: ###############################################################
1523: ## Get Authentication Defaults for Domain ##
1524: ###############################################################
1525:
1526: =pod
1527:
1528: =head1 Domains and Authentication
1529:
1530: Returns default authentication type and an associated argument as
1531: listed in file 'domain.tab'.
1532:
1533: =over 4
1534:
1535: =item * get_auth_defaults
1536:
1537: get_auth_defaults($target_domain) returns the default authentication
1538: type and an associated argument (initial password or a kerberos domain).
1539: These values are stored in lonTabs/domain.tab
1540:
1541: ($def_auth, $def_arg) = &get_auth_defaults($target_domain);
1542:
1543: If target_domain is not found in domain.tab, returns nothing ('').
1544:
1545: =cut
1546:
1547: #-------------------------------------------
1548: sub get_auth_defaults {
1549: my $domain=shift;
1550: return ($Apache::lonnet::domain_auth_def{$domain},$Apache::lonnet::domain_auth_arg_def{$domain});
1551: }
1552: ###############################################################
1553: ## End Get Authentication Defaults for Domain ##
1554: ###############################################################
1555:
1556: ###############################################################
1557: ## Get Kerberos Defaults for Domain ##
1558: ###############################################################
1559: ##
1560: ## Returns default kerberos version and an associated argument
1561: ## as listed in file domain.tab. If not listed, provides
1562: ## appropriate default domain and kerberos version.
1563: ##
1564: #-------------------------------------------
1565:
1566: =pod
1567:
1568: =item * get_kerberos_defaults
1569:
1570: get_kerberos_defaults($target_domain) returns the default kerberos
1571: version and domain. If not found in domain.tabs, it defaults to
1572: version 4 and the domain of the server.
1573:
1574: ($def_version, $def_krb_domain) = &get_kerberos_defaults($target_domain);
1575:
1576: =cut
1577:
1578: #-------------------------------------------
1579: sub get_kerberos_defaults {
1580: my $domain=shift;
1581: my ($krbdef,$krbdefdom) =
1582: &Apache::loncommon::get_auth_defaults($domain);
1583: unless ($krbdef =~/^krb/ && $krbdefdom) {
1584: $ENV{'SERVER_NAME'}=~/(\w+\.\w+)$/;
1585: my $krbdefdom=$1;
1586: $krbdefdom=~tr/a-z/A-Z/;
1587: $krbdef = "krb4";
1588: }
1589: return ($krbdef,$krbdefdom);
1590: }
1591:
1592: =pod
1593:
1594: =back
1595:
1596: =cut
1597:
1598: ###############################################################
1599: ## Thesaurus Functions ##
1600: ###############################################################
1601:
1602: =pod
1603:
1604: =head1 Thesaurus Functions
1605:
1606: =over 4
1607:
1608: =item * initialize_keywords
1609:
1610: Initializes the package variable %Keywords if it is empty. Uses the
1611: package variable $thesaurus_db_file.
1612:
1613: =cut
1614:
1615: ###################################################
1616:
1617: sub initialize_keywords {
1618: return 1 if (scalar keys(%Keywords));
1619: # If we are here, %Keywords is empty, so fill it up
1620: # Make sure the file we need exists...
1621: if (! -e $thesaurus_db_file) {
1622: &Apache::lonnet::logthis("Attempt to access $thesaurus_db_file".
1623: " failed because it does not exist");
1624: return 0;
1625: }
1626: # Set up the hash as a database
1627: my %thesaurus_db;
1628: if (! tie(%thesaurus_db,'GDBM_File',
1629: $thesaurus_db_file,&GDBM_READER(),0640)){
1630: &Apache::lonnet::logthis("Could not tie \%thesaurus_db to ".
1631: $thesaurus_db_file);
1632: return 0;
1633: }
1634: # Get the average number of appearances of a word.
1635: my $avecount = $thesaurus_db{'average.count'};
1636: # Put keywords (those that appear > average) into %Keywords
1637: while (my ($word,$data)=each (%thesaurus_db)) {
1638: my ($count,undef) = split /:/,$data;
1639: $Keywords{$word}++ if ($count > $avecount);
1640: }
1641: untie %thesaurus_db;
1642: # Remove special values from %Keywords.
1643: foreach ('total.count','average.count') {
1644: delete($Keywords{$_}) if (exists($Keywords{$_}));
1645: }
1646: return 1;
1647: }
1648:
1649: ###################################################
1650:
1651: =pod
1652:
1653: =item * keyword($word)
1654:
1655: Returns true if $word is a keyword. A keyword is a word that appears more
1656: than the average number of times in the thesaurus database. Calls
1657: &initialize_keywords
1658:
1659: =cut
1660:
1661: ###################################################
1662:
1663: sub keyword {
1664: return if (!&initialize_keywords());
1665: my $word=lc(shift());
1666: $word=~s/\W//g;
1667: return exists($Keywords{$word});
1668: }
1669:
1670: ###############################################################
1671:
1672: =pod
1673:
1674: =item * get_related_words
1675:
1676: Look up a word in the thesaurus. Takes a scalar argument and returns
1677: an array of words. If the keyword is not in the thesaurus, an empty array
1678: will be returned. The order of the words returned is determined by the
1679: database which holds them.
1680:
1681: Uses global $thesaurus_db_file.
1682:
1683: =cut
1684:
1685: ###############################################################
1686: sub get_related_words {
1687: my $keyword = shift;
1688: my %thesaurus_db;
1689: if (! -e $thesaurus_db_file) {
1690: &Apache::lonnet::logthis("Attempt to access $thesaurus_db_file ".
1691: "failed because the file does not exist");
1692: return ();
1693: }
1694: if (! tie(%thesaurus_db,'GDBM_File',
1695: $thesaurus_db_file,&GDBM_READER(),0640)){
1696: return ();
1697: }
1698: my @Words=();
1699: if (exists($thesaurus_db{$keyword})) {
1700: $_ = $thesaurus_db{$keyword};
1701: (undef,@Words) = split/:/; # The first element is the number of times
1702: # the word appears. We do not need it now.
1703: for (my $i=0;$i<=$#Words;$i++) {
1704: ($Words[$i],undef)= split/\,/,$Words[$i];
1705: }
1706: }
1707: untie %thesaurus_db;
1708: return @Words;
1709: }
1710:
1711: =pod
1712:
1713: =back
1714:
1715: =cut
1716:
1717: # -------------------------------------------------------------- Plaintext name
1718: =pod
1719:
1720: =head1 User Name Functions
1721:
1722: =over 4
1723:
1724: =item * plainname($uname,$udom)
1725:
1726: Takes a users logon name and returns it as a string in
1727: "first middle last generation" form
1728:
1729: =cut
1730:
1731: ###############################################################
1732: sub plainname {
1733: my ($uname,$udom)=@_;
1734: my %names=&Apache::lonnet::get('environment',
1735: ['firstname','middlename','lastname','generation'],
1736: $udom,$uname);
1737: my $name=$names{'firstname'}.' '.$names{'middlename'}.' '.
1738: $names{'lastname'}.' '.$names{'generation'};
1739: $name=~s/\s+$//;
1740: $name=~s/\s+/ /g;
1741: if ($name !~ /\S/) { $name=$uname.'@'.$udom; }
1742: return $name;
1743: }
1744:
1745: # -------------------------------------------------------------------- Nickname
1746: =pod
1747:
1748: =item * nickname($uname,$udom)
1749:
1750: Gets a users name and returns it as a string as
1751:
1752: ""nickname""
1753:
1754: if the user has a nickname or
1755:
1756: "first middle last generation"
1757:
1758: if the user does not
1759:
1760: =cut
1761:
1762: sub nickname {
1763: my ($uname,$udom)=@_;
1764: my %names=&Apache::lonnet::get('environment',
1765: ['nickname','firstname','middlename','lastname','generation'],$udom,$uname);
1766: my $name=$names{'nickname'};
1767: if ($name) {
1768: $name='"'.$name.'"';
1769: } else {
1770: $name=$names{'firstname'}.' '.$names{'middlename'}.' '.
1771: $names{'lastname'}.' '.$names{'generation'};
1772: $name=~s/\s+$//;
1773: $name=~s/\s+/ /g;
1774: }
1775: return $name;
1776: }
1777:
1778:
1779: # ------------------------------------------------------------------ Screenname
1780:
1781: =pod
1782:
1783: =item * screenname($uname,$udom)
1784:
1785: Gets a users screenname and returns it as a string
1786:
1787: =cut
1788:
1789: sub screenname {
1790: my ($uname,$udom)=@_;
1791: my %names=
1792: &Apache::lonnet::get('environment',['screenname'],$udom,$uname);
1793: return $names{'screenname'};
1794: }
1795:
1796: # ------------------------------------------------------------- Message Wrapper
1797:
1798: sub messagewrapper {
1799: my ($link,$un,$do)=@_;
1800: return
1801: "<a href='/adm/email?compose=individual&recname=$un&recdom=$do'>$link</a>";
1802: }
1803: # --------------------------------------------------------------- Notes Wrapper
1804:
1805: sub noteswrapper {
1806: my ($link,$un,$do)=@_;
1807: return
1808: "<a href='/adm/email?recordftf=retrieve&recname=$un&recdom=$do'>$link</a>";
1809: }
1810: # ------------------------------------------------------------- Aboutme Wrapper
1811:
1812: sub aboutmewrapper {
1813: my ($link,$username,$domain,$target)=@_;
1814: return "<a href='/adm/$domain/$username/aboutme'".
1815: ($target?" target='$target'":'').">$link</a>";
1816: }
1817:
1818: # ------------------------------------------------------------ Syllabus Wrapper
1819:
1820:
1821: sub syllabuswrapper {
1822: my ($linktext,$coursedir,$domain,$fontcolor)=@_;
1823: if ($fontcolor) {
1824: $linktext='<font color="'.$fontcolor.'">'.$linktext.'</font>';
1825: }
1826: return "<a href='/public/$domain/$coursedir/syllabus'>$linktext</a>";
1827: }
1828:
1829: =pod
1830:
1831: =back
1832:
1833: =head1 Access .tab File Data
1834:
1835: =over 4
1836:
1837: =item * languageids()
1838:
1839: returns list of all language ids
1840:
1841: =cut
1842:
1843: sub languageids {
1844: return sort(keys(%language));
1845: }
1846:
1847: =pod
1848:
1849: =item * languagedescription()
1850:
1851: returns description of a specified language id
1852:
1853: =cut
1854:
1855: sub languagedescription {
1856: my $code=shift;
1857: return ($supported_language{$code}?'* ':'').
1858: $language{$code}.
1859: ($supported_language{$code}?' ('.&mt('interface available').')':'');
1860: }
1861:
1862: sub plainlanguagedescription {
1863: my $code=shift;
1864: return $language{$code};
1865: }
1866:
1867: sub supportedlanguagecode {
1868: my $code=shift;
1869: return $supported_language{$code};
1870: }
1871:
1872: =pod
1873:
1874: =item * copyrightids()
1875:
1876: returns list of all copyrights
1877:
1878: =cut
1879:
1880: sub copyrightids {
1881: return sort(keys(%cprtag));
1882: }
1883:
1884: =pod
1885:
1886: =item * copyrightdescription()
1887:
1888: returns description of a specified copyright id
1889:
1890: =cut
1891:
1892: sub copyrightdescription {
1893: return &mt($cprtag{shift(@_)});
1894: }
1895: =item * source_copyrightids()
1896:
1897: returns list of all source copyrights
1898:
1899: =cut
1900:
1901: sub source_copyrightids {
1902: return sort(keys(%scprtag));
1903: }
1904:
1905: =pod
1906:
1907: =item * source_copyrightdescription()
1908:
1909: returns description of a specified source copyright id
1910:
1911: =cut
1912:
1913: sub source_copyrightdescription {
1914: return &mt($scprtag{shift(@_)});
1915: }
1916:
1917: =pod
1918:
1919: =item * filecategories()
1920:
1921: returns list of all file categories
1922:
1923: =cut
1924:
1925: sub filecategories {
1926: return sort(keys(%category_extensions));
1927: }
1928:
1929: =pod
1930:
1931: =item * filecategorytypes()
1932:
1933: returns list of file types belonging to a given file
1934: category
1935:
1936: =cut
1937:
1938: sub filecategorytypes {
1939: return @{$category_extensions{lc($_[0])}};
1940: }
1941:
1942: =pod
1943:
1944: =item * fileembstyle()
1945:
1946: returns embedding style for a specified file type
1947:
1948: =cut
1949:
1950: sub fileembstyle {
1951: return $fe{lc(shift(@_))};
1952: }
1953:
1954:
1955: sub filecategoryselect {
1956: my ($name,$value)=@_;
1957: return &select_form($value,$name,
1958: '' => &mt('Any category'),
1959: map { $_,$_ } sort(keys(%category_extensions)));
1960: }
1961:
1962: =pod
1963:
1964: =item * filedescription()
1965:
1966: returns description for a specified file type
1967:
1968: =cut
1969:
1970: sub filedescription {
1971: my $file_description = $fd{lc(shift())};
1972: $file_description =~ s:([\[\]]):~$1:g;
1973: return &mt($file_description);
1974: }
1975:
1976: =pod
1977:
1978: =item * filedescriptionex()
1979:
1980: returns description for a specified file type with
1981: extra formatting
1982:
1983: =cut
1984:
1985: sub filedescriptionex {
1986: my $ex=shift;
1987: my $file_description = $fd{lc($ex)};
1988: $file_description =~ s:([\[\]]):~$1:g;
1989: return '.'.$ex.' '.&mt($file_description);
1990: }
1991:
1992: # End of .tab access
1993: =pod
1994:
1995: =back
1996:
1997: =cut
1998:
1999: # ------------------------------------------------------------------ File Types
2000: sub fileextensions {
2001: return sort(keys(%fe));
2002: }
2003:
2004: # ----------------------------------------------------------- Display Languages
2005: # returns a hash with all desired display languages
2006: #
2007:
2008: sub display_languages {
2009: my %languages=();
2010: foreach (&preferred_languages()) {
2011: $languages{$_}=1;
2012: }
2013: &get_unprocessed_cgi($ENV{'QUERY_STRING'},['displaylanguage']);
2014: if ($ENV{'form.displaylanguage'}) {
2015: foreach (split(/\s*(\,|\;|\:)\s*/,$ENV{'form.displaylanguage'})) {
2016: $languages{$_}=1;
2017: }
2018: }
2019: return %languages;
2020: }
2021:
2022: sub preferred_languages {
2023: my @languages=();
2024: if ($ENV{'course.'.$ENV{'request.course.id'}.'.languages'}) {
2025: @languages=(@languages,split(/\s*(\,|\;|\:)\s*/,
2026: $ENV{'course.'.$ENV{'request.course.id'}.'.languages'}));
2027: }
2028: if ($ENV{'environment.languages'}) {
2029: @languages=split(/\s*(\,|\;|\:)\s*/,$ENV{'environment.languages'});
2030: }
2031: my $browser=(split(/\;/,$ENV{'HTTP_ACCEPT_LANGUAGE'}))[0];
2032: if ($browser) {
2033: @languages=(@languages,split(/\s*(\,|\;|\:)\s*/,$browser));
2034: }
2035: if ($Apache::lonnet::domain_lang_def{$ENV{'user.domain'}}) {
2036: @languages=(@languages,
2037: $Apache::lonnet::domain_lang_def{$ENV{'user.domain'}});
2038: }
2039: if ($Apache::lonnet::domain_lang_def{$ENV{'request.role.domain'}}) {
2040: @languages=(@languages,
2041: $Apache::lonnet::domain_lang_def{$ENV{'request.role.domain'}});
2042: }
2043: if ($Apache::lonnet::domain_lang_def{
2044: $Apache::lonnet::perlvar{'lonDefDomain'}}) {
2045: @languages=(@languages,
2046: $Apache::lonnet::domain_lang_def{
2047: $Apache::lonnet::perlvar{'lonDefDomain'}});
2048: }
2049: # turn "en-ca" into "en-ca,en"
2050: my @genlanguages;
2051: foreach (@languages) {
2052: unless ($_=~/\w/) { next; }
2053: push (@genlanguages,$_);
2054: if ($_=~/(\-|\_)/) {
2055: push (@genlanguages,(split(/(\-|\_)/,$_))[0]);
2056: }
2057: }
2058: return @genlanguages;
2059: }
2060:
2061: ###############################################################
2062: ## Student Answer Attempts ##
2063: ###############################################################
2064:
2065: =pod
2066:
2067: =head1 Alternate Problem Views
2068:
2069: =over 4
2070:
2071: =item * get_previous_attempt($symb, $username, $domain, $course,
2072: $getattempt, $regexp, $gradesub)
2073:
2074: Return string with previous attempt on problem. Arguments:
2075:
2076: =over 4
2077:
2078: =item * $symb: Problem, including path
2079:
2080: =item * $username: username of the desired student
2081:
2082: =item * $domain: domain of the desired student
2083:
2084: =item * $course: Course ID
2085:
2086: =item * $getattempt: Leave blank for all attempts, otherwise put
2087: something
2088:
2089: =item * $regexp: if string matches this regexp, the string will be
2090: sent to $gradesub
2091:
2092: =item * $gradesub: routine that processes the string if it matches $regexp
2093:
2094: =back
2095:
2096: The output string is a table containing all desired attempts, if any.
2097:
2098: =cut
2099:
2100: sub get_previous_attempt {
2101: my ($symb,$username,$domain,$course,$getattempt,$regexp,$gradesub)=@_;
2102: my $prevattempts='';
2103: no strict 'refs';
2104: if ($symb) {
2105: my (%returnhash)=
2106: &Apache::lonnet::restore($symb,$course,$domain,$username);
2107: if ($returnhash{'version'}) {
2108: my %lasthash=();
2109: my $version;
2110: for ($version=1;$version<=$returnhash{'version'};$version++) {
2111: foreach (sort(split(/\:/,$returnhash{$version.':keys'}))) {
2112: $lasthash{$_}=$returnhash{$version.':'.$_};
2113: }
2114: }
2115: $prevattempts='<table border="0" width="100%"><tr><td bgcolor="#777777">';
2116: $prevattempts.='<table border="0" width="100%"><tr bgcolor="#e6ffff"><td>History</td>';
2117: foreach (sort(keys %lasthash)) {
2118: my ($ign,@parts) = split(/\./,$_);
2119: if ($#parts > 0) {
2120: my $data=$parts[-1];
2121: pop(@parts);
2122: $prevattempts.='<td>Part '.join('.',@parts).'<br />'.$data.' </td>';
2123: } else {
2124: if ($#parts == 0) {
2125: $prevattempts.='<th>'.$parts[0].'</th>';
2126: } else {
2127: $prevattempts.='<th>'.$ign.'</th>';
2128: }
2129: }
2130: }
2131: if ($getattempt eq '') {
2132: for ($version=1;$version<=$returnhash{'version'};$version++) {
2133: $prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Transaction '.$version.'</td>';
2134: foreach (sort(keys %lasthash)) {
2135: my $value;
2136: if ($_ =~ /timestamp/) {
2137: $value=scalar(localtime($returnhash{$version.':'.$_}));
2138: } else {
2139: $value=$returnhash{$version.':'.$_};
2140: }
2141: $prevattempts.='<td>'.&Apache::lonnet::unescape($value).' </td>';
2142: }
2143: }
2144: }
2145: $prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Current</td>';
2146: foreach (sort(keys %lasthash)) {
2147: my $value;
2148: if ($_ =~ /timestamp/) {
2149: $value=scalar(localtime($lasthash{$_}));
2150: } else {
2151: $value=$lasthash{$_};
2152: }
2153: $value=&Apache::lonnet::unescape($value);
2154: if ($_ =~/$regexp$/ && (defined &$gradesub)) {$value = &$gradesub($value)}
2155: $prevattempts.='<td>'.$value.' </td>';
2156: }
2157: $prevattempts.='</tr></table></td></tr></table>';
2158: } else {
2159: $prevattempts='Nothing submitted - no attempts.';
2160: }
2161: } else {
2162: $prevattempts='No data.';
2163: }
2164: }
2165:
2166: sub relative_to_absolute {
2167: my ($url,$output)=@_;
2168: my $parser=HTML::TokeParser->new(\$output);
2169: my $token;
2170: my $thisdir=$url;
2171: my @rlinks=();
2172: while ($token=$parser->get_token) {
2173: if ($token->[0] eq 'S') {
2174: if ($token->[1] eq 'a') {
2175: if ($token->[2]->{'href'}) {
2176: $rlinks[$#rlinks+1]=$token->[2]->{'href'};
2177: }
2178: } elsif ($token->[1] eq 'img' || $token->[1] eq 'embed' ) {
2179: $rlinks[$#rlinks+1]=$token->[2]->{'src'};
2180: } elsif ($token->[1] eq 'base') {
2181: $thisdir=$token->[2]->{'href'};
2182: }
2183: }
2184: }
2185: $thisdir=~s-/[^/]*$--;
2186: foreach (@rlinks) {
2187: unless (($_=~/^http:\/\//i) ||
2188: ($_=~/^\//) ||
2189: ($_=~/^javascript:/i) ||
2190: ($_=~/^mailto:/i) ||
2191: ($_=~/^\#/)) {
2192: my $newlocation=&Apache::lonnet::hreflocation($thisdir,$_);
2193: $output=~s/(\"|\'|\=\s*)$_(\"|\'|\s|\>)/$1$newlocation$2/;
2194: }
2195: }
2196: # -------------------------------------------------- Deal with Applet codebases
2197: $output=~s/(\<applet[^\>]+)(codebase\=[^\S\>]+)*([^\>]*)\>/$1.($2?$2:' codebase="'.$thisdir.'"').$3.'>'/gei;
2198: return $output;
2199: }
2200:
2201: =pod
2202:
2203: =item * get_student_view
2204:
2205: show a snapshot of what student was looking at
2206:
2207: =cut
2208:
2209: sub get_student_view {
2210: my ($symb,$username,$domain,$courseid,$target,$moreenv) = @_;
2211: my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb);
2212: my (%form);
2213: my @elements=('symb','courseid','domain','username');
2214: foreach my $element (@elements) {
2215: $form{'grade_'.$element}=eval '$'.$element #'
2216: }
2217: if (defined($moreenv)) {
2218: %form=(%form,%{$moreenv});
2219: }
2220: if ($target eq 'tex') {$form{'grade_target'} = 'tex';}
2221: $feedurl=&Apache::lonnet::clutter($feedurl);
2222: my $userview=&Apache::lonnet::ssi_body($feedurl,%form);
2223: $userview=~s/\<body[^\>]*\>//gi;
2224: $userview=~s/\<\/body\>//gi;
2225: $userview=~s/\<html\>//gi;
2226: $userview=~s/\<\/html\>//gi;
2227: $userview=~s/\<head\>//gi;
2228: $userview=~s/\<\/head\>//gi;
2229: $userview=~s/action\s*\=/would_be_action\=/gi;
2230: $userview=&relative_to_absolute($feedurl,$userview);
2231: return $userview;
2232: }
2233:
2234: =pod
2235:
2236: =item * get_student_answers()
2237:
2238: show a snapshot of how student was answering problem
2239:
2240: =cut
2241:
2242: sub get_student_answers {
2243: my ($symb,$username,$domain,$courseid,%form) = @_;
2244: my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb);
2245: my (%moreenv);
2246: my @elements=('symb','courseid','domain','username');
2247: foreach my $element (@elements) {
2248: $moreenv{'grade_'.$element}=eval '$'.$element #'
2249: }
2250: $moreenv{'grade_target'}='answer';
2251: %moreenv=(%form,%moreenv);
2252: my $userview=&Apache::lonnet::ssi('/res/'.$feedurl,%moreenv);
2253: return $userview;
2254: }
2255:
2256: =pod
2257:
2258: =item * &submlink()
2259:
2260: Inputs: $text $uname $udom $symb
2261:
2262: Returns: A link to grades.pm such as to see the SUBM view of a student
2263:
2264: =cut
2265:
2266: ###############################################
2267: sub submlink {
2268: my ($text,$uname,$udom,$symb)=@_;
2269: if (!($uname && $udom)) {
2270: (my $cursymb, my $courseid,$udom,$uname)=
2271: &Apache::lonxml::whichuser($symb);
2272: if (!$symb) { $symb=$cursymb; }
2273: }
2274: if (!$symb) { $symb=&symbread(); }
2275: return '<a href="/adm/grades?symb='.$symb.'&student='.$uname.
2276: '&userdom='.$udom.'&command=submission">'.$text.'</a>';
2277: }
2278: ##############################################
2279:
2280: =pod
2281:
2282: =back
2283:
2284: =cut
2285:
2286: ###############################################
2287:
2288:
2289: sub timehash {
2290: my @ltime=localtime(shift);
2291: return ( 'seconds' => $ltime[0],
2292: 'minutes' => $ltime[1],
2293: 'hours' => $ltime[2],
2294: 'day' => $ltime[3],
2295: 'month' => $ltime[4]+1,
2296: 'year' => $ltime[5]+1900,
2297: 'weekday' => $ltime[6],
2298: 'dayyear' => $ltime[7]+1,
2299: 'dlsav' => $ltime[8] );
2300: }
2301:
2302: sub maketime {
2303: my %th=@_;
2304: return POSIX::mktime(
2305: ($th{'seconds'},$th{'minutes'},$th{'hours'},
2306: $th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,$th{'dlsav'}));
2307: }
2308:
2309: #########################################
2310:
2311: sub findallcourses {
2312: my %courses=();
2313: my $now=time;
2314: foreach (keys %ENV) {
2315: if ($_=~/^user\.role\.\w+\.\/(\w+)\/(\w+)/) {
2316: my ($starttime,$endtime)=$ENV{$_};
2317: my $active=1;
2318: if ($starttime) {
2319: if ($now<$starttime) { $active=0; }
2320: }
2321: if ($endtime) {
2322: if ($now>$endtime) { $active=0; }
2323: }
2324: if ($active) { $courses{$1.'_'.$2}=1; }
2325: }
2326: }
2327: return keys %courses;
2328: }
2329:
2330: ###############################################
2331: ###############################################
2332:
2333: =pod
2334:
2335: =head1 Domain Template Functions
2336:
2337: =over 4
2338:
2339: =item * &determinedomain()
2340:
2341: Inputs: $domain (usually will be undef)
2342:
2343: Returns: Determines which domain should be used for designs
2344:
2345: =cut
2346:
2347: ###############################################
2348: sub determinedomain {
2349: my $domain=shift;
2350: if (! $domain) {
2351: # Determine domain if we have not been given one
2352: $domain = $Apache::lonnet::perlvar{'lonDefDomain'};
2353: if ($ENV{'user.domain'}) { $domain=$ENV{'user.domain'}; }
2354: if ($ENV{'request.role.domain'}) {
2355: $domain=$ENV{'request.role.domain'};
2356: }
2357: }
2358: return $domain;
2359: }
2360: ###############################################
2361: =pod
2362:
2363: =item * &domainlogo()
2364:
2365: Inputs: $domain (usually will be undef)
2366:
2367: Returns: A link to a domain logo, if the domain logo exists.
2368: If the domain logo does not exist, a description of the domain.
2369:
2370: =cut
2371:
2372: ###############################################
2373: sub domainlogo {
2374: my $domain = &determinedomain(shift);
2375: # See if there is a logo
2376: if (-e '/home/httpd/html/adm/lonDomLogos/'.$domain.'.gif') {
2377: my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'};
2378: if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; }
2379: return '<img src="http://'.$ENV{'HTTP_HOST'}.':'.$lonhttpdPort.
2380: '/adm/lonDomLogos/'.$domain.'.gif" alt="'.$domain.'" />';
2381: } elsif(exists($Apache::lonnet::domaindescription{$domain})) {
2382: return $Apache::lonnet::domaindescription{$domain};
2383: } else {
2384: return '';
2385: }
2386: }
2387: ##############################################
2388:
2389: =pod
2390:
2391: =item * &designparm()
2392:
2393: Inputs: $which parameter; $domain (usually will be undef)
2394:
2395: Returns: value of designparamter $which
2396:
2397: =cut
2398:
2399: ##############################################
2400: sub designparm {
2401: my ($which,$domain)=@_;
2402: if ($ENV{'browser.blackwhite'} eq 'on') {
2403: if ($which=~/\.(font|alink|vlink|link)$/) {
2404: return '#000000';
2405: }
2406: if ($which=~/\.(pgbg|sidebg)$/) {
2407: return '#FFFFFF';
2408: }
2409: if ($which=~/\.tabbg$/) {
2410: return '#CCCCCC';
2411: }
2412: }
2413: if ($ENV{'environment.color.'.$which}) {
2414: return $ENV{'environment.color.'.$which};
2415: }
2416: $domain=&determinedomain($domain);
2417: if ($designhash{$domain.'.'.$which}) {
2418: return $designhash{$domain.'.'.$which};
2419: } else {
2420: return $designhash{'default.'.$which};
2421: }
2422: }
2423:
2424: ###############################################
2425: ###############################################
2426:
2427: =pod
2428:
2429: =back
2430:
2431: =head1 HTTP Helpers
2432:
2433: =over 4
2434:
2435: =item * &bodytag()
2436:
2437: Returns a uniform header for LON-CAPA web pages.
2438:
2439: Inputs:
2440:
2441: =over 4
2442:
2443: =item * $title, A title to be displayed on the page.
2444:
2445: =item * $function, the current role (can be undef).
2446:
2447: =item * $addentries, extra parameters for the <body> tag.
2448:
2449: =item * $bodyonly, if defined, only return the <body> tag.
2450:
2451: =item * $domain, if defined, force a given domain.
2452:
2453: =item * $forcereg, if page should register as content page (relevant for
2454: text interface only)
2455:
2456: =back
2457:
2458: Returns: A uniform header for LON-CAPA web pages.
2459: If $bodyonly is nonzero, a string containing a <body> tag will be returned.
2460: If $bodyonly is undef or zero, an html string containing a <body> tag and
2461: other decorations will be returned.
2462:
2463: =cut
2464:
2465: sub bodytag {
2466: my ($title,$function,$addentries,$bodyonly,$domain,$forcereg)=@_;
2467: $title=&mt($title);
2468: $function = &get_users_function() if (!$function);
2469: my $img=&designparm($function.'.img',$domain);
2470: my $pgbg=&designparm($function.'.pgbg',$domain);
2471: my $tabbg=&designparm($function.'.tabbg',$domain);
2472: my $font=&designparm($function.'.font',$domain);
2473: my $link=&designparm($function.'.link',$domain);
2474: my $alink=&designparm($function.'.alink',$domain);
2475: my $vlink=&designparm($function.'.vlink',$domain);
2476: my $sidebg=&designparm($function.'.sidebg',$domain);
2477: # Accessibility font enhance
2478: unless ($addentries) { $addentries=''; }
2479: my $addstyle='';
2480: if ($ENV{'browser.fontenhance'} eq 'on') {
2481: $addstyle=' font-size: x-large;';
2482: }
2483: # role and realm
2484: my ($role,$realm)
2485: =&Apache::lonnet::plaintext((split(/\./,$ENV{'request.role'}))[0]);
2486: # realm
2487: if ($ENV{'request.course.id'}) {
2488: $realm=
2489: $ENV{'course.'.$ENV{'request.course.id'}.'.description'};
2490: }
2491: unless ($realm) { $realm=' '; }
2492: # Set messages
2493: my $messages=&domainlogo($domain);
2494: # Port for miniserver
2495: my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'};
2496: if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; }
2497: # construct main body tag
2498: my $bodytag = <<END;
2499: <style>
2500: h1, h2, h3, th { font-family: Arial, Helvetica, sans-serif }
2501: a:focus { color: red; background: yellow }
2502: </style>
2503: <body bgcolor="$pgbg" text="$font" alink="$alink" vlink="$vlink" link="$link"
2504: style="margin-top: 0px;$addstyle" $addentries>
2505: END
2506: my $upperleft='<img src="http://'.$ENV{'HTTP_HOST'}.':'.
2507: $lonhttpdPort.$img.'" alt="'.$function.'" />';
2508: if ($bodyonly) {
2509: return $bodytag;
2510: } elsif ($ENV{'browser.interface'} eq 'textual') {
2511: # Accessibility
2512: return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web',
2513: $forcereg).
2514: '<h1>LON-CAPA: '.$title.'</h1>';
2515: } elsif ($ENV{'environment.remote'} eq 'off') {
2516: # No Remote
2517: return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web',
2518: $forcereg).
2519: '<table bgcolor="'.$pgbg.'" width="100%" border="0" cellspacing="3" cellpadding="3"><tr><td bgcolor="'.$tabbg.'"><font face="Arial, Helvetica, sans-serif" size="+3" color="'.$font.'"><b>'.$title.
2520: '</b></font></td></tr></table>';
2521: }
2522:
2523: #
2524: # Top frame rendering, Remote is up
2525: #
2526: return(<<ENDBODY);
2527: $bodytag
2528: <table width="100%" cellspacing="0" border="0" cellpadding="0">
2529: <tr><td bgcolor="$sidebg">
2530: $upperleft</td>
2531: <td bgcolor="$sidebg" align="right">$messages </td>
2532: </tr>
2533: <tr>
2534: <td rowspan="3" bgcolor="$tabbg">
2535: <font size="5" face="Arial, Helvetica, sans-serif"><b>$title</b></font>
2536: <td bgcolor="$tabbg" align="right">
2537: <font size="2" face="Arial, Helvetica, sans-serif">
2538: $ENV{'environment.firstname'}
2539: $ENV{'environment.middlename'}
2540: $ENV{'environment.lastname'}
2541: $ENV{'environment.generation'}
2542: </font>
2543: </td>
2544: </tr>
2545: <tr><td bgcolor="$tabbg" align="right">
2546: <font size="2" face="Arial, Helvetica, sans-serif">$role</font>
2547: </td></tr>
2548: <tr>
2549: <td bgcolor="$tabbg" align="right"><font size="2" face="Arial, Helvetica, sans-serif">$realm</font> </td></tr>
2550: </table><br>
2551: ENDBODY
2552: }
2553:
2554: ###############################################
2555:
2556: =pod
2557:
2558: =item get_users_function
2559:
2560: Used by &bodytag to determine the current users primary role.
2561: Returns either 'student','coordinator','admin', or 'author'.
2562:
2563: =cut
2564:
2565: ###############################################
2566: sub get_users_function {
2567: my $function = 'student';
2568: if ($ENV{'request.role'}=~/^(cc|in|ta|ep)/) {
2569: $function='coordinator';
2570: }
2571: if ($ENV{'request.role'}=~/^(su|dc|ad|li)/) {
2572: $function='admin';
2573: }
2574: if (($ENV{'request.role'}=~/^(au|ca)/) ||
2575: ($ENV{'REQUEST_URI'}=~/^(\/priv|\~)/)) {
2576: $function='author';
2577: }
2578: return $function;
2579: }
2580:
2581: ###############################################
2582:
2583: sub get_posted_cgi {
2584: my $r=shift;
2585:
2586: my $buffer;
2587:
2588: $r->read($buffer,$r->header_in('Content-length'),0);
2589: unless ($buffer=~/^(\-+\w+)\s+Content\-Disposition\:\s*form\-data/si) {
2590: my @pairs=split(/&/,$buffer);
2591: my $pair;
2592: foreach $pair (@pairs) {
2593: my ($name,$value) = split(/=/,$pair);
2594: $value =~ tr/+/ /;
2595: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
2596: $name =~ tr/+/ /;
2597: $name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
2598: &add_to_env("form.$name",$value);
2599: }
2600: } else {
2601: my $contentsep=$1;
2602: my @lines = split (/\n/,$buffer);
2603: my $name='';
2604: my $value='';
2605: my $fname='';
2606: my $fmime='';
2607: my $i;
2608: for ($i=0;$i<=$#lines;$i++) {
2609: if ($lines[$i]=~/^$contentsep/) {
2610: if ($name) {
2611: chomp($value);
2612: if ($fname) {
2613: $ENV{"form.$name.filename"}=$fname;
2614: $ENV{"form.$name.mimetype"}=$fmime;
2615: } else {
2616: $value=~s/\s+$//s;
2617: }
2618: &add_to_env("form.$name",$value);
2619: }
2620: if ($i<$#lines) {
2621: $i++;
2622: $lines[$i]=~
2623: /Content\-Disposition\:\s*form\-data\;\s*name\=\"([^\"]+)\"/i;
2624: $name=$1;
2625: $value='';
2626: if ($lines[$i]=~/filename\=\"([^\"]+)\"/i) {
2627: $fname=$1;
2628: if
2629: ($lines[$i+1]=~/Content\-Type\:\s*([\w\-\/]+)/i) {
2630: $fmime=$1;
2631: $i++;
2632: } else {
2633: $fmime='';
2634: }
2635: } else {
2636: $fname='';
2637: $fmime='';
2638: }
2639: $i++;
2640: }
2641: } else {
2642: $value.=$lines[$i]."\n";
2643: }
2644: }
2645: }
2646: $ENV{'request.method'}=$ENV{'REQUEST_METHOD'};
2647: $r->method_number(M_GET);
2648: $r->method('GET');
2649: $r->headers_in->unset('Content-length');
2650: }
2651:
2652: =pod
2653:
2654: =item * get_unprocessed_cgi($query,$possible_names)
2655:
2656: Modify the %ENV hash to contain unprocessed CGI form parameters held in
2657: $query. The parameters listed in $possible_names (an array reference),
2658: will be set in $ENV{'form.name'} if they do not already exist.
2659:
2660: Typically called with $ENV{'QUERY_STRING'} as the first parameter.
2661: $possible_names is an ref to an array of form element names. As an example:
2662: get_unprocessed_cgi($ENV{'QUERY_STRING'},['uname','udom']);
2663: will result in $ENV{'form.uname'} and $ENV{'form.udom'} being set.
2664:
2665: =cut
2666:
2667: sub get_unprocessed_cgi {
2668: my ($query,$possible_names)= @_;
2669: # $Apache::lonxml::debug=1;
2670: foreach (split(/&/,$query)) {
2671: my ($name, $value) = split(/=/,$_);
2672: $name = &Apache::lonnet::unescape($name);
2673: if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) {
2674: $value =~ tr/+/ /;
2675: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
2676: &Apache::lonxml::debug("Seting :$name: to :$value:");
2677: unless (defined($ENV{'form.'.$name})) { &add_to_env('form.'.$name,$value) };
2678: }
2679: }
2680: }
2681:
2682: =pod
2683:
2684: =item * cacheheader()
2685:
2686: returns cache-controlling header code
2687:
2688: =cut
2689:
2690: sub cacheheader {
2691: unless ($ENV{'request.method'} eq 'GET') { return ''; }
2692: my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
2693: my $output .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" />
2694: <meta HTTP-EQUIV="Cache-control" CONTENT="no-cache" />
2695: <meta HTTP-EQUIV="Pragma" CONTENT="no-cache" />';
2696: return $output;
2697: }
2698:
2699: =pod
2700:
2701: =item * no_cache($r)
2702:
2703: specifies header code to not have cache
2704:
2705: =cut
2706:
2707: sub no_cache {
2708: my ($r) = @_;
2709: unless ($ENV{'request.method'} eq 'GET') { return ''; }
2710: #my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
2711: $r->no_cache(1);
2712: $r->header_out("Pragma" => "no-cache");
2713: #$r->header_out("Expires" => $date);
2714: }
2715:
2716: sub content_type {
2717: my ($r,$type,$charset) = @_;
2718: unless ($charset) {
2719: $charset=&Apache::lonlocal::current_encoding;
2720: }
2721: if ($charset) { $type.='; charset='.$charset; }
2722: if ($r) {
2723: $r->content_type($type);
2724: } else {
2725: print("Content-type: $type\n\n");
2726: }
2727: }
2728:
2729: =pod
2730:
2731: =item * add_to_env($name,$value)
2732:
2733: adds $name to the %ENV hash with value
2734: $value, if $name already exists, the entry is converted to an array
2735: reference and $value is added to the array.
2736:
2737: =cut
2738:
2739: sub add_to_env {
2740: my ($name,$value)=@_;
2741: if (defined($ENV{$name})) {
2742: if (ref($ENV{$name})) {
2743: #already have multiple values
2744: push(@{ $ENV{$name} },$value);
2745: } else {
2746: #first time seeing multiple values, convert hash entry to an arrayref
2747: my $first=$ENV{$name};
2748: undef($ENV{$name});
2749: push(@{ $ENV{$name} },$first,$value);
2750: }
2751: } else {
2752: $ENV{$name}=$value;
2753: }
2754: }
2755:
2756: =pod
2757:
2758: =item * get_env_multiple($name)
2759:
2760: gets $name from the %ENV hash, it seemlessly handles the cases where multiple
2761: values may be defined and end up as an array ref.
2762:
2763: returns an array of values
2764:
2765: =cut
2766:
2767: sub get_env_multiple {
2768: my ($name) = @_;
2769: my @values;
2770: if (defined($ENV{$name})) {
2771: # exists is it an array
2772: if (ref($ENV{$name})) {
2773: @values=@{ $ENV{$name} };
2774: } else {
2775: $values[0]=$ENV{$name};
2776: }
2777: }
2778: return(@values);
2779: }
2780:
2781:
2782: =pod
2783:
2784: =back
2785:
2786: =head1 CSV Upload/Handling functions
2787:
2788: =over 4
2789:
2790: =item * upfile_store($r)
2791:
2792: Store uploaded file, $r should be the HTTP Request object,
2793: needs $ENV{'form.upfile'}
2794: returns $datatoken to be put into hidden field
2795:
2796: =cut
2797:
2798: sub upfile_store {
2799: my $r=shift;
2800: $ENV{'form.upfile'}=~s/\r/\n/gs;
2801: $ENV{'form.upfile'}=~s/\f/\n/gs;
2802: $ENV{'form.upfile'}=~s/\n+/\n/gs;
2803: $ENV{'form.upfile'}=~s/\n+$//gs;
2804:
2805: my $datatoken=$ENV{'user.name'}.'_'.$ENV{'user.domain'}.
2806: '_enroll_'.$ENV{'request.course.id'}.'_'.time.'_'.$$;
2807: {
2808: my $datafile = $r->dir_config('lonDaemons').
2809: '/tmp/'.$datatoken.'.tmp';
2810: if ( open(my $fh,">$datafile") ) {
2811: print $fh $ENV{'form.upfile'};
2812: close($fh);
2813: }
2814: }
2815: return $datatoken;
2816: }
2817:
2818: =pod
2819:
2820: =item * load_tmp_file($r)
2821:
2822: Load uploaded file from tmp, $r should be the HTTP Request object,
2823: needs $ENV{'form.datatoken'},
2824: sets $ENV{'form.upfile'} to the contents of the file
2825:
2826: =cut
2827:
2828: sub load_tmp_file {
2829: my $r=shift;
2830: my @studentdata=();
2831: {
2832: my $studentfile = $r->dir_config('lonDaemons').
2833: '/tmp/'.$ENV{'form.datatoken'}.'.tmp';
2834: if ( open(my $fh,"<$studentfile") ) {
2835: @studentdata=<$fh>;
2836: close($fh);
2837: }
2838: }
2839: $ENV{'form.upfile'}=join('',@studentdata);
2840: }
2841:
2842: =pod
2843:
2844: =item * upfile_record_sep()
2845:
2846: Separate uploaded file into records
2847: returns array of records,
2848: needs $ENV{'form.upfile'} and $ENV{'form.upfiletype'}
2849:
2850: =cut
2851:
2852: sub upfile_record_sep {
2853: if ($ENV{'form.upfiletype'} eq 'xml') {
2854: } else {
2855: return split(/\n/,$ENV{'form.upfile'});
2856: }
2857: }
2858:
2859: =pod
2860:
2861: =item * record_sep($record)
2862:
2863: Separate a record into fields $record should be an item from the upfile_record_sep(), needs $ENV{'form.upfiletype'}
2864:
2865: =cut
2866:
2867: sub record_sep {
2868: my $record=shift;
2869: my %components=();
2870: if ($ENV{'form.upfiletype'} eq 'xml') {
2871: } elsif ($ENV{'form.upfiletype'} eq 'space') {
2872: my $i=0;
2873: foreach (split(/\s+/,$record)) {
2874: my $field=$_;
2875: $field=~s/^(\"|\')//;
2876: $field=~s/(\"|\')$//;
2877: $components{$i}=$field;
2878: $i++;
2879: }
2880: } elsif ($ENV{'form.upfiletype'} eq 'tab') {
2881: my $i=0;
2882: foreach (split(/\t/,$record)) {
2883: my $field=$_;
2884: $field=~s/^(\"|\')//;
2885: $field=~s/(\"|\')$//;
2886: $components{$i}=$field;
2887: $i++;
2888: }
2889: } else {
2890: my @allfields=split(/\,/,$record);
2891: my $i=0;
2892: my $j;
2893: for ($j=0;$j<=$#allfields;$j++) {
2894: my $field=$allfields[$j];
2895: if ($field=~/^\s*(\"|\')/) {
2896: my $delimiter=$1;
2897: while (($field!~/$delimiter$/) && ($j<$#allfields)) {
2898: $j++;
2899: $field.=','.$allfields[$j];
2900: }
2901: $field=~s/^\s*$delimiter//;
2902: $field=~s/$delimiter\s*$//;
2903: }
2904: $components{$i}=$field;
2905: $i++;
2906: }
2907: }
2908: return %components;
2909: }
2910:
2911: ######################################################
2912: ######################################################
2913:
2914: =pod
2915:
2916: =item * upfile_select_html()
2917:
2918: Return HTML code to select a file from the users machine and specify
2919: the file type.
2920:
2921: =cut
2922:
2923: ######################################################
2924: ######################################################
2925: sub upfile_select_html {
2926: my %Types = (
2927: csv => &mt('CSV (comma separated values, spreadsheet)'),
2928: space => &mt('Space separated'),
2929: tab => &mt('Tabulator separated'),
2930: # xml => &mt('HTML/XML'),
2931: );
2932: my $Str = '<input type="file" name="upfile" size="50" />'.
2933: '<br />Type: <select name="upfiletype">';
2934: foreach my $type (sort(keys(%Types))) {
2935: $Str .= '<option value="'.$type.'" >'.$Types{$type}."</option>\n";
2936: }
2937: $Str .= "</select>\n";
2938: return $Str;
2939: }
2940:
2941: ######################################################
2942: ######################################################
2943:
2944: =pod
2945:
2946: =item * csv_print_samples($r,$records)
2947:
2948: Prints a table of sample values from each column uploaded $r is an
2949: Apache Request ref, $records is an arrayref from
2950: &Apache::loncommon::upfile_record_sep
2951:
2952: =cut
2953:
2954: ######################################################
2955: ######################################################
2956: sub csv_print_samples {
2957: my ($r,$records) = @_;
2958: my (%sone,%stwo,%sthree);
2959: %sone=&record_sep($$records[0]);
2960: if (defined($$records[1])) {%stwo=&record_sep($$records[1]);}
2961: if (defined($$records[2])) {%sthree=&record_sep($$records[2]);}
2962: #
2963: $r->print(&mt('Samples').'<br /><table border="2"><tr>');
2964: foreach (sort({$a <=> $b} keys(%sone))) {
2965: $r->print('<th>'.&mt('Column [_1]',($_+1)).'</th>'); }
2966: $r->print('</tr>');
2967: foreach my $hash (\%sone,\%stwo,\%sthree) {
2968: $r->print('<tr>');
2969: foreach (sort({$a <=> $b} keys(%sone))) {
2970: $r->print('<td>');
2971: if (defined($$hash{$_})) { $r->print($$hash{$_}); }
2972: $r->print('</td>');
2973: }
2974: $r->print('</tr>');
2975: }
2976: $r->print('</tr></table><br />'."\n");
2977: }
2978:
2979: ######################################################
2980: ######################################################
2981:
2982: =pod
2983:
2984: =item * csv_print_select_table($r,$records,$d)
2985:
2986: Prints a table to create associations between values and table columns.
2987:
2988: $r is an Apache Request ref,
2989: $records is an arrayref from &Apache::loncommon::upfile_record_sep,
2990: $d is an array of 2 element arrays (internal name, displayed name,defaultcol)
2991:
2992: =cut
2993:
2994: ######################################################
2995: ######################################################
2996: sub csv_print_select_table {
2997: my ($r,$records,$d) = @_;
2998: my $i=0;my %sone;
2999: %sone=&record_sep($$records[0]);
3000: $r->print(&mt('Associate columns with student attributes.')."\n".
3001: '<table border="2"><tr>'.
3002: '<th>'.&mt('Attribute').'</th>'.
3003: '<th>'.&mt('Column').'</th></tr>'."\n");
3004: foreach (@$d) {
3005: my ($value,$display,$defaultcol)=@{ $_ };
3006: $r->print('<tr><td>'.$display.'</td>');
3007:
3008: $r->print('<td><select name=f'.$i.
3009: ' onchange="javascript:flip(this.form,'.$i.');">');
3010: $r->print('<option value="none"></option>');
3011: foreach (sort({$a <=> $b} keys(%sone))) {
3012: $r->print('<option value="'.$_.'"'.
3013: ($_ eq $defaultcol ? ' selected ' : '').
3014: '>Column '.($_+1).'</option>');
3015: }
3016: $r->print('</select></td></tr>'."\n");
3017: $i++;
3018: }
3019: $i--;
3020: return $i;
3021: }
3022:
3023: ######################################################
3024: ######################################################
3025:
3026: =pod
3027:
3028: =item * csv_samples_select_table($r,$records,$d)
3029:
3030: Prints a table of sample values from the upload and can make associate samples to internal names.
3031:
3032: $r is an Apache Request ref,
3033: $records is an arrayref from &Apache::loncommon::upfile_record_sep,
3034: $d is an array of 2 element arrays (internal name, displayed name)
3035:
3036: =cut
3037:
3038: ######################################################
3039: ######################################################
3040: sub csv_samples_select_table {
3041: my ($r,$records,$d) = @_;
3042: my %sone; my %stwo; my %sthree;
3043: my $i=0;
3044: #
3045: $r->print('<table border=2><tr><th>'.
3046: &mt('Field').'</th><th>'.&mt('Samples').'</th></tr>');
3047: %sone=&record_sep($$records[0]);
3048: if (defined($$records[1])) {%stwo=&record_sep($$records[1]);}
3049: if (defined($$records[2])) {%sthree=&record_sep($$records[2]);}
3050: #
3051: foreach (sort keys %sone) {
3052: $r->print('<tr><td><select name="f'.$i.'"'.
3053: ' onchange="javascript:flip(this.form,'.$i.');">');
3054: foreach (@$d) {
3055: my ($value,$display,$defaultcol)=@{ $_ };
3056: $r->print('<option value="'.$value.'"'.
3057: ($i eq $defaultcol ? ' selected ':'').'>'.
3058: $display.'</option>');
3059: }
3060: $r->print('</select></td><td>');
3061: if (defined($sone{$_})) { $r->print($sone{$_}."</br>\n"); }
3062: if (defined($stwo{$_})) { $r->print($stwo{$_}."</br>\n"); }
3063: if (defined($sthree{$_})) { $r->print($sthree{$_}."</br>\n"); }
3064: $r->print('</td></tr>');
3065: $i++;
3066: }
3067: $i--;
3068: return($i);
3069: }
3070:
3071: ######################################################
3072: ######################################################
3073:
3074: =pod
3075:
3076: =item clean_excel_name($name)
3077:
3078: Returns a replacement for $name which does not contain any illegal characters.
3079:
3080: =cut
3081:
3082: ######################################################
3083: ######################################################
3084: sub clean_excel_name {
3085: my ($name) = @_;
3086: $name =~ s/[:\*\?\/\\]//g;
3087: if (length($name) > 31) {
3088: $name = substr($name,0,31);
3089: }
3090: return $name;
3091: }
3092:
3093: =pod
3094:
3095: =item * check_if_partid_hidden($id,$symb,$udom,$uname)
3096:
3097: Returns either 1 or undef
3098:
3099: 1 if the part is to be hidden, undef if it is to be shown
3100:
3101: Arguments are:
3102:
3103: $id the id of the part to be checked
3104: $symb, optional the symb of the resource to check
3105: $udom, optional the domain of the user to check for
3106: $uname, optional the username of the user to check for
3107:
3108: =cut
3109:
3110: sub check_if_partid_hidden {
3111: my ($id,$symb,$udom,$uname) = @_;
3112: my $hiddenparts=&Apache::lonnet::EXT('resource.0.hiddenparts',
3113: $symb,$udom,$uname);
3114: my $truth=1;
3115: #if the string starts with !, then the list is the list to show not hide
3116: if ($hiddenparts=~s/^\s*!//) { $truth=undef; }
3117: my @hiddenlist=split(/,/,$hiddenparts);
3118: foreach my $checkid (@hiddenlist) {
3119: if ($checkid =~ /^\s*\Q$id\E\s*$/) { return $truth; }
3120: }
3121: return !$truth;
3122: }
3123:
3124:
3125: ############################################################
3126: ############################################################
3127:
3128: =pod
3129:
3130: =back
3131:
3132: =head1 cgi-bin script and graphing routines
3133:
3134: =over 4
3135:
3136: =item get_cgi_id
3137:
3138: Inputs: none
3139:
3140: Returns an id which can be used to pass environment variables
3141: to various cgi-bin scripts. These environment variables will
3142: be removed from the users environment after a given time by
3143: the routine &Apache::lonnet::transfer_profile_to_env.
3144:
3145: =cut
3146:
3147: ############################################################
3148: ############################################################
3149: my $uniq=0;
3150: sub get_cgi_id {
3151: $uniq=($uniq+1)%100000;
3152: return (time.'_'.$uniq);
3153: }
3154:
3155: ############################################################
3156: ############################################################
3157:
3158: =pod
3159:
3160: =item DrawBarGraph
3161:
3162: Facilitates the plotting of data in a (stacked) bar graph.
3163: Puts plot definition data into the users environment in order for
3164: graph.png to plot it. Returns an <img> tag for the plot.
3165: The bars on the plot are labeled '1','2',...,'n'.
3166:
3167: Inputs:
3168:
3169: =over 4
3170:
3171: =item $Title: string, the title of the plot
3172:
3173: =item $xlabel: string, text describing the X-axis of the plot
3174:
3175: =item $ylabel: string, text describing the Y-axis of the plot
3176:
3177: =item $Max: scalar, the maximum Y value to use in the plot
3178: If $Max is < any data point, the graph will not be rendered.
3179:
3180: =item $colors: array ref holding the colors to be used for the data sets when
3181: they are plotted. If undefined, default values will be used.
3182:
3183: =item $labels: array ref holding the labels to use on the x-axis for the bars.
3184:
3185: =item @Values: An array of array references. Each array reference holds data
3186: to be plotted in a stacked bar chart.
3187:
3188: =back
3189:
3190: Returns:
3191:
3192: An <img> tag which references graph.png and the appropriate identifying
3193: information for the plot.
3194:
3195: =cut
3196:
3197: ############################################################
3198: ############################################################
3199: sub DrawBarGraph {
3200: my ($Title,$xlabel,$ylabel,$Max,$colors,$labels,@Values)=@_;
3201: #
3202: if (! defined($colors)) {
3203: $colors = ['#33ff00',
3204: '#0033cc', '#990000', '#aaaa66', '#663399', '#ff9933',
3205: '#66ccff', '#ff9999', '#cccc33', '#660000', '#33cc66',
3206: ];
3207: }
3208: #
3209: my $identifier = &get_cgi_id();
3210: my $id = 'cgi.'.$identifier;
3211: if (! @Values || ref($Values[0]) ne 'ARRAY') {
3212: return '';
3213: }
3214: my $NumBars = scalar(@{$Values[0]});
3215: my %ValuesHash;
3216: my $NumSets=1;
3217: foreach my $array (@Values) {
3218: next if (! ref($array));
3219: $ValuesHash{$id.'.data.'.$NumSets++} =
3220: join(',',@$array);
3221: }
3222: #
3223: my ($height,$width,$xskip,$bar_width) = (200,120,1,15);
3224: if ($NumBars < 10) {
3225: $width = 120+$NumBars*15;
3226: $xskip = 1;
3227: $bar_width = 15;
3228: } elsif ($NumBars <= 25) {
3229: $width = 120+$NumBars*11;
3230: $xskip = 5;
3231: $bar_width = 8;
3232: } elsif ($NumBars <= 50) {
3233: $width = 120+$NumBars*8;
3234: $xskip = 5;
3235: $bar_width = 4;
3236: } else {
3237: $width = 120+$NumBars*8;
3238: $xskip = 5;
3239: $bar_width = 4;
3240: }
3241: #
3242: my @Labels;
3243: if (defined($labels)) {
3244: @Labels = @$labels;
3245: } else {
3246: for (my $i=0;$i<@{$Values[0]};$i++) {
3247: push (@Labels,$i+1);
3248: }
3249: }
3250: #
3251: $Max = 1 if ($Max < 1);
3252: if ( int($Max) < $Max ) {
3253: $Max++;
3254: $Max = int($Max);
3255: }
3256: $Title = '' if (! defined($Title));
3257: $xlabel = '' if (! defined($xlabel));
3258: $ylabel = '' if (! defined($ylabel));
3259: $ValuesHash{$id.'.title'} = &Apache::lonnet::escape($Title);
3260: $ValuesHash{$id.'.xlabel'} = &Apache::lonnet::escape($xlabel);
3261: $ValuesHash{$id.'.ylabel'} = &Apache::lonnet::escape($ylabel);
3262: $ValuesHash{$id.'.y_max_value'} = $Max;
3263: $ValuesHash{$id.'.NumBars'} = $NumBars;
3264: $ValuesHash{$id.'.NumSets'} = $NumSets;
3265: $ValuesHash{$id.'.PlotType'} = 'bar';
3266: $ValuesHash{$id.'.Colors'} = join(',',@{$colors});
3267: $ValuesHash{$id.'.height'} = $height;
3268: $ValuesHash{$id.'.width'} = $width;
3269: $ValuesHash{$id.'.xskip'} = $xskip;
3270: $ValuesHash{$id.'.bar_width'} = $bar_width;
3271: $ValuesHash{$id.'.labels'} = join(',',@Labels);
3272: #
3273: &Apache::lonnet::appenv(%ValuesHash);
3274: return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
3275: }
3276:
3277: ############################################################
3278: ############################################################
3279:
3280: =pod
3281:
3282: =item DrawXYGraph
3283:
3284: Facilitates the plotting of data in an XY graph.
3285: Puts plot definition data into the users environment in order for
3286: graph.png to plot it. Returns an <img> tag for the plot.
3287:
3288: Inputs:
3289:
3290: =over 4
3291:
3292: =item $Title: string, the title of the plot
3293:
3294: =item $xlabel: string, text describing the X-axis of the plot
3295:
3296: =item $ylabel: string, text describing the Y-axis of the plot
3297:
3298: =item $Max: scalar, the maximum Y value to use in the plot
3299: If $Max is < any data point, the graph will not be rendered.
3300:
3301: =item $colors: Array ref containing the hex color codes for the data to be
3302: plotted in. If undefined, default values will be used.
3303:
3304: =item $Xlabels: Array ref containing the labels to be used for the X-axis.
3305:
3306: =item $Ydata: Array ref containing Array refs.
3307: Each of the contained arrays will be plotted as a separate curve.
3308:
3309: =item %Values: hash indicating or overriding any default values which are
3310: passed to graph.png.
3311: Possible values are: width, xskip, x_ticks, x_tick_offset, among others.
3312:
3313: =back
3314:
3315: Returns:
3316:
3317: An <img> tag which references graph.png and the appropriate identifying
3318: information for the plot.
3319:
3320: =cut
3321:
3322: ############################################################
3323: ############################################################
3324: sub DrawXYGraph {
3325: my ($Title,$xlabel,$ylabel,$Max,$colors,$Xlabels,$Ydata,%Values)=@_;
3326: #
3327: # Create the identifier for the graph
3328: my $identifier = &get_cgi_id();
3329: my $id = 'cgi.'.$identifier;
3330: #
3331: $Title = '' if (! defined($Title));
3332: $xlabel = '' if (! defined($xlabel));
3333: $ylabel = '' if (! defined($ylabel));
3334: my %ValuesHash =
3335: (
3336: $id.'.title' => &Apache::lonnet::escape($Title),
3337: $id.'.xlabel' => &Apache::lonnet::escape($xlabel),
3338: $id.'.ylabel' => &Apache::lonnet::escape($ylabel),
3339: $id.'.y_max_value'=> $Max,
3340: $id.'.labels' => join(',',@$Xlabels),
3341: $id.'.PlotType' => 'XY',
3342: );
3343: #
3344: if (defined($colors) && ref($colors) eq 'ARRAY') {
3345: $ValuesHash{$id.'.Colors'} = join(',',@{$colors});
3346: }
3347: #
3348: if (! ref($Ydata) || ref($Ydata) ne 'ARRAY') {
3349: return '';
3350: }
3351: my $NumSets=1;
3352: foreach my $array (@{$Ydata}){
3353: next if (! ref($array));
3354: $ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array);
3355: }
3356: $ValuesHash{$id.'.NumSets'} = $NumSets-1;
3357: #
3358: # Deal with other parameters
3359: while (my ($key,$value) = each(%Values)) {
3360: $ValuesHash{$id.'.'.$key} = $value;
3361: }
3362: #
3363: &Apache::lonnet::appenv(%ValuesHash);
3364: return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
3365: }
3366:
3367: ############################################################
3368: ############################################################
3369:
3370: =pod
3371:
3372: =item DrawXYYGraph
3373:
3374: Facilitates the plotting of data in an XY graph with two Y axes.
3375: Puts plot definition data into the users environment in order for
3376: graph.png to plot it. Returns an <img> tag for the plot.
3377:
3378: Inputs:
3379:
3380: =over 4
3381:
3382: =item $Title: string, the title of the plot
3383:
3384: =item $xlabel: string, text describing the X-axis of the plot
3385:
3386: =item $ylabel: string, text describing the Y-axis of the plot
3387:
3388: =item $colors: Array ref containing the hex color codes for the data to be
3389: plotted in. If undefined, default values will be used.
3390:
3391: =item $Xlabels: Array ref containing the labels to be used for the X-axis.
3392:
3393: =item $Ydata1: The first data set
3394:
3395: =item $Min1: The minimum value of the left Y-axis
3396:
3397: =item $Max1: The maximum value of the left Y-axis
3398:
3399: =item $Ydata2: The second data set
3400:
3401: =item $Min2: The minimum value of the right Y-axis
3402:
3403: =item $Max2: The maximum value of the left Y-axis
3404:
3405: =item %Values: hash indicating or overriding any default values which are
3406: passed to graph.png.
3407: Possible values are: width, xskip, x_ticks, x_tick_offset, among others.
3408:
3409: =back
3410:
3411: Returns:
3412:
3413: An <img> tag which references graph.png and the appropriate identifying
3414: information for the plot.
3415:
3416: =cut
3417:
3418: ############################################################
3419: ############################################################
3420: sub DrawXYYGraph {
3421: my ($Title,$xlabel,$ylabel,$colors,$Xlabels,$Ydata1,$Min1,$Max1,
3422: $Ydata2,$Min2,$Max2,%Values)=@_;
3423: #
3424: # Create the identifier for the graph
3425: my $identifier = &get_cgi_id();
3426: my $id = 'cgi.'.$identifier;
3427: #
3428: $Title = '' if (! defined($Title));
3429: $xlabel = '' if (! defined($xlabel));
3430: $ylabel = '' if (! defined($ylabel));
3431: my %ValuesHash =
3432: (
3433: $id.'.title' => &Apache::lonnet::escape($Title),
3434: $id.'.xlabel' => &Apache::lonnet::escape($xlabel),
3435: $id.'.ylabel' => &Apache::lonnet::escape($ylabel),
3436: $id.'.labels' => join(',',@$Xlabels),
3437: $id.'.PlotType' => 'XY',
3438: $id.'.NumSets' => 2,
3439: $id.'.two_axes' => 1,
3440: $id.'.y1_max_value' => $Max1,
3441: $id.'.y1_min_value' => $Min1,
3442: $id.'.y2_max_value' => $Max2,
3443: $id.'.y2_min_value' => $Min2,
3444: );
3445: #
3446: if (defined($colors) && ref($colors) eq 'ARRAY') {
3447: $ValuesHash{$id.'.Colors'} = join(',',@{$colors});
3448: }
3449: #
3450: if (! ref($Ydata1) || ref($Ydata1) ne 'ARRAY' ||
3451: ! ref($Ydata2) || ref($Ydata2) ne 'ARRAY'){
3452: return '';
3453: }
3454: my $NumSets=1;
3455: foreach my $array ($Ydata1,$Ydata2){
3456: next if (! ref($array));
3457: $ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array);
3458: }
3459: #
3460: # Deal with other parameters
3461: while (my ($key,$value) = each(%Values)) {
3462: $ValuesHash{$id.'.'.$key} = $value;
3463: }
3464: #
3465: &Apache::lonnet::appenv(%ValuesHash);
3466: return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
3467: }
3468:
3469: ############################################################
3470: ############################################################
3471:
3472: =pod
3473:
3474: =back
3475:
3476: =head1 Statistics helper routines?
3477:
3478: Bad place for them but what the hell.
3479:
3480: =over 4
3481:
3482: =item &chartlink
3483:
3484: Returns a link to the chart for a specific student.
3485:
3486: Inputs:
3487:
3488: =over 4
3489:
3490: =item $linktext: The text of the link
3491:
3492: =item $sname: The students username
3493:
3494: =item $sdomain: The students domain
3495:
3496: =back
3497:
3498: =back
3499:
3500: =cut
3501:
3502: ############################################################
3503: ############################################################
3504: sub chartlink {
3505: my ($linktext, $sname, $sdomain) = @_;
3506: my $link = '<a href="/adm/statistics?reportSelected=student_assessment'.
3507: '&SelectedStudent='.&Apache::lonnet::escape($sname.':'.$sdomain).
3508: '&chartoutputmode='.HTML::Entities::encode('html, with all links').
3509: '">'.$linktext.'</a>';
3510: }
3511:
3512: #######################################################
3513: #######################################################
3514:
3515: =pod
3516:
3517: =head1 Course Environment Routines
3518:
3519: =over 4
3520:
3521: =item &restore_course_settings
3522:
3523: =item &store_course_settings
3524:
3525: Restores/Store indicated form parameters from the course environment.
3526: Will not overwrite existing values of the form parameters.
3527:
3528: Inputs:
3529: a scalar describing the data (e.g. 'chart', 'problem_analysis')
3530:
3531: a hash ref describing the data to be stored. For example:
3532:
3533: %Save_Parameters = ('Status' => 'scalar',
3534: 'chartoutputmode' => 'scalar',
3535: 'chartoutputdata' => 'scalar',
3536: 'Section' => 'array',
3537: 'StudentData' => 'array',
3538: 'Maps' => 'array');
3539:
3540: Returns: both routines return nothing
3541:
3542: =cut
3543:
3544: #######################################################
3545: #######################################################
3546: sub store_course_settings {
3547: # save to the environment
3548: # appenv the same items, just to be safe
3549: my $courseid = $ENV{'request.course.id'};
3550: my $coursedom = $ENV{'course.'.$courseid.'.domain'};
3551: my ($prefix,$Settings) = @_;
3552: my %SaveHash;
3553: my %AppHash;
3554: while (my ($setting,$type) = each(%$Settings)) {
3555: my $basename = 'internal.'.$prefix.'.'.$setting;
3556: my $envname = 'course.'.$courseid.'.'.$basename;
3557: if (exists($ENV{'form.'.$setting})) {
3558: # Save this value away
3559: if ($type eq 'scalar' &&
3560: (! exists($ENV{$envname}) ||
3561: $ENV{$envname} ne $ENV{'form.'.$setting})) {
3562: $SaveHash{$basename} = $ENV{'form.'.$setting};
3563: $AppHash{$envname} = $ENV{'form.'.$setting};
3564: } elsif ($type eq 'array') {
3565: my $stored_form;
3566: if (ref($ENV{'form.'.$setting})) {
3567: $stored_form = join(',',
3568: map {
3569: &Apache::lonnet::escape($_);
3570: } sort(@{$ENV{'form.'.$setting}}));
3571: } else {
3572: $stored_form =
3573: &Apache::lonnet::escape($ENV{'form.'.$setting});
3574: }
3575: # Determine if the array contents are the same.
3576: if ($stored_form ne $ENV{$envname}) {
3577: $SaveHash{$basename} = $stored_form;
3578: $AppHash{$envname} = $stored_form;
3579: }
3580: }
3581: }
3582: }
3583: my $put_result = &Apache::lonnet::put('environment',\%SaveHash,
3584: $coursedom,
3585: $ENV{'course.'.$courseid.'.num'});
3586: if ($put_result !~ /^(ok|delayed)/) {
3587: &Apache::lonnet::logthis('unable to save form parameters, '.
3588: 'got error:'.$put_result);
3589: }
3590: # Make sure these settings stick around in this session, too
3591: &Apache::lonnet::appenv(%AppHash);
3592: return;
3593: }
3594:
3595: sub restore_course_settings {
3596: my $courseid = $ENV{'request.course.id'};
3597: my ($prefix,$Settings) = @_;
3598: while (my ($setting,$type) = each(%$Settings)) {
3599: next if (exists($ENV{'form.'.$setting}));
3600: my $envname = 'course.'.$courseid.'.internal.'.$prefix.
3601: '.'.$setting;
3602: if (exists($ENV{$envname})) {
3603: if ($type eq 'scalar') {
3604: $ENV{'form.'.$setting} = $ENV{$envname};
3605: } elsif ($type eq 'array') {
3606: $ENV{'form.'.$setting} = [
3607: map {
3608: &Apache::lonnet::unescape($_);
3609: } split(',',$ENV{$envname})
3610: ];
3611: }
3612: }
3613: }
3614: }
3615:
3616: ############################################################
3617: ############################################################
3618:
3619: sub propath {
3620: my ($udom,$uname)=@_;
3621: $udom=~s/\W//g;
3622: $uname=~s/\W//g;
3623: my $subdir=$uname.'__';
3624: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
3625: my $proname="$Apache::lonnet::perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
3626: return $proname;
3627: }
3628:
3629: sub icon {
3630: my ($file)=@_;
3631: my $curfext = (split(/\./,$file))[-1];
3632: my $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/unknown.gif';
3633: my $embstyle = &Apache::loncommon::fileembstyle($curfext);
3634: if (!(!defined($embstyle) || $embstyle eq 'unk' || $embstyle eq 'hdn')) {
3635: if (-e $Apache::lonnet::perlvar{'lonDocRoot'}.'/'.
3636: $Apache::lonnet::perlvar{'lonIconsURL'}.'/'.
3637: $curfext.".gif") {
3638: $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/'.
3639: $curfext.".gif";
3640: }
3641: }
3642: return $iconname;
3643: }
3644:
3645: =pod
3646:
3647: =back
3648:
3649: =cut
3650:
3651: 1;
3652: __END__;
3653:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to loncommon.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / interface