![]() ![]() | ![]() |
Get current language directly from lonlocal
1: # The LearningOnline Network with CAPA 2: # a pile of common routines 3: # 4: # $Id: loncommon.pm,v 1.122 2003/09/20 13:21:45 www 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/21 Gerd Kortemeyer 31: # 12/25,12/28 Gerd Kortemeyer 32: # YEAR=2002 33: # 1/4 Gerd Kortemeyer 34: # 6/24,7/2 H. K. Ng 35: 36: # Makes a table out of the previous attempts 37: # Inputs result_from_symbread, user, domain, course_id 38: # Reads in non-network-related .tab files 39: 40: # POD header: 41: 42: =pod 43: 44: =head1 NAME 45: 46: Apache::loncommon - pile of common routines 47: 48: =head1 SYNOPSIS 49: 50: Common routines for manipulating connections, student answers, 51: domains, common Javascript fragments, etc. 52: 53: =head1 OVERVIEW 54: 55: A collection of commonly used subroutines that don't have a natural 56: home anywhere else. This collection helps remove 57: redundancy from other modules and increase efficiency of memory usage. 58: 59: =cut 60: 61: # End of POD header 62: package Apache::loncommon; 63: 64: use strict; 65: use Apache::lonnet(); 66: use GDBM_File; 67: use POSIX qw(strftime mktime); 68: use Apache::Constants qw(:common :http :methods); 69: use Apache::lonmsg(); 70: use Apache::lonmenu(); 71: use Apache::lonlocal; 72: 73: my $readit; 74: 75: =pod 76: 77: =head1 Global Variables 78: 79: =cut 80: 81: # ----------------------------------------------- Filetypes/Languages/Copyright 82: my %language; 83: my %cprtag; 84: my %fe; my %fd; 85: my %category_extensions; 86: 87: # ---------------------------------------------- Designs 88: 89: my %designhash; 90: 91: # ---------------------------------------------- Thesaurus variables 92: 93: # FIXME: I don't think it's necessary to document these things; 94: # they're privately used - Jeremy 95: 96: =pod 97: 98: =over 4 99: 100: =item * %Keywords 101: 102: A hash used by &keyword to determine if a word is considered a keyword. 103: 104: =item * $thesaurus_db_file 105: 106: Scalar containing the full path to the thesaurus database. 107: 108: =back 109: 110: =cut 111: 112: my %Keywords; 113: my $thesaurus_db_file; 114: 115: # ----------------------------------------------------------------------- BEGIN 116: 117: # FIXME: I don't think this needs to be documented, it prepares 118: # private data structures - Jeremy 119: =pod 120: 121: =head1 General Subroutines 122: 123: =over 4 124: 125: =item * BEGIN() 126: 127: Initialize values from language.tab, copyright.tab, filetypes.tab, 128: thesaurus.tab, and filecategories.tab. 129: 130: =back 131: 132: =cut 133: 134: # ----------------------------------------------------------------------- BEGIN 135: 136: BEGIN { 137: # Variable initialization 138: $thesaurus_db_file = $Apache::lonnet::perlvar{'lonTabDir'}."/thesaurus.db"; 139: # 140: unless ($readit) { 141: # ------------------------------------------------------------------- languages 142: { 143: my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}. 144: '/language.tab'); 145: if ($fh) { 146: while (<$fh>) { 147: next if /^\#/; 148: chomp; 149: my ($key,$two,$country,$three,$enc,$val)=(split(/\t/,$_)); 150: $language{$key}=$val.' - '.$enc; 151: } 152: } 153: } 154: # ------------------------------------------------------------------ copyrights 155: { 156: my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonIncludes'}. 157: '/copyright.tab'); 158: if ($fh) { 159: while (<$fh>) { 160: next if /^\#/; 161: chomp; 162: my ($key,$val)=(split(/\s+/,$_,2)); 163: $cprtag{$key}=$val; 164: } 165: } 166: } 167: 168: # -------------------------------------------------------------- domain designs 169: 170: my $filename; 171: my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors'; 172: opendir(DIR,$designdir); 173: while ($filename=readdir(DIR)) { 174: my ($domain)=($filename=~/^(\w+)\./); 175: { 176: my $fh=Apache::File->new($designdir.'/'.$filename); 177: if ($fh) { 178: while (<$fh>) { 179: next if /^\#/; 180: chomp; 181: my ($key,$val)=(split(/\=/,$_)); 182: if ($val) { $designhash{$domain.'.'.$key}=$val; } 183: } 184: } 185: } 186: 187: } 188: closedir(DIR); 189: 190: 191: # ------------------------------------------------------------- file categories 192: { 193: my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}. 194: '/filecategories.tab'); 195: if ($fh) { 196: while (<$fh>) { 197: next if /^\#/; 198: chomp; 199: my ($extension,$category)=(split(/\s+/,$_,2)); 200: push @{$category_extensions{lc($category)}},$extension; 201: } 202: } 203: } 204: # ------------------------------------------------------------------ file types 205: { 206: my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}. 207: '/filetypes.tab'); 208: if ($fh) { 209: while (<$fh>) { 210: next if (/^\#/); 211: chomp; 212: my ($ending,$emb,$descr)=split(/\s+/,$_,3); 213: if ($descr ne '') { 214: $fe{$ending}=lc($emb); 215: $fd{$ending}=$descr; 216: } 217: } 218: } 219: } 220: &Apache::lonnet::logthis( 221: "<font color=yellow>INFO: Read file types</font>"); 222: $readit=1; 223: } # end of unless($readit) 224: 225: } 226: 227: ############################################################### 228: ## HTML and Javascript Helper Functions ## 229: ############################################################### 230: 231: =pod 232: 233: =head1 HTML and Javascript Functions 234: 235: =over 4 236: 237: =item * browser_and_searcher_javascript () 238: 239: X<browsing, javascript>X<searching, javascript>Returns a string 240: containing javascript with two functions, C<openbrowser> and 241: C<opensearcher>. Returned string does not contain E<lt>scriptE<gt> 242: tags. 243: 244: =over 4 245: 246: =item * openbrowser(formname,elementname,only,omit) [javascript] 247: 248: inputs: formname, elementname, only, omit 249: 250: formname and elementname indicate the name of the html form and name of 251: the element that the results of the browsing selection are to be placed in. 252: 253: Specifying 'only' will restrict the browser to displaying only files 254: with the given extension. Can be a comma seperated list. 255: 256: Specifying 'omit' will restrict the browser to NOT displaying files 257: with the given extension. Can be a comma seperated list. 258: 259: =item * opensearcher(formname, elementname) [javascript] 260: 261: Inputs: formname, elementname 262: 263: formname and elementname specify the name of the html form and the name 264: of the element the selection from the search results will be placed in. 265: 266: =back 267: 268: =cut 269: 270: sub browser_and_searcher_javascript { 271: return <<END; 272: var editbrowser = null; 273: function openbrowser(formname,elementname,only,omit) { 274: var url = '/res/?'; 275: if (editbrowser == null) { 276: url += 'launch=1&'; 277: } 278: url += 'catalogmode=interactive&'; 279: url += 'mode=edit&'; 280: url += 'form=' + formname + '&'; 281: if (only != null) { 282: url += 'only=' + only + '&'; 283: } 284: if (omit != null) { 285: url += 'omit=' + omit + '&'; 286: } 287: url += 'element=' + elementname + ''; 288: var title = 'Browser'; 289: var options = 'scrollbars=1,resizable=1,menubar=0'; 290: options += ',width=700,height=600'; 291: editbrowser = open(url,title,options,'1'); 292: editbrowser.focus(); 293: } 294: var editsearcher; 295: function opensearcher(formname,elementname) { 296: var url = '/adm/searchcat?'; 297: if (editsearcher == null) { 298: url += 'launch=1&'; 299: } 300: url += 'catalogmode=interactive&'; 301: url += 'mode=edit&'; 302: url += 'form=' + formname + '&'; 303: url += 'element=' + elementname + ''; 304: var title = 'Search'; 305: var options = 'scrollbars=1,resizable=1,menubar=0'; 306: options += ',width=700,height=600'; 307: editsearcher = open(url,title,options,'1'); 308: editsearcher.focus(); 309: } 310: END 311: } 312: 313: sub studentbrowser_javascript { 314: unless ( 315: (($ENV{'request.course.id'}) && 316: (&Apache::lonnet::allowed('srm',$ENV{'request.course.id'}))) 317: || ($ENV{'request.role'}=~/^(au|dc|su)/) 318: ) { return ''; } 319: return (<<'ENDSTDBRW'); 320: <script type="text/javascript" language="Javascript" > 321: var stdeditbrowser; 322: function openstdbrowser(formname,uname,udom,roleflag) { 323: var url = '/adm/pickstudent?'; 324: var filter; 325: eval('filter=document.'+formname+'.'+uname+'.value;'); 326: if (filter != null) { 327: if (filter != '') { 328: url += 'filter='+filter+'&'; 329: } 330: } 331: url += 'form=' + formname + '&unameelement='+uname+ 332: '&udomelement='+udom; 333: if (roleflag) { url+="&roles=1"; } 334: var title = 'Student_Browser'; 335: var options = 'scrollbars=1,resizable=1,menubar=0'; 336: options += ',width=700,height=600'; 337: stdeditbrowser = open(url,title,options,'1'); 338: stdeditbrowser.focus(); 339: } 340: </script> 341: ENDSTDBRW 342: } 343: 344: sub selectstudent_link { 345: my ($form,$unameele,$udomele)=@_; 346: if ($ENV{'request.course.id'}) { 347: unless (&Apache::lonnet::allowed('srm',$ENV{'request.course.id'})) { 348: return ''; 349: } 350: return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele. 351: '","'.$udomele.'");'."'>".&mt('Select User')."</a>"; 352: } 353: if ($ENV{'request.role'}=~/^(au|dc|su)/) { 354: return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele. 355: '","'.$udomele.'",1);'."'>".&mt('Select User')."</a>"; 356: } 357: return ''; 358: } 359: 360: sub coursebrowser_javascript { 361: return (<<'ENDSTDBRW'); 362: <script type="text/javascript" language="Javascript" > 363: var stdeditbrowser; 364: function opencrsbrowser(formname,uname,udom) { 365: var url = '/adm/pickcourse?'; 366: var filter; 367: if (filter != null) { 368: if (filter != '') { 369: url += 'filter='+filter+'&'; 370: } 371: } 372: url += 'form=' + formname + '&cnumelement='+uname+ 373: '&cdomelement='+udom; 374: var title = 'Course_Browser'; 375: var options = 'scrollbars=1,resizable=1,menubar=0'; 376: options += ',width=700,height=600'; 377: stdeditbrowser = open(url,title,options,'1'); 378: stdeditbrowser.focus(); 379: } 380: </script> 381: ENDSTDBRW 382: } 383: 384: sub selectcourse_link { 385: my ($form,$unameele,$udomele)=@_; 386: return "<a href='".'javascript:opencrsbrowser("'.$form.'","'.$unameele. 387: '","'.$udomele.'");'."'>".&mt('Select Course')."</a>"; 388: } 389: 390: =pod 391: 392: =item * linked_select_forms(...) 393: 394: linked_select_forms returns a string containing a <script></script> block 395: and html for two <select> menus. The select menus will be linked in that 396: changing the value of the first menu will result in new values being placed 397: in the second menu. The values in the select menu will appear in alphabetical 398: order. 399: 400: linked_select_forms takes the following ordered inputs: 401: 402: =over 4 403: 404: =item * $formname, the name of the <form> tag 405: 406: =item * $middletext, the text which appears between the <select> tags 407: 408: =item * $firstdefault, the default value for the first menu 409: 410: =item * $firstselectname, the name of the first <select> tag 411: 412: =item * $secondselectname, the name of the second <select> tag 413: 414: =item * $hashref, a reference to a hash containing the data for the menus. 415: 416: =back 417: 418: Below is an example of such a hash. Only the 'text', 'default', and 419: 'select2' keys must appear as stated. keys(%menu) are the possible 420: values for the first select menu. The text that coincides with the 421: first menu value is given in $menu{$choice1}->{'text'}. The values 422: and text for the second menu are given in the hash pointed to by 423: $menu{$choice1}->{'select2'}. 424: 425: my %menu = ( A1 => { text =>"Choice A1" , 426: default => "B3", 427: select2 => { 428: B1 => "Choice B1", 429: B2 => "Choice B2", 430: B3 => "Choice B3", 431: B4 => "Choice B4" 432: } 433: }, 434: A2 => { text =>"Choice A2" , 435: default => "C2", 436: select2 => { 437: C1 => "Choice C1", 438: C2 => "Choice C2", 439: C3 => "Choice C3" 440: } 441: }, 442: A3 => { text =>"Choice A3" , 443: default => "D6", 444: select2 => { 445: D1 => "Choice D1", 446: D2 => "Choice D2", 447: D3 => "Choice D3", 448: D4 => "Choice D4", 449: D5 => "Choice D5", 450: D6 => "Choice D6", 451: D7 => "Choice D7" 452: } 453: } 454: ); 455: 456: =cut 457: 458: sub linked_select_forms { 459: my ($formname, 460: $middletext, 461: $firstdefault, 462: $firstselectname, 463: $secondselectname, 464: $hashref 465: ) = @_; 466: my $second = "document.$formname.$secondselectname"; 467: my $first = "document.$formname.$firstselectname"; 468: # output the javascript to do the changing 469: my $result = ''; 470: $result.="<script>\n"; 471: $result.="var select2data = new Object();\n"; 472: $" = '","'; 473: my $debug = ''; 474: foreach my $s1 (sort(keys(%$hashref))) { 475: $result.="select2data.d_$s1 = new Object();\n"; 476: $result.="select2data.d_$s1.def = new String('". 477: $hashref->{$s1}->{'default'}."');\n"; 478: $result.="select2data.d_$s1.values = new Array("; 479: my @s2values = sort(keys( %{ $hashref->{$s1}->{'select2'} } )); 480: $result.="\"@s2values\");\n"; 481: $result.="select2data.d_$s1.texts = new Array("; 482: my @s2texts; 483: foreach my $value (@s2values) { 484: push @s2texts, $hashref->{$s1}->{'select2'}->{$value}; 485: } 486: $result.="\"@s2texts\");\n"; 487: } 488: $"=' '; 489: $result.= <<"END"; 490: 491: function select1_changed() { 492: // Determine new choice 493: var newvalue = "d_" + $first.value; 494: // update select2 495: var values = select2data[newvalue].values; 496: var texts = select2data[newvalue].texts; 497: var select2def = select2data[newvalue].def; 498: var i; 499: // out with the old 500: for (i = 0; i < $second.options.length; i++) { 501: $second.options[i] = null; 502: } 503: // in with the nuclear 504: for (i=0;i<values.length; i++) { 505: $second.options[i] = new Option(values[i]); 506: $second.options[i].text = texts[i]; 507: if (values[i] == select2def) { 508: $second.options[i].selected = true; 509: } 510: } 511: } 512: </script> 513: END 514: # output the initial values for the selection lists 515: $result .= "<select size=\"1\" name=\"$firstselectname\" onchange=\"select1_changed()\">\n"; 516: foreach my $value (sort(keys(%$hashref))) { 517: $result.=" <option value=\"$value\" "; 518: $result.=" selected=\"true\" " if ($value eq $firstdefault); 519: $result.=">".&mt($hashref->{$value}->{'text'})."</option>\n"; 520: } 521: $result .= "</select>\n"; 522: my %select2 = %{$hashref->{$firstdefault}->{'select2'}}; 523: $result .= $middletext; 524: $result .= "<select size=\"1\" name=\"$secondselectname\">\n"; 525: my $seconddefault = $hashref->{$firstdefault}->{'default'}; 526: foreach my $value (sort(keys(%select2))) { 527: $result.=" <option value=\"$value\" "; 528: $result.=" selected=\"true\" " if ($value eq $seconddefault); 529: $result.=">".&mt($select2{$value})."</option>\n"; 530: } 531: $result .= "</select>\n"; 532: # return $debug; 533: return $result; 534: } # end of sub linked_select_forms { 535: 536: =pod 537: 538: =item * help_open_topic($topic, $text, $stayOnPage, $width, $height) 539: 540: Returns a string corresponding to an HTML link to the given help 541: $topic, where $topic corresponds to the name of a .tex file in 542: /home/httpd/html/adm/help/tex, with underscores replaced by 543: spaces. 544: 545: $text will optionally be linked to the same topic, allowing you to 546: link text in addition to the graphic. If you do not want to link 547: text, but wish to specify one of the later parameters, pass an 548: empty string. 549: 550: $stayOnPage is a value that will be interpreted as a boolean. If true, 551: the link will not open a new window. If false, the link will open 552: a new window using Javascript. (Default is false.) 553: 554: $width and $height are optional numerical parameters that will 555: override the width and height of the popped up window, which may 556: be useful for certain help topics with big pictures included. 557: 558: =cut 559: 560: sub help_open_topic { 561: my ($topic, $text, $stayOnPage, $width, $height) = @_; 562: $text = "" if (not defined $text); 563: $stayOnPage = 0 if (not defined $stayOnPage); 564: if ($ENV{'browser.interface'} eq 'textual' || 565: $ENV{'environment.remote'} eq 'off' ) { 566: $stayOnPage=1; 567: } 568: $width = 350 if (not defined $width); 569: $height = 400 if (not defined $height); 570: my $filename = $topic; 571: $filename =~ s/ /_/g; 572: 573: my $template = ""; 574: my $link; 575: 576: if (!$stayOnPage) 577: { 578: $link = "javascript:void(open('/adm/help/${filename}.hlp', 'Help_for_$topic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))"; 579: } 580: else 581: { 582: $link = "/adm/help/${filename}.hlp"; 583: } 584: 585: # Add the text 586: if ($text ne "") 587: { 588: $template .= 589: "<table bgcolor='#3333AA' cellspacing='1' cellpadding='1' border='0'><tr>". 590: "<td bgcolor='#5555FF'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>"; 591: } 592: 593: # Add the graphic 594: $template .= <<"ENDTEMPLATE"; 595: <a href="$link"><image src="/adm/help/gif/smallHelp.gif" border="0" alt="(Help: $topic)" /></a> 596: ENDTEMPLATE 597: if ($text ne '') { $template.='</td></tr></table>' }; 598: return $template; 599: 600: } 601: 602: # This is a quicky function for Latex cheatsheet editing, since it 603: # appears in at least four places 604: sub helpLatexCheatsheet { 605: my $other = shift; 606: my $addOther = ''; 607: if ($other) { 608: $addOther = Apache::loncommon::help_open_topic($other, shift, 609: undef, undef, 600) . 610: '</td><td>'; 611: } 612: return '<table><tr><td>'. 613: $addOther . 614: &Apache::loncommon::help_open_topic("Greek_Symbols",'Greek Symbols', 615: undef,undef,600) 616: .'</td><td>'. 617: &Apache::loncommon::help_open_topic("Other_Symbols",'Other Symbols', 618: undef,undef,600) 619: .'</td></tr></table>'; 620: } 621: 622: =pod 623: 624: =item * csv_translate($text) 625: 626: Translate $text to allow it to be output as a 'comma seperated values' 627: format. 628: 629: =cut 630: 631: sub csv_translate { 632: my $text = shift; 633: $text =~ s/\"/\"\"/g; 634: $text =~ s/\n//g; 635: return $text; 636: } 637: 638: =pod 639: 640: =item * change_content_javascript(): 641: 642: This and the next function allow you to create small sections of an 643: otherwise static HTML page that you can update on the fly with 644: Javascript, even in Netscape 4. 645: 646: The Javascript fragment returned by this function (no E<lt>scriptE<gt> tag) 647: must be written to the HTML page once. It will prove the Javascript 648: function "change(name, content)". Calling the change function with the 649: name of the section 650: you want to update, matching the name passed to C<changable_area>, and 651: the new content you want to put in there, will put the content into 652: that area. 653: 654: B<Note>: Netscape 4 only reserves enough space for the changable area 655: to contain room for the original contents. You need to "make space" 656: for whatever changes you wish to make, and be B<sure> to check your 657: code in Netscape 4. This feature in Netscape 4 is B<not> powerful; 658: it's adequate for updating a one-line status display, but little more. 659: This script will set the space to 100% width, so you only need to 660: worry about height in Netscape 4. 661: 662: Modern browsers are much less limiting, and if you can commit to the 663: user not using Netscape 4, this feature may be used freely with 664: pretty much any HTML. 665: 666: =cut 667: 668: sub change_content_javascript { 669: # If we're on Netscape 4, we need to use Layer-based code 670: if ($ENV{'browser.type'} eq 'netscape' && 671: $ENV{'browser.version'} =~ /^4\./) { 672: return (<<NETSCAPE4); 673: function change(name, content) { 674: doc = document.layers[name+"___escape"].layers[0].document; 675: doc.open(); 676: doc.write(content); 677: doc.close(); 678: } 679: NETSCAPE4 680: } else { 681: # Otherwise, we need to use semi-standards-compliant code 682: # (technically, "innerHTML" isn't standard but the equivalent 683: # is really scary, and every useful browser supports it 684: return (<<DOMBASED); 685: function change(name, content) { 686: element = document.getElementById(name); 687: element.innerHTML = content; 688: } 689: DOMBASED 690: } 691: } 692: 693: =pod 694: 695: =item * changable_area($name, $origContent): 696: 697: This provides a "changable area" that can be modified on the fly via 698: the Javascript code provided in C<change_content_javascript>. $name is 699: the name you will use to reference the area later; do not repeat the 700: same name on a given HTML page more then once. $origContent is what 701: the area will originally contain, which can be left blank. 702: 703: =cut 704: 705: sub changable_area { 706: my ($name, $origContent) = @_; 707: 708: if ($ENV{'browser.type'} eq 'netscape' && 709: $ENV{'browser.version'} =~ /^4\./) { 710: # If this is netscape 4, we need to use the Layer tag 711: return "<ilayer width='100%' id='${name}___escape' overflow='none'><layer width='100%' id='$name' overflow='none'>$origContent</layer></ilayer>"; 712: } else { 713: return "<span id='$name'>$origContent</span>"; 714: } 715: } 716: 717: =pod 718: 719: =back 720: 721: =cut 722: 723: ############################################################### 724: ## Home server <option> list generating code ## 725: ############################################################### 726: 727: =pod 728: 729: =head1 Home Server option list generating code 730: 731: =over 4 732: 733: =item * get_domains() 734: 735: Returns an array containing each of the domains listed in the hosts.tab 736: file. 737: 738: =cut 739: 740: #------------------------------------------- 741: sub get_domains { 742: # The code below was stolen from "The Perl Cookbook", p 102, 1st ed. 743: my @domains; 744: my %seen; 745: foreach (sort values(%Apache::lonnet::hostdom)) { 746: push (@domains,$_) unless $seen{$_}++; 747: } 748: return @domains; 749: } 750: 751: #------------------------------------------- 752: 753: =pod 754: 755: =item * select_form($defdom,$name,%hash) 756: 757: Returns a string containing a <select name='$name' size='1'> form to 758: allow a user to select options from a hash option_name => displayed text. 759: See lonrights.pm for an example invocation and use. 760: 761: =cut 762: 763: #------------------------------------------- 764: sub select_form { 765: my ($def,$name,%hash) = @_; 766: my $selectform = "<select name=\"$name\" size=\"1\">\n"; 767: foreach (sort keys %hash) { 768: $selectform.="<option value=\"$_\" ". 769: ($_ eq $def ? 'selected' : ''). 770: ">".&mt($hash{$_})."</option>\n"; 771: } 772: $selectform.="</select>"; 773: return $selectform; 774: } 775: 776: 777: #------------------------------------------- 778: 779: =pod 780: 781: =item * select_dom_form($defdom,$name,$includeempty) 782: 783: Returns a string containing a <select name='$name' size='1'> form to 784: allow a user to select the domain to preform an operation in. 785: See loncreateuser.pm for an example invocation and use. 786: 787: If the $includeempty flag is set, it also includes an empty choice ("no domain 788: selected"); 789: 790: =cut 791: 792: #------------------------------------------- 793: sub select_dom_form { 794: my ($defdom,$name,$includeempty) = @_; 795: my @domains = get_domains(); 796: if ($includeempty) { @domains=('',@domains); } 797: my $selectdomain = "<select name=\"$name\" size=\"1\">\n"; 798: foreach (@domains) { 799: $selectdomain.="<option value=\"$_\" ". 800: ($_ eq $defdom ? 'selected' : ''). 801: ">$_</option>\n"; 802: } 803: $selectdomain.="</select>"; 804: return $selectdomain; 805: } 806: 807: #------------------------------------------- 808: 809: =pod 810: 811: =item * get_library_servers($domain) 812: 813: Returns a hash which contains keys like '103l3' and values like 814: 'kirk.lite.msu.edu'. All of the keys will be for machines in the 815: given $domain. 816: 817: =cut 818: 819: #------------------------------------------- 820: sub get_library_servers { 821: my $domain = shift; 822: my %library_servers; 823: foreach (keys(%Apache::lonnet::libserv)) { 824: if ($Apache::lonnet::hostdom{$_} eq $domain) { 825: $library_servers{$_} = $Apache::lonnet::hostname{$_}; 826: } 827: } 828: return %library_servers; 829: } 830: 831: #------------------------------------------- 832: 833: =pod 834: 835: =item * home_server_option_list($domain) 836: 837: returns a string which contains an <option> list to be used in a 838: <select> form input. See loncreateuser.pm for an example. 839: 840: =cut 841: 842: #------------------------------------------- 843: sub home_server_option_list { 844: my $domain = shift; 845: my %servers = &get_library_servers($domain); 846: my $result = ''; 847: foreach (sort keys(%servers)) { 848: $result.= 849: '<option value="'.$_.'">'.$_.' '.$servers{$_}."</option>\n"; 850: } 851: return $result; 852: } 853: 854: =pod 855: 856: =back 857: 858: =cut 859: 860: ############################################################### 861: ## Decoding User Agent ## 862: ############################################################### 863: 864: =pod 865: 866: =head1 Decoding the User Agent 867: 868: =over 4 869: 870: =item * &decode_user_agent() 871: 872: Inputs: $r 873: 874: Outputs: 875: 876: =over 4 877: 878: =item * $httpbrowser 879: 880: =item * $clientbrowser 881: 882: =item * $clientversion 883: 884: =item * $clientmathml 885: 886: =item * $clientunicode 887: 888: =item * $clientos 889: 890: =back 891: 892: =cut 893: 894: ############################################################### 895: ############################################################### 896: sub decode_user_agent { 897: my @browsertype=split(/\&/,$Apache::lonnet::perlvar{"lonBrowsDet"}); 898: my %mathcap=split(/\&/,$$Apache::lonnet::perlvar{"lonMathML"}); 899: my $httpbrowser=$ENV{"HTTP_USER_AGENT"}; 900: my $clientbrowser='unknown'; 901: my $clientversion='0'; 902: my $clientmathml=''; 903: my $clientunicode='0'; 904: for (my $i=0;$i<=$#browsertype;$i++) { 905: my ($bname,$match,$notmatch,$vreg,$minv,$univ)=split(/\:/,$browsertype[$i]); 906: if (($httpbrowser=~/$match/i) && ($httpbrowser!~/$notmatch/i)) { 907: $clientbrowser=$bname; 908: $httpbrowser=~/$vreg/i; 909: $clientversion=$1; 910: $clientmathml=($clientversion>=$minv); 911: $clientunicode=($clientversion>=$univ); 912: } 913: } 914: my $clientos='unknown'; 915: if (($httpbrowser=~/linux/i) || 916: ($httpbrowser=~/unix/i) || 917: ($httpbrowser=~/ux/i) || 918: ($httpbrowser=~/solaris/i)) { $clientos='unix'; } 919: if (($httpbrowser=~/vax/i) || 920: ($httpbrowser=~/vms/i)) { $clientos='vms'; } 921: if ($httpbrowser=~/next/i) { $clientos='next'; } 922: if (($httpbrowser=~/mac/i) || 923: ($httpbrowser=~/powerpc/i)) { $clientos='mac'; } 924: if ($httpbrowser=~/win/i) { $clientos='win'; } 925: if ($httpbrowser=~/embed/i) { $clientos='pda'; } 926: return ($httpbrowser,$clientbrowser,$clientversion,$clientmathml, 927: $clientunicode,$clientos,); 928: } 929: 930: =pod 931: 932: =back 933: 934: =cut 935: 936: ############################################################### 937: ## Authentication changing form generation subroutines ## 938: ############################################################### 939: ## 940: ## All of the authform_xxxxxxx subroutines take their inputs in a 941: ## hash, and have reasonable default values. 942: ## 943: ## formname = the name given in the <form> tag. 944: #------------------------------------------- 945: 946: =pod 947: 948: =head1 Authentication Routines 949: 950: =over 4 951: 952: =item * authform_xxxxxx 953: 954: The authform_xxxxxx subroutines provide javascript and html forms which 955: handle some of the conveniences required for authentication forms. 956: This is not an optimal method, but it works. 957: 958: See loncreateuser.pm for invocation and use examples. 959: 960: =over 4 961: 962: =item * authform_header 963: 964: =item * authform_authorwarning 965: 966: =item * authform_nochange 967: 968: =item * authform_kerberos 969: 970: =item * authform_internal 971: 972: =item * authform_filesystem 973: 974: =back 975: 976: =cut 977: 978: #------------------------------------------- 979: sub authform_header{ 980: my %in = ( 981: formname => 'cu', 982: kerb_def_dom => '', 983: @_, 984: ); 985: $in{'formname'} = 'document.' . $in{'formname'}; 986: my $result=''; 987: 988: #---------------------------------------------- Code for upper case translation 989: my $Javascript_toUpperCase; 990: unless ($in{kerb_def_dom}) { 991: $Javascript_toUpperCase =<<"END"; 992: switch (choice) { 993: case 'krb': currentform.elements[choicearg].value = 994: currentform.elements[choicearg].value.toUpperCase(); 995: break; 996: default: 997: } 998: END 999: } else { 1000: $Javascript_toUpperCase = ""; 1001: } 1002: 1003: $result.=<<"END"; 1004: var current = new Object(); 1005: current.radiovalue = 'nochange'; 1006: current.argfield = null; 1007: 1008: function changed_radio(choice,currentform) { 1009: var choicearg = choice + 'arg'; 1010: // If a radio button in changed, we need to change the argfield 1011: if (current.radiovalue != choice) { 1012: current.radiovalue = choice; 1013: if (current.argfield != null) { 1014: currentform.elements[current.argfield].value = ''; 1015: } 1016: if (choice == 'nochange') { 1017: current.argfield = null; 1018: } else { 1019: current.argfield = choicearg; 1020: switch(choice) { 1021: case 'krb': 1022: currentform.elements[current.argfield].value = 1023: "$in{'kerb_def_dom'}"; 1024: break; 1025: default: 1026: break; 1027: } 1028: } 1029: } 1030: return; 1031: } 1032: 1033: function changed_text(choice,currentform) { 1034: var choicearg = choice + 'arg'; 1035: if (currentform.elements[choicearg].value !='') { 1036: $Javascript_toUpperCase 1037: // clear old field 1038: if ((current.argfield != choicearg) && (current.argfield != null)) { 1039: currentform.elements[current.argfield].value = ''; 1040: } 1041: current.argfield = choicearg; 1042: } 1043: set_auth_radio_buttons(choice,currentform); 1044: return; 1045: } 1046: 1047: function set_auth_radio_buttons(newvalue,currentform) { 1048: var i=0; 1049: while (i < currentform.login.length) { 1050: if (currentform.login[i].value == newvalue) { break; } 1051: i++; 1052: } 1053: if (i == currentform.login.length) { 1054: return; 1055: } 1056: current.radiovalue = newvalue; 1057: currentform.login[i].checked = true; 1058: return; 1059: } 1060: END 1061: return $result; 1062: } 1063: 1064: sub authform_authorwarning{ 1065: my $result=''; 1066: $result=<<"END"; 1067: <i>As a general rule, only authors or co-authors should be filesystem 1068: authenticated (which allows access to the server filesystem).</i> 1069: END 1070: return $result; 1071: } 1072: 1073: sub authform_nochange{ 1074: my %in = ( 1075: formname => 'document.cu', 1076: kerb_def_dom => 'MSU.EDU', 1077: @_, 1078: ); 1079: my $result=''; 1080: $result.=<<"END"; 1081: <input type="radio" name="login" value="nochange" checked="checked" 1082: onclick="javascript:changed_radio('nochange',$in{'formname'});" /> 1083: Do not change login data 1084: END 1085: return $result; 1086: } 1087: 1088: sub authform_kerberos{ 1089: my %in = ( 1090: formname => 'document.cu', 1091: kerb_def_dom => 'MSU.EDU', 1092: kerb_def_auth => 'krb4', 1093: @_, 1094: ); 1095: my $result=''; 1096: my $check4; 1097: my $check5; 1098: if ($in{'kerb_def_auth'} eq 'krb5') { 1099: $check5 = " checked=\"on\""; 1100: } else { 1101: $check4 = " checked=\"on\""; 1102: } 1103: $result.=<<"END"; 1104: <input type="radio" name="login" value="krb" 1105: onclick="javascript:changed_radio('krb',$in{'formname'});" 1106: onchange="javascript:changed_radio('krb',$in{'formname'});" /> 1107: Kerberos authenticated with domain 1108: <input type="text" size="10" name="krbarg" value="$in{'kerb_def_dom'}" 1109: onchange="javascript:changed_text('krb',$in{'formname'});" /> 1110: <input type="radio" name="krbver" value="4" $check4 />Version 4 1111: <input type="radio" name="krbver" value="5" $check5 />Version 5 1112: END 1113: return $result; 1114: } 1115: 1116: sub authform_internal{ 1117: my %args = ( 1118: formname => 'document.cu', 1119: kerb_def_dom => 'MSU.EDU', 1120: @_, 1121: ); 1122: my $result=''; 1123: $result.=<<"END"; 1124: <input type="radio" name="login" value="int" 1125: onchange="javascript:changed_radio('int',$args{'formname'});" 1126: onclick="javascript:changed_radio('int',$args{'formname'});" /> 1127: Internally authenticated (with initial password 1128: <input type="text" size="10" name="intarg" value="" 1129: onchange="javascript:changed_text('int',$args{'formname'});" />) 1130: END 1131: return $result; 1132: } 1133: 1134: sub authform_local{ 1135: my %in = ( 1136: formname => 'document.cu', 1137: kerb_def_dom => 'MSU.EDU', 1138: @_, 1139: ); 1140: my $result=''; 1141: $result.=<<"END"; 1142: <input type="radio" name="login" value="loc" 1143: onchange="javascript:changed_radio('loc',$in{'formname'});" 1144: onclick="javascript:changed_radio('loc',$in{'formname'});" /> 1145: Local Authentication with argument 1146: <input type="text" size="10" name="locarg" value="" 1147: onchange="javascript:changed_text('loc',$in{'formname'});" /> 1148: END 1149: return $result; 1150: } 1151: 1152: sub authform_filesystem{ 1153: my %in = ( 1154: formname => 'document.cu', 1155: kerb_def_dom => 'MSU.EDU', 1156: @_, 1157: ); 1158: my $result=''; 1159: $result.=<<"END"; 1160: <input type="radio" name="login" value="fsys" 1161: onchange="javascript:changed_radio('fsys',$in{'formname'});" 1162: onclick="javascript:changed_radio('fsys',$in{'formname'});" /> 1163: Filesystem authenticated (with initial password 1164: <input type="text" size="10" name="fsysarg" value="" 1165: onchange="javascript:changed_text('fsys',$in{'formname'});">) 1166: END 1167: return $result; 1168: } 1169: 1170: =pod 1171: 1172: =back 1173: 1174: =cut 1175: 1176: ############################################################### 1177: ## Get Authentication Defaults for Domain ## 1178: ############################################################### 1179: 1180: =pod 1181: 1182: =head1 Domains and Authentication 1183: 1184: Returns default authentication type and an associated argument as 1185: listed in file 'domain.tab'. 1186: 1187: =over 4 1188: 1189: =item * get_auth_defaults 1190: 1191: get_auth_defaults($target_domain) returns the default authentication 1192: type and an associated argument (initial password or a kerberos domain). 1193: These values are stored in lonTabs/domain.tab 1194: 1195: ($def_auth, $def_arg) = &get_auth_defaults($target_domain); 1196: 1197: If target_domain is not found in domain.tab, returns nothing (''). 1198: 1199: =cut 1200: 1201: #------------------------------------------- 1202: sub get_auth_defaults { 1203: my $domain=shift; 1204: return ($Apache::lonnet::domain_auth_def{$domain},$Apache::lonnet::domain_auth_arg_def{$domain}); 1205: } 1206: ############################################################### 1207: ## End Get Authentication Defaults for Domain ## 1208: ############################################################### 1209: 1210: ############################################################### 1211: ## Get Kerberos Defaults for Domain ## 1212: ############################################################### 1213: ## 1214: ## Returns default kerberos version and an associated argument 1215: ## as listed in file domain.tab. If not listed, provides 1216: ## appropriate default domain and kerberos version. 1217: ## 1218: #------------------------------------------- 1219: 1220: =pod 1221: 1222: =item * get_kerberos_defaults 1223: 1224: get_kerberos_defaults($target_domain) returns the default kerberos 1225: version and domain. If not found in domain.tabs, it defaults to 1226: version 4 and the domain of the server. 1227: 1228: ($def_version, $def_krb_domain) = &get_kerberos_defaults($target_domain); 1229: 1230: =cut 1231: 1232: #------------------------------------------- 1233: sub get_kerberos_defaults { 1234: my $domain=shift; 1235: my ($krbdef,$krbdefdom) = 1236: &Apache::loncommon::get_auth_defaults($domain); 1237: unless ($krbdef =~/^krb/ && $krbdefdom) { 1238: $ENV{'SERVER_NAME'}=~/(\w+\.\w+)$/; 1239: my $krbdefdom=$1; 1240: $krbdefdom=~tr/a-z/A-Z/; 1241: $krbdef = "krb4"; 1242: } 1243: return ($krbdef,$krbdefdom); 1244: } 1245: 1246: =pod 1247: 1248: =back 1249: 1250: =cut 1251: 1252: ############################################################### 1253: ## Thesaurus Functions ## 1254: ############################################################### 1255: 1256: =pod 1257: 1258: =head1 Thesaurus Functions 1259: 1260: =over 4 1261: 1262: =item * initialize_keywords 1263: 1264: Initializes the package variable %Keywords if it is empty. Uses the 1265: package variable $thesaurus_db_file. 1266: 1267: =cut 1268: 1269: ################################################### 1270: 1271: sub initialize_keywords { 1272: return 1 if (scalar keys(%Keywords)); 1273: # If we are here, %Keywords is empty, so fill it up 1274: # Make sure the file we need exists... 1275: if (! -e $thesaurus_db_file) { 1276: &Apache::lonnet::logthis("Attempt to access $thesaurus_db_file". 1277: " failed because it does not exist"); 1278: return 0; 1279: } 1280: # Set up the hash as a database 1281: my %thesaurus_db; 1282: if (! tie(%thesaurus_db,'GDBM_File', 1283: $thesaurus_db_file,&GDBM_READER(),0640)){ 1284: &Apache::lonnet::logthis("Could not tie \%thesaurus_db to ". 1285: $thesaurus_db_file); 1286: return 0; 1287: } 1288: # Get the average number of appearances of a word. 1289: my $avecount = $thesaurus_db{'average.count'}; 1290: # Put keywords (those that appear > average) into %Keywords 1291: while (my ($word,$data)=each (%thesaurus_db)) { 1292: my ($count,undef) = split /:/,$data; 1293: $Keywords{$word}++ if ($count > $avecount); 1294: } 1295: untie %thesaurus_db; 1296: # Remove special values from %Keywords. 1297: foreach ('total.count','average.count') { 1298: delete($Keywords{$_}) if (exists($Keywords{$_})); 1299: } 1300: return 1; 1301: } 1302: 1303: ################################################### 1304: 1305: =pod 1306: 1307: =item * keyword($word) 1308: 1309: Returns true if $word is a keyword. A keyword is a word that appears more 1310: than the average number of times in the thesaurus database. Calls 1311: &initialize_keywords 1312: 1313: =cut 1314: 1315: ################################################### 1316: 1317: sub keyword { 1318: return if (!&initialize_keywords()); 1319: my $word=lc(shift()); 1320: $word=~s/\W//g; 1321: return exists($Keywords{$word}); 1322: } 1323: 1324: ############################################################### 1325: 1326: =pod 1327: 1328: =item * get_related_words 1329: 1330: Look up a word in the thesaurus. Takes a scalar arguement and returns 1331: an array of words. If the keyword is not in the thesaurus, an empty array 1332: will be returned. The order of the words returned is determined by the 1333: database which holds them. 1334: 1335: Uses global $thesaurus_db_file. 1336: 1337: =cut 1338: 1339: ############################################################### 1340: sub get_related_words { 1341: my $keyword = shift; 1342: my %thesaurus_db; 1343: if (! -e $thesaurus_db_file) { 1344: &Apache::lonnet::logthis("Attempt to access $thesaurus_db_file ". 1345: "failed because the file does not exist"); 1346: return (); 1347: } 1348: if (! tie(%thesaurus_db,'GDBM_File', 1349: $thesaurus_db_file,&GDBM_READER(),0640)){ 1350: return (); 1351: } 1352: my @Words=(); 1353: if (exists($thesaurus_db{$keyword})) { 1354: $_ = $thesaurus_db{$keyword}; 1355: (undef,@Words) = split/:/; # The first element is the number of times 1356: # the word appears. We do not need it now. 1357: for (my $i=0;$i<=$#Words;$i++) { 1358: ($Words[$i],undef)= split/\,/,$Words[$i]; 1359: } 1360: } 1361: untie %thesaurus_db; 1362: return @Words; 1363: } 1364: 1365: =pod 1366: 1367: =back 1368: 1369: =cut 1370: 1371: # -------------------------------------------------------------- Plaintext name 1372: =pod 1373: 1374: =head1 User Name Functions 1375: 1376: =over 4 1377: 1378: =item * plainname($uname,$udom) 1379: 1380: Takes a users logon name and returns it as a string in 1381: "first middle last generation" form 1382: 1383: =cut 1384: 1385: ############################################################### 1386: sub plainname { 1387: my ($uname,$udom)=@_; 1388: my %names=&Apache::lonnet::get('environment', 1389: ['firstname','middlename','lastname','generation'], 1390: $udom,$uname); 1391: my $name=$names{'firstname'}.' '.$names{'middlename'}.' '. 1392: $names{'lastname'}.' '.$names{'generation'}; 1393: $name=~s/\s+$//; 1394: $name=~s/\s+/ /g; 1395: return $name; 1396: } 1397: 1398: # -------------------------------------------------------------------- Nickname 1399: =pod 1400: 1401: =item * nickname($uname,$udom) 1402: 1403: Gets a users name and returns it as a string as 1404: 1405: ""nickname"" 1406: 1407: if the user has a nickname or 1408: 1409: "first middle last generation" 1410: 1411: if the user does not 1412: 1413: =cut 1414: 1415: sub nickname { 1416: my ($uname,$udom)=@_; 1417: my %names=&Apache::lonnet::get('environment', 1418: ['nickname','firstname','middlename','lastname','generation'],$udom,$uname); 1419: my $name=$names{'nickname'}; 1420: if ($name) { 1421: $name='"'.$name.'"'; 1422: } else { 1423: $name=$names{'firstname'}.' '.$names{'middlename'}.' '. 1424: $names{'lastname'}.' '.$names{'generation'}; 1425: $name=~s/\s+$//; 1426: $name=~s/\s+/ /g; 1427: } 1428: return $name; 1429: } 1430: 1431: 1432: # ------------------------------------------------------------------ Screenname 1433: 1434: =pod 1435: 1436: =item * screenname($uname,$udom) 1437: 1438: Gets a users screenname and returns it as a string 1439: 1440: =cut 1441: 1442: sub screenname { 1443: my ($uname,$udom)=@_; 1444: my %names= 1445: &Apache::lonnet::get('environment',['screenname'],$udom,$uname); 1446: return $names{'screenname'}; 1447: } 1448: 1449: # ------------------------------------------------------------- Message Wrapper 1450: 1451: sub messagewrapper { 1452: my ($link,$un,$do)=@_; 1453: return 1454: "<a href='/adm/email?compose=individual&recname=$un&recdom=$do'>$link</a>"; 1455: } 1456: # --------------------------------------------------------------- Notes Wrapper 1457: 1458: sub noteswrapper { 1459: my ($link,$un,$do)=@_; 1460: return 1461: "<a href='/adm/email?recordftf=retrieve&recname=$un&recdom=$do'>$link</a>"; 1462: } 1463: # ------------------------------------------------------------- Aboutme Wrapper 1464: 1465: sub aboutmewrapper { 1466: my ($link,$username,$domain)=@_; 1467: return "<a href='/adm/$domain/$username/aboutme'>$link</a>"; 1468: } 1469: 1470: # ------------------------------------------------------------ Syllabus Wrapper 1471: 1472: 1473: sub syllabuswrapper { 1474: my ($linktext,$coursedir,$domain,$fontcolor)=@_; 1475: if ($fontcolor) { 1476: $linktext='<font color="'.$fontcolor.'">'.$linktext.'</font>'; 1477: } 1478: return "<a href='/public/$domain/$coursedir/syllabus'>$linktext</a>"; 1479: } 1480: 1481: =pod 1482: 1483: =back 1484: 1485: =head1 Access .tab File Data 1486: 1487: =over 4 1488: 1489: =item * languageids() 1490: 1491: returns list of all language ids 1492: 1493: =cut 1494: 1495: sub languageids { 1496: return sort(keys(%language)); 1497: } 1498: 1499: =pod 1500: 1501: =item * languagedescription() 1502: 1503: returns description of a specified language id 1504: 1505: =cut 1506: 1507: sub languagedescription { 1508: return $language{shift(@_)}; 1509: } 1510: 1511: =pod 1512: 1513: =item * copyrightids() 1514: 1515: returns list of all copyrights 1516: 1517: =cut 1518: 1519: sub copyrightids { 1520: return sort(keys(%cprtag)); 1521: } 1522: 1523: =pod 1524: 1525: =item * copyrightdescription() 1526: 1527: returns description of a specified copyright id 1528: 1529: =cut 1530: 1531: sub copyrightdescription { 1532: return $cprtag{shift(@_)}; 1533: } 1534: 1535: =pod 1536: 1537: =item * filecategories() 1538: 1539: returns list of all file categories 1540: 1541: =cut 1542: 1543: sub filecategories { 1544: return sort(keys(%category_extensions)); 1545: } 1546: 1547: =pod 1548: 1549: =item * filecategorytypes() 1550: 1551: returns list of file types belonging to a given file 1552: category 1553: 1554: =cut 1555: 1556: sub filecategorytypes { 1557: return @{$category_extensions{lc($_[0])}}; 1558: } 1559: 1560: =pod 1561: 1562: =item * fileembstyle() 1563: 1564: returns embedding style for a specified file type 1565: 1566: =cut 1567: 1568: sub fileembstyle { 1569: return $fe{lc(shift(@_))}; 1570: } 1571: 1572: =pod 1573: 1574: =item * filedescription() 1575: 1576: returns description for a specified file type 1577: 1578: =cut 1579: 1580: sub filedescription { 1581: return $fd{lc(shift(@_))}; 1582: } 1583: 1584: =pod 1585: 1586: =item * filedescriptionex() 1587: 1588: returns description for a specified file type with 1589: extra formatting 1590: 1591: =cut 1592: 1593: sub filedescriptionex { 1594: my $ex=shift; 1595: return '.'.$ex.' '.$fd{lc($ex)}; 1596: } 1597: 1598: # End of .tab access 1599: =pod 1600: 1601: =back 1602: 1603: =cut 1604: 1605: # ------------------------------------------------------------------ File Types 1606: sub fileextensions { 1607: return sort(keys(%fe)); 1608: } 1609: 1610: # ----------------------------------------------------------- Display Languages 1611: # returns a hash with all desired display languages 1612: # 1613: 1614: sub display_languages { 1615: my %languages=(); 1616: foreach (&preferred_languages()) { 1617: $languages{$_}=1; 1618: } 1619: &get_unprocessed_cgi($ENV{'QUERY_STRING'},['displaylanguage']); 1620: if ($ENV{'form.displaylanguage'}) { 1621: foreach (split(/\s*(\,|\;|\:)\s*/,$ENV{'form.displaylanguage'})) { 1622: $languages{$_}=1; 1623: } 1624: } 1625: return %languages; 1626: } 1627: 1628: sub preferred_languages { 1629: my @languages=(); 1630: if ($ENV{'environment.languages'}) { 1631: @languages=split(/\s*(\,|\;|\:)\s*/,$ENV{'environment.languages'}); 1632: } 1633: if ($ENV{'course.'.$ENV{'request.course.id'}.'.languages'}) { 1634: @languages=(@languages,split(/\s*(\,|\;|\:)\s*/, 1635: $ENV{'course.'.$ENV{'request.course.id'}.'.languages'})); 1636: } 1637: my $browser=(split(/\;/,$ENV{'HTTP_ACCEPT_LANGUAGE'}))[0]; 1638: if ($browser) { 1639: @languages=(@languages,split(/\s*(\,|\;|\:)\s*/,$browser)); 1640: } 1641: if ($Apache::lonnet::domain_lang_def{$ENV{'user.domain'}}) { 1642: @languages=(@languages, 1643: $Apache::lonnet::domain_lang_def{$ENV{'user.domain'}}); 1644: } 1645: if ($Apache::lonnet::domain_lang_def{$ENV{'request.role.domain'}}) { 1646: @languages=(@languages, 1647: $Apache::lonnet::domain_lang_def{$ENV{'request.role.domain'}}); 1648: } 1649: if ($Apache::lonnet::domain_lang_def{ 1650: $Apache::lonnet::perlvar{'lonDefDomain'}}) { 1651: @languages=(@languages, 1652: $Apache::lonnet::domain_lang_def{ 1653: $Apache::lonnet::perlvar{'lonDefDomain'}}); 1654: } 1655: # turn "en-ca" into "en-ca,en" 1656: my @genlanguages; 1657: foreach (@languages) { 1658: unless ($_=~/\w/) { next; } 1659: push (@genlanguages,$_); 1660: if ($_=~/(\-|\_)/) { 1661: push (@genlanguages,(split(/(\-|\_)/,$_))[0]); 1662: } 1663: } 1664: return @genlanguages; 1665: } 1666: 1667: ############################################################### 1668: ## Student Answer Attempts ## 1669: ############################################################### 1670: 1671: =pod 1672: 1673: =head1 Alternate Problem Views 1674: 1675: =over 4 1676: 1677: =item * get_previous_attempt($symb, $username, $domain, $course, 1678: $getattempt, $regexp, $gradesub) 1679: 1680: Return string with previous attempt on problem. Arguments: 1681: 1682: =over 4 1683: 1684: =item * $symb: Problem, including path 1685: 1686: =item * $username: username of the desired student 1687: 1688: =item * $domain: domain of the desired student 1689: 1690: =item * $course: Course ID 1691: 1692: =item * $getattempt: Leave blank for all attempts, otherwise put 1693: something 1694: 1695: =item * $regexp: if string matches this regexp, the string will be 1696: sent to $gradesub 1697: 1698: =item * $gradesub: routine that processes the string if it matches $regexp 1699: 1700: =back 1701: 1702: The output string is a table containing all desired attempts, if any. 1703: 1704: =cut 1705: 1706: sub get_previous_attempt { 1707: my ($symb,$username,$domain,$course,$getattempt,$regexp,$gradesub)=@_; 1708: my $prevattempts=''; 1709: no strict 'refs'; 1710: if ($symb) { 1711: my (%returnhash)= 1712: &Apache::lonnet::restore($symb,$course,$domain,$username); 1713: if ($returnhash{'version'}) { 1714: my %lasthash=(); 1715: my $version; 1716: for ($version=1;$version<=$returnhash{'version'};$version++) { 1717: foreach (sort(split(/\:/,$returnhash{$version.':keys'}))) { 1718: $lasthash{$_}=$returnhash{$version.':'.$_}; 1719: } 1720: } 1721: $prevattempts='<table border="0" width="100%"><tr><td bgcolor="#777777">'; 1722: $prevattempts.='<table border="0" width="100%"><tr bgcolor="#e6ffff"><td>History</td>'; 1723: foreach (sort(keys %lasthash)) { 1724: my ($ign,@parts) = split(/\./,$_); 1725: if ($#parts > 0) { 1726: my $data=$parts[-1]; 1727: pop(@parts); 1728: $prevattempts.='<td>Part '.join('.',@parts).'<br />'.$data.' </td>'; 1729: } else { 1730: if ($#parts == 0) { 1731: $prevattempts.='<th>'.$parts[0].'</th>'; 1732: } else { 1733: $prevattempts.='<th>'.$ign.'</th>'; 1734: } 1735: } 1736: } 1737: if ($getattempt eq '') { 1738: for ($version=1;$version<=$returnhash{'version'};$version++) { 1739: $prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Transaction '.$version.'</td>'; 1740: foreach (sort(keys %lasthash)) { 1741: my $value; 1742: if ($_ =~ /timestamp/) { 1743: $value=scalar(localtime($returnhash{$version.':'.$_})); 1744: } else { 1745: $value=$returnhash{$version.':'.$_}; 1746: } 1747: $prevattempts.='<td>'.$value.' </td>'; 1748: } 1749: } 1750: } 1751: $prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Current</td>'; 1752: foreach (sort(keys %lasthash)) { 1753: my $value; 1754: if ($_ =~ /timestamp/) { 1755: $value=scalar(localtime($lasthash{$_})); 1756: } else { 1757: $value=$lasthash{$_}; 1758: } 1759: if ($_ =~/$regexp$/ && (defined &$gradesub)) {$value = &$gradesub($value)} 1760: $prevattempts.='<td>'.$value.' </td>'; 1761: } 1762: $prevattempts.='</tr></table></td></tr></table>'; 1763: } else { 1764: $prevattempts='Nothing submitted - no attempts.'; 1765: } 1766: } else { 1767: $prevattempts='No data.'; 1768: } 1769: } 1770: 1771: sub relative_to_absolute { 1772: my ($url,$output)=@_; 1773: my $parser=HTML::TokeParser->new(\$output); 1774: my $token; 1775: my $thisdir=$url; 1776: my @rlinks=(); 1777: while ($token=$parser->get_token) { 1778: if ($token->[0] eq 'S') { 1779: if ($token->[1] eq 'a') { 1780: if ($token->[2]->{'href'}) { 1781: $rlinks[$#rlinks+1]=$token->[2]->{'href'}; 1782: } 1783: } elsif ($token->[1] eq 'img' || $token->[1] eq 'embed' ) { 1784: $rlinks[$#rlinks+1]=$token->[2]->{'src'}; 1785: } elsif ($token->[1] eq 'base') { 1786: $thisdir=$token->[2]->{'href'}; 1787: } 1788: } 1789: } 1790: $thisdir=~s-/[^/]*$--; 1791: foreach (@rlinks) { 1792: unless (($_=~/^http:\/\//i) || 1793: ($_=~/^\//) || 1794: ($_=~/^javascript:/i) || 1795: ($_=~/^mailto:/i) || 1796: ($_=~/^\#/)) { 1797: my $newlocation=&Apache::lonnet::hreflocation($thisdir,$_); 1798: $output=~s/(\"|\'|\=\s*)$_(\"|\'|\s|\>)/$1$newlocation$2/; 1799: } 1800: } 1801: # -------------------------------------------------- Deal with Applet codebases 1802: $output=~s/(\<applet[^\>]+)(codebase\=[^\S\>]+)*([^\>]*)\>/$1.($2?$2:' codebase="'.$thisdir.'"').$3.'>'/gei; 1803: return $output; 1804: } 1805: 1806: =pod 1807: 1808: =item * get_student_view 1809: 1810: show a snapshot of what student was looking at 1811: 1812: =cut 1813: 1814: sub get_student_view { 1815: my ($symb,$username,$domain,$courseid,$target) = @_; 1816: my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb); 1817: my (%old,%moreenv); 1818: my @elements=('symb','courseid','domain','username'); 1819: foreach my $element (@elements) { 1820: $old{$element}=$ENV{'form.grade_'.$element}; 1821: $moreenv{'form.grade_'.$element}=eval '$'.$element #' 1822: } 1823: if ($target eq 'tex') {$moreenv{'form.grade_target'} = 'tex';} 1824: &Apache::lonnet::appenv(%moreenv); 1825: $feedurl=&Apache::lonnet::clutter($feedurl); 1826: my $userview=&Apache::lonnet::ssi_body($feedurl); 1827: &Apache::lonnet::delenv('form.grade_'); 1828: foreach my $element (@elements) { 1829: $ENV{'form.grade_'.$element}=$old{$element}; 1830: } 1831: $userview=~s/\<body[^\>]*\>//gi; 1832: $userview=~s/\<\/body\>//gi; 1833: $userview=~s/\<html\>//gi; 1834: $userview=~s/\<\/html\>//gi; 1835: $userview=~s/\<head\>//gi; 1836: $userview=~s/\<\/head\>//gi; 1837: $userview=~s/action\s*\=/would_be_action\=/gi; 1838: $userview=&relative_to_absolute($feedurl,$userview); 1839: return $userview; 1840: } 1841: 1842: =pod 1843: 1844: =item * get_student_answers() 1845: 1846: show a snapshot of how student was answering problem 1847: 1848: =cut 1849: 1850: sub get_student_answers { 1851: my ($symb,$username,$domain,$courseid,%form) = @_; 1852: my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb); 1853: my (%old,%moreenv); 1854: my @elements=('symb','courseid','domain','username'); 1855: foreach my $element (@elements) { 1856: $old{$element}=$ENV{'form.grade_'.$element}; 1857: $moreenv{'form.grade_'.$element}=eval '$'.$element #' 1858: } 1859: $moreenv{'form.grade_target'}='answer'; 1860: &Apache::lonnet::appenv(%moreenv); 1861: my $userview=&Apache::lonnet::ssi('/res/'.$feedurl,%form); 1862: &Apache::lonnet::delenv('form.grade_'); 1863: foreach my $element (@elements) { 1864: $ENV{'form.grade_'.$element}=$old{$element}; 1865: } 1866: return $userview; 1867: } 1868: 1869: =pod 1870: 1871: =item * &submlink() 1872: 1873: Inputs: $text $uname $udom $symb 1874: 1875: Returns: A link to grades.pm such as to see the SUBM view of a student 1876: 1877: =cut 1878: 1879: ############################################### 1880: sub submlink { 1881: my ($text,$uname,$udom,$symb)=@_; 1882: if (!($uname && $udom)) { 1883: (my $cursymb, my $courseid,$udom,$uname)= 1884: &Apache::lonxml::whichuser($symb); 1885: if (!$symb) { $symb=$cursymb; } 1886: } 1887: if (!$symb) { $symb=&symbread(); } 1888: return '<a href="/adm/grades?symb='.$symb.'&student='.$uname. 1889: '&userdom='.$udom.'&command=submission">'.$text.'</a>'; 1890: } 1891: ############################################## 1892: 1893: =pod 1894: 1895: =back 1896: 1897: =cut 1898: 1899: ############################################### 1900: 1901: 1902: sub timehash { 1903: my @ltime=localtime(shift); 1904: return ( 'seconds' => $ltime[0], 1905: 'minutes' => $ltime[1], 1906: 'hours' => $ltime[2], 1907: 'day' => $ltime[3], 1908: 'month' => $ltime[4]+1, 1909: 'year' => $ltime[5]+1900, 1910: 'weekday' => $ltime[6], 1911: 'dayyear' => $ltime[7]+1, 1912: 'dlsav' => $ltime[8] ); 1913: } 1914: 1915: sub maketime { 1916: my %th=@_; 1917: return POSIX::mktime( 1918: ($th{'seconds'},$th{'minutes'},$th{'hours'}, 1919: $th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,$th{'dlsav'})); 1920: } 1921: 1922: 1923: ######################################### 1924: # 1925: # Retro-fixing of un-backward-compatible time format 1926: 1927: sub unsqltime { 1928: my $timestamp=shift; 1929: if ($timestamp=~/^(\d+)\-(\d+)\-(\d+)\s+(\d+)\:(\d+)\:(\d+)$/) { 1930: $timestamp=&maketime( 1931: 'year'=>$1,'month'=>$2,'day'=>$3, 1932: 'hours'=>$4,'minutes'=>$5,'seconds'=>$6); 1933: } 1934: return $timestamp; 1935: } 1936: 1937: ######################################### 1938: 1939: sub findallcourses { 1940: my %courses=(); 1941: my $now=time; 1942: foreach (keys %ENV) { 1943: if ($_=~/^user\.role\.\w+\.\/(\w+)\/(\w+)/) { 1944: my ($starttime,$endtime)=$ENV{$_}; 1945: my $active=1; 1946: if ($starttime) { 1947: if ($now<$starttime) { $active=0; } 1948: } 1949: if ($endtime) { 1950: if ($now>$endtime) { $active=0; } 1951: } 1952: if ($active) { $courses{$1.'_'.$2}=1; } 1953: } 1954: } 1955: return keys %courses; 1956: } 1957: 1958: ############################################### 1959: ############################################### 1960: 1961: =pod 1962: 1963: =head1 Domain Template Functions 1964: 1965: =over 4 1966: 1967: =item * &determinedomain() 1968: 1969: Inputs: $domain (usually will be undef) 1970: 1971: Returns: Determines which domain should be used for designs 1972: 1973: =cut 1974: 1975: ############################################### 1976: sub determinedomain { 1977: my $domain=shift; 1978: if (! $domain) { 1979: # Determine domain if we have not been given one 1980: $domain = $Apache::lonnet::perlvar{'lonDefDomain'}; 1981: if ($ENV{'user.domain'}) { $domain=$ENV{'user.domain'}; } 1982: if ($ENV{'request.role.domain'}) { 1983: $domain=$ENV{'request.role.domain'}; 1984: } 1985: } 1986: return $domain; 1987: } 1988: ############################################### 1989: =pod 1990: 1991: =item * &domainlogo() 1992: 1993: Inputs: $domain (usually will be undef) 1994: 1995: Returns: A link to a domain logo, if the domain logo exists. 1996: If the domain logo does not exist, a description of the domain. 1997: 1998: =cut 1999: 2000: ############################################### 2001: sub domainlogo { 2002: my $domain = &determinedomain(shift); 2003: # See if there is a logo 2004: if (-e '/home/httpd/html/adm/lonDomLogos/'.$domain.'.gif') { 2005: my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'}; 2006: if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; } 2007: return '<img src="http://'.$ENV{'HTTP_HOST'}.':'.$lonhttpdPort. 2008: '/adm/lonDomLogos/'.$domain.'.gif" />'; 2009: } elsif(exists($Apache::lonnet::domaindescription{$domain})) { 2010: return $Apache::lonnet::domaindescription{$domain}; 2011: } else { 2012: return ''; 2013: } 2014: } 2015: ############################################## 2016: 2017: =pod 2018: 2019: =item * &designparm() 2020: 2021: Inputs: $which parameter; $domain (usually will be undef) 2022: 2023: Returns: value of designparamter $which 2024: 2025: =cut 2026: 2027: ############################################## 2028: sub designparm { 2029: my ($which,$domain)=@_; 2030: if ($ENV{'browser.blackwhite'} eq 'on') { 2031: if ($which=~/\.(font|alink|vlink|link)$/) { 2032: return '#000000'; 2033: } 2034: if ($which=~/\.(pgbg|sidebg)$/) { 2035: return '#FFFFFF'; 2036: } 2037: if ($which=~/\.tabbg$/) { 2038: return '#CCCCCC'; 2039: } 2040: } 2041: if ($ENV{'environment.color.'.$which}) { 2042: return $ENV{'environment.color.'.$which}; 2043: } 2044: $domain=&determinedomain($domain); 2045: if ($designhash{$domain.'.'.$which}) { 2046: return $designhash{$domain.'.'.$which}; 2047: } else { 2048: return $designhash{'default.'.$which}; 2049: } 2050: } 2051: 2052: ############################################### 2053: ############################################### 2054: 2055: =pod 2056: 2057: =back 2058: 2059: =head1 HTTP Helpers 2060: 2061: =over 4 2062: 2063: =item * &bodytag() 2064: 2065: Returns a uniform header for LON-CAPA web pages. 2066: 2067: Inputs: 2068: 2069: =over 4 2070: 2071: =item * $title, A title to be displayed on the page. 2072: 2073: =item * $function, the current role (can be undef). 2074: 2075: =item * $addentries, extra parameters for the <body> tag. 2076: 2077: =item * $bodyonly, if defined, only return the <body> tag. 2078: 2079: =item * $domain, if defined, force a given domain. 2080: 2081: =item * $forcereg, if page should register as content page (relevant for 2082: text interface only) 2083: 2084: =back 2085: 2086: Returns: A uniform header for LON-CAPA web pages. 2087: If $bodyonly is nonzero, a string containing a <body> tag will be returned. 2088: If $bodyonly is undef or zero, an html string containing a <body> tag and 2089: other decorations will be returned. 2090: 2091: =cut 2092: 2093: sub bodytag { 2094: my ($title,$function,$addentries,$bodyonly,$domain,$forcereg)=@_; 2095: $title=&mt($title); 2096: unless ($function) { 2097: $function='student'; 2098: if ($ENV{'request.role'}=~/^(cc|in|ta|ep)/) { 2099: $function='coordinator'; 2100: } 2101: if ($ENV{'request.role'}=~/^(su|dc|ad|li)/) { 2102: $function='admin'; 2103: } 2104: if (($ENV{'request.role'}=~/^(au|ca)/) || 2105: ($ENV{'REQUEST_URI'}=~/^(\/priv|\~)/)) { 2106: $function='author'; 2107: } 2108: } 2109: my $img=&designparm($function.'.img',$domain); 2110: my $pgbg=&designparm($function.'.pgbg',$domain); 2111: my $tabbg=&designparm($function.'.tabbg',$domain); 2112: my $font=&designparm($function.'.font',$domain); 2113: my $link=&designparm($function.'.link',$domain); 2114: my $alink=&designparm($function.'.alink',$domain); 2115: my $vlink=&designparm($function.'.vlink',$domain); 2116: my $sidebg=&designparm($function.'.sidebg',$domain); 2117: # Accessibility font enhance 2118: unless ($addentries) { $addentries=''; } 2119: if ($ENV{'browser.fontenhance'} eq 'on') { 2120: $addentries.=' style="font-size: x-large"'; 2121: } 2122: # role and realm 2123: my ($role,$realm) 2124: =&Apache::lonnet::plaintext((split(/\./,$ENV{'request.role'}))[0]); 2125: # realm 2126: if ($ENV{'request.course.id'}) { 2127: $realm= 2128: $ENV{'course.'.$ENV{'request.course.id'}.'.description'}; 2129: } 2130: unless ($realm) { $realm=' '; } 2131: # Set messages 2132: my $messages=&domainlogo($domain); 2133: # Port for miniserver 2134: my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'}; 2135: if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; } 2136: # construct main body tag 2137: my $bodytag = <<END; 2138: <body bgcolor="$pgbg" text="$font" alink="$alink" vlink="$vlink" link="$link" 2139: $addentries> 2140: END 2141: my $upperleft='<img src="http://'.$ENV{'HTTP_HOST'}.':'. 2142: $lonhttpdPort.$img.'" />'; 2143: if ($bodyonly) { 2144: return $bodytag; 2145: } elsif ($ENV{'browser.interface'} eq 'textual') { 2146: # Accessibility 2147: return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web', 2148: $forcereg). 2149: '<h1>LON-CAPA: '.$title.'</h1>'; 2150: } elsif ($ENV{'environment.remote'} eq 'off') { 2151: # No Remote 2152: return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web', 2153: $forcereg). 2154: '<table bgcolor="'.$pgbg.'" width="100%" border="0" cellspacing="3" cellpadding="3"><tr><td bgcolor="'.$tabbg.'"><font size="+3" color="'.$font.'"><b>'.$title. 2155: '</b></font></td></tr></table>'; 2156: } 2157: 2158: # 2159: # Top frame rendering, Remote is up 2160: # 2161: return(<<ENDBODY); 2162: $bodytag 2163: <table width="100%" cellspacing="0" border="0" cellpadding="0"> 2164: <tr><td bgcolor="$sidebg"> 2165: $upperleft</td> 2166: <td bgcolor="$sidebg" align="right">$messages </td> 2167: </tr> 2168: <tr> 2169: <td rowspan="3" bgcolor="$tabbg"> 2170: <font size="5"><b>$title</b></font> 2171: <td bgcolor="$tabbg" align="right"> 2172: <font size="2"> 2173: $ENV{'environment.firstname'} 2174: $ENV{'environment.middlename'} 2175: $ENV{'environment.lastname'} 2176: $ENV{'environment.generation'} 2177: </font> 2178: </td> 2179: </tr> 2180: <tr><td bgcolor="$tabbg" align="right"> 2181: <font size="2">$role</font> 2182: </td></tr> 2183: <tr> 2184: <td bgcolor="$tabbg" align="right"><font size="2">$realm</font> </td></tr> 2185: </table><br> 2186: ENDBODY 2187: } 2188: 2189: ############################################### 2190: 2191: sub get_posted_cgi { 2192: my $r=shift; 2193: 2194: my $buffer; 2195: 2196: $r->read($buffer,$r->header_in('Content-length'),0); 2197: unless ($buffer=~/^(\-+\w+)\s+Content\-Disposition\:\s*form\-data/si) { 2198: my @pairs=split(/&/,$buffer); 2199: my $pair; 2200: foreach $pair (@pairs) { 2201: my ($name,$value) = split(/=/,$pair); 2202: $value =~ tr/+/ /; 2203: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; 2204: $name =~ tr/+/ /; 2205: $name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; 2206: &add_to_env("form.$name",$value); 2207: } 2208: } else { 2209: my $contentsep=$1; 2210: my @lines = split (/\n/,$buffer); 2211: my $name=''; 2212: my $value=''; 2213: my $fname=''; 2214: my $fmime=''; 2215: my $i; 2216: for ($i=0;$i<=$#lines;$i++) { 2217: if ($lines[$i]=~/^$contentsep/) { 2218: if ($name) { 2219: chomp($value); 2220: if ($fname) { 2221: $ENV{"form.$name.filename"}=$fname; 2222: $ENV{"form.$name.mimetype"}=$fmime; 2223: } else { 2224: $value=~s/\s+$//s; 2225: } 2226: &add_to_env("form.$name",$value); 2227: } 2228: if ($i<$#lines) { 2229: $i++; 2230: $lines[$i]=~ 2231: /Content\-Disposition\:\s*form\-data\;\s*name\=\"([^\"]+)\"/i; 2232: $name=$1; 2233: $value=''; 2234: if ($lines[$i]=~/filename\=\"([^\"]+)\"/i) { 2235: $fname=$1; 2236: if 2237: ($lines[$i+1]=~/Content\-Type\:\s*([\w\-\/]+)/i) { 2238: $fmime=$1; 2239: $i++; 2240: } else { 2241: $fmime=''; 2242: } 2243: } else { 2244: $fname=''; 2245: $fmime=''; 2246: } 2247: $i++; 2248: } 2249: } else { 2250: $value.=$lines[$i]."\n"; 2251: } 2252: } 2253: } 2254: $ENV{'request.method'}=$ENV{'REQUEST_METHOD'}; 2255: $r->method_number(M_GET); 2256: $r->method('GET'); 2257: $r->headers_in->unset('Content-length'); 2258: } 2259: 2260: =pod 2261: 2262: =item * get_unprocessed_cgi($query,$possible_names) 2263: 2264: Modify the %ENV hash to contain unprocessed CGI form parameters held in 2265: $query. The parameters listed in $possible_names (an array reference), 2266: will be set in $ENV{'form.name'} if they do not already exist. 2267: 2268: Typically called with $ENV{'QUERY_STRING'} as the first parameter. 2269: $possible_names is an ref to an array of form element names. As an example: 2270: get_unprocessed_cgi($ENV{'QUERY_STRING'},['uname','udom']); 2271: will result in $ENV{'form.uname'} and $ENV{'form.udom'} being set. 2272: 2273: =cut 2274: 2275: sub get_unprocessed_cgi { 2276: my ($query,$possible_names)= @_; 2277: # $Apache::lonxml::debug=1; 2278: foreach (split(/&/,$query)) { 2279: my ($name, $value) = split(/=/,$_); 2280: $name = &Apache::lonnet::unescape($name); 2281: if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) { 2282: $value =~ tr/+/ /; 2283: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; 2284: &Apache::lonxml::debug("Seting :$name: to :$value:"); 2285: unless (defined($ENV{'form.'.$name})) { &add_to_env('form.'.$name,$value) }; 2286: } 2287: } 2288: } 2289: 2290: =pod 2291: 2292: =item * cacheheader() 2293: 2294: returns cache-controlling header code 2295: 2296: =cut 2297: 2298: sub cacheheader { 2299: unless ($ENV{'request.method'} eq 'GET') { return ''; } 2300: my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime); 2301: my $output .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" /> 2302: <meta HTTP-EQUIV="Cache-control" CONTENT="no-cache" /> 2303: <meta HTTP-EQUIV="Pragma" CONTENT="no-cache" />'; 2304: return $output; 2305: } 2306: 2307: =pod 2308: 2309: =item * no_cache($r) 2310: 2311: specifies header code to not have cache 2312: 2313: =cut 2314: 2315: sub no_cache { 2316: my ($r) = @_; 2317: unless ($ENV{'request.method'} eq 'GET') { return ''; } 2318: #my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime); 2319: $r->no_cache(1); 2320: $r->header_out("Pragma" => "no-cache"); 2321: #$r->header_out("Expires" => $date); 2322: } 2323: 2324: =pod 2325: 2326: =item * add_to_env($name,$value) 2327: 2328: adds $name to the %ENV hash with value 2329: $value, if $name already exists, the entry is converted to an array 2330: reference and $value is added to the array. 2331: 2332: =cut 2333: 2334: sub add_to_env { 2335: my ($name,$value)=@_; 2336: if (defined($ENV{$name})) { 2337: if (ref($ENV{$name})) { 2338: #already have multiple values 2339: push(@{ $ENV{$name} },$value); 2340: } else { 2341: #first time seeing multiple values, convert hash entry to an arrayref 2342: my $first=$ENV{$name}; 2343: undef($ENV{$name}); 2344: push(@{ $ENV{$name} },$first,$value); 2345: } 2346: } else { 2347: $ENV{$name}=$value; 2348: } 2349: } 2350: 2351: =pod 2352: 2353: =back 2354: 2355: =head1 CSV Upload/Handling functions 2356: 2357: =over 4 2358: 2359: =item * upfile_store($r) 2360: 2361: Store uploaded file, $r should be the HTTP Request object, 2362: needs $ENV{'form.upfile'} 2363: returns $datatoken to be put into hidden field 2364: 2365: =cut 2366: 2367: sub upfile_store { 2368: my $r=shift; 2369: $ENV{'form.upfile'}=~s/\r/\n/gs; 2370: $ENV{'form.upfile'}=~s/\f/\n/gs; 2371: $ENV{'form.upfile'}=~s/\n+/\n/gs; 2372: $ENV{'form.upfile'}=~s/\n+$//gs; 2373: 2374: my $datatoken=$ENV{'user.name'}.'_'.$ENV{'user.domain'}. 2375: '_enroll_'.$ENV{'request.course.id'}.'_'.time.'_'.$$; 2376: { 2377: my $fh=Apache::File->new('>'.$r->dir_config('lonDaemons'). 2378: '/tmp/'.$datatoken.'.tmp'); 2379: print $fh $ENV{'form.upfile'}; 2380: } 2381: return $datatoken; 2382: } 2383: 2384: =pod 2385: 2386: =item * load_tmp_file($r) 2387: 2388: Load uploaded file from tmp, $r should be the HTTP Request object, 2389: needs $ENV{'form.datatoken'}, 2390: sets $ENV{'form.upfile'} to the contents of the file 2391: 2392: =cut 2393: 2394: sub load_tmp_file { 2395: my $r=shift; 2396: my @studentdata=(); 2397: { 2398: my $fh; 2399: if ($fh=Apache::File->new($r->dir_config('lonDaemons'). 2400: '/tmp/'.$ENV{'form.datatoken'}.'.tmp')) { 2401: @studentdata=<$fh>; 2402: } 2403: } 2404: $ENV{'form.upfile'}=join('',@studentdata); 2405: } 2406: 2407: =pod 2408: 2409: =item * upfile_record_sep() 2410: 2411: Separate uploaded file into records 2412: returns array of records, 2413: needs $ENV{'form.upfile'} and $ENV{'form.upfiletype'} 2414: 2415: =cut 2416: 2417: sub upfile_record_sep { 2418: if ($ENV{'form.upfiletype'} eq 'xml') { 2419: } else { 2420: return split(/\n/,$ENV{'form.upfile'}); 2421: } 2422: } 2423: 2424: =pod 2425: 2426: =item * record_sep($record) 2427: 2428: Separate a record into fields $record should be an item from the upfile_record_sep(), needs $ENV{'form.upfiletype'} 2429: 2430: =cut 2431: 2432: sub record_sep { 2433: my $record=shift; 2434: my %components=(); 2435: if ($ENV{'form.upfiletype'} eq 'xml') { 2436: } elsif ($ENV{'form.upfiletype'} eq 'space') { 2437: my $i=0; 2438: foreach (split(/\s+/,$record)) { 2439: my $field=$_; 2440: $field=~s/^(\"|\')//; 2441: $field=~s/(\"|\')$//; 2442: $components{$i}=$field; 2443: $i++; 2444: } 2445: } elsif ($ENV{'form.upfiletype'} eq 'tab') { 2446: my $i=0; 2447: foreach (split(/\t+/,$record)) { 2448: my $field=$_; 2449: $field=~s/^(\"|\')//; 2450: $field=~s/(\"|\')$//; 2451: $components{$i}=$field; 2452: $i++; 2453: } 2454: } else { 2455: my @allfields=split(/\,/,$record); 2456: my $i=0; 2457: my $j; 2458: for ($j=0;$j<=$#allfields;$j++) { 2459: my $field=$allfields[$j]; 2460: if ($field=~/^\s*(\"|\')/) { 2461: my $delimiter=$1; 2462: while (($field!~/$delimiter$/) && ($j<$#allfields)) { 2463: $j++; 2464: $field.=','.$allfields[$j]; 2465: } 2466: $field=~s/^\s*$delimiter//; 2467: $field=~s/$delimiter\s*$//; 2468: } 2469: $components{$i}=$field; 2470: $i++; 2471: } 2472: } 2473: return %components; 2474: } 2475: 2476: =pod 2477: 2478: =item * upfile_select_html() 2479: 2480: return HTML code to select file and specify its type 2481: 2482: =cut 2483: 2484: sub upfile_select_html { 2485: return (<<'ENDUPFORM'); 2486: <input type="file" name="upfile" size="50" /> 2487: <br />Type: <select name="upfiletype"> 2488: <option value="csv">CSV (comma separated values, spreadsheet)</option> 2489: <option value="space">Space separated</option> 2490: <option value="tab">Tabulator separated</option> 2491: <option value="xml">HTML/XML</option> 2492: </select> 2493: ENDUPFORM 2494: } 2495: 2496: =pod 2497: 2498: =item * csv_print_samples($r,$records) 2499: 2500: Prints a table of sample values from each column uploaded $r is an 2501: Apache Request ref, $records is an arrayref from 2502: &Apache::loncommon::upfile_record_sep 2503: 2504: =cut 2505: 2506: sub csv_print_samples { 2507: my ($r,$records) = @_; 2508: my (%sone,%stwo,%sthree); 2509: %sone=&record_sep($$records[0]); 2510: if (defined($$records[1])) {%stwo=&record_sep($$records[1]);} 2511: if (defined($$records[2])) {%sthree=&record_sep($$records[2]);} 2512: 2513: $r->print('Samples<br /><table border="2"><tr>'); 2514: foreach (sort({$a <=> $b} keys(%sone))) { $r->print('<th>Column '.($_+1).'</th>'); } 2515: $r->print('</tr>'); 2516: foreach my $hash (\%sone,\%stwo,\%sthree) { 2517: $r->print('<tr>'); 2518: foreach (sort({$a <=> $b} keys(%sone))) { 2519: $r->print('<td>'); 2520: if (defined($$hash{$_})) { $r->print($$hash{$_}); } 2521: $r->print('</td>'); 2522: } 2523: $r->print('</tr>'); 2524: } 2525: $r->print('</tr></table><br />'."\n"); 2526: } 2527: 2528: =pod 2529: 2530: =item * csv_print_select_table($r,$records,$d) 2531: 2532: Prints a table to create associations between values and table columns. 2533: $r is an Apache Request ref, 2534: $records is an arrayref from &Apache::loncommon::upfile_record_sep, 2535: $d is an array of 2 element arrays (internal name, displayed name) 2536: 2537: =cut 2538: 2539: sub csv_print_select_table { 2540: my ($r,$records,$d) = @_; 2541: my $i=0;my %sone; 2542: %sone=&record_sep($$records[0]); 2543: $r->print('Associate columns with student attributes.'."\n". 2544: '<table border="2"><tr><th>Attribute</th><th>Column</th></tr>'."\n"); 2545: foreach (@$d) { 2546: my ($value,$display)=@{ $_ }; 2547: $r->print('<tr><td>'.$display.'</td>'); 2548: 2549: $r->print('<td><select name=f'.$i. 2550: ' onchange="javascript:flip(this.form,'.$i.');">'); 2551: $r->print('<option value="none"></option>'); 2552: foreach (sort({$a <=> $b} keys(%sone))) { 2553: $r->print('<option value="'.$_.'">Column '.($_+1).'</option>'); 2554: } 2555: $r->print('</select></td></tr>'."\n"); 2556: $i++; 2557: } 2558: $i--; 2559: return $i; 2560: } 2561: 2562: =pod 2563: 2564: =item * csv_samples_select_table($r,$records,$d) 2565: 2566: Prints a table of sample values from the upload and can make associate samples to internal names. 2567: 2568: $r is an Apache Request ref, 2569: $records is an arrayref from &Apache::loncommon::upfile_record_sep, 2570: $d is an array of 2 element arrays (internal name, displayed name) 2571: 2572: =cut 2573: 2574: sub csv_samples_select_table { 2575: my ($r,$records,$d) = @_; 2576: my %sone; my %stwo; my %sthree; 2577: my $i=0; 2578: 2579: $r->print('<table border=2><tr><th>Field</th><th>Samples</th></tr>'); 2580: %sone=&record_sep($$records[0]); 2581: if (defined($$records[1])) {%stwo=&record_sep($$records[1]);} 2582: if (defined($$records[2])) {%sthree=&record_sep($$records[2]);} 2583: 2584: foreach (sort keys %sone) { 2585: $r->print('<tr><td><select name=f'.$i. 2586: ' onchange="javascript:flip(this.form,'.$i.');">'); 2587: foreach (@$d) { 2588: my ($value,$display)=@{ $_ }; 2589: $r->print('<option value='.$value.'>'.$display.'</option>'); 2590: } 2591: $r->print('</select></td><td>'); 2592: if (defined($sone{$_})) { $r->print($sone{$_}."</br>\n"); } 2593: if (defined($stwo{$_})) { $r->print($stwo{$_}."</br>\n"); } 2594: if (defined($sthree{$_})) { $r->print($sthree{$_}."</br>\n"); } 2595: $r->print('</td></tr>'); 2596: $i++; 2597: } 2598: $i--; 2599: return($i); 2600: } 2601: 2602: =pod 2603: 2604: =item clean_excel_name($name) 2605: 2606: Returns a replacement for $name which does not contain any illegal characters. 2607: 2608: =cut 2609: 2610: sub clean_excel_name { 2611: my ($name) = @_; 2612: $name =~ s/[:\*\?\/\\]//g; 2613: if (length($name) > 31) { 2614: $name = substr($name,0,31); 2615: } 2616: return $name; 2617: } 2618: 2619: =pod 2620: 2621: =item * check_if_partid_hidden($id,$symb,$udom,$uname) 2622: 2623: Returns either 1 or undef 2624: 2625: 1 if the part is to be hidden, undef if it is to be shown 2626: 2627: Arguments are: 2628: 2629: $id the id of the part to be checked 2630: $symb, optional the symb of the resource to check 2631: $udom, optional the domain of the user to check for 2632: $uname, optional the username of the user to check for 2633: 2634: =cut 2635: 2636: sub check_if_partid_hidden { 2637: my ($id,$symb,$udom,$uname) = @_; 2638: my $hiddenparts=&Apache::lonnet::EXT('resource.0.parameter_hiddenparts', 2639: $symb,$udom,$uname); 2640: my @hiddenlist=split(/,/,$hiddenparts); 2641: foreach my $checkid (@hiddenlist) { 2642: if ($checkid =~ /^\s*\Q$id\E\s*$/) { return 1; } 2643: } 2644: return undef; 2645: } 2646: 2647: =pod 2648: 2649: =back 2650: 2651: =cut 2652: 2653: 1; 2654: __END__; 2655: