loncom/interface/loncommon.pm - view

File: [LON-CAPA] / loncom / interface / loncommon.pm
Revision 1.44: download - view: text, annotated - select for diffs
Fri Jul 5 16:12:31 2002 UTC (21 years, 11 months ago) by bowersj2
Branches: MAIN
CVS tags: HEAD

This commit implements the .tex-based online help system in LON-CAPA. It
may be necessary to manually run loncom/build/help_graphics_converter.pl
and doc/help/rebuildLabelHash.pl after a cvs update, and
loncapa_apache.conf may need to be manually copied to /etc. (The
loncapafiles.lpml has been updated.)

After merging this, the URL http://[loncapahost]/adm/help/Foils.hlp
should display a help file.

Also, some *very* out-of-date files have been removed from the /doc
directory.

1: # The LearningOnline Network with CAPA 2: # a pile of common routines 3: # 4: # $Id: loncommon.pm,v 1.44 2002/07/05 16:12:31 bowersj2 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: 432: =item help_open_topic($topic, $stayOnPage, $width, $height) 433: 434: Returns a string corresponding to an HTML link to the given help $topic, where $topic corresponds to the name of a .tex file in /home/httpd/html/adm/help/tex, with underscores replaced by spaces. 435: 436: $stayOnPage is a value that will be interpreted as a boolean. If true, the link will not open a new window. If false, the link will open a new window using Javascript. (Default is false.) 437: 438: $width and $height are optional numerical parameters that will override the width and height of the popped up window, which may be useful for certain help topics with big pictures included. 439: 440: =cut 441: 442: sub help_open_topic { 443: my ($topic, $stayOnPage, $width, $height) = @_; 444: $stayOnPage = 0 if (not defined $stayOnPage); 445: $width = 350 if (not defined $width); 446: $height = 400 if (not defined $height); 447: my $filename = $topic; 448: $filename =~ s/ /_/g; 449: 450: my $template; 451: 452: if (!$stayOnPage) 453: { 454: $template = <<"ENDTEMPLATE"; 455: <a href="javascript:void(open('/adm/help/${filename}.hlp', 'Help for $topic', 'menubar=0,s 456: crollbars=1,width=$width,height=$height'))"><image 457: src="/adm/help/gif/smallHelp.gif" 458: border="0" alt="(Help: $topic)"></a> 459: ENDTEMPLATE 460: } 461: else 462: { 463: $template = <<"ENDTEMPLATE"; 464: <a href="/adm/help/${filename}.hlp"><image 465: src="/adm/help/gif/smallHelp.gif" 466: border="0" alt="(Help: $topic)"></a> 467: ENDTEMPLATE 468: } 469: 470: return $template; 471: 472: } 473: 474: =item csv_translate($text) 475: 476: Translate $text to allow it to be output as a 'comma seperated values' 477: format. 478: 479: =cut 480: 481: sub csv_translate { 482: my $text = shift; 483: $text =~ s/\"/\"\"/g; 484: $text =~ s/\n//g; 485: return $text; 486: } 487: 488: ############################################################### 489: 490: ############################################################### 491: ## Home server <option> list generating code ## 492: ############################################################### 493: #------------------------------------------- 494: 495: =item get_domains() 496: 497: Returns an array containing each of the domains listed in the hosts.tab 498: file. 499: 500: =cut 501: 502: #------------------------------------------- 503: sub get_domains { 504: # The code below was stolen from "The Perl Cookbook", p 102, 1st ed. 505: my @domains; 506: my %seen; 507: foreach (sort values(%Apache::lonnet::hostdom)) { 508: push (@domains,$_) unless $seen{$_}++; 509: } 510: return @domains; 511: } 512: 513: #------------------------------------------- 514: 515: =item select_dom_form($defdom,$name) 516: 517: Returns a string containing a <select name='$name' size='1'> form to 518: allow a user to select the domain to preform an operation in. 519: See loncreateuser.pm for an example invocation and use. 520: 521: =cut 522: 523: #------------------------------------------- 524: sub select_dom_form { 525: my ($defdom,$name) = @_; 526: my @domains = get_domains(); 527: my $selectdomain = "<select name=\"$name\" size=\"1\">\n"; 528: foreach (@domains) { 529: $selectdomain.="<option value=\"$_\" ". 530: ($_ eq $defdom ? 'selected' : ''). 531: ">$_</option>\n"; 532: } 533: $selectdomain.="</select>"; 534: return $selectdomain; 535: } 536: 537: #------------------------------------------- 538: 539: =item get_home_servers($domain) 540: 541: Returns a hash which contains keys like '103l3' and values like 542: 'kirk.lite.msu.edu'. All of the keys will be for machines in the 543: given $domain. 544: 545: =cut 546: 547: #------------------------------------------- 548: sub get_home_servers { 549: my $domain = shift; 550: my %home_servers; 551: foreach (keys(%Apache::lonnet::libserv)) { 552: if ($Apache::lonnet::hostdom{$_} eq $domain) { 553: $home_servers{$_} = $Apache::lonnet::hostname{$_}; 554: } 555: } 556: return %home_servers; 557: } 558: 559: #------------------------------------------- 560: 561: =item home_server_option_list($domain) 562: 563: returns a string which contains an <option> list to be used in a 564: <select> form input. See loncreateuser.pm for an example. 565: 566: =cut 567: 568: #------------------------------------------- 569: sub home_server_option_list { 570: my $domain = shift; 571: my %servers = &get_home_servers($domain); 572: my $result = ''; 573: foreach (sort keys(%servers)) { 574: $result.= 575: '<option value="'.$_.'">'.$_.' '.$servers{$_}."</option>\n"; 576: } 577: return $result; 578: } 579: ############################################################### 580: ## End of home server <option> list generating code ## 581: ############################################################### 582: 583: ############################################################### 584: ## Authentication changing form generation subroutines ## 585: ############################################################### 586: ## 587: ## All of the authform_xxxxxxx subroutines take their inputs in a 588: ## hash, and have reasonable default values. 589: ## 590: ## formname = the name given in the <form> tag. 591: #------------------------------------------- 592: 593: =item authform_xxxxxx 594: 595: The authform_xxxxxx subroutines provide javascript and html forms which 596: handle some of the conveniences required for authentication forms. 597: This is not an optimal method, but it works. 598: 599: See loncreateuser.pm for invocation and use examples. 600: 601: =over 4 602: 603: =item authform_header 604: 605: =item authform_authorwarning 606: 607: =item authform_nochange 608: 609: =item authform_kerberos 610: 611: =item authform_internal 612: 613: =item authform_filesystem 614: 615: =back 616: 617: =cut 618: 619: #------------------------------------------- 620: sub authform_header{ 621: my %in = ( 622: formname => 'cu', 623: kerb_def_dom => 'MSU.EDU', 624: @_, 625: ); 626: $in{'formname'} = 'document.' . $in{'formname'}; 627: my $result=''; 628: $result.=<<"END"; 629: var current = new Object(); 630: current.radiovalue = 'nochange'; 631: current.argfield = null; 632: 633: function changed_radio(choice,currentform) { 634: var choicearg = choice + 'arg'; 635: // If a radio button in changed, we need to change the argfield 636: if (current.radiovalue != choice) { 637: current.radiovalue = choice; 638: if (current.argfield != null) { 639: currentform.elements[current.argfield].value = ''; 640: } 641: if (choice == 'nochange') { 642: current.argfield = null; 643: } else { 644: current.argfield = choicearg; 645: switch(choice) { 646: case 'krb': 647: currentform.elements[current.argfield].value = 648: "$in{'kerb_def_dom'}"; 649: break; 650: default: 651: break; 652: } 653: } 654: } 655: return; 656: } 657: 658: function changed_text(choice,currentform) { 659: var choicearg = choice + 'arg'; 660: if (currentform.elements[choicearg].value !='') { 661: switch (choice) { 662: case 'krb': currentform.elements[choicearg].value = 663: currentform.elements[choicearg].value.toUpperCase(); 664: break; 665: default: 666: } 667: // clear old field 668: if ((current.argfield != choicearg) && (current.argfield != null)) { 669: currentform.elements[current.argfield].value = ''; 670: } 671: current.argfield = choicearg; 672: } 673: set_auth_radio_buttons(choice,currentform); 674: return; 675: } 676: 677: function set_auth_radio_buttons(newvalue,currentform) { 678: var i=0; 679: while (i < currentform.login.length) { 680: if (currentform.login[i].value == newvalue) { break; } 681: i++; 682: } 683: if (i == currentform.login.length) { 684: return; 685: } 686: current.radiovalue = newvalue; 687: currentform.login[i].checked = true; 688: return; 689: } 690: END 691: return $result; 692: } 693: 694: sub authform_authorwarning{ 695: my $result=''; 696: $result=<<"END"; 697: <i>As a general rule, only authors or co-authors should be filesystem 698: authenticated (which allows access to the server filesystem).</i> 699: END 700: return $result; 701: } 702: 703: sub authform_nochange{ 704: my %in = ( 705: formname => 'document.cu', 706: kerb_def_dom => 'MSU.EDU', 707: @_, 708: ); 709: my $result=''; 710: $result.=<<"END"; 711: <input type="radio" name="login" value="nochange" checked="checked" 712: onclick="javascript:changed_radio('nochange',$in{'formname'});"> 713: Do not change login data 714: END 715: return $result; 716: } 717: 718: sub authform_kerberos{ 719: my %in = ( 720: formname => 'document.cu', 721: kerb_def_dom => 'MSU.EDU', 722: @_, 723: ); 724: my $result=''; 725: $result.=<<"END"; 726: <input type="radio" name="login" value="krb" 727: onclick="javascript:changed_radio('krb',$in{'formname'});" 728: onchange="javascript:changed_radio('krb',$in{'formname'});"> 729: Kerberos authenticated with domain 730: <input type="text" size="10" name="krbarg" value="" 731: onchange="javascript:changed_text('krb',$in{'formname'});"> 732: END 733: return $result; 734: } 735: 736: sub authform_internal{ 737: my %args = ( 738: formname => 'document.cu', 739: kerb_def_dom => 'MSU.EDU', 740: @_, 741: ); 742: my $result=''; 743: $result.=<<"END"; 744: <input type="radio" name="login" value="int" 745: onchange="javascript:changed_radio('int',$args{'formname'});" 746: onclick="javascript:changed_radio('int',$args{'formname'});"> 747: Internally authenticated (with initial password 748: <input type="text" size="10" name="intarg" value="" 749: onchange="javascript:changed_text('int',$args{'formname'});"> 750: END 751: return $result; 752: } 753: 754: sub authform_local{ 755: my %in = ( 756: formname => 'document.cu', 757: kerb_def_dom => 'MSU.EDU', 758: @_, 759: ); 760: my $result=''; 761: $result.=<<"END"; 762: <input type="radio" name="login" value="loc" 763: onchange="javascript:changed_radio('loc',$in{'formname'});" 764: onclick="javascript:changed_radio('loc',$in{'formname'});"> 765: Local Authentication with argument 766: <input type="text" size="10" name="locarg" value="" 767: onchange="javascript:changed_text('loc',$in{'formname'});"> 768: END 769: return $result; 770: } 771: 772: sub authform_filesystem{ 773: my %in = ( 774: formname => 'document.cu', 775: kerb_def_dom => 'MSU.EDU', 776: @_, 777: ); 778: my $result=''; 779: $result.=<<"END"; 780: <input type="radio" name="login" value="fsys" 781: onchange="javascript:changed_radio('fsys',$in{'formname'});" 782: onclick="javascript:changed_radio('fsys',$in{'formname'});"> 783: Filesystem authenticated (with initial password 784: <input type="text" size="10" name="fsysarg" value="" 785: onchange="javascript:changed_text('fsys',$in{'formname'});"> 786: END 787: return $result; 788: } 789: 790: ############################################################### 791: ## End Authentication changing form generation functions ## 792: ############################################################### 793: 794: 795: 796: # ---------------------------------------------------------- Is this a keyword? 797: 798: sub keyword { 799: my $newword=shift; 800: $newword=~s/\W//g; 801: $newword=~tr/A-Z/a-z/; 802: my $tindex=$theindex{$newword}; 803: if ($tindex) { 804: if ($thecount[$tindex]>$theavecount) { 805: return 1; 806: } 807: } 808: return 0; 809: } 810: # -------------------------------------------------------- Return related words 811: 812: sub related { 813: my $newword=shift; 814: $newword=~s/\W//g; 815: $newword=~tr/A-Z/a-z/; 816: my $tindex=$theindex{$newword}; 817: if ($tindex) { 818: my %found=(); 819: foreach (split(/\,/,$therelated[$tindex])) { 820: # - Related word found 821: my ($ridx,$rcount)=split(/\:/,$_); 822: # - Direct relation index 823: my $directrel=$rcount/$thecount[$tindex]; 824: if ($directrel>$thethreshold) { 825: foreach (split(/\,/,$therelated[$ridx])) { 826: my ($rridx,$rrcount)=split(/\:/,$_); 827: if ($rridx==$tindex) { 828: # - Determine reverse relation index 829: my $revrel=$rrcount/$thecount[$ridx]; 830: # - Calculate full index 831: $found{$ridx}=$directrel*$revrel; 832: if ($found{$ridx}>$thethreshold) { 833: foreach (split(/\,/,$therelated[$ridx])) { 834: my ($rrridx,$rrrcount)=split(/\:/,$_); 835: unless ($found{$rrridx}) { 836: my $revrevrel=$rrrcount/$thecount[$ridx]; 837: if ( 838: $directrel*$revrel*$revrevrel>$thethreshold 839: ) { 840: $found{$rrridx}= 841: $directrel*$revrel*$revrevrel; 842: } 843: } 844: } 845: } 846: } 847: } 848: } 849: } 850: } 851: return (); 852: } 853: 854: # ---------------------------------------------------------------- Language IDs 855: sub languageids { 856: return sort(keys(%language)); 857: } 858: 859: # -------------------------------------------------------- Language Description 860: sub languagedescription { 861: return $language{shift(@_)}; 862: } 863: 864: # --------------------------------------------------------------- Copyright IDs 865: sub copyrightids { 866: return sort(keys(%cprtag)); 867: } 868: 869: # ------------------------------------------------------- Copyright Description 870: sub copyrightdescription { 871: return $cprtag{shift(@_)}; 872: } 873: 874: # ------------------------------------------------------------- File Categories 875: sub filecategories { 876: return sort(keys(%category_extensions)); 877: } 878: 879: # -------------------------------------- File Types within a specified category 880: sub filecategorytypes { 881: return @{$category_extensions{lc($_[0])}}; 882: } 883: 884: # ------------------------------------------------------------------ File Types 885: sub fileextensions { 886: return sort(keys(%fe)); 887: } 888: 889: # ------------------------------------------------------------- Embedding Style 890: sub fileembstyle { 891: return $fe{lc(shift(@_))}; 892: } 893: 894: # ------------------------------------------------------------ Description Text 895: sub filedescription { 896: return $fd{lc(shift(@_))}; 897: } 898: 899: # ------------------------------------------------------------ Description Text 900: sub filedescriptionex { 901: my $ex=shift; 902: return '.'.$ex.' '.$fd{lc($ex)}; 903: } 904: 905: # ---- Retrieve attempts by students 906: # input 907: # $symb - problem including path 908: # $username,$domain - that of the student 909: # $course - course name 910: # $getattempt - leave blank if want all attempts, else put something. 911: # $regexp - regular expression. If string matches regexp send to 912: # $gradesub - routine that process the string if it matches regexp 913: # 914: # output 915: # formatted as a table all the attempts, if any. 916: # 917: sub get_previous_attempt { 918: my ($symb,$username,$domain,$course,$getattempt,$regexp,$gradesub)=@_; 919: my $prevattempts=''; 920: no strict 'refs'; 921: if ($symb) { 922: my (%returnhash)= 923: &Apache::lonnet::restore($symb,$course,$domain,$username); 924: if ($returnhash{'version'}) { 925: my %lasthash=(); 926: my $version; 927: for ($version=1;$version<=$returnhash{'version'};$version++) { 928: foreach (sort(split(/\:/,$returnhash{$version.':keys'}))) { 929: $lasthash{$_}=$returnhash{$version.':'.$_}; 930: } 931: } 932: $prevattempts='<table border="0" width="100%"><tr><td bgcolor="#777777">'; 933: $prevattempts.='<table border="0" width="100%"><tr bgcolor="#e6ffff"><td>History</td>'; 934: foreach (sort(keys %lasthash)) { 935: my ($ign,@parts) = split(/\./,$_); 936: if ($#parts > 0) { 937: my $data=$parts[-1]; 938: pop(@parts); 939: $prevattempts.='<td>Part '.join('.',@parts).'<br />'.$data.' </td>'; 940: } else { 941: if ($#parts == 0) { 942: $prevattempts.='<th>'.$parts[0].'</th>'; 943: } else { 944: $prevattempts.='<th>'.$ign.'</th>'; 945: } 946: } 947: } 948: if ($getattempt eq '') { 949: for ($version=1;$version<=$returnhash{'version'};$version++) { 950: $prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Transaction '.$version.'</td>'; 951: foreach (sort(keys %lasthash)) { 952: my $value; 953: if ($_ =~ /timestamp/) { 954: $value=scalar(localtime($returnhash{$version.':'.$_})); 955: } else { 956: $value=$returnhash{$version.':'.$_}; 957: } 958: $prevattempts.='<td>'.$value.' </td>'; 959: } 960: } 961: } 962: $prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Current</td>'; 963: foreach (sort(keys %lasthash)) { 964: my $value; 965: if ($_ =~ /timestamp/) { 966: $value=scalar(localtime($lasthash{$_})); 967: } else { 968: $value=$lasthash{$_}; 969: } 970: if ($_ =~/$regexp$/) {$value = &$gradesub($value)} 971: $prevattempts.='<td>'.$value.' </td>'; 972: } 973: $prevattempts.='</tr></table></td></tr></table>'; 974: } else { 975: $prevattempts='Nothing submitted - no attempts.'; 976: } 977: } else { 978: $prevattempts='No data.'; 979: } 980: } 981: 982: sub get_student_view { 983: my ($symb,$username,$domain,$courseid) = @_; 984: my ($map,$id,$feedurl) = split(/___/,$symb); 985: my (%old,%moreenv); 986: my @elements=('symb','courseid','domain','username'); 987: foreach my $element (@elements) { 988: $old{$element}=$ENV{'form.grade_'.$element}; 989: $moreenv{'form.grade_'.$element}=eval '$'.$element #' 990: } 991: &Apache::lonnet::appenv(%moreenv); 992: my $userview=&Apache::lonnet::ssi('/res/'.$feedurl); 993: &Apache::lonnet::delenv('form.grade_'); 994: foreach my $element (@elements) { 995: $ENV{'form.grade_'.$element}=$old{$element}; 996: } 997: $userview=~s/\<body[^\>]*\>//gi; 998: $userview=~s/\<\/body\>//gi; 999: $userview=~s/\<html\>//gi; 1000: $userview=~s/\<\/html\>//gi; 1001: $userview=~s/\<head\>//gi; 1002: $userview=~s/\<\/head\>//gi; 1003: $userview=~s/action\s*\=/would_be_action\=/gi; 1004: return $userview; 1005: } 1006: 1007: sub get_student_answers { 1008: my ($symb,$username,$domain,$courseid) = @_; 1009: my ($map,$id,$feedurl) = split(/___/,$symb); 1010: my (%old,%moreenv); 1011: my @elements=('symb','courseid','domain','username'); 1012: foreach my $element (@elements) { 1013: $old{$element}=$ENV{'form.grade_'.$element}; 1014: $moreenv{'form.grade_'.$element}=eval '$'.$element #' 1015: } 1016: $moreenv{'form.grade_target'}='answer'; 1017: &Apache::lonnet::appenv(%moreenv); 1018: my $userview=&Apache::lonnet::ssi('/res/'.$feedurl); 1019: &Apache::lonnet::delenv('form.grade_'); 1020: foreach my $element (@elements) { 1021: $ENV{'form.grade_'.$element}=$old{$element}; 1022: } 1023: return $userview; 1024: } 1025: 1026: ############################################### 1027: 1028: ############################################### 1029: 1030: sub get_unprocessed_cgi { 1031: my ($query,$possible_names)= @_; 1032: # $Apache::lonxml::debug=1; 1033: foreach (split(/&/,$query)) { 1034: my ($name, $value) = split(/=/,$_); 1035: $name = &Apache::lonnet::unescape($name); 1036: if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) { 1037: $value =~ tr/+/ /; 1038: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; 1039: &Apache::lonxml::debug("Seting :$name: to :$value:"); 1040: unless (defined($ENV{'form.'.$name})) { &add_to_env('form.'.$name,$value) }; 1041: } 1042: } 1043: } 1044: 1045: sub cacheheader { 1046: unless ($ENV{'request.method'} eq 'GET') { return ''; } 1047: my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime); 1048: my $output .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" /> 1049: <meta HTTP-EQUIV="Cache-control" CONTENT="no-cache" /> 1050: <meta HTTP-EQUIV="Pragma" CONTENT="no-cache" />'; 1051: return $output; 1052: } 1053: 1054: sub no_cache { 1055: my ($r) = @_; 1056: unless ($ENV{'request.method'} eq 'GET') { return ''; } 1057: #my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime); 1058: $r->no_cache(1); 1059: $r->header_out("Pragma" => "no-cache"); 1060: #$r->header_out("Expires" => $date); 1061: } 1062: 1063: sub add_to_env { 1064: my ($name,$value)=@_; 1065: if (defined($ENV{$name})) { 1066: if (ref($ENV{$name})) { 1067: #already have multiple values 1068: push(@{ $ENV{$name} },$value); 1069: } else { 1070: #first time seeing multiple values, convert hash entry to an arrayref 1071: my $first=$ENV{$name}; 1072: undef($ENV{$name}); 1073: push(@{ $ENV{$name} },$first,$value); 1074: } 1075: } else { 1076: $ENV{$name}=$value; 1077: } 1078: } 1079: 1080: =pod 1081: 1082: =head2 CSV Upload/Handling functions 1083: 1084: =over 4 1085: 1086: =item upfile_store($r) 1087: 1088: Store uploaded file, $r should be the HTTP Request object, 1089: needs $ENV{'form.upfile'} 1090: returns $datatoken to be put into hidden field 1091: 1092: =cut 1093: 1094: sub upfile_store { 1095: my $r=shift; 1096: $ENV{'form.upfile'}=~s/\r/\n/gs; 1097: $ENV{'form.upfile'}=~s/\f/\n/gs; 1098: $ENV{'form.upfile'}=~s/\n+/\n/gs; 1099: $ENV{'form.upfile'}=~s/\n+$//gs; 1100: 1101: my $datatoken=$ENV{'user.name'}.'_'.$ENV{'user.domain'}. 1102: '_enroll_'.$ENV{'request.course.id'}.'_'.time.'_'.$$; 1103: { 1104: my $fh=Apache::File->new('>'.$r->dir_config('lonDaemons'). 1105: '/tmp/'.$datatoken.'.tmp'); 1106: print $fh $ENV{'form.upfile'}; 1107: } 1108: return $datatoken; 1109: } 1110: 1111: =item load_tmp_file($r) 1112: 1113: Load uploaded file from tmp, $r should be the HTTP Request object, 1114: needs $ENV{'form.datatoken'}, 1115: sets $ENV{'form.upfile'} to the contents of the file 1116: 1117: =cut 1118: 1119: sub load_tmp_file { 1120: my $r=shift; 1121: my @studentdata=(); 1122: { 1123: my $fh; 1124: if ($fh=Apache::File->new($r->dir_config('lonDaemons'). 1125: '/tmp/'.$ENV{'form.datatoken'}.'.tmp')) { 1126: @studentdata=<$fh>; 1127: } 1128: } 1129: $ENV{'form.upfile'}=join('',@studentdata); 1130: } 1131: 1132: =item upfile_record_sep() 1133: 1134: Separate uploaded file into records 1135: returns array of records, 1136: needs $ENV{'form.upfile'} and $ENV{'form.upfiletype'} 1137: 1138: =cut 1139: 1140: sub upfile_record_sep { 1141: if ($ENV{'form.upfiletype'} eq 'xml') { 1142: } else { 1143: return split(/\n/,$ENV{'form.upfile'}); 1144: } 1145: } 1146: 1147: =item record_sep($record) 1148: 1149: Separate a record into fields $record should be an item from the upfile_record_sep(), needs $ENV{'form.upfiletype'} 1150: 1151: =cut 1152: 1153: sub record_sep { 1154: my $record=shift; 1155: my %components=(); 1156: if ($ENV{'form.upfiletype'} eq 'xml') { 1157: } elsif ($ENV{'form.upfiletype'} eq 'space') { 1158: my $i=0; 1159: foreach (split(/\s+/,$record)) { 1160: my $field=$_; 1161: $field=~s/^(\"|\')//; 1162: $field=~s/(\"|\')$//; 1163: $components{$i}=$field; 1164: $i++; 1165: } 1166: } elsif ($ENV{'form.upfiletype'} eq 'tab') { 1167: my $i=0; 1168: foreach (split(/\t+/,$record)) { 1169: my $field=$_; 1170: $field=~s/^(\"|\')//; 1171: $field=~s/(\"|\')$//; 1172: $components{$i}=$field; 1173: $i++; 1174: } 1175: } else { 1176: my @allfields=split(/\,/,$record); 1177: my $i=0; 1178: my $j; 1179: for ($j=0;$j<=$#allfields;$j++) { 1180: my $field=$allfields[$j]; 1181: if ($field=~/^\s*(\"|\')/) { 1182: my $delimiter=$1; 1183: while (($field!~/$delimiter$/) && ($j<$#allfields)) { 1184: $j++; 1185: $field.=','.$allfields[$j]; 1186: } 1187: $field=~s/^\s*$delimiter//; 1188: $field=~s/$delimiter\s*$//; 1189: } 1190: $components{$i}=$field; 1191: $i++; 1192: } 1193: } 1194: return %components; 1195: } 1196: 1197: =item upfile_select_html() 1198: 1199: return HTML code to select file and specify its type 1200: 1201: =cut 1202: 1203: sub upfile_select_html { 1204: return (<<'ENDUPFORM'); 1205: <input type="file" name="upfile" size="50"> 1206: <br />Type: <select name="upfiletype"> 1207: <option value="csv">CSV (comma separated values, spreadsheet)</option> 1208: <option value="space">Space separated</option> 1209: <option value="tab">Tabulator separated</option> 1210: <option value="xml">HTML/XML</option> 1211: </select> 1212: ENDUPFORM 1213: } 1214: 1215: =item csv_print_samples($r,$records) 1216: 1217: Prints a table of sample values from each column uploaded $r is an 1218: Apache Request ref, $records is an arrayref from 1219: &Apache::loncommon::upfile_record_sep 1220: 1221: =cut 1222: 1223: sub csv_print_samples { 1224: my ($r,$records) = @_; 1225: my (%sone,%stwo,%sthree); 1226: %sone=&record_sep($$records[0]); 1227: if (defined($$records[1])) {%stwo=&record_sep($$records[1]);} 1228: if (defined($$records[2])) {%sthree=&record_sep($$records[2]);} 1229: 1230: $r->print('Samples<br /><table border="2"><tr>'); 1231: foreach (sort({$a <=> $b} keys(%sone))) { $r->print('<th>Column '.($_+1).'</th>'); } 1232: $r->print('</tr>'); 1233: foreach my $hash (\%sone,\%stwo,\%sthree) { 1234: $r->print('<tr>'); 1235: foreach (sort({$a <=> $b} keys(%sone))) { 1236: $r->print('<td>'); 1237: if (defined($$hash{$_})) { $r->print($$hash{$_}); } 1238: $r->print('</td>'); 1239: } 1240: $r->print('</tr>'); 1241: } 1242: $r->print('</tr></table><br />'."\n"); 1243: } 1244: 1245: =item csv_print_select_table($r,$records,$d) 1246: 1247: Prints a table to create associations between values and table columns. 1248: $r is an Apache Request ref, 1249: $records is an arrayref from &Apache::loncommon::upfile_record_sep, 1250: $d is an array of 2 element arrays (internal name, displayed name) 1251: 1252: =cut 1253: 1254: sub csv_print_select_table { 1255: my ($r,$records,$d) = @_; 1256: my $i=0;my %sone; 1257: %sone=&record_sep($$records[0]); 1258: $r->print('Associate columns with student attributes.'."\n". 1259: '<table border="2"><tr><th>Attribute</th><th>Column</th></tr>'."\n"); 1260: foreach (@$d) { 1261: my ($value,$display)=@{ $_ }; 1262: $r->print('<tr><td>'.$display.'</td>'); 1263: 1264: $r->print('<td><select name=f'.$i. 1265: ' onchange="javascript:flip(this.form,'.$i.');">'); 1266: $r->print('<option value="none"></option>'); 1267: foreach (sort({$a <=> $b} keys(%sone))) { 1268: $r->print('<option value="'.$_.'">Column '.($_+1).'</option>'); 1269: } 1270: $r->print('</select></td></tr>'."\n"); 1271: $i++; 1272: } 1273: $i--; 1274: return $i; 1275: } 1276: 1277: =item csv_samples_select_table($r,$records,$d) 1278: 1279: Prints a table of sample values from the upload and can make associate samples to internal names. 1280: 1281: $r is an Apache Request ref, 1282: $records is an arrayref from &Apache::loncommon::upfile_record_sep, 1283: $d is an array of 2 element arrays (internal name, displayed name) 1284: 1285: =cut 1286: 1287: sub csv_samples_select_table { 1288: my ($r,$records,$d) = @_; 1289: my %sone; my %stwo; my %sthree; 1290: my $i=0; 1291: 1292: $r->print('<table border=2><tr><th>Field</th><th>Samples</th></tr>'); 1293: %sone=&record_sep($$records[0]); 1294: if (defined($$records[1])) {%stwo=&record_sep($$records[1]);} 1295: if (defined($$records[2])) {%sthree=&record_sep($$records[2]);} 1296: 1297: foreach (sort keys %sone) { 1298: $r->print('<tr><td><select name=f'.$i. 1299: ' onchange="javascript:flip(this.form,'.$i.');">'); 1300: foreach (@$d) { 1301: my ($value,$display)=@{ $_ }; 1302: $r->print('<option value='.$value.'>'.$display.'</option>'); 1303: } 1304: $r->print('</select></td><td>'); 1305: if (defined($sone{$_})) { $r->print($sone{$_}."</br>\n"); } 1306: if (defined($stwo{$_})) { $r->print($stwo{$_}."</br>\n"); } 1307: if (defined($sthree{$_})) { $r->print($sthree{$_}."</br>\n"); } 1308: $r->print('</td></tr>'); 1309: $i++; 1310: } 1311: $i--; 1312: return($i); 1313: } 1314: 1; 1315: __END__; 1316: 1317: =pod 1318: 1319: =back 1320: 1321: =head2 Access .tab File Data 1322: 1323: =over 4 1324: 1325: =item languageids() 1326: 1327: returns list of all language ids 1328: 1329: =item languagedescription() 1330: 1331: returns description of a specified language id 1332: 1333: =item copyrightids() 1334: 1335: returns list of all copyrights 1336: 1337: =item copyrightdescription() 1338: 1339: returns description of a specified copyright id 1340: 1341: =item filecategories() 1342: 1343: returns list of all file categories 1344: 1345: =item filecategorytypes() 1346: 1347: returns list of file types belonging to a given file 1348: category 1349: 1350: =item fileembstyle() 1351: 1352: returns embedding style for a specified file type 1353: 1354: =item filedescription() 1355: 1356: returns description for a specified file type 1357: 1358: =item filedescriptionex() 1359: 1360: returns description for a specified file type with 1361: extra formatting 1362: 1363: =back 1364: 1365: =head2 Alternate Problem Views 1366: 1367: =over 4 1368: 1369: =item get_previous_attempt() 1370: 1371: return string with previous attempt on problem 1372: 1373: =item get_student_view() 1374: 1375: show a snapshot of what student was looking at 1376: 1377: =item get_student_answers() 1378: 1379: show a snapshot of how student was answering problem 1380: 1381: =back 1382: 1383: =head2 HTTP Helper 1384: 1385: =over 4 1386: 1387: =item get_unprocessed_cgi($query,$possible_names) 1388: 1389: Modify the %ENV hash to contain unprocessed CGI form parameters held in 1390: $query. The parameters listed in $possible_names (an array reference), 1391: will be set in $ENV{'form.name'} if they do not already exist. 1392: 1393: Typically called with $ENV{'QUERY_STRING'} as the first parameter. 1394: $possible_names is an ref to an array of form element names. As an example: 1395: get_unprocessed_cgi($ENV{'QUERY_STRING'},['uname','udom']); 1396: will result in $ENV{'form.uname'} and $ENV{'form.udom'} being set. 1397: 1398: =item cacheheader() 1399: 1400: returns cache-controlling header code 1401: 1402: =item nocache() 1403: 1404: specifies header code to not have cache 1405: 1406: =item add_to_env($name,$value) 1407: 1408: adds $name to the %ENV hash with value 1409: $value, if $name already exists, the entry is converted to an array 1410: reference and $value is added to the array. 1411: 1412: =back 1413: 1414: =cut