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