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