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