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