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