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