1: # The LearningOnline Network with CAPA
2: # a pile of common routines
3: #
4: # $Id: loncommon.pm,v 1.35 2002/04/23 21:42:01 matthew 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 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:
83: my $readit;
84:
85: # ----------------------------------------------- Filetypes/Languages/Copyright
86: my %language;
87: my %cprtag;
88: my %fe; my %fd;
89: my %fc;
90:
91: # -------------------------------------------------------------- Thesaurus data
92: my @therelated;
93: my @theword;
94: my @thecount;
95: my %theindex;
96: my $thetotalcount;
97: my $thefuzzy=2;
98: my $thethreshold=0.1/$thefuzzy;
99: my $theavecount;
100:
101: # ----------------------------------------------------------------------- BEGIN
102: =item BEGIN()
103:
104: Initialize values from language.tab, copyright.tab, filetypes.tab,
105: and filecategories.tab.
106:
107: =cut
108: # ----------------------------------------------------------------------- BEGIN
109:
110: BEGIN {
111:
112: unless ($readit) {
113: # ------------------------------------------------------------------- languages
114: {
115: my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
116: '/language.tab');
117: if ($fh) {
118: while (<$fh>) {
119: next if /^\#/;
120: chomp;
121: my ($key,$val)=(split(/\s+/,$_,2));
122: $language{$key}=$val;
123: }
124: }
125: }
126: # ------------------------------------------------------------------ copyrights
127: {
128: my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonIncludes'}.
129: '/copyright.tab');
130: if ($fh) {
131: while (<$fh>) {
132: next if /^\#/;
133: chomp;
134: my ($key,$val)=(split(/\s+/,$_,2));
135: $cprtag{$key}=$val;
136: }
137: }
138: }
139: # ------------------------------------------------------------- file categories
140: {
141: my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
142: '/filecategories.tab');
143: if ($fh) {
144: while (<$fh>) {
145: next if /^\#/;
146: chomp;
147: my ($key,$val)=(split(/\s+/,$_,2));
148: push @{$fc{$key}},$val;
149: }
150: }
151: }
152: # ------------------------------------------------------------------ file types
153: {
154: my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
155: '/filetypes.tab');
156: if ($fh) {
157: while (<$fh>) {
158: next if (/^\#/);
159: chomp;
160: my ($ending,$emb,$descr)=split(/\s+/,$_,3);
161: if ($descr ne '') {
162: $fe{$ending}=lc($emb);
163: $fd{$ending}=$descr;
164: }
165: }
166: }
167: }
168: # -------------------------------------------------------------- Thesaurus data
169: {
170: my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
171: '/thesaurus.dat');
172: if ($fh) {
173: while (<$fh>) {
174: my ($tword,$tindex,$tcount,$trelated)=split(/\@/,$_);
175: $theindex{$tword}=$tindex;
176: $theword[$tindex]=$tword;
177: $thecount[$tindex]=$tcount;
178: $thetotalcount+=$tcount;
179: $therelated[$tindex]=$trelated;
180: }
181: }
182: $theavecount=$thetotalcount/$#thecount;
183: }
184: &Apache::lonnet::logthis(
185: "<font color=yellow>INFO: Read file types and thesaurus</font>");
186: $readit=1;
187: }
188:
189: }
190: # ============================================================= END BEGIN BLOCK
191: ###############################################################
192: ## Home server <option> list generating code ##
193: ###############################################################
194: #-------------------------------------------
195:
196: =item get_domains()
197:
198: Returns an array containing each of the domains listed in the hosts.tab
199: file.
200:
201: =cut
202:
203: #-------------------------------------------
204: sub get_domains {
205: # The code below was stolen from "The Perl Cookbook", p 102, 1st ed.
206: my @domains;
207: my %seen;
208: foreach (sort values(%Apache::lonnet::hostdom)) {
209: push (@domains,$_) unless $seen{$_}++;
210: }
211: return @domains;
212: }
213:
214: #-------------------------------------------
215:
216: =item select_dom_form($defdom,$name)
217:
218: Returns a string containing a <select name='$name' size='1'> form to
219: allow a user to select the domain to preform an operation in.
220: See loncreateuser.pm for an example invocation and use.
221:
222: =cut
223:
224: #-------------------------------------------
225: sub select_dom_form {
226: my ($defdom,$name) = @_;
227: my @domains = get_domains();
228: my $selectdomain = "<select name=\"$name\" size=\"1\">\n";
229: foreach (@domains) {
230: $selectdomain.="<option value=\"$_\" ".
231: ($_ eq $defdom ? 'selected' : '').
232: ">$_</option>\n";
233: }
234: $selectdomain.="</select>";
235: return $selectdomain;
236: }
237:
238: #-------------------------------------------
239:
240: =item get_home_servers($domain)
241:
242: Returns a hash which contains keys like '103l3' and values like
243: 'kirk.lite.msu.edu'. All of the keys will be for machines in the
244: given $domain.
245:
246: =cut
247:
248: #-------------------------------------------
249: sub get_home_servers {
250: my $domain = shift;
251: my %home_servers;
252: foreach (keys(%Apache::lonnet::libserv)) {
253: if ($Apache::lonnet::hostdom{$_} eq $domain) {
254: $home_servers{$_} = $Apache::lonnet::hostname{$_};
255: }
256: }
257: return %home_servers;
258: }
259:
260: #-------------------------------------------
261:
262: =item home_server_option_list($domain)
263:
264: returns a string which contains an <option> list to be used in a
265: <select> form input. See loncreateuser.pm for an example.
266:
267: =cut
268:
269: #-------------------------------------------
270: sub home_server_option_list {
271: my $domain = shift;
272: my %servers = &get_home_servers($domain);
273: my $result = '';
274: foreach (sort keys(%servers)) {
275: $result.=
276: '<option value="'.$_.'">'.$_.' '.$servers{$_}."</option>\n";
277: }
278: return $result;
279: }
280: ###############################################################
281: ## End of home server <option> list generating code ##
282: ###############################################################
283:
284: ###############################################################
285: ## Authentication changing form generation subroutines ##
286: ###############################################################
287: ##
288: ## All of the authform_xxxxxxx subroutines take their inputs in a
289: ## hash, and have reasonable default values.
290: ##
291: ## formname = the name given in the <form> tag.
292: #-------------------------------------------
293:
294: =item authform_xxxxxx
295:
296: The authform_xxxxxx subroutines provide javascript and html forms which
297: handle some of the conveniences required for authentication forms.
298: This is not an optimal method, but it works.
299:
300: See loncreateuser.pm for invocation and use examples.
301:
302: =over 4
303:
304: =item authform_header
305:
306: =item authform_authorwarning
307:
308: =item authform_nochange
309:
310: =item authform_kerberos
311:
312: =item authform_internal
313:
314: =item authform_filesystem
315:
316: =back
317:
318: =cut
319:
320: #-------------------------------------------
321: sub authform_header{
322: my %in = (
323: formname => 'cu',
324: kerb_def_dom => 'MSU.EDU',
325: @_,
326: );
327: $in{'formname'} = 'document.' . $in{'formname'};
328: my $result='';
329: $result.=<<"END";
330: var current = new Object();
331: current.radiovalue = 'nochange';
332: current.argfield = null;
333:
334: function changed_radio(choice,currentform) {
335: var choicearg = choice + 'arg';
336: // If a radio button in changed, we need to change the argfield
337: if (current.radiovalue != choice) {
338: current.radiovalue = choice;
339: if (current.argfield != null) {
340: currentform.elements[current.argfield].value = '';
341: }
342: if (choice == 'nochange') {
343: current.argfield = null;
344: } else {
345: current.argfield = choicearg;
346: switch(choice) {
347: case 'krb':
348: currentform.elements[current.argfield].value =
349: "$in{'kerb_def_dom'}";
350: break;
351: default:
352: break;
353: }
354: }
355: }
356: return;
357: }
358:
359: function changed_text(choice,currentform) {
360: var choicearg = choice + 'arg';
361: if (currentform.elements[choicearg].value !='') {
362: switch (choice) {
363: case 'krb': currentform.elements[choicearg].value =
364: currentform.elements[choicearg].value.toUpperCase();
365: break;
366: default:
367: }
368: // clear old field
369: if ((current.argfield != choicearg) && (current.argfield != null)) {
370: currentform.elements[current.argfield].value = '';
371: }
372: current.argfield = choicearg;
373: }
374: set_auth_radio_buttons(choice,currentform);
375: return;
376: }
377:
378: function set_auth_radio_buttons(newvalue,currentform) {
379: var i=0;
380: while (i < currentform.login.length) {
381: if (currentform.login[i].value == newvalue) { break; }
382: i++;
383: }
384: if (i == currentform.login.length) {
385: return;
386: }
387: current.radiovalue = newvalue;
388: currentform.login[i].checked = true;
389: return;
390: }
391: END
392: return $result;
393: }
394:
395: sub authform_authorwarning{
396: my $result='';
397: $result=<<"END";
398: <i>As a general rule, only authors or co-authors should be filesystem
399: authenticated (which allows access to the server filesystem).</i>
400: END
401: return $result;
402: }
403:
404: sub authform_nochange{
405: my %in = (
406: formname => 'document.cu',
407: kerb_def_dom => 'MSU.EDU',
408: @_,
409: );
410: my $result='';
411: $result.=<<"END";
412: <input type="radio" name="login" value="nochange" checked="checked"
413: onclick="javascript:changed_radio('nochange',$in{'formname'});">
414: Do not change login data
415: END
416: return $result;
417: }
418:
419: sub authform_kerberos{
420: my %in = (
421: formname => 'document.cu',
422: kerb_def_dom => 'MSU.EDU',
423: @_,
424: );
425: my $result='';
426: $result.=<<"END";
427: <input type="radio" name="login" value="krb"
428: onclick="javascript:changed_radio('krb',$in{'formname'});"
429: onchange="javascript:changed_radio('krb',$in{'formname'});">
430: Kerberos authenticated with domain
431: <input type="text" size="10" name="krbarg" value=""
432: onchange="javascript:changed_text('krb',$in{'formname'});">
433: END
434: return $result;
435: }
436:
437: sub authform_internal{
438: my %args = (
439: formname => 'document.cu',
440: kerb_def_dom => 'MSU.EDU',
441: @_,
442: );
443: my $result='';
444: $result.=<<"END";
445: <input type="radio" name="login" value="int"
446: onchange="javascript:changed_radio('int',$args{'formname'});"
447: onclick="javascript:changed_radio('int',$args{'formname'});">
448: Internally authenticated (with initial password
449: <input type="text" size="10" name="intarg" value=""
450: onchange="javascript:changed_text('int',$args{'formname'});">
451: END
452: return $result;
453: }
454:
455: sub authform_local{
456: my %in = (
457: formname => 'document.cu',
458: kerb_def_dom => 'MSU.EDU',
459: @_,
460: );
461: my $result='';
462: $result.=<<"END";
463: <input type="radio" name="login" value="loc"
464: onchange="javascript:changed_radio('loc',$in{'formname'});"
465: onclick="javascript:changed_radio('loc',$in{'formname'});">
466: Local Authentication with argument
467: <input type="text" size="10" name="locarg" value=""
468: onchange="javascript:changed_text('loc',$in{'formname'});">
469: END
470: return $result;
471: }
472:
473: sub authform_filesystem{
474: my %in = (
475: formname => 'document.cu',
476: kerb_def_dom => 'MSU.EDU',
477: @_,
478: );
479: my $result='';
480: $result.=<<"END";
481: <input type="radio" name="login" value="fsys"
482: onchange="javascript:changed_radio('fsys',$in{'formname'});"
483: onclick="javascript:changed_radio('fsys',$in{'formname'});">
484: Filesystem authenticated (with initial password
485: <input type="text" size="10" name="fsysarg" value=""
486: onchange="javascript:changed_text('fsys',$in{'formname'});">
487: END
488: return $result;
489: }
490:
491: ###############################################################
492: ## End Authentication changing form generation functions ##
493: ###############################################################
494:
495:
496:
497: # ---------------------------------------------------------- Is this a keyword?
498:
499: sub keyword {
500: my $newword=shift;
501: $newword=~s/\W//g;
502: $newword=~tr/A-Z/a-z/;
503: my $tindex=$theindex{$newword};
504: if ($tindex) {
505: if ($thecount[$tindex]>$theavecount) {
506: return 1;
507: }
508: }
509: return 0;
510: }
511: # -------------------------------------------------------- Return related words
512:
513: sub related {
514: my $newword=shift;
515: $newword=~s/\W//g;
516: $newword=~tr/A-Z/a-z/;
517: my $tindex=$theindex{$newword};
518: if ($tindex) {
519: my %found=();
520: foreach (split(/\,/,$therelated[$tindex])) {
521: # - Related word found
522: my ($ridx,$rcount)=split(/\:/,$_);
523: # - Direct relation index
524: my $directrel=$rcount/$thecount[$tindex];
525: if ($directrel>$thethreshold) {
526: foreach (split(/\,/,$therelated[$ridx])) {
527: my ($rridx,$rrcount)=split(/\:/,$_);
528: if ($rridx==$tindex) {
529: # - Determine reverse relation index
530: my $revrel=$rrcount/$thecount[$ridx];
531: # - Calculate full index
532: $found{$ridx}=$directrel*$revrel;
533: if ($found{$ridx}>$thethreshold) {
534: foreach (split(/\,/,$therelated[$ridx])) {
535: my ($rrridx,$rrrcount)=split(/\:/,$_);
536: unless ($found{$rrridx}) {
537: my $revrevrel=$rrrcount/$thecount[$ridx];
538: if (
539: $directrel*$revrel*$revrevrel>$thethreshold
540: ) {
541: $found{$rrridx}=
542: $directrel*$revrel*$revrevrel;
543: }
544: }
545: }
546: }
547: }
548: }
549: }
550: }
551: }
552: return ();
553: }
554:
555: # ---------------------------------------------------------------- Language IDs
556: sub languageids {
557: return sort(keys(%language));
558: }
559:
560: # -------------------------------------------------------- Language Description
561: sub languagedescription {
562: return $language{shift(@_)};
563: }
564:
565: # --------------------------------------------------------------- Copyright IDs
566: sub copyrightids {
567: return sort(keys(%cprtag));
568: }
569:
570: # ------------------------------------------------------- Copyright Description
571: sub copyrightdescription {
572: return $cprtag{shift(@_)};
573: }
574:
575: # ------------------------------------------------------------- File Categories
576: sub filecategories {
577: return sort(keys(%fc));
578: }
579:
580: # -------------------------------------- File Types within a specified category
581: sub filecategorytypes {
582: return @{$fc{lc(shift(@_))}};
583: }
584:
585: # ------------------------------------------------------------------ File Types
586: sub fileextensions {
587: return sort(keys(%fe));
588: }
589:
590: # ------------------------------------------------------------- Embedding Style
591: sub fileembstyle {
592: return $fe{lc(shift(@_))};
593: }
594:
595: # ------------------------------------------------------------ Description Text
596: sub filedescription {
597: return $fd{lc(shift(@_))};
598: }
599:
600: # ------------------------------------------------------------ Description Text
601: sub filedescriptionex {
602: my $ex=shift;
603: return '.'.$ex.' '.$fd{lc($ex)};
604: }
605:
606: sub get_previous_attempt {
607: my ($symb,$username,$domain,$course)=@_;
608: my $prevattempts='';
609: if ($symb) {
610: my (%returnhash)=
611: &Apache::lonnet::restore($symb,$course,$domain,$username);
612: if ($returnhash{'version'}) {
613: my %lasthash=();
614: my $version;
615: for ($version=1;$version<=$returnhash{'version'};$version++) {
616: foreach (sort(split(/\:/,$returnhash{$version.':keys'}))) {
617: $lasthash{$_}=$returnhash{$version.':'.$_};
618: }
619: }
620: $prevattempts='<table border=2></tr><th>History</th>';
621: foreach (sort(keys %lasthash)) {
622: my ($ign,@parts) = split(/\./,$_);
623: if (@parts) {
624: my $data=$parts[-1];
625: pop(@parts);
626: $prevattempts.='<th>Part '.join('.',@parts).'<br />'.$data.'</th>';
627: } else {
628: $prevattempts.='<th>'.$ign.'</th>';
629: }
630: }
631: for ($version=1;$version<=$returnhash{'version'};$version++) {
632: $prevattempts.='</tr><tr><th>Attempt '.$version.'</th>';
633: foreach (sort(keys %lasthash)) {
634: my $value;
635: if ($_ =~ /timestamp/) {
636: $value=scalar(localtime($returnhash{$version.':'.$_}));
637: } else {
638: $value=$returnhash{$version.':'.$_};
639: }
640: $prevattempts.='<td>'.$value.'</td>';
641: }
642: }
643: $prevattempts.='</tr><tr><th>Current</th>';
644: foreach (sort(keys %lasthash)) {
645: my $value;
646: if ($_ =~ /timestamp/) {
647: $value=scalar(localtime($lasthash{$_}));
648: } else {
649: $value=$lasthash{$_};
650: }
651: $prevattempts.='<td>'.$value.'</td>';
652: }
653: $prevattempts.='</tr></table>';
654: } else {
655: $prevattempts='Nothing submitted - no attempts.';
656: }
657: } else {
658: $prevattempts='No data.';
659: }
660: }
661:
662: sub get_student_view {
663: my ($symb,$username,$domain,$courseid) = @_;
664: my ($map,$id,$feedurl) = split(/___/,$symb);
665: my (%old,%moreenv);
666: my @elements=('symb','courseid','domain','username');
667: foreach my $element (@elements) {
668: $old{$element}=$ENV{'form.grade_'.$element};
669: $moreenv{'form.grade_'.$element}=eval '$'.$element #'
670: }
671: &Apache::lonnet::appenv(%moreenv);
672: my $userview=&Apache::lonnet::ssi('/res/'.$feedurl);
673: &Apache::lonnet::delenv('form.grade_');
674: foreach my $element (@elements) {
675: $ENV{'form.grade_'.$element}=$old{$element};
676: }
677: $userview=~s/\<body[^\>]*\>//gi;
678: $userview=~s/\<\/body\>//gi;
679: $userview=~s/\<html\>//gi;
680: $userview=~s/\<\/html\>//gi;
681: $userview=~s/\<head\>//gi;
682: $userview=~s/\<\/head\>//gi;
683: $userview=~s/action\s*\=/would_be_action\=/gi;
684: return $userview;
685: }
686:
687: sub get_student_answers {
688: my ($symb,$username,$domain,$courseid) = @_;
689: my ($map,$id,$feedurl) = split(/___/,$symb);
690: my (%old,%moreenv);
691: my @elements=('symb','courseid','domain','username');
692: foreach my $element (@elements) {
693: $old{$element}=$ENV{'form.grade_'.$element};
694: $moreenv{'form.grade_'.$element}=eval '$'.$element #'
695: }
696: $moreenv{'form.grade_target'}='answer';
697: &Apache::lonnet::appenv(%moreenv);
698: my $userview=&Apache::lonnet::ssi('/res/'.$feedurl);
699: &Apache::lonnet::delenv('form.grade_');
700: foreach my $element (@elements) {
701: $ENV{'form.grade_'.$element}=$old{$element};
702: }
703: $userview=~s/\<body[^\>]*\>//gi;
704: $userview=~s/\<\/body\>//gi;
705: $userview=~s/\<html\>//gi;
706: $userview=~s/\<\/html\>//gi;
707: $userview=~s/\<head\>//gi;
708: $userview=~s/\<\/head\>//gi;
709: $userview=~s/action\s*\=/would_be_action\=/gi;
710: return $userview;
711: }
712:
713: sub get_unprocessed_cgi {
714: my ($query,$possible_names)= @_;
715: # $Apache::lonxml::debug=1;
716: foreach (split(/&/,$query)) {
717: my ($name, $value) = split(/=/,$_);
718: $name = &Apache::lonnet::unescape($name);
719: if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) {
720: $value =~ tr/+/ /;
721: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
722: &Apache::lonxml::debug("Seting :$name: to :$value:");
723: unless (defined($ENV{'form.'.$name})) { &add_to_env('form.'.$name,$value) };
724: }
725: }
726: }
727:
728: sub cacheheader {
729: unless ($ENV{'request.method'} eq 'GET') { return ''; }
730: my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
731: my $output .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" />
732: <meta HTTP-EQUIV="Cache-control" CONTENT="no-cache" />
733: <meta HTTP-EQUIV="Pragma" CONTENT="no-cache" />';
734: return $output;
735: }
736:
737: sub no_cache {
738: my ($r) = @_;
739: unless ($ENV{'request.method'} eq 'GET') { return ''; }
740: #my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
741: $r->no_cache(1);
742: $r->header_out("Pragma" => "no-cache");
743: #$r->header_out("Expires" => $date);
744: }
745:
746: sub add_to_env {
747: my ($name,$value)=@_;
748: if (defined($ENV{$name})) {
749: if (ref($ENV{$name})) {
750: #already have multiple values
751: push(@{ $ENV{$name} },$value);
752: } else {
753: #first time seeing multiple values, convert hash entry to an arrayref
754: my $first=$ENV{$name};
755: undef($ENV{$name});
756: push(@{ $ENV{$name} },$first,$value);
757: }
758: } else {
759: $ENV{$name}=$value;
760: }
761: }
762:
763: #---CSV Upload/Handling functions
764:
765: # ========================================================= Store uploaded file
766: # needs $ENV{'form.upfile'}
767: # return $datatoken to be put into hidden field
768:
769: sub upfile_store {
770: my $r=shift;
771: $ENV{'form.upfile'}=~s/\r/\n/gs;
772: $ENV{'form.upfile'}=~s/\f/\n/gs;
773: $ENV{'form.upfile'}=~s/\n+/\n/gs;
774: $ENV{'form.upfile'}=~s/\n+$//gs;
775:
776: my $datatoken=$ENV{'user.name'}.'_'.$ENV{'user.domain'}.
777: '_enroll_'.$ENV{'request.course.id'}.'_'.time.'_'.$$;
778: {
779: my $fh=Apache::File->new('>'.$r->dir_config('lonDaemons').
780: '/tmp/'.$datatoken.'.tmp');
781: print $fh $ENV{'form.upfile'};
782: }
783: return $datatoken;
784: }
785:
786: # ================================================= Load uploaded file from tmp
787: # needs $ENV{'form.datatoken'}
788: # sets $ENV{'form.upfile'} to the contents of the file
789:
790: sub load_tmp_file {
791: my $r=shift;
792: my @studentdata=();
793: {
794: my $fh;
795: if ($fh=Apache::File->new($r->dir_config('lonDaemons').
796: '/tmp/'.$ENV{'form.datatoken'}.'.tmp')) {
797: @studentdata=<$fh>;
798: }
799: }
800: $ENV{'form.upfile'}=join('',@studentdata);
801: }
802:
803: # ========================================= Separate uploaded file into records
804: # returns array of records
805: # needs $ENV{'form.upfile'}
806: # needs $ENV{'form.upfiletype'}
807:
808: sub upfile_record_sep {
809: if ($ENV{'form.upfiletype'} eq 'xml') {
810: } else {
811: return split(/\n/,$ENV{'form.upfile'});
812: }
813: }
814:
815: # =============================================== Separate a record into fields
816: # needs $ENV{'form.upfiletype'}
817: # takes $record as arg
818: sub record_sep {
819: my $record=shift;
820: my %components=();
821: if ($ENV{'form.upfiletype'} eq 'xml') {
822: } elsif ($ENV{'form.upfiletype'} eq 'space') {
823: my $i=0;
824: foreach (split(/\s+/,$record)) {
825: my $field=$_;
826: $field=~s/^(\"|\')//;
827: $field=~s/(\"|\')$//;
828: $components{$i}=$field;
829: $i++;
830: }
831: } elsif ($ENV{'form.upfiletype'} eq 'tab') {
832: my $i=0;
833: foreach (split(/\t+/,$record)) {
834: my $field=$_;
835: $field=~s/^(\"|\')//;
836: $field=~s/(\"|\')$//;
837: $components{$i}=$field;
838: $i++;
839: }
840: } else {
841: my @allfields=split(/\,/,$record);
842: my $i=0;
843: my $j;
844: for ($j=0;$j<=$#allfields;$j++) {
845: my $field=$allfields[$j];
846: if ($field=~/^\s*(\"|\')/) {
847: my $delimiter=$1;
848: while (($field!~/$delimiter$/) && ($j<$#allfields)) {
849: $j++;
850: $field.=','.$allfields[$j];
851: }
852: $field=~s/^\s*$delimiter//;
853: $field=~s/$delimiter\s*$//;
854: }
855: $components{$i}=$field;
856: $i++;
857: }
858: }
859: return %components;
860: }
861:
862: # =============================== HTML code to select file and specify its type
863: sub upfile_select_html {
864: return (<<'ENDUPFORM');
865: <input type="file" name="upfile" size="50">
866: <br />Type: <select name="upfiletype">
867: <option value="csv">CSV (comma separated values, spreadsheet)</option>
868: <option value="space">Space separated</option>
869: <option value="tab">Tabulator separated</option>
870: <option value="xml">HTML/XML</option>
871: </select>
872: ENDUPFORM
873: }
874:
875: # ===================Prints a table of sample values from each column uploaded
876: # $r is an Apache Request ref
877: # $records is an arrayref from &Apache::loncommon::upfile_record_sep
878: sub csv_print_samples {
879: my ($r,$records) = @_;
880: my (%sone,%stwo,%sthree);
881: %sone=&record_sep($$records[0]);
882: if (defined($$records[1])) {%stwo=&record_sep($$records[1]);}
883: if (defined($$records[2])) {%sthree=&record_sep($$records[2]);}
884:
885: $r->print('Samples<br /><table border="2"><tr>');
886: foreach (sort({$a <=> $b} keys(%sone))) { $r->print('<th>Column '.($_+1).'</th>'); }
887: $r->print('</tr>');
888: foreach my $hash (\%sone,\%stwo,\%sthree) {
889: $r->print('<tr>');
890: foreach (sort({$a <=> $b} keys(%sone))) {
891: $r->print('<td>');
892: if (defined($$hash{$_})) { $r->print($$hash{$_}); }
893: $r->print('</td>');
894: }
895: $r->print('</tr>');
896: }
897: $r->print('</tr></table><br />'."\n");
898: }
899:
900: # ======Prints a table to create associations between values and table columns
901: # $r is an Apache Request ref
902: # $records is an arrayref from &Apache::loncommon::upfile_record_sep
903: # $d is an array of 2 element arrays (internal name, displayed name)
904: sub csv_print_select_table {
905: my ($r,$records,$d) = @_;
906: my $i=0;my %sone;
907: %sone=&record_sep($$records[0]);
908: $r->print('Associate columns with student attributes.'."\n".
909: '<table border="2"><tr><th>Attribute</th><th>Column</th></tr>'."\n");
910: foreach (@$d) {
911: my ($value,$display)=@{ $_ };
912: $r->print('<tr><td>'.$display.'</td>');
913:
914: $r->print('<td><select name=f'.$i.
915: ' onchange="javascript:flip(this.form,'.$i.');">');
916: $r->print('<option value="none"></option>');
917: foreach (sort({$a <=> $b} keys(%sone))) {
918: $r->print('<option value="'.$_.'">Column '.($_+1).'</option>');
919: }
920: $r->print('</select></td></tr>'."\n");
921: $i++;
922: }
923: $i--;
924: return $i;
925: }
926:
927: # ===================Prints a table of sample values from the upload and
928: # can make associate samples to internal names
929: # $r is an Apache Request ref
930: # $records is an arrayref from &Apache::loncommon::upfile_record_sep
931: # $d is an array of 2 element arrays (internal name, displayed name)
932: sub csv_samples_select_table {
933: my ($r,$records,$d) = @_;
934: my %sone; my %stwo; my %sthree;
935: my $i=0;
936:
937: $r->print('<table border=2><tr><th>Field</th><th>Samples</th></tr>');
938: %sone=&record_sep($$records[0]);
939: if (defined($$records[1])) {%stwo=&record_sep($$records[1]);}
940: if (defined($$records[2])) {%sthree=&record_sep($$records[2]);}
941:
942: foreach (sort keys %sone) {
943: $r->print('<tr><td><select name=f'.$i.
944: ' onchange="javascript:flip(this.form,'.$i.');">');
945: foreach (@$d) {
946: my ($value,$display)=@{ $_ };
947: $r->print('<option value='.$value.'>'.$display.'</option>');
948: }
949: $r->print('</select></td><td>');
950: if (defined($sone{$_})) { $r->print($sone{$_}."</br>\n"); }
951: if (defined($stwo{$_})) { $r->print($stwo{$_}."</br>\n"); }
952: if (defined($sthree{$_})) { $r->print($sthree{$_}."</br>\n"); }
953: $r->print('</td></tr>');
954: $i++;
955: }
956: $i--;
957: return($i);
958: }
959: 1;
960: __END__;
961:
962: =item languageids()
963:
964: returns list of all language ids
965:
966: =item languagedescription()
967:
968: returns description of a specified language id
969:
970: =item copyrightids()
971:
972: returns list of all copyrights
973:
974: =item copyrightdescription()
975:
976: returns description of a specified copyright id
977:
978: =item filecategories()
979:
980: returns list of all file categories
981:
982: =item filecategorytypes()
983:
984: returns list of file types belonging to a given file
985: category
986:
987: =item fileembstyle()
988:
989: returns embedding style for a specified file type
990:
991: =item filedescription()
992:
993: returns description for a specified file type
994:
995: =item filedescriptionex()
996:
997: returns description for a specified file type with
998: extra formatting
999:
1000: =item get_previous_attempt()
1001:
1002: return string with previous attempt on problem
1003:
1004: =item get_student_view()
1005:
1006: show a snapshot of what student was looking at
1007:
1008: =item get_student_answers()
1009:
1010: show a snapshot of how student was answering problem
1011:
1012: =item get_unprocessed_cgi()
1013:
1014: get unparsed CGI parameters
1015:
1016: =item cacheheader()
1017:
1018: returns cache-controlling header code
1019:
1020: =item nocache()
1021:
1022: specifies header code to not have cache
1023:
1024: =item add_to_env($name,$value)
1025:
1026: adds $name to the %ENV hash with value
1027: $value, if $name already exists, the entry is converted to an array
1028: reference and $value is added to the array.
1029:
1030: =back
1031:
1032: =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