1: # The LearningOnline Network with CAPA
2: # a pile of common routines
3: #
4: # $Id: loncommon.pm,v 1.38 2002/06/24 19:06:05 albertel Exp $
5: #
6: # Copyright Michigan State University Board of Trustees
7: #
8: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
9: #
10: # LON-CAPA is free software; you can redistribute it and/or modify
11: # it under the terms of the GNU General Public License as published by
12: # the Free Software Foundation; either version 2 of the License, or
13: # (at your option) any later version.
14: #
15: # LON-CAPA is distributed in the hope that it will be useful,
16: # but WITHOUT ANY WARRANTY; without even the implied warranty of
17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18: # GNU General Public License for more details.
19: #
20: # You should have received a copy of the GNU General Public License
21: # along with LON-CAPA; if not, write to the Free Software
22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
23: #
24: # /home/httpd/html/adm/gpl.txt
25: #
26: # http://www.lon-capa.org/
27: #
28: # YEAR=2001
29: # 2/13-12/7 Guy Albertelli
30: # 12/11,12/12,12/17 Scott Harrison
31: # 12/21 Gerd Kortemeyer
32: # 12/21 Scott Harrison
33: # 12/25,12/28 Gerd Kortemeyer
34: # YEAR=2002
35: # 1/4 Gerd Kortemeyer
36:
37: # Makes a table out of the previous attempts
38: # Inputs result_from_symbread, user, domain, course_id
39: # Reads in non-network-related .tab files
40:
41: # POD header:
42:
43: =head1 NAME
44:
45: Apache::loncommon - pile of common routines
46:
47: =head1 SYNOPSIS
48:
49: Referenced by other mod_perl Apache modules.
50:
51: Invocation:
52: &Apache::loncommon::SUBROUTINENAME(ARGUMENTS);
53:
54: =head1 INTRODUCTION
55:
56: Common collection of used subroutines. This collection helps remove
57: redundancy from other modules and increase efficiency of memory usage.
58:
59: Current things done:
60:
61: Makes a table out of the previous homework attempts
62: Inputs result_from_symbread, user, domain, course_id
63: Reads in non-network-related .tab files
64:
65: This is part of the LearningOnline Network with CAPA project
66: described at http://www.lon-capa.org.
67:
68: =head2 General Subroutines
69:
70: =over 4
71:
72: =cut
73:
74: # End of POD header
75: package Apache::loncommon;
76:
77: use strict;
78: use Apache::lonnet();
79: use POSIX qw(strftime);
80: use Apache::Constants qw(:common);
81: use Apache::lonmsg();
82: my $readit;
83:
84: # ----------------------------------------------- Filetypes/Languages/Copyright
85: my %language;
86: my %cprtag;
87: my %fe; my %fd;
88: my %fc;
89:
90: # -------------------------------------------------------------- Thesaurus data
91: my @therelated;
92: my @theword;
93: my @thecount;
94: my %theindex;
95: my $thetotalcount;
96: my $thefuzzy=2;
97: my $thethreshold=0.1/$thefuzzy;
98: my $theavecount;
99:
100: # ----------------------------------------------------------------------- BEGIN
101:
102: =pod
103:
104: =item BEGIN()
105:
106: Initialize values from language.tab, copyright.tab, filetypes.tab,
107: and filecategories.tab.
108:
109: =cut
110: # ----------------------------------------------------------------------- BEGIN
111:
112: BEGIN {
113:
114: unless ($readit) {
115: # ------------------------------------------------------------------- languages
116: {
117: my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
118: '/language.tab');
119: if ($fh) {
120: while (<$fh>) {
121: next if /^\#/;
122: chomp;
123: my ($key,$val)=(split(/\s+/,$_,2));
124: $language{$key}=$val;
125: }
126: }
127: }
128: # ------------------------------------------------------------------ copyrights
129: {
130: my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonIncludes'}.
131: '/copyright.tab');
132: if ($fh) {
133: while (<$fh>) {
134: next if /^\#/;
135: chomp;
136: my ($key,$val)=(split(/\s+/,$_,2));
137: $cprtag{$key}=$val;
138: }
139: }
140: }
141: # ------------------------------------------------------------- file categories
142: {
143: my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
144: '/filecategories.tab');
145: if ($fh) {
146: while (<$fh>) {
147: next if /^\#/;
148: chomp;
149: my ($key,$val)=(split(/\s+/,$_,2));
150: push @{$fc{$key}},$val;
151: }
152: }
153: }
154: # ------------------------------------------------------------------ file types
155: {
156: my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
157: '/filetypes.tab');
158: if ($fh) {
159: while (<$fh>) {
160: next if (/^\#/);
161: chomp;
162: my ($ending,$emb,$descr)=split(/\s+/,$_,3);
163: if ($descr ne '') {
164: $fe{$ending}=lc($emb);
165: $fd{$ending}=$descr;
166: }
167: }
168: }
169: }
170: # -------------------------------------------------------------- Thesaurus data
171: {
172: my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
173: '/thesaurus.dat');
174: if ($fh) {
175: while (<$fh>) {
176: my ($tword,$tindex,$tcount,$trelated)=split(/\@/,$_);
177: $theindex{$tword}=$tindex;
178: $theword[$tindex]=$tword;
179: $thecount[$tindex]=$tcount;
180: $thetotalcount+=$tcount;
181: $therelated[$tindex]=$trelated;
182: }
183: }
184: $theavecount=$thetotalcount/$#thecount;
185: }
186: &Apache::lonnet::logthis(
187: "<font color=yellow>INFO: Read file types and thesaurus</font>");
188: $readit=1;
189: }
190:
191: }
192: # ============================================================= END BEGIN BLOCK
193:
194: =item linked_select_forms(...)
195:
196: linked_select_forms returns a string containing a <script></script> block
197: and html for two <select> menus. The select menus will be linked in that
198: changing the value of the first menu will result in new values being placed
199: in the second menu. The values in the select menu will appear in alphabetical
200: order.
201:
202: linked_select_forms takes the following ordered inputs:
203:
204: =over 4
205:
206: =item $formname, the name of the <form> tag
207:
208: =item $middletext, the text which appears between the <select> tags
209:
210: =item $firstdefault, the default value for the first menu
211:
212: =item $firstselectname, the name of the first <select> tag
213:
214: =item $secondselectname, the name of the second <select> tag
215:
216: =item $hashref, a reference to a hash containing the data for the menus.
217:
218: Below is an example of such a hash. Only the 'text', 'default', and
219: 'select2' keys must appear as stated. keys(%menu) are the possible
220: values for the first select menu. The text that coincides with the
221: first menu values is given in $menu{$choice1}->{'text'}. The values
222: and text for the second menu are given in the hash pointed to by
223: $menu{$choice1}->{'select2'}.
224:
225: my %menu = ( A1 => { text =>"Choice A1" ,
226: default => "B3",
227: select2 => {
228: B1 => "Choice B1",
229: B2 => "Choice B2",
230: B3 => "Choice B3",
231: B4 => "Choice B4"
232: }
233: },
234: A2 => { text =>"Choice A2" ,
235: default => "C2",
236: select2 => {
237: C1 => "Choice C1",
238: C2 => "Choice C2",
239: C3 => "Choice C3"
240: }
241: },
242: A3 => { text =>"Choice A3" ,
243: default => "D6",
244: select2 => {
245: D1 => "Choice D1",
246: D2 => "Choice D2",
247: D3 => "Choice D3",
248: D4 => "Choice D4",
249: D5 => "Choice D5",
250: D6 => "Choice D6",
251: D7 => "Choice D7"
252: }
253: }
254: );
255:
256: =back
257:
258: =cut
259:
260: # ------------------------------------------------
261:
262: sub linked_select_forms {
263: my ($formname,
264: $middletext,
265: $firstdefault,
266: $firstselectname,
267: $secondselectname,
268: $hashref
269: ) = @_;
270: my $second = "document.$formname.$secondselectname";
271: my $first = "document.$formname.$firstselectname";
272: # output the javascript to do the changing
273: my $result = '';
274: $result.="<script>\n";
275: $result.="var select2data = new Object();\n";
276: $" = '","';
277: my $debug = '';
278: foreach my $s1 (sort(keys(%$hashref))) {
279: $result.="select2data.d_$s1 = new Object();\n";
280: $result.="select2data.d_$s1.def = new String('".
281: $hashref->{$s1}->{'default'}."');\n";
282: $result.="select2data.d_$s1.values = new Array(";
283: my @s2values = sort(keys( %{ $hashref->{$s1}->{'select2'} } ));
284: $result.="\"@s2values\");\n";
285: $result.="select2data.d_$s1.texts = new Array(";
286: my @s2texts;
287: foreach my $value (@s2values) {
288: push @s2texts, $hashref->{$s1}->{'select2'}->{$value};
289: }
290: $result.="\"@s2texts\");\n";
291: }
292: $"=' ';
293: $result.= <<"END";
294:
295: function select1_changed() {
296: // Determine new choice
297: var newvalue = "d_" + $first.value;
298: // update select2
299: var values = select2data[newvalue].values;
300: var texts = select2data[newvalue].texts;
301: var select2def = select2data[newvalue].def;
302: var i;
303: // out with the old
304: for (i = 0; i < $second.options.length; i++) {
305: $second.options[i] = null;
306: }
307: // in with the nuclear
308: for (i=0;i<values.length; i++) {
309: $second.options[i] = new Option(values[i]);
310: $second.options[i].text = texts[i];
311: if (values[i] == select2def) {
312: $second.options[i].selected = true;
313: }
314: }
315: }
316: </script>
317: END
318: # output the initial values for the selection lists
319: $result .= "<select size=\"1\" name=\"$firstselectname\" onchange=\"select1_changed()\">\n";
320: foreach my $value (sort(keys(%$hashref))) {
321: $result.=" <option value=\"$value\" ";
322: $result.=" selected=\"true\" " if ($value eq $firstdefault);
323: $result.=">$hashref->{$value}->{'text'}</option>\n";
324: }
325: $result .= "</select>\n";
326: my %select2 = %{$hashref->{$firstdefault}->{'select2'}};
327: $result .= $middletext;
328: $result .= "<select size=\"1\" name=\"$secondselectname\">\n";
329: my $seconddefault = $hashref->{$firstdefault}->{'default'};
330: foreach my $value (sort(keys(%select2))) {
331: $result.=" <option value=\"$value\" ";
332: $result.=" selected=\"true\" " if ($value eq $seconddefault);
333: $result.=">$select2{$value}</option>\n";
334: }
335: $result .= "</select>\n";
336: # return $debug;
337: return $result;
338: } # end of sub linked_select_forms {
339:
340: ###############################################################
341:
342: =item csv_translate($text)
343:
344: Translate $text to allow it to be output as a 'comma seperated values'
345: format.
346:
347: =cut
348:
349: sub csv_translate {
350: my $text = shift;
351: $text =~ s/\"/\"\"/g;
352: $text =~ s/\n//g;
353: return $text;
354: }
355:
356: ###############################################################
357:
358: ###############################################################
359: ## Home server <option> list generating code ##
360: ###############################################################
361: #-------------------------------------------
362:
363: =item get_domains()
364:
365: Returns an array containing each of the domains listed in the hosts.tab
366: file.
367:
368: =cut
369:
370: #-------------------------------------------
371: sub get_domains {
372: # The code below was stolen from "The Perl Cookbook", p 102, 1st ed.
373: my @domains;
374: my %seen;
375: foreach (sort values(%Apache::lonnet::hostdom)) {
376: push (@domains,$_) unless $seen{$_}++;
377: }
378: return @domains;
379: }
380:
381: #-------------------------------------------
382:
383: =item select_dom_form($defdom,$name)
384:
385: Returns a string containing a <select name='$name' size='1'> form to
386: allow a user to select the domain to preform an operation in.
387: See loncreateuser.pm for an example invocation and use.
388:
389: =cut
390:
391: #-------------------------------------------
392: sub select_dom_form {
393: my ($defdom,$name) = @_;
394: my @domains = get_domains();
395: my $selectdomain = "<select name=\"$name\" size=\"1\">\n";
396: foreach (@domains) {
397: $selectdomain.="<option value=\"$_\" ".
398: ($_ eq $defdom ? 'selected' : '').
399: ">$_</option>\n";
400: }
401: $selectdomain.="</select>";
402: return $selectdomain;
403: }
404:
405: #-------------------------------------------
406:
407: =item get_home_servers($domain)
408:
409: Returns a hash which contains keys like '103l3' and values like
410: 'kirk.lite.msu.edu'. All of the keys will be for machines in the
411: given $domain.
412:
413: =cut
414:
415: #-------------------------------------------
416: sub get_home_servers {
417: my $domain = shift;
418: my %home_servers;
419: foreach (keys(%Apache::lonnet::libserv)) {
420: if ($Apache::lonnet::hostdom{$_} eq $domain) {
421: $home_servers{$_} = $Apache::lonnet::hostname{$_};
422: }
423: }
424: return %home_servers;
425: }
426:
427: #-------------------------------------------
428:
429: =item home_server_option_list($domain)
430:
431: returns a string which contains an <option> list to be used in a
432: <select> form input. See loncreateuser.pm for an example.
433:
434: =cut
435:
436: #-------------------------------------------
437: sub home_server_option_list {
438: my $domain = shift;
439: my %servers = &get_home_servers($domain);
440: my $result = '';
441: foreach (sort keys(%servers)) {
442: $result.=
443: '<option value="'.$_.'">'.$_.' '.$servers{$_}."</option>\n";
444: }
445: return $result;
446: }
447: ###############################################################
448: ## End of home server <option> list generating code ##
449: ###############################################################
450:
451: ###############################################################
452: ## Authentication changing form generation subroutines ##
453: ###############################################################
454: ##
455: ## All of the authform_xxxxxxx subroutines take their inputs in a
456: ## hash, and have reasonable default values.
457: ##
458: ## formname = the name given in the <form> tag.
459: #-------------------------------------------
460:
461: =item authform_xxxxxx
462:
463: The authform_xxxxxx subroutines provide javascript and html forms which
464: handle some of the conveniences required for authentication forms.
465: This is not an optimal method, but it works.
466:
467: See loncreateuser.pm for invocation and use examples.
468:
469: =over 4
470:
471: =item authform_header
472:
473: =item authform_authorwarning
474:
475: =item authform_nochange
476:
477: =item authform_kerberos
478:
479: =item authform_internal
480:
481: =item authform_filesystem
482:
483: =back
484:
485: =cut
486:
487: #-------------------------------------------
488: sub authform_header{
489: my %in = (
490: formname => 'cu',
491: kerb_def_dom => 'MSU.EDU',
492: @_,
493: );
494: $in{'formname'} = 'document.' . $in{'formname'};
495: my $result='';
496: $result.=<<"END";
497: var current = new Object();
498: current.radiovalue = 'nochange';
499: current.argfield = null;
500:
501: function changed_radio(choice,currentform) {
502: var choicearg = choice + 'arg';
503: // If a radio button in changed, we need to change the argfield
504: if (current.radiovalue != choice) {
505: current.radiovalue = choice;
506: if (current.argfield != null) {
507: currentform.elements[current.argfield].value = '';
508: }
509: if (choice == 'nochange') {
510: current.argfield = null;
511: } else {
512: current.argfield = choicearg;
513: switch(choice) {
514: case 'krb':
515: currentform.elements[current.argfield].value =
516: "$in{'kerb_def_dom'}";
517: break;
518: default:
519: break;
520: }
521: }
522: }
523: return;
524: }
525:
526: function changed_text(choice,currentform) {
527: var choicearg = choice + 'arg';
528: if (currentform.elements[choicearg].value !='') {
529: switch (choice) {
530: case 'krb': currentform.elements[choicearg].value =
531: currentform.elements[choicearg].value.toUpperCase();
532: break;
533: default:
534: }
535: // clear old field
536: if ((current.argfield != choicearg) && (current.argfield != null)) {
537: currentform.elements[current.argfield].value = '';
538: }
539: current.argfield = choicearg;
540: }
541: set_auth_radio_buttons(choice,currentform);
542: return;
543: }
544:
545: function set_auth_radio_buttons(newvalue,currentform) {
546: var i=0;
547: while (i < currentform.login.length) {
548: if (currentform.login[i].value == newvalue) { break; }
549: i++;
550: }
551: if (i == currentform.login.length) {
552: return;
553: }
554: current.radiovalue = newvalue;
555: currentform.login[i].checked = true;
556: return;
557: }
558: END
559: return $result;
560: }
561:
562: sub authform_authorwarning{
563: my $result='';
564: $result=<<"END";
565: <i>As a general rule, only authors or co-authors should be filesystem
566: authenticated (which allows access to the server filesystem).</i>
567: END
568: return $result;
569: }
570:
571: sub authform_nochange{
572: my %in = (
573: formname => 'document.cu',
574: kerb_def_dom => 'MSU.EDU',
575: @_,
576: );
577: my $result='';
578: $result.=<<"END";
579: <input type="radio" name="login" value="nochange" checked="checked"
580: onclick="javascript:changed_radio('nochange',$in{'formname'});">
581: Do not change login data
582: END
583: return $result;
584: }
585:
586: sub authform_kerberos{
587: my %in = (
588: formname => 'document.cu',
589: kerb_def_dom => 'MSU.EDU',
590: @_,
591: );
592: my $result='';
593: $result.=<<"END";
594: <input type="radio" name="login" value="krb"
595: onclick="javascript:changed_radio('krb',$in{'formname'});"
596: onchange="javascript:changed_radio('krb',$in{'formname'});">
597: Kerberos authenticated with domain
598: <input type="text" size="10" name="krbarg" value=""
599: onchange="javascript:changed_text('krb',$in{'formname'});">
600: END
601: return $result;
602: }
603:
604: sub authform_internal{
605: my %args = (
606: formname => 'document.cu',
607: kerb_def_dom => 'MSU.EDU',
608: @_,
609: );
610: my $result='';
611: $result.=<<"END";
612: <input type="radio" name="login" value="int"
613: onchange="javascript:changed_radio('int',$args{'formname'});"
614: onclick="javascript:changed_radio('int',$args{'formname'});">
615: Internally authenticated (with initial password
616: <input type="text" size="10" name="intarg" value=""
617: onchange="javascript:changed_text('int',$args{'formname'});">
618: END
619: return $result;
620: }
621:
622: sub authform_local{
623: my %in = (
624: formname => 'document.cu',
625: kerb_def_dom => 'MSU.EDU',
626: @_,
627: );
628: my $result='';
629: $result.=<<"END";
630: <input type="radio" name="login" value="loc"
631: onchange="javascript:changed_radio('loc',$in{'formname'});"
632: onclick="javascript:changed_radio('loc',$in{'formname'});">
633: Local Authentication with argument
634: <input type="text" size="10" name="locarg" value=""
635: onchange="javascript:changed_text('loc',$in{'formname'});">
636: END
637: return $result;
638: }
639:
640: sub authform_filesystem{
641: my %in = (
642: formname => 'document.cu',
643: kerb_def_dom => 'MSU.EDU',
644: @_,
645: );
646: my $result='';
647: $result.=<<"END";
648: <input type="radio" name="login" value="fsys"
649: onchange="javascript:changed_radio('fsys',$in{'formname'});"
650: onclick="javascript:changed_radio('fsys',$in{'formname'});">
651: Filesystem authenticated (with initial password
652: <input type="text" size="10" name="fsysarg" value=""
653: onchange="javascript:changed_text('fsys',$in{'formname'});">
654: END
655: return $result;
656: }
657:
658: ###############################################################
659: ## End Authentication changing form generation functions ##
660: ###############################################################
661:
662:
663:
664: # ---------------------------------------------------------- Is this a keyword?
665:
666: sub keyword {
667: my $newword=shift;
668: $newword=~s/\W//g;
669: $newword=~tr/A-Z/a-z/;
670: my $tindex=$theindex{$newword};
671: if ($tindex) {
672: if ($thecount[$tindex]>$theavecount) {
673: return 1;
674: }
675: }
676: return 0;
677: }
678: # -------------------------------------------------------- Return related words
679:
680: sub related {
681: my $newword=shift;
682: $newword=~s/\W//g;
683: $newword=~tr/A-Z/a-z/;
684: my $tindex=$theindex{$newword};
685: if ($tindex) {
686: my %found=();
687: foreach (split(/\,/,$therelated[$tindex])) {
688: # - Related word found
689: my ($ridx,$rcount)=split(/\:/,$_);
690: # - Direct relation index
691: my $directrel=$rcount/$thecount[$tindex];
692: if ($directrel>$thethreshold) {
693: foreach (split(/\,/,$therelated[$ridx])) {
694: my ($rridx,$rrcount)=split(/\:/,$_);
695: if ($rridx==$tindex) {
696: # - Determine reverse relation index
697: my $revrel=$rrcount/$thecount[$ridx];
698: # - Calculate full index
699: $found{$ridx}=$directrel*$revrel;
700: if ($found{$ridx}>$thethreshold) {
701: foreach (split(/\,/,$therelated[$ridx])) {
702: my ($rrridx,$rrrcount)=split(/\:/,$_);
703: unless ($found{$rrridx}) {
704: my $revrevrel=$rrrcount/$thecount[$ridx];
705: if (
706: $directrel*$revrel*$revrevrel>$thethreshold
707: ) {
708: $found{$rrridx}=
709: $directrel*$revrel*$revrevrel;
710: }
711: }
712: }
713: }
714: }
715: }
716: }
717: }
718: }
719: return ();
720: }
721:
722: # ---------------------------------------------------------------- Language IDs
723: sub languageids {
724: return sort(keys(%language));
725: }
726:
727: # -------------------------------------------------------- Language Description
728: sub languagedescription {
729: return $language{shift(@_)};
730: }
731:
732: # --------------------------------------------------------------- Copyright IDs
733: sub copyrightids {
734: return sort(keys(%cprtag));
735: }
736:
737: # ------------------------------------------------------- Copyright Description
738: sub copyrightdescription {
739: return $cprtag{shift(@_)};
740: }
741:
742: # ------------------------------------------------------------- File Categories
743: sub filecategories {
744: return sort(keys(%fc));
745: }
746:
747: # -------------------------------------- File Types within a specified category
748: sub filecategorytypes {
749: return @{$fc{lc(shift(@_))}};
750: }
751:
752: # ------------------------------------------------------------------ File Types
753: sub fileextensions {
754: return sort(keys(%fe));
755: }
756:
757: # ------------------------------------------------------------- Embedding Style
758: sub fileembstyle {
759: return $fe{lc(shift(@_))};
760: }
761:
762: # ------------------------------------------------------------ Description Text
763: sub filedescription {
764: return $fd{lc(shift(@_))};
765: }
766:
767: # ------------------------------------------------------------ Description Text
768: sub filedescriptionex {
769: my $ex=shift;
770: return '.'.$ex.' '.$fd{lc($ex)};
771: }
772:
773: sub get_previous_attempt {
774: my ($symb,$username,$domain,$course)=@_;
775: my $prevattempts='';
776: if ($symb) {
777: my (%returnhash)=
778: &Apache::lonnet::restore($symb,$course,$domain,$username);
779: if ($returnhash{'version'}) {
780: my %lasthash=();
781: my $version;
782: for ($version=1;$version<=$returnhash{'version'};$version++) {
783: foreach (sort(split(/\:/,$returnhash{$version.':keys'}))) {
784: $lasthash{$_}=$returnhash{$version.':'.$_};
785: }
786: }
787: $prevattempts='<table border=2></tr><th>History</th>';
788: foreach (sort(keys %lasthash)) {
789: my ($ign,@parts) = split(/\./,$_);
790: if ($#parts > 0) {
791: my $data=$parts[-1];
792: pop(@parts);
793: $prevattempts.='<th>Part '.join('.',@parts).'<br />'.$data.'</th>';
794: } else {
795: if ($#parts == 0) {
796: $prevattempts.='<th>'.$parts[0].'</th>';
797: } else {
798: $prevattempts.='<th>'.$ign.'</th>';
799: }
800: }
801: }
802: for ($version=1;$version<=$returnhash{'version'};$version++) {
803: $prevattempts.='</tr><tr><th>Attempt '.$version.'</th>';
804: foreach (sort(keys %lasthash)) {
805: my $value;
806: if ($_ =~ /timestamp/) {
807: $value=scalar(localtime($returnhash{$version.':'.$_}));
808: } else {
809: $value=$returnhash{$version.':'.$_};
810: }
811: $prevattempts.='<td>'.$value.'</td>';
812: }
813: }
814: $prevattempts.='</tr><tr><th>Current</th>';
815: foreach (sort(keys %lasthash)) {
816: my $value;
817: if ($_ =~ /timestamp/) {
818: $value=scalar(localtime($lasthash{$_}));
819: } else {
820: $value=$lasthash{$_};
821: }
822: $prevattempts.='<td>'.$value.'</td>';
823: }
824: $prevattempts.='</tr></table>';
825: } else {
826: $prevattempts='Nothing submitted - no attempts.';
827: }
828: } else {
829: $prevattempts='No data.';
830: }
831: }
832:
833: sub get_student_view {
834: my ($symb,$username,$domain,$courseid) = @_;
835: my ($map,$id,$feedurl) = split(/___/,$symb);
836: my (%old,%moreenv);
837: my @elements=('symb','courseid','domain','username');
838: foreach my $element (@elements) {
839: $old{$element}=$ENV{'form.grade_'.$element};
840: $moreenv{'form.grade_'.$element}=eval '$'.$element #'
841: }
842: &Apache::lonnet::appenv(%moreenv);
843: my $userview=&Apache::lonnet::ssi('/res/'.$feedurl);
844: &Apache::lonnet::delenv('form.grade_');
845: foreach my $element (@elements) {
846: $ENV{'form.grade_'.$element}=$old{$element};
847: }
848: $userview=~s/\<body[^\>]*\>//gi;
849: $userview=~s/\<\/body\>//gi;
850: $userview=~s/\<html\>//gi;
851: $userview=~s/\<\/html\>//gi;
852: $userview=~s/\<head\>//gi;
853: $userview=~s/\<\/head\>//gi;
854: $userview=~s/action\s*\=/would_be_action\=/gi;
855: return $userview;
856: }
857:
858: sub get_student_answers {
859: my ($symb,$username,$domain,$courseid) = @_;
860: my ($map,$id,$feedurl) = split(/___/,$symb);
861: my (%old,%moreenv);
862: my @elements=('symb','courseid','domain','username');
863: foreach my $element (@elements) {
864: $old{$element}=$ENV{'form.grade_'.$element};
865: $moreenv{'form.grade_'.$element}=eval '$'.$element #'
866: }
867: $moreenv{'form.grade_target'}='answer';
868: &Apache::lonnet::appenv(%moreenv);
869: my $userview=&Apache::lonnet::ssi('/res/'.$feedurl);
870: &Apache::lonnet::delenv('form.grade_');
871: foreach my $element (@elements) {
872: $ENV{'form.grade_'.$element}=$old{$element};
873: }
874: return $userview;
875: }
876:
877: ###############################################
878:
879: ###############################################
880:
881: sub get_unprocessed_cgi {
882: my ($query,$possible_names)= @_;
883: # $Apache::lonxml::debug=1;
884: foreach (split(/&/,$query)) {
885: my ($name, $value) = split(/=/,$_);
886: $name = &Apache::lonnet::unescape($name);
887: if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) {
888: $value =~ tr/+/ /;
889: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
890: &Apache::lonxml::debug("Seting :$name: to :$value:");
891: unless (defined($ENV{'form.'.$name})) { &add_to_env('form.'.$name,$value) };
892: }
893: }
894: }
895:
896: sub cacheheader {
897: unless ($ENV{'request.method'} eq 'GET') { return ''; }
898: my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
899: my $output .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" />
900: <meta HTTP-EQUIV="Cache-control" CONTENT="no-cache" />
901: <meta HTTP-EQUIV="Pragma" CONTENT="no-cache" />';
902: return $output;
903: }
904:
905: sub no_cache {
906: my ($r) = @_;
907: unless ($ENV{'request.method'} eq 'GET') { return ''; }
908: #my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
909: $r->no_cache(1);
910: $r->header_out("Pragma" => "no-cache");
911: #$r->header_out("Expires" => $date);
912: }
913:
914: sub add_to_env {
915: my ($name,$value)=@_;
916: if (defined($ENV{$name})) {
917: if (ref($ENV{$name})) {
918: #already have multiple values
919: push(@{ $ENV{$name} },$value);
920: } else {
921: #first time seeing multiple values, convert hash entry to an arrayref
922: my $first=$ENV{$name};
923: undef($ENV{$name});
924: push(@{ $ENV{$name} },$first,$value);
925: }
926: } else {
927: $ENV{$name}=$value;
928: }
929: }
930:
931: =pod
932:
933: =back
934:
935: =head2 CSV Upload/Handling functions
936:
937: =over 4
938:
939: =item upfile_store($r)
940:
941: Store uploaded file, $r should be the HTTP Request object,
942: needs $ENV{'form.upfile'}
943: returns $datatoken to be put into hidden field
944:
945: =cut
946:
947: sub upfile_store {
948: my $r=shift;
949: $ENV{'form.upfile'}=~s/\r/\n/gs;
950: $ENV{'form.upfile'}=~s/\f/\n/gs;
951: $ENV{'form.upfile'}=~s/\n+/\n/gs;
952: $ENV{'form.upfile'}=~s/\n+$//gs;
953:
954: my $datatoken=$ENV{'user.name'}.'_'.$ENV{'user.domain'}.
955: '_enroll_'.$ENV{'request.course.id'}.'_'.time.'_'.$$;
956: {
957: my $fh=Apache::File->new('>'.$r->dir_config('lonDaemons').
958: '/tmp/'.$datatoken.'.tmp');
959: print $fh $ENV{'form.upfile'};
960: }
961: return $datatoken;
962: }
963:
964: =item load_tmp_file($r)
965:
966: Load uploaded file from tmp, $r should be the HTTP Request object,
967: needs $ENV{'form.datatoken'},
968: sets $ENV{'form.upfile'} to the contents of the file
969:
970: =cut
971:
972: sub load_tmp_file {
973: my $r=shift;
974: my @studentdata=();
975: {
976: my $fh;
977: if ($fh=Apache::File->new($r->dir_config('lonDaemons').
978: '/tmp/'.$ENV{'form.datatoken'}.'.tmp')) {
979: @studentdata=<$fh>;
980: }
981: }
982: $ENV{'form.upfile'}=join('',@studentdata);
983: }
984:
985: =item upfile_record_sep()
986:
987: Separate uploaded file into records
988: returns array of records,
989: needs $ENV{'form.upfile'} and $ENV{'form.upfiletype'}
990:
991: =cut
992:
993: sub upfile_record_sep {
994: if ($ENV{'form.upfiletype'} eq 'xml') {
995: } else {
996: return split(/\n/,$ENV{'form.upfile'});
997: }
998: }
999:
1000: =item record_sep($record)
1001:
1002: Separate a record into fields $record should be an item from the upfile_record_sep(), needs $ENV{'form.upfiletype'}
1003:
1004: =cut
1005:
1006: sub record_sep {
1007: my $record=shift;
1008: my %components=();
1009: if ($ENV{'form.upfiletype'} eq 'xml') {
1010: } elsif ($ENV{'form.upfiletype'} eq 'space') {
1011: my $i=0;
1012: foreach (split(/\s+/,$record)) {
1013: my $field=$_;
1014: $field=~s/^(\"|\')//;
1015: $field=~s/(\"|\')$//;
1016: $components{$i}=$field;
1017: $i++;
1018: }
1019: } elsif ($ENV{'form.upfiletype'} eq 'tab') {
1020: my $i=0;
1021: foreach (split(/\t+/,$record)) {
1022: my $field=$_;
1023: $field=~s/^(\"|\')//;
1024: $field=~s/(\"|\')$//;
1025: $components{$i}=$field;
1026: $i++;
1027: }
1028: } else {
1029: my @allfields=split(/\,/,$record);
1030: my $i=0;
1031: my $j;
1032: for ($j=0;$j<=$#allfields;$j++) {
1033: my $field=$allfields[$j];
1034: if ($field=~/^\s*(\"|\')/) {
1035: my $delimiter=$1;
1036: while (($field!~/$delimiter$/) && ($j<$#allfields)) {
1037: $j++;
1038: $field.=','.$allfields[$j];
1039: }
1040: $field=~s/^\s*$delimiter//;
1041: $field=~s/$delimiter\s*$//;
1042: }
1043: $components{$i}=$field;
1044: $i++;
1045: }
1046: }
1047: return %components;
1048: }
1049:
1050: =item upfile_select_html()
1051:
1052: return HTML code to select file and specify its type
1053:
1054: =cut
1055:
1056: sub upfile_select_html {
1057: return (<<'ENDUPFORM');
1058: <input type="file" name="upfile" size="50">
1059: <br />Type: <select name="upfiletype">
1060: <option value="csv">CSV (comma separated values, spreadsheet)</option>
1061: <option value="space">Space separated</option>
1062: <option value="tab">Tabulator separated</option>
1063: <option value="xml">HTML/XML</option>
1064: </select>
1065: ENDUPFORM
1066: }
1067:
1068: =item csv_print_samples($r,$records)
1069:
1070: Prints a table of sample values from each column uploaded $r is an
1071: Apache Request ref, $records is an arrayref from
1072: &Apache::loncommon::upfile_record_sep
1073:
1074: =cut
1075:
1076: sub csv_print_samples {
1077: my ($r,$records) = @_;
1078: my (%sone,%stwo,%sthree);
1079: %sone=&record_sep($$records[0]);
1080: if (defined($$records[1])) {%stwo=&record_sep($$records[1]);}
1081: if (defined($$records[2])) {%sthree=&record_sep($$records[2]);}
1082:
1083: $r->print('Samples<br /><table border="2"><tr>');
1084: foreach (sort({$a <=> $b} keys(%sone))) { $r->print('<th>Column '.($_+1).'</th>'); }
1085: $r->print('</tr>');
1086: foreach my $hash (\%sone,\%stwo,\%sthree) {
1087: $r->print('<tr>');
1088: foreach (sort({$a <=> $b} keys(%sone))) {
1089: $r->print('<td>');
1090: if (defined($$hash{$_})) { $r->print($$hash{$_}); }
1091: $r->print('</td>');
1092: }
1093: $r->print('</tr>');
1094: }
1095: $r->print('</tr></table><br />'."\n");
1096: }
1097:
1098: =item csv_print_select_table($r,$records,$d)
1099:
1100: Prints a table to create associations between values and table columns.
1101: $r is an Apache Request ref,
1102: $records is an arrayref from &Apache::loncommon::upfile_record_sep,
1103: $d is an array of 2 element arrays (internal name, displayed name)
1104:
1105: =cut
1106:
1107: sub csv_print_select_table {
1108: my ($r,$records,$d) = @_;
1109: my $i=0;my %sone;
1110: %sone=&record_sep($$records[0]);
1111: $r->print('Associate columns with student attributes.'."\n".
1112: '<table border="2"><tr><th>Attribute</th><th>Column</th></tr>'."\n");
1113: foreach (@$d) {
1114: my ($value,$display)=@{ $_ };
1115: $r->print('<tr><td>'.$display.'</td>');
1116:
1117: $r->print('<td><select name=f'.$i.
1118: ' onchange="javascript:flip(this.form,'.$i.');">');
1119: $r->print('<option value="none"></option>');
1120: foreach (sort({$a <=> $b} keys(%sone))) {
1121: $r->print('<option value="'.$_.'">Column '.($_+1).'</option>');
1122: }
1123: $r->print('</select></td></tr>'."\n");
1124: $i++;
1125: }
1126: $i--;
1127: return $i;
1128: }
1129:
1130: =item csv_samples_select_table($r,$records,$d)
1131:
1132: Prints a table of sample values from the upload and can make associate samples to internal names.
1133:
1134: $r is an Apache Request ref,
1135: $records is an arrayref from &Apache::loncommon::upfile_record_sep,
1136: $d is an array of 2 element arrays (internal name, displayed name)
1137:
1138: =cut
1139:
1140: sub csv_samples_select_table {
1141: my ($r,$records,$d) = @_;
1142: my %sone; my %stwo; my %sthree;
1143: my $i=0;
1144:
1145: $r->print('<table border=2><tr><th>Field</th><th>Samples</th></tr>');
1146: %sone=&record_sep($$records[0]);
1147: if (defined($$records[1])) {%stwo=&record_sep($$records[1]);}
1148: if (defined($$records[2])) {%sthree=&record_sep($$records[2]);}
1149:
1150: foreach (sort keys %sone) {
1151: $r->print('<tr><td><select name=f'.$i.
1152: ' onchange="javascript:flip(this.form,'.$i.');">');
1153: foreach (@$d) {
1154: my ($value,$display)=@{ $_ };
1155: $r->print('<option value='.$value.'>'.$display.'</option>');
1156: }
1157: $r->print('</select></td><td>');
1158: if (defined($sone{$_})) { $r->print($sone{$_}."</br>\n"); }
1159: if (defined($stwo{$_})) { $r->print($stwo{$_}."</br>\n"); }
1160: if (defined($sthree{$_})) { $r->print($sthree{$_}."</br>\n"); }
1161: $r->print('</td></tr>');
1162: $i++;
1163: }
1164: $i--;
1165: return($i);
1166: }
1167: 1;
1168: __END__;
1169:
1170: =pod
1171:
1172: =back
1173:
1174: =head2 Access .tab File Data
1175:
1176: =over 4
1177:
1178: =item languageids()
1179:
1180: returns list of all language ids
1181:
1182: =item languagedescription()
1183:
1184: returns description of a specified language id
1185:
1186: =item copyrightids()
1187:
1188: returns list of all copyrights
1189:
1190: =item copyrightdescription()
1191:
1192: returns description of a specified copyright id
1193:
1194: =item filecategories()
1195:
1196: returns list of all file categories
1197:
1198: =item filecategorytypes()
1199:
1200: returns list of file types belonging to a given file
1201: category
1202:
1203: =item fileembstyle()
1204:
1205: returns embedding style for a specified file type
1206:
1207: =item filedescription()
1208:
1209: returns description for a specified file type
1210:
1211: =item filedescriptionex()
1212:
1213: returns description for a specified file type with
1214: extra formatting
1215:
1216: =back
1217:
1218: =head2 Alternate Problem Views
1219:
1220: =over 4
1221:
1222: =item get_previous_attempt()
1223:
1224: return string with previous attempt on problem
1225:
1226: =item get_student_view()
1227:
1228: show a snapshot of what student was looking at
1229:
1230: =item get_student_answers()
1231:
1232: show a snapshot of how student was answering problem
1233:
1234: =back
1235:
1236: =head2 HTTP Helper
1237:
1238: =over 4
1239:
1240: =item get_unprocessed_cgi($query,$possible_names)
1241:
1242: Modify the %ENV hash to contain unprocessed CGI form parameters held in
1243: $query. The parameters listed in $possible_names (an array reference),
1244: will be set in $ENV{'form.name'} if they do not already exist.
1245:
1246: Typically called with $ENV{'QUERY_STRING'} as the first parameter.
1247: $possible_names is an ref to an array of form element names. As an example:
1248: get_unprocessed_cgi($ENV{'QUERY_STRING'},['uname','udom']);
1249: will result in $ENV{'form.uname'} and $ENV{'form.udom'} being set.
1250:
1251: =item cacheheader()
1252:
1253: returns cache-controlling header code
1254:
1255: =item nocache()
1256:
1257: specifies header code to not have cache
1258:
1259: =item add_to_env($name,$value)
1260:
1261: adds $name to the %ENV hash with value
1262: $value, if $name already exists, the entry is converted to an array
1263: reference and $value is added to the array.
1264:
1265: =back
1266:
1267: =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