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