Annotation of loncom/interface/loncommon.pm, revision 1.35
1.10 albertel 1: # The LearningOnline Network with CAPA
1.1 albertel 2: # a pile of common routines
1.10 albertel 3: #
1.35 ! matthew 4: # $Id: loncommon.pm,v 1.34 2002/04/23 21:00:01 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:
1.35 ! matthew 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
1.1 albertel 75: package Apache::loncommon;
76:
77: use strict;
1.22 www 78: use Apache::lonnet();
1.8 albertel 79: use POSIX qw(strftime);
1.1 albertel 80: use Apache::Constants qw(:common);
81: use Apache::lonmsg();
1.12 harris41 82:
1.22 www 83: my $readit;
84:
1.20 www 85: # ----------------------------------------------- Filetypes/Languages/Copyright
1.12 harris41 86: my %language;
87: my %cprtag;
88: my %fe; my %fd;
1.15 harris41 89: my %fc;
1.12 harris41 90:
1.20 www 91: # -------------------------------------------------------------- Thesaurus data
1.21 www 92: my @therelated;
93: my @theword;
94: my @thecount;
95: my %theindex;
96: my $thetotalcount;
1.20 www 97: my $thefuzzy=2;
98: my $thethreshold=0.1/$thefuzzy;
99: my $theavecount;
100:
1.12 harris41 101: # ----------------------------------------------------------------------- BEGIN
1.35 ! matthew 102: =item BEGIN()
! 103:
! 104: Initialize values from language.tab, copyright.tab, filetypes.tab,
! 105: and filecategories.tab.
! 106:
! 107: =cut
! 108: # ----------------------------------------------------------------------- BEGIN
! 109:
1.18 www 110: BEGIN {
1.22 www 111:
112: unless ($readit) {
1.12 harris41 113: # ------------------------------------------------------------------- languages
114: {
115: my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
116: '/language.tab');
1.16 harris41 117: if ($fh) {
118: while (<$fh>) {
119: next if /^\#/;
120: chomp;
121: my ($key,$val)=(split(/\s+/,$_,2));
122: $language{$key}=$val;
123: }
1.12 harris41 124: }
125: }
126: # ------------------------------------------------------------------ copyrights
127: {
1.16 harris41 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: }
1.12 harris41 137: }
138: }
1.15 harris41 139: # ------------------------------------------------------------- file categories
140: {
141: my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
1.16 harris41 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: }
1.15 harris41 150: }
151: }
1.12 harris41 152: # ------------------------------------------------------------------ file types
153: {
1.16 harris41 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: }
1.12 harris41 165: }
166: }
167: }
1.20 www 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: }
1.22 www 184: &Apache::lonnet::logthis(
185: "<font color=yellow>INFO: Read file types and thesaurus</font>");
186: $readit=1;
187: }
1.32 matthew 188:
189: }
190: # ============================================================= END BEGIN BLOCK
1.33 matthew 191: ###############################################################
192: ## Home server <option> list generating code ##
193: ###############################################################
1.35 ! matthew 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: #-------------------------------------------
1.34 matthew 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:
1.35 ! matthew 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: #-------------------------------------------
1.34 matthew 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:
1.35 ! matthew 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: #-------------------------------------------
1.33 matthew 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:
1.35 ! matthew 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: #-------------------------------------------
1.33 matthew 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: ###############################################################
1.32 matthew 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.
1.35 ! matthew 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: #-------------------------------------------
1.32 matthew 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: }
1.22 www 358:
1.32 matthew 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;
1.20 www 376: }
1.32 matthew 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:
1.20 www 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 ();
1.14 harris41 553: }
554:
555: # ---------------------------------------------------------------- Language IDs
556: sub languageids {
1.16 harris41 557: return sort(keys(%language));
1.14 harris41 558: }
559:
560: # -------------------------------------------------------- Language Description
561: sub languagedescription {
1.16 harris41 562: return $language{shift(@_)};
1.14 harris41 563: }
564:
565: # --------------------------------------------------------------- Copyright IDs
566: sub copyrightids {
1.16 harris41 567: return sort(keys(%cprtag));
1.14 harris41 568: }
569:
570: # ------------------------------------------------------- Copyright Description
571: sub copyrightdescription {
1.16 harris41 572: return $cprtag{shift(@_)};
1.14 harris41 573: }
574:
575: # ------------------------------------------------------------- File Categories
576: sub filecategories {
1.16 harris41 577: return sort(keys(%fc));
1.15 harris41 578: }
1.14 harris41 579:
1.17 harris41 580: # -------------------------------------- File Types within a specified category
1.15 harris41 581: sub filecategorytypes {
1.16 harris41 582: return @{$fc{lc(shift(@_))}};
1.14 harris41 583: }
584:
585: # ------------------------------------------------------------------ File Types
586: sub fileextensions {
1.16 harris41 587: return sort(keys(%fe));
1.14 harris41 588: }
589:
590: # ------------------------------------------------------------- Embedding Style
591: sub fileembstyle {
1.16 harris41 592: return $fe{lc(shift(@_))};
1.14 harris41 593: }
594:
595: # ------------------------------------------------------------ Description Text
596: sub filedescription {
1.16 harris41 597: return $fd{lc(shift(@_))};
598: }
599:
600: # ------------------------------------------------------------ Description Text
601: sub filedescriptionex {
602: my $ex=shift;
603: return '.'.$ex.' '.$fd{lc($ex)};
1.12 harris41 604: }
1.1 albertel 605:
606: sub get_previous_attempt {
1.2 albertel 607: my ($symb,$username,$domain,$course)=@_;
1.1 albertel 608: my $prevattempts='';
609: if ($symb) {
1.3 albertel 610: my (%returnhash)=
611: &Apache::lonnet::restore($symb,$course,$domain,$username);
1.1 albertel 612: if ($returnhash{'version'}) {
613: my %lasthash=();
614: my $version;
615: for ($version=1;$version<=$returnhash{'version'};$version++) {
1.19 harris41 616: foreach (sort(split(/\:/,$returnhash{$version.':keys'}))) {
1.1 albertel 617: $lasthash{$_}=$returnhash{$version.':'.$_};
1.19 harris41 618: }
1.1 albertel 619: }
620: $prevattempts='<table border=2></tr><th>History</th>';
1.16 harris41 621: foreach (sort(keys %lasthash)) {
1.31 albertel 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: }
1.16 harris41 630: }
1.1 albertel 631: for ($version=1;$version<=$returnhash{'version'};$version++) {
632: $prevattempts.='</tr><tr><th>Attempt '.$version.'</th>';
1.16 harris41 633: foreach (sort(keys %lasthash)) {
1.5 albertel 634: my $value;
635: if ($_ =~ /timestamp/) {
636: $value=scalar(localtime($returnhash{$version.':'.$_}));
637: } else {
638: $value=$returnhash{$version.':'.$_};
639: }
640: $prevattempts.='<td>'.$value.'</td>';
1.16 harris41 641: }
1.1 albertel 642: }
643: $prevattempts.='</tr><tr><th>Current</th>';
1.16 harris41 644: foreach (sort(keys %lasthash)) {
1.5 albertel 645: my $value;
646: if ($_ =~ /timestamp/) {
647: $value=scalar(localtime($lasthash{$_}));
648: } else {
649: $value=$lasthash{$_};
650: }
651: $prevattempts.='<td>'.$value.'</td>';
1.16 harris41 652: }
1.1 albertel 653: $prevattempts.='</tr></table>';
654: } else {
655: $prevattempts='Nothing submitted - no attempts.';
656: }
657: } else {
658: $prevattempts='No data.';
659: }
1.10 albertel 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: }
1.11 albertel 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';
1.10 albertel 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;
1.1 albertel 711: }
712:
1.6 albertel 713: sub get_unprocessed_cgi {
1.25 albertel 714: my ($query,$possible_names)= @_;
1.26 matthew 715: # $Apache::lonxml::debug=1;
1.16 harris41 716: foreach (split(/&/,$query)) {
1.6 albertel 717: my ($name, $value) = split(/=/,$_);
1.25 albertel 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:");
1.30 albertel 723: unless (defined($ENV{'form.'.$name})) { &add_to_env('form.'.$name,$value) };
1.25 albertel 724: }
1.16 harris41 725: }
1.6 albertel 726: }
727:
1.7 albertel 728: sub cacheheader {
1.23 www 729: unless ($ENV{'request.method'} eq 'GET') { return ''; }
1.8 albertel 730: my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
1.7 albertel 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:
1.9 albertel 737: sub no_cache {
738: my ($r) = @_;
1.23 www 739: unless ($ENV{'request.method'} eq 'GET') { return ''; }
1.24 albertel 740: #my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
1.9 albertel 741: $r->no_cache(1);
742: $r->header_out("Pragma" => "no-cache");
1.24 albertel 743: #$r->header_out("Expires" => $date);
1.9 albertel 744: }
1.25 albertel 745:
746: sub add_to_env {
747: my ($name,$value)=@_;
1.28 albertel 748: if (defined($ENV{$name})) {
1.27 albertel 749: if (ref($ENV{$name})) {
1.25 albertel 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: }
1.31 albertel 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.
1.32 matthew 915: ' onchange="javascript:flip(this.form,'.$i.');">');
1.31 albertel 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.
1.32 matthew 944: ' onchange="javascript:flip(this.form,'.$i.');">');
1.31 albertel 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);
1.25 albertel 958: }
1.1 albertel 959: 1;
960: __END__;
1.17 harris41 961:
1.35 ! matthew 962: =item languageids()
1.17 harris41 963:
1.35 ! matthew 964: returns list of all language ids
1.17 harris41 965:
1.35 ! matthew 966: =item languagedescription()
1.17 harris41 967:
1.35 ! matthew 968: returns description of a specified language id
1.17 harris41 969:
1.35 ! matthew 970: =item copyrightids()
1.17 harris41 971:
1.35 ! matthew 972: returns list of all copyrights
1.17 harris41 973:
1.35 ! matthew 974: =item copyrightdescription()
1.17 harris41 975:
1.35 ! matthew 976: returns description of a specified copyright id
1.17 harris41 977:
1.35 ! matthew 978: =item filecategories()
1.17 harris41 979:
1.35 ! matthew 980: returns list of all file categories
1.17 harris41 981:
1.35 ! matthew 982: =item filecategorytypes()
1.17 harris41 983:
1.35 ! matthew 984: returns list of file types belonging to a given file
1.17 harris41 985: category
986:
1.35 ! matthew 987: =item fileembstyle()
1.17 harris41 988:
1.35 ! matthew 989: returns embedding style for a specified file type
1.17 harris41 990:
1.35 ! matthew 991: =item filedescription()
1.17 harris41 992:
1.35 ! matthew 993: returns description for a specified file type
1.17 harris41 994:
1.35 ! matthew 995: =item filedescriptionex()
1.17 harris41 996:
1.35 ! matthew 997: returns description for a specified file type with
1.17 harris41 998: extra formatting
999:
1.35 ! matthew 1000: =item get_previous_attempt()
1.17 harris41 1001:
1.35 ! matthew 1002: return string with previous attempt on problem
1.17 harris41 1003:
1.35 ! matthew 1004: =item get_student_view()
1.17 harris41 1005:
1.35 ! matthew 1006: show a snapshot of what student was looking at
1.17 harris41 1007:
1.35 ! matthew 1008: =item get_student_answers()
1.17 harris41 1009:
1.35 ! matthew 1010: show a snapshot of how student was answering problem
1.17 harris41 1011:
1.35 ! matthew 1012: =item get_unprocessed_cgi()
1.17 harris41 1013:
1.35 ! matthew 1014: get unparsed CGI parameters
1.17 harris41 1015:
1.35 ! matthew 1016: =item cacheheader()
1.17 harris41 1017:
1.35 ! matthew 1018: returns cache-controlling header code
1.17 harris41 1019:
1.35 ! matthew 1020: =item nocache()
1.17 harris41 1021:
1.35 ! matthew 1022: specifies header code to not have cache
1.25 albertel 1023:
1.35 ! matthew 1024: =item add_to_env($name,$value)
1.25 albertel 1025:
1.35 ! matthew 1026: adds $name to the %ENV hash with value
1.25 albertel 1027: $value, if $name already exists, the entry is converted to an array
1028: reference and $value is added to the array.
1.17 harris41 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