Annotation of loncom/interface/loncommon.pm, revision 1.39
1.10 albertel 1: # The LearningOnline Network with CAPA
1.1 albertel 2: # a pile of common routines
1.10 albertel 3: #
1.39 ! matthew 4: # $Id: loncommon.pm,v 1.38 2002/06/24 19:06:05 albertel Exp $
1.10 albertel 5: #
6: # Copyright Michigan State University Board of Trustees
7: #
8: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
9: #
10: # LON-CAPA is free software; you can redistribute it and/or modify
11: # it under the terms of the GNU General Public License as published by
12: # the Free Software Foundation; either version 2 of the License, or
13: # (at your option) any later version.
14: #
15: # LON-CAPA is distributed in the hope that it will be useful,
16: # but WITHOUT ANY WARRANTY; without even the implied warranty of
17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18: # GNU General Public License for more details.
19: #
20: # You should have received a copy of the GNU General Public License
21: # along with LON-CAPA; if not, write to the Free Software
22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
23: #
24: # /home/httpd/html/adm/gpl.txt
25: #
26: # http://www.lon-capa.org/
27: #
1.12 harris41 28: # YEAR=2001
29: # 2/13-12/7 Guy Albertelli
1.17 harris41 30: # 12/11,12/12,12/17 Scott Harrison
1.18 www 31: # 12/21 Gerd Kortemeyer
1.20 www 32: # 12/21 Scott Harrison
1.22 www 33: # 12/25,12/28 Gerd Kortemeyer
1.23 www 34: # YEAR=2002
35: # 1/4 Gerd Kortemeyer
1.1 albertel 36:
37: # Makes a table out of the previous attempts
1.2 albertel 38: # Inputs result_from_symbread, user, domain, course_id
1.16 harris41 39: # Reads in non-network-related .tab files
1.1 albertel 40:
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.39 ! matthew 88: my %category_extensions;
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;
1.39 ! matthew 149: my ($extension,$category)=(split(/\s+/,$_,2));
! 150: push @{$category_extensions{lc($category)}},$extension;
1.16 harris41 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:
1.39 ! matthew 218: =back
! 219:
1.36 matthew 220: Below is an example of such a hash. Only the 'text', 'default', and
221: 'select2' keys must appear as stated. keys(%menu) are the possible
222: values for the first select menu. The text that coincides with the
1.39 ! matthew 223: first menu value is given in $menu{$choice1}->{'text'}. The values
1.36 matthew 224: and text for the second menu are given in the hash pointed to by
225: $menu{$choice1}->{'select2'}.
226:
1.39 ! matthew 227: my %menu = ( A1 => { text =>"Choice A1" ,
1.36 matthew 228: default => "B3",
229: select2 => {
230: B1 => "Choice B1",
231: B2 => "Choice B2",
232: B3 => "Choice B3",
233: B4 => "Choice B4"
234: }
235: },
236: A2 => { text =>"Choice A2" ,
237: default => "C2",
238: select2 => {
239: C1 => "Choice C1",
240: C2 => "Choice C2",
241: C3 => "Choice C3"
242: }
243: },
244: A3 => { text =>"Choice A3" ,
245: default => "D6",
246: select2 => {
247: D1 => "Choice D1",
248: D2 => "Choice D2",
249: D3 => "Choice D3",
250: D4 => "Choice D4",
251: D5 => "Choice D5",
252: D6 => "Choice D6",
253: D7 => "Choice D7"
254: }
255: }
256: );
257:
258: =back
259:
260: =cut
261:
262: # ------------------------------------------------
263:
264: sub linked_select_forms {
265: my ($formname,
266: $middletext,
267: $firstdefault,
268: $firstselectname,
269: $secondselectname,
270: $hashref
271: ) = @_;
272: my $second = "document.$formname.$secondselectname";
273: my $first = "document.$formname.$firstselectname";
274: # output the javascript to do the changing
275: my $result = '';
276: $result.="<script>\n";
277: $result.="var select2data = new Object();\n";
278: $" = '","';
279: my $debug = '';
280: foreach my $s1 (sort(keys(%$hashref))) {
281: $result.="select2data.d_$s1 = new Object();\n";
282: $result.="select2data.d_$s1.def = new String('".
283: $hashref->{$s1}->{'default'}."');\n";
284: $result.="select2data.d_$s1.values = new Array(";
285: my @s2values = sort(keys( %{ $hashref->{$s1}->{'select2'} } ));
286: $result.="\"@s2values\");\n";
287: $result.="select2data.d_$s1.texts = new Array(";
288: my @s2texts;
289: foreach my $value (@s2values) {
290: push @s2texts, $hashref->{$s1}->{'select2'}->{$value};
291: }
292: $result.="\"@s2texts\");\n";
293: }
294: $"=' ';
295: $result.= <<"END";
296:
297: function select1_changed() {
298: // Determine new choice
299: var newvalue = "d_" + $first.value;
300: // update select2
301: var values = select2data[newvalue].values;
302: var texts = select2data[newvalue].texts;
303: var select2def = select2data[newvalue].def;
304: var i;
305: // out with the old
306: for (i = 0; i < $second.options.length; i++) {
307: $second.options[i] = null;
308: }
309: // in with the nuclear
310: for (i=0;i<values.length; i++) {
311: $second.options[i] = new Option(values[i]);
312: $second.options[i].text = texts[i];
313: if (values[i] == select2def) {
314: $second.options[i].selected = true;
315: }
316: }
317: }
318: </script>
319: END
320: # output the initial values for the selection lists
321: $result .= "<select size=\"1\" name=\"$firstselectname\" onchange=\"select1_changed()\">\n";
322: foreach my $value (sort(keys(%$hashref))) {
323: $result.=" <option value=\"$value\" ";
324: $result.=" selected=\"true\" " if ($value eq $firstdefault);
325: $result.=">$hashref->{$value}->{'text'}</option>\n";
326: }
327: $result .= "</select>\n";
328: my %select2 = %{$hashref->{$firstdefault}->{'select2'}};
329: $result .= $middletext;
330: $result .= "<select size=\"1\" name=\"$secondselectname\">\n";
331: my $seconddefault = $hashref->{$firstdefault}->{'default'};
332: foreach my $value (sort(keys(%select2))) {
333: $result.=" <option value=\"$value\" ";
334: $result.=" selected=\"true\" " if ($value eq $seconddefault);
335: $result.=">$select2{$value}</option>\n";
336: }
337: $result .= "</select>\n";
338: # return $debug;
339: return $result;
340: } # end of sub linked_select_forms {
341:
1.33 matthew 342: ###############################################################
1.37 matthew 343:
344: =item csv_translate($text)
345:
346: Translate $text to allow it to be output as a 'comma seperated values'
347: format.
348:
349: =cut
350:
351: sub csv_translate {
352: my $text = shift;
353: $text =~ s/\"/\"\"/g;
354: $text =~ s/\n//g;
355: return $text;
356: }
357:
358: ###############################################################
359:
360: ###############################################################
1.33 matthew 361: ## Home server <option> list generating code ##
362: ###############################################################
1.35 matthew 363: #-------------------------------------------
364:
365: =item get_domains()
366:
367: Returns an array containing each of the domains listed in the hosts.tab
368: file.
369:
370: =cut
371:
372: #-------------------------------------------
1.34 matthew 373: sub get_domains {
374: # The code below was stolen from "The Perl Cookbook", p 102, 1st ed.
375: my @domains;
376: my %seen;
377: foreach (sort values(%Apache::lonnet::hostdom)) {
378: push (@domains,$_) unless $seen{$_}++;
379: }
380: return @domains;
381: }
382:
1.35 matthew 383: #-------------------------------------------
384:
385: =item select_dom_form($defdom,$name)
386:
387: Returns a string containing a <select name='$name' size='1'> form to
388: allow a user to select the domain to preform an operation in.
389: See loncreateuser.pm for an example invocation and use.
390:
391: =cut
392:
393: #-------------------------------------------
1.34 matthew 394: sub select_dom_form {
395: my ($defdom,$name) = @_;
396: my @domains = get_domains();
397: my $selectdomain = "<select name=\"$name\" size=\"1\">\n";
398: foreach (@domains) {
399: $selectdomain.="<option value=\"$_\" ".
400: ($_ eq $defdom ? 'selected' : '').
401: ">$_</option>\n";
402: }
403: $selectdomain.="</select>";
404: return $selectdomain;
405: }
406:
1.35 matthew 407: #-------------------------------------------
408:
409: =item get_home_servers($domain)
410:
411: Returns a hash which contains keys like '103l3' and values like
412: 'kirk.lite.msu.edu'. All of the keys will be for machines in the
413: given $domain.
414:
415: =cut
416:
417: #-------------------------------------------
1.33 matthew 418: sub get_home_servers {
419: my $domain = shift;
420: my %home_servers;
421: foreach (keys(%Apache::lonnet::libserv)) {
422: if ($Apache::lonnet::hostdom{$_} eq $domain) {
423: $home_servers{$_} = $Apache::lonnet::hostname{$_};
424: }
425: }
426: return %home_servers;
427: }
428:
1.35 matthew 429: #-------------------------------------------
430:
431: =item home_server_option_list($domain)
432:
433: returns a string which contains an <option> list to be used in a
434: <select> form input. See loncreateuser.pm for an example.
435:
436: =cut
437:
438: #-------------------------------------------
1.33 matthew 439: sub home_server_option_list {
440: my $domain = shift;
441: my %servers = &get_home_servers($domain);
442: my $result = '';
443: foreach (sort keys(%servers)) {
444: $result.=
445: '<option value="'.$_.'">'.$_.' '.$servers{$_}."</option>\n";
446: }
447: return $result;
448: }
449: ###############################################################
450: ## End of home server <option> list generating code ##
451: ###############################################################
1.32 matthew 452:
453: ###############################################################
454: ## Authentication changing form generation subroutines ##
455: ###############################################################
456: ##
457: ## All of the authform_xxxxxxx subroutines take their inputs in a
458: ## hash, and have reasonable default values.
459: ##
460: ## formname = the name given in the <form> tag.
1.35 matthew 461: #-------------------------------------------
462:
463: =item authform_xxxxxx
464:
465: The authform_xxxxxx subroutines provide javascript and html forms which
466: handle some of the conveniences required for authentication forms.
467: This is not an optimal method, but it works.
468:
469: See loncreateuser.pm for invocation and use examples.
470:
471: =over 4
472:
473: =item authform_header
474:
475: =item authform_authorwarning
476:
477: =item authform_nochange
478:
479: =item authform_kerberos
480:
481: =item authform_internal
482:
483: =item authform_filesystem
484:
485: =back
486:
487: =cut
488:
489: #-------------------------------------------
1.32 matthew 490: sub authform_header{
491: my %in = (
492: formname => 'cu',
493: kerb_def_dom => 'MSU.EDU',
494: @_,
495: );
496: $in{'formname'} = 'document.' . $in{'formname'};
497: my $result='';
498: $result.=<<"END";
499: var current = new Object();
500: current.radiovalue = 'nochange';
501: current.argfield = null;
502:
503: function changed_radio(choice,currentform) {
504: var choicearg = choice + 'arg';
505: // If a radio button in changed, we need to change the argfield
506: if (current.radiovalue != choice) {
507: current.radiovalue = choice;
508: if (current.argfield != null) {
509: currentform.elements[current.argfield].value = '';
510: }
511: if (choice == 'nochange') {
512: current.argfield = null;
513: } else {
514: current.argfield = choicearg;
515: switch(choice) {
516: case 'krb':
517: currentform.elements[current.argfield].value =
518: "$in{'kerb_def_dom'}";
519: break;
520: default:
521: break;
522: }
523: }
524: }
525: return;
526: }
1.22 www 527:
1.32 matthew 528: function changed_text(choice,currentform) {
529: var choicearg = choice + 'arg';
530: if (currentform.elements[choicearg].value !='') {
531: switch (choice) {
532: case 'krb': currentform.elements[choicearg].value =
533: currentform.elements[choicearg].value.toUpperCase();
534: break;
535: default:
536: }
537: // clear old field
538: if ((current.argfield != choicearg) && (current.argfield != null)) {
539: currentform.elements[current.argfield].value = '';
540: }
541: current.argfield = choicearg;
542: }
543: set_auth_radio_buttons(choice,currentform);
544: return;
1.20 www 545: }
1.32 matthew 546:
547: function set_auth_radio_buttons(newvalue,currentform) {
548: var i=0;
549: while (i < currentform.login.length) {
550: if (currentform.login[i].value == newvalue) { break; }
551: i++;
552: }
553: if (i == currentform.login.length) {
554: return;
555: }
556: current.radiovalue = newvalue;
557: currentform.login[i].checked = true;
558: return;
559: }
560: END
561: return $result;
562: }
563:
564: sub authform_authorwarning{
565: my $result='';
566: $result=<<"END";
567: <i>As a general rule, only authors or co-authors should be filesystem
568: authenticated (which allows access to the server filesystem).</i>
569: END
570: return $result;
571: }
572:
573: sub authform_nochange{
574: my %in = (
575: formname => 'document.cu',
576: kerb_def_dom => 'MSU.EDU',
577: @_,
578: );
579: my $result='';
580: $result.=<<"END";
581: <input type="radio" name="login" value="nochange" checked="checked"
582: onclick="javascript:changed_radio('nochange',$in{'formname'});">
583: Do not change login data
584: END
585: return $result;
586: }
587:
588: sub authform_kerberos{
589: my %in = (
590: formname => 'document.cu',
591: kerb_def_dom => 'MSU.EDU',
592: @_,
593: );
594: my $result='';
595: $result.=<<"END";
596: <input type="radio" name="login" value="krb"
597: onclick="javascript:changed_radio('krb',$in{'formname'});"
598: onchange="javascript:changed_radio('krb',$in{'formname'});">
599: Kerberos authenticated with domain
600: <input type="text" size="10" name="krbarg" value=""
601: onchange="javascript:changed_text('krb',$in{'formname'});">
602: END
603: return $result;
604: }
605:
606: sub authform_internal{
607: my %args = (
608: formname => 'document.cu',
609: kerb_def_dom => 'MSU.EDU',
610: @_,
611: );
612: my $result='';
613: $result.=<<"END";
614: <input type="radio" name="login" value="int"
615: onchange="javascript:changed_radio('int',$args{'formname'});"
616: onclick="javascript:changed_radio('int',$args{'formname'});">
617: Internally authenticated (with initial password
618: <input type="text" size="10" name="intarg" value=""
619: onchange="javascript:changed_text('int',$args{'formname'});">
620: END
621: return $result;
622: }
623:
624: sub authform_local{
625: my %in = (
626: formname => 'document.cu',
627: kerb_def_dom => 'MSU.EDU',
628: @_,
629: );
630: my $result='';
631: $result.=<<"END";
632: <input type="radio" name="login" value="loc"
633: onchange="javascript:changed_radio('loc',$in{'formname'});"
634: onclick="javascript:changed_radio('loc',$in{'formname'});">
635: Local Authentication with argument
636: <input type="text" size="10" name="locarg" value=""
637: onchange="javascript:changed_text('loc',$in{'formname'});">
638: END
639: return $result;
640: }
641:
642: sub authform_filesystem{
643: my %in = (
644: formname => 'document.cu',
645: kerb_def_dom => 'MSU.EDU',
646: @_,
647: );
648: my $result='';
649: $result.=<<"END";
650: <input type="radio" name="login" value="fsys"
651: onchange="javascript:changed_radio('fsys',$in{'formname'});"
652: onclick="javascript:changed_radio('fsys',$in{'formname'});">
653: Filesystem authenticated (with initial password
654: <input type="text" size="10" name="fsysarg" value=""
655: onchange="javascript:changed_text('fsys',$in{'formname'});">
656: END
657: return $result;
658: }
659:
660: ###############################################################
661: ## End Authentication changing form generation functions ##
662: ###############################################################
663:
1.20 www 664:
665:
666: # ---------------------------------------------------------- Is this a keyword?
667:
668: sub keyword {
669: my $newword=shift;
670: $newword=~s/\W//g;
671: $newword=~tr/A-Z/a-z/;
672: my $tindex=$theindex{$newword};
673: if ($tindex) {
674: if ($thecount[$tindex]>$theavecount) {
675: return 1;
676: }
677: }
678: return 0;
679: }
680: # -------------------------------------------------------- Return related words
681:
682: sub related {
683: my $newword=shift;
684: $newword=~s/\W//g;
685: $newword=~tr/A-Z/a-z/;
686: my $tindex=$theindex{$newword};
687: if ($tindex) {
688: my %found=();
689: foreach (split(/\,/,$therelated[$tindex])) {
690: # - Related word found
691: my ($ridx,$rcount)=split(/\:/,$_);
692: # - Direct relation index
693: my $directrel=$rcount/$thecount[$tindex];
694: if ($directrel>$thethreshold) {
695: foreach (split(/\,/,$therelated[$ridx])) {
696: my ($rridx,$rrcount)=split(/\:/,$_);
697: if ($rridx==$tindex) {
698: # - Determine reverse relation index
699: my $revrel=$rrcount/$thecount[$ridx];
700: # - Calculate full index
701: $found{$ridx}=$directrel*$revrel;
702: if ($found{$ridx}>$thethreshold) {
703: foreach (split(/\,/,$therelated[$ridx])) {
704: my ($rrridx,$rrrcount)=split(/\:/,$_);
705: unless ($found{$rrridx}) {
706: my $revrevrel=$rrrcount/$thecount[$ridx];
707: if (
708: $directrel*$revrel*$revrevrel>$thethreshold
709: ) {
710: $found{$rrridx}=
711: $directrel*$revrel*$revrevrel;
712: }
713: }
714: }
715: }
716: }
717: }
718: }
719: }
720: }
721: return ();
1.14 harris41 722: }
723:
724: # ---------------------------------------------------------------- Language IDs
725: sub languageids {
1.16 harris41 726: return sort(keys(%language));
1.14 harris41 727: }
728:
729: # -------------------------------------------------------- Language Description
730: sub languagedescription {
1.16 harris41 731: return $language{shift(@_)};
1.14 harris41 732: }
733:
734: # --------------------------------------------------------------- Copyright IDs
735: sub copyrightids {
1.16 harris41 736: return sort(keys(%cprtag));
1.14 harris41 737: }
738:
739: # ------------------------------------------------------- Copyright Description
740: sub copyrightdescription {
1.16 harris41 741: return $cprtag{shift(@_)};
1.14 harris41 742: }
743:
744: # ------------------------------------------------------------- File Categories
745: sub filecategories {
1.39 ! matthew 746: return sort(keys(%category_extensions));
1.15 harris41 747: }
1.14 harris41 748:
1.17 harris41 749: # -------------------------------------- File Types within a specified category
1.15 harris41 750: sub filecategorytypes {
1.39 ! matthew 751: return @{$category_extensions{lc($_[0])}};
1.14 harris41 752: }
753:
754: # ------------------------------------------------------------------ File Types
755: sub fileextensions {
1.16 harris41 756: return sort(keys(%fe));
1.14 harris41 757: }
758:
759: # ------------------------------------------------------------- Embedding Style
760: sub fileembstyle {
1.16 harris41 761: return $fe{lc(shift(@_))};
1.14 harris41 762: }
763:
764: # ------------------------------------------------------------ Description Text
765: sub filedescription {
1.16 harris41 766: return $fd{lc(shift(@_))};
767: }
768:
769: # ------------------------------------------------------------ Description Text
770: sub filedescriptionex {
771: my $ex=shift;
772: return '.'.$ex.' '.$fd{lc($ex)};
1.12 harris41 773: }
1.1 albertel 774:
775: sub get_previous_attempt {
1.2 albertel 776: my ($symb,$username,$domain,$course)=@_;
1.1 albertel 777: my $prevattempts='';
778: if ($symb) {
1.3 albertel 779: my (%returnhash)=
780: &Apache::lonnet::restore($symb,$course,$domain,$username);
1.1 albertel 781: if ($returnhash{'version'}) {
782: my %lasthash=();
783: my $version;
784: for ($version=1;$version<=$returnhash{'version'};$version++) {
1.19 harris41 785: foreach (sort(split(/\:/,$returnhash{$version.':keys'}))) {
1.1 albertel 786: $lasthash{$_}=$returnhash{$version.':'.$_};
1.19 harris41 787: }
1.1 albertel 788: }
789: $prevattempts='<table border=2></tr><th>History</th>';
1.16 harris41 790: foreach (sort(keys %lasthash)) {
1.31 albertel 791: my ($ign,@parts) = split(/\./,$_);
1.38 albertel 792: if ($#parts > 0) {
1.31 albertel 793: my $data=$parts[-1];
794: pop(@parts);
795: $prevattempts.='<th>Part '.join('.',@parts).'<br />'.$data.'</th>';
796: } else {
1.38 albertel 797: if ($#parts == 0) {
798: $prevattempts.='<th>'.$parts[0].'</th>';
799: } else {
800: $prevattempts.='<th>'.$ign.'</th>';
801: }
1.31 albertel 802: }
1.16 harris41 803: }
1.1 albertel 804: for ($version=1;$version<=$returnhash{'version'};$version++) {
805: $prevattempts.='</tr><tr><th>Attempt '.$version.'</th>';
1.16 harris41 806: foreach (sort(keys %lasthash)) {
1.5 albertel 807: my $value;
808: if ($_ =~ /timestamp/) {
809: $value=scalar(localtime($returnhash{$version.':'.$_}));
810: } else {
811: $value=$returnhash{$version.':'.$_};
812: }
813: $prevattempts.='<td>'.$value.'</td>';
1.16 harris41 814: }
1.1 albertel 815: }
816: $prevattempts.='</tr><tr><th>Current</th>';
1.16 harris41 817: foreach (sort(keys %lasthash)) {
1.5 albertel 818: my $value;
819: if ($_ =~ /timestamp/) {
820: $value=scalar(localtime($lasthash{$_}));
821: } else {
822: $value=$lasthash{$_};
823: }
824: $prevattempts.='<td>'.$value.'</td>';
1.16 harris41 825: }
1.1 albertel 826: $prevattempts.='</tr></table>';
827: } else {
828: $prevattempts='Nothing submitted - no attempts.';
829: }
830: } else {
831: $prevattempts='No data.';
832: }
1.10 albertel 833: }
834:
835: sub get_student_view {
836: my ($symb,$username,$domain,$courseid) = @_;
837: my ($map,$id,$feedurl) = split(/___/,$symb);
838: my (%old,%moreenv);
839: my @elements=('symb','courseid','domain','username');
840: foreach my $element (@elements) {
841: $old{$element}=$ENV{'form.grade_'.$element};
842: $moreenv{'form.grade_'.$element}=eval '$'.$element #'
843: }
1.11 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;
858: }
859:
860: sub get_student_answers {
861: my ($symb,$username,$domain,$courseid) = @_;
862: my ($map,$id,$feedurl) = split(/___/,$symb);
863: my (%old,%moreenv);
864: my @elements=('symb','courseid','domain','username');
865: foreach my $element (@elements) {
866: $old{$element}=$ENV{'form.grade_'.$element};
867: $moreenv{'form.grade_'.$element}=eval '$'.$element #'
868: }
869: $moreenv{'form.grade_target'}='answer';
1.10 albertel 870: &Apache::lonnet::appenv(%moreenv);
871: my $userview=&Apache::lonnet::ssi('/res/'.$feedurl);
872: &Apache::lonnet::delenv('form.grade_');
873: foreach my $element (@elements) {
874: $ENV{'form.grade_'.$element}=$old{$element};
875: }
876: return $userview;
1.1 albertel 877: }
1.37 matthew 878:
879: ###############################################
880:
881: ###############################################
1.1 albertel 882:
1.6 albertel 883: sub get_unprocessed_cgi {
1.25 albertel 884: my ($query,$possible_names)= @_;
1.26 matthew 885: # $Apache::lonxml::debug=1;
1.16 harris41 886: foreach (split(/&/,$query)) {
1.6 albertel 887: my ($name, $value) = split(/=/,$_);
1.25 albertel 888: $name = &Apache::lonnet::unescape($name);
889: if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) {
890: $value =~ tr/+/ /;
891: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
892: &Apache::lonxml::debug("Seting :$name: to :$value:");
1.30 albertel 893: unless (defined($ENV{'form.'.$name})) { &add_to_env('form.'.$name,$value) };
1.25 albertel 894: }
1.16 harris41 895: }
1.6 albertel 896: }
897:
1.7 albertel 898: sub cacheheader {
1.23 www 899: unless ($ENV{'request.method'} eq 'GET') { return ''; }
1.8 albertel 900: my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
1.7 albertel 901: my $output .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" />
902: <meta HTTP-EQUIV="Cache-control" CONTENT="no-cache" />
903: <meta HTTP-EQUIV="Pragma" CONTENT="no-cache" />';
904: return $output;
905: }
906:
1.9 albertel 907: sub no_cache {
908: my ($r) = @_;
1.23 www 909: unless ($ENV{'request.method'} eq 'GET') { return ''; }
1.24 albertel 910: #my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
1.9 albertel 911: $r->no_cache(1);
912: $r->header_out("Pragma" => "no-cache");
1.24 albertel 913: #$r->header_out("Expires" => $date);
1.9 albertel 914: }
1.25 albertel 915:
916: sub add_to_env {
917: my ($name,$value)=@_;
1.28 albertel 918: if (defined($ENV{$name})) {
1.27 albertel 919: if (ref($ENV{$name})) {
1.25 albertel 920: #already have multiple values
921: push(@{ $ENV{$name} },$value);
922: } else {
923: #first time seeing multiple values, convert hash entry to an arrayref
924: my $first=$ENV{$name};
925: undef($ENV{$name});
926: push(@{ $ENV{$name} },$first,$value);
927: }
928: } else {
929: $ENV{$name}=$value;
930: }
1.31 albertel 931: }
932:
1.38 albertel 933: =pod
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