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