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