Annotation of loncom/interface/loncommon.pm, revision 1.37
1.10 albertel 1: # The LearningOnline Network with CAPA
1.1 albertel 2: # a pile of common routines
1.10 albertel 3: #
1.37 ! matthew 4: # $Id: loncommon.pm,v 1.36 2002/04/26 18:57:27 matthew Exp $
1.10 albertel 5: #
6: # Copyright Michigan State University Board of Trustees
7: #
8: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
9: #
10: # LON-CAPA is free software; you can redistribute it and/or modify
11: # it under the terms of the GNU General Public License as published by
12: # the Free Software Foundation; either version 2 of the License, or
13: # (at your option) any later version.
14: #
15: # LON-CAPA is distributed in the hope that it will be useful,
16: # but WITHOUT ANY WARRANTY; without even the implied warranty of
17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18: # GNU General Public License for more details.
19: #
20: # You should have received a copy of the GNU General Public License
21: # along with LON-CAPA; if not, write to the Free Software
22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
23: #
24: # /home/httpd/html/adm/gpl.txt
25: #
26: # http://www.lon-capa.org/
27: #
1.12 harris41 28: # YEAR=2001
29: # 2/13-12/7 Guy Albertelli
1.17 harris41 30: # 12/11,12/12,12/17 Scott Harrison
1.18 www 31: # 12/21 Gerd Kortemeyer
1.20 www 32: # 12/21 Scott Harrison
1.22 www 33: # 12/25,12/28 Gerd Kortemeyer
1.23 www 34: # YEAR=2002
35: # 1/4 Gerd Kortemeyer
1.1 albertel 36:
37: # Makes a table out of the previous attempts
1.2 albertel 38: # Inputs result_from_symbread, user, domain, course_id
1.16 harris41 39: # Reads in non-network-related .tab files
1.1 albertel 40:
1.35 matthew 41: # POD header:
42:
43: =head1 NAME
44:
45: Apache::loncommon - pile of common routines
46:
47: =head1 SYNOPSIS
48:
49: Referenced by other mod_perl Apache modules.
50:
51: Invocation:
52: &Apache::loncommon::SUBROUTINENAME(ARGUMENTS);
53:
54: =head1 INTRODUCTION
55:
56: Common collection of used subroutines. This collection helps remove
57: redundancy from other modules and increase efficiency of memory usage.
58:
59: Current things done:
60:
61: Makes a table out of the previous homework attempts
62: Inputs result_from_symbread, user, domain, course_id
63: Reads in non-network-related .tab files
64:
65: This is part of the LearningOnline Network with CAPA project
66: described at http://www.lon-capa.org.
67:
68: =head2 Subroutines
69:
70: =over 4
71:
72: =cut
73:
74: # End of POD header
1.1 albertel 75: package Apache::loncommon;
76:
77: use strict;
1.22 www 78: use Apache::lonnet();
1.8 albertel 79: use POSIX qw(strftime);
1.1 albertel 80: use Apache::Constants qw(:common);
81: use Apache::lonmsg();
1.12 harris41 82:
1.22 www 83: my $readit;
84:
1.20 www 85: # ----------------------------------------------- Filetypes/Languages/Copyright
1.12 harris41 86: my %language;
87: my %cprtag;
88: my %fe; my %fd;
1.15 harris41 89: my %fc;
1.12 harris41 90:
1.20 www 91: # -------------------------------------------------------------- Thesaurus data
1.21 www 92: my @therelated;
93: my @theword;
94: my @thecount;
95: my %theindex;
96: my $thetotalcount;
1.20 www 97: my $thefuzzy=2;
98: my $thethreshold=0.1/$thefuzzy;
99: my $theavecount;
100:
1.12 harris41 101: # ----------------------------------------------------------------------- BEGIN
1.35 matthew 102: =item BEGIN()
103:
104: Initialize values from language.tab, copyright.tab, filetypes.tab,
105: and filecategories.tab.
106:
107: =cut
108: # ----------------------------------------------------------------------- BEGIN
109:
1.18 www 110: BEGIN {
1.22 www 111:
112: unless ($readit) {
1.12 harris41 113: # ------------------------------------------------------------------- languages
114: {
115: my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
116: '/language.tab');
1.16 harris41 117: if ($fh) {
118: while (<$fh>) {
119: next if /^\#/;
120: chomp;
121: my ($key,$val)=(split(/\s+/,$_,2));
122: $language{$key}=$val;
123: }
1.12 harris41 124: }
125: }
126: # ------------------------------------------------------------------ copyrights
127: {
1.16 harris41 128: my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonIncludes'}.
129: '/copyright.tab');
130: if ($fh) {
131: while (<$fh>) {
132: next if /^\#/;
133: chomp;
134: my ($key,$val)=(split(/\s+/,$_,2));
135: $cprtag{$key}=$val;
136: }
1.12 harris41 137: }
138: }
1.15 harris41 139: # ------------------------------------------------------------- file categories
140: {
141: my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
1.16 harris41 142: '/filecategories.tab');
143: if ($fh) {
144: while (<$fh>) {
145: next if /^\#/;
146: chomp;
147: my ($key,$val)=(split(/\s+/,$_,2));
148: push @{$fc{$key}},$val;
149: }
1.15 harris41 150: }
151: }
1.12 harris41 152: # ------------------------------------------------------------------ file types
153: {
1.16 harris41 154: my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
155: '/filetypes.tab');
156: if ($fh) {
157: while (<$fh>) {
158: next if (/^\#/);
159: chomp;
160: my ($ending,$emb,$descr)=split(/\s+/,$_,3);
161: if ($descr ne '') {
162: $fe{$ending}=lc($emb);
163: $fd{$ending}=$descr;
164: }
1.12 harris41 165: }
166: }
167: }
1.20 www 168: # -------------------------------------------------------------- Thesaurus data
169: {
170: my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
171: '/thesaurus.dat');
172: if ($fh) {
173: while (<$fh>) {
174: my ($tword,$tindex,$tcount,$trelated)=split(/\@/,$_);
175: $theindex{$tword}=$tindex;
176: $theword[$tindex]=$tword;
177: $thecount[$tindex]=$tcount;
178: $thetotalcount+=$tcount;
179: $therelated[$tindex]=$trelated;
180: }
181: }
182: $theavecount=$thetotalcount/$#thecount;
183: }
1.22 www 184: &Apache::lonnet::logthis(
185: "<font color=yellow>INFO: Read file types and thesaurus</font>");
186: $readit=1;
187: }
1.32 matthew 188:
189: }
190: # ============================================================= END BEGIN BLOCK
1.36 matthew 191:
192: =item linked_select_forms(...)
193:
194: linked_select_forms returns a string containing a <script></script> block
195: and html for two <select> menus. The select menus will be linked in that
196: changing the value of the first menu will result in new values being placed
197: in the second menu. The values in the select menu will appear in alphabetical
198: order.
199:
200: linked_select_forms takes the following ordered inputs:
201:
202: =over 4
203:
204: =item $formname, the name of the <form> tag
205:
206: =item $middletext, the text which appears between the <select> tags
207:
208: =item $firstdefault, the default value for the first menu
209:
210: =item $firstselectname, the name of the first <select> tag
211:
212: =item $secondselectname, the name of the second <select> tag
213:
214: =item $hashref, a reference to a hash containing the data for the menus.
215:
216: Below is an example of such a hash. Only the 'text', 'default', and
217: 'select2' keys must appear as stated. keys(%menu) are the possible
218: values for the first select menu. The text that coincides with the
219: first menu values is given in $menu{$choice1}->{'text'}. The values
220: and text for the second menu are given in the hash pointed to by
221: $menu{$choice1}->{'select2'}.
222:
223: my %menu = ( A1 => { text =>"Choice A1" ,
224: default => "B3",
225: select2 => {
226: B1 => "Choice B1",
227: B2 => "Choice B2",
228: B3 => "Choice B3",
229: B4 => "Choice B4"
230: }
231: },
232: A2 => { text =>"Choice A2" ,
233: default => "C2",
234: select2 => {
235: C1 => "Choice C1",
236: C2 => "Choice C2",
237: C3 => "Choice C3"
238: }
239: },
240: A3 => { text =>"Choice A3" ,
241: default => "D6",
242: select2 => {
243: D1 => "Choice D1",
244: D2 => "Choice D2",
245: D3 => "Choice D3",
246: D4 => "Choice D4",
247: D5 => "Choice D5",
248: D6 => "Choice D6",
249: D7 => "Choice D7"
250: }
251: }
252: );
253:
254: =back
255:
256: =cut
257:
258: # ------------------------------------------------
259:
260: sub linked_select_forms {
261: my ($formname,
262: $middletext,
263: $firstdefault,
264: $firstselectname,
265: $secondselectname,
266: $hashref
267: ) = @_;
268: my $second = "document.$formname.$secondselectname";
269: my $first = "document.$formname.$firstselectname";
270: # output the javascript to do the changing
271: my $result = '';
272: $result.="<script>\n";
273: $result.="var select2data = new Object();\n";
274: $" = '","';
275: my $debug = '';
276: foreach my $s1 (sort(keys(%$hashref))) {
277: $result.="select2data.d_$s1 = new Object();\n";
278: $result.="select2data.d_$s1.def = new String('".
279: $hashref->{$s1}->{'default'}."');\n";
280: $result.="select2data.d_$s1.values = new Array(";
281: my @s2values = sort(keys( %{ $hashref->{$s1}->{'select2'} } ));
282: $result.="\"@s2values\");\n";
283: $result.="select2data.d_$s1.texts = new Array(";
284: my @s2texts;
285: foreach my $value (@s2values) {
286: push @s2texts, $hashref->{$s1}->{'select2'}->{$value};
287: }
288: $result.="\"@s2texts\");\n";
289: }
290: $"=' ';
291: $result.= <<"END";
292:
293: function select1_changed() {
294: // Determine new choice
295: var newvalue = "d_" + $first.value;
296: // update select2
297: var values = select2data[newvalue].values;
298: var texts = select2data[newvalue].texts;
299: var select2def = select2data[newvalue].def;
300: var i;
301: // out with the old
302: for (i = 0; i < $second.options.length; i++) {
303: $second.options[i] = null;
304: }
305: // in with the nuclear
306: for (i=0;i<values.length; i++) {
307: $second.options[i] = new Option(values[i]);
308: $second.options[i].text = texts[i];
309: if (values[i] == select2def) {
310: $second.options[i].selected = true;
311: }
312: }
313: }
314: </script>
315: END
316: # output the initial values for the selection lists
317: $result .= "<select size=\"1\" name=\"$firstselectname\" onchange=\"select1_changed()\">\n";
318: foreach my $value (sort(keys(%$hashref))) {
319: $result.=" <option value=\"$value\" ";
320: $result.=" selected=\"true\" " if ($value eq $firstdefault);
321: $result.=">$hashref->{$value}->{'text'}</option>\n";
322: }
323: $result .= "</select>\n";
324: my %select2 = %{$hashref->{$firstdefault}->{'select2'}};
325: $result .= $middletext;
326: $result .= "<select size=\"1\" name=\"$secondselectname\">\n";
327: my $seconddefault = $hashref->{$firstdefault}->{'default'};
328: foreach my $value (sort(keys(%select2))) {
329: $result.=" <option value=\"$value\" ";
330: $result.=" selected=\"true\" " if ($value eq $seconddefault);
331: $result.=">$select2{$value}</option>\n";
332: }
333: $result .= "</select>\n";
334: # return $debug;
335: return $result;
336: } # end of sub linked_select_forms {
337:
1.33 matthew 338: ###############################################################
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.16 harris41 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.16 harris41 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:
771: sub get_previous_attempt {
1.2 albertel 772: my ($symb,$username,$domain,$course)=@_;
1.1 albertel 773: my $prevattempts='';
774: if ($symb) {
1.3 albertel 775: my (%returnhash)=
776: &Apache::lonnet::restore($symb,$course,$domain,$username);
1.1 albertel 777: if ($returnhash{'version'}) {
778: my %lasthash=();
779: my $version;
780: for ($version=1;$version<=$returnhash{'version'};$version++) {
1.19 harris41 781: foreach (sort(split(/\:/,$returnhash{$version.':keys'}))) {
1.1 albertel 782: $lasthash{$_}=$returnhash{$version.':'.$_};
1.19 harris41 783: }
1.1 albertel 784: }
785: $prevattempts='<table border=2></tr><th>History</th>';
1.16 harris41 786: foreach (sort(keys %lasthash)) {
1.31 albertel 787: my ($ign,@parts) = split(/\./,$_);
788: if (@parts) {
789: my $data=$parts[-1];
790: pop(@parts);
791: $prevattempts.='<th>Part '.join('.',@parts).'<br />'.$data.'</th>';
792: } else {
793: $prevattempts.='<th>'.$ign.'</th>';
794: }
1.16 harris41 795: }
1.1 albertel 796: for ($version=1;$version<=$returnhash{'version'};$version++) {
797: $prevattempts.='</tr><tr><th>Attempt '.$version.'</th>';
1.16 harris41 798: foreach (sort(keys %lasthash)) {
1.5 albertel 799: my $value;
800: if ($_ =~ /timestamp/) {
801: $value=scalar(localtime($returnhash{$version.':'.$_}));
802: } else {
803: $value=$returnhash{$version.':'.$_};
804: }
805: $prevattempts.='<td>'.$value.'</td>';
1.16 harris41 806: }
1.1 albertel 807: }
808: $prevattempts.='</tr><tr><th>Current</th>';
1.16 harris41 809: foreach (sort(keys %lasthash)) {
1.5 albertel 810: my $value;
811: if ($_ =~ /timestamp/) {
812: $value=scalar(localtime($lasthash{$_}));
813: } else {
814: $value=$lasthash{$_};
815: }
816: $prevattempts.='<td>'.$value.'</td>';
1.16 harris41 817: }
1.1 albertel 818: $prevattempts.='</tr></table>';
819: } else {
820: $prevattempts='Nothing submitted - no attempts.';
821: }
822: } else {
823: $prevattempts='No data.';
824: }
1.10 albertel 825: }
826:
827: sub get_student_view {
828: my ($symb,$username,$domain,$courseid) = @_;
829: my ($map,$id,$feedurl) = split(/___/,$symb);
830: my (%old,%moreenv);
831: my @elements=('symb','courseid','domain','username');
832: foreach my $element (@elements) {
833: $old{$element}=$ENV{'form.grade_'.$element};
834: $moreenv{'form.grade_'.$element}=eval '$'.$element #'
835: }
1.11 albertel 836: &Apache::lonnet::appenv(%moreenv);
837: my $userview=&Apache::lonnet::ssi('/res/'.$feedurl);
838: &Apache::lonnet::delenv('form.grade_');
839: foreach my $element (@elements) {
840: $ENV{'form.grade_'.$element}=$old{$element};
841: }
842: $userview=~s/\<body[^\>]*\>//gi;
843: $userview=~s/\<\/body\>//gi;
844: $userview=~s/\<html\>//gi;
845: $userview=~s/\<\/html\>//gi;
846: $userview=~s/\<head\>//gi;
847: $userview=~s/\<\/head\>//gi;
848: $userview=~s/action\s*\=/would_be_action\=/gi;
849: return $userview;
850: }
851:
852: sub get_student_answers {
853: my ($symb,$username,$domain,$courseid) = @_;
854: my ($map,$id,$feedurl) = split(/___/,$symb);
855: my (%old,%moreenv);
856: my @elements=('symb','courseid','domain','username');
857: foreach my $element (@elements) {
858: $old{$element}=$ENV{'form.grade_'.$element};
859: $moreenv{'form.grade_'.$element}=eval '$'.$element #'
860: }
861: $moreenv{'form.grade_target'}='answer';
1.10 albertel 862: &Apache::lonnet::appenv(%moreenv);
863: my $userview=&Apache::lonnet::ssi('/res/'.$feedurl);
864: &Apache::lonnet::delenv('form.grade_');
865: foreach my $element (@elements) {
866: $ENV{'form.grade_'.$element}=$old{$element};
867: }
868: $userview=~s/\<body[^\>]*\>//gi;
869: $userview=~s/\<\/body\>//gi;
870: $userview=~s/\<html\>//gi;
871: $userview=~s/\<\/html\>//gi;
872: $userview=~s/\<head\>//gi;
873: $userview=~s/\<\/head\>//gi;
874: $userview=~s/action\s*\=/would_be_action\=/gi;
875: return $userview;
1.1 albertel 876: }
1.37 ! matthew 877:
! 878: ###############################################
! 879:
! 880: =item get_unprocessed_cgi($query,$possible_names)
! 881:
! 882: Modify the %ENV hash to contain unprocessed CGI form parameters held in
! 883: $query. The parameters listed in $possible_names (an array reference),
! 884: will be set in $ENV{'form.name'} if they do not already exist.
! 885:
! 886: Typically called with $ENV{'QUERY_STRING'} as the first parameter.
! 887: $possible_names is an ref to an array of form element names. As an example:
! 888: get_unprocessed_cgi($ENV{'QUERY_STRING'},['uname','udom']);
! 889: will result in $ENV{'form.uname'} and $ENV{'form.udom'} being set.
! 890:
! 891: =cut
! 892:
! 893: ###############################################
1.1 albertel 894:
1.6 albertel 895: sub get_unprocessed_cgi {
1.25 albertel 896: my ($query,$possible_names)= @_;
1.26 matthew 897: # $Apache::lonxml::debug=1;
1.16 harris41 898: foreach (split(/&/,$query)) {
1.6 albertel 899: my ($name, $value) = split(/=/,$_);
1.25 albertel 900: $name = &Apache::lonnet::unescape($name);
901: if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) {
902: $value =~ tr/+/ /;
903: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
904: &Apache::lonxml::debug("Seting :$name: to :$value:");
1.30 albertel 905: unless (defined($ENV{'form.'.$name})) { &add_to_env('form.'.$name,$value) };
1.25 albertel 906: }
1.16 harris41 907: }
1.6 albertel 908: }
909:
1.7 albertel 910: sub cacheheader {
1.23 www 911: unless ($ENV{'request.method'} eq 'GET') { return ''; }
1.8 albertel 912: my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
1.7 albertel 913: my $output .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" />
914: <meta HTTP-EQUIV="Cache-control" CONTENT="no-cache" />
915: <meta HTTP-EQUIV="Pragma" CONTENT="no-cache" />';
916: return $output;
917: }
918:
1.9 albertel 919: sub no_cache {
920: my ($r) = @_;
1.23 www 921: unless ($ENV{'request.method'} eq 'GET') { return ''; }
1.24 albertel 922: #my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
1.9 albertel 923: $r->no_cache(1);
924: $r->header_out("Pragma" => "no-cache");
1.24 albertel 925: #$r->header_out("Expires" => $date);
1.9 albertel 926: }
1.25 albertel 927:
928: sub add_to_env {
929: my ($name,$value)=@_;
1.28 albertel 930: if (defined($ENV{$name})) {
1.27 albertel 931: if (ref($ENV{$name})) {
1.25 albertel 932: #already have multiple values
933: push(@{ $ENV{$name} },$value);
934: } else {
935: #first time seeing multiple values, convert hash entry to an arrayref
936: my $first=$ENV{$name};
937: undef($ENV{$name});
938: push(@{ $ENV{$name} },$first,$value);
939: }
940: } else {
941: $ENV{$name}=$value;
942: }
1.31 albertel 943: }
944:
945: #---CSV Upload/Handling functions
946:
947: # ========================================================= Store uploaded file
948: # needs $ENV{'form.upfile'}
949: # return $datatoken to be put into hidden field
950:
951: sub upfile_store {
952: my $r=shift;
953: $ENV{'form.upfile'}=~s/\r/\n/gs;
954: $ENV{'form.upfile'}=~s/\f/\n/gs;
955: $ENV{'form.upfile'}=~s/\n+/\n/gs;
956: $ENV{'form.upfile'}=~s/\n+$//gs;
957:
958: my $datatoken=$ENV{'user.name'}.'_'.$ENV{'user.domain'}.
959: '_enroll_'.$ENV{'request.course.id'}.'_'.time.'_'.$$;
960: {
961: my $fh=Apache::File->new('>'.$r->dir_config('lonDaemons').
962: '/tmp/'.$datatoken.'.tmp');
963: print $fh $ENV{'form.upfile'};
964: }
965: return $datatoken;
966: }
967:
968: # ================================================= Load uploaded file from tmp
969: # needs $ENV{'form.datatoken'}
970: # sets $ENV{'form.upfile'} to the contents of the file
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:
985: # ========================================= Separate uploaded file into records
986: # returns array of records
987: # needs $ENV{'form.upfile'}
988: # needs $ENV{'form.upfiletype'}
989:
990: sub upfile_record_sep {
991: if ($ENV{'form.upfiletype'} eq 'xml') {
992: } else {
993: return split(/\n/,$ENV{'form.upfile'});
994: }
995: }
996:
997: # =============================================== Separate a record into fields
998: # needs $ENV{'form.upfiletype'}
999: # takes $record as arg
1000: sub record_sep {
1001: my $record=shift;
1002: my %components=();
1003: if ($ENV{'form.upfiletype'} eq 'xml') {
1004: } elsif ($ENV{'form.upfiletype'} eq 'space') {
1005: my $i=0;
1006: foreach (split(/\s+/,$record)) {
1007: my $field=$_;
1008: $field=~s/^(\"|\')//;
1009: $field=~s/(\"|\')$//;
1010: $components{$i}=$field;
1011: $i++;
1012: }
1013: } elsif ($ENV{'form.upfiletype'} eq 'tab') {
1014: my $i=0;
1015: foreach (split(/\t+/,$record)) {
1016: my $field=$_;
1017: $field=~s/^(\"|\')//;
1018: $field=~s/(\"|\')$//;
1019: $components{$i}=$field;
1020: $i++;
1021: }
1022: } else {
1023: my @allfields=split(/\,/,$record);
1024: my $i=0;
1025: my $j;
1026: for ($j=0;$j<=$#allfields;$j++) {
1027: my $field=$allfields[$j];
1028: if ($field=~/^\s*(\"|\')/) {
1029: my $delimiter=$1;
1030: while (($field!~/$delimiter$/) && ($j<$#allfields)) {
1031: $j++;
1032: $field.=','.$allfields[$j];
1033: }
1034: $field=~s/^\s*$delimiter//;
1035: $field=~s/$delimiter\s*$//;
1036: }
1037: $components{$i}=$field;
1038: $i++;
1039: }
1040: }
1041: return %components;
1042: }
1043:
1044: # =============================== HTML code to select file and specify its type
1045: sub upfile_select_html {
1046: return (<<'ENDUPFORM');
1047: <input type="file" name="upfile" size="50">
1048: <br />Type: <select name="upfiletype">
1049: <option value="csv">CSV (comma separated values, spreadsheet)</option>
1050: <option value="space">Space separated</option>
1051: <option value="tab">Tabulator separated</option>
1052: <option value="xml">HTML/XML</option>
1053: </select>
1054: ENDUPFORM
1055: }
1056:
1057: # ===================Prints a table of sample values from each column uploaded
1058: # $r is an Apache Request ref
1059: # $records is an arrayref from &Apache::loncommon::upfile_record_sep
1060: sub csv_print_samples {
1061: my ($r,$records) = @_;
1062: my (%sone,%stwo,%sthree);
1063: %sone=&record_sep($$records[0]);
1064: if (defined($$records[1])) {%stwo=&record_sep($$records[1]);}
1065: if (defined($$records[2])) {%sthree=&record_sep($$records[2]);}
1066:
1067: $r->print('Samples<br /><table border="2"><tr>');
1068: foreach (sort({$a <=> $b} keys(%sone))) { $r->print('<th>Column '.($_+1).'</th>'); }
1069: $r->print('</tr>');
1070: foreach my $hash (\%sone,\%stwo,\%sthree) {
1071: $r->print('<tr>');
1072: foreach (sort({$a <=> $b} keys(%sone))) {
1073: $r->print('<td>');
1074: if (defined($$hash{$_})) { $r->print($$hash{$_}); }
1075: $r->print('</td>');
1076: }
1077: $r->print('</tr>');
1078: }
1079: $r->print('</tr></table><br />'."\n");
1080: }
1081:
1082: # ======Prints a table to create associations between values and table columns
1083: # $r is an Apache Request ref
1084: # $records is an arrayref from &Apache::loncommon::upfile_record_sep
1085: # $d is an array of 2 element arrays (internal name, displayed name)
1086: sub csv_print_select_table {
1087: my ($r,$records,$d) = @_;
1088: my $i=0;my %sone;
1089: %sone=&record_sep($$records[0]);
1090: $r->print('Associate columns with student attributes.'."\n".
1091: '<table border="2"><tr><th>Attribute</th><th>Column</th></tr>'."\n");
1092: foreach (@$d) {
1093: my ($value,$display)=@{ $_ };
1094: $r->print('<tr><td>'.$display.'</td>');
1095:
1096: $r->print('<td><select name=f'.$i.
1.32 matthew 1097: ' onchange="javascript:flip(this.form,'.$i.');">');
1.31 albertel 1098: $r->print('<option value="none"></option>');
1099: foreach (sort({$a <=> $b} keys(%sone))) {
1100: $r->print('<option value="'.$_.'">Column '.($_+1).'</option>');
1101: }
1102: $r->print('</select></td></tr>'."\n");
1103: $i++;
1104: }
1105: $i--;
1106: return $i;
1107: }
1108:
1109: # ===================Prints a table of sample values from the upload and
1110: # can make associate samples to internal names
1111: # $r is an Apache Request ref
1112: # $records is an arrayref from &Apache::loncommon::upfile_record_sep
1113: # $d is an array of 2 element arrays (internal name, displayed name)
1114: sub csv_samples_select_table {
1115: my ($r,$records,$d) = @_;
1116: my %sone; my %stwo; my %sthree;
1117: my $i=0;
1118:
1119: $r->print('<table border=2><tr><th>Field</th><th>Samples</th></tr>');
1120: %sone=&record_sep($$records[0]);
1121: if (defined($$records[1])) {%stwo=&record_sep($$records[1]);}
1122: if (defined($$records[2])) {%sthree=&record_sep($$records[2]);}
1123:
1124: foreach (sort keys %sone) {
1125: $r->print('<tr><td><select name=f'.$i.
1.32 matthew 1126: ' onchange="javascript:flip(this.form,'.$i.');">');
1.31 albertel 1127: foreach (@$d) {
1128: my ($value,$display)=@{ $_ };
1129: $r->print('<option value='.$value.'>'.$display.'</option>');
1130: }
1131: $r->print('</select></td><td>');
1132: if (defined($sone{$_})) { $r->print($sone{$_}."</br>\n"); }
1133: if (defined($stwo{$_})) { $r->print($stwo{$_}."</br>\n"); }
1134: if (defined($sthree{$_})) { $r->print($sthree{$_}."</br>\n"); }
1135: $r->print('</td></tr>');
1136: $i++;
1137: }
1138: $i--;
1139: return($i);
1.25 albertel 1140: }
1.1 albertel 1141: 1;
1142: __END__;
1.17 harris41 1143:
1.35 matthew 1144: =item languageids()
1.17 harris41 1145:
1.35 matthew 1146: returns list of all language ids
1.17 harris41 1147:
1.35 matthew 1148: =item languagedescription()
1.17 harris41 1149:
1.35 matthew 1150: returns description of a specified language id
1.17 harris41 1151:
1.35 matthew 1152: =item copyrightids()
1.17 harris41 1153:
1.35 matthew 1154: returns list of all copyrights
1.17 harris41 1155:
1.35 matthew 1156: =item copyrightdescription()
1.17 harris41 1157:
1.35 matthew 1158: returns description of a specified copyright id
1.17 harris41 1159:
1.35 matthew 1160: =item filecategories()
1.17 harris41 1161:
1.35 matthew 1162: returns list of all file categories
1.17 harris41 1163:
1.35 matthew 1164: =item filecategorytypes()
1.17 harris41 1165:
1.35 matthew 1166: returns list of file types belonging to a given file
1.17 harris41 1167: category
1168:
1.35 matthew 1169: =item fileembstyle()
1.17 harris41 1170:
1.35 matthew 1171: returns embedding style for a specified file type
1.17 harris41 1172:
1.35 matthew 1173: =item filedescription()
1.17 harris41 1174:
1.35 matthew 1175: returns description for a specified file type
1.17 harris41 1176:
1.35 matthew 1177: =item filedescriptionex()
1.17 harris41 1178:
1.35 matthew 1179: returns description for a specified file type with
1.17 harris41 1180: extra formatting
1181:
1.35 matthew 1182: =item get_previous_attempt()
1.17 harris41 1183:
1.35 matthew 1184: return string with previous attempt on problem
1.17 harris41 1185:
1.35 matthew 1186: =item get_student_view()
1.17 harris41 1187:
1.35 matthew 1188: show a snapshot of what student was looking at
1.17 harris41 1189:
1.35 matthew 1190: =item get_student_answers()
1.17 harris41 1191:
1.35 matthew 1192: show a snapshot of how student was answering problem
1.17 harris41 1193:
1.35 matthew 1194: =item get_unprocessed_cgi()
1.17 harris41 1195:
1.35 matthew 1196: get unparsed CGI parameters
1.17 harris41 1197:
1.35 matthew 1198: =item cacheheader()
1.17 harris41 1199:
1.35 matthew 1200: returns cache-controlling header code
1.17 harris41 1201:
1.35 matthew 1202: =item nocache()
1.17 harris41 1203:
1.35 matthew 1204: specifies header code to not have cache
1.25 albertel 1205:
1.35 matthew 1206: =item add_to_env($name,$value)
1.25 albertel 1207:
1.35 matthew 1208: adds $name to the %ENV hash with value
1.25 albertel 1209: $value, if $name already exists, the entry is converted to an array
1210: reference and $value is added to the array.
1.17 harris41 1211:
1212: =back
1213:
1214: =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