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