Annotation of loncom/interface/loncommon.pm, revision 1.108
1.10 albertel 1: # The LearningOnline Network with CAPA
1.1 albertel 2: # a pile of common routines
1.10 albertel 3: #
1.108 ! bowersj2 4: # $Id: loncommon.pm,v 1.107 2003/06/24 22:16:32 albertel 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.73 www 1356: my ($link,$un,$do,$tf)=@_;
1357: if ($tf) { $link='<font color="'.$tf.'">'.$link.'</font>'; }
1.62 www 1358: return "<a href='/public/$do/$un/syllabus'>$link</a>";
1.61 www 1359: }
1.14 harris41 1360:
1361: # ---------------------------------------------------------------- Language IDs
1362: sub languageids {
1.16 harris41 1363: return sort(keys(%language));
1.14 harris41 1364: }
1365:
1366: # -------------------------------------------------------- Language Description
1367: sub languagedescription {
1.16 harris41 1368: return $language{shift(@_)};
1.97 www 1369: }
1370:
1371: # ----------------------------------------------------------- Display Languages
1372: # returns a hash with all desired display languages
1373: #
1374:
1375: sub display_languages {
1376: my %languages=();
1377: if ($ENV{'environment.languages'}) {
1378: foreach (split(/\s*(\,|\;|\:)\s*/,$ENV{'environment.languages'})) {
1.104 www 1379: $languages{$_}=1;
1380: }
1381: }
1382: if ($ENV{'course.'.$ENV{'request.course.id'}.'.languages'}) {
1383: foreach (split(/\s*(\,|\;|\:)\s*/,
1384: $ENV{'course.'.$ENV{'request.course.id'}.'.languages'})) {
1.97 www 1385: $languages{$_}=1;
1386: }
1387: }
1388: &get_unprocessed_cgi($ENV{'QUERY_STRING'},['displaylanguage']);
1389: if ($ENV{'form.displaylanguage'}) {
1390: foreach (split(/\s*(\,|\;|\:)\s*/,$ENV{'form.displaylanguage'})) {
1391: $languages{$_}=1;
1392: }
1393: }
1394: return %languages;
1.14 harris41 1395: }
1396:
1397: # --------------------------------------------------------------- Copyright IDs
1398: sub copyrightids {
1.16 harris41 1399: return sort(keys(%cprtag));
1.14 harris41 1400: }
1401:
1402: # ------------------------------------------------------- Copyright Description
1403: sub copyrightdescription {
1.16 harris41 1404: return $cprtag{shift(@_)};
1.14 harris41 1405: }
1406:
1407: # ------------------------------------------------------------- File Categories
1408: sub filecategories {
1.41 ng 1409: return sort(keys(%category_extensions));
1.15 harris41 1410: }
1.14 harris41 1411:
1.17 harris41 1412: # -------------------------------------- File Types within a specified category
1.15 harris41 1413: sub filecategorytypes {
1.41 ng 1414: return @{$category_extensions{lc($_[0])}};
1.14 harris41 1415: }
1416:
1417: # ------------------------------------------------------------------ File Types
1418: sub fileextensions {
1.16 harris41 1419: return sort(keys(%fe));
1.14 harris41 1420: }
1421:
1422: # ------------------------------------------------------------- Embedding Style
1423: sub fileembstyle {
1.16 harris41 1424: return $fe{lc(shift(@_))};
1.14 harris41 1425: }
1426:
1427: # ------------------------------------------------------------ Description Text
1428: sub filedescription {
1.16 harris41 1429: return $fd{lc(shift(@_))};
1430: }
1431:
1432: # ------------------------------------------------------------ Description Text
1433: sub filedescriptionex {
1434: my $ex=shift;
1435: return '.'.$ex.' '.$fd{lc($ex)};
1.12 harris41 1436: }
1.1 albertel 1437:
1.40 ng 1438: # ---- Retrieve attempts by students
1439: # input
1440: # $symb - problem including path
1441: # $username,$domain - that of the student
1442: # $course - course name
1443: # $getattempt - leave blank if want all attempts, else put something.
1.43 ng 1444: # $regexp - regular expression. If string matches regexp send to
1445: # $gradesub - routine that process the string if it matches regexp
1.40 ng 1446: #
1447: # output
1448: # formatted as a table all the attempts, if any.
1449: #
1.1 albertel 1450: sub get_previous_attempt {
1.43 ng 1451: my ($symb,$username,$domain,$course,$getattempt,$regexp,$gradesub)=@_;
1.1 albertel 1452: my $prevattempts='';
1.43 ng 1453: no strict 'refs';
1.1 albertel 1454: if ($symb) {
1.3 albertel 1455: my (%returnhash)=
1456: &Apache::lonnet::restore($symb,$course,$domain,$username);
1.1 albertel 1457: if ($returnhash{'version'}) {
1458: my %lasthash=();
1459: my $version;
1460: for ($version=1;$version<=$returnhash{'version'};$version++) {
1.19 harris41 1461: foreach (sort(split(/\:/,$returnhash{$version.':keys'}))) {
1.1 albertel 1462: $lasthash{$_}=$returnhash{$version.':'.$_};
1.19 harris41 1463: }
1.1 albertel 1464: }
1.43 ng 1465: $prevattempts='<table border="0" width="100%"><tr><td bgcolor="#777777">';
1.40 ng 1466: $prevattempts.='<table border="0" width="100%"><tr bgcolor="#e6ffff"><td>History</td>';
1.16 harris41 1467: foreach (sort(keys %lasthash)) {
1.31 albertel 1468: my ($ign,@parts) = split(/\./,$_);
1.41 ng 1469: if ($#parts > 0) {
1.31 albertel 1470: my $data=$parts[-1];
1471: pop(@parts);
1.40 ng 1472: $prevattempts.='<td>Part '.join('.',@parts).'<br />'.$data.' </td>';
1.31 albertel 1473: } else {
1.41 ng 1474: if ($#parts == 0) {
1475: $prevattempts.='<th>'.$parts[0].'</th>';
1476: } else {
1477: $prevattempts.='<th>'.$ign.'</th>';
1478: }
1.31 albertel 1479: }
1.16 harris41 1480: }
1.40 ng 1481: if ($getattempt eq '') {
1482: for ($version=1;$version<=$returnhash{'version'};$version++) {
1483: $prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Transaction '.$version.'</td>';
1484: foreach (sort(keys %lasthash)) {
1485: my $value;
1486: if ($_ =~ /timestamp/) {
1487: $value=scalar(localtime($returnhash{$version.':'.$_}));
1488: } else {
1489: $value=$returnhash{$version.':'.$_};
1490: }
1491: $prevattempts.='<td>'.$value.' </td>';
1492: }
1493: }
1.1 albertel 1494: }
1.40 ng 1495: $prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Current</td>';
1.16 harris41 1496: foreach (sort(keys %lasthash)) {
1.5 albertel 1497: my $value;
1498: if ($_ =~ /timestamp/) {
1499: $value=scalar(localtime($lasthash{$_}));
1500: } else {
1501: $value=$lasthash{$_};
1502: }
1.49 ng 1503: if ($_ =~/$regexp$/ && (defined &$gradesub)) {$value = &$gradesub($value)}
1.40 ng 1504: $prevattempts.='<td>'.$value.' </td>';
1.16 harris41 1505: }
1.40 ng 1506: $prevattempts.='</tr></table></td></tr></table>';
1.1 albertel 1507: } else {
1508: $prevattempts='Nothing submitted - no attempts.';
1509: }
1510: } else {
1511: $prevattempts='No data.';
1512: }
1.10 albertel 1513: }
1514:
1.107 albertel 1515: sub relative_to_absolute {
1516: my ($url,$output)=@_;
1517: my $parser=HTML::TokeParser->new(\$output);
1518: my $token;
1519: my $thisdir=$url;
1520: my @rlinks=();
1521: while ($token=$parser->get_token) {
1522: if ($token->[0] eq 'S') {
1523: if ($token->[1] eq 'a') {
1524: if ($token->[2]->{'href'}) {
1525: $rlinks[$#rlinks+1]=$token->[2]->{'href'};
1526: }
1527: } elsif ($token->[1] eq 'img' || $token->[1] eq 'embed' ) {
1528: $rlinks[$#rlinks+1]=$token->[2]->{'src'};
1529: } elsif ($token->[1] eq 'base') {
1530: $thisdir=$token->[2]->{'href'};
1531: }
1532: }
1533: }
1534: $thisdir=~s-/[^/]*$--;
1535: foreach (@rlinks) {
1536: unless (($_=~/^http:\/\//i) ||
1537: ($_=~/^\//) ||
1538: ($_=~/^javascript:/i) ||
1539: ($_=~/^mailto:/i) ||
1540: ($_=~/^\#/)) {
1541: my $newlocation=&Apache::lonnet::hreflocation($thisdir,$_);
1542: $output=~s/(\"|\'|\=\s*)$_(\"|\'|\s|\>)/$1$newlocation$2/;
1543: }
1544: }
1545: # -------------------------------------------------- Deal with Applet codebases
1546: $output=~s/(\<applet[^\>]+)(codebase\=[^\S\>]+)*([^\>]*)\>/$1.($2?$2:' codebase="'.$thisdir.'"').$3.'>'/gei;
1547: return $output;
1548: }
1549:
1.10 albertel 1550: sub get_student_view {
1.64 sakharuk 1551: my ($symb,$username,$domain,$courseid,$target) = @_;
1.10 albertel 1552: my ($map,$id,$feedurl) = split(/___/,$symb);
1553: my (%old,%moreenv);
1554: my @elements=('symb','courseid','domain','username');
1555: foreach my $element (@elements) {
1556: $old{$element}=$ENV{'form.grade_'.$element};
1557: $moreenv{'form.grade_'.$element}=eval '$'.$element #'
1558: }
1.64 sakharuk 1559: if ($target eq 'tex') {$moreenv{'form.grade_target'} = 'tex';}
1.11 albertel 1560: &Apache::lonnet::appenv(%moreenv);
1.107 albertel 1561: $feedurl=&Apache::lonnet::clutter($feedurl);
1562: my $userview=&Apache::lonnet::ssi_body($feedurl);
1.11 albertel 1563: &Apache::lonnet::delenv('form.grade_');
1564: foreach my $element (@elements) {
1565: $ENV{'form.grade_'.$element}=$old{$element};
1566: }
1567: $userview=~s/\<body[^\>]*\>//gi;
1568: $userview=~s/\<\/body\>//gi;
1569: $userview=~s/\<html\>//gi;
1570: $userview=~s/\<\/html\>//gi;
1571: $userview=~s/\<head\>//gi;
1572: $userview=~s/\<\/head\>//gi;
1573: $userview=~s/action\s*\=/would_be_action\=/gi;
1.107 albertel 1574: $userview=&relative_to_absolute($feedurl,$userview);
1.11 albertel 1575: return $userview;
1576: }
1577:
1578: sub get_student_answers {
1.100 sakharuk 1579: my ($symb,$username,$domain,$courseid,%form) = @_;
1.11 albertel 1580: my ($map,$id,$feedurl) = split(/___/,$symb);
1581: my (%old,%moreenv);
1582: my @elements=('symb','courseid','domain','username');
1583: foreach my $element (@elements) {
1584: $old{$element}=$ENV{'form.grade_'.$element};
1585: $moreenv{'form.grade_'.$element}=eval '$'.$element #'
1586: }
1587: $moreenv{'form.grade_target'}='answer';
1.10 albertel 1588: &Apache::lonnet::appenv(%moreenv);
1.100 sakharuk 1589: my $userview=&Apache::lonnet::ssi('/res/'.$feedurl,%form);
1.10 albertel 1590: &Apache::lonnet::delenv('form.grade_');
1591: foreach my $element (@elements) {
1592: $ENV{'form.grade_'.$element}=$old{$element};
1593: }
1594: return $userview;
1.1 albertel 1595: }
1.37 matthew 1596:
1597: ###############################################
1.51 www 1598:
1599:
1600: sub timehash {
1601: my @ltime=localtime(shift);
1602: return ( 'seconds' => $ltime[0],
1603: 'minutes' => $ltime[1],
1604: 'hours' => $ltime[2],
1605: 'day' => $ltime[3],
1606: 'month' => $ltime[4]+1,
1607: 'year' => $ltime[5]+1900,
1608: 'weekday' => $ltime[6],
1609: 'dayyear' => $ltime[7]+1,
1610: 'dlsav' => $ltime[8] );
1611: }
1612:
1613: sub maketime {
1614: my %th=@_;
1615: return POSIX::mktime(
1616: ($th{'seconds'},$th{'minutes'},$th{'hours'},
1617: $th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,$th{'dlsav'}));
1618: }
1619:
1.70 www 1620:
1621: #########################################
1622: #
1623: # Retro-fixing of un-backward-compatible time format
1624:
1625: sub unsqltime {
1626: my $timestamp=shift;
1627: if ($timestamp=~/^(\d+)\-(\d+)\-(\d+)\s+(\d+)\:(\d+)\:(\d+)$/) {
1628: $timestamp=&maketime(
1629: 'year'=>$1,'month'=>$2,'day'=>$3,
1630: 'hours'=>$4,'minutes'=>$5,'seconds'=>$6);
1631: }
1632: return $timestamp;
1633: }
1634:
1635: #########################################
1.51 www 1636:
1637: sub findallcourses {
1638: my %courses=();
1639: my $now=time;
1640: foreach (keys %ENV) {
1641: if ($_=~/^user\.role\.\w+\.\/(\w+)\/(\w+)/) {
1642: my ($starttime,$endtime)=$ENV{$_};
1643: my $active=1;
1644: if ($starttime) {
1645: if ($now<$starttime) { $active=0; }
1646: }
1647: if ($endtime) {
1648: if ($now>$endtime) { $active=0; }
1649: }
1650: if ($active) { $courses{$1.'_'.$2}=1; }
1651: }
1652: }
1653: return keys %courses;
1654: }
1.37 matthew 1655:
1.54 www 1656: ###############################################
1.60 matthew 1657: ###############################################
1658:
1659: =pod
1660:
1.63 www 1661: =item &determinedomain()
1.60 matthew 1662:
1663: Inputs: $domain (usually will be undef)
1664:
1.63 www 1665: Returns: Determines which domain should be used for designs
1.60 matthew 1666:
1667: =cut
1.54 www 1668:
1.60 matthew 1669: ###############################################
1.63 www 1670: sub determinedomain {
1671: my $domain=shift;
1672: if (! $domain) {
1.60 matthew 1673: # Determine domain if we have not been given one
1674: $domain = $Apache::lonnet::perlvar{'lonDefDomain'};
1675: if ($ENV{'user.domain'}) { $domain=$ENV{'user.domain'}; }
1676: if ($ENV{'request.role.domain'}) {
1677: $domain=$ENV{'request.role.domain'};
1678: }
1679: }
1.63 www 1680: return $domain;
1681: }
1682: ###############################################
1683: =pod
1684:
1685: =item &domainlogo()
1686:
1687: Inputs: $domain (usually will be undef)
1688:
1689: Returns: A link to a domain logo, if the domain logo exists.
1690: If the domain logo does not exist, a description of the domain.
1691:
1692: =cut
1693: ###############################################
1694: sub domainlogo {
1695: my $domain = &determinedomain(shift);
1696: # See if there is a logo
1.59 www 1697: if (-e '/home/httpd/html/adm/lonDomLogos/'.$domain.'.gif') {
1.83 albertel 1698: my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'};
1699: if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; }
1700: return '<img src="http://'.$ENV{'HTTP_HOST'}.':'.$lonhttpdPort.
1701: '/adm/lonDomLogos/'.$domain.'.gif" />';
1.60 matthew 1702: } elsif(exists($Apache::lonnet::domaindescription{$domain})) {
1703: return $Apache::lonnet::domaindescription{$domain};
1.59 www 1704: } else {
1.60 matthew 1705: return '';
1.59 www 1706: }
1707: }
1.63 www 1708: ##############################################
1709:
1710: =pod
1711:
1712: =item &designparm()
1713:
1714: Inputs: $which parameter; $domain (usually will be undef)
1715:
1716: Returns: value of designparamter $which
1717:
1718: =cut
1719: ##############################################
1720: sub designparm {
1721: my ($which,$domain)=@_;
1.96 www 1722: if ($ENV{'environment.color.'.$which}) {
1723: return $ENV{'environment.color.'.$which};
1724: }
1.63 www 1725: $domain=&determinedomain($domain);
1726: if ($designhash{$domain.'.'.$which}) {
1727: return $designhash{$domain.'.'.$which};
1728: } else {
1729: return $designhash{'default.'.$which};
1730: }
1731: }
1.59 www 1732:
1.60 matthew 1733: ###############################################
1734: ###############################################
1735:
1736: =pod
1737:
1738: =item &bodytag()
1739:
1740: Returns a uniform header for LON-CAPA web pages.
1741:
1742: Inputs:
1743:
1744: $title, A title to be displayed on the page.
1745: $function, the current role (can be undef).
1746: $addentries, extra parameters for the <body> tag.
1747: $bodyonly, if defined, only return the <body> tag.
1748: $domain, if defined, force a given domain.
1.86 www 1749: $forcereg, if page should register as content page (relevant for
1750: text interface only)
1.60 matthew 1751:
1752: Returns: A uniform header for LON-CAPA web pages.
1753: If $bodyonly is nonzero, a string containing a <body> tag will be returned.
1754: If $bodyonly is undef or zero, an html string containing a <body> tag and
1755: other decorations will be returned.
1756:
1757: =cut
1758:
1759: ###############################################
1.63 www 1760:
1761:
1.60 matthew 1762: ###############################################
1.54 www 1763: sub bodytag {
1.86 www 1764: my ($title,$function,$addentries,$bodyonly,$domain,$forcereg)=@_;
1.55 www 1765: unless ($function) {
1766: $function='student';
1767: if ($ENV{'request.role'}=~/^(cc|in|ta|ep)/) {
1768: $function='coordinator';
1769: }
1770: if ($ENV{'request.role'}=~/^(su|dc|ad|li)/) {
1771: $function='admin';
1772: }
1773: if (($ENV{'request.role'}=~/^(au|ca)/) ||
1774: ($ENV{'REQUEST_URI'}=~/^(\/priv|\~)/)) {
1775: $function='author';
1776: }
1777: }
1.63 www 1778: my $img=&designparm($function.'.img',$domain);
1779: my $pgbg=&designparm($function.'.pgbg',$domain);
1780: my $tabbg=&designparm($function.'.tabbg',$domain);
1781: my $font=&designparm($function.'.font',$domain);
1782: my $link=&designparm($function.'.link',$domain);
1783: my $alink=&designparm($function.'.alink',$domain);
1784: my $vlink=&designparm($function.'.vlink',$domain);
1785: my $sidebg=&designparm($function.'.sidebg',$domain);
1786:
1787: # role and realm
1.55 www 1788: my ($role,$realm)
1789: =&Apache::lonnet::plaintext((split(/\./,$ENV{'request.role'}))[0]);
1790: # realm
1.54 www 1791: if ($ENV{'request.course.id'}) {
1.55 www 1792: $realm=
1793: $ENV{'course.'.$ENV{'request.course.id'}.'.description'};
1.54 www 1794: }
1.55 www 1795: unless ($realm) { $realm=' '; }
1796: # Set messages
1.60 matthew 1797: my $messages=&domainlogo($domain);
1.101 www 1798: # Port for miniserver
1.83 albertel 1799: my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'};
1800: if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; }
1.101 www 1801: # construct main body tag
1.60 matthew 1802: my $bodytag = <<END;
1.54 www 1803: <body bgcolor="$pgbg" text="$font" alink="$alink" vlink="$vlink" link="$link"
1804: $addentries>
1.60 matthew 1805: END
1.94 www 1806: my $upperleft='<img src="http://'.$ENV{'HTTP_HOST'}.':'.
1807: $lonhttpdPort.$img.'" />';
1.60 matthew 1808: if ($bodyonly) {
1809: return $bodytag;
1.79 www 1810: } elsif ($ENV{'browser.interface'} eq 'textual') {
1.95 www 1811: # Accessibility
1.93 www 1812: return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web',
1813: $forcereg).
1814: '<h1>LON-CAPA: '.$title.'</h1>';
1815: } elsif ($ENV{'environment.remote'} eq 'off') {
1.95 www 1816: # No Remote
1817: return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web',
1818: $forcereg).
1819: '<table bgcolor="'.$pgbg.'" width="100%" border="0" cellspacing="3" cellpadding="3"><tr><td bgcolor="'.$tabbg.'"><font size="+3" color="'.$font.'"><b>'.$title.
1820: '</b></font></td></tr></table>';
1.94 www 1821: }
1.95 www 1822:
1.93 www 1823: #
1.95 www 1824: # Top frame rendering, Remote is up
1.93 www 1825: #
1.94 www 1826: return(<<ENDBODY);
1.60 matthew 1827: $bodytag
1.55 www 1828: <table width="100%" cellspacing="0" border="0" cellpadding="0">
1.95 www 1829: <tr><td bgcolor="$sidebg">
1.94 www 1830: $upperleft</td>
1.95 www 1831: <td bgcolor="$sidebg" align="right">$messages </td>
1.55 www 1832: </tr>
1.54 www 1833: <tr>
1.55 www 1834: <td rowspan="3" bgcolor="$tabbg">
1835: <font size="5"><b>$title</b></font>
1.54 www 1836: <td bgcolor="$tabbg" align="right">
1837: <font size="2">
1838: $ENV{'environment.firstname'}
1839: $ENV{'environment.middlename'}
1840: $ENV{'environment.lastname'}
1841: $ENV{'environment.generation'}
1.55 www 1842: </font>
1.54 www 1843: </td>
1844: </tr>
1845: <tr><td bgcolor="$tabbg" align="right">
1.55 www 1846: <font size="2">$role</font>
1.54 www 1847: </td></tr>
1.55 www 1848: <tr>
1849: <td bgcolor="$tabbg" align="right"><font size="2">$realm</font> </td></tr>
1.54 www 1850: </table><br>
1851: ENDBODY
1852: }
1.99 www 1853:
1854: ###############################################
1855:
1856: sub get_posted_cgi {
1857: my $r=shift;
1858:
1859: my $buffer;
1860:
1861: $r->read($buffer,$r->header_in('Content-length'),0);
1862: unless ($buffer=~/^(\-+\w+)\s+Content\-Disposition\:\s*form\-data/si) {
1863: my @pairs=split(/&/,$buffer);
1864: my $pair;
1865: foreach $pair (@pairs) {
1866: my ($name,$value) = split(/=/,$pair);
1867: $value =~ tr/+/ /;
1868: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
1869: $name =~ tr/+/ /;
1870: $name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
1871: &add_to_env("form.$name",$value);
1872: }
1873: } else {
1874: my $contentsep=$1;
1875: my @lines = split (/\n/,$buffer);
1876: my $name='';
1877: my $value='';
1878: my $fname='';
1879: my $fmime='';
1880: my $i;
1881: for ($i=0;$i<=$#lines;$i++) {
1882: if ($lines[$i]=~/^$contentsep/) {
1883: if ($name) {
1884: chomp($value);
1885: if ($fname) {
1886: $ENV{"form.$name.filename"}=$fname;
1887: $ENV{"form.$name.mimetype"}=$fmime;
1888: } else {
1889: $value=~s/\s+$//s;
1890: }
1891: &add_to_env("form.$name",$value);
1892: }
1893: if ($i<$#lines) {
1894: $i++;
1895: $lines[$i]=~
1896: /Content\-Disposition\:\s*form\-data\;\s*name\=\"([^\"]+)\"/i;
1897: $name=$1;
1898: $value='';
1899: if ($lines[$i]=~/filename\=\"([^\"]+)\"/i) {
1900: $fname=$1;
1901: if
1902: ($lines[$i+1]=~/Content\-Type\:\s*([\w\-\/]+)/i) {
1903: $fmime=$1;
1904: $i++;
1905: } else {
1906: $fmime='';
1907: }
1908: } else {
1909: $fname='';
1910: $fmime='';
1911: }
1912: $i++;
1913: }
1914: } else {
1915: $value.=$lines[$i]."\n";
1916: }
1917: }
1918: }
1919: $ENV{'request.method'}=$ENV{'REQUEST_METHOD'};
1920: $r->method_number(M_GET);
1921: $r->method('GET');
1922: $r->headers_in->unset('Content-length');
1923: }
1924:
1.37 matthew 1925: ###############################################
1.1 albertel 1926:
1.6 albertel 1927: sub get_unprocessed_cgi {
1.25 albertel 1928: my ($query,$possible_names)= @_;
1.26 matthew 1929: # $Apache::lonxml::debug=1;
1.16 harris41 1930: foreach (split(/&/,$query)) {
1.6 albertel 1931: my ($name, $value) = split(/=/,$_);
1.25 albertel 1932: $name = &Apache::lonnet::unescape($name);
1933: if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) {
1934: $value =~ tr/+/ /;
1935: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
1936: &Apache::lonxml::debug("Seting :$name: to :$value:");
1.30 albertel 1937: unless (defined($ENV{'form.'.$name})) { &add_to_env('form.'.$name,$value) };
1.25 albertel 1938: }
1.16 harris41 1939: }
1.6 albertel 1940: }
1941:
1.7 albertel 1942: sub cacheheader {
1.23 www 1943: unless ($ENV{'request.method'} eq 'GET') { return ''; }
1.8 albertel 1944: my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
1.7 albertel 1945: my $output .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" />
1946: <meta HTTP-EQUIV="Cache-control" CONTENT="no-cache" />
1947: <meta HTTP-EQUIV="Pragma" CONTENT="no-cache" />';
1948: return $output;
1949: }
1950:
1.9 albertel 1951: sub no_cache {
1952: my ($r) = @_;
1.23 www 1953: unless ($ENV{'request.method'} eq 'GET') { return ''; }
1.24 albertel 1954: #my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
1.9 albertel 1955: $r->no_cache(1);
1956: $r->header_out("Pragma" => "no-cache");
1.24 albertel 1957: #$r->header_out("Expires" => $date);
1.9 albertel 1958: }
1.25 albertel 1959:
1960: sub add_to_env {
1961: my ($name,$value)=@_;
1.28 albertel 1962: if (defined($ENV{$name})) {
1.27 albertel 1963: if (ref($ENV{$name})) {
1.25 albertel 1964: #already have multiple values
1965: push(@{ $ENV{$name} },$value);
1966: } else {
1967: #first time seeing multiple values, convert hash entry to an arrayref
1968: my $first=$ENV{$name};
1969: undef($ENV{$name});
1970: push(@{ $ENV{$name} },$first,$value);
1971: }
1972: } else {
1973: $ENV{$name}=$value;
1974: }
1.31 albertel 1975: }
1976:
1.41 ng 1977: =pod
1.45 matthew 1978:
1979: =back
1.41 ng 1980:
1981: =head2 CSV Upload/Handling functions
1.38 albertel 1982:
1.41 ng 1983: =over 4
1984:
1985: =item upfile_store($r)
1986:
1987: Store uploaded file, $r should be the HTTP Request object,
1988: needs $ENV{'form.upfile'}
1989: returns $datatoken to be put into hidden field
1990:
1991: =cut
1.31 albertel 1992:
1993: sub upfile_store {
1994: my $r=shift;
1995: $ENV{'form.upfile'}=~s/\r/\n/gs;
1996: $ENV{'form.upfile'}=~s/\f/\n/gs;
1997: $ENV{'form.upfile'}=~s/\n+/\n/gs;
1998: $ENV{'form.upfile'}=~s/\n+$//gs;
1999:
2000: my $datatoken=$ENV{'user.name'}.'_'.$ENV{'user.domain'}.
2001: '_enroll_'.$ENV{'request.course.id'}.'_'.time.'_'.$$;
2002: {
2003: my $fh=Apache::File->new('>'.$r->dir_config('lonDaemons').
2004: '/tmp/'.$datatoken.'.tmp');
2005: print $fh $ENV{'form.upfile'};
2006: }
2007: return $datatoken;
2008: }
2009:
1.56 matthew 2010: =pod
2011:
1.41 ng 2012: =item load_tmp_file($r)
2013:
2014: Load uploaded file from tmp, $r should be the HTTP Request object,
2015: needs $ENV{'form.datatoken'},
2016: sets $ENV{'form.upfile'} to the contents of the file
2017:
2018: =cut
1.31 albertel 2019:
2020: sub load_tmp_file {
2021: my $r=shift;
2022: my @studentdata=();
2023: {
2024: my $fh;
2025: if ($fh=Apache::File->new($r->dir_config('lonDaemons').
2026: '/tmp/'.$ENV{'form.datatoken'}.'.tmp')) {
2027: @studentdata=<$fh>;
2028: }
2029: }
2030: $ENV{'form.upfile'}=join('',@studentdata);
2031: }
2032:
1.56 matthew 2033: =pod
2034:
1.41 ng 2035: =item upfile_record_sep()
2036:
2037: Separate uploaded file into records
2038: returns array of records,
2039: needs $ENV{'form.upfile'} and $ENV{'form.upfiletype'}
2040:
2041: =cut
1.31 albertel 2042:
2043: sub upfile_record_sep {
2044: if ($ENV{'form.upfiletype'} eq 'xml') {
2045: } else {
2046: return split(/\n/,$ENV{'form.upfile'});
2047: }
2048: }
2049:
1.56 matthew 2050: =pod
2051:
1.41 ng 2052: =item record_sep($record)
2053:
2054: Separate a record into fields $record should be an item from the upfile_record_sep(), needs $ENV{'form.upfiletype'}
2055:
2056: =cut
2057:
1.31 albertel 2058: sub record_sep {
2059: my $record=shift;
2060: my %components=();
2061: if ($ENV{'form.upfiletype'} eq 'xml') {
2062: } elsif ($ENV{'form.upfiletype'} eq 'space') {
2063: my $i=0;
2064: foreach (split(/\s+/,$record)) {
2065: my $field=$_;
2066: $field=~s/^(\"|\')//;
2067: $field=~s/(\"|\')$//;
2068: $components{$i}=$field;
2069: $i++;
2070: }
2071: } elsif ($ENV{'form.upfiletype'} eq 'tab') {
2072: my $i=0;
2073: foreach (split(/\t+/,$record)) {
2074: my $field=$_;
2075: $field=~s/^(\"|\')//;
2076: $field=~s/(\"|\')$//;
2077: $components{$i}=$field;
2078: $i++;
2079: }
2080: } else {
2081: my @allfields=split(/\,/,$record);
2082: my $i=0;
2083: my $j;
2084: for ($j=0;$j<=$#allfields;$j++) {
2085: my $field=$allfields[$j];
2086: if ($field=~/^\s*(\"|\')/) {
2087: my $delimiter=$1;
2088: while (($field!~/$delimiter$/) && ($j<$#allfields)) {
2089: $j++;
2090: $field.=','.$allfields[$j];
2091: }
2092: $field=~s/^\s*$delimiter//;
2093: $field=~s/$delimiter\s*$//;
2094: }
2095: $components{$i}=$field;
2096: $i++;
2097: }
2098: }
2099: return %components;
2100: }
2101:
1.56 matthew 2102: =pod
2103:
1.41 ng 2104: =item upfile_select_html()
2105:
2106: return HTML code to select file and specify its type
2107:
2108: =cut
2109:
1.31 albertel 2110: sub upfile_select_html {
2111: return (<<'ENDUPFORM');
1.57 albertel 2112: <input type="file" name="upfile" size="50" />
1.31 albertel 2113: <br />Type: <select name="upfiletype">
2114: <option value="csv">CSV (comma separated values, spreadsheet)</option>
2115: <option value="space">Space separated</option>
2116: <option value="tab">Tabulator separated</option>
2117: <option value="xml">HTML/XML</option>
2118: </select>
2119: ENDUPFORM
2120: }
2121:
1.56 matthew 2122: =pod
2123:
1.41 ng 2124: =item csv_print_samples($r,$records)
2125:
2126: Prints a table of sample values from each column uploaded $r is an
2127: Apache Request ref, $records is an arrayref from
2128: &Apache::loncommon::upfile_record_sep
2129:
2130: =cut
2131:
1.31 albertel 2132: sub csv_print_samples {
2133: my ($r,$records) = @_;
2134: my (%sone,%stwo,%sthree);
2135: %sone=&record_sep($$records[0]);
2136: if (defined($$records[1])) {%stwo=&record_sep($$records[1]);}
2137: if (defined($$records[2])) {%sthree=&record_sep($$records[2]);}
2138:
2139: $r->print('Samples<br /><table border="2"><tr>');
2140: foreach (sort({$a <=> $b} keys(%sone))) { $r->print('<th>Column '.($_+1).'</th>'); }
2141: $r->print('</tr>');
2142: foreach my $hash (\%sone,\%stwo,\%sthree) {
2143: $r->print('<tr>');
2144: foreach (sort({$a <=> $b} keys(%sone))) {
2145: $r->print('<td>');
2146: if (defined($$hash{$_})) { $r->print($$hash{$_}); }
2147: $r->print('</td>');
2148: }
2149: $r->print('</tr>');
2150: }
2151: $r->print('</tr></table><br />'."\n");
2152: }
2153:
1.56 matthew 2154: =pod
2155:
1.41 ng 2156: =item csv_print_select_table($r,$records,$d)
2157:
2158: Prints a table to create associations between values and table columns.
2159: $r is an Apache Request ref,
2160: $records is an arrayref from &Apache::loncommon::upfile_record_sep,
2161: $d is an array of 2 element arrays (internal name, displayed name)
2162:
2163: =cut
2164:
1.31 albertel 2165: sub csv_print_select_table {
2166: my ($r,$records,$d) = @_;
2167: my $i=0;my %sone;
2168: %sone=&record_sep($$records[0]);
2169: $r->print('Associate columns with student attributes.'."\n".
2170: '<table border="2"><tr><th>Attribute</th><th>Column</th></tr>'."\n");
2171: foreach (@$d) {
2172: my ($value,$display)=@{ $_ };
2173: $r->print('<tr><td>'.$display.'</td>');
2174:
2175: $r->print('<td><select name=f'.$i.
1.32 matthew 2176: ' onchange="javascript:flip(this.form,'.$i.');">');
1.31 albertel 2177: $r->print('<option value="none"></option>');
2178: foreach (sort({$a <=> $b} keys(%sone))) {
2179: $r->print('<option value="'.$_.'">Column '.($_+1).'</option>');
2180: }
2181: $r->print('</select></td></tr>'."\n");
2182: $i++;
2183: }
2184: $i--;
2185: return $i;
2186: }
1.56 matthew 2187:
2188: =pod
1.31 albertel 2189:
1.41 ng 2190: =item csv_samples_select_table($r,$records,$d)
2191:
2192: Prints a table of sample values from the upload and can make associate samples to internal names.
2193:
2194: $r is an Apache Request ref,
2195: $records is an arrayref from &Apache::loncommon::upfile_record_sep,
2196: $d is an array of 2 element arrays (internal name, displayed name)
2197:
2198: =cut
2199:
1.31 albertel 2200: sub csv_samples_select_table {
2201: my ($r,$records,$d) = @_;
2202: my %sone; my %stwo; my %sthree;
2203: my $i=0;
2204:
2205: $r->print('<table border=2><tr><th>Field</th><th>Samples</th></tr>');
2206: %sone=&record_sep($$records[0]);
2207: if (defined($$records[1])) {%stwo=&record_sep($$records[1]);}
2208: if (defined($$records[2])) {%sthree=&record_sep($$records[2]);}
2209:
2210: foreach (sort keys %sone) {
2211: $r->print('<tr><td><select name=f'.$i.
1.32 matthew 2212: ' onchange="javascript:flip(this.form,'.$i.');">');
1.31 albertel 2213: foreach (@$d) {
2214: my ($value,$display)=@{ $_ };
2215: $r->print('<option value='.$value.'>'.$display.'</option>');
2216: }
2217: $r->print('</select></td><td>');
2218: if (defined($sone{$_})) { $r->print($sone{$_}."</br>\n"); }
2219: if (defined($stwo{$_})) { $r->print($stwo{$_}."</br>\n"); }
2220: if (defined($sthree{$_})) { $r->print($sthree{$_}."</br>\n"); }
2221: $r->print('</td></tr>');
2222: $i++;
2223: }
2224: $i--;
2225: return($i);
1.25 albertel 2226: }
1.84 albertel 2227:
1.85 albertel 2228: =pod
2229:
2230: =item check_if_partid_hidden($id,$symb,$udom,$uname)
2231:
2232: Returns either 1 or undef
2233:
2234: 1 if the part is to be hidden, undef if it is to be shown
2235:
2236: Arguments are:
2237:
2238: $id the id of the part to be checked
2239: $symb, optional the symb of the resource to check
2240: $udom, optional the domain of the user to check for
2241: $uname, optional the username of the user to check for
2242:
2243: =cut
1.84 albertel 2244:
2245: sub check_if_partid_hidden {
2246: my ($id,$symb,$udom,$uname) = @_;
2247: my $hiddenparts=&Apache::lonnet::EXT('resource.0.parameter_hiddenparts',
2248: $symb,$udom,$uname);
2249: my @hiddenlist=split(/,/,$hiddenparts);
2250: foreach my $checkid (@hiddenlist) {
2251: if ($checkid =~ /^\s*\Q$id\E\s*$/) { return 1; }
2252: }
2253: return undef;
2254: }
2255:
2256:
2257:
1.1 albertel 2258: 1;
2259: __END__;
1.17 harris41 2260:
1.41 ng 2261: =pod
2262:
2263: =back
2264:
2265: =head2 Access .tab File Data
2266:
2267: =over 4
2268:
1.35 matthew 2269: =item languageids()
1.17 harris41 2270:
1.35 matthew 2271: returns list of all language ids
1.17 harris41 2272:
1.35 matthew 2273: =item languagedescription()
1.17 harris41 2274:
1.35 matthew 2275: returns description of a specified language id
1.17 harris41 2276:
1.35 matthew 2277: =item copyrightids()
1.17 harris41 2278:
1.35 matthew 2279: returns list of all copyrights
1.17 harris41 2280:
1.35 matthew 2281: =item copyrightdescription()
1.17 harris41 2282:
1.35 matthew 2283: returns description of a specified copyright id
1.17 harris41 2284:
1.35 matthew 2285: =item filecategories()
1.17 harris41 2286:
1.35 matthew 2287: returns list of all file categories
1.17 harris41 2288:
1.35 matthew 2289: =item filecategorytypes()
1.17 harris41 2290:
1.35 matthew 2291: returns list of file types belonging to a given file
1.17 harris41 2292: category
2293:
1.35 matthew 2294: =item fileembstyle()
1.17 harris41 2295:
1.35 matthew 2296: returns embedding style for a specified file type
1.17 harris41 2297:
1.35 matthew 2298: =item filedescription()
1.17 harris41 2299:
1.35 matthew 2300: returns description for a specified file type
1.17 harris41 2301:
1.35 matthew 2302: =item filedescriptionex()
1.17 harris41 2303:
1.35 matthew 2304: returns description for a specified file type with
1.17 harris41 2305: extra formatting
2306:
1.41 ng 2307: =back
2308:
2309: =head2 Alternate Problem Views
2310:
2311: =over 4
2312:
1.35 matthew 2313: =item get_previous_attempt()
1.17 harris41 2314:
1.35 matthew 2315: return string with previous attempt on problem
1.17 harris41 2316:
1.35 matthew 2317: =item get_student_view()
1.17 harris41 2318:
1.35 matthew 2319: show a snapshot of what student was looking at
1.17 harris41 2320:
1.35 matthew 2321: =item get_student_answers()
1.17 harris41 2322:
1.35 matthew 2323: show a snapshot of how student was answering problem
1.17 harris41 2324:
1.41 ng 2325: =back
2326:
2327: =head2 HTTP Helper
2328:
2329: =over 4
2330:
2331: =item get_unprocessed_cgi($query,$possible_names)
2332:
2333: Modify the %ENV hash to contain unprocessed CGI form parameters held in
2334: $query. The parameters listed in $possible_names (an array reference),
2335: will be set in $ENV{'form.name'} if they do not already exist.
1.17 harris41 2336:
1.41 ng 2337: Typically called with $ENV{'QUERY_STRING'} as the first parameter.
2338: $possible_names is an ref to an array of form element names. As an example:
2339: get_unprocessed_cgi($ENV{'QUERY_STRING'},['uname','udom']);
2340: will result in $ENV{'form.uname'} and $ENV{'form.udom'} being set.
1.17 harris41 2341:
1.35 matthew 2342: =item cacheheader()
1.17 harris41 2343:
1.35 matthew 2344: returns cache-controlling header code
1.17 harris41 2345:
1.65 matthew 2346: =item no_cache($r)
1.17 harris41 2347:
1.35 matthew 2348: specifies header code to not have cache
1.25 albertel 2349:
1.35 matthew 2350: =item add_to_env($name,$value)
1.25 albertel 2351:
1.35 matthew 2352: adds $name to the %ENV hash with value
1.25 albertel 2353: $value, if $name already exists, the entry is converted to an array
2354: reference and $value is added to the array.
1.17 harris41 2355:
2356: =back
2357:
2358: =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