Annotation of loncom/interface/loncommon.pm, revision 1.88
1.10 albertel 1: # The LearningOnline Network with CAPA
1.1 albertel 2: # a pile of common routines
1.10 albertel 3: #
1.88 ! www 4: # $Id: loncommon.pm,v 1.87 2003/03/10 20:21:45 matthew 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.1 albertel 82: use Apache::Constants qw(:common);
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;
154: my ($key,$val)=(split(/\s+/,$_,2));
155: $language{$key}=$val;
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;
332: var title = 'Student Browser';
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.
349: '","'.$udomele.'");'."'>Select</a>";
350: }
1.42 matthew 351:
352: ###############################################################
353:
354: =pod
1.36 matthew 355:
356: =item linked_select_forms(...)
357:
358: linked_select_forms returns a string containing a <script></script> block
359: and html for two <select> menus. The select menus will be linked in that
360: changing the value of the first menu will result in new values being placed
361: in the second menu. The values in the select menu will appear in alphabetical
362: order.
363:
364: linked_select_forms takes the following ordered inputs:
365:
366: =over 4
367:
368: =item $formname, the name of the <form> tag
369:
370: =item $middletext, the text which appears between the <select> tags
371:
372: =item $firstdefault, the default value for the first menu
373:
374: =item $firstselectname, the name of the first <select> tag
375:
376: =item $secondselectname, the name of the second <select> tag
377:
378: =item $hashref, a reference to a hash containing the data for the menus.
379:
1.41 ng 380: =back
381:
1.36 matthew 382: Below is an example of such a hash. Only the 'text', 'default', and
383: 'select2' keys must appear as stated. keys(%menu) are the possible
384: values for the first select menu. The text that coincides with the
1.41 ng 385: first menu value is given in $menu{$choice1}->{'text'}. The values
1.36 matthew 386: and text for the second menu are given in the hash pointed to by
387: $menu{$choice1}->{'select2'}.
388:
1.41 ng 389: my %menu = ( A1 => { text =>"Choice A1" ,
1.36 matthew 390: default => "B3",
391: select2 => {
392: B1 => "Choice B1",
393: B2 => "Choice B2",
394: B3 => "Choice B3",
395: B4 => "Choice B4"
396: }
397: },
398: A2 => { text =>"Choice A2" ,
399: default => "C2",
400: select2 => {
401: C1 => "Choice C1",
402: C2 => "Choice C2",
403: C3 => "Choice C3"
404: }
405: },
406: A3 => { text =>"Choice A3" ,
407: default => "D6",
408: select2 => {
409: D1 => "Choice D1",
410: D2 => "Choice D2",
411: D3 => "Choice D3",
412: D4 => "Choice D4",
413: D5 => "Choice D5",
414: D6 => "Choice D6",
415: D7 => "Choice D7"
416: }
417: }
418: );
419:
420: =cut
421:
422: # ------------------------------------------------
423:
424: sub linked_select_forms {
425: my ($formname,
426: $middletext,
427: $firstdefault,
428: $firstselectname,
429: $secondselectname,
430: $hashref
431: ) = @_;
432: my $second = "document.$formname.$secondselectname";
433: my $first = "document.$formname.$firstselectname";
434: # output the javascript to do the changing
435: my $result = '';
436: $result.="<script>\n";
437: $result.="var select2data = new Object();\n";
438: $" = '","';
439: my $debug = '';
440: foreach my $s1 (sort(keys(%$hashref))) {
441: $result.="select2data.d_$s1 = new Object();\n";
442: $result.="select2data.d_$s1.def = new String('".
443: $hashref->{$s1}->{'default'}."');\n";
444: $result.="select2data.d_$s1.values = new Array(";
445: my @s2values = sort(keys( %{ $hashref->{$s1}->{'select2'} } ));
446: $result.="\"@s2values\");\n";
447: $result.="select2data.d_$s1.texts = new Array(";
448: my @s2texts;
449: foreach my $value (@s2values) {
450: push @s2texts, $hashref->{$s1}->{'select2'}->{$value};
451: }
452: $result.="\"@s2texts\");\n";
453: }
454: $"=' ';
455: $result.= <<"END";
456:
457: function select1_changed() {
458: // Determine new choice
459: var newvalue = "d_" + $first.value;
460: // update select2
461: var values = select2data[newvalue].values;
462: var texts = select2data[newvalue].texts;
463: var select2def = select2data[newvalue].def;
464: var i;
465: // out with the old
466: for (i = 0; i < $second.options.length; i++) {
467: $second.options[i] = null;
468: }
469: // in with the nuclear
470: for (i=0;i<values.length; i++) {
471: $second.options[i] = new Option(values[i]);
472: $second.options[i].text = texts[i];
473: if (values[i] == select2def) {
474: $second.options[i].selected = true;
475: }
476: }
477: }
478: </script>
479: END
480: # output the initial values for the selection lists
481: $result .= "<select size=\"1\" name=\"$firstselectname\" onchange=\"select1_changed()\">\n";
482: foreach my $value (sort(keys(%$hashref))) {
483: $result.=" <option value=\"$value\" ";
484: $result.=" selected=\"true\" " if ($value eq $firstdefault);
485: $result.=">$hashref->{$value}->{'text'}</option>\n";
486: }
487: $result .= "</select>\n";
488: my %select2 = %{$hashref->{$firstdefault}->{'select2'}};
489: $result .= $middletext;
490: $result .= "<select size=\"1\" name=\"$secondselectname\">\n";
491: my $seconddefault = $hashref->{$firstdefault}->{'default'};
492: foreach my $value (sort(keys(%select2))) {
493: $result.=" <option value=\"$value\" ";
494: $result.=" selected=\"true\" " if ($value eq $seconddefault);
495: $result.=">$select2{$value}</option>\n";
496: }
497: $result .= "</select>\n";
498: # return $debug;
499: return $result;
500: } # end of sub linked_select_forms {
501:
1.33 matthew 502: ###############################################################
1.44 bowersj2 503:
1.45 matthew 504: =pod
1.44 bowersj2 505:
1.48 bowersj2 506: =item help_open_topic($topic, $text, $stayOnPage, $width, $height)
1.44 bowersj2 507:
508: 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.
509:
1.48 bowersj2 510: $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.
511:
1.44 bowersj2 512: $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.)
513:
514: $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.
515:
516: =cut
517:
518: sub help_open_topic {
1.48 bowersj2 519: my ($topic, $text, $stayOnPage, $width, $height) = @_;
520: $text = "" if (not defined $text);
1.44 bowersj2 521: $stayOnPage = 0 if (not defined $stayOnPage);
1.79 www 522: if ($ENV{'browser.interface'} eq 'textual') {
523: $stayOnPage=1;
524: }
1.44 bowersj2 525: $width = 350 if (not defined $width);
526: $height = 400 if (not defined $height);
527: my $filename = $topic;
528: $filename =~ s/ /_/g;
529:
1.48 bowersj2 530: my $template = "";
531: my $link;
1.44 bowersj2 532:
533: if (!$stayOnPage)
534: {
1.72 bowersj2 535: $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 536: }
537: else
538: {
1.48 bowersj2 539: $link = "/adm/help/${filename}.hlp";
540: }
541:
542: # Add the text
543: if ($text ne "")
544: {
1.77 www 545: $template .=
546: "<table bgcolor='#3333AA' cellspacing='1' cellpadding='1' border='0'><tr>".
1.78 www 547: "<td bgcolor='#5555FF'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
1.48 bowersj2 548: }
549:
550: # Add the graphic
551: $template .= <<"ENDTEMPLATE";
1.77 www 552: <a href="$link"><image src="/adm/help/gif/smallHelp.gif" border="0" alt="(Help: $topic)" /></a>
1.44 bowersj2 553: ENDTEMPLATE
1.78 www 554: if ($text ne '') { $template.='</td></tr></table>' };
1.44 bowersj2 555: return $template;
556:
557: }
1.37 matthew 558:
1.45 matthew 559: =pod
560:
1.37 matthew 561: =item csv_translate($text)
562:
563: Translate $text to allow it to be output as a 'comma seperated values'
564: format.
565:
566: =cut
567:
568: sub csv_translate {
569: my $text = shift;
570: $text =~ s/\"/\"\"/g;
571: $text =~ s/\n//g;
572: return $text;
573: }
574:
575: ###############################################################
1.33 matthew 576: ## Home server <option> list generating code ##
577: ###############################################################
1.35 matthew 578: #-------------------------------------------
579:
1.45 matthew 580: =pod
581:
1.35 matthew 582: =item get_domains()
583:
584: Returns an array containing each of the domains listed in the hosts.tab
585: file.
586:
587: =cut
588:
589: #-------------------------------------------
1.34 matthew 590: sub get_domains {
591: # The code below was stolen from "The Perl Cookbook", p 102, 1st ed.
592: my @domains;
593: my %seen;
594: foreach (sort values(%Apache::lonnet::hostdom)) {
595: push (@domains,$_) unless $seen{$_}++;
596: }
597: return @domains;
598: }
1.88 ! www 599:
! 600: #-------------------------------------------
! 601:
! 602: =pod
! 603:
! 604: =item select_form($defdom,$name,%hash)
! 605:
! 606: Returns a string containing a <select name='$name' size='1'> form to
! 607: allow a user to select options from a hash option_name => displayed text.
! 608: See lonrights.pm for an example invocation and use.
! 609:
! 610: =cut
! 611:
! 612: #-------------------------------------------
! 613: sub select_form {
! 614: my ($def,$name,%hash) = @_;
! 615: my $selectform = "<select name=\"$name\" size=\"1\">\n";
! 616: foreach (keys %hash) {
! 617: $selectform.="<option value=\"$_\" ".
! 618: ($_ eq $def ? 'selected' : '').
! 619: ">".$hash{$_}."</option>\n";
! 620: }
! 621: $selectform.="</select>";
! 622: return $selectform;
! 623: }
! 624:
1.34 matthew 625:
1.35 matthew 626: #-------------------------------------------
627:
1.45 matthew 628: =pod
629:
1.35 matthew 630: =item select_dom_form($defdom,$name)
631:
632: Returns a string containing a <select name='$name' size='1'> form to
633: allow a user to select the domain to preform an operation in.
634: See loncreateuser.pm for an example invocation and use.
635:
636: =cut
637:
638: #-------------------------------------------
1.34 matthew 639: sub select_dom_form {
640: my ($defdom,$name) = @_;
641: my @domains = get_domains();
642: my $selectdomain = "<select name=\"$name\" size=\"1\">\n";
643: foreach (@domains) {
644: $selectdomain.="<option value=\"$_\" ".
645: ($_ eq $defdom ? 'selected' : '').
646: ">$_</option>\n";
647: }
648: $selectdomain.="</select>";
649: return $selectdomain;
650: }
651:
1.35 matthew 652: #-------------------------------------------
653:
1.45 matthew 654: =pod
655:
1.52 matthew 656: =item get_library_servers($domain)
1.35 matthew 657:
658: Returns a hash which contains keys like '103l3' and values like
659: 'kirk.lite.msu.edu'. All of the keys will be for machines in the
660: given $domain.
661:
662: =cut
663:
664: #-------------------------------------------
1.52 matthew 665: sub get_library_servers {
1.33 matthew 666: my $domain = shift;
1.52 matthew 667: my %library_servers;
1.33 matthew 668: foreach (keys(%Apache::lonnet::libserv)) {
669: if ($Apache::lonnet::hostdom{$_} eq $domain) {
1.52 matthew 670: $library_servers{$_} = $Apache::lonnet::hostname{$_};
1.33 matthew 671: }
672: }
1.52 matthew 673: return %library_servers;
1.33 matthew 674: }
675:
1.35 matthew 676: #-------------------------------------------
677:
1.45 matthew 678: =pod
679:
1.35 matthew 680: =item home_server_option_list($domain)
681:
682: returns a string which contains an <option> list to be used in a
683: <select> form input. See loncreateuser.pm for an example.
684:
685: =cut
686:
687: #-------------------------------------------
1.33 matthew 688: sub home_server_option_list {
689: my $domain = shift;
1.52 matthew 690: my %servers = &get_library_servers($domain);
1.33 matthew 691: my $result = '';
692: foreach (sort keys(%servers)) {
693: $result.=
694: '<option value="'.$_.'">'.$_.' '.$servers{$_}."</option>\n";
695: }
696: return $result;
697: }
698: ###############################################################
699: ## End of home server <option> list generating code ##
700: ###############################################################
1.87 matthew 701:
702: ###############################################################
703: ###############################################################
704:
705: =pod
706:
707: =item &decode_user_agent()
708:
709: Inputs: $r
710:
711: Outputs:
712:
713: =over 4
714:
715: =item $httpbrowser
716:
717: =item $clientbrowser
718:
719: =item $clientversion
720:
721: =item $clientmathml
722:
723: =item $clientunicode
724:
725: =item $clientos
726:
727: =back
728:
729: =cut
730:
731: ###############################################################
732: ###############################################################
733: sub decode_user_agent {
734: my @browsertype=split(/\&/,$Apache::lonnet::perlvar{"lonBrowsDet"});
735: my %mathcap=split(/\&/,$$Apache::lonnet::perlvar{"lonMathML"});
736: my $httpbrowser=$ENV{"HTTP_USER_AGENT"};
737: my $clientbrowser='unknown';
738: my $clientversion='0';
739: my $clientmathml='';
740: my $clientunicode='0';
741: for (my $i=0;$i<=$#browsertype;$i++) {
742: my ($bname,$match,$notmatch,$vreg,$minv,$univ)=split(/\:/,$browsertype[$i]);
743: if (($httpbrowser=~/$match/i) && ($httpbrowser!~/$notmatch/i)) {
744: $clientbrowser=$bname;
745: $httpbrowser=~/$vreg/i;
746: $clientversion=$1;
747: $clientmathml=($clientversion>=$minv);
748: $clientunicode=($clientversion>=$univ);
749: }
750: }
751: my $clientos='unknown';
752: if (($httpbrowser=~/linux/i) ||
753: ($httpbrowser=~/unix/i) ||
754: ($httpbrowser=~/ux/i) ||
755: ($httpbrowser=~/solaris/i)) { $clientos='unix'; }
756: if (($httpbrowser=~/vax/i) ||
757: ($httpbrowser=~/vms/i)) { $clientos='vms'; }
758: if ($httpbrowser=~/next/i) { $clientos='next'; }
759: if (($httpbrowser=~/mac/i) ||
760: ($httpbrowser=~/powerpc/i)) { $clientos='mac'; }
761: if ($httpbrowser=~/win/i) { $clientos='win'; }
762: if ($httpbrowser=~/embed/i) { $clientos='pda'; }
763: return ($httpbrowser,$clientbrowser,$clientversion,$clientmathml,
764: $clientunicode,$clientos,);
765: }
766:
767: ###############################################################
768: ###############################################################
769:
1.32 matthew 770:
771: ###############################################################
772: ## Authentication changing form generation subroutines ##
773: ###############################################################
774: ##
775: ## All of the authform_xxxxxxx subroutines take their inputs in a
776: ## hash, and have reasonable default values.
777: ##
778: ## formname = the name given in the <form> tag.
1.35 matthew 779: #-------------------------------------------
780:
1.45 matthew 781: =pod
782:
1.35 matthew 783: =item authform_xxxxxx
784:
785: The authform_xxxxxx subroutines provide javascript and html forms which
786: handle some of the conveniences required for authentication forms.
787: This is not an optimal method, but it works.
788:
789: See loncreateuser.pm for invocation and use examples.
790:
791: =over 4
792:
793: =item authform_header
794:
795: =item authform_authorwarning
796:
797: =item authform_nochange
798:
799: =item authform_kerberos
800:
801: =item authform_internal
802:
803: =item authform_filesystem
804:
805: =back
806:
807: =cut
808:
809: #-------------------------------------------
1.32 matthew 810: sub authform_header{
811: my %in = (
812: formname => 'cu',
1.80 albertel 813: kerb_def_dom => '',
1.32 matthew 814: @_,
815: );
816: $in{'formname'} = 'document.' . $in{'formname'};
817: my $result='';
1.80 albertel 818:
819: #---------------------------------------------- Code for upper case translation
820: my $Javascript_toUpperCase;
821: unless ($in{kerb_def_dom}) {
822: $Javascript_toUpperCase =<<"END";
823: switch (choice) {
824: case 'krb': currentform.elements[choicearg].value =
825: currentform.elements[choicearg].value.toUpperCase();
826: break;
827: default:
828: }
829: END
830: } else {
831: $Javascript_toUpperCase = "";
832: }
833:
1.32 matthew 834: $result.=<<"END";
835: var current = new Object();
836: current.radiovalue = 'nochange';
837: current.argfield = null;
838:
839: function changed_radio(choice,currentform) {
840: var choicearg = choice + 'arg';
841: // If a radio button in changed, we need to change the argfield
842: if (current.radiovalue != choice) {
843: current.radiovalue = choice;
844: if (current.argfield != null) {
845: currentform.elements[current.argfield].value = '';
846: }
847: if (choice == 'nochange') {
848: current.argfield = null;
849: } else {
850: current.argfield = choicearg;
851: switch(choice) {
852: case 'krb':
853: currentform.elements[current.argfield].value =
854: "$in{'kerb_def_dom'}";
855: break;
856: default:
857: break;
858: }
859: }
860: }
861: return;
862: }
1.22 www 863:
1.32 matthew 864: function changed_text(choice,currentform) {
865: var choicearg = choice + 'arg';
866: if (currentform.elements[choicearg].value !='') {
1.80 albertel 867: $Javascript_toUpperCase
1.32 matthew 868: // clear old field
869: if ((current.argfield != choicearg) && (current.argfield != null)) {
870: currentform.elements[current.argfield].value = '';
871: }
872: current.argfield = choicearg;
873: }
874: set_auth_radio_buttons(choice,currentform);
875: return;
1.20 www 876: }
1.32 matthew 877:
878: function set_auth_radio_buttons(newvalue,currentform) {
879: var i=0;
880: while (i < currentform.login.length) {
881: if (currentform.login[i].value == newvalue) { break; }
882: i++;
883: }
884: if (i == currentform.login.length) {
885: return;
886: }
887: current.radiovalue = newvalue;
888: currentform.login[i].checked = true;
889: return;
890: }
891: END
892: return $result;
893: }
894:
895: sub authform_authorwarning{
896: my $result='';
897: $result=<<"END";
898: <i>As a general rule, only authors or co-authors should be filesystem
899: authenticated (which allows access to the server filesystem).</i>
900: END
901: return $result;
902: }
903:
904: sub authform_nochange{
905: my %in = (
906: formname => 'document.cu',
907: kerb_def_dom => 'MSU.EDU',
908: @_,
909: );
910: my $result='';
911: $result.=<<"END";
912: <input type="radio" name="login" value="nochange" checked="checked"
1.57 albertel 913: onclick="javascript:changed_radio('nochange',$in{'formname'});" />
1.32 matthew 914: Do not change login data
915: END
916: return $result;
917: }
918:
919: sub authform_kerberos{
920: my %in = (
921: formname => 'document.cu',
922: kerb_def_dom => 'MSU.EDU',
1.80 albertel 923: kerb_def_auth => 'krb4',
1.32 matthew 924: @_,
925: );
926: my $result='';
1.80 albertel 927: my $check4;
928: my $check5;
929: if ($in{'kerb_def_auth'} eq 'krb5') {
930: $check5 = " checked=\"on\"";
931: } else {
932: $check4 = " checked=\"on\"";
933: }
1.32 matthew 934: $result.=<<"END";
935: <input type="radio" name="login" value="krb"
936: onclick="javascript:changed_radio('krb',$in{'formname'});"
1.57 albertel 937: onchange="javascript:changed_radio('krb',$in{'formname'});" />
1.32 matthew 938: Kerberos authenticated with domain
1.80 albertel 939: <input type="text" size="10" name="krbarg" value="$in{'kerb_def_dom'}"
1.57 albertel 940: onchange="javascript:changed_text('krb',$in{'formname'});" />
1.80 albertel 941: <input type="radio" name="krbver" value="4" $check4 />Version 4
942: <input type="radio" name="krbver" value="5" $check5 />Version 5
1.32 matthew 943: END
944: return $result;
945: }
946:
947: sub authform_internal{
948: my %args = (
949: formname => 'document.cu',
950: kerb_def_dom => 'MSU.EDU',
951: @_,
952: );
953: my $result='';
954: $result.=<<"END";
955: <input type="radio" name="login" value="int"
956: onchange="javascript:changed_radio('int',$args{'formname'});"
1.57 albertel 957: onclick="javascript:changed_radio('int',$args{'formname'});" />
1.32 matthew 958: Internally authenticated (with initial password
959: <input type="text" size="10" name="intarg" value=""
1.75 www 960: onchange="javascript:changed_text('int',$args{'formname'});" />)
1.32 matthew 961: END
962: return $result;
963: }
964:
965: sub authform_local{
966: my %in = (
967: formname => 'document.cu',
968: kerb_def_dom => 'MSU.EDU',
969: @_,
970: );
971: my $result='';
972: $result.=<<"END";
973: <input type="radio" name="login" value="loc"
974: onchange="javascript:changed_radio('loc',$in{'formname'});"
1.57 albertel 975: onclick="javascript:changed_radio('loc',$in{'formname'});" />
1.32 matthew 976: Local Authentication with argument
977: <input type="text" size="10" name="locarg" value=""
1.57 albertel 978: onchange="javascript:changed_text('loc',$in{'formname'});" />
1.32 matthew 979: END
980: return $result;
981: }
982:
983: sub authform_filesystem{
984: my %in = (
985: formname => 'document.cu',
986: kerb_def_dom => 'MSU.EDU',
987: @_,
988: );
989: my $result='';
990: $result.=<<"END";
991: <input type="radio" name="login" value="fsys"
992: onchange="javascript:changed_radio('fsys',$in{'formname'});"
1.57 albertel 993: onclick="javascript:changed_radio('fsys',$in{'formname'});" />
1.32 matthew 994: Filesystem authenticated (with initial password
995: <input type="text" size="10" name="fsysarg" value=""
1.75 www 996: onchange="javascript:changed_text('fsys',$in{'formname'});">)
1.32 matthew 997: END
998: return $result;
999: }
1000:
1001: ###############################################################
1002: ## End Authentication changing form generation functions ##
1.80 albertel 1003: ###############################################################
1004:
1005: ###############################################################
1006: ## Get Authentication Defaults for Domain ##
1007: ###############################################################
1008: ##
1009: ## Returns default authentication type and an associated argument
1010: ## as listed in file domain.tab
1011: ##
1012: #-------------------------------------------
1013:
1014: =pod
1015:
1016: =item get_auth_defaults
1017:
1018: get_auth_defaults($target_domain) returns the default authentication
1019: type and an associated argument (initial password or a kerberos domain).
1020: These values are stored in lonTabs/domain.tab
1021:
1022: ($def_auth, $def_arg) = &get_auth_defaults($target_domain);
1023:
1024: If target_domain is not found in domain.tab, returns nothing ('').
1025:
1026: =over 4
1027:
1028: =item get_auth_defaults
1029:
1030: =back
1031:
1032: =cut
1033:
1034: #-------------------------------------------
1035: sub get_auth_defaults {
1036: my $domain=shift;
1037: return ($Apache::lonnet::domain_auth_def{$domain},$Apache::lonnet::domain_auth_arg_def{$domain});
1038: }
1039: ###############################################################
1040: ## End Get Authentication Defaults for Domain ##
1041: ###############################################################
1042:
1043: ###############################################################
1044: ## Get Kerberos Defaults for Domain ##
1045: ###############################################################
1046: ##
1047: ## Returns default kerberos version and an associated argument
1048: ## as listed in file domain.tab. If not listed, provides
1049: ## appropriate default domain and kerberos version.
1050: ##
1051: #-------------------------------------------
1052:
1053: =pod
1054:
1055: =item get_kerberos_defaults
1056:
1057: get_kerberos_defaults($target_domain) returns the default kerberos
1058: version and domain. If not found in domain.tabs, it defaults to
1059: version 4 and the domain of the server.
1060:
1061: ($def_version, $def_krb_domain) = &get_kerberos_defaults($target_domain);
1062:
1063: =over 4
1064:
1065: =item get_kerberos_defaults
1066:
1067: =back
1068:
1069: =cut
1070:
1071: #-------------------------------------------
1072: sub get_kerberos_defaults {
1073: my $domain=shift;
1074: my ($krbdef,$krbdefdom) =
1075: &Apache::loncommon::get_auth_defaults($domain);
1076: unless ($krbdef =~/^krb/ && $krbdefdom) {
1077: $ENV{'SERVER_NAME'}=~/(\w+\.\w+)$/;
1078: my $krbdefdom=$1;
1079: $krbdefdom=~tr/a-z/A-Z/;
1080: $krbdef = "krb4";
1081: }
1082: return ($krbdef,$krbdefdom);
1083: }
1084: ###############################################################
1085: ## End Get Kerberos Defaults for Domain ##
1.32 matthew 1086: ###############################################################
1087:
1.46 matthew 1088: ###############################################################
1089: ## Thesaurus Functions ##
1090: ###############################################################
1.20 www 1091:
1.46 matthew 1092: =pod
1.20 www 1093:
1.46 matthew 1094: =item initialize_keywords
1095:
1096: Initializes the package variable %Keywords if it is empty. Uses the
1097: package variable $thesaurus_db_file.
1098:
1099: =cut
1100:
1101: ###################################################
1102:
1103: sub initialize_keywords {
1104: return 1 if (scalar keys(%Keywords));
1105: # If we are here, %Keywords is empty, so fill it up
1106: # Make sure the file we need exists...
1107: if (! -e $thesaurus_db_file) {
1108: &Apache::lonnet::logthis("Attempt to access $thesaurus_db_file".
1109: " failed because it does not exist");
1110: return 0;
1111: }
1112: # Set up the hash as a database
1113: my %thesaurus_db;
1114: if (! tie(%thesaurus_db,'GDBM_File',
1.53 albertel 1115: $thesaurus_db_file,&GDBM_READER(),0640)){
1.46 matthew 1116: &Apache::lonnet::logthis("Could not tie \%thesaurus_db to ".
1117: $thesaurus_db_file);
1118: return 0;
1119: }
1120: # Get the average number of appearances of a word.
1121: my $avecount = $thesaurus_db{'average.count'};
1122: # Put keywords (those that appear > average) into %Keywords
1123: while (my ($word,$data)=each (%thesaurus_db)) {
1124: my ($count,undef) = split /:/,$data;
1125: $Keywords{$word}++ if ($count > $avecount);
1126: }
1127: untie %thesaurus_db;
1128: # Remove special values from %Keywords.
1129: foreach ('total.count','average.count') {
1130: delete($Keywords{$_}) if (exists($Keywords{$_}));
1131: }
1132: return 1;
1133: }
1134:
1135: ###################################################
1136:
1137: =pod
1138:
1139: =item keyword($word)
1140:
1141: Returns true if $word is a keyword. A keyword is a word that appears more
1142: than the average number of times in the thesaurus database. Calls
1143: &initialize_keywords
1144:
1145: =cut
1146:
1147: ###################################################
1.20 www 1148:
1149: sub keyword {
1.46 matthew 1150: return if (!&initialize_keywords());
1151: my $word=lc(shift());
1152: $word=~s/\W//g;
1153: return exists($Keywords{$word});
1.20 www 1154: }
1.46 matthew 1155:
1156: ###############################################################
1157:
1158: =pod
1.20 www 1159:
1.46 matthew 1160: =item get_related_words
1161:
1162: Look up a word in the thesaurus. Takes a scalar arguement and returns
1163: an array of words. If the keyword is not in the thesaurus, an empty array
1164: will be returned. The order of the words returned is determined by the
1165: database which holds them.
1166:
1167: Uses global $thesaurus_db_file.
1168:
1169: =cut
1170:
1171: ###############################################################
1172: sub get_related_words {
1173: my $keyword = shift;
1174: my %thesaurus_db;
1175: if (! -e $thesaurus_db_file) {
1176: &Apache::lonnet::logthis("Attempt to access $thesaurus_db_file ".
1177: "failed because the file does not exist");
1178: return ();
1179: }
1180: if (! tie(%thesaurus_db,'GDBM_File',
1.53 albertel 1181: $thesaurus_db_file,&GDBM_READER(),0640)){
1.46 matthew 1182: return ();
1183: }
1184: my @Words=();
1185: if (exists($thesaurus_db{$keyword})) {
1186: $_ = $thesaurus_db{$keyword};
1187: (undef,@Words) = split/:/; # The first element is the number of times
1188: # the word appears. We do not need it now.
1189: for (my $i=0;$i<=$#Words;$i++) {
1190: ($Words[$i],undef)= split/\,/,$Words[$i];
1.20 www 1191: }
1192: }
1.46 matthew 1193: untie %thesaurus_db;
1194: return @Words;
1.14 harris41 1195: }
1.46 matthew 1196:
1197: ###############################################################
1198: ## End Thesaurus Functions ##
1199: ###############################################################
1.61 www 1200:
1201: # -------------------------------------------------------------- Plaintext name
1.81 albertel 1202: =pod
1203:
1204: =item plainname($uname,$udom)
1205:
1206: Gets a users name and returns it as a string in
1207: "first middle last generation"
1208: form
1209:
1210: =cut
1.61 www 1211:
1.81 albertel 1212: ###############################################################
1.61 www 1213: sub plainname {
1214: my ($uname,$udom)=@_;
1215: my %names=&Apache::lonnet::get('environment',
1216: ['firstname','middlename','lastname','generation'],
1217: $udom,$uname);
1.62 www 1218: my $name=$names{'firstname'}.' '.$names{'middlename'}.' '.
1.61 www 1219: $names{'lastname'}.' '.$names{'generation'};
1.62 www 1220: $name=~s/\s+$//;
1221: $name=~s/\s+/ /g;
1222: return $name;
1.61 www 1223: }
1.66 www 1224:
1225: # -------------------------------------------------------------------- Nickname
1.81 albertel 1226: =pod
1227:
1228: =item nickname($uname,$udom)
1229:
1230: Gets a users name and returns it as a string as
1231:
1232: ""nickname""
1.66 www 1233:
1.81 albertel 1234: if the user has a nickname or
1235:
1236: "first middle last generation"
1237:
1238: if the user does not
1239:
1240: =cut
1.66 www 1241:
1242: sub nickname {
1243: my ($uname,$udom)=@_;
1244: my %names=&Apache::lonnet::get('environment',
1245: ['nickname','firstname','middlename','lastname','generation'],$udom,$uname);
1.68 albertel 1246: my $name=$names{'nickname'};
1.66 www 1247: if ($name) {
1248: $name='"'.$name.'"';
1249: } else {
1250: $name=$names{'firstname'}.' '.$names{'middlename'}.' '.
1251: $names{'lastname'}.' '.$names{'generation'};
1252: $name=~s/\s+$//;
1253: $name=~s/\s+/ /g;
1254: }
1255: return $name;
1256: }
1257:
1.61 www 1258:
1259: # ------------------------------------------------------------------ Screenname
1.81 albertel 1260:
1261: =pod
1262:
1263: =item screenname($uname,$udom)
1264:
1265: Gets a users screenname and returns it as a string
1266:
1267: =cut
1.61 www 1268:
1269: sub screenname {
1270: my ($uname,$udom)=@_;
1271: my %names=
1272: &Apache::lonnet::get('environment',['screenname'],$udom,$uname);
1.68 albertel 1273: return $names{'screenname'};
1.62 www 1274: }
1275:
1276: # ------------------------------------------------------------- Message Wrapper
1277:
1278: sub messagewrapper {
1279: my ($link,$un,$do)=@_;
1280: return
1281: "<a href='/adm/email?compose=individual&recname=$un&recdom=$do'>$link</a>";
1.74 www 1282: }
1283: # --------------------------------------------------------------- Notes Wrapper
1284:
1285: sub noteswrapper {
1286: my ($link,$un,$do)=@_;
1287: return
1288: "<a href='/adm/email?recordftf=retrieve&recname=$un&recdom=$do'>$link</a>";
1.62 www 1289: }
1290: # ------------------------------------------------------------- Aboutme Wrapper
1291:
1292: sub aboutmewrapper {
1.69 matthew 1293: my ($link,$username,$domain)=@_;
1294: return "<a href='/adm/$domain/$username/aboutme'>$link</a>";
1.62 www 1295: }
1296:
1297: # ------------------------------------------------------------ Syllabus Wrapper
1298:
1299:
1300: sub syllabuswrapper {
1.73 www 1301: my ($link,$un,$do,$tf)=@_;
1302: if ($tf) { $link='<font color="'.$tf.'">'.$link.'</font>'; }
1.62 www 1303: return "<a href='/public/$do/$un/syllabus'>$link</a>";
1.61 www 1304: }
1.14 harris41 1305:
1306: # ---------------------------------------------------------------- Language IDs
1307: sub languageids {
1.16 harris41 1308: return sort(keys(%language));
1.14 harris41 1309: }
1310:
1311: # -------------------------------------------------------- Language Description
1312: sub languagedescription {
1.16 harris41 1313: return $language{shift(@_)};
1.14 harris41 1314: }
1315:
1316: # --------------------------------------------------------------- Copyright IDs
1317: sub copyrightids {
1.16 harris41 1318: return sort(keys(%cprtag));
1.14 harris41 1319: }
1320:
1321: # ------------------------------------------------------- Copyright Description
1322: sub copyrightdescription {
1.16 harris41 1323: return $cprtag{shift(@_)};
1.14 harris41 1324: }
1325:
1326: # ------------------------------------------------------------- File Categories
1327: sub filecategories {
1.41 ng 1328: return sort(keys(%category_extensions));
1.15 harris41 1329: }
1.14 harris41 1330:
1.17 harris41 1331: # -------------------------------------- File Types within a specified category
1.15 harris41 1332: sub filecategorytypes {
1.41 ng 1333: return @{$category_extensions{lc($_[0])}};
1.14 harris41 1334: }
1335:
1336: # ------------------------------------------------------------------ File Types
1337: sub fileextensions {
1.16 harris41 1338: return sort(keys(%fe));
1.14 harris41 1339: }
1340:
1341: # ------------------------------------------------------------- Embedding Style
1342: sub fileembstyle {
1.16 harris41 1343: return $fe{lc(shift(@_))};
1.14 harris41 1344: }
1345:
1346: # ------------------------------------------------------------ Description Text
1347: sub filedescription {
1.16 harris41 1348: return $fd{lc(shift(@_))};
1349: }
1350:
1351: # ------------------------------------------------------------ Description Text
1352: sub filedescriptionex {
1353: my $ex=shift;
1354: return '.'.$ex.' '.$fd{lc($ex)};
1.12 harris41 1355: }
1.1 albertel 1356:
1.40 ng 1357: # ---- Retrieve attempts by students
1358: # input
1359: # $symb - problem including path
1360: # $username,$domain - that of the student
1361: # $course - course name
1362: # $getattempt - leave blank if want all attempts, else put something.
1.43 ng 1363: # $regexp - regular expression. If string matches regexp send to
1364: # $gradesub - routine that process the string if it matches regexp
1.40 ng 1365: #
1366: # output
1367: # formatted as a table all the attempts, if any.
1368: #
1.1 albertel 1369: sub get_previous_attempt {
1.43 ng 1370: my ($symb,$username,$domain,$course,$getattempt,$regexp,$gradesub)=@_;
1.1 albertel 1371: my $prevattempts='';
1.43 ng 1372: no strict 'refs';
1.1 albertel 1373: if ($symb) {
1.3 albertel 1374: my (%returnhash)=
1375: &Apache::lonnet::restore($symb,$course,$domain,$username);
1.1 albertel 1376: if ($returnhash{'version'}) {
1377: my %lasthash=();
1378: my $version;
1379: for ($version=1;$version<=$returnhash{'version'};$version++) {
1.19 harris41 1380: foreach (sort(split(/\:/,$returnhash{$version.':keys'}))) {
1.1 albertel 1381: $lasthash{$_}=$returnhash{$version.':'.$_};
1.19 harris41 1382: }
1.1 albertel 1383: }
1.43 ng 1384: $prevattempts='<table border="0" width="100%"><tr><td bgcolor="#777777">';
1.40 ng 1385: $prevattempts.='<table border="0" width="100%"><tr bgcolor="#e6ffff"><td>History</td>';
1.16 harris41 1386: foreach (sort(keys %lasthash)) {
1.31 albertel 1387: my ($ign,@parts) = split(/\./,$_);
1.41 ng 1388: if ($#parts > 0) {
1.31 albertel 1389: my $data=$parts[-1];
1390: pop(@parts);
1.40 ng 1391: $prevattempts.='<td>Part '.join('.',@parts).'<br />'.$data.' </td>';
1.31 albertel 1392: } else {
1.41 ng 1393: if ($#parts == 0) {
1394: $prevattempts.='<th>'.$parts[0].'</th>';
1395: } else {
1396: $prevattempts.='<th>'.$ign.'</th>';
1397: }
1.31 albertel 1398: }
1.16 harris41 1399: }
1.40 ng 1400: if ($getattempt eq '') {
1401: for ($version=1;$version<=$returnhash{'version'};$version++) {
1402: $prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Transaction '.$version.'</td>';
1403: foreach (sort(keys %lasthash)) {
1404: my $value;
1405: if ($_ =~ /timestamp/) {
1406: $value=scalar(localtime($returnhash{$version.':'.$_}));
1407: } else {
1408: $value=$returnhash{$version.':'.$_};
1409: }
1410: $prevattempts.='<td>'.$value.' </td>';
1411: }
1412: }
1.1 albertel 1413: }
1.40 ng 1414: $prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Current</td>';
1.16 harris41 1415: foreach (sort(keys %lasthash)) {
1.5 albertel 1416: my $value;
1417: if ($_ =~ /timestamp/) {
1418: $value=scalar(localtime($lasthash{$_}));
1419: } else {
1420: $value=$lasthash{$_};
1421: }
1.49 ng 1422: if ($_ =~/$regexp$/ && (defined &$gradesub)) {$value = &$gradesub($value)}
1.40 ng 1423: $prevattempts.='<td>'.$value.' </td>';
1.16 harris41 1424: }
1.40 ng 1425: $prevattempts.='</tr></table></td></tr></table>';
1.1 albertel 1426: } else {
1427: $prevattempts='Nothing submitted - no attempts.';
1428: }
1429: } else {
1430: $prevattempts='No data.';
1431: }
1.10 albertel 1432: }
1433:
1434: sub get_student_view {
1.64 sakharuk 1435: my ($symb,$username,$domain,$courseid,$target) = @_;
1.10 albertel 1436: my ($map,$id,$feedurl) = split(/___/,$symb);
1437: my (%old,%moreenv);
1438: my @elements=('symb','courseid','domain','username');
1439: foreach my $element (@elements) {
1440: $old{$element}=$ENV{'form.grade_'.$element};
1441: $moreenv{'form.grade_'.$element}=eval '$'.$element #'
1442: }
1.64 sakharuk 1443: if ($target eq 'tex') {$moreenv{'form.grade_target'} = 'tex';}
1.11 albertel 1444: &Apache::lonnet::appenv(%moreenv);
1445: my $userview=&Apache::lonnet::ssi('/res/'.$feedurl);
1446: &Apache::lonnet::delenv('form.grade_');
1447: foreach my $element (@elements) {
1448: $ENV{'form.grade_'.$element}=$old{$element};
1449: }
1450: $userview=~s/\<body[^\>]*\>//gi;
1451: $userview=~s/\<\/body\>//gi;
1452: $userview=~s/\<html\>//gi;
1453: $userview=~s/\<\/html\>//gi;
1454: $userview=~s/\<head\>//gi;
1455: $userview=~s/\<\/head\>//gi;
1456: $userview=~s/action\s*\=/would_be_action\=/gi;
1457: return $userview;
1458: }
1459:
1460: sub get_student_answers {
1461: my ($symb,$username,$domain,$courseid) = @_;
1462: my ($map,$id,$feedurl) = split(/___/,$symb);
1463: my (%old,%moreenv);
1464: my @elements=('symb','courseid','domain','username');
1465: foreach my $element (@elements) {
1466: $old{$element}=$ENV{'form.grade_'.$element};
1467: $moreenv{'form.grade_'.$element}=eval '$'.$element #'
1468: }
1469: $moreenv{'form.grade_target'}='answer';
1.10 albertel 1470: &Apache::lonnet::appenv(%moreenv);
1471: my $userview=&Apache::lonnet::ssi('/res/'.$feedurl);
1472: &Apache::lonnet::delenv('form.grade_');
1473: foreach my $element (@elements) {
1474: $ENV{'form.grade_'.$element}=$old{$element};
1475: }
1476: return $userview;
1.1 albertel 1477: }
1.37 matthew 1478:
1479: ###############################################
1.51 www 1480:
1481:
1482: sub timehash {
1483: my @ltime=localtime(shift);
1484: return ( 'seconds' => $ltime[0],
1485: 'minutes' => $ltime[1],
1486: 'hours' => $ltime[2],
1487: 'day' => $ltime[3],
1488: 'month' => $ltime[4]+1,
1489: 'year' => $ltime[5]+1900,
1490: 'weekday' => $ltime[6],
1491: 'dayyear' => $ltime[7]+1,
1492: 'dlsav' => $ltime[8] );
1493: }
1494:
1495: sub maketime {
1496: my %th=@_;
1497: return POSIX::mktime(
1498: ($th{'seconds'},$th{'minutes'},$th{'hours'},
1499: $th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,$th{'dlsav'}));
1500: }
1501:
1.70 www 1502:
1503: #########################################
1504: #
1505: # Retro-fixing of un-backward-compatible time format
1506:
1507: sub unsqltime {
1508: my $timestamp=shift;
1509: if ($timestamp=~/^(\d+)\-(\d+)\-(\d+)\s+(\d+)\:(\d+)\:(\d+)$/) {
1510: $timestamp=&maketime(
1511: 'year'=>$1,'month'=>$2,'day'=>$3,
1512: 'hours'=>$4,'minutes'=>$5,'seconds'=>$6);
1513: }
1514: return $timestamp;
1515: }
1516:
1517: #########################################
1.51 www 1518:
1519: sub findallcourses {
1520: my %courses=();
1521: my $now=time;
1522: foreach (keys %ENV) {
1523: if ($_=~/^user\.role\.\w+\.\/(\w+)\/(\w+)/) {
1524: my ($starttime,$endtime)=$ENV{$_};
1525: my $active=1;
1526: if ($starttime) {
1527: if ($now<$starttime) { $active=0; }
1528: }
1529: if ($endtime) {
1530: if ($now>$endtime) { $active=0; }
1531: }
1532: if ($active) { $courses{$1.'_'.$2}=1; }
1533: }
1534: }
1535: return keys %courses;
1536: }
1.37 matthew 1537:
1.54 www 1538: ###############################################
1.60 matthew 1539: ###############################################
1540:
1541: =pod
1542:
1.63 www 1543: =item &determinedomain()
1.60 matthew 1544:
1545: Inputs: $domain (usually will be undef)
1546:
1.63 www 1547: Returns: Determines which domain should be used for designs
1.60 matthew 1548:
1549: =cut
1.54 www 1550:
1.60 matthew 1551: ###############################################
1.63 www 1552: sub determinedomain {
1553: my $domain=shift;
1554: if (! $domain) {
1.60 matthew 1555: # Determine domain if we have not been given one
1556: $domain = $Apache::lonnet::perlvar{'lonDefDomain'};
1557: if ($ENV{'user.domain'}) { $domain=$ENV{'user.domain'}; }
1558: if ($ENV{'request.role.domain'}) {
1559: $domain=$ENV{'request.role.domain'};
1560: }
1561: }
1.63 www 1562: return $domain;
1563: }
1564: ###############################################
1565: =pod
1566:
1567: =item &domainlogo()
1568:
1569: Inputs: $domain (usually will be undef)
1570:
1571: Returns: A link to a domain logo, if the domain logo exists.
1572: If the domain logo does not exist, a description of the domain.
1573:
1574: =cut
1575: ###############################################
1576: sub domainlogo {
1577: my $domain = &determinedomain(shift);
1578: # See if there is a logo
1.59 www 1579: if (-e '/home/httpd/html/adm/lonDomLogos/'.$domain.'.gif') {
1.83 albertel 1580: my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'};
1581: if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; }
1582: return '<img src="http://'.$ENV{'HTTP_HOST'}.':'.$lonhttpdPort.
1583: '/adm/lonDomLogos/'.$domain.'.gif" />';
1.60 matthew 1584: } elsif(exists($Apache::lonnet::domaindescription{$domain})) {
1585: return $Apache::lonnet::domaindescription{$domain};
1.59 www 1586: } else {
1.60 matthew 1587: return '';
1.59 www 1588: }
1589: }
1.63 www 1590: ##############################################
1591:
1592: =pod
1593:
1594: =item &designparm()
1595:
1596: Inputs: $which parameter; $domain (usually will be undef)
1597:
1598: Returns: value of designparamter $which
1599:
1600: =cut
1601: ##############################################
1602: sub designparm {
1603: my ($which,$domain)=@_;
1604: $domain=&determinedomain($domain);
1605: if ($designhash{$domain.'.'.$which}) {
1606: return $designhash{$domain.'.'.$which};
1607: } else {
1608: return $designhash{'default.'.$which};
1609: }
1610: }
1.59 www 1611:
1.60 matthew 1612: ###############################################
1613: ###############################################
1614:
1615: =pod
1616:
1617: =item &bodytag()
1618:
1619: Returns a uniform header for LON-CAPA web pages.
1620:
1621: Inputs:
1622:
1623: $title, A title to be displayed on the page.
1624: $function, the current role (can be undef).
1625: $addentries, extra parameters for the <body> tag.
1626: $bodyonly, if defined, only return the <body> tag.
1627: $domain, if defined, force a given domain.
1.86 www 1628: $forcereg, if page should register as content page (relevant for
1629: text interface only)
1.60 matthew 1630:
1631: Returns: A uniform header for LON-CAPA web pages.
1632: If $bodyonly is nonzero, a string containing a <body> tag will be returned.
1633: If $bodyonly is undef or zero, an html string containing a <body> tag and
1634: other decorations will be returned.
1635:
1636: =cut
1637:
1638: ###############################################
1.63 www 1639:
1640:
1.60 matthew 1641: ###############################################
1.54 www 1642: sub bodytag {
1.86 www 1643: my ($title,$function,$addentries,$bodyonly,$domain,$forcereg)=@_;
1.55 www 1644: unless ($function) {
1645: $function='student';
1646: if ($ENV{'request.role'}=~/^(cc|in|ta|ep)/) {
1647: $function='coordinator';
1648: }
1649: if ($ENV{'request.role'}=~/^(su|dc|ad|li)/) {
1650: $function='admin';
1651: }
1652: if (($ENV{'request.role'}=~/^(au|ca)/) ||
1653: ($ENV{'REQUEST_URI'}=~/^(\/priv|\~)/)) {
1654: $function='author';
1655: }
1656: }
1.63 www 1657: my $img=&designparm($function.'.img',$domain);
1658: my $pgbg=&designparm($function.'.pgbg',$domain);
1659: my $tabbg=&designparm($function.'.tabbg',$domain);
1660: my $font=&designparm($function.'.font',$domain);
1661: my $link=&designparm($function.'.link',$domain);
1662: my $alink=&designparm($function.'.alink',$domain);
1663: my $vlink=&designparm($function.'.vlink',$domain);
1664: my $sidebg=&designparm($function.'.sidebg',$domain);
1665:
1666: # role and realm
1.55 www 1667: my ($role,$realm)
1668: =&Apache::lonnet::plaintext((split(/\./,$ENV{'request.role'}))[0]);
1669: # realm
1.54 www 1670: if ($ENV{'request.course.id'}) {
1.55 www 1671: $realm=
1672: $ENV{'course.'.$ENV{'request.course.id'}.'.description'};
1.54 www 1673: }
1.55 www 1674: unless ($realm) { $realm=' '; }
1675: # Set messages
1.60 matthew 1676: my $messages=&domainlogo($domain);
1.55 www 1677: # Output
1.83 albertel 1678: my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'};
1679: if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; }
1.60 matthew 1680: my $bodytag = <<END;
1.54 www 1681: <body bgcolor="$pgbg" text="$font" alink="$alink" vlink="$vlink" link="$link"
1682: $addentries>
1.60 matthew 1683: END
1684: if ($bodyonly) {
1685: return $bodytag;
1.79 www 1686: } elsif ($ENV{'browser.interface'} eq 'textual') {
1.86 www 1687: return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web',
1688: $forcereg).
1.82 www 1689: '<h1>LON-CAPA: '.$title.'</h1>';
1.60 matthew 1690: } else {
1691: return(<<ENDBODY);
1692: $bodytag
1.55 www 1693: <table width="100%" cellspacing="0" border="0" cellpadding="0">
1694: <tr><td bgcolor="$font">
1.83 albertel 1695: <img src="http://$ENV{'HTTP_HOST'}:$lonhttpdPort$img" /></td>
1.63 www 1696: <td bgcolor="$font"><font color='$sidebg'>$messages</font></td>
1.55 www 1697: </tr>
1.54 www 1698: <tr>
1.55 www 1699: <td rowspan="3" bgcolor="$tabbg">
1700: <font size="5"><b>$title</b></font>
1.54 www 1701: <td bgcolor="$tabbg" align="right">
1702: <font size="2">
1703: $ENV{'environment.firstname'}
1704: $ENV{'environment.middlename'}
1705: $ENV{'environment.lastname'}
1706: $ENV{'environment.generation'}
1.55 www 1707: </font>
1.54 www 1708: </td>
1709: </tr>
1710: <tr><td bgcolor="$tabbg" align="right">
1.55 www 1711: <font size="2">$role</font>
1.54 www 1712: </td></tr>
1.55 www 1713: <tr>
1714: <td bgcolor="$tabbg" align="right"><font size="2">$realm</font> </td></tr>
1.54 www 1715: </table><br>
1716: ENDBODY
1.60 matthew 1717: }
1.54 www 1718: }
1.37 matthew 1719: ###############################################
1.1 albertel 1720:
1.6 albertel 1721: sub get_unprocessed_cgi {
1.25 albertel 1722: my ($query,$possible_names)= @_;
1.26 matthew 1723: # $Apache::lonxml::debug=1;
1.16 harris41 1724: foreach (split(/&/,$query)) {
1.6 albertel 1725: my ($name, $value) = split(/=/,$_);
1.25 albertel 1726: $name = &Apache::lonnet::unescape($name);
1727: if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) {
1728: $value =~ tr/+/ /;
1729: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
1730: &Apache::lonxml::debug("Seting :$name: to :$value:");
1.30 albertel 1731: unless (defined($ENV{'form.'.$name})) { &add_to_env('form.'.$name,$value) };
1.25 albertel 1732: }
1.16 harris41 1733: }
1.6 albertel 1734: }
1735:
1.7 albertel 1736: sub cacheheader {
1.23 www 1737: unless ($ENV{'request.method'} eq 'GET') { return ''; }
1.8 albertel 1738: my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
1.7 albertel 1739: my $output .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" />
1740: <meta HTTP-EQUIV="Cache-control" CONTENT="no-cache" />
1741: <meta HTTP-EQUIV="Pragma" CONTENT="no-cache" />';
1742: return $output;
1743: }
1744:
1.9 albertel 1745: sub no_cache {
1746: my ($r) = @_;
1.23 www 1747: unless ($ENV{'request.method'} eq 'GET') { return ''; }
1.24 albertel 1748: #my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
1.9 albertel 1749: $r->no_cache(1);
1750: $r->header_out("Pragma" => "no-cache");
1.24 albertel 1751: #$r->header_out("Expires" => $date);
1.9 albertel 1752: }
1.25 albertel 1753:
1754: sub add_to_env {
1755: my ($name,$value)=@_;
1.28 albertel 1756: if (defined($ENV{$name})) {
1.27 albertel 1757: if (ref($ENV{$name})) {
1.25 albertel 1758: #already have multiple values
1759: push(@{ $ENV{$name} },$value);
1760: } else {
1761: #first time seeing multiple values, convert hash entry to an arrayref
1762: my $first=$ENV{$name};
1763: undef($ENV{$name});
1764: push(@{ $ENV{$name} },$first,$value);
1765: }
1766: } else {
1767: $ENV{$name}=$value;
1768: }
1.31 albertel 1769: }
1770:
1.41 ng 1771: =pod
1.45 matthew 1772:
1773: =back
1.41 ng 1774:
1775: =head2 CSV Upload/Handling functions
1.38 albertel 1776:
1.41 ng 1777: =over 4
1778:
1779: =item upfile_store($r)
1780:
1781: Store uploaded file, $r should be the HTTP Request object,
1782: needs $ENV{'form.upfile'}
1783: returns $datatoken to be put into hidden field
1784:
1785: =cut
1.31 albertel 1786:
1787: sub upfile_store {
1788: my $r=shift;
1789: $ENV{'form.upfile'}=~s/\r/\n/gs;
1790: $ENV{'form.upfile'}=~s/\f/\n/gs;
1791: $ENV{'form.upfile'}=~s/\n+/\n/gs;
1792: $ENV{'form.upfile'}=~s/\n+$//gs;
1793:
1794: my $datatoken=$ENV{'user.name'}.'_'.$ENV{'user.domain'}.
1795: '_enroll_'.$ENV{'request.course.id'}.'_'.time.'_'.$$;
1796: {
1797: my $fh=Apache::File->new('>'.$r->dir_config('lonDaemons').
1798: '/tmp/'.$datatoken.'.tmp');
1799: print $fh $ENV{'form.upfile'};
1800: }
1801: return $datatoken;
1802: }
1803:
1.56 matthew 1804: =pod
1805:
1.41 ng 1806: =item load_tmp_file($r)
1807:
1808: Load uploaded file from tmp, $r should be the HTTP Request object,
1809: needs $ENV{'form.datatoken'},
1810: sets $ENV{'form.upfile'} to the contents of the file
1811:
1812: =cut
1.31 albertel 1813:
1814: sub load_tmp_file {
1815: my $r=shift;
1816: my @studentdata=();
1817: {
1818: my $fh;
1819: if ($fh=Apache::File->new($r->dir_config('lonDaemons').
1820: '/tmp/'.$ENV{'form.datatoken'}.'.tmp')) {
1821: @studentdata=<$fh>;
1822: }
1823: }
1824: $ENV{'form.upfile'}=join('',@studentdata);
1825: }
1826:
1.56 matthew 1827: =pod
1828:
1.41 ng 1829: =item upfile_record_sep()
1830:
1831: Separate uploaded file into records
1832: returns array of records,
1833: needs $ENV{'form.upfile'} and $ENV{'form.upfiletype'}
1834:
1835: =cut
1.31 albertel 1836:
1837: sub upfile_record_sep {
1838: if ($ENV{'form.upfiletype'} eq 'xml') {
1839: } else {
1840: return split(/\n/,$ENV{'form.upfile'});
1841: }
1842: }
1843:
1.56 matthew 1844: =pod
1845:
1.41 ng 1846: =item record_sep($record)
1847:
1848: Separate a record into fields $record should be an item from the upfile_record_sep(), needs $ENV{'form.upfiletype'}
1849:
1850: =cut
1851:
1.31 albertel 1852: sub record_sep {
1853: my $record=shift;
1854: my %components=();
1855: if ($ENV{'form.upfiletype'} eq 'xml') {
1856: } elsif ($ENV{'form.upfiletype'} eq 'space') {
1857: my $i=0;
1858: foreach (split(/\s+/,$record)) {
1859: my $field=$_;
1860: $field=~s/^(\"|\')//;
1861: $field=~s/(\"|\')$//;
1862: $components{$i}=$field;
1863: $i++;
1864: }
1865: } elsif ($ENV{'form.upfiletype'} eq 'tab') {
1866: my $i=0;
1867: foreach (split(/\t+/,$record)) {
1868: my $field=$_;
1869: $field=~s/^(\"|\')//;
1870: $field=~s/(\"|\')$//;
1871: $components{$i}=$field;
1872: $i++;
1873: }
1874: } else {
1875: my @allfields=split(/\,/,$record);
1876: my $i=0;
1877: my $j;
1878: for ($j=0;$j<=$#allfields;$j++) {
1879: my $field=$allfields[$j];
1880: if ($field=~/^\s*(\"|\')/) {
1881: my $delimiter=$1;
1882: while (($field!~/$delimiter$/) && ($j<$#allfields)) {
1883: $j++;
1884: $field.=','.$allfields[$j];
1885: }
1886: $field=~s/^\s*$delimiter//;
1887: $field=~s/$delimiter\s*$//;
1888: }
1889: $components{$i}=$field;
1890: $i++;
1891: }
1892: }
1893: return %components;
1894: }
1895:
1.56 matthew 1896: =pod
1897:
1.41 ng 1898: =item upfile_select_html()
1899:
1900: return HTML code to select file and specify its type
1901:
1902: =cut
1903:
1.31 albertel 1904: sub upfile_select_html {
1905: return (<<'ENDUPFORM');
1.57 albertel 1906: <input type="file" name="upfile" size="50" />
1.31 albertel 1907: <br />Type: <select name="upfiletype">
1908: <option value="csv">CSV (comma separated values, spreadsheet)</option>
1909: <option value="space">Space separated</option>
1910: <option value="tab">Tabulator separated</option>
1911: <option value="xml">HTML/XML</option>
1912: </select>
1913: ENDUPFORM
1914: }
1915:
1.56 matthew 1916: =pod
1917:
1.41 ng 1918: =item csv_print_samples($r,$records)
1919:
1920: Prints a table of sample values from each column uploaded $r is an
1921: Apache Request ref, $records is an arrayref from
1922: &Apache::loncommon::upfile_record_sep
1923:
1924: =cut
1925:
1.31 albertel 1926: sub csv_print_samples {
1927: my ($r,$records) = @_;
1928: my (%sone,%stwo,%sthree);
1929: %sone=&record_sep($$records[0]);
1930: if (defined($$records[1])) {%stwo=&record_sep($$records[1]);}
1931: if (defined($$records[2])) {%sthree=&record_sep($$records[2]);}
1932:
1933: $r->print('Samples<br /><table border="2"><tr>');
1934: foreach (sort({$a <=> $b} keys(%sone))) { $r->print('<th>Column '.($_+1).'</th>'); }
1935: $r->print('</tr>');
1936: foreach my $hash (\%sone,\%stwo,\%sthree) {
1937: $r->print('<tr>');
1938: foreach (sort({$a <=> $b} keys(%sone))) {
1939: $r->print('<td>');
1940: if (defined($$hash{$_})) { $r->print($$hash{$_}); }
1941: $r->print('</td>');
1942: }
1943: $r->print('</tr>');
1944: }
1945: $r->print('</tr></table><br />'."\n");
1946: }
1947:
1.56 matthew 1948: =pod
1949:
1.41 ng 1950: =item csv_print_select_table($r,$records,$d)
1951:
1952: Prints a table to create associations between values and table columns.
1953: $r is an Apache Request ref,
1954: $records is an arrayref from &Apache::loncommon::upfile_record_sep,
1955: $d is an array of 2 element arrays (internal name, displayed name)
1956:
1957: =cut
1958:
1.31 albertel 1959: sub csv_print_select_table {
1960: my ($r,$records,$d) = @_;
1961: my $i=0;my %sone;
1962: %sone=&record_sep($$records[0]);
1963: $r->print('Associate columns with student attributes.'."\n".
1964: '<table border="2"><tr><th>Attribute</th><th>Column</th></tr>'."\n");
1965: foreach (@$d) {
1966: my ($value,$display)=@{ $_ };
1967: $r->print('<tr><td>'.$display.'</td>');
1968:
1969: $r->print('<td><select name=f'.$i.
1.32 matthew 1970: ' onchange="javascript:flip(this.form,'.$i.');">');
1.31 albertel 1971: $r->print('<option value="none"></option>');
1972: foreach (sort({$a <=> $b} keys(%sone))) {
1973: $r->print('<option value="'.$_.'">Column '.($_+1).'</option>');
1974: }
1975: $r->print('</select></td></tr>'."\n");
1976: $i++;
1977: }
1978: $i--;
1979: return $i;
1980: }
1.56 matthew 1981:
1982: =pod
1.31 albertel 1983:
1.41 ng 1984: =item csv_samples_select_table($r,$records,$d)
1985:
1986: Prints a table of sample values from the upload and can make associate samples to internal names.
1987:
1988: $r is an Apache Request ref,
1989: $records is an arrayref from &Apache::loncommon::upfile_record_sep,
1990: $d is an array of 2 element arrays (internal name, displayed name)
1991:
1992: =cut
1993:
1.31 albertel 1994: sub csv_samples_select_table {
1995: my ($r,$records,$d) = @_;
1996: my %sone; my %stwo; my %sthree;
1997: my $i=0;
1998:
1999: $r->print('<table border=2><tr><th>Field</th><th>Samples</th></tr>');
2000: %sone=&record_sep($$records[0]);
2001: if (defined($$records[1])) {%stwo=&record_sep($$records[1]);}
2002: if (defined($$records[2])) {%sthree=&record_sep($$records[2]);}
2003:
2004: foreach (sort keys %sone) {
2005: $r->print('<tr><td><select name=f'.$i.
1.32 matthew 2006: ' onchange="javascript:flip(this.form,'.$i.');">');
1.31 albertel 2007: foreach (@$d) {
2008: my ($value,$display)=@{ $_ };
2009: $r->print('<option value='.$value.'>'.$display.'</option>');
2010: }
2011: $r->print('</select></td><td>');
2012: if (defined($sone{$_})) { $r->print($sone{$_}."</br>\n"); }
2013: if (defined($stwo{$_})) { $r->print($stwo{$_}."</br>\n"); }
2014: if (defined($sthree{$_})) { $r->print($sthree{$_}."</br>\n"); }
2015: $r->print('</td></tr>');
2016: $i++;
2017: }
2018: $i--;
2019: return($i);
1.25 albertel 2020: }
1.84 albertel 2021:
1.85 albertel 2022: =pod
2023:
2024: =item check_if_partid_hidden($id,$symb,$udom,$uname)
2025:
2026: Returns either 1 or undef
2027:
2028: 1 if the part is to be hidden, undef if it is to be shown
2029:
2030: Arguments are:
2031:
2032: $id the id of the part to be checked
2033: $symb, optional the symb of the resource to check
2034: $udom, optional the domain of the user to check for
2035: $uname, optional the username of the user to check for
2036:
2037: =cut
1.84 albertel 2038:
2039: sub check_if_partid_hidden {
2040: my ($id,$symb,$udom,$uname) = @_;
2041: my $hiddenparts=&Apache::lonnet::EXT('resource.0.parameter_hiddenparts',
2042: $symb,$udom,$uname);
2043: my @hiddenlist=split(/,/,$hiddenparts);
2044: foreach my $checkid (@hiddenlist) {
2045: if ($checkid =~ /^\s*\Q$id\E\s*$/) { return 1; }
2046: }
2047: return undef;
2048: }
2049:
2050:
2051:
1.1 albertel 2052: 1;
2053: __END__;
1.17 harris41 2054:
1.41 ng 2055: =pod
2056:
2057: =back
2058:
2059: =head2 Access .tab File Data
2060:
2061: =over 4
2062:
1.35 matthew 2063: =item languageids()
1.17 harris41 2064:
1.35 matthew 2065: returns list of all language ids
1.17 harris41 2066:
1.35 matthew 2067: =item languagedescription()
1.17 harris41 2068:
1.35 matthew 2069: returns description of a specified language id
1.17 harris41 2070:
1.35 matthew 2071: =item copyrightids()
1.17 harris41 2072:
1.35 matthew 2073: returns list of all copyrights
1.17 harris41 2074:
1.35 matthew 2075: =item copyrightdescription()
1.17 harris41 2076:
1.35 matthew 2077: returns description of a specified copyright id
1.17 harris41 2078:
1.35 matthew 2079: =item filecategories()
1.17 harris41 2080:
1.35 matthew 2081: returns list of all file categories
1.17 harris41 2082:
1.35 matthew 2083: =item filecategorytypes()
1.17 harris41 2084:
1.35 matthew 2085: returns list of file types belonging to a given file
1.17 harris41 2086: category
2087:
1.35 matthew 2088: =item fileembstyle()
1.17 harris41 2089:
1.35 matthew 2090: returns embedding style for a specified file type
1.17 harris41 2091:
1.35 matthew 2092: =item filedescription()
1.17 harris41 2093:
1.35 matthew 2094: returns description for a specified file type
1.17 harris41 2095:
1.35 matthew 2096: =item filedescriptionex()
1.17 harris41 2097:
1.35 matthew 2098: returns description for a specified file type with
1.17 harris41 2099: extra formatting
2100:
1.41 ng 2101: =back
2102:
2103: =head2 Alternate Problem Views
2104:
2105: =over 4
2106:
1.35 matthew 2107: =item get_previous_attempt()
1.17 harris41 2108:
1.35 matthew 2109: return string with previous attempt on problem
1.17 harris41 2110:
1.35 matthew 2111: =item get_student_view()
1.17 harris41 2112:
1.35 matthew 2113: show a snapshot of what student was looking at
1.17 harris41 2114:
1.35 matthew 2115: =item get_student_answers()
1.17 harris41 2116:
1.35 matthew 2117: show a snapshot of how student was answering problem
1.17 harris41 2118:
1.41 ng 2119: =back
2120:
2121: =head2 HTTP Helper
2122:
2123: =over 4
2124:
2125: =item get_unprocessed_cgi($query,$possible_names)
2126:
2127: Modify the %ENV hash to contain unprocessed CGI form parameters held in
2128: $query. The parameters listed in $possible_names (an array reference),
2129: will be set in $ENV{'form.name'} if they do not already exist.
1.17 harris41 2130:
1.41 ng 2131: Typically called with $ENV{'QUERY_STRING'} as the first parameter.
2132: $possible_names is an ref to an array of form element names. As an example:
2133: get_unprocessed_cgi($ENV{'QUERY_STRING'},['uname','udom']);
2134: will result in $ENV{'form.uname'} and $ENV{'form.udom'} being set.
1.17 harris41 2135:
1.35 matthew 2136: =item cacheheader()
1.17 harris41 2137:
1.35 matthew 2138: returns cache-controlling header code
1.17 harris41 2139:
1.65 matthew 2140: =item no_cache($r)
1.17 harris41 2141:
1.35 matthew 2142: specifies header code to not have cache
1.25 albertel 2143:
1.35 matthew 2144: =item add_to_env($name,$value)
1.25 albertel 2145:
1.35 matthew 2146: adds $name to the %ENV hash with value
1.25 albertel 2147: $value, if $name already exists, the entry is converted to an array
2148: reference and $value is added to the array.
1.17 harris41 2149:
2150: =back
2151:
2152: =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