Annotation of loncom/interface/loncommon.pm, revision 1.36
1.10 albertel 1: # The LearningOnline Network with CAPA
1.1 albertel 2: # a pile of common routines
1.10 albertel 3: #
1.36 ! matthew 4: # $Id: loncommon.pm,v 1.35 2002/04/23 21:42: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.36 ! matthew 191:
! 192: =item linked_select_forms(...)
! 193:
! 194: linked_select_forms returns a string containing a <script></script> block
! 195: and html for two <select> menus. The select menus will be linked in that
! 196: changing the value of the first menu will result in new values being placed
! 197: in the second menu. The values in the select menu will appear in alphabetical
! 198: order.
! 199:
! 200: linked_select_forms takes the following ordered inputs:
! 201:
! 202: =over 4
! 203:
! 204: =item $formname, the name of the <form> tag
! 205:
! 206: =item $middletext, the text which appears between the <select> tags
! 207:
! 208: =item $firstdefault, the default value for the first menu
! 209:
! 210: =item $firstselectname, the name of the first <select> tag
! 211:
! 212: =item $secondselectname, the name of the second <select> tag
! 213:
! 214: =item $hashref, a reference to a hash containing the data for the menus.
! 215:
! 216: Below is an example of such a hash. Only the 'text', 'default', and
! 217: 'select2' keys must appear as stated. keys(%menu) are the possible
! 218: values for the first select menu. The text that coincides with the
! 219: first menu values is given in $menu{$choice1}->{'text'}. The values
! 220: and text for the second menu are given in the hash pointed to by
! 221: $menu{$choice1}->{'select2'}.
! 222:
! 223: my %menu = ( A1 => { text =>"Choice A1" ,
! 224: default => "B3",
! 225: select2 => {
! 226: B1 => "Choice B1",
! 227: B2 => "Choice B2",
! 228: B3 => "Choice B3",
! 229: B4 => "Choice B4"
! 230: }
! 231: },
! 232: A2 => { text =>"Choice A2" ,
! 233: default => "C2",
! 234: select2 => {
! 235: C1 => "Choice C1",
! 236: C2 => "Choice C2",
! 237: C3 => "Choice C3"
! 238: }
! 239: },
! 240: A3 => { text =>"Choice A3" ,
! 241: default => "D6",
! 242: select2 => {
! 243: D1 => "Choice D1",
! 244: D2 => "Choice D2",
! 245: D3 => "Choice D3",
! 246: D4 => "Choice D4",
! 247: D5 => "Choice D5",
! 248: D6 => "Choice D6",
! 249: D7 => "Choice D7"
! 250: }
! 251: }
! 252: );
! 253:
! 254: =back
! 255:
! 256: =cut
! 257:
! 258: # ------------------------------------------------
! 259:
! 260: sub linked_select_forms {
! 261: my ($formname,
! 262: $middletext,
! 263: $firstdefault,
! 264: $firstselectname,
! 265: $secondselectname,
! 266: $hashref
! 267: ) = @_;
! 268: my $second = "document.$formname.$secondselectname";
! 269: my $first = "document.$formname.$firstselectname";
! 270: # output the javascript to do the changing
! 271: my $result = '';
! 272: $result.="<script>\n";
! 273: $result.="var select2data = new Object();\n";
! 274: $" = '","';
! 275: my $debug = '';
! 276: foreach my $s1 (sort(keys(%$hashref))) {
! 277: $result.="select2data.d_$s1 = new Object();\n";
! 278: $result.="select2data.d_$s1.def = new String('".
! 279: $hashref->{$s1}->{'default'}."');\n";
! 280: $result.="select2data.d_$s1.values = new Array(";
! 281: my @s2values = sort(keys( %{ $hashref->{$s1}->{'select2'} } ));
! 282: $result.="\"@s2values\");\n";
! 283: $result.="select2data.d_$s1.texts = new Array(";
! 284: my @s2texts;
! 285: foreach my $value (@s2values) {
! 286: push @s2texts, $hashref->{$s1}->{'select2'}->{$value};
! 287: }
! 288: $result.="\"@s2texts\");\n";
! 289: }
! 290: $"=' ';
! 291: $result.= <<"END";
! 292:
! 293: function select1_changed() {
! 294: // Determine new choice
! 295: var newvalue = "d_" + $first.value;
! 296: // update select2
! 297: var values = select2data[newvalue].values;
! 298: var texts = select2data[newvalue].texts;
! 299: var select2def = select2data[newvalue].def;
! 300: var i;
! 301: // out with the old
! 302: for (i = 0; i < $second.options.length; i++) {
! 303: $second.options[i] = null;
! 304: }
! 305: // in with the nuclear
! 306: for (i=0;i<values.length; i++) {
! 307: $second.options[i] = new Option(values[i]);
! 308: $second.options[i].text = texts[i];
! 309: if (values[i] == select2def) {
! 310: $second.options[i].selected = true;
! 311: }
! 312: }
! 313: }
! 314: </script>
! 315: END
! 316: # output the initial values for the selection lists
! 317: $result .= "<select size=\"1\" name=\"$firstselectname\" onchange=\"select1_changed()\">\n";
! 318: foreach my $value (sort(keys(%$hashref))) {
! 319: $result.=" <option value=\"$value\" ";
! 320: $result.=" selected=\"true\" " if ($value eq $firstdefault);
! 321: $result.=">$hashref->{$value}->{'text'}</option>\n";
! 322: }
! 323: $result .= "</select>\n";
! 324: my %select2 = %{$hashref->{$firstdefault}->{'select2'}};
! 325: $result .= $middletext;
! 326: $result .= "<select size=\"1\" name=\"$secondselectname\">\n";
! 327: my $seconddefault = $hashref->{$firstdefault}->{'default'};
! 328: foreach my $value (sort(keys(%select2))) {
! 329: $result.=" <option value=\"$value\" ";
! 330: $result.=" selected=\"true\" " if ($value eq $seconddefault);
! 331: $result.=">$select2{$value}</option>\n";
! 332: }
! 333: $result .= "</select>\n";
! 334: # return $debug;
! 335: return $result;
! 336: } # end of sub linked_select_forms {
! 337:
1.33 matthew 338: ###############################################################
339: ## Home server <option> list generating code ##
340: ###############################################################
1.35 matthew 341: #-------------------------------------------
342:
343: =item get_domains()
344:
345: Returns an array containing each of the domains listed in the hosts.tab
346: file.
347:
348: =cut
349:
350: #-------------------------------------------
1.34 matthew 351: sub get_domains {
352: # The code below was stolen from "The Perl Cookbook", p 102, 1st ed.
353: my @domains;
354: my %seen;
355: foreach (sort values(%Apache::lonnet::hostdom)) {
356: push (@domains,$_) unless $seen{$_}++;
357: }
358: return @domains;
359: }
360:
1.35 matthew 361: #-------------------------------------------
362:
363: =item select_dom_form($defdom,$name)
364:
365: Returns a string containing a <select name='$name' size='1'> form to
366: allow a user to select the domain to preform an operation in.
367: See loncreateuser.pm for an example invocation and use.
368:
369: =cut
370:
371: #-------------------------------------------
1.34 matthew 372: sub select_dom_form {
373: my ($defdom,$name) = @_;
374: my @domains = get_domains();
375: my $selectdomain = "<select name=\"$name\" size=\"1\">\n";
376: foreach (@domains) {
377: $selectdomain.="<option value=\"$_\" ".
378: ($_ eq $defdom ? 'selected' : '').
379: ">$_</option>\n";
380: }
381: $selectdomain.="</select>";
382: return $selectdomain;
383: }
384:
1.35 matthew 385: #-------------------------------------------
386:
387: =item get_home_servers($domain)
388:
389: Returns a hash which contains keys like '103l3' and values like
390: 'kirk.lite.msu.edu'. All of the keys will be for machines in the
391: given $domain.
392:
393: =cut
394:
395: #-------------------------------------------
1.33 matthew 396: sub get_home_servers {
397: my $domain = shift;
398: my %home_servers;
399: foreach (keys(%Apache::lonnet::libserv)) {
400: if ($Apache::lonnet::hostdom{$_} eq $domain) {
401: $home_servers{$_} = $Apache::lonnet::hostname{$_};
402: }
403: }
404: return %home_servers;
405: }
406:
1.35 matthew 407: #-------------------------------------------
408:
409: =item home_server_option_list($domain)
410:
411: returns a string which contains an <option> list to be used in a
412: <select> form input. See loncreateuser.pm for an example.
413:
414: =cut
415:
416: #-------------------------------------------
1.33 matthew 417: sub home_server_option_list {
418: my $domain = shift;
419: my %servers = &get_home_servers($domain);
420: my $result = '';
421: foreach (sort keys(%servers)) {
422: $result.=
423: '<option value="'.$_.'">'.$_.' '.$servers{$_}."</option>\n";
424: }
425: return $result;
426: }
427: ###############################################################
428: ## End of home server <option> list generating code ##
429: ###############################################################
1.32 matthew 430:
431: ###############################################################
432: ## Authentication changing form generation subroutines ##
433: ###############################################################
434: ##
435: ## All of the authform_xxxxxxx subroutines take their inputs in a
436: ## hash, and have reasonable default values.
437: ##
438: ## formname = the name given in the <form> tag.
1.35 matthew 439: #-------------------------------------------
440:
441: =item authform_xxxxxx
442:
443: The authform_xxxxxx subroutines provide javascript and html forms which
444: handle some of the conveniences required for authentication forms.
445: This is not an optimal method, but it works.
446:
447: See loncreateuser.pm for invocation and use examples.
448:
449: =over 4
450:
451: =item authform_header
452:
453: =item authform_authorwarning
454:
455: =item authform_nochange
456:
457: =item authform_kerberos
458:
459: =item authform_internal
460:
461: =item authform_filesystem
462:
463: =back
464:
465: =cut
466:
467: #-------------------------------------------
1.32 matthew 468: sub authform_header{
469: my %in = (
470: formname => 'cu',
471: kerb_def_dom => 'MSU.EDU',
472: @_,
473: );
474: $in{'formname'} = 'document.' . $in{'formname'};
475: my $result='';
476: $result.=<<"END";
477: var current = new Object();
478: current.radiovalue = 'nochange';
479: current.argfield = null;
480:
481: function changed_radio(choice,currentform) {
482: var choicearg = choice + 'arg';
483: // If a radio button in changed, we need to change the argfield
484: if (current.radiovalue != choice) {
485: current.radiovalue = choice;
486: if (current.argfield != null) {
487: currentform.elements[current.argfield].value = '';
488: }
489: if (choice == 'nochange') {
490: current.argfield = null;
491: } else {
492: current.argfield = choicearg;
493: switch(choice) {
494: case 'krb':
495: currentform.elements[current.argfield].value =
496: "$in{'kerb_def_dom'}";
497: break;
498: default:
499: break;
500: }
501: }
502: }
503: return;
504: }
1.22 www 505:
1.32 matthew 506: function changed_text(choice,currentform) {
507: var choicearg = choice + 'arg';
508: if (currentform.elements[choicearg].value !='') {
509: switch (choice) {
510: case 'krb': currentform.elements[choicearg].value =
511: currentform.elements[choicearg].value.toUpperCase();
512: break;
513: default:
514: }
515: // clear old field
516: if ((current.argfield != choicearg) && (current.argfield != null)) {
517: currentform.elements[current.argfield].value = '';
518: }
519: current.argfield = choicearg;
520: }
521: set_auth_radio_buttons(choice,currentform);
522: return;
1.20 www 523: }
1.32 matthew 524:
525: function set_auth_radio_buttons(newvalue,currentform) {
526: var i=0;
527: while (i < currentform.login.length) {
528: if (currentform.login[i].value == newvalue) { break; }
529: i++;
530: }
531: if (i == currentform.login.length) {
532: return;
533: }
534: current.radiovalue = newvalue;
535: currentform.login[i].checked = true;
536: return;
537: }
538: END
539: return $result;
540: }
541:
542: sub authform_authorwarning{
543: my $result='';
544: $result=<<"END";
545: <i>As a general rule, only authors or co-authors should be filesystem
546: authenticated (which allows access to the server filesystem).</i>
547: END
548: return $result;
549: }
550:
551: sub authform_nochange{
552: my %in = (
553: formname => 'document.cu',
554: kerb_def_dom => 'MSU.EDU',
555: @_,
556: );
557: my $result='';
558: $result.=<<"END";
559: <input type="radio" name="login" value="nochange" checked="checked"
560: onclick="javascript:changed_radio('nochange',$in{'formname'});">
561: Do not change login data
562: END
563: return $result;
564: }
565:
566: sub authform_kerberos{
567: my %in = (
568: formname => 'document.cu',
569: kerb_def_dom => 'MSU.EDU',
570: @_,
571: );
572: my $result='';
573: $result.=<<"END";
574: <input type="radio" name="login" value="krb"
575: onclick="javascript:changed_radio('krb',$in{'formname'});"
576: onchange="javascript:changed_radio('krb',$in{'formname'});">
577: Kerberos authenticated with domain
578: <input type="text" size="10" name="krbarg" value=""
579: onchange="javascript:changed_text('krb',$in{'formname'});">
580: END
581: return $result;
582: }
583:
584: sub authform_internal{
585: my %args = (
586: formname => 'document.cu',
587: kerb_def_dom => 'MSU.EDU',
588: @_,
589: );
590: my $result='';
591: $result.=<<"END";
592: <input type="radio" name="login" value="int"
593: onchange="javascript:changed_radio('int',$args{'formname'});"
594: onclick="javascript:changed_radio('int',$args{'formname'});">
595: Internally authenticated (with initial password
596: <input type="text" size="10" name="intarg" value=""
597: onchange="javascript:changed_text('int',$args{'formname'});">
598: END
599: return $result;
600: }
601:
602: sub authform_local{
603: my %in = (
604: formname => 'document.cu',
605: kerb_def_dom => 'MSU.EDU',
606: @_,
607: );
608: my $result='';
609: $result.=<<"END";
610: <input type="radio" name="login" value="loc"
611: onchange="javascript:changed_radio('loc',$in{'formname'});"
612: onclick="javascript:changed_radio('loc',$in{'formname'});">
613: Local Authentication with argument
614: <input type="text" size="10" name="locarg" value=""
615: onchange="javascript:changed_text('loc',$in{'formname'});">
616: END
617: return $result;
618: }
619:
620: sub authform_filesystem{
621: my %in = (
622: formname => 'document.cu',
623: kerb_def_dom => 'MSU.EDU',
624: @_,
625: );
626: my $result='';
627: $result.=<<"END";
628: <input type="radio" name="login" value="fsys"
629: onchange="javascript:changed_radio('fsys',$in{'formname'});"
630: onclick="javascript:changed_radio('fsys',$in{'formname'});">
631: Filesystem authenticated (with initial password
632: <input type="text" size="10" name="fsysarg" value=""
633: onchange="javascript:changed_text('fsys',$in{'formname'});">
634: END
635: return $result;
636: }
637:
638: ###############################################################
639: ## End Authentication changing form generation functions ##
640: ###############################################################
641:
1.20 www 642:
643:
644: # ---------------------------------------------------------- Is this a keyword?
645:
646: sub keyword {
647: my $newword=shift;
648: $newword=~s/\W//g;
649: $newword=~tr/A-Z/a-z/;
650: my $tindex=$theindex{$newword};
651: if ($tindex) {
652: if ($thecount[$tindex]>$theavecount) {
653: return 1;
654: }
655: }
656: return 0;
657: }
658: # -------------------------------------------------------- Return related words
659:
660: sub related {
661: my $newword=shift;
662: $newword=~s/\W//g;
663: $newword=~tr/A-Z/a-z/;
664: my $tindex=$theindex{$newword};
665: if ($tindex) {
666: my %found=();
667: foreach (split(/\,/,$therelated[$tindex])) {
668: # - Related word found
669: my ($ridx,$rcount)=split(/\:/,$_);
670: # - Direct relation index
671: my $directrel=$rcount/$thecount[$tindex];
672: if ($directrel>$thethreshold) {
673: foreach (split(/\,/,$therelated[$ridx])) {
674: my ($rridx,$rrcount)=split(/\:/,$_);
675: if ($rridx==$tindex) {
676: # - Determine reverse relation index
677: my $revrel=$rrcount/$thecount[$ridx];
678: # - Calculate full index
679: $found{$ridx}=$directrel*$revrel;
680: if ($found{$ridx}>$thethreshold) {
681: foreach (split(/\,/,$therelated[$ridx])) {
682: my ($rrridx,$rrrcount)=split(/\:/,$_);
683: unless ($found{$rrridx}) {
684: my $revrevrel=$rrrcount/$thecount[$ridx];
685: if (
686: $directrel*$revrel*$revrevrel>$thethreshold
687: ) {
688: $found{$rrridx}=
689: $directrel*$revrel*$revrevrel;
690: }
691: }
692: }
693: }
694: }
695: }
696: }
697: }
698: }
699: return ();
1.14 harris41 700: }
701:
702: # ---------------------------------------------------------------- Language IDs
703: sub languageids {
1.16 harris41 704: return sort(keys(%language));
1.14 harris41 705: }
706:
707: # -------------------------------------------------------- Language Description
708: sub languagedescription {
1.16 harris41 709: return $language{shift(@_)};
1.14 harris41 710: }
711:
712: # --------------------------------------------------------------- Copyright IDs
713: sub copyrightids {
1.16 harris41 714: return sort(keys(%cprtag));
1.14 harris41 715: }
716:
717: # ------------------------------------------------------- Copyright Description
718: sub copyrightdescription {
1.16 harris41 719: return $cprtag{shift(@_)};
1.14 harris41 720: }
721:
722: # ------------------------------------------------------------- File Categories
723: sub filecategories {
1.16 harris41 724: return sort(keys(%fc));
1.15 harris41 725: }
1.14 harris41 726:
1.17 harris41 727: # -------------------------------------- File Types within a specified category
1.15 harris41 728: sub filecategorytypes {
1.16 harris41 729: return @{$fc{lc(shift(@_))}};
1.14 harris41 730: }
731:
732: # ------------------------------------------------------------------ File Types
733: sub fileextensions {
1.16 harris41 734: return sort(keys(%fe));
1.14 harris41 735: }
736:
737: # ------------------------------------------------------------- Embedding Style
738: sub fileembstyle {
1.16 harris41 739: return $fe{lc(shift(@_))};
1.14 harris41 740: }
741:
742: # ------------------------------------------------------------ Description Text
743: sub filedescription {
1.16 harris41 744: return $fd{lc(shift(@_))};
745: }
746:
747: # ------------------------------------------------------------ Description Text
748: sub filedescriptionex {
749: my $ex=shift;
750: return '.'.$ex.' '.$fd{lc($ex)};
1.12 harris41 751: }
1.1 albertel 752:
753: sub get_previous_attempt {
1.2 albertel 754: my ($symb,$username,$domain,$course)=@_;
1.1 albertel 755: my $prevattempts='';
756: if ($symb) {
1.3 albertel 757: my (%returnhash)=
758: &Apache::lonnet::restore($symb,$course,$domain,$username);
1.1 albertel 759: if ($returnhash{'version'}) {
760: my %lasthash=();
761: my $version;
762: for ($version=1;$version<=$returnhash{'version'};$version++) {
1.19 harris41 763: foreach (sort(split(/\:/,$returnhash{$version.':keys'}))) {
1.1 albertel 764: $lasthash{$_}=$returnhash{$version.':'.$_};
1.19 harris41 765: }
1.1 albertel 766: }
767: $prevattempts='<table border=2></tr><th>History</th>';
1.16 harris41 768: foreach (sort(keys %lasthash)) {
1.31 albertel 769: my ($ign,@parts) = split(/\./,$_);
770: if (@parts) {
771: my $data=$parts[-1];
772: pop(@parts);
773: $prevattempts.='<th>Part '.join('.',@parts).'<br />'.$data.'</th>';
774: } else {
775: $prevattempts.='<th>'.$ign.'</th>';
776: }
1.16 harris41 777: }
1.1 albertel 778: for ($version=1;$version<=$returnhash{'version'};$version++) {
779: $prevattempts.='</tr><tr><th>Attempt '.$version.'</th>';
1.16 harris41 780: foreach (sort(keys %lasthash)) {
1.5 albertel 781: my $value;
782: if ($_ =~ /timestamp/) {
783: $value=scalar(localtime($returnhash{$version.':'.$_}));
784: } else {
785: $value=$returnhash{$version.':'.$_};
786: }
787: $prevattempts.='<td>'.$value.'</td>';
1.16 harris41 788: }
1.1 albertel 789: }
790: $prevattempts.='</tr><tr><th>Current</th>';
1.16 harris41 791: foreach (sort(keys %lasthash)) {
1.5 albertel 792: my $value;
793: if ($_ =~ /timestamp/) {
794: $value=scalar(localtime($lasthash{$_}));
795: } else {
796: $value=$lasthash{$_};
797: }
798: $prevattempts.='<td>'.$value.'</td>';
1.16 harris41 799: }
1.1 albertel 800: $prevattempts.='</tr></table>';
801: } else {
802: $prevattempts='Nothing submitted - no attempts.';
803: }
804: } else {
805: $prevattempts='No data.';
806: }
1.10 albertel 807: }
808:
809: sub get_student_view {
810: my ($symb,$username,$domain,$courseid) = @_;
811: my ($map,$id,$feedurl) = split(/___/,$symb);
812: my (%old,%moreenv);
813: my @elements=('symb','courseid','domain','username');
814: foreach my $element (@elements) {
815: $old{$element}=$ENV{'form.grade_'.$element};
816: $moreenv{'form.grade_'.$element}=eval '$'.$element #'
817: }
1.11 albertel 818: &Apache::lonnet::appenv(%moreenv);
819: my $userview=&Apache::lonnet::ssi('/res/'.$feedurl);
820: &Apache::lonnet::delenv('form.grade_');
821: foreach my $element (@elements) {
822: $ENV{'form.grade_'.$element}=$old{$element};
823: }
824: $userview=~s/\<body[^\>]*\>//gi;
825: $userview=~s/\<\/body\>//gi;
826: $userview=~s/\<html\>//gi;
827: $userview=~s/\<\/html\>//gi;
828: $userview=~s/\<head\>//gi;
829: $userview=~s/\<\/head\>//gi;
830: $userview=~s/action\s*\=/would_be_action\=/gi;
831: return $userview;
832: }
833:
834: sub get_student_answers {
835: my ($symb,$username,$domain,$courseid) = @_;
836: my ($map,$id,$feedurl) = split(/___/,$symb);
837: my (%old,%moreenv);
838: my @elements=('symb','courseid','domain','username');
839: foreach my $element (@elements) {
840: $old{$element}=$ENV{'form.grade_'.$element};
841: $moreenv{'form.grade_'.$element}=eval '$'.$element #'
842: }
843: $moreenv{'form.grade_target'}='answer';
1.10 albertel 844: &Apache::lonnet::appenv(%moreenv);
845: my $userview=&Apache::lonnet::ssi('/res/'.$feedurl);
846: &Apache::lonnet::delenv('form.grade_');
847: foreach my $element (@elements) {
848: $ENV{'form.grade_'.$element}=$old{$element};
849: }
850: $userview=~s/\<body[^\>]*\>//gi;
851: $userview=~s/\<\/body\>//gi;
852: $userview=~s/\<html\>//gi;
853: $userview=~s/\<\/html\>//gi;
854: $userview=~s/\<head\>//gi;
855: $userview=~s/\<\/head\>//gi;
856: $userview=~s/action\s*\=/would_be_action\=/gi;
857: return $userview;
1.1 albertel 858: }
859:
1.6 albertel 860: sub get_unprocessed_cgi {
1.25 albertel 861: my ($query,$possible_names)= @_;
1.26 matthew 862: # $Apache::lonxml::debug=1;
1.16 harris41 863: foreach (split(/&/,$query)) {
1.6 albertel 864: my ($name, $value) = split(/=/,$_);
1.25 albertel 865: $name = &Apache::lonnet::unescape($name);
866: if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) {
867: $value =~ tr/+/ /;
868: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
869: &Apache::lonxml::debug("Seting :$name: to :$value:");
1.30 albertel 870: unless (defined($ENV{'form.'.$name})) { &add_to_env('form.'.$name,$value) };
1.25 albertel 871: }
1.16 harris41 872: }
1.6 albertel 873: }
874:
1.7 albertel 875: sub cacheheader {
1.23 www 876: unless ($ENV{'request.method'} eq 'GET') { return ''; }
1.8 albertel 877: my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
1.7 albertel 878: my $output .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" />
879: <meta HTTP-EQUIV="Cache-control" CONTENT="no-cache" />
880: <meta HTTP-EQUIV="Pragma" CONTENT="no-cache" />';
881: return $output;
882: }
883:
1.9 albertel 884: sub no_cache {
885: my ($r) = @_;
1.23 www 886: unless ($ENV{'request.method'} eq 'GET') { return ''; }
1.24 albertel 887: #my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
1.9 albertel 888: $r->no_cache(1);
889: $r->header_out("Pragma" => "no-cache");
1.24 albertel 890: #$r->header_out("Expires" => $date);
1.9 albertel 891: }
1.25 albertel 892:
893: sub add_to_env {
894: my ($name,$value)=@_;
1.28 albertel 895: if (defined($ENV{$name})) {
1.27 albertel 896: if (ref($ENV{$name})) {
1.25 albertel 897: #already have multiple values
898: push(@{ $ENV{$name} },$value);
899: } else {
900: #first time seeing multiple values, convert hash entry to an arrayref
901: my $first=$ENV{$name};
902: undef($ENV{$name});
903: push(@{ $ENV{$name} },$first,$value);
904: }
905: } else {
906: $ENV{$name}=$value;
907: }
1.31 albertel 908: }
909:
910: #---CSV Upload/Handling functions
911:
912: # ========================================================= Store uploaded file
913: # needs $ENV{'form.upfile'}
914: # return $datatoken to be put into hidden field
915:
916: sub upfile_store {
917: my $r=shift;
918: $ENV{'form.upfile'}=~s/\r/\n/gs;
919: $ENV{'form.upfile'}=~s/\f/\n/gs;
920: $ENV{'form.upfile'}=~s/\n+/\n/gs;
921: $ENV{'form.upfile'}=~s/\n+$//gs;
922:
923: my $datatoken=$ENV{'user.name'}.'_'.$ENV{'user.domain'}.
924: '_enroll_'.$ENV{'request.course.id'}.'_'.time.'_'.$$;
925: {
926: my $fh=Apache::File->new('>'.$r->dir_config('lonDaemons').
927: '/tmp/'.$datatoken.'.tmp');
928: print $fh $ENV{'form.upfile'};
929: }
930: return $datatoken;
931: }
932:
933: # ================================================= Load uploaded file from tmp
934: # needs $ENV{'form.datatoken'}
935: # sets $ENV{'form.upfile'} to the contents of the file
936:
937: sub load_tmp_file {
938: my $r=shift;
939: my @studentdata=();
940: {
941: my $fh;
942: if ($fh=Apache::File->new($r->dir_config('lonDaemons').
943: '/tmp/'.$ENV{'form.datatoken'}.'.tmp')) {
944: @studentdata=<$fh>;
945: }
946: }
947: $ENV{'form.upfile'}=join('',@studentdata);
948: }
949:
950: # ========================================= Separate uploaded file into records
951: # returns array of records
952: # needs $ENV{'form.upfile'}
953: # needs $ENV{'form.upfiletype'}
954:
955: sub upfile_record_sep {
956: if ($ENV{'form.upfiletype'} eq 'xml') {
957: } else {
958: return split(/\n/,$ENV{'form.upfile'});
959: }
960: }
961:
962: # =============================================== Separate a record into fields
963: # needs $ENV{'form.upfiletype'}
964: # takes $record as arg
965: sub record_sep {
966: my $record=shift;
967: my %components=();
968: if ($ENV{'form.upfiletype'} eq 'xml') {
969: } elsif ($ENV{'form.upfiletype'} eq 'space') {
970: my $i=0;
971: foreach (split(/\s+/,$record)) {
972: my $field=$_;
973: $field=~s/^(\"|\')//;
974: $field=~s/(\"|\')$//;
975: $components{$i}=$field;
976: $i++;
977: }
978: } elsif ($ENV{'form.upfiletype'} eq 'tab') {
979: my $i=0;
980: foreach (split(/\t+/,$record)) {
981: my $field=$_;
982: $field=~s/^(\"|\')//;
983: $field=~s/(\"|\')$//;
984: $components{$i}=$field;
985: $i++;
986: }
987: } else {
988: my @allfields=split(/\,/,$record);
989: my $i=0;
990: my $j;
991: for ($j=0;$j<=$#allfields;$j++) {
992: my $field=$allfields[$j];
993: if ($field=~/^\s*(\"|\')/) {
994: my $delimiter=$1;
995: while (($field!~/$delimiter$/) && ($j<$#allfields)) {
996: $j++;
997: $field.=','.$allfields[$j];
998: }
999: $field=~s/^\s*$delimiter//;
1000: $field=~s/$delimiter\s*$//;
1001: }
1002: $components{$i}=$field;
1003: $i++;
1004: }
1005: }
1006: return %components;
1007: }
1008:
1009: # =============================== HTML code to select file and specify its type
1010: sub upfile_select_html {
1011: return (<<'ENDUPFORM');
1012: <input type="file" name="upfile" size="50">
1013: <br />Type: <select name="upfiletype">
1014: <option value="csv">CSV (comma separated values, spreadsheet)</option>
1015: <option value="space">Space separated</option>
1016: <option value="tab">Tabulator separated</option>
1017: <option value="xml">HTML/XML</option>
1018: </select>
1019: ENDUPFORM
1020: }
1021:
1022: # ===================Prints a table of sample values from each column uploaded
1023: # $r is an Apache Request ref
1024: # $records is an arrayref from &Apache::loncommon::upfile_record_sep
1025: sub csv_print_samples {
1026: my ($r,$records) = @_;
1027: my (%sone,%stwo,%sthree);
1028: %sone=&record_sep($$records[0]);
1029: if (defined($$records[1])) {%stwo=&record_sep($$records[1]);}
1030: if (defined($$records[2])) {%sthree=&record_sep($$records[2]);}
1031:
1032: $r->print('Samples<br /><table border="2"><tr>');
1033: foreach (sort({$a <=> $b} keys(%sone))) { $r->print('<th>Column '.($_+1).'</th>'); }
1034: $r->print('</tr>');
1035: foreach my $hash (\%sone,\%stwo,\%sthree) {
1036: $r->print('<tr>');
1037: foreach (sort({$a <=> $b} keys(%sone))) {
1038: $r->print('<td>');
1039: if (defined($$hash{$_})) { $r->print($$hash{$_}); }
1040: $r->print('</td>');
1041: }
1042: $r->print('</tr>');
1043: }
1044: $r->print('</tr></table><br />'."\n");
1045: }
1046:
1047: # ======Prints a table to create associations between values and table columns
1048: # $r is an Apache Request ref
1049: # $records is an arrayref from &Apache::loncommon::upfile_record_sep
1050: # $d is an array of 2 element arrays (internal name, displayed name)
1051: sub csv_print_select_table {
1052: my ($r,$records,$d) = @_;
1053: my $i=0;my %sone;
1054: %sone=&record_sep($$records[0]);
1055: $r->print('Associate columns with student attributes.'."\n".
1056: '<table border="2"><tr><th>Attribute</th><th>Column</th></tr>'."\n");
1057: foreach (@$d) {
1058: my ($value,$display)=@{ $_ };
1059: $r->print('<tr><td>'.$display.'</td>');
1060:
1061: $r->print('<td><select name=f'.$i.
1.32 matthew 1062: ' onchange="javascript:flip(this.form,'.$i.');">');
1.31 albertel 1063: $r->print('<option value="none"></option>');
1064: foreach (sort({$a <=> $b} keys(%sone))) {
1065: $r->print('<option value="'.$_.'">Column '.($_+1).'</option>');
1066: }
1067: $r->print('</select></td></tr>'."\n");
1068: $i++;
1069: }
1070: $i--;
1071: return $i;
1072: }
1073:
1074: # ===================Prints a table of sample values from the upload and
1075: # can make associate samples to internal names
1076: # $r is an Apache Request ref
1077: # $records is an arrayref from &Apache::loncommon::upfile_record_sep
1078: # $d is an array of 2 element arrays (internal name, displayed name)
1079: sub csv_samples_select_table {
1080: my ($r,$records,$d) = @_;
1081: my %sone; my %stwo; my %sthree;
1082: my $i=0;
1083:
1084: $r->print('<table border=2><tr><th>Field</th><th>Samples</th></tr>');
1085: %sone=&record_sep($$records[0]);
1086: if (defined($$records[1])) {%stwo=&record_sep($$records[1]);}
1087: if (defined($$records[2])) {%sthree=&record_sep($$records[2]);}
1088:
1089: foreach (sort keys %sone) {
1090: $r->print('<tr><td><select name=f'.$i.
1.32 matthew 1091: ' onchange="javascript:flip(this.form,'.$i.');">');
1.31 albertel 1092: foreach (@$d) {
1093: my ($value,$display)=@{ $_ };
1094: $r->print('<option value='.$value.'>'.$display.'</option>');
1095: }
1096: $r->print('</select></td><td>');
1097: if (defined($sone{$_})) { $r->print($sone{$_}."</br>\n"); }
1098: if (defined($stwo{$_})) { $r->print($stwo{$_}."</br>\n"); }
1099: if (defined($sthree{$_})) { $r->print($sthree{$_}."</br>\n"); }
1100: $r->print('</td></tr>');
1101: $i++;
1102: }
1103: $i--;
1104: return($i);
1.25 albertel 1105: }
1.1 albertel 1106: 1;
1107: __END__;
1.17 harris41 1108:
1.35 matthew 1109: =item languageids()
1.17 harris41 1110:
1.35 matthew 1111: returns list of all language ids
1.17 harris41 1112:
1.35 matthew 1113: =item languagedescription()
1.17 harris41 1114:
1.35 matthew 1115: returns description of a specified language id
1.17 harris41 1116:
1.35 matthew 1117: =item copyrightids()
1.17 harris41 1118:
1.35 matthew 1119: returns list of all copyrights
1.17 harris41 1120:
1.35 matthew 1121: =item copyrightdescription()
1.17 harris41 1122:
1.35 matthew 1123: returns description of a specified copyright id
1.17 harris41 1124:
1.35 matthew 1125: =item filecategories()
1.17 harris41 1126:
1.35 matthew 1127: returns list of all file categories
1.17 harris41 1128:
1.35 matthew 1129: =item filecategorytypes()
1.17 harris41 1130:
1.35 matthew 1131: returns list of file types belonging to a given file
1.17 harris41 1132: category
1133:
1.35 matthew 1134: =item fileembstyle()
1.17 harris41 1135:
1.35 matthew 1136: returns embedding style for a specified file type
1.17 harris41 1137:
1.35 matthew 1138: =item filedescription()
1.17 harris41 1139:
1.35 matthew 1140: returns description for a specified file type
1.17 harris41 1141:
1.35 matthew 1142: =item filedescriptionex()
1.17 harris41 1143:
1.35 matthew 1144: returns description for a specified file type with
1.17 harris41 1145: extra formatting
1146:
1.35 matthew 1147: =item get_previous_attempt()
1.17 harris41 1148:
1.35 matthew 1149: return string with previous attempt on problem
1.17 harris41 1150:
1.35 matthew 1151: =item get_student_view()
1.17 harris41 1152:
1.35 matthew 1153: show a snapshot of what student was looking at
1.17 harris41 1154:
1.35 matthew 1155: =item get_student_answers()
1.17 harris41 1156:
1.35 matthew 1157: show a snapshot of how student was answering problem
1.17 harris41 1158:
1.35 matthew 1159: =item get_unprocessed_cgi()
1.17 harris41 1160:
1.35 matthew 1161: get unparsed CGI parameters
1.17 harris41 1162:
1.35 matthew 1163: =item cacheheader()
1.17 harris41 1164:
1.35 matthew 1165: returns cache-controlling header code
1.17 harris41 1166:
1.35 matthew 1167: =item nocache()
1.17 harris41 1168:
1.35 matthew 1169: specifies header code to not have cache
1.25 albertel 1170:
1.35 matthew 1171: =item add_to_env($name,$value)
1.25 albertel 1172:
1.35 matthew 1173: adds $name to the %ENV hash with value
1.25 albertel 1174: $value, if $name already exists, the entry is converted to an array
1175: reference and $value is added to the array.
1.17 harris41 1176:
1177: =back
1178:
1179: =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