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