loncom/interface/loncommon.pm - view

File: [LON-CAPA] / loncom / interface / loncommon.pm
Revision 1.45: download - view: text, annotated - select for diffs
Tue Jul 9 17:15:58 2002 UTC (21 years, 11 months ago) by matthew
Branches: MAIN
CVS tags: HEAD

POD changes to fix bug in "make build;".  There were two errors:  An =item
appeared outside of an =over list and an =head2 appeared inside an =over list.
Added =pod to a few places that should likely have it (not having it does not
generate an error).  Added a few newlines after POD commands, too.

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