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