Annotation of loncom/interface/loncommon.pm, revision 1.109
1.10 albertel 1: # The LearningOnline Network with CAPA
1.1 albertel 2: # a pile of common routines
1.10 albertel 3: #
1.109 ! matthew 4: # $Id: loncommon.pm,v 1.108 2003/07/16 14:21:56 bowersj2 Exp $
1.10 albertel 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: #
1.12 harris41 28: # YEAR=2001
29: # 2/13-12/7 Guy Albertelli
1.18 www 30: # 12/21 Gerd Kortemeyer
1.22 www 31: # 12/25,12/28 Gerd Kortemeyer
1.23 www 32: # YEAR=2002
33: # 1/4 Gerd Kortemeyer
1.43 ng 34: # 6/24,7/2 H. K. Ng
1.1 albertel 35:
36: # Makes a table out of the previous attempts
1.2 albertel 37: # Inputs result_from_symbread, user, domain, course_id
1.16 harris41 38: # Reads in non-network-related .tab files
1.1 albertel 39:
1.35 matthew 40: # POD header:
41:
1.45 matthew 42: =pod
43:
1.35 matthew 44: =head1 NAME
45:
46: Apache::loncommon - pile of common routines
47:
48: =head1 SYNOPSIS
49:
50: Referenced by other mod_perl Apache modules.
51:
52: Invocation:
53: &Apache::loncommon::SUBROUTINENAME(ARGUMENTS);
54:
55: =head1 INTRODUCTION
56:
57: Common collection of used subroutines. This collection helps remove
58: redundancy from other modules and increase efficiency of memory usage.
59:
60: Current things done:
61:
62: Makes a table out of the previous homework attempts
63: Inputs result_from_symbread, user, domain, course_id
64: Reads in non-network-related .tab files
65:
66: This is part of the LearningOnline Network with CAPA project
67: described at http://www.lon-capa.org.
68:
1.41 ng 69: =head2 General Subroutines
1.35 matthew 70:
71: =over 4
72:
73: =cut
74:
75: # End of POD header
1.1 albertel 76: package Apache::loncommon;
77:
78: use strict;
1.22 www 79: use Apache::lonnet();
1.46 matthew 80: use GDBM_File;
1.51 www 81: use POSIX qw(strftime mktime);
1.99 www 82: use Apache::Constants qw(:common :http :methods);
1.1 albertel 83: use Apache::lonmsg();
1.82 www 84: use Apache::lonmenu();
1.22 www 85: my $readit;
86:
1.46 matthew 87: =pod
88:
89: =item Global Variables
90:
91: =over 4
92:
93: =cut
1.20 www 94: # ----------------------------------------------- Filetypes/Languages/Copyright
1.12 harris41 95: my %language;
96: my %cprtag;
97: my %fe; my %fd;
1.41 ng 98: my %category_extensions;
1.12 harris41 99:
1.63 www 100: # ---------------------------------------------- Designs
101:
102: my %designhash;
103:
1.46 matthew 104: # ---------------------------------------------- Thesaurus variables
105:
106: =pod
107:
108: =item %Keywords
109:
110: A hash used by &keyword to determine if a word is considered a keyword.
111:
112: =item $thesaurus_db_file
113:
114: Scalar containing the full path to the thesaurus database.
115:
116: =cut
117:
118: my %Keywords;
119: my $thesaurus_db_file;
120:
121:
122: =pod
123:
124: =back
125:
126: =cut
1.20 www 127:
1.12 harris41 128: # ----------------------------------------------------------------------- BEGIN
1.41 ng 129:
130: =pod
131:
1.35 matthew 132: =item BEGIN()
133:
134: Initialize values from language.tab, copyright.tab, filetypes.tab,
1.45 matthew 135: thesaurus.tab, and filecategories.tab.
1.35 matthew 136:
137: =cut
1.45 matthew 138:
1.35 matthew 139: # ----------------------------------------------------------------------- BEGIN
140:
1.18 www 141: BEGIN {
1.46 matthew 142: # Variable initialization
143: $thesaurus_db_file = $Apache::lonnet::perlvar{'lonTabDir'}."/thesaurus.db";
144: #
1.22 www 145: unless ($readit) {
1.12 harris41 146: # ------------------------------------------------------------------- languages
147: {
148: my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
149: '/language.tab');
1.16 harris41 150: if ($fh) {
151: while (<$fh>) {
152: next if /^\#/;
153: chomp;
1.98 www 154: my ($key,$two,$country,$three,$enc,$val)=(split(/\t/,$_));
155: $language{$key}=$val.' - '.$enc;
1.16 harris41 156: }
1.12 harris41 157: }
158: }
159: # ------------------------------------------------------------------ copyrights
160: {
1.16 harris41 161: my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonIncludes'}.
162: '/copyright.tab');
163: if ($fh) {
164: while (<$fh>) {
165: next if /^\#/;
166: chomp;
167: my ($key,$val)=(split(/\s+/,$_,2));
168: $cprtag{$key}=$val;
169: }
1.12 harris41 170: }
171: }
1.63 www 172:
173: # -------------------------------------------------------------- domain designs
174:
175: my $filename;
176: my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';
177: opendir(DIR,$designdir);
178: while ($filename=readdir(DIR)) {
179: my ($domain)=($filename=~/^(\w+)\./);
180: {
181: my $fh=Apache::File->new($designdir.'/'.$filename);
182: if ($fh) {
183: while (<$fh>) {
184: next if /^\#/;
185: chomp;
186: my ($key,$val)=(split(/\=/,$_));
187: if ($val) { $designhash{$domain.'.'.$key}=$val; }
188: }
189: }
190: }
191:
192: }
193: closedir(DIR);
194:
195:
1.15 harris41 196: # ------------------------------------------------------------- file categories
197: {
198: my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
1.16 harris41 199: '/filecategories.tab');
200: if ($fh) {
201: while (<$fh>) {
202: next if /^\#/;
203: chomp;
1.41 ng 204: my ($extension,$category)=(split(/\s+/,$_,2));
205: push @{$category_extensions{lc($category)}},$extension;
1.16 harris41 206: }
1.15 harris41 207: }
208: }
1.12 harris41 209: # ------------------------------------------------------------------ file types
210: {
1.16 harris41 211: my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
212: '/filetypes.tab');
213: if ($fh) {
214: while (<$fh>) {
215: next if (/^\#/);
216: chomp;
217: my ($ending,$emb,$descr)=split(/\s+/,$_,3);
218: if ($descr ne '') {
219: $fe{$ending}=lc($emb);
220: $fd{$ending}=$descr;
221: }
1.12 harris41 222: }
223: }
224: }
1.22 www 225: &Apache::lonnet::logthis(
1.46 matthew 226: "<font color=yellow>INFO: Read file types</font>");
1.22 www 227: $readit=1;
1.46 matthew 228: } # end of unless($readit)
1.32 matthew 229:
230: }
231: # ============================================================= END BEGIN BLOCK
1.42 matthew 232: ###############################################################
233: ## HTML and Javascript Helper Functions ##
234: ###############################################################
235:
236: =pod
237:
238: =item browser_and_searcher_javascript
239:
240: Returns scalar containing javascript to open a browser window
241: or a searcher window. Also creates
242:
243: =over 4
244:
245: =item openbrowser(formname,elementname,only,omit) [javascript]
246:
247: inputs: formname, elementname, only, omit
248:
249: formname and elementname indicate the name of the html form and name of
250: the element that the results of the browsing selection are to be placed in.
251:
252: Specifying 'only' will restrict the browser to displaying only files
253: with the given extension. Can be a comma seperated list.
254:
255: Specifying 'omit' will restrict the browser to NOT displaying files
256: with the given extension. Can be a comma seperated list.
257:
258: =item opensearcher(formname, elementname) [javascript]
259:
260: Inputs: formname, elementname
261:
262: formname and elementname specify the name of the html form and the name
263: of the element the selection from the search results will be placed in.
264:
265: =back
266:
267: =cut
268:
269: ###############################################################
270: sub browser_and_searcher_javascript {
271: return <<END;
1.50 matthew 272: var editbrowser = null;
1.42 matthew 273: function openbrowser(formname,elementname,only,omit) {
274: var url = '/res/?';
275: if (editbrowser == null) {
276: url += 'launch=1&';
277: }
278: url += 'catalogmode=interactive&';
279: url += 'mode=edit&';
280: url += 'form=' + formname + '&';
281: if (only != null) {
282: url += 'only=' + only + '&';
283: }
284: if (omit != null) {
285: url += 'omit=' + omit + '&';
286: }
287: url += 'element=' + elementname + '';
288: var title = 'Browser';
289: var options = 'scrollbars=1,resizable=1,menubar=0';
290: options += ',width=700,height=600';
291: editbrowser = open(url,title,options,'1');
292: editbrowser.focus();
293: }
294: var editsearcher;
295: function opensearcher(formname,elementname) {
296: var url = '/adm/searchcat?';
297: if (editsearcher == null) {
298: url += 'launch=1&';
299: }
300: url += 'catalogmode=interactive&';
301: url += 'mode=edit&';
302: url += 'form=' + formname + '&';
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
311: }
312:
1.74 www 313: sub studentbrowser_javascript {
314: unless ($ENV{'request.course.id'}) { return ''; }
315: unless (&Apache::lonnet::allowed('srm',$ENV{'request.course.id'})) {
316: return '';
317: }
318: return (<<'ENDSTDBRW');
319: <script type="text/javascript" language="Javascript" >
320: var stdeditbrowser;
321: function openstdbrowser(formname,uname,udom) {
322: var url = '/adm/pickstudent?';
323: var filter;
324: eval('filter=document.'+formname+'.'+uname+'.value;');
325: if (filter != null) {
326: if (filter != '') {
327: url += 'filter='+filter+'&';
328: }
329: }
330: url += 'form=' + formname + '&unameelement='+uname+
331: '&udomelement='+udom;
1.102 www 332: var title = 'Student_Browser';
1.74 www 333: var options = 'scrollbars=1,resizable=1,menubar=0';
334: options += ',width=700,height=600';
335: stdeditbrowser = open(url,title,options,'1');
336: stdeditbrowser.focus();
337: }
338: </script>
339: ENDSTDBRW
340: }
1.42 matthew 341:
1.74 www 342: sub selectstudent_link {
343: my ($form,$unameele,$udomele)=@_;
344: unless ($ENV{'request.course.id'}) { return ''; }
345: unless (&Apache::lonnet::allowed('srm',$ENV{'request.course.id'})) {
346: return '';
347: }
348: return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele.
1.92 www 349: '","'.$udomele.'");'."'>Select User</a>";
1.91 www 350: }
351:
352: sub coursebrowser_javascript {
353: return (<<'ENDSTDBRW');
354: <script type="text/javascript" language="Javascript" >
355: var stdeditbrowser;
356: function opencrsbrowser(formname,uname,udom) {
357: var url = '/adm/pickcourse?';
358: var filter;
359: if (filter != null) {
360: if (filter != '') {
361: url += 'filter='+filter+'&';
362: }
363: }
364: url += 'form=' + formname + '&cnumelement='+uname+
365: '&cdomelement='+udom;
1.102 www 366: var title = 'Course_Browser';
1.91 www 367: var options = 'scrollbars=1,resizable=1,menubar=0';
368: options += ',width=700,height=600';
369: stdeditbrowser = open(url,title,options,'1');
370: stdeditbrowser.focus();
371: }
372: </script>
373: ENDSTDBRW
374: }
375:
376: sub selectcourse_link {
377: my ($form,$unameele,$udomele)=@_;
378: return "<a href='".'javascript:opencrsbrowser("'.$form.'","'.$unameele.
379: '","'.$udomele.'");'."'>Select Course</a>";
1.74 www 380: }
1.42 matthew 381:
382: ###############################################################
383:
384: =pod
1.36 matthew 385:
386: =item linked_select_forms(...)
387:
388: linked_select_forms returns a string containing a <script></script> block
389: and html for two <select> menus. The select menus will be linked in that
390: changing the value of the first menu will result in new values being placed
391: in the second menu. The values in the select menu will appear in alphabetical
392: order.
393:
394: linked_select_forms takes the following ordered inputs:
395:
396: =over 4
397:
398: =item $formname, the name of the <form> tag
399:
400: =item $middletext, the text which appears between the <select> tags
401:
402: =item $firstdefault, the default value for the first menu
403:
404: =item $firstselectname, the name of the first <select> tag
405:
406: =item $secondselectname, the name of the second <select> tag
407:
408: =item $hashref, a reference to a hash containing the data for the menus.
409:
1.41 ng 410: =back
411:
1.36 matthew 412: Below is an example of such a hash. Only the 'text', 'default', and
413: 'select2' keys must appear as stated. keys(%menu) are the possible
414: values for the first select menu. The text that coincides with the
1.41 ng 415: first menu value is given in $menu{$choice1}->{'text'}. The values
1.36 matthew 416: and text for the second menu are given in the hash pointed to by
417: $menu{$choice1}->{'select2'}.
418:
1.41 ng 419: my %menu = ( A1 => { text =>"Choice A1" ,
1.36 matthew 420: default => "B3",
421: select2 => {
422: B1 => "Choice B1",
423: B2 => "Choice B2",
424: B3 => "Choice B3",
425: B4 => "Choice B4"
426: }
427: },
428: A2 => { text =>"Choice A2" ,
429: default => "C2",
430: select2 => {
431: C1 => "Choice C1",
432: C2 => "Choice C2",
433: C3 => "Choice C3"
434: }
435: },
436: A3 => { text =>"Choice A3" ,
437: default => "D6",
438: select2 => {
439: D1 => "Choice D1",
440: D2 => "Choice D2",
441: D3 => "Choice D3",
442: D4 => "Choice D4",
443: D5 => "Choice D5",
444: D6 => "Choice D6",
445: D7 => "Choice D7"
446: }
447: }
448: );
449:
450: =cut
451:
452: # ------------------------------------------------
453:
454: sub linked_select_forms {
455: my ($formname,
456: $middletext,
457: $firstdefault,
458: $firstselectname,
459: $secondselectname,
460: $hashref
461: ) = @_;
462: my $second = "document.$formname.$secondselectname";
463: my $first = "document.$formname.$firstselectname";
464: # output the javascript to do the changing
465: my $result = '';
466: $result.="<script>\n";
467: $result.="var select2data = new Object();\n";
468: $" = '","';
469: my $debug = '';
470: foreach my $s1 (sort(keys(%$hashref))) {
471: $result.="select2data.d_$s1 = new Object();\n";
472: $result.="select2data.d_$s1.def = new String('".
473: $hashref->{$s1}->{'default'}."');\n";
474: $result.="select2data.d_$s1.values = new Array(";
475: my @s2values = sort(keys( %{ $hashref->{$s1}->{'select2'} } ));
476: $result.="\"@s2values\");\n";
477: $result.="select2data.d_$s1.texts = new Array(";
478: my @s2texts;
479: foreach my $value (@s2values) {
480: push @s2texts, $hashref->{$s1}->{'select2'}->{$value};
481: }
482: $result.="\"@s2texts\");\n";
483: }
484: $"=' ';
485: $result.= <<"END";
486:
487: function select1_changed() {
488: // Determine new choice
489: var newvalue = "d_" + $first.value;
490: // update select2
491: var values = select2data[newvalue].values;
492: var texts = select2data[newvalue].texts;
493: var select2def = select2data[newvalue].def;
494: var i;
495: // out with the old
496: for (i = 0; i < $second.options.length; i++) {
497: $second.options[i] = null;
498: }
499: // in with the nuclear
500: for (i=0;i<values.length; i++) {
501: $second.options[i] = new Option(values[i]);
502: $second.options[i].text = texts[i];
503: if (values[i] == select2def) {
504: $second.options[i].selected = true;
505: }
506: }
507: }
508: </script>
509: END
510: # output the initial values for the selection lists
511: $result .= "<select size=\"1\" name=\"$firstselectname\" onchange=\"select1_changed()\">\n";
512: foreach my $value (sort(keys(%$hashref))) {
513: $result.=" <option value=\"$value\" ";
514: $result.=" selected=\"true\" " if ($value eq $firstdefault);
515: $result.=">$hashref->{$value}->{'text'}</option>\n";
516: }
517: $result .= "</select>\n";
518: my %select2 = %{$hashref->{$firstdefault}->{'select2'}};
519: $result .= $middletext;
520: $result .= "<select size=\"1\" name=\"$secondselectname\">\n";
521: my $seconddefault = $hashref->{$firstdefault}->{'default'};
522: foreach my $value (sort(keys(%select2))) {
523: $result.=" <option value=\"$value\" ";
524: $result.=" selected=\"true\" " if ($value eq $seconddefault);
525: $result.=">$select2{$value}</option>\n";
526: }
527: $result .= "</select>\n";
528: # return $debug;
529: return $result;
530: } # end of sub linked_select_forms {
531:
1.33 matthew 532: ###############################################################
1.44 bowersj2 533:
1.45 matthew 534: =pod
1.44 bowersj2 535:
1.48 bowersj2 536: =item help_open_topic($topic, $text, $stayOnPage, $width, $height)
1.44 bowersj2 537:
538: Returns a string corresponding to an HTML link to the given help $topic, where $topic corresponds to the name of a .tex file in /home/httpd/html/adm/help/tex, with underscores replaced by spaces.
539:
1.48 bowersj2 540: $text will optionally be linked to the same topic, allowing you to link text in addition to the graphic. If you do not want to link text, but wish to specify one of the later parameters, pass an empty string.
541:
1.44 bowersj2 542: $stayOnPage is a value that will be interpreted as a boolean. If true, the link will not open a new window. If false, the link will open a new window using Javascript. (Default is false.)
543:
544: $width and $height are optional numerical parameters that will override the width and height of the popped up window, which may be useful for certain help topics with big pictures included.
545:
546: =cut
547:
548: sub help_open_topic {
1.48 bowersj2 549: my ($topic, $text, $stayOnPage, $width, $height) = @_;
550: $text = "" if (not defined $text);
1.44 bowersj2 551: $stayOnPage = 0 if (not defined $stayOnPage);
1.108 bowersj2 552: if ($ENV{'browser.interface'} eq 'textual' ||
553: $ENV{'environment.remote'} eq 'off' ) {
1.79 www 554: $stayOnPage=1;
555: }
1.44 bowersj2 556: $width = 350 if (not defined $width);
557: $height = 400 if (not defined $height);
558: my $filename = $topic;
559: $filename =~ s/ /_/g;
560:
1.48 bowersj2 561: my $template = "";
562: my $link;
1.44 bowersj2 563:
564: if (!$stayOnPage)
565: {
1.72 bowersj2 566: $link = "javascript:void(open('/adm/help/${filename}.hlp', 'Help_for_$topic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";
1.44 bowersj2 567: }
568: else
569: {
1.48 bowersj2 570: $link = "/adm/help/${filename}.hlp";
571: }
572:
573: # Add the text
574: if ($text ne "")
575: {
1.77 www 576: $template .=
577: "<table bgcolor='#3333AA' cellspacing='1' cellpadding='1' border='0'><tr>".
1.78 www 578: "<td bgcolor='#5555FF'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
1.48 bowersj2 579: }
580:
581: # Add the graphic
582: $template .= <<"ENDTEMPLATE";
1.77 www 583: <a href="$link"><image src="/adm/help/gif/smallHelp.gif" border="0" alt="(Help: $topic)" /></a>
1.44 bowersj2 584: ENDTEMPLATE
1.78 www 585: if ($text ne '') { $template.='</td></tr></table>' };
1.44 bowersj2 586: return $template;
587:
1.106 bowersj2 588: }
589:
590: # This is a quicky function for Latex cheatsheet editing, since it
591: # appears in at least four places
592: sub helpLatexCheatsheet {
593: my $other = shift;
594: my $addOther = '';
595: if ($other) {
596: $addOther = Apache::loncommon::help_open_topic($other, shift,
597: undef, undef, 600) .
598: '</td><td>';
599: }
600: return '<table><tr><td>'.
601: $addOther .
602: &Apache::loncommon::help_open_topic("Greek_Symbols",'Greek Symbols',
603: undef,undef,600)
604: .'</td><td>'.
605: &Apache::loncommon::help_open_topic("Other_Symbols",'Other Symbols',
606: undef,undef,600)
607: .'</td></tr></table>';
1.44 bowersj2 608: }
1.37 matthew 609:
1.45 matthew 610: =pod
611:
1.37 matthew 612: =item csv_translate($text)
613:
614: Translate $text to allow it to be output as a 'comma seperated values'
615: format.
616:
617: =cut
618:
619: sub csv_translate {
620: my $text = shift;
621: $text =~ s/\"/\"\"/g;
622: $text =~ s/\n//g;
623: return $text;
624: }
625:
626: ###############################################################
1.33 matthew 627: ## Home server <option> list generating code ##
628: ###############################################################
1.35 matthew 629: #-------------------------------------------
630:
1.45 matthew 631: =pod
632:
1.35 matthew 633: =item get_domains()
634:
635: Returns an array containing each of the domains listed in the hosts.tab
636: file.
637:
638: =cut
639:
640: #-------------------------------------------
1.34 matthew 641: sub get_domains {
642: # The code below was stolen from "The Perl Cookbook", p 102, 1st ed.
643: my @domains;
644: my %seen;
645: foreach (sort values(%Apache::lonnet::hostdom)) {
646: push (@domains,$_) unless $seen{$_}++;
647: }
648: return @domains;
649: }
1.88 www 650:
651: #-------------------------------------------
652:
653: =pod
654:
655: =item select_form($defdom,$name,%hash)
656:
657: Returns a string containing a <select name='$name' size='1'> form to
658: allow a user to select options from a hash option_name => displayed text.
659: See lonrights.pm for an example invocation and use.
660:
661: =cut
662:
663: #-------------------------------------------
664: sub select_form {
665: my ($def,$name,%hash) = @_;
666: my $selectform = "<select name=\"$name\" size=\"1\">\n";
1.89 www 667: foreach (sort keys %hash) {
1.88 www 668: $selectform.="<option value=\"$_\" ".
669: ($_ eq $def ? 'selected' : '').
670: ">".$hash{$_}."</option>\n";
671: }
672: $selectform.="</select>";
673: return $selectform;
674: }
675:
1.34 matthew 676:
1.35 matthew 677: #-------------------------------------------
678:
1.45 matthew 679: =pod
680:
1.90 www 681: =item select_dom_form($defdom,$name,$includeempty)
1.35 matthew 682:
683: Returns a string containing a <select name='$name' size='1'> form to
684: allow a user to select the domain to preform an operation in.
685: See loncreateuser.pm for an example invocation and use.
686:
1.90 www 687: If the $includeempty flag is set, it also includes an empty choice ("no domain
688: selected");
689:
1.35 matthew 690: =cut
691:
692: #-------------------------------------------
1.34 matthew 693: sub select_dom_form {
1.90 www 694: my ($defdom,$name,$includeempty) = @_;
1.34 matthew 695: my @domains = get_domains();
1.90 www 696: if ($includeempty) { @domains=('',@domains); }
1.34 matthew 697: my $selectdomain = "<select name=\"$name\" size=\"1\">\n";
698: foreach (@domains) {
699: $selectdomain.="<option value=\"$_\" ".
700: ($_ eq $defdom ? 'selected' : '').
701: ">$_</option>\n";
702: }
703: $selectdomain.="</select>";
704: return $selectdomain;
705: }
706:
1.35 matthew 707: #-------------------------------------------
708:
1.45 matthew 709: =pod
710:
1.52 matthew 711: =item get_library_servers($domain)
1.35 matthew 712:
713: Returns a hash which contains keys like '103l3' and values like
714: 'kirk.lite.msu.edu'. All of the keys will be for machines in the
715: given $domain.
716:
717: =cut
718:
719: #-------------------------------------------
1.52 matthew 720: sub get_library_servers {
1.33 matthew 721: my $domain = shift;
1.52 matthew 722: my %library_servers;
1.33 matthew 723: foreach (keys(%Apache::lonnet::libserv)) {
724: if ($Apache::lonnet::hostdom{$_} eq $domain) {
1.52 matthew 725: $library_servers{$_} = $Apache::lonnet::hostname{$_};
1.33 matthew 726: }
727: }
1.52 matthew 728: return %library_servers;
1.33 matthew 729: }
730:
1.35 matthew 731: #-------------------------------------------
732:
1.45 matthew 733: =pod
734:
1.35 matthew 735: =item home_server_option_list($domain)
736:
737: returns a string which contains an <option> list to be used in a
738: <select> form input. See loncreateuser.pm for an example.
739:
740: =cut
741:
742: #-------------------------------------------
1.33 matthew 743: sub home_server_option_list {
744: my $domain = shift;
1.52 matthew 745: my %servers = &get_library_servers($domain);
1.33 matthew 746: my $result = '';
747: foreach (sort keys(%servers)) {
748: $result.=
749: '<option value="'.$_.'">'.$_.' '.$servers{$_}."</option>\n";
750: }
751: return $result;
752: }
753: ###############################################################
754: ## End of home server <option> list generating code ##
755: ###############################################################
1.87 matthew 756:
757: ###############################################################
758: ###############################################################
759:
760: =pod
761:
762: =item &decode_user_agent()
763:
764: Inputs: $r
765:
766: Outputs:
767:
768: =over 4
769:
770: =item $httpbrowser
771:
772: =item $clientbrowser
773:
774: =item $clientversion
775:
776: =item $clientmathml
777:
778: =item $clientunicode
779:
780: =item $clientos
781:
782: =back
783:
784: =cut
785:
786: ###############################################################
787: ###############################################################
788: sub decode_user_agent {
789: my @browsertype=split(/\&/,$Apache::lonnet::perlvar{"lonBrowsDet"});
790: my %mathcap=split(/\&/,$$Apache::lonnet::perlvar{"lonMathML"});
791: my $httpbrowser=$ENV{"HTTP_USER_AGENT"};
792: my $clientbrowser='unknown';
793: my $clientversion='0';
794: my $clientmathml='';
795: my $clientunicode='0';
796: for (my $i=0;$i<=$#browsertype;$i++) {
797: my ($bname,$match,$notmatch,$vreg,$minv,$univ)=split(/\:/,$browsertype[$i]);
798: if (($httpbrowser=~/$match/i) && ($httpbrowser!~/$notmatch/i)) {
799: $clientbrowser=$bname;
800: $httpbrowser=~/$vreg/i;
801: $clientversion=$1;
802: $clientmathml=($clientversion>=$minv);
803: $clientunicode=($clientversion>=$univ);
804: }
805: }
806: my $clientos='unknown';
807: if (($httpbrowser=~/linux/i) ||
808: ($httpbrowser=~/unix/i) ||
809: ($httpbrowser=~/ux/i) ||
810: ($httpbrowser=~/solaris/i)) { $clientos='unix'; }
811: if (($httpbrowser=~/vax/i) ||
812: ($httpbrowser=~/vms/i)) { $clientos='vms'; }
813: if ($httpbrowser=~/next/i) { $clientos='next'; }
814: if (($httpbrowser=~/mac/i) ||
815: ($httpbrowser=~/powerpc/i)) { $clientos='mac'; }
816: if ($httpbrowser=~/win/i) { $clientos='win'; }
817: if ($httpbrowser=~/embed/i) { $clientos='pda'; }
818: return ($httpbrowser,$clientbrowser,$clientversion,$clientmathml,
819: $clientunicode,$clientos,);
820: }
821:
822: ###############################################################
823: ###############################################################
824:
1.32 matthew 825:
826: ###############################################################
827: ## Authentication changing form generation subroutines ##
828: ###############################################################
829: ##
830: ## All of the authform_xxxxxxx subroutines take their inputs in a
831: ## hash, and have reasonable default values.
832: ##
833: ## formname = the name given in the <form> tag.
1.35 matthew 834: #-------------------------------------------
835:
1.45 matthew 836: =pod
837:
1.35 matthew 838: =item authform_xxxxxx
839:
840: The authform_xxxxxx subroutines provide javascript and html forms which
841: handle some of the conveniences required for authentication forms.
842: This is not an optimal method, but it works.
843:
844: See loncreateuser.pm for invocation and use examples.
845:
846: =over 4
847:
848: =item authform_header
849:
850: =item authform_authorwarning
851:
852: =item authform_nochange
853:
854: =item authform_kerberos
855:
856: =item authform_internal
857:
858: =item authform_filesystem
859:
860: =back
861:
862: =cut
863:
864: #-------------------------------------------
1.32 matthew 865: sub authform_header{
866: my %in = (
867: formname => 'cu',
1.80 albertel 868: kerb_def_dom => '',
1.32 matthew 869: @_,
870: );
871: $in{'formname'} = 'document.' . $in{'formname'};
872: my $result='';
1.80 albertel 873:
874: #---------------------------------------------- Code for upper case translation
875: my $Javascript_toUpperCase;
876: unless ($in{kerb_def_dom}) {
877: $Javascript_toUpperCase =<<"END";
878: switch (choice) {
879: case 'krb': currentform.elements[choicearg].value =
880: currentform.elements[choicearg].value.toUpperCase();
881: break;
882: default:
883: }
884: END
885: } else {
886: $Javascript_toUpperCase = "";
887: }
888:
1.32 matthew 889: $result.=<<"END";
890: var current = new Object();
891: current.radiovalue = 'nochange';
892: current.argfield = null;
893:
894: function changed_radio(choice,currentform) {
895: var choicearg = choice + 'arg';
896: // If a radio button in changed, we need to change the argfield
897: if (current.radiovalue != choice) {
898: current.radiovalue = choice;
899: if (current.argfield != null) {
900: currentform.elements[current.argfield].value = '';
901: }
902: if (choice == 'nochange') {
903: current.argfield = null;
904: } else {
905: current.argfield = choicearg;
906: switch(choice) {
907: case 'krb':
908: currentform.elements[current.argfield].value =
909: "$in{'kerb_def_dom'}";
910: break;
911: default:
912: break;
913: }
914: }
915: }
916: return;
917: }
1.22 www 918:
1.32 matthew 919: function changed_text(choice,currentform) {
920: var choicearg = choice + 'arg';
921: if (currentform.elements[choicearg].value !='') {
1.80 albertel 922: $Javascript_toUpperCase
1.32 matthew 923: // clear old field
924: if ((current.argfield != choicearg) && (current.argfield != null)) {
925: currentform.elements[current.argfield].value = '';
926: }
927: current.argfield = choicearg;
928: }
929: set_auth_radio_buttons(choice,currentform);
930: return;
1.20 www 931: }
1.32 matthew 932:
933: function set_auth_radio_buttons(newvalue,currentform) {
934: var i=0;
935: while (i < currentform.login.length) {
936: if (currentform.login[i].value == newvalue) { break; }
937: i++;
938: }
939: if (i == currentform.login.length) {
940: return;
941: }
942: current.radiovalue = newvalue;
943: currentform.login[i].checked = true;
944: return;
945: }
946: END
947: return $result;
948: }
949:
950: sub authform_authorwarning{
951: my $result='';
952: $result=<<"END";
953: <i>As a general rule, only authors or co-authors should be filesystem
954: authenticated (which allows access to the server filesystem).</i>
955: END
956: return $result;
957: }
958:
959: sub authform_nochange{
960: my %in = (
961: formname => 'document.cu',
962: kerb_def_dom => 'MSU.EDU',
963: @_,
964: );
965: my $result='';
966: $result.=<<"END";
967: <input type="radio" name="login" value="nochange" checked="checked"
1.57 albertel 968: onclick="javascript:changed_radio('nochange',$in{'formname'});" />
1.32 matthew 969: Do not change login data
970: END
971: return $result;
972: }
973:
974: sub authform_kerberos{
975: my %in = (
976: formname => 'document.cu',
977: kerb_def_dom => 'MSU.EDU',
1.80 albertel 978: kerb_def_auth => 'krb4',
1.32 matthew 979: @_,
980: );
981: my $result='';
1.80 albertel 982: my $check4;
983: my $check5;
984: if ($in{'kerb_def_auth'} eq 'krb5') {
985: $check5 = " checked=\"on\"";
986: } else {
987: $check4 = " checked=\"on\"";
988: }
1.32 matthew 989: $result.=<<"END";
990: <input type="radio" name="login" value="krb"
991: onclick="javascript:changed_radio('krb',$in{'formname'});"
1.57 albertel 992: onchange="javascript:changed_radio('krb',$in{'formname'});" />
1.32 matthew 993: Kerberos authenticated with domain
1.80 albertel 994: <input type="text" size="10" name="krbarg" value="$in{'kerb_def_dom'}"
1.57 albertel 995: onchange="javascript:changed_text('krb',$in{'formname'});" />
1.80 albertel 996: <input type="radio" name="krbver" value="4" $check4 />Version 4
997: <input type="radio" name="krbver" value="5" $check5 />Version 5
1.32 matthew 998: END
999: return $result;
1000: }
1001:
1002: sub authform_internal{
1003: my %args = (
1004: formname => 'document.cu',
1005: kerb_def_dom => 'MSU.EDU',
1006: @_,
1007: );
1008: my $result='';
1009: $result.=<<"END";
1010: <input type="radio" name="login" value="int"
1011: onchange="javascript:changed_radio('int',$args{'formname'});"
1.57 albertel 1012: onclick="javascript:changed_radio('int',$args{'formname'});" />
1.32 matthew 1013: Internally authenticated (with initial password
1014: <input type="text" size="10" name="intarg" value=""
1.75 www 1015: onchange="javascript:changed_text('int',$args{'formname'});" />)
1.32 matthew 1016: END
1017: return $result;
1018: }
1019:
1020: sub authform_local{
1021: my %in = (
1022: formname => 'document.cu',
1023: kerb_def_dom => 'MSU.EDU',
1024: @_,
1025: );
1026: my $result='';
1027: $result.=<<"END";
1028: <input type="radio" name="login" value="loc"
1029: onchange="javascript:changed_radio('loc',$in{'formname'});"
1.57 albertel 1030: onclick="javascript:changed_radio('loc',$in{'formname'});" />
1.32 matthew 1031: Local Authentication with argument
1032: <input type="text" size="10" name="locarg" value=""
1.57 albertel 1033: onchange="javascript:changed_text('loc',$in{'formname'});" />
1.32 matthew 1034: END
1035: return $result;
1036: }
1037:
1038: sub authform_filesystem{
1039: my %in = (
1040: formname => 'document.cu',
1041: kerb_def_dom => 'MSU.EDU',
1042: @_,
1043: );
1044: my $result='';
1045: $result.=<<"END";
1046: <input type="radio" name="login" value="fsys"
1047: onchange="javascript:changed_radio('fsys',$in{'formname'});"
1.57 albertel 1048: onclick="javascript:changed_radio('fsys',$in{'formname'});" />
1.32 matthew 1049: Filesystem authenticated (with initial password
1050: <input type="text" size="10" name="fsysarg" value=""
1.75 www 1051: onchange="javascript:changed_text('fsys',$in{'formname'});">)
1.32 matthew 1052: END
1053: return $result;
1054: }
1055:
1056: ###############################################################
1057: ## End Authentication changing form generation functions ##
1.80 albertel 1058: ###############################################################
1059:
1060: ###############################################################
1061: ## Get Authentication Defaults for Domain ##
1062: ###############################################################
1063: ##
1064: ## Returns default authentication type and an associated argument
1065: ## as listed in file domain.tab
1066: ##
1067: #-------------------------------------------
1068:
1069: =pod
1070:
1071: =item get_auth_defaults
1072:
1073: get_auth_defaults($target_domain) returns the default authentication
1074: type and an associated argument (initial password or a kerberos domain).
1075: These values are stored in lonTabs/domain.tab
1076:
1077: ($def_auth, $def_arg) = &get_auth_defaults($target_domain);
1078:
1079: If target_domain is not found in domain.tab, returns nothing ('').
1080:
1081: =over 4
1082:
1083: =item get_auth_defaults
1084:
1085: =back
1086:
1087: =cut
1088:
1089: #-------------------------------------------
1090: sub get_auth_defaults {
1091: my $domain=shift;
1092: return ($Apache::lonnet::domain_auth_def{$domain},$Apache::lonnet::domain_auth_arg_def{$domain});
1093: }
1094: ###############################################################
1095: ## End Get Authentication Defaults for Domain ##
1096: ###############################################################
1097:
1098: ###############################################################
1099: ## Get Kerberos Defaults for Domain ##
1100: ###############################################################
1101: ##
1102: ## Returns default kerberos version and an associated argument
1103: ## as listed in file domain.tab. If not listed, provides
1104: ## appropriate default domain and kerberos version.
1105: ##
1106: #-------------------------------------------
1107:
1108: =pod
1109:
1110: =item get_kerberos_defaults
1111:
1112: get_kerberos_defaults($target_domain) returns the default kerberos
1113: version and domain. If not found in domain.tabs, it defaults to
1114: version 4 and the domain of the server.
1115:
1116: ($def_version, $def_krb_domain) = &get_kerberos_defaults($target_domain);
1117:
1118: =over 4
1119:
1120: =item get_kerberos_defaults
1121:
1122: =back
1123:
1124: =cut
1125:
1126: #-------------------------------------------
1127: sub get_kerberos_defaults {
1128: my $domain=shift;
1129: my ($krbdef,$krbdefdom) =
1130: &Apache::loncommon::get_auth_defaults($domain);
1131: unless ($krbdef =~/^krb/ && $krbdefdom) {
1132: $ENV{'SERVER_NAME'}=~/(\w+\.\w+)$/;
1133: my $krbdefdom=$1;
1134: $krbdefdom=~tr/a-z/A-Z/;
1135: $krbdef = "krb4";
1136: }
1137: return ($krbdef,$krbdefdom);
1138: }
1139: ###############################################################
1140: ## End Get Kerberos Defaults for Domain ##
1.32 matthew 1141: ###############################################################
1142:
1.46 matthew 1143: ###############################################################
1144: ## Thesaurus Functions ##
1145: ###############################################################
1.20 www 1146:
1.46 matthew 1147: =pod
1.20 www 1148:
1.46 matthew 1149: =item initialize_keywords
1150:
1151: Initializes the package variable %Keywords if it is empty. Uses the
1152: package variable $thesaurus_db_file.
1153:
1154: =cut
1155:
1156: ###################################################
1157:
1158: sub initialize_keywords {
1159: return 1 if (scalar keys(%Keywords));
1160: # If we are here, %Keywords is empty, so fill it up
1161: # Make sure the file we need exists...
1162: if (! -e $thesaurus_db_file) {
1163: &Apache::lonnet::logthis("Attempt to access $thesaurus_db_file".
1164: " failed because it does not exist");
1165: return 0;
1166: }
1167: # Set up the hash as a database
1168: my %thesaurus_db;
1169: if (! tie(%thesaurus_db,'GDBM_File',
1.53 albertel 1170: $thesaurus_db_file,&GDBM_READER(),0640)){
1.46 matthew 1171: &Apache::lonnet::logthis("Could not tie \%thesaurus_db to ".
1172: $thesaurus_db_file);
1173: return 0;
1174: }
1175: # Get the average number of appearances of a word.
1176: my $avecount = $thesaurus_db{'average.count'};
1177: # Put keywords (those that appear > average) into %Keywords
1178: while (my ($word,$data)=each (%thesaurus_db)) {
1179: my ($count,undef) = split /:/,$data;
1180: $Keywords{$word}++ if ($count > $avecount);
1181: }
1182: untie %thesaurus_db;
1183: # Remove special values from %Keywords.
1184: foreach ('total.count','average.count') {
1185: delete($Keywords{$_}) if (exists($Keywords{$_}));
1186: }
1187: return 1;
1188: }
1189:
1190: ###################################################
1191:
1192: =pod
1193:
1194: =item keyword($word)
1195:
1196: Returns true if $word is a keyword. A keyword is a word that appears more
1197: than the average number of times in the thesaurus database. Calls
1198: &initialize_keywords
1199:
1200: =cut
1201:
1202: ###################################################
1.20 www 1203:
1204: sub keyword {
1.46 matthew 1205: return if (!&initialize_keywords());
1206: my $word=lc(shift());
1207: $word=~s/\W//g;
1208: return exists($Keywords{$word});
1.20 www 1209: }
1.46 matthew 1210:
1211: ###############################################################
1212:
1213: =pod
1.20 www 1214:
1.46 matthew 1215: =item get_related_words
1216:
1217: Look up a word in the thesaurus. Takes a scalar arguement and returns
1218: an array of words. If the keyword is not in the thesaurus, an empty array
1219: will be returned. The order of the words returned is determined by the
1220: database which holds them.
1221:
1222: Uses global $thesaurus_db_file.
1223:
1224: =cut
1225:
1226: ###############################################################
1227: sub get_related_words {
1228: my $keyword = shift;
1229: my %thesaurus_db;
1230: if (! -e $thesaurus_db_file) {
1231: &Apache::lonnet::logthis("Attempt to access $thesaurus_db_file ".
1232: "failed because the file does not exist");
1233: return ();
1234: }
1235: if (! tie(%thesaurus_db,'GDBM_File',
1.53 albertel 1236: $thesaurus_db_file,&GDBM_READER(),0640)){
1.46 matthew 1237: return ();
1238: }
1239: my @Words=();
1240: if (exists($thesaurus_db{$keyword})) {
1241: $_ = $thesaurus_db{$keyword};
1242: (undef,@Words) = split/:/; # The first element is the number of times
1243: # the word appears. We do not need it now.
1244: for (my $i=0;$i<=$#Words;$i++) {
1245: ($Words[$i],undef)= split/\,/,$Words[$i];
1.20 www 1246: }
1247: }
1.46 matthew 1248: untie %thesaurus_db;
1249: return @Words;
1.14 harris41 1250: }
1.46 matthew 1251:
1252: ###############################################################
1253: ## End Thesaurus Functions ##
1254: ###############################################################
1.61 www 1255:
1256: # -------------------------------------------------------------- Plaintext name
1.81 albertel 1257: =pod
1258:
1259: =item plainname($uname,$udom)
1260:
1261: Gets a users name and returns it as a string in
1262: "first middle last generation"
1263: form
1264:
1265: =cut
1.61 www 1266:
1.81 albertel 1267: ###############################################################
1.61 www 1268: sub plainname {
1269: my ($uname,$udom)=@_;
1270: my %names=&Apache::lonnet::get('environment',
1271: ['firstname','middlename','lastname','generation'],
1272: $udom,$uname);
1.62 www 1273: my $name=$names{'firstname'}.' '.$names{'middlename'}.' '.
1.61 www 1274: $names{'lastname'}.' '.$names{'generation'};
1.62 www 1275: $name=~s/\s+$//;
1276: $name=~s/\s+/ /g;
1277: return $name;
1.61 www 1278: }
1.66 www 1279:
1280: # -------------------------------------------------------------------- Nickname
1.81 albertel 1281: =pod
1282:
1283: =item nickname($uname,$udom)
1284:
1285: Gets a users name and returns it as a string as
1286:
1287: ""nickname""
1.66 www 1288:
1.81 albertel 1289: if the user has a nickname or
1290:
1291: "first middle last generation"
1292:
1293: if the user does not
1294:
1295: =cut
1.66 www 1296:
1297: sub nickname {
1298: my ($uname,$udom)=@_;
1299: my %names=&Apache::lonnet::get('environment',
1300: ['nickname','firstname','middlename','lastname','generation'],$udom,$uname);
1.68 albertel 1301: my $name=$names{'nickname'};
1.66 www 1302: if ($name) {
1303: $name='"'.$name.'"';
1304: } else {
1305: $name=$names{'firstname'}.' '.$names{'middlename'}.' '.
1306: $names{'lastname'}.' '.$names{'generation'};
1307: $name=~s/\s+$//;
1308: $name=~s/\s+/ /g;
1309: }
1310: return $name;
1311: }
1312:
1.61 www 1313:
1314: # ------------------------------------------------------------------ Screenname
1.81 albertel 1315:
1316: =pod
1317:
1318: =item screenname($uname,$udom)
1319:
1320: Gets a users screenname and returns it as a string
1321:
1322: =cut
1.61 www 1323:
1324: sub screenname {
1325: my ($uname,$udom)=@_;
1326: my %names=
1327: &Apache::lonnet::get('environment',['screenname'],$udom,$uname);
1.68 albertel 1328: return $names{'screenname'};
1.62 www 1329: }
1330:
1331: # ------------------------------------------------------------- Message Wrapper
1332:
1333: sub messagewrapper {
1334: my ($link,$un,$do)=@_;
1335: return
1336: "<a href='/adm/email?compose=individual&recname=$un&recdom=$do'>$link</a>";
1.74 www 1337: }
1338: # --------------------------------------------------------------- Notes Wrapper
1339:
1340: sub noteswrapper {
1341: my ($link,$un,$do)=@_;
1342: return
1343: "<a href='/adm/email?recordftf=retrieve&recname=$un&recdom=$do'>$link</a>";
1.62 www 1344: }
1345: # ------------------------------------------------------------- Aboutme Wrapper
1346:
1347: sub aboutmewrapper {
1.69 matthew 1348: my ($link,$username,$domain)=@_;
1349: return "<a href='/adm/$domain/$username/aboutme'>$link</a>";
1.62 www 1350: }
1351:
1352: # ------------------------------------------------------------ Syllabus Wrapper
1353:
1354:
1355: sub syllabuswrapper {
1.109 ! matthew 1356: my ($linktext,$coursedir,$domain,$fontcolor)=@_;
! 1357: if ($fontcolor) {
! 1358: $linktext='<font color="'.$fontcolor.'">'.$linktext.'</font>';
! 1359: }
! 1360: return "<a href='/public/$domain/$coursedir/syllabus'>$linktext</a>";
1.61 www 1361: }
1.14 harris41 1362:
1363: # ---------------------------------------------------------------- Language IDs
1364: sub languageids {
1.16 harris41 1365: return sort(keys(%language));
1.14 harris41 1366: }
1367:
1368: # -------------------------------------------------------- Language Description
1369: sub languagedescription {
1.16 harris41 1370: return $language{shift(@_)};
1.97 www 1371: }
1372:
1373: # ----------------------------------------------------------- Display Languages
1374: # returns a hash with all desired display languages
1375: #
1376:
1377: sub display_languages {
1378: my %languages=();
1379: if ($ENV{'environment.languages'}) {
1380: foreach (split(/\s*(\,|\;|\:)\s*/,$ENV{'environment.languages'})) {
1.104 www 1381: $languages{$_}=1;
1382: }
1383: }
1384: if ($ENV{'course.'.$ENV{'request.course.id'}.'.languages'}) {
1385: foreach (split(/\s*(\,|\;|\:)\s*/,
1386: $ENV{'course.'.$ENV{'request.course.id'}.'.languages'})) {
1.97 www 1387: $languages{$_}=1;
1388: }
1389: }
1390: &get_unprocessed_cgi($ENV{'QUERY_STRING'},['displaylanguage']);
1391: if ($ENV{'form.displaylanguage'}) {
1392: foreach (split(/\s*(\,|\;|\:)\s*/,$ENV{'form.displaylanguage'})) {
1393: $languages{$_}=1;
1394: }
1395: }
1396: return %languages;
1.14 harris41 1397: }
1398:
1399: # --------------------------------------------------------------- Copyright IDs
1400: sub copyrightids {
1.16 harris41 1401: return sort(keys(%cprtag));
1.14 harris41 1402: }
1403:
1404: # ------------------------------------------------------- Copyright Description
1405: sub copyrightdescription {
1.16 harris41 1406: return $cprtag{shift(@_)};
1.14 harris41 1407: }
1408:
1409: # ------------------------------------------------------------- File Categories
1410: sub filecategories {
1.41 ng 1411: return sort(keys(%category_extensions));
1.15 harris41 1412: }
1.14 harris41 1413:
1.17 harris41 1414: # -------------------------------------- File Types within a specified category
1.15 harris41 1415: sub filecategorytypes {
1.41 ng 1416: return @{$category_extensions{lc($_[0])}};
1.14 harris41 1417: }
1418:
1419: # ------------------------------------------------------------------ File Types
1420: sub fileextensions {
1.16 harris41 1421: return sort(keys(%fe));
1.14 harris41 1422: }
1423:
1424: # ------------------------------------------------------------- Embedding Style
1425: sub fileembstyle {
1.16 harris41 1426: return $fe{lc(shift(@_))};
1.14 harris41 1427: }
1428:
1429: # ------------------------------------------------------------ Description Text
1430: sub filedescription {
1.16 harris41 1431: return $fd{lc(shift(@_))};
1432: }
1433:
1434: # ------------------------------------------------------------ Description Text
1435: sub filedescriptionex {
1436: my $ex=shift;
1437: return '.'.$ex.' '.$fd{lc($ex)};
1.12 harris41 1438: }
1.1 albertel 1439:
1.40 ng 1440: # ---- Retrieve attempts by students
1441: # input
1442: # $symb - problem including path
1443: # $username,$domain - that of the student
1444: # $course - course name
1445: # $getattempt - leave blank if want all attempts, else put something.
1.43 ng 1446: # $regexp - regular expression. If string matches regexp send to
1447: # $gradesub - routine that process the string if it matches regexp
1.40 ng 1448: #
1449: # output
1450: # formatted as a table all the attempts, if any.
1451: #
1.1 albertel 1452: sub get_previous_attempt {
1.43 ng 1453: my ($symb,$username,$domain,$course,$getattempt,$regexp,$gradesub)=@_;
1.1 albertel 1454: my $prevattempts='';
1.43 ng 1455: no strict 'refs';
1.1 albertel 1456: if ($symb) {
1.3 albertel 1457: my (%returnhash)=
1458: &Apache::lonnet::restore($symb,$course,$domain,$username);
1.1 albertel 1459: if ($returnhash{'version'}) {
1460: my %lasthash=();
1461: my $version;
1462: for ($version=1;$version<=$returnhash{'version'};$version++) {
1.19 harris41 1463: foreach (sort(split(/\:/,$returnhash{$version.':keys'}))) {
1.1 albertel 1464: $lasthash{$_}=$returnhash{$version.':'.$_};
1.19 harris41 1465: }
1.1 albertel 1466: }
1.43 ng 1467: $prevattempts='<table border="0" width="100%"><tr><td bgcolor="#777777">';
1.40 ng 1468: $prevattempts.='<table border="0" width="100%"><tr bgcolor="#e6ffff"><td>History</td>';
1.16 harris41 1469: foreach (sort(keys %lasthash)) {
1.31 albertel 1470: my ($ign,@parts) = split(/\./,$_);
1.41 ng 1471: if ($#parts > 0) {
1.31 albertel 1472: my $data=$parts[-1];
1473: pop(@parts);
1.40 ng 1474: $prevattempts.='<td>Part '.join('.',@parts).'<br />'.$data.' </td>';
1.31 albertel 1475: } else {
1.41 ng 1476: if ($#parts == 0) {
1477: $prevattempts.='<th>'.$parts[0].'</th>';
1478: } else {
1479: $prevattempts.='<th>'.$ign.'</th>';
1480: }
1.31 albertel 1481: }
1.16 harris41 1482: }
1.40 ng 1483: if ($getattempt eq '') {
1484: for ($version=1;$version<=$returnhash{'version'};$version++) {
1485: $prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Transaction '.$version.'</td>';
1486: foreach (sort(keys %lasthash)) {
1487: my $value;
1488: if ($_ =~ /timestamp/) {
1489: $value=scalar(localtime($returnhash{$version.':'.$_}));
1490: } else {
1491: $value=$returnhash{$version.':'.$_};
1492: }
1493: $prevattempts.='<td>'.$value.' </td>';
1494: }
1495: }
1.1 albertel 1496: }
1.40 ng 1497: $prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Current</td>';
1.16 harris41 1498: foreach (sort(keys %lasthash)) {
1.5 albertel 1499: my $value;
1500: if ($_ =~ /timestamp/) {
1501: $value=scalar(localtime($lasthash{$_}));
1502: } else {
1503: $value=$lasthash{$_};
1504: }
1.49 ng 1505: if ($_ =~/$regexp$/ && (defined &$gradesub)) {$value = &$gradesub($value)}
1.40 ng 1506: $prevattempts.='<td>'.$value.' </td>';
1.16 harris41 1507: }
1.40 ng 1508: $prevattempts.='</tr></table></td></tr></table>';
1.1 albertel 1509: } else {
1510: $prevattempts='Nothing submitted - no attempts.';
1511: }
1512: } else {
1513: $prevattempts='No data.';
1514: }
1.10 albertel 1515: }
1516:
1.107 albertel 1517: sub relative_to_absolute {
1518: my ($url,$output)=@_;
1519: my $parser=HTML::TokeParser->new(\$output);
1520: my $token;
1521: my $thisdir=$url;
1522: my @rlinks=();
1523: while ($token=$parser->get_token) {
1524: if ($token->[0] eq 'S') {
1525: if ($token->[1] eq 'a') {
1526: if ($token->[2]->{'href'}) {
1527: $rlinks[$#rlinks+1]=$token->[2]->{'href'};
1528: }
1529: } elsif ($token->[1] eq 'img' || $token->[1] eq 'embed' ) {
1530: $rlinks[$#rlinks+1]=$token->[2]->{'src'};
1531: } elsif ($token->[1] eq 'base') {
1532: $thisdir=$token->[2]->{'href'};
1533: }
1534: }
1535: }
1536: $thisdir=~s-/[^/]*$--;
1537: foreach (@rlinks) {
1538: unless (($_=~/^http:\/\//i) ||
1539: ($_=~/^\//) ||
1540: ($_=~/^javascript:/i) ||
1541: ($_=~/^mailto:/i) ||
1542: ($_=~/^\#/)) {
1543: my $newlocation=&Apache::lonnet::hreflocation($thisdir,$_);
1544: $output=~s/(\"|\'|\=\s*)$_(\"|\'|\s|\>)/$1$newlocation$2/;
1545: }
1546: }
1547: # -------------------------------------------------- Deal with Applet codebases
1548: $output=~s/(\<applet[^\>]+)(codebase\=[^\S\>]+)*([^\>]*)\>/$1.($2?$2:' codebase="'.$thisdir.'"').$3.'>'/gei;
1549: return $output;
1550: }
1551:
1.10 albertel 1552: sub get_student_view {
1.64 sakharuk 1553: my ($symb,$username,$domain,$courseid,$target) = @_;
1.10 albertel 1554: my ($map,$id,$feedurl) = split(/___/,$symb);
1555: my (%old,%moreenv);
1556: my @elements=('symb','courseid','domain','username');
1557: foreach my $element (@elements) {
1558: $old{$element}=$ENV{'form.grade_'.$element};
1559: $moreenv{'form.grade_'.$element}=eval '$'.$element #'
1560: }
1.64 sakharuk 1561: if ($target eq 'tex') {$moreenv{'form.grade_target'} = 'tex';}
1.11 albertel 1562: &Apache::lonnet::appenv(%moreenv);
1.107 albertel 1563: $feedurl=&Apache::lonnet::clutter($feedurl);
1564: my $userview=&Apache::lonnet::ssi_body($feedurl);
1.11 albertel 1565: &Apache::lonnet::delenv('form.grade_');
1566: foreach my $element (@elements) {
1567: $ENV{'form.grade_'.$element}=$old{$element};
1568: }
1569: $userview=~s/\<body[^\>]*\>//gi;
1570: $userview=~s/\<\/body\>//gi;
1571: $userview=~s/\<html\>//gi;
1572: $userview=~s/\<\/html\>//gi;
1573: $userview=~s/\<head\>//gi;
1574: $userview=~s/\<\/head\>//gi;
1575: $userview=~s/action\s*\=/would_be_action\=/gi;
1.107 albertel 1576: $userview=&relative_to_absolute($feedurl,$userview);
1.11 albertel 1577: return $userview;
1578: }
1579:
1580: sub get_student_answers {
1.100 sakharuk 1581: my ($symb,$username,$domain,$courseid,%form) = @_;
1.11 albertel 1582: my ($map,$id,$feedurl) = split(/___/,$symb);
1583: my (%old,%moreenv);
1584: my @elements=('symb','courseid','domain','username');
1585: foreach my $element (@elements) {
1586: $old{$element}=$ENV{'form.grade_'.$element};
1587: $moreenv{'form.grade_'.$element}=eval '$'.$element #'
1588: }
1589: $moreenv{'form.grade_target'}='answer';
1.10 albertel 1590: &Apache::lonnet::appenv(%moreenv);
1.100 sakharuk 1591: my $userview=&Apache::lonnet::ssi('/res/'.$feedurl,%form);
1.10 albertel 1592: &Apache::lonnet::delenv('form.grade_');
1593: foreach my $element (@elements) {
1594: $ENV{'form.grade_'.$element}=$old{$element};
1595: }
1596: return $userview;
1.1 albertel 1597: }
1.37 matthew 1598:
1599: ###############################################
1.51 www 1600:
1601:
1602: sub timehash {
1603: my @ltime=localtime(shift);
1604: return ( 'seconds' => $ltime[0],
1605: 'minutes' => $ltime[1],
1606: 'hours' => $ltime[2],
1607: 'day' => $ltime[3],
1608: 'month' => $ltime[4]+1,
1609: 'year' => $ltime[5]+1900,
1610: 'weekday' => $ltime[6],
1611: 'dayyear' => $ltime[7]+1,
1612: 'dlsav' => $ltime[8] );
1613: }
1614:
1615: sub maketime {
1616: my %th=@_;
1617: return POSIX::mktime(
1618: ($th{'seconds'},$th{'minutes'},$th{'hours'},
1619: $th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,$th{'dlsav'}));
1620: }
1621:
1.70 www 1622:
1623: #########################################
1624: #
1625: # Retro-fixing of un-backward-compatible time format
1626:
1627: sub unsqltime {
1628: my $timestamp=shift;
1629: if ($timestamp=~/^(\d+)\-(\d+)\-(\d+)\s+(\d+)\:(\d+)\:(\d+)$/) {
1630: $timestamp=&maketime(
1631: 'year'=>$1,'month'=>$2,'day'=>$3,
1632: 'hours'=>$4,'minutes'=>$5,'seconds'=>$6);
1633: }
1634: return $timestamp;
1635: }
1636:
1637: #########################################
1.51 www 1638:
1639: sub findallcourses {
1640: my %courses=();
1641: my $now=time;
1642: foreach (keys %ENV) {
1643: if ($_=~/^user\.role\.\w+\.\/(\w+)\/(\w+)/) {
1644: my ($starttime,$endtime)=$ENV{$_};
1645: my $active=1;
1646: if ($starttime) {
1647: if ($now<$starttime) { $active=0; }
1648: }
1649: if ($endtime) {
1650: if ($now>$endtime) { $active=0; }
1651: }
1652: if ($active) { $courses{$1.'_'.$2}=1; }
1653: }
1654: }
1655: return keys %courses;
1656: }
1.37 matthew 1657:
1.54 www 1658: ###############################################
1.60 matthew 1659: ###############################################
1660:
1661: =pod
1662:
1.63 www 1663: =item &determinedomain()
1.60 matthew 1664:
1665: Inputs: $domain (usually will be undef)
1666:
1.63 www 1667: Returns: Determines which domain should be used for designs
1.60 matthew 1668:
1669: =cut
1.54 www 1670:
1.60 matthew 1671: ###############################################
1.63 www 1672: sub determinedomain {
1673: my $domain=shift;
1674: if (! $domain) {
1.60 matthew 1675: # Determine domain if we have not been given one
1676: $domain = $Apache::lonnet::perlvar{'lonDefDomain'};
1677: if ($ENV{'user.domain'}) { $domain=$ENV{'user.domain'}; }
1678: if ($ENV{'request.role.domain'}) {
1679: $domain=$ENV{'request.role.domain'};
1680: }
1681: }
1.63 www 1682: return $domain;
1683: }
1684: ###############################################
1685: =pod
1686:
1687: =item &domainlogo()
1688:
1689: Inputs: $domain (usually will be undef)
1690:
1691: Returns: A link to a domain logo, if the domain logo exists.
1692: If the domain logo does not exist, a description of the domain.
1693:
1694: =cut
1695: ###############################################
1696: sub domainlogo {
1697: my $domain = &determinedomain(shift);
1698: # See if there is a logo
1.59 www 1699: if (-e '/home/httpd/html/adm/lonDomLogos/'.$domain.'.gif') {
1.83 albertel 1700: my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'};
1701: if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; }
1702: return '<img src="http://'.$ENV{'HTTP_HOST'}.':'.$lonhttpdPort.
1703: '/adm/lonDomLogos/'.$domain.'.gif" />';
1.60 matthew 1704: } elsif(exists($Apache::lonnet::domaindescription{$domain})) {
1705: return $Apache::lonnet::domaindescription{$domain};
1.59 www 1706: } else {
1.60 matthew 1707: return '';
1.59 www 1708: }
1709: }
1.63 www 1710: ##############################################
1711:
1712: =pod
1713:
1714: =item &designparm()
1715:
1716: Inputs: $which parameter; $domain (usually will be undef)
1717:
1718: Returns: value of designparamter $which
1719:
1720: =cut
1721: ##############################################
1722: sub designparm {
1723: my ($which,$domain)=@_;
1.96 www 1724: if ($ENV{'environment.color.'.$which}) {
1725: return $ENV{'environment.color.'.$which};
1726: }
1.63 www 1727: $domain=&determinedomain($domain);
1728: if ($designhash{$domain.'.'.$which}) {
1729: return $designhash{$domain.'.'.$which};
1730: } else {
1731: return $designhash{'default.'.$which};
1732: }
1733: }
1.59 www 1734:
1.60 matthew 1735: ###############################################
1736: ###############################################
1737:
1738: =pod
1739:
1740: =item &bodytag()
1741:
1742: Returns a uniform header for LON-CAPA web pages.
1743:
1744: Inputs:
1745:
1746: $title, A title to be displayed on the page.
1747: $function, the current role (can be undef).
1748: $addentries, extra parameters for the <body> tag.
1749: $bodyonly, if defined, only return the <body> tag.
1750: $domain, if defined, force a given domain.
1.86 www 1751: $forcereg, if page should register as content page (relevant for
1752: text interface only)
1.60 matthew 1753:
1754: Returns: A uniform header for LON-CAPA web pages.
1755: If $bodyonly is nonzero, a string containing a <body> tag will be returned.
1756: If $bodyonly is undef or zero, an html string containing a <body> tag and
1757: other decorations will be returned.
1758:
1759: =cut
1760:
1761: ###############################################
1.63 www 1762:
1763:
1.60 matthew 1764: ###############################################
1.54 www 1765: sub bodytag {
1.86 www 1766: my ($title,$function,$addentries,$bodyonly,$domain,$forcereg)=@_;
1.55 www 1767: unless ($function) {
1768: $function='student';
1769: if ($ENV{'request.role'}=~/^(cc|in|ta|ep)/) {
1770: $function='coordinator';
1771: }
1772: if ($ENV{'request.role'}=~/^(su|dc|ad|li)/) {
1773: $function='admin';
1774: }
1775: if (($ENV{'request.role'}=~/^(au|ca)/) ||
1776: ($ENV{'REQUEST_URI'}=~/^(\/priv|\~)/)) {
1777: $function='author';
1778: }
1779: }
1.63 www 1780: my $img=&designparm($function.'.img',$domain);
1781: my $pgbg=&designparm($function.'.pgbg',$domain);
1782: my $tabbg=&designparm($function.'.tabbg',$domain);
1783: my $font=&designparm($function.'.font',$domain);
1784: my $link=&designparm($function.'.link',$domain);
1785: my $alink=&designparm($function.'.alink',$domain);
1786: my $vlink=&designparm($function.'.vlink',$domain);
1787: my $sidebg=&designparm($function.'.sidebg',$domain);
1788:
1789: # role and realm
1.55 www 1790: my ($role,$realm)
1791: =&Apache::lonnet::plaintext((split(/\./,$ENV{'request.role'}))[0]);
1792: # realm
1.54 www 1793: if ($ENV{'request.course.id'}) {
1.55 www 1794: $realm=
1795: $ENV{'course.'.$ENV{'request.course.id'}.'.description'};
1.54 www 1796: }
1.55 www 1797: unless ($realm) { $realm=' '; }
1798: # Set messages
1.60 matthew 1799: my $messages=&domainlogo($domain);
1.101 www 1800: # Port for miniserver
1.83 albertel 1801: my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'};
1802: if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; }
1.101 www 1803: # construct main body tag
1.60 matthew 1804: my $bodytag = <<END;
1.54 www 1805: <body bgcolor="$pgbg" text="$font" alink="$alink" vlink="$vlink" link="$link"
1806: $addentries>
1.60 matthew 1807: END
1.94 www 1808: my $upperleft='<img src="http://'.$ENV{'HTTP_HOST'}.':'.
1809: $lonhttpdPort.$img.'" />';
1.60 matthew 1810: if ($bodyonly) {
1811: return $bodytag;
1.79 www 1812: } elsif ($ENV{'browser.interface'} eq 'textual') {
1.95 www 1813: # Accessibility
1.93 www 1814: return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web',
1815: $forcereg).
1816: '<h1>LON-CAPA: '.$title.'</h1>';
1817: } elsif ($ENV{'environment.remote'} eq 'off') {
1.95 www 1818: # No Remote
1819: return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web',
1820: $forcereg).
1821: '<table bgcolor="'.$pgbg.'" width="100%" border="0" cellspacing="3" cellpadding="3"><tr><td bgcolor="'.$tabbg.'"><font size="+3" color="'.$font.'"><b>'.$title.
1822: '</b></font></td></tr></table>';
1.94 www 1823: }
1.95 www 1824:
1.93 www 1825: #
1.95 www 1826: # Top frame rendering, Remote is up
1.93 www 1827: #
1.94 www 1828: return(<<ENDBODY);
1.60 matthew 1829: $bodytag
1.55 www 1830: <table width="100%" cellspacing="0" border="0" cellpadding="0">
1.95 www 1831: <tr><td bgcolor="$sidebg">
1.94 www 1832: $upperleft</td>
1.95 www 1833: <td bgcolor="$sidebg" align="right">$messages </td>
1.55 www 1834: </tr>
1.54 www 1835: <tr>
1.55 www 1836: <td rowspan="3" bgcolor="$tabbg">
1837: <font size="5"><b>$title</b></font>
1.54 www 1838: <td bgcolor="$tabbg" align="right">
1839: <font size="2">
1840: $ENV{'environment.firstname'}
1841: $ENV{'environment.middlename'}
1842: $ENV{'environment.lastname'}
1843: $ENV{'environment.generation'}
1.55 www 1844: </font>
1.54 www 1845: </td>
1846: </tr>
1847: <tr><td bgcolor="$tabbg" align="right">
1.55 www 1848: <font size="2">$role</font>
1.54 www 1849: </td></tr>
1.55 www 1850: <tr>
1851: <td bgcolor="$tabbg" align="right"><font size="2">$realm</font> </td></tr>
1.54 www 1852: </table><br>
1853: ENDBODY
1854: }
1.99 www 1855:
1856: ###############################################
1857:
1858: sub get_posted_cgi {
1859: my $r=shift;
1860:
1861: my $buffer;
1862:
1863: $r->read($buffer,$r->header_in('Content-length'),0);
1864: unless ($buffer=~/^(\-+\w+)\s+Content\-Disposition\:\s*form\-data/si) {
1865: my @pairs=split(/&/,$buffer);
1866: my $pair;
1867: foreach $pair (@pairs) {
1868: my ($name,$value) = split(/=/,$pair);
1869: $value =~ tr/+/ /;
1870: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
1871: $name =~ tr/+/ /;
1872: $name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
1873: &add_to_env("form.$name",$value);
1874: }
1875: } else {
1876: my $contentsep=$1;
1877: my @lines = split (/\n/,$buffer);
1878: my $name='';
1879: my $value='';
1880: my $fname='';
1881: my $fmime='';
1882: my $i;
1883: for ($i=0;$i<=$#lines;$i++) {
1884: if ($lines[$i]=~/^$contentsep/) {
1885: if ($name) {
1886: chomp($value);
1887: if ($fname) {
1888: $ENV{"form.$name.filename"}=$fname;
1889: $ENV{"form.$name.mimetype"}=$fmime;
1890: } else {
1891: $value=~s/\s+$//s;
1892: }
1893: &add_to_env("form.$name",$value);
1894: }
1895: if ($i<$#lines) {
1896: $i++;
1897: $lines[$i]=~
1898: /Content\-Disposition\:\s*form\-data\;\s*name\=\"([^\"]+)\"/i;
1899: $name=$1;
1900: $value='';
1901: if ($lines[$i]=~/filename\=\"([^\"]+)\"/i) {
1902: $fname=$1;
1903: if
1904: ($lines[$i+1]=~/Content\-Type\:\s*([\w\-\/]+)/i) {
1905: $fmime=$1;
1906: $i++;
1907: } else {
1908: $fmime='';
1909: }
1910: } else {
1911: $fname='';
1912: $fmime='';
1913: }
1914: $i++;
1915: }
1916: } else {
1917: $value.=$lines[$i]."\n";
1918: }
1919: }
1920: }
1921: $ENV{'request.method'}=$ENV{'REQUEST_METHOD'};
1922: $r->method_number(M_GET);
1923: $r->method('GET');
1924: $r->headers_in->unset('Content-length');
1925: }
1926:
1.37 matthew 1927: ###############################################
1.1 albertel 1928:
1.6 albertel 1929: sub get_unprocessed_cgi {
1.25 albertel 1930: my ($query,$possible_names)= @_;
1.26 matthew 1931: # $Apache::lonxml::debug=1;
1.16 harris41 1932: foreach (split(/&/,$query)) {
1.6 albertel 1933: my ($name, $value) = split(/=/,$_);
1.25 albertel 1934: $name = &Apache::lonnet::unescape($name);
1935: if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) {
1936: $value =~ tr/+/ /;
1937: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
1938: &Apache::lonxml::debug("Seting :$name: to :$value:");
1.30 albertel 1939: unless (defined($ENV{'form.'.$name})) { &add_to_env('form.'.$name,$value) };
1.25 albertel 1940: }
1.16 harris41 1941: }
1.6 albertel 1942: }
1943:
1.7 albertel 1944: sub cacheheader {
1.23 www 1945: unless ($ENV{'request.method'} eq 'GET') { return ''; }
1.8 albertel 1946: my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
1.7 albertel 1947: my $output .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" />
1948: <meta HTTP-EQUIV="Cache-control" CONTENT="no-cache" />
1949: <meta HTTP-EQUIV="Pragma" CONTENT="no-cache" />';
1950: return $output;
1951: }
1952:
1.9 albertel 1953: sub no_cache {
1954: my ($r) = @_;
1.23 www 1955: unless ($ENV{'request.method'} eq 'GET') { return ''; }
1.24 albertel 1956: #my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
1.9 albertel 1957: $r->no_cache(1);
1958: $r->header_out("Pragma" => "no-cache");
1.24 albertel 1959: #$r->header_out("Expires" => $date);
1.9 albertel 1960: }
1.25 albertel 1961:
1962: sub add_to_env {
1963: my ($name,$value)=@_;
1.28 albertel 1964: if (defined($ENV{$name})) {
1.27 albertel 1965: if (ref($ENV{$name})) {
1.25 albertel 1966: #already have multiple values
1967: push(@{ $ENV{$name} },$value);
1968: } else {
1969: #first time seeing multiple values, convert hash entry to an arrayref
1970: my $first=$ENV{$name};
1971: undef($ENV{$name});
1972: push(@{ $ENV{$name} },$first,$value);
1973: }
1974: } else {
1975: $ENV{$name}=$value;
1976: }
1.31 albertel 1977: }
1978:
1.41 ng 1979: =pod
1.45 matthew 1980:
1981: =back
1.41 ng 1982:
1983: =head2 CSV Upload/Handling functions
1.38 albertel 1984:
1.41 ng 1985: =over 4
1986:
1987: =item upfile_store($r)
1988:
1989: Store uploaded file, $r should be the HTTP Request object,
1990: needs $ENV{'form.upfile'}
1991: returns $datatoken to be put into hidden field
1992:
1993: =cut
1.31 albertel 1994:
1995: sub upfile_store {
1996: my $r=shift;
1997: $ENV{'form.upfile'}=~s/\r/\n/gs;
1998: $ENV{'form.upfile'}=~s/\f/\n/gs;
1999: $ENV{'form.upfile'}=~s/\n+/\n/gs;
2000: $ENV{'form.upfile'}=~s/\n+$//gs;
2001:
2002: my $datatoken=$ENV{'user.name'}.'_'.$ENV{'user.domain'}.
2003: '_enroll_'.$ENV{'request.course.id'}.'_'.time.'_'.$$;
2004: {
2005: my $fh=Apache::File->new('>'.$r->dir_config('lonDaemons').
2006: '/tmp/'.$datatoken.'.tmp');
2007: print $fh $ENV{'form.upfile'};
2008: }
2009: return $datatoken;
2010: }
2011:
1.56 matthew 2012: =pod
2013:
1.41 ng 2014: =item load_tmp_file($r)
2015:
2016: Load uploaded file from tmp, $r should be the HTTP Request object,
2017: needs $ENV{'form.datatoken'},
2018: sets $ENV{'form.upfile'} to the contents of the file
2019:
2020: =cut
1.31 albertel 2021:
2022: sub load_tmp_file {
2023: my $r=shift;
2024: my @studentdata=();
2025: {
2026: my $fh;
2027: if ($fh=Apache::File->new($r->dir_config('lonDaemons').
2028: '/tmp/'.$ENV{'form.datatoken'}.'.tmp')) {
2029: @studentdata=<$fh>;
2030: }
2031: }
2032: $ENV{'form.upfile'}=join('',@studentdata);
2033: }
2034:
1.56 matthew 2035: =pod
2036:
1.41 ng 2037: =item upfile_record_sep()
2038:
2039: Separate uploaded file into records
2040: returns array of records,
2041: needs $ENV{'form.upfile'} and $ENV{'form.upfiletype'}
2042:
2043: =cut
1.31 albertel 2044:
2045: sub upfile_record_sep {
2046: if ($ENV{'form.upfiletype'} eq 'xml') {
2047: } else {
2048: return split(/\n/,$ENV{'form.upfile'});
2049: }
2050: }
2051:
1.56 matthew 2052: =pod
2053:
1.41 ng 2054: =item record_sep($record)
2055:
2056: Separate a record into fields $record should be an item from the upfile_record_sep(), needs $ENV{'form.upfiletype'}
2057:
2058: =cut
2059:
1.31 albertel 2060: sub record_sep {
2061: my $record=shift;
2062: my %components=();
2063: if ($ENV{'form.upfiletype'} eq 'xml') {
2064: } elsif ($ENV{'form.upfiletype'} eq 'space') {
2065: my $i=0;
2066: foreach (split(/\s+/,$record)) {
2067: my $field=$_;
2068: $field=~s/^(\"|\')//;
2069: $field=~s/(\"|\')$//;
2070: $components{$i}=$field;
2071: $i++;
2072: }
2073: } elsif ($ENV{'form.upfiletype'} eq 'tab') {
2074: my $i=0;
2075: foreach (split(/\t+/,$record)) {
2076: my $field=$_;
2077: $field=~s/^(\"|\')//;
2078: $field=~s/(\"|\')$//;
2079: $components{$i}=$field;
2080: $i++;
2081: }
2082: } else {
2083: my @allfields=split(/\,/,$record);
2084: my $i=0;
2085: my $j;
2086: for ($j=0;$j<=$#allfields;$j++) {
2087: my $field=$allfields[$j];
2088: if ($field=~/^\s*(\"|\')/) {
2089: my $delimiter=$1;
2090: while (($field!~/$delimiter$/) && ($j<$#allfields)) {
2091: $j++;
2092: $field.=','.$allfields[$j];
2093: }
2094: $field=~s/^\s*$delimiter//;
2095: $field=~s/$delimiter\s*$//;
2096: }
2097: $components{$i}=$field;
2098: $i++;
2099: }
2100: }
2101: return %components;
2102: }
2103:
1.56 matthew 2104: =pod
2105:
1.41 ng 2106: =item upfile_select_html()
2107:
2108: return HTML code to select file and specify its type
2109:
2110: =cut
2111:
1.31 albertel 2112: sub upfile_select_html {
2113: return (<<'ENDUPFORM');
1.57 albertel 2114: <input type="file" name="upfile" size="50" />
1.31 albertel 2115: <br />Type: <select name="upfiletype">
2116: <option value="csv">CSV (comma separated values, spreadsheet)</option>
2117: <option value="space">Space separated</option>
2118: <option value="tab">Tabulator separated</option>
2119: <option value="xml">HTML/XML</option>
2120: </select>
2121: ENDUPFORM
2122: }
2123:
1.56 matthew 2124: =pod
2125:
1.41 ng 2126: =item csv_print_samples($r,$records)
2127:
2128: Prints a table of sample values from each column uploaded $r is an
2129: Apache Request ref, $records is an arrayref from
2130: &Apache::loncommon::upfile_record_sep
2131:
2132: =cut
2133:
1.31 albertel 2134: sub csv_print_samples {
2135: my ($r,$records) = @_;
2136: my (%sone,%stwo,%sthree);
2137: %sone=&record_sep($$records[0]);
2138: if (defined($$records[1])) {%stwo=&record_sep($$records[1]);}
2139: if (defined($$records[2])) {%sthree=&record_sep($$records[2]);}
2140:
2141: $r->print('Samples<br /><table border="2"><tr>');
2142: foreach (sort({$a <=> $b} keys(%sone))) { $r->print('<th>Column '.($_+1).'</th>'); }
2143: $r->print('</tr>');
2144: foreach my $hash (\%sone,\%stwo,\%sthree) {
2145: $r->print('<tr>');
2146: foreach (sort({$a <=> $b} keys(%sone))) {
2147: $r->print('<td>');
2148: if (defined($$hash{$_})) { $r->print($$hash{$_}); }
2149: $r->print('</td>');
2150: }
2151: $r->print('</tr>');
2152: }
2153: $r->print('</tr></table><br />'."\n");
2154: }
2155:
1.56 matthew 2156: =pod
2157:
1.41 ng 2158: =item csv_print_select_table($r,$records,$d)
2159:
2160: Prints a table to create associations between values and table columns.
2161: $r is an Apache Request ref,
2162: $records is an arrayref from &Apache::loncommon::upfile_record_sep,
2163: $d is an array of 2 element arrays (internal name, displayed name)
2164:
2165: =cut
2166:
1.31 albertel 2167: sub csv_print_select_table {
2168: my ($r,$records,$d) = @_;
2169: my $i=0;my %sone;
2170: %sone=&record_sep($$records[0]);
2171: $r->print('Associate columns with student attributes.'."\n".
2172: '<table border="2"><tr><th>Attribute</th><th>Column</th></tr>'."\n");
2173: foreach (@$d) {
2174: my ($value,$display)=@{ $_ };
2175: $r->print('<tr><td>'.$display.'</td>');
2176:
2177: $r->print('<td><select name=f'.$i.
1.32 matthew 2178: ' onchange="javascript:flip(this.form,'.$i.');">');
1.31 albertel 2179: $r->print('<option value="none"></option>');
2180: foreach (sort({$a <=> $b} keys(%sone))) {
2181: $r->print('<option value="'.$_.'">Column '.($_+1).'</option>');
2182: }
2183: $r->print('</select></td></tr>'."\n");
2184: $i++;
2185: }
2186: $i--;
2187: return $i;
2188: }
1.56 matthew 2189:
2190: =pod
1.31 albertel 2191:
1.41 ng 2192: =item csv_samples_select_table($r,$records,$d)
2193:
2194: Prints a table of sample values from the upload and can make associate samples to internal names.
2195:
2196: $r is an Apache Request ref,
2197: $records is an arrayref from &Apache::loncommon::upfile_record_sep,
2198: $d is an array of 2 element arrays (internal name, displayed name)
2199:
2200: =cut
2201:
1.31 albertel 2202: sub csv_samples_select_table {
2203: my ($r,$records,$d) = @_;
2204: my %sone; my %stwo; my %sthree;
2205: my $i=0;
2206:
2207: $r->print('<table border=2><tr><th>Field</th><th>Samples</th></tr>');
2208: %sone=&record_sep($$records[0]);
2209: if (defined($$records[1])) {%stwo=&record_sep($$records[1]);}
2210: if (defined($$records[2])) {%sthree=&record_sep($$records[2]);}
2211:
2212: foreach (sort keys %sone) {
2213: $r->print('<tr><td><select name=f'.$i.
1.32 matthew 2214: ' onchange="javascript:flip(this.form,'.$i.');">');
1.31 albertel 2215: foreach (@$d) {
2216: my ($value,$display)=@{ $_ };
2217: $r->print('<option value='.$value.'>'.$display.'</option>');
2218: }
2219: $r->print('</select></td><td>');
2220: if (defined($sone{$_})) { $r->print($sone{$_}."</br>\n"); }
2221: if (defined($stwo{$_})) { $r->print($stwo{$_}."</br>\n"); }
2222: if (defined($sthree{$_})) { $r->print($sthree{$_}."</br>\n"); }
2223: $r->print('</td></tr>');
2224: $i++;
2225: }
2226: $i--;
2227: return($i);
1.25 albertel 2228: }
1.84 albertel 2229:
1.85 albertel 2230: =pod
2231:
2232: =item check_if_partid_hidden($id,$symb,$udom,$uname)
2233:
2234: Returns either 1 or undef
2235:
2236: 1 if the part is to be hidden, undef if it is to be shown
2237:
2238: Arguments are:
2239:
2240: $id the id of the part to be checked
2241: $symb, optional the symb of the resource to check
2242: $udom, optional the domain of the user to check for
2243: $uname, optional the username of the user to check for
2244:
2245: =cut
1.84 albertel 2246:
2247: sub check_if_partid_hidden {
2248: my ($id,$symb,$udom,$uname) = @_;
2249: my $hiddenparts=&Apache::lonnet::EXT('resource.0.parameter_hiddenparts',
2250: $symb,$udom,$uname);
2251: my @hiddenlist=split(/,/,$hiddenparts);
2252: foreach my $checkid (@hiddenlist) {
2253: if ($checkid =~ /^\s*\Q$id\E\s*$/) { return 1; }
2254: }
2255: return undef;
2256: }
2257:
2258:
2259:
1.1 albertel 2260: 1;
2261: __END__;
1.17 harris41 2262:
1.41 ng 2263: =pod
2264:
2265: =back
2266:
2267: =head2 Access .tab File Data
2268:
2269: =over 4
2270:
1.35 matthew 2271: =item languageids()
1.17 harris41 2272:
1.35 matthew 2273: returns list of all language ids
1.17 harris41 2274:
1.35 matthew 2275: =item languagedescription()
1.17 harris41 2276:
1.35 matthew 2277: returns description of a specified language id
1.17 harris41 2278:
1.35 matthew 2279: =item copyrightids()
1.17 harris41 2280:
1.35 matthew 2281: returns list of all copyrights
1.17 harris41 2282:
1.35 matthew 2283: =item copyrightdescription()
1.17 harris41 2284:
1.35 matthew 2285: returns description of a specified copyright id
1.17 harris41 2286:
1.35 matthew 2287: =item filecategories()
1.17 harris41 2288:
1.35 matthew 2289: returns list of all file categories
1.17 harris41 2290:
1.35 matthew 2291: =item filecategorytypes()
1.17 harris41 2292:
1.35 matthew 2293: returns list of file types belonging to a given file
1.17 harris41 2294: category
2295:
1.35 matthew 2296: =item fileembstyle()
1.17 harris41 2297:
1.35 matthew 2298: returns embedding style for a specified file type
1.17 harris41 2299:
1.35 matthew 2300: =item filedescription()
1.17 harris41 2301:
1.35 matthew 2302: returns description for a specified file type
1.17 harris41 2303:
1.35 matthew 2304: =item filedescriptionex()
1.17 harris41 2305:
1.35 matthew 2306: returns description for a specified file type with
1.17 harris41 2307: extra formatting
2308:
1.41 ng 2309: =back
2310:
2311: =head2 Alternate Problem Views
2312:
2313: =over 4
2314:
1.35 matthew 2315: =item get_previous_attempt()
1.17 harris41 2316:
1.35 matthew 2317: return string with previous attempt on problem
1.17 harris41 2318:
1.35 matthew 2319: =item get_student_view()
1.17 harris41 2320:
1.35 matthew 2321: show a snapshot of what student was looking at
1.17 harris41 2322:
1.35 matthew 2323: =item get_student_answers()
1.17 harris41 2324:
1.35 matthew 2325: show a snapshot of how student was answering problem
1.17 harris41 2326:
1.41 ng 2327: =back
2328:
2329: =head2 HTTP Helper
2330:
2331: =over 4
2332:
2333: =item get_unprocessed_cgi($query,$possible_names)
2334:
2335: Modify the %ENV hash to contain unprocessed CGI form parameters held in
2336: $query. The parameters listed in $possible_names (an array reference),
2337: will be set in $ENV{'form.name'} if they do not already exist.
1.17 harris41 2338:
1.41 ng 2339: Typically called with $ENV{'QUERY_STRING'} as the first parameter.
2340: $possible_names is an ref to an array of form element names. As an example:
2341: get_unprocessed_cgi($ENV{'QUERY_STRING'},['uname','udom']);
2342: will result in $ENV{'form.uname'} and $ENV{'form.udom'} being set.
1.17 harris41 2343:
1.35 matthew 2344: =item cacheheader()
1.17 harris41 2345:
1.35 matthew 2346: returns cache-controlling header code
1.17 harris41 2347:
1.65 matthew 2348: =item no_cache($r)
1.17 harris41 2349:
1.35 matthew 2350: specifies header code to not have cache
1.25 albertel 2351:
1.35 matthew 2352: =item add_to_env($name,$value)
1.25 albertel 2353:
1.35 matthew 2354: adds $name to the %ENV hash with value
1.25 albertel 2355: $value, if $name already exists, the entry is converted to an array
2356: reference and $value is added to the array.
1.17 harris41 2357:
2358: =back
2359:
2360: =cut
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