loncom/interface/loncommon.pm - view

File: [LON-CAPA] / loncom / interface / loncommon.pm
Revision 1.246: download - view: text, annotated - select for diffs
Fri Jan 14 21:15:09 2005 UTC (19 years, 4 months ago) by matthew
Branches: MAIN
CVS tags: version_1_3_X, version_1_3_3, version_1_3_2, HEAD

Bug 3390: When outputting number of attempts, indicate those who did not
get the problem correct by prepending '-' to the number.  Added
'non_html_notes' so I can warn the instructor about the negative values.

1: # The LearningOnline Network with CAPA 2: # a pile of common routines 3: # 4: # $Id: loncommon.pm,v 1.246 2005/01/14 21:15:09 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: 29: # Makes a table out of the previous attempts 30: # Inputs result_from_symbread, user, domain, course_id 31: # Reads in non-network-related .tab files 32: 33: # POD header: 34: 35: =pod 36: 37: =head1 NAME 38: 39: Apache::loncommon - pile of common routines 40: 41: =head1 SYNOPSIS 42: 43: Common routines for manipulating connections, student answers, 44: domains, common Javascript fragments, etc. 45: 46: =head1 OVERVIEW 47: 48: A collection of commonly used subroutines that don't have a natural 49: home anywhere else. This collection helps remove 50: redundancy from other modules and increase efficiency of memory usage. 51: 52: =cut 53: 54: # End of POD header 55: package Apache::loncommon; 56: 57: use strict; 58: use Apache::lonnet(); 59: use GDBM_File; 60: use POSIX qw(strftime mktime); 61: use Apache::Constants qw(:common :http :methods); 62: use Apache::lonmenu(); 63: use Apache::lonlocal; 64: use HTML::Entities; 65: 66: my $readit; 67: 68: ## 69: ## Global Variables 70: ## 71: 72: # ----------------------------------------------- Filetypes/Languages/Copyright 73: my %language; 74: my %supported_language; 75: my %cprtag; 76: my %scprtag; 77: my %fe; my %fd; 78: my %category_extensions; 79: 80: # ---------------------------------------------- Designs 81: 82: my %designhash; 83: 84: # ---------------------------------------------- Thesaurus variables 85: # 86: # %Keywords: 87: # A hash used by &keyword to determine if a word is considered a keyword. 88: # $thesaurus_db_file 89: # Scalar containing the full path to the thesaurus database. 90: 91: my %Keywords; 92: my $thesaurus_db_file; 93: 94: # 95: # Initialize values from language.tab, copyright.tab, filetypes.tab, 96: # thesaurus.tab, and filecategories.tab. 97: # 98: BEGIN { 99: # Variable initialization 100: $thesaurus_db_file = $Apache::lonnet::perlvar{'lonTabDir'}."/thesaurus.db"; 101: # 102: unless ($readit) { 103: # ------------------------------------------------------------------- languages 104: { 105: my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}. 106: '/language.tab'; 107: if ( open(my $fh,"<$langtabfile") ) { 108: while (<$fh>) { 109: next if /^\#/; 110: chomp; 111: my ($key,$two,$country,$three,$enc,$val,$sup)=(split(/\t/,$_)); 112: $language{$key}=$val.' - '.$enc; 113: if ($sup) { 114: $supported_language{$key}=$sup; 115: } 116: } 117: close($fh); 118: } 119: } 120: # ------------------------------------------------------------------ copyrights 121: { 122: my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. 123: '/copyright.tab'; 124: if ( open (my $fh,"<$copyrightfile") ) { 125: while (<$fh>) { 126: next if /^\#/; 127: chomp; 128: my ($key,$val)=(split(/\s+/,$_,2)); 129: $cprtag{$key}=$val; 130: } 131: close($fh); 132: } 133: } 134: # ------------------------------------------------------------------ source copyrights 135: { 136: my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. 137: '/source_copyright.tab'; 138: if ( open (my $fh,"<$sourcecopyrightfile") ) { 139: while (<$fh>) { 140: next if /^\#/; 141: chomp; 142: my ($key,$val)=(split(/\s+/,$_,2)); 143: $scprtag{$key}=$val; 144: } 145: close($fh); 146: } 147: } 148: 149: # -------------------------------------------------------------- domain designs 150: 151: my $filename; 152: my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors'; 153: opendir(DIR,$designdir); 154: while ($filename=readdir(DIR)) { 155: my ($domain)=($filename=~/^(\w+)\./); 156: { 157: my $designfile = $designdir.'/'.$filename; 158: if ( open (my $fh,"<$designfile") ) { 159: while (<$fh>) { 160: next if /^\#/; 161: chomp; 162: my ($key,$val)=(split(/\=/,$_)); 163: if ($val) { $designhash{$domain.'.'.$key}=$val; } 164: } 165: close($fh); 166: } 167: } 168: 169: } 170: closedir(DIR); 171: 172: 173: # ------------------------------------------------------------- file categories 174: { 175: my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}. 176: '/filecategories.tab'; 177: if ( open (my $fh,"<$categoryfile") ) { 178: while (<$fh>) { 179: next if /^\#/; 180: chomp; 181: my ($extension,$category)=(split(/\s+/,$_,2)); 182: push @{$category_extensions{lc($category)}},$extension; 183: } 184: close($fh); 185: } 186: 187: } 188: # ------------------------------------------------------------------ file types 189: { 190: my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}. 191: '/filetypes.tab'; 192: if ( open (my $fh,"<$typesfile") ) { 193: while (<$fh>) { 194: next if (/^\#/); 195: chomp; 196: my ($ending,$emb,$descr)=split(/\s+/,$_,3); 197: if ($descr ne '') { 198: $fe{$ending}=lc($emb); 199: $fd{$ending}=$descr; 200: } 201: } 202: close($fh); 203: } 204: } 205: &Apache::lonnet::logthis( 206: "<font color=yellow>INFO: Read file types</font>"); 207: $readit=1; 208: } # end of unless($readit) 209: 210: } 211: 212: ############################################################### 213: ## HTML and Javascript Helper Functions ## 214: ############################################################### 215: 216: =pod 217: 218: =head1 HTML and Javascript Functions 219: 220: =over 4 221: 222: =item * browser_and_searcher_javascript () 223: 224: X<browsing, javascript>X<searching, javascript>Returns a string 225: containing javascript with two functions, C<openbrowser> and 226: C<opensearcher>. Returned string does not contain E<lt>scriptE<gt> 227: tags. 228: 229: =item * openbrowser(formname,elementname,only,omit) [javascript] 230: 231: inputs: formname, elementname, only, omit 232: 233: formname and elementname indicate the name of the html form and name of 234: the element that the results of the browsing selection are to be placed in. 235: 236: Specifying 'only' will restrict the browser to displaying only files 237: with the given extension. Can be a comma separated list. 238: 239: Specifying 'omit' will restrict the browser to NOT displaying files 240: with the given extension. Can be a comma separated list. 241: 242: =item * opensearcher(formname, elementname) [javascript] 243: 244: Inputs: formname, elementname 245: 246: formname and elementname specify the name of the html form and the name 247: of the element the selection from the search results will be placed in. 248: 249: =cut 250: 251: sub browser_and_searcher_javascript { 252: my ($mode)=@_; 253: if (!defined($mode)) { $mode='edit'; } 254: my $resurl=&lastresurl(); 255: return <<END; 256: //  310: END 311: } 312: 313: sub lastresurl { 314: if ($ENV{'environment.lastresurl'}) { 315: return $ENV{'environment.lastresurl'} 316: } else { 317: return '/res'; 318: } 319: } 320: 321: sub storeresurl { 322: my $resurl=&Apache::lonnet::clutter(shift); 323: unless ($resurl=~/^\/res/) { return 0; } 324: $resurl=~s/\/$//; 325: &Apache::lonnet::put('environment',{'lastresurl' => $resurl}); 326: &Apache::lonnet::appenv('environment.lastresurl' => $resurl); 327: return 1; 328: } 329: 330: sub studentbrowser_javascript { 331: unless ( 332: (($ENV{'request.course.id'}) && 333: (&Apache::lonnet::allowed('srm',$ENV{'request.course.id'}))) 334: || ($ENV{'request.role'}=~/^(au|dc|su)/) 335: ) { return ''; } 336: return (<<'ENDSTDBRW'); 337: <script type="text/javascript" language="Javascript" > 338: var stdeditbrowser; 339: function openstdbrowser(formname,uname,udom,roleflag) { 340: var url = '/adm/pickstudent?'; 341: var filter; 342: eval('filter=document.'+formname+'.'+uname+'.value;'); 343: if (filter != null) { 344: if (filter != '') { 345: url += 'filter='+filter+'&'; 346: } 347: } 348: url += 'form=' + formname + '&unameelement='+uname+ 349: '&udomelement='+udom; 350: if (roleflag) { url+="&roles=1"; } 351: var title = 'Student_Browser'; 352: var options = 'scrollbars=1,resizable=1,menubar=0'; 353: options += ',width=700,height=600'; 354: stdeditbrowser = open(url,title,options,'1'); 355: stdeditbrowser.focus(); 356: } 357: </script> 358: ENDSTDBRW 359: } 360: 361: sub selectstudent_link { 362: my ($form,$unameele,$udomele)=@_; 363: if ($ENV{'request.course.id'}) { 364: unless (&Apache::lonnet::allowed('srm',$ENV{'request.course.id'})) { 365: return ''; 366: } 367: return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele. 368: '","'.$udomele.'");'."'>".&mt('Select User')."</a>"; 369: } 370: if ($ENV{'request.role'}=~/^(au|dc|su)/) { 371: return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele. 372: '","'.$udomele.'",1);'."'>".&mt('Select User')."</a>"; 373: } 374: return ''; 375: } 376: 377: sub coursebrowser_javascript { 378: my ($domainfilter)=@_; 379: return (<<ENDSTDBRW); 380: <script type="text/javascript" language="Javascript" > 381: var stdeditbrowser; 382: function opencrsbrowser(formname,uname,udom,desc,extra_element) { 383: var url = '/adm/pickcourse?'; 384: var filter; 385: if (filter != null) { 386: if (filter != '') { 387: url += 'filter='+filter+'&'; 388: } 389: } 390: var domainfilter='$domainfilter'; 391: if (domainfilter != null) { 392: if (domainfilter != '') { 393: url += 'domainfilter='+domainfilter+'&'; 394: } 395: } 396: url += 'form=' + formname + '&cnumelement='+uname+ 397: '&cdomelement='+udom+ 398: '&cnameelement='+desc; 399: if (extra_element !=null && extra_element != '' && formname == 'rolechoice') { 400: url += '&roleelement='+extra_element; 401: if (domainfilter == null || domainfilter == '') { 402: url += '&domainfilter='+extra_element; 403: } 404: } 405: var title = 'Course_Browser'; 406: var options = 'scrollbars=1,resizable=1,menubar=0'; 407: options += ',width=700,height=600'; 408: stdeditbrowser = open(url,title,options,'1'); 409: stdeditbrowser.focus(); 410: } 411: </script> 412: ENDSTDBRW 413: } 414: 415: sub selectcourse_link { 416: my ($form,$unameele,$udomele,$desc,$extra_element)=@_; 417: return "<a href='".'javascript:opencrsbrowser("'.$form.'","'.$unameele. 418: '","'.$udomele.'","'.$desc.'","'.$extra_element.'");'."'>".&mt('Select Course')."</a>"; 419: } 420: 421: =pod 422: 423: =item * linked_select_forms(...) 424: 425: linked_select_forms returns a string containing a <script></script> block 426: and html for two <select> menus. The select menus will be linked in that 427: changing the value of the first menu will result in new values being placed 428: in the second menu. The values in the select menu will appear in alphabetical 429: order. 430: 431: linked_select_forms takes the following ordered inputs: 432: 433: =over 4 434: 435: =item * $formname, the name of the <form> tag 436: 437: =item * $middletext, the text which appears between the <select> tags 438: 439: =item * $firstdefault, the default value for the first menu 440: 441: =item * $firstselectname, the name of the first <select> tag 442: 443: =item * $secondselectname, the name of the second <select> tag 444: 445: =item * $hashref, a reference to a hash containing the data for the menus. 446: 447: =back 448: 449: Below is an example of such a hash. Only the 'text', 'default', and 450: 'select2' keys must appear as stated. keys(%menu) are the possible 451: values for the first select menu. The text that coincides with the 452: first menu value is given in $menu{$choice1}->{'text'}. The values 453: and text for the second menu are given in the hash pointed to by 454: $menu{$choice1}->{'select2'}. 455: 456: my %menu = ( A1 => { text =>"Choice A1" , 457: default => "B3", 458: select2 => { 459: B1 => "Choice B1", 460: B2 => "Choice B2", 461: B3 => "Choice B3", 462: B4 => "Choice B4" 463: } 464: }, 465: A2 => { text =>"Choice A2" , 466: default => "C2", 467: select2 => { 468: C1 => "Choice C1", 469: C2 => "Choice C2", 470: C3 => "Choice C3" 471: } 472: }, 473: A3 => { text =>"Choice A3" , 474: default => "D6", 475: select2 => { 476: D1 => "Choice D1", 477: D2 => "Choice D2", 478: D3 => "Choice D3", 479: D4 => "Choice D4", 480: D5 => "Choice D5", 481: D6 => "Choice D6", 482: D7 => "Choice D7" 483: } 484: } 485: ); 486: 487: =cut 488: 489: sub linked_select_forms { 490: my ($formname, 491: $middletext, 492: $firstdefault, 493: $firstselectname, 494: $secondselectname, 495: $hashref 496: ) = @_; 497: my $second = "document.$formname.$secondselectname"; 498: my $first = "document.$formname.$firstselectname"; 499: # output the javascript to do the changing 500: my $result = ''; 501: $result.="<script type=\"text/javascript\">\n"; 502: $result.="var select2data = new Object();\n"; 503: $" = '","'; 504: my $debug = ''; 505: foreach my $s1 (sort(keys(%$hashref))) { 506: $result.="select2data.d_$s1 = new Object();\n"; 507: $result.="select2data.d_$s1.def = new String('". 508: $hashref->{$s1}->{'default'}."');\n"; 509: $result.="select2data.d_$s1.values = new Array("; 510: my @s2values = sort(keys( %{ $hashref->{$s1}->{'select2'} } )); 511: $result.="\"@s2values\");\n"; 512: $result.="select2data.d_$s1.texts = new Array("; 513: my @s2texts; 514: foreach my $value (@s2values) { 515: push @s2texts, $hashref->{$s1}->{'select2'}->{$value}; 516: } 517: $result.="\"@s2texts\");\n"; 518: } 519: $"=' '; 520: $result.= <<"END"; 521: 522: function select1_changed() { 523: // Determine new choice 524: var newvalue = "d_" + $first.value; 525: // update select2 526: var values = select2data[newvalue].values; 527: var texts = select2data[newvalue].texts; 528: var select2def = select2data[newvalue].def; 529: var i; 530: // out with the old 531: for (i = 0; i < $second.options.length; i++) { 532: $second.options[i] = null; 533: } 534: // in with the nuclear 535: for (i=0;i<values.length; i++) { 536: $second.options[i] = new Option(values[i]); 537: $second.options[i].value = values[i]; 538: $second.options[i].text = texts[i]; 539: if (values[i] == select2def) { 540: $second.options[i].selected = true; 541: } 542: } 543: } 544: </script> 545: END 546: # output the initial values for the selection lists 547: $result .= "<select size=\"1\" name=\"$firstselectname\" onchange=\"select1_changed()\">\n"; 548: foreach my $value (sort(keys(%$hashref))) { 549: $result.=" <option value=\"$value\" "; 550: $result.=" selected=\"true\" " if ($value eq $firstdefault); 551: $result.=">".&mt($hashref->{$value}->{'text'})."</option>\n"; 552: } 553: $result .= "</select>\n"; 554: my %select2 = %{$hashref->{$firstdefault}->{'select2'}}; 555: $result .= $middletext; 556: $result .= "<select size=\"1\" name=\"$secondselectname\">\n"; 557: my $seconddefault = $hashref->{$firstdefault}->{'default'}; 558: foreach my $value (sort(keys(%select2))) { 559: $result.=" <option value=\"$value\" "; 560: $result.=" selected=\"true\" " if ($value eq $seconddefault); 561: $result.=">".&mt($select2{$value})."</option>\n"; 562: } 563: $result .= "</select>\n"; 564: # return $debug; 565: return $result; 566: } # end of sub linked_select_forms { 567: 568: =pod 569: 570: =item * help_open_topic($topic, $text, $stayOnPage, $width, $height) 571: 572: Returns a string corresponding to an HTML link to the given help 573: $topic, where $topic corresponds to the name of a .tex file in 574: /home/httpd/html/adm/help/tex, with underscores replaced by 575: spaces. 576: 577: $text will optionally be linked to the same topic, allowing you to 578: link text in addition to the graphic. If you do not want to link 579: text, but wish to specify one of the later parameters, pass an 580: empty string. 581: 582: $stayOnPage is a value that will be interpreted as a boolean. If true, 583: the link will not open a new window. If false, the link will open 584: a new window using Javascript. (Default is false.) 585: 586: $width and $height are optional numerical parameters that will 587: override the width and height of the popped up window, which may 588: be useful for certain help topics with big pictures included. 589: 590: =cut 591: 592: sub help_open_topic { 593: my ($topic, $text, $stayOnPage, $width, $height) = @_; 594: $text = "" if (not defined $text); 595: $stayOnPage = 0 if (not defined $stayOnPage); 596: if ($ENV{'browser.interface'} eq 'textual' || 597: $ENV{'environment.remote'} eq 'off' ) { 598: $stayOnPage=1; 599: } 600: $width = 350 if (not defined $width); 601: $height = 400 if (not defined $height); 602: my $filename = $topic; 603: $filename =~ s/ /_/g; 604: 605: my $template = ""; 606: my $link; 607: 608: $topic=~s/\W/\_/g; 609: 610: if (!$stayOnPage) 611: { 612: $link = "javascript:void(open('/adm/help/${filename}.hlp', 'Help_for_$topic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))"; 613: } 614: else 615: { 616: $link = "/adm/help/${filename}.hlp"; 617: } 618: 619: # Add the text 620: if ($text ne "") 621: { 622: $template .= 623: "<table bgcolor='#3333AA' cellspacing='1' cellpadding='1' border='0'><tr>". 624: "<td bgcolor='#5555FF'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>"; 625: } 626: 627: # Add the graphic 628: my $title = &mt('Online Help'); 629: my $helpicon=&lonhttpdurl("/adm/help/gif/smallHelp.gif"); 630: $template .= <<"ENDTEMPLATE"; 631: <a href="$link" title="$title"><img src="$helpicon" border="0" alt="(Help: $topic)" /></a> 632: ENDTEMPLATE 633: if ($text ne '') { $template.='</td></tr></table>' }; 634: return $template; 635: 636: } 637: 638: # This is a quicky function for Latex cheatsheet editing, since it 639: # appears in at least four places 640: sub helpLatexCheatsheet { 641: my $other = shift; 642: my $addOther = ''; 643: if ($other) { 644: $addOther = Apache::loncommon::help_open_topic($other, shift, 645: undef, undef, 600) . 646: '</td><td>'; 647: } 648: return '<table><tr><td>'. 649: $addOther . 650: &Apache::loncommon::help_open_topic("Greek_Symbols",'Greek Symbols', 651: undef,undef,600) 652: .'</td><td>'. 653: &Apache::loncommon::help_open_topic("Other_Symbols",'Other Symbols', 654: undef,undef,600) 655: .'</td></tr></table>'; 656: } 657: 658: sub help_open_menu { 659: my ($color,$topic,$component_help,$function,$faq,$bug,$stayOnPage,$width,$height,$text) = @_; 660: $text = "" if (not defined $text); 661: $stayOnPage = 0 if (not defined $stayOnPage); 662: if ($ENV{'browser.interface'} eq 'textual' || 663: $ENV{'environment.remote'} eq 'off' ) { 664: $stayOnPage=1; 665: } 666: $width = 620 if (not defined $width); 667: $height = 600 if (not defined $height); 668: my $link=''; 669: my $title = &mt('Get help'); 670: my $origurl = $ENV{'REQUEST_URI'}; 671: $origurl=~s|^/~|/priv/|; 672: my $timestamp = time; 673: foreach (\$color,\$function,\$topic,\$component_help,\$faq,\$bug,\$origurl) { 674: $$_ = &Apache::lonnet::escape($$_); 675: } 676: 677: if (!$stayOnPage) { 678: $link = "javascript:helpMenu('open')"; 679: } else { 680: $link = "javascript:helpMenu('display')"; 681: } 682: my $banner_link = "/adm/helpmenu?page=banner&color=$color&function=$function&topic=$topic&component_help=$component_help&faq=$faq&bug=$bug&origurl=$origurl&stamp=$timestamp&stayonpage=$stayOnPage"; 683: my $details_link = "/adm/helpmenu?page=body&color=$color&function=$function&topic=$topic&component_help=$component_help&faq=$faq&bug=$bug&origurl=$origurl&stamp=$timestamp"; 684: my $template; 685: if ($text ne "") { 686: $template .= 687: "<table bgcolor='#773311' cellspacing='1' cellpadding='1' border='0'><tr>". 688: "<td bgcolor='#886622'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>"; 689: } 690: my $helpicon=&lonhttpdurl("/adm/lonIcons/helpgateway.gif"); 691: $template .= <<"ENDTEMPLATE"; 692: <script type="text/javascript"> 693: // 720: </script> 721: <a href="$link" title="$title"><img src="$helpicon" border="0" alt="(Help Menu)" /></a> 722: ENDTEMPLATE 723: if ($component_help) { 724: if (!$text) { 725: $template=&help_open_topic($component_help,undef,$stayOnPage, 726: $width,$height).' '.$template; 727: } else { 728: my $help_text; 729: $help_text=&Apache::lonnet::unescape($topic); 730: $template='<table><tr><td>'. 731: &help_open_topic($component_help,$help_text,$stayOnPage, 732: $width,$height).'</td><td>'.$template. 733: '</td></tr></table>'; 734: } 735: } 736: if ($text ne '') { $template.='</td></tr></table>' }; 737: return $template; 738: } 739: 740: sub help_open_bug { 741: my ($topic, $text, $stayOnPage, $width, $height) = @_; 742: unless ($ENV{'user.adv'}) { return ''; } 743: unless ($Apache::lonnet::perlvar{'BugzillaHost'}) { return ''; } 744: $text = "" if (not defined $text); 745: $stayOnPage = 0 if (not defined $stayOnPage); 746: if ($ENV{'browser.interface'} eq 'textual' || 747: $ENV{'environment.remote'} eq 'off' ) { 748: $stayOnPage=1; 749: } 750: $width = 600 if (not defined $width); 751: $height = 600 if (not defined $height); 752: 753: $topic=~s/\W+/\+/g; 754: my $link=''; 755: my $template=''; 756: my $url=$Apache::lonnet::perlvar{'BugzillaHost'}.'enter_bug.cgi?product=LON-CAPA&bug_file_loc='. 757: &Apache::lonnet::escape($ENV{'REQUEST_URI'}).'&component='.$topic; 758: if (!$stayOnPage) 759: { 760: $link = "javascript:void(open('$url', 'Bugzilla', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))"; 761: } 762: else 763: { 764: $link = $url; 765: } 766: # Add the text 767: if ($text ne "") 768: { 769: $template .= 770: "<table bgcolor='#AA3333' cellspacing='1' cellpadding='1' border='0'><tr>". 771: "<td bgcolor='#FF5555'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>"; 772: } 773: 774: # Add the graphic 775: my $title = &mt('Report a Bug'); 776: my $bugicon=&lonhttpdurl("/adm/lonMisc/smallBug.gif"); 777: $template .= <<"ENDTEMPLATE"; 778: <a href="$link" title="$title"><img src="$bugicon" border="0" alt="(Bug: $topic)" /></a> 779: ENDTEMPLATE 780: if ($text ne '') { $template.='</td></tr></table>' }; 781: return $template; 782: 783: } 784: 785: sub help_open_faq { 786: my ($topic, $text, $stayOnPage, $width, $height) = @_; 787: unless ($ENV{'user.adv'}) { return ''; } 788: unless ($Apache::lonnet::perlvar{'FAQHost'}) { return ''; } 789: $text = "" if (not defined $text); 790: $stayOnPage = 0 if (not defined $stayOnPage); 791: if ($ENV{'browser.interface'} eq 'textual' || 792: $ENV{'environment.remote'} eq 'off' ) { 793: $stayOnPage=1; 794: } 795: $width = 350 if (not defined $width); 796: $height = 400 if (not defined $height); 797: 798: $topic=~s/\W+/\+/g; 799: my $link=''; 800: my $template=''; 801: my $url=$Apache::lonnet::perlvar{'FAQHost'}.'/fom/cache/'.$topic.'.html'; 802: if (!$stayOnPage) 803: { 804: $link = "javascript:void(open('$url', 'FAQ-O-Matic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))"; 805: } 806: else 807: { 808: $link = $url; 809: } 810: 811: # Add the text 812: if ($text ne "") 813: { 814: $template .= 815: "<table bgcolor='#337733' cellspacing='1' cellpadding='1' border='0'><tr>". 816: "<td bgcolor='#448844'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>"; 817: } 818: 819: # Add the graphic 820: my $title = &mt('View the FAQ'); 821: my $faqicon=&lonhttpdurl("/adm/lonMisc/smallFAQ.gif"); 822: $template .= <<"ENDTEMPLATE"; 823: <a href="$link" title="$title"><img src="$faqicon" border="0" alt="(FAQ: $topic)" /></a> 824: ENDTEMPLATE 825: if ($text ne '') { $template.='</td></tr></table>' }; 826: return $template; 827: 828: } 829: 830: ############################################################### 831: ############################################################### 832: 833: =pod 834: 835: =item * csv_translate($text) 836: 837: Translate $text to allow it to be output as a 'comma separated values' 838: format. 839: 840: =cut 841: 842: ############################################################### 843: ############################################################### 844: sub csv_translate { 845: my $text = shift; 846: $text =~ s/\"/\"\"/g; 847: $text =~ s/\n/ /g; 848: return $text; 849: } 850: 851: 852: ############################################################### 853: ############################################################### 854: 855: =pod 856: 857: =item * define_excel_formats 858: 859: Define some commonly used Excel cell formats. 860: 861: Currently supported formats: 862: 863: =over 4 864: 865: =item header 866: 867: =item bold 868: 869: =item h1 870: 871: =item h2 872: 873: =item h3 874: 875: =item date 876: 877: =back 878: 879: Inputs: $workbook 880: 881: Returns: $format, a hash reference. 882: 883: =cut 884: 885: ############################################################### 886: ############################################################### 887: sub define_excel_formats { 888: my ($workbook) = @_; 889: my $format; 890: $format->{'header'} = $workbook->add_format(bold => 1, 891: bottom => 1, 892: align => 'center'); 893: $format->{'bold'} = $workbook->add_format(bold=>1); 894: $format->{'h1'} = $workbook->add_format(bold=>1, size=>18); 895: $format->{'h2'} = $workbook->add_format(bold=>1, size=>16); 896: $format->{'h3'} = $workbook->add_format(bold=>1, size=>14); 897: $format->{'i'} = $workbook->add_format(italic=>1); 898: $format->{'date'} = $workbook->add_format(num_format=> 899: 'mm/dd/yyyy hh:mm:ss'); 900: return $format; 901: } 902: 903: ############################################################### 904: ############################################################### 905: 906: =pod 907: 908: =item * change_content_javascript(): 909: 910: This and the next function allow you to create small sections of an 911: otherwise static HTML page that you can update on the fly with 912: Javascript, even in Netscape 4. 913: 914: The Javascript fragment returned by this function (no E<lt>scriptE<gt> tag) 915: must be written to the HTML page once. It will prove the Javascript 916: function "change(name, content)". Calling the change function with the 917: name of the section 918: you want to update, matching the name passed to C<changable_area>, and 919: the new content you want to put in there, will put the content into 920: that area. 921: 922: B<Note>: Netscape 4 only reserves enough space for the changable area 923: to contain room for the original contents. You need to "make space" 924: for whatever changes you wish to make, and be B<sure> to check your 925: code in Netscape 4. This feature in Netscape 4 is B<not> powerful; 926: it's adequate for updating a one-line status display, but little more. 927: This script will set the space to 100% width, so you only need to 928: worry about height in Netscape 4. 929: 930: Modern browsers are much less limiting, and if you can commit to the 931: user not using Netscape 4, this feature may be used freely with 932: pretty much any HTML. 933: 934: =cut 935: 936: sub change_content_javascript { 937: # If we're on Netscape 4, we need to use Layer-based code 938: if ($ENV{'browser.type'} eq 'netscape' && 939: $ENV{'browser.version'} =~ /^4\./) { 940: return (<<NETSCAPE4); 941: function change(name, content) { 942: doc = document.layers[name+"___escape"].layers[0].document; 943: doc.open(); 944: doc.write(content); 945: doc.close(); 946: } 947: NETSCAPE4 948: } else { 949: # Otherwise, we need to use semi-standards-compliant code 950: # (technically, "innerHTML" isn't standard but the equivalent 951: # is really scary, and every useful browser supports it 952: return (<<DOMBASED); 953: function change(name, content) { 954: element = document.getElementById(name); 955: element.innerHTML = content; 956: } 957: DOMBASED 958: } 959: } 960: 961: =pod 962: 963: =item * changable_area($name, $origContent): 964: 965: This provides a "changable area" that can be modified on the fly via 966: the Javascript code provided in C<change_content_javascript>. $name is 967: the name you will use to reference the area later; do not repeat the 968: same name on a given HTML page more then once. $origContent is what 969: the area will originally contain, which can be left blank. 970: 971: =cut 972: 973: sub changable_area { 974: my ($name, $origContent) = @_; 975: 976: if ($ENV{'browser.type'} eq 'netscape' && 977: $ENV{'browser.version'} =~ /^4\./) { 978: # If this is netscape 4, we need to use the Layer tag 979: return "<ilayer width='100%' id='${name}___escape' overflow='none'><layer width='100%' id='$name' overflow='none'>$origContent</layer></ilayer>"; 980: } else { 981: return "<span id='$name'>$origContent</span>"; 982: } 983: } 984: 985: =pod 986: 987: =back 988: 989: =cut 990: 991: ############################################################### 992: ## Home server <option> list generating code ## 993: ############################################################### 994: 995: =pod 996: 997: =head1 Home Server option list generating code 998: 999: =over 4 1000: 1001: =item * get_domains() 1002: 1003: Returns an array containing each of the domains listed in the hosts.tab 1004: file. 1005: 1006: =cut 1007: 1008: #------------------------------------------- 1009: sub get_domains { 1010: # The code below was stolen from "The Perl Cookbook", p 102, 1st ed. 1011: my @domains; 1012: my %seen; 1013: foreach (sort values(%Apache::lonnet::hostdom)) { 1014: push (@domains,$_) unless $seen{$_}++; 1015: } 1016: return @domains; 1017: } 1018: 1019: # ------------------------------------------ 1020: 1021: sub domain_select { 1022: my ($name,$value,$multiple)=@_; 1023: my %domains=map { 1024: $_ => $_.' '.$Apache::lonnet::domaindescription{$_} 1025: } &get_domains; 1026: if ($multiple) { 1027: $domains{''}=&mt('Any domain'); 1028: return &multiple_select_form($name,$value,4,%domains); 1029: } else { 1030: return &select_form($name,$value,%domains); 1031: } 1032: } 1033: 1034: sub multiple_select_form { 1035: my ($name,$value,$size,%hash)=@_; 1036: my %selected = map { $_ => 1 } ref($value)?@{$value}:($value); 1037: my $output=''; 1038: if (! defined($size)) { 1039: $size = 4; 1040: if (scalar(keys(%hash))<4) { 1041: $size = scalar(keys(%hash)); 1042: } 1043: } 1044: $output.="\n<select name='$name' size='$size' multiple='1'>"; 1045: foreach (sort(keys(%hash))) { 1046: $output.='<option value="'.$_.'" '; 1047: $output.='selected ' if ($selected{$_}); 1048: $output.='>'.$hash{$_}."</option>\n"; 1049: } 1050: $output.="</select>\n"; 1051: return $output; 1052: } 1053: 1054: #------------------------------------------- 1055: 1056: =pod 1057: 1058: =item * select_form($defdom,$name,%hash) 1059: 1060: Returns a string containing a <select name='$name' size='1'> form to 1061: allow a user to select options from a hash option_name => displayed text. 1062: See lonrights.pm for an example invocation and use. 1063: 1064: =cut 1065: 1066: #------------------------------------------- 1067: sub select_form { 1068: my ($def,$name,%hash) = @_; 1069: my $selectform = "<select name=\"$name\" size=\"1\">\n"; 1070: my @keys; 1071: if (exists($hash{'select_form_order'})) { 1072: @keys=@{$hash{'select_form_order'}}; 1073: } else { 1074: @keys=sort(keys(%hash)); 1075: } 1076: foreach (@keys) { 1077: $selectform.="<option value=\"$_\" ". 1078: ($_ eq $def ? 'selected' : ''). 1079: ">".&mt($hash{$_})."</option>\n"; 1080: } 1081: $selectform.="</select>"; 1082: return $selectform; 1083: } 1084: 1085: sub gradeleveldescription { 1086: my $gradelevel=shift; 1087: my %gradelevels=(0 => 'Not specified', 1088: 1 => 'Grade 1', 1089: 2 => 'Grade 2', 1090: 3 => 'Grade 3', 1091: 4 => 'Grade 4', 1092: 5 => 'Grade 5', 1093: 6 => 'Grade 6', 1094: 7 => 'Grade 7', 1095: 8 => 'Grade 8', 1096: 9 => 'Grade 9', 1097: 10 => 'Grade 10', 1098: 11 => 'Grade 11', 1099: 12 => 'Grade 12', 1100: 13 => 'Grade 13', 1101: 14 => '100 Level', 1102: 15 => '200 Level', 1103: 16 => '300 Level', 1104: 17 => '400 Level', 1105: 18 => 'Graduate Level'); 1106: return &mt($gradelevels{$gradelevel}); 1107: } 1108: 1109: sub select_level_form { 1110: my ($deflevel,$name)=@_; 1111: unless ($deflevel) { $deflevel=0; } 1112: my $selectform = "<select name=\"$name\" size=\"1\">\n"; 1113: for (my $i=0; $i<=18; $i++) { 1114: $selectform.="<option value=\"$i\" ". 1115: ($i==$deflevel ? 'selected' : ''). 1116: ">".&gradeleveldescription($i)."</option>\n"; 1117: } 1118: $selectform.="</select>"; 1119: return $selectform; 1120: } 1121: 1122: #------------------------------------------- 1123: 1124: =pod 1125: 1126: =item * select_dom_form($defdom,$name,$includeempty) 1127: 1128: Returns a string containing a <select name='$name' size='1'> form to 1129: allow a user to select the domain to preform an operation in. 1130: See loncreateuser.pm for an example invocation and use. 1131: 1132: If the $includeempty flag is set, it also includes an empty choice ("no domain 1133: selected"); 1134: 1135: =cut 1136: 1137: #------------------------------------------- 1138: sub select_dom_form { 1139: my ($defdom,$name,$includeempty) = @_; 1140: my @domains = get_domains(); 1141: if ($includeempty) { @domains=('',@domains); } 1142: my $selectdomain = "<select name=\"$name\" size=\"1\">\n"; 1143: foreach (@domains) { 1144: $selectdomain.="<option value=\"$_\" ". 1145: ($_ eq $defdom ? 'selected' : ''). 1146: ">$_</option>\n"; 1147: } 1148: $selectdomain.="</select>"; 1149: return $selectdomain; 1150: } 1151: 1152: #------------------------------------------- 1153: 1154: =pod 1155: 1156: =item * get_library_servers($domain) 1157: 1158: Returns a hash which contains keys like '103l3' and values like 1159: 'kirk.lite.msu.edu'. All of the keys will be for machines in the 1160: given $domain. 1161: 1162: =cut 1163: 1164: #------------------------------------------- 1165: sub get_library_servers { 1166: my $domain = shift; 1167: my %library_servers; 1168: foreach (keys(%Apache::lonnet::libserv)) { 1169: if ($Apache::lonnet::hostdom{$_} eq $domain) { 1170: $library_servers{$_} = $Apache::lonnet::hostname{$_}; 1171: } 1172: } 1173: return %library_servers; 1174: } 1175: 1176: #------------------------------------------- 1177: 1178: =pod 1179: 1180: =item * home_server_option_list($domain) 1181: 1182: returns a string which contains an <option> list to be used in a 1183: <select> form input. See loncreateuser.pm for an example. 1184: 1185: =cut 1186: 1187: #------------------------------------------- 1188: sub home_server_option_list { 1189: my $domain = shift; 1190: my %servers = &get_library_servers($domain); 1191: my $result = ''; 1192: foreach (sort keys(%servers)) { 1193: $result.= 1194: '<option value="'.$_.'">'.$_.' '.$servers{$_}."</option>\n"; 1195: } 1196: return $result; 1197: } 1198: 1199: =pod 1200: 1201: =back 1202: 1203: =cut 1204: 1205: ############################################################### 1206: ## Decoding User Agent ## 1207: ############################################################### 1208: 1209: =pod 1210: 1211: =head1 Decoding the User Agent 1212: 1213: =over 4 1214: 1215: =item * &decode_user_agent() 1216: 1217: Inputs: $r 1218: 1219: Outputs: 1220: 1221: =over 4 1222: 1223: =item * $httpbrowser 1224: 1225: =item * $clientbrowser 1226: 1227: =item * $clientversion 1228: 1229: =item * $clientmathml 1230: 1231: =item * $clientunicode 1232: 1233: =item * $clientos 1234: 1235: =back 1236: 1237: =back 1238: 1239: =cut 1240: 1241: ############################################################### 1242: ############################################################### 1243: sub decode_user_agent { 1244: my @browsertype=split(/\&/,$Apache::lonnet::perlvar{"lonBrowsDet"}); 1245: my %mathcap=split(/\&/,$$Apache::lonnet::perlvar{"lonMathML"}); 1246: my $httpbrowser=$ENV{"HTTP_USER_AGENT"}; 1247: my $clientbrowser='unknown'; 1248: my $clientversion='0'; 1249: my $clientmathml=''; 1250: my $clientunicode='0'; 1251: for (my $i=0;$i<=$#browsertype;$i++) { 1252: my ($bname,$match,$notmatch,$vreg,$minv,$univ)=split(/\:/,$browsertype[$i]); 1253: if (($httpbrowser=~/$match/i) && ($httpbrowser!~/$notmatch/i)) { 1254: $clientbrowser=$bname; 1255: $httpbrowser=~/$vreg/i; 1256: $clientversion=$1; 1257: $clientmathml=($clientversion>=$minv); 1258: $clientunicode=($clientversion>=$univ); 1259: } 1260: } 1261: my $clientos='unknown'; 1262: if (($httpbrowser=~/linux/i) || 1263: ($httpbrowser=~/unix/i) || 1264: ($httpbrowser=~/ux/i) || 1265: ($httpbrowser=~/solaris/i)) { $clientos='unix'; } 1266: if (($httpbrowser=~/vax/i) || 1267: ($httpbrowser=~/vms/i)) { $clientos='vms'; } 1268: if ($httpbrowser=~/next/i) { $clientos='next'; } 1269: if (($httpbrowser=~/mac/i) || 1270: ($httpbrowser=~/powerpc/i)) { $clientos='mac'; } 1271: if ($httpbrowser=~/win/i) { $clientos='win'; } 1272: if ($httpbrowser=~/embed/i) { $clientos='pda'; } 1273: return ($httpbrowser,$clientbrowser,$clientversion,$clientmathml, 1274: $clientunicode,$clientos,); 1275: } 1276: 1277: ############################################################### 1278: ## Authentication changing form generation subroutines ## 1279: ############################################################### 1280: ## 1281: ## All of the authform_xxxxxxx subroutines take their inputs in a 1282: ## hash, and have reasonable default values. 1283: ## 1284: ## formname = the name given in the <form> tag. 1285: #------------------------------------------- 1286: 1287: =pod 1288: 1289: =head1 Authentication Routines 1290: 1291: =over 4 1292: 1293: =item * authform_xxxxxx 1294: 1295: The authform_xxxxxx subroutines provide javascript and html forms which 1296: handle some of the conveniences required for authentication forms. 1297: This is not an optimal method, but it works. 1298: 1299: See loncreateuser.pm for invocation and use examples. 1300: 1301: =over 4 1302: 1303: =item * authform_header 1304: 1305: =item * authform_authorwarning 1306: 1307: =item * authform_nochange 1308: 1309: =item * authform_kerberos 1310: 1311: =item * authform_internal 1312: 1313: =item * authform_filesystem 1314: 1315: =back 1316: 1317: =back 1318: 1319: =cut 1320: 1321: #------------------------------------------- 1322: sub authform_header{ 1323: my %in = ( 1324: formname => 'cu', 1325: kerb_def_dom => '', 1326: @_, 1327: ); 1328: $in{'formname'} = 'document.' . $in{'formname'}; 1329: my $result=''; 1330: 1331: #---------------------------------------------- Code for upper case translation 1332: my $Javascript_toUpperCase; 1333: unless ($in{kerb_def_dom}) { 1334: $Javascript_toUpperCase =<<"END"; 1335: switch (choice) { 1336: case 'krb': currentform.elements[choicearg].value = 1337: currentform.elements[choicearg].value.toUpperCase(); 1338: break; 1339: default: 1340: } 1341: END 1342: } else { 1343: $Javascript_toUpperCase = ""; 1344: } 1345: 1346: my $radioval = "'nochange'"; 1347: if (exists($in{'curr_authtype'}) && 1348: defined($in{'curr_authtype'}) && 1349: $in{'curr_authtype'} ne '') { 1350: $radioval = "'$in{'curr_authtype'}arg'"; 1351: } 1352: my $argfield = 'null'; 1353: if ( grep/^mode$/,(keys %in) ) { 1354: if ($in{'mode'} eq 'modifycourse') { 1355: if ( grep/^curr_authtype$/,(keys %in) ) { 1356: $radioval = "'$in{'curr_authtype'}'"; 1357: } 1358: if ( grep/^curr_autharg$/,(keys %in) ) { 1359: unless ($in{'curr_autharg'} eq '') { 1360: $argfield = "'$in{'curr_autharg'}'"; 1361: } 1362: } 1363: } 1364: } 1365: 1366: $result.=<<"END"; 1367: var current = new Object(); 1368: current.radiovalue = $radioval; 1369: current.argfield = $argfield; 1370: 1371: function changed_radio(choice,currentform) { 1372: var choicearg = choice + 'arg'; 1373: // If a radio button in changed, we need to change the argfield 1374: if (current.radiovalue != choice) { 1375: current.radiovalue = choice; 1376: if (current.argfield != null) { 1377: currentform.elements[current.argfield].value = ''; 1378: } 1379: if (choice == 'nochange') { 1380: current.argfield = null; 1381: } else { 1382: current.argfield = choicearg; 1383: switch(choice) { 1384: case 'krb': 1385: currentform.elements[current.argfield].value = 1386: "$in{'kerb_def_dom'}"; 1387: break; 1388: default: 1389: break; 1390: } 1391: } 1392: } 1393: return; 1394: } 1395: 1396: function changed_text(choice,currentform) { 1397: var choicearg = choice + 'arg'; 1398: if (currentform.elements[choicearg].value !='') { 1399: $Javascript_toUpperCase 1400: // clear old field 1401: if ((current.argfield != choicearg) && (current.argfield != null)) { 1402: currentform.elements[current.argfield].value = ''; 1403: } 1404: current.argfield = choicearg; 1405: } 1406: set_auth_radio_buttons(choice,currentform); 1407: return; 1408: } 1409: 1410: function set_auth_radio_buttons(newvalue,currentform) { 1411: var i=0; 1412: while (i < currentform.login.length) { 1413: if (currentform.login[i].value == newvalue) { break; } 1414: i++; 1415: } 1416: if (i == currentform.login.length) { 1417: return; 1418: } 1419: current.radiovalue = newvalue; 1420: currentform.login[i].checked = true; 1421: return; 1422: } 1423: END 1424: return $result; 1425: } 1426: 1427: sub authform_authorwarning{ 1428: my $result=''; 1429: $result='<i>'. 1430: &mt('As a general rule, only authors or co-authors should be '. 1431: 'filesystem authenticated '. 1432: '(which allows access to the server filesystem).')."</i>\n"; 1433: return $result; 1434: } 1435: 1436: sub authform_nochange{ 1437: my %in = ( 1438: formname => 'document.cu', 1439: kerb_def_dom => 'MSU.EDU', 1440: @_, 1441: ); 1442: my $result = &mt('[_1] Do not change login data', 1443: '<input type="radio" name="login" value="nochange" '. 1444: 'checked="checked" onclick="'. 1445: "javascript:changed_radio('nochange',$in{'formname'});".'" />'); 1446: return $result; 1447: } 1448: 1449: sub authform_kerberos{ 1450: my %in = ( 1451: formname => 'document.cu', 1452: kerb_def_dom => 'MSU.EDU', 1453: kerb_def_auth => 'krb4', 1454: @_, 1455: ); 1456: my ($check4,$check5,$krbarg); 1457: if ($in{'kerb_def_auth'} eq 'krb5') { 1458: $check5 = " checked=\"on\""; 1459: } else { 1460: $check4 = " checked=\"on\""; 1461: } 1462: $krbarg = $in{'kerb_def_dom'}; 1463: 1464: my $krbcheck = ""; 1465: if ( grep/^curr_authtype$/,(keys %in) ) { 1466: if ($in{'curr_authtype'} =~ m/^krb/) { 1467: $krbcheck = " checked=\"on\""; 1468: if ( grep/^curr_autharg$/,(keys %in) ) { 1469: $krbarg = $in{'curr_autharg'}; 1470: } 1471: } 1472: } 1473: 1474: my $jscall = "javascript:changed_radio('krb',$in{'formname'});"; 1475: my $result .= &mt 1476: ('[_1] Kerberos authenticated with domain [_2] '. 1477: '[_3] Version 4 [_4] Version 5', 1478: '<input type="radio" name="login" value="krb" '. 1479: 'onclick="'.$jscall.'" onchange="'.$jscall.'"'.$krbcheck.' />', 1480: '<input type="text" size="10" name="krbarg" '. 1481: 'value="'.$krbarg.'" '. 1482: 'onchange="'.$jscall.'" />', 1483: '<input type="radio" name="krbver" value="4" '.$check4.' />', 1484: '<input type="radio" name="krbver" value="5" '.$check5.' />'); 1485: return $result; 1486: } 1487: 1488: sub authform_internal{ 1489: my %args = ( 1490: formname => 'document.cu', 1491: kerb_def_dom => 'MSU.EDU', 1492: @_, 1493: ); 1494: 1495: my $intcheck = ""; 1496: my $intarg = 'value=""'; 1497: if ( grep/^curr_authtype$/,(keys %args) ) { 1498: if ($args{'curr_authtype'} eq 'int') { 1499: $intcheck = " checked=\"on\""; 1500: if ( grep/^curr_autharg$/,(keys %args) ) { 1501: $intarg = "value=\"$args{'curr_autharg'}\""; 1502: } 1503: } 1504: } 1505: 1506: my $jscall = "javascript:changed_radio('int',$args{'formname'});"; 1507: my $result.=&mt 1508: ('[_1] Internally authenticated (with initial password [_2])', 1509: '<input type="radio" name="login" value="int" '.$intcheck. 1510: ' onchange="'.$jscall.'" onclick="'.$jscall.'" />', 1511: '<input type="text" size="10" name="intarg" '.$intarg. 1512: ' onchange="'.$jscall.'" />'); 1513: return $result; 1514: } 1515: 1516: sub authform_local{ 1517: my %in = ( 1518: formname => 'document.cu', 1519: kerb_def_dom => 'MSU.EDU', 1520: @_, 1521: ); 1522: 1523: my $loccheck = ""; 1524: my $locarg = 'value=""'; 1525: if ( grep/^curr_authtype$/,(keys %in) ) { 1526: if ($in{'curr_authtype'} eq 'loc') { 1527: $loccheck = " checked=\"on\""; 1528: if ( grep/^curr_autharg$/,(keys %in) ) { 1529: $locarg = "value=\"$in{'curr_autharg'}\""; 1530: } 1531: } 1532: } 1533: 1534: my $jscall = "javascript:changed_radio('loc',$in{'formname'});"; 1535: my $result.=&mt('[_1] Local Authentication with argument [_2]', 1536: '<input type="radio" name="login" value="loc" '.$loccheck. 1537: ' onchange="'.$jscall.'" onclick="'.$jscall.'" />', 1538: '<input type="text" size="10" name="locarg" '.$locarg. 1539: ' onchange="'.$jscall.'" />'); 1540: return $result; 1541: } 1542: 1543: sub authform_filesystem{ 1544: my %in = ( 1545: formname => 'document.cu', 1546: kerb_def_dom => 'MSU.EDU', 1547: @_, 1548: ); 1549: my $jscall = "javascript:changed_radio('fsys',$in{'formname'});"; 1550: my $result.= &mt 1551: ('[_1] Filesystem Authenticated (with initial password [_2])', 1552: '<input type="radio" name="login" value="fsys" '. 1553: 'onchange="'.$jscall.'" onclick="'.$jscall.'" />', 1554: '<input type="text" size="10" name="fsysarg" value="" '. 1555: 'onchange="'.$jscall.'" />'); 1556: return $result; 1557: } 1558: 1559: ############################################################### 1560: ## Get Authentication Defaults for Domain ## 1561: ############################################################### 1562: 1563: =pod 1564: 1565: =head1 Domains and Authentication 1566: 1567: Returns default authentication type and an associated argument as 1568: listed in file 'domain.tab'. 1569: 1570: =over 4 1571: 1572: =item * get_auth_defaults 1573: 1574: get_auth_defaults($target_domain) returns the default authentication 1575: type and an associated argument (initial password or a kerberos domain). 1576: These values are stored in lonTabs/domain.tab 1577: 1578: ($def_auth, $def_arg) = &get_auth_defaults($target_domain); 1579: 1580: If target_domain is not found in domain.tab, returns nothing (''). 1581: 1582: =cut 1583: 1584: #------------------------------------------- 1585: sub get_auth_defaults { 1586: my $domain=shift; 1587: return ($Apache::lonnet::domain_auth_def{$domain},$Apache::lonnet::domain_auth_arg_def{$domain}); 1588: } 1589: ############################################################### 1590: ## End Get Authentication Defaults for Domain ## 1591: ############################################################### 1592: 1593: ############################################################### 1594: ## Get Kerberos Defaults for Domain ## 1595: ############################################################### 1596: ## 1597: ## Returns default kerberos version and an associated argument 1598: ## as listed in file domain.tab. If not listed, provides 1599: ## appropriate default domain and kerberos version. 1600: ## 1601: #------------------------------------------- 1602: 1603: =pod 1604: 1605: =item * get_kerberos_defaults 1606: 1607: get_kerberos_defaults($target_domain) returns the default kerberos 1608: version and domain. If not found in domain.tabs, it defaults to 1609: version 4 and the domain of the server. 1610: 1611: ($def_version, $def_krb_domain) = &get_kerberos_defaults($target_domain); 1612: 1613: =cut 1614: 1615: #------------------------------------------- 1616: sub get_kerberos_defaults { 1617: my $domain=shift; 1618: my ($krbdef,$krbdefdom) = 1619: &Apache::loncommon::get_auth_defaults($domain); 1620: unless ($krbdef =~/^krb/ && $krbdefdom) { 1621: $ENV{'SERVER_NAME'}=~/(\w+\.\w+)$/; 1622: my $krbdefdom=$1; 1623: $krbdefdom=~tr/a-z/A-Z/; 1624: $krbdef = "krb4"; 1625: } 1626: return ($krbdef,$krbdefdom); 1627: } 1628: 1629: =pod 1630: 1631: =back 1632: 1633: =cut 1634: 1635: ############################################################### 1636: ## Thesaurus Functions ## 1637: ############################################################### 1638: 1639: =pod 1640: 1641: =head1 Thesaurus Functions 1642: 1643: =over 4 1644: 1645: =item * initialize_keywords 1646: 1647: Initializes the package variable %Keywords if it is empty. Uses the 1648: package variable $thesaurus_db_file. 1649: 1650: =cut 1651: 1652: ################################################### 1653: 1654: sub initialize_keywords { 1655: return 1 if (scalar keys(%Keywords)); 1656: # If we are here, %Keywords is empty, so fill it up 1657: # Make sure the file we need exists... 1658: if (! -e $thesaurus_db_file) { 1659: &Apache::lonnet::logthis("Attempt to access $thesaurus_db_file". 1660: " failed because it does not exist"); 1661: return 0; 1662: } 1663: # Set up the hash as a database 1664: my %thesaurus_db; 1665: if (! tie(%thesaurus_db,'GDBM_File', 1666: $thesaurus_db_file,&GDBM_READER(),0640)){ 1667: &Apache::lonnet::logthis("Could not tie \%thesaurus_db to ". 1668: $thesaurus_db_file); 1669: return 0; 1670: } 1671: # Get the average number of appearances of a word. 1672: my $avecount = $thesaurus_db{'average.count'}; 1673: # Put keywords (those that appear > average) into %Keywords 1674: while (my ($word,$data)=each (%thesaurus_db)) { 1675: my ($count,undef) = split /:/,$data; 1676: $Keywords{$word}++ if ($count > $avecount); 1677: } 1678: untie %thesaurus_db; 1679: # Remove special values from %Keywords. 1680: foreach ('total.count','average.count') { 1681: delete($Keywords{$_}) if (exists($Keywords{$_})); 1682: } 1683: return 1; 1684: } 1685: 1686: ################################################### 1687: 1688: =pod 1689: 1690: =item * keyword($word) 1691: 1692: Returns true if $word is a keyword. A keyword is a word that appears more 1693: than the average number of times in the thesaurus database. Calls 1694: &initialize_keywords 1695: 1696: =cut 1697: 1698: ################################################### 1699: 1700: sub keyword { 1701: return if (!&initialize_keywords()); 1702: my $word=lc(shift()); 1703: $word=~s/\W//g; 1704: return exists($Keywords{$word}); 1705: } 1706: 1707: ############################################################### 1708: 1709: =pod 1710: 1711: =item * get_related_words 1712: 1713: Look up a word in the thesaurus. Takes a scalar argument and returns 1714: an array of words. If the keyword is not in the thesaurus, an empty array 1715: will be returned. The order of the words returned is determined by the 1716: database which holds them. 1717: 1718: Uses global $thesaurus_db_file. 1719: 1720: =cut 1721: 1722: ############################################################### 1723: sub get_related_words { 1724: my $keyword = shift; 1725: my %thesaurus_db; 1726: if (! -e $thesaurus_db_file) { 1727: &Apache::lonnet::logthis("Attempt to access $thesaurus_db_file ". 1728: "failed because the file does not exist"); 1729: return (); 1730: } 1731: if (! tie(%thesaurus_db,'GDBM_File', 1732: $thesaurus_db_file,&GDBM_READER(),0640)){ 1733: return (); 1734: } 1735: my @Words=(); 1736: if (exists($thesaurus_db{$keyword})) { 1737: $_ = $thesaurus_db{$keyword}; 1738: (undef,@Words) = split/:/; # The first element is the number of times 1739: # the word appears. We do not need it now. 1740: for (my $i=0;$i<=$#Words;$i++) { 1741: ($Words[$i],undef)= split/\,/,$Words[$i]; 1742: } 1743: } 1744: untie %thesaurus_db; 1745: return @Words; 1746: } 1747: 1748: =pod 1749: 1750: =back 1751: 1752: =cut 1753: 1754: # -------------------------------------------------------------- Plaintext name 1755: =pod 1756: 1757: =head1 User Name Functions 1758: 1759: =over 4 1760: 1761: =item * plainname($uname,$udom,$first) 1762: 1763: Takes a users logon name and returns it as a string in 1764: "first middle last generation" form 1765: if $first is set to 'lastname' then it returns it as 1766: 'lastname generation, firstname middlename' if their is a lastname 1767: 1768: =cut 1769: 1770: ############################################################### 1771: sub plainname { 1772: my ($uname,$udom,$first)=@_; 1773: my %names=&Apache::lonnet::get('environment', 1774: ['firstname','middlename','lastname','generation'], 1775: $udom,$uname); 1776: my $name=&Apache::lonnet::format_name($names{'firstname'}, 1777: $names{'middlename'}, 1778: $names{'lastname'}, 1779: $names{'generation'},$first); 1780: $name=~s/^\s+//; 1781: $name=~s/\s+$//; 1782: $name=~s/\s+/ /g; 1783: if ($name !~ /\S/) { $name=$uname.'@'.$udom; } 1784: return $name; 1785: } 1786: 1787: # -------------------------------------------------------------------- Nickname 1788: =pod 1789: 1790: =item * nickname($uname,$udom) 1791: 1792: Gets a users name and returns it as a string as 1793: 1794: ""nickname"" 1795: 1796: if the user has a nickname or 1797: 1798: "first middle last generation" 1799: 1800: if the user does not 1801: 1802: =cut 1803: 1804: sub nickname { 1805: my ($uname,$udom)=@_; 1806: my %names; 1807: if ($uname eq $ENV{'user.name'} && 1808: $udom eq $ENV{'user.domain'}) { 1809: %names=('nickname' => $ENV{'environment.nickname'} , 1810: 'firstname' => $ENV{'environment.firstname'} , 1811: 'middlename' => $ENV{'environment.middlename'}, 1812: 'lastname' => $ENV{'environment.lastname'} , 1813: 'generation' => $ENV{'environment.generation'}); 1814: } else { 1815: %names=&Apache::lonnet::get('environment', 1816: ['nickname','firstname','middlename', 1817: 'lastname','generation'],$udom,$uname); 1818: } 1819: my $name=$names{'nickname'}; 1820: if ($name) { 1821: $name='"'.$name.'"'; 1822: } else { 1823: $name=$names{'firstname'}.' '.$names{'middlename'}.' '. 1824: $names{'lastname'}.' '.$names{'generation'}; 1825: $name=~s/\s+$//; 1826: $name=~s/\s+/ /g; 1827: } 1828: return $name; 1829: } 1830: 1831: 1832: # ------------------------------------------------------------------ Screenname 1833: 1834: =pod 1835: 1836: =item * screenname($uname,$udom) 1837: 1838: Gets a users screenname and returns it as a string 1839: 1840: =cut 1841: 1842: sub screenname { 1843: my ($uname,$udom)=@_; 1844: if ($uname eq $ENV{'user.name'} && 1845: $udom eq $ENV{'user.domain'}) {return $ENV{'environment.screenname'};} 1846: my %names=&Apache::lonnet::get('environment',['screenname'],$udom,$uname); 1847: return $names{'screenname'}; 1848: } 1849: 1850: 1851: # ------------------------------------------------------------- Message Wrapper 1852: 1853: sub messagewrapper { 1854: my ($link,$username,$domain)=@_; 1855: return 1856: '<a href="/adm/email?compose=individual&'. 1857: 'recname='.$username.'&recdom='.$domain.'" '. 1858: 'title="'.&mt('Send message').'">'.$link.'</a>'; 1859: } 1860: # --------------------------------------------------------------- Notes Wrapper 1861: 1862: sub noteswrapper { 1863: my ($link,$un,$do)=@_; 1864: return 1865: "<a href='/adm/email?recordftf=retrieve&recname=$un&recdom=$do'>$link</a>"; 1866: } 1867: # ------------------------------------------------------------- Aboutme Wrapper 1868: 1869: sub aboutmewrapper { 1870: my ($link,$username,$domain,$target)=@_; 1871: return '<a href="/adm/'.$domain.'/'.$username.'/aboutme"'. 1872: ($target?' target="$target"':'').' title="'.&mt('View this users personal page').'">'.$link.'</a>'; 1873: } 1874: 1875: # ------------------------------------------------------------ Syllabus Wrapper 1876: 1877: 1878: sub syllabuswrapper { 1879: my ($linktext,$coursedir,$domain,$fontcolor)=@_; 1880: if ($fontcolor) { 1881: $linktext='<font color="'.$fontcolor.'">'.$linktext.'</font>'; 1882: } 1883: return qq{<a href="/public/$domain/$coursedir/syllabus">$linktext</a>}; 1884: } 1885: 1886: sub track_student_link { 1887: my ($linktext,$sname,$sdom,$target) = @_; 1888: my $link ="/adm/trackstudent"; 1889: my $title = 'View recent activity'; 1890: if (defined($sname) && $sname !~ /^\s*$/ && 1891: defined($sdom) && $sdom !~ /^\s*$/) { 1892: $link .= "?selected_student=$sname:$sdom"; 1893: $title .= ' of this student'; 1894: } 1895: if (defined($target) && $target !~ /^\s*$/) { 1896: $target = qq{target="$target"}; 1897: } else { 1898: $target = ''; 1899: } 1900: return qq{<a href="$link" title="$title" $target>$linktext</a>}; 1901: } 1902: 1903: 1904: 1905: =pod 1906: 1907: =back 1908: 1909: =head1 Access .tab File Data 1910: 1911: =over 4 1912: 1913: =item * languageids() 1914: 1915: returns list of all language ids 1916: 1917: =cut 1918: 1919: sub languageids { 1920: return sort(keys(%language)); 1921: } 1922: 1923: =pod 1924: 1925: =item * languagedescription() 1926: 1927: returns description of a specified language id 1928: 1929: =cut 1930: 1931: sub languagedescription { 1932: my $code=shift; 1933: return ($supported_language{$code}?'* ':''). 1934: $language{$code}. 1935: ($supported_language{$code}?' ('.&mt('interface available').')':''); 1936: } 1937: 1938: sub plainlanguagedescription { 1939: my $code=shift; 1940: return $language{$code}; 1941: } 1942: 1943: sub supportedlanguagecode { 1944: my $code=shift; 1945: return $supported_language{$code}; 1946: } 1947: 1948: =pod 1949: 1950: =item * copyrightids() 1951: 1952: returns list of all copyrights 1953: 1954: =cut 1955: 1956: sub copyrightids { 1957: return sort(keys(%cprtag)); 1958: } 1959: 1960: =pod 1961: 1962: =item * copyrightdescription() 1963: 1964: returns description of a specified copyright id 1965: 1966: =cut 1967: 1968: sub copyrightdescription { 1969: return &mt($cprtag{shift(@_)}); 1970: } 1971: 1972: =pod 1973: 1974: =item * source_copyrightids() 1975: 1976: returns list of all source copyrights 1977: 1978: =cut 1979: 1980: sub source_copyrightids { 1981: return sort(keys(%scprtag)); 1982: } 1983: 1984: =pod 1985: 1986: =item * source_copyrightdescription() 1987: 1988: returns description of a specified source copyright id 1989: 1990: =cut 1991: 1992: sub source_copyrightdescription { 1993: return &mt($scprtag{shift(@_)}); 1994: } 1995: 1996: =pod 1997: 1998: =item * filecategories() 1999: 2000: returns list of all file categories 2001: 2002: =cut 2003: 2004: sub filecategories { 2005: return sort(keys(%category_extensions)); 2006: } 2007: 2008: =pod 2009: 2010: =item * filecategorytypes() 2011: 2012: returns list of file types belonging to a given file 2013: category 2014: 2015: =cut 2016: 2017: sub filecategorytypes { 2018: return @{$category_extensions{lc($_[0])}}; 2019: } 2020: 2021: =pod 2022: 2023: =item * fileembstyle() 2024: 2025: returns embedding style for a specified file type 2026: 2027: =cut 2028: 2029: sub fileembstyle { 2030: return $fe{lc(shift(@_))}; 2031: } 2032: 2033: 2034: sub filecategoryselect { 2035: my ($name,$value)=@_; 2036: return &select_form($value,$name, 2037: '' => &mt('Any category'), 2038: map { $_,$_ } sort(keys(%category_extensions))); 2039: } 2040: 2041: =pod 2042: 2043: =item * filedescription() 2044: 2045: returns description for a specified file type 2046: 2047: =cut 2048: 2049: sub filedescription { 2050: my $file_description = $fd{lc(shift())}; 2051: $file_description =~ s:([\[\]]):~$1:g; 2052: return &mt($file_description); 2053: } 2054: 2055: =pod 2056: 2057: =item * filedescriptionex() 2058: 2059: returns description for a specified file type with 2060: extra formatting 2061: 2062: =cut 2063: 2064: sub filedescriptionex { 2065: my $ex=shift; 2066: my $file_description = $fd{lc($ex)}; 2067: $file_description =~ s:([\[\]]):~$1:g; 2068: return '.'.$ex.' '.&mt($file_description); 2069: } 2070: 2071: # End of .tab access 2072: =pod 2073: 2074: =back 2075: 2076: =cut 2077: 2078: # ------------------------------------------------------------------ File Types 2079: sub fileextensions { 2080: return sort(keys(%fe)); 2081: } 2082: 2083: # ----------------------------------------------------------- Display Languages 2084: # returns a hash with all desired display languages 2085: # 2086: 2087: sub display_languages { 2088: my %languages=(); 2089: foreach (&preferred_languages()) { 2090: $languages{$_}=1; 2091: } 2092: &get_unprocessed_cgi($ENV{'QUERY_STRING'},['displaylanguage']); 2093: if ($ENV{'form.displaylanguage'}) { 2094: foreach (split(/\s*(\,|\;|\:)\s*/,$ENV{'form.displaylanguage'})) { 2095: $languages{$_}=1; 2096: } 2097: } 2098: return %languages; 2099: } 2100: 2101: sub preferred_languages { 2102: my @languages=(); 2103: if ($ENV{'course.'.$ENV{'request.course.id'}.'.languages'}) { 2104: @languages=(@languages,split(/\s*(\,|\;|\:)\s*/, 2105: $ENV{'course.'.$ENV{'request.course.id'}.'.languages'})); 2106: } 2107: if ($ENV{'environment.languages'}) { 2108: @languages=split(/\s*(\,|\;|\:)\s*/,$ENV{'environment.languages'}); 2109: } 2110: my $browser=(split(/\;/,$ENV{'HTTP_ACCEPT_LANGUAGE'}))[0]; 2111: if ($browser) { 2112: @languages=(@languages,split(/\s*(\,|\;|\:)\s*/,$browser)); 2113: } 2114: if ($Apache::lonnet::domain_lang_def{$ENV{'user.domain'}}) { 2115: @languages=(@languages, 2116: $Apache::lonnet::domain_lang_def{$ENV{'user.domain'}}); 2117: } 2118: if ($Apache::lonnet::domain_lang_def{$ENV{'request.role.domain'}}) { 2119: @languages=(@languages, 2120: $Apache::lonnet::domain_lang_def{$ENV{'request.role.domain'}}); 2121: } 2122: if ($Apache::lonnet::domain_lang_def{ 2123: $Apache::lonnet::perlvar{'lonDefDomain'}}) { 2124: @languages=(@languages, 2125: $Apache::lonnet::domain_lang_def{ 2126: $Apache::lonnet::perlvar{'lonDefDomain'}}); 2127: } 2128: # turn "en-ca" into "en-ca,en" 2129: my @genlanguages; 2130: foreach (@languages) { 2131: unless ($_=~/\w/) { next; } 2132: push (@genlanguages,$_); 2133: if ($_=~/(\-|\_)/) { 2134: push (@genlanguages,(split(/(\-|\_)/,$_))[0]); 2135: } 2136: } 2137: return @genlanguages; 2138: } 2139: 2140: ############################################################### 2141: ## Student Answer Attempts ## 2142: ############################################################### 2143: 2144: =pod 2145: 2146: =head1 Alternate Problem Views 2147: 2148: =over 4 2149: 2150: =item * get_previous_attempt($symb, $username, $domain, $course, 2151: $getattempt, $regexp, $gradesub) 2152: 2153: Return string with previous attempt on problem. Arguments: 2154: 2155: =over 4 2156: 2157: =item * $symb: Problem, including path 2158: 2159: =item * $username: username of the desired student 2160: 2161: =item * $domain: domain of the desired student 2162: 2163: =item * $course: Course ID 2164: 2165: =item * $getattempt: Leave blank for all attempts, otherwise put 2166: something 2167: 2168: =item * $regexp: if string matches this regexp, the string will be 2169: sent to $gradesub 2170: 2171: =item * $gradesub: routine that processes the string if it matches $regexp 2172: 2173: =back 2174: 2175: The output string is a table containing all desired attempts, if any. 2176: 2177: =cut 2178: 2179: sub get_previous_attempt { 2180: my ($symb,$username,$domain,$course,$getattempt,$regexp,$gradesub)=@_; 2181: my $prevattempts=''; 2182: no strict 'refs'; 2183: if ($symb) { 2184: my (%returnhash)= 2185: &Apache::lonnet::restore($symb,$course,$domain,$username); 2186: if ($returnhash{'version'}) { 2187: my %lasthash=(); 2188: my $version; 2189: for ($version=1;$version<=$returnhash{'version'};$version++) { 2190: foreach (sort(split(/\:/,$returnhash{$version.':keys'}))) { 2191: $lasthash{$_}=$returnhash{$version.':'.$_}; 2192: } 2193: } 2194: $prevattempts='<table border="0" width="100%"><tr><td bgcolor="#777777">'; 2195: $prevattempts.='<table border="0" width="100%"><tr bgcolor="#e6ffff"><td>History</td>'; 2196: foreach (sort(keys %lasthash)) { 2197: my ($ign,@parts) = split(/\./,$_); 2198: if ($#parts > 0) { 2199: my $data=$parts[-1]; 2200: pop(@parts); 2201: $prevattempts.='<td>Part '.join('.',@parts).'<br />'.$data.' </td>'; 2202: } else { 2203: if ($#parts == 0) { 2204: $prevattempts.='<th>'.$parts[0].'</th>'; 2205: } else { 2206: $prevattempts.='<th>'.$ign.'</th>'; 2207: } 2208: } 2209: } 2210: if ($getattempt eq '') { 2211: for ($version=1;$version<=$returnhash{'version'};$version++) { 2212: $prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Transaction '.$version.'</td>'; 2213: foreach (sort(keys %lasthash)) { 2214: my $value; 2215: if ($_ =~ /timestamp/) { 2216: $value=scalar(localtime($returnhash{$version.':'.$_})); 2217: } else { 2218: $value=$returnhash{$version.':'.$_}; 2219: } 2220: $prevattempts.='<td>'.&Apache::lonnet::unescape($value).' </td>'; 2221: } 2222: } 2223: } 2224: $prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Current</td>'; 2225: foreach (sort(keys %lasthash)) { 2226: my $value; 2227: if ($_ =~ /timestamp/) { 2228: $value=scalar(localtime($lasthash{$_})); 2229: } else { 2230: $value=$lasthash{$_}; 2231: } 2232: $value=&Apache::lonnet::unescape($value); 2233: if ($_ =~/$regexp$/ && (defined &$gradesub)) {$value = &$gradesub($value)} 2234: $prevattempts.='<td>'.$value.' </td>'; 2235: } 2236: $prevattempts.='</tr></table></td></tr></table>'; 2237: } else { 2238: $prevattempts='Nothing submitted - no attempts.'; 2239: } 2240: } else { 2241: $prevattempts='No data.'; 2242: } 2243: } 2244: 2245: sub relative_to_absolute { 2246: my ($url,$output)=@_; 2247: my $parser=HTML::TokeParser->new(\$output); 2248: my $token; 2249: my $thisdir=$url; 2250: my @rlinks=(); 2251: while ($token=$parser->get_token) { 2252: if ($token->[0] eq 'S') { 2253: if ($token->[1] eq 'a') { 2254: if ($token->[2]->{'href'}) { 2255: $rlinks[$#rlinks+1]=$token->[2]->{'href'}; 2256: } 2257: } elsif ($token->[1] eq 'img' || $token->[1] eq 'embed' ) { 2258: $rlinks[$#rlinks+1]=$token->[2]->{'src'}; 2259: } elsif ($token->[1] eq 'base') { 2260: $thisdir=$token->[2]->{'href'}; 2261: } 2262: } 2263: } 2264: $thisdir=~s-/[^/]*$--; 2265: foreach (@rlinks) { 2266: unless (($_=~/^http:\/\//i) || 2267: ($_=~/^\//) || 2268: ($_=~/^javascript:/i) || 2269: ($_=~/^mailto:/i) || 2270: ($_=~/^\#/)) { 2271: my $newlocation=&Apache::lonnet::hreflocation($thisdir,$_); 2272: $output=~s/(\"|\'|\=\s*)$_(\"|\'|\s|\>)/$1$newlocation$2/; 2273: } 2274: } 2275: # -------------------------------------------------- Deal with Applet codebases 2276: $output=~s/(\<applet[^\>]+)(codebase\=[^\S\>]+)*([^\>]*)\>/$1.($2?$2:' codebase="'.$thisdir.'"').$3.'>'/gei; 2277: return $output; 2278: } 2279: 2280: =pod 2281: 2282: =item * get_student_view 2283: 2284: show a snapshot of what student was looking at 2285: 2286: =cut 2287: 2288: sub get_student_view { 2289: my ($symb,$username,$domain,$courseid,$target,$moreenv) = @_; 2290: my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb); 2291: my (%form); 2292: my @elements=('symb','courseid','domain','username'); 2293: foreach my $element (@elements) { 2294: $form{'grade_'.$element}=eval '$'.$element #' 2295: } 2296: if (defined($moreenv)) { 2297: %form=(%form,%{$moreenv}); 2298: } 2299: if (defined($target)) { $form{'grade_target'} = $target; } 2300: $feedurl=&Apache::lonnet::clutter($feedurl); 2301: my $userview=&Apache::lonnet::ssi_body($feedurl,%form); 2302: $userview=~s/\<body[^\>]*\>//gi; 2303: $userview=~s/\<\/body\>//gi; 2304: $userview=~s/\<html\>//gi; 2305: $userview=~s/\<\/html\>//gi; 2306: $userview=~s/\<head\>//gi; 2307: $userview=~s/\<\/head\>//gi; 2308: $userview=~s/action\s*\=/would_be_action\=/gi; 2309: $userview=&relative_to_absolute($feedurl,$userview); 2310: return $userview; 2311: } 2312: 2313: =pod 2314: 2315: =item * get_student_answers() 2316: 2317: show a snapshot of how student was answering problem 2318: 2319: =cut 2320: 2321: sub get_student_answers { 2322: my ($symb,$username,$domain,$courseid,%form) = @_; 2323: my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb); 2324: my (%moreenv); 2325: my @elements=('symb','courseid','domain','username'); 2326: foreach my $element (@elements) { 2327: $moreenv{'grade_'.$element}=eval '$'.$element #' 2328: } 2329: $moreenv{'grade_target'}='answer'; 2330: %moreenv=(%form,%moreenv); 2331: my $userview=&Apache::lonnet::ssi('/res/'.$feedurl,%moreenv); 2332: return $userview; 2333: } 2334: 2335: =pod 2336: 2337: =item * &submlink() 2338: 2339: Inputs: $text $uname $udom $symb $target 2340: 2341: Returns: A link to grades.pm such as to see the SUBM view of a student 2342: 2343: =cut 2344: 2345: ############################################### 2346: sub submlink { 2347: my ($text,$uname,$udom,$symb,$target)=@_; 2348: if (!($uname && $udom)) { 2349: (my $cursymb, my $courseid,$udom,$uname)= 2350: &Apache::lonxml::whichuser($symb); 2351: if (!$symb) { $symb=$cursymb; } 2352: } 2353: if (!$symb) { $symb=&symbread(); } 2354: $symb=&Apache::lonnet::escape($symb); 2355: if ($target) { $target="target=\"$target\""; } 2356: return '<a href="/adm/grades?&command=submission&'. 2357: 'symb='.$symb.'&student='.$uname. 2358: '&userdom='.$udom.'" '.$target.'>'.$text.'</a>'; 2359: } 2360: ############################################## 2361: 2362: =pod 2363: 2364: =item * &pgrdlink() 2365: 2366: Inputs: $text $uname $udom $symb $target 2367: 2368: Returns: A link to grades.pm such as to see the PGRD view of a student 2369: 2370: =cut 2371: 2372: ############################################### 2373: sub pgrdlink { 2374: my $link=&submlink(@_); 2375: $link=~s/(&command=submission)/$1&showgrading=yes/; 2376: return $link; 2377: } 2378: ############################################## 2379: 2380: =pod 2381: 2382: =item * &pprmlink() 2383: 2384: Inputs: $text $uname $udom $symb $target 2385: 2386: Returns: A link to parmset.pm such as to see the PPRM view of a 2387: student andn resource 2388: 2389: =cut 2390: 2391: ############################################### 2392: sub pprmlink { 2393: my ($text,$uname,$udom,$symb,$target)=@_; 2394: if (!($uname && $udom)) { 2395: (my $cursymb, my $courseid,$udom,$uname)= 2396: &Apache::lonxml::whichuser($symb); 2397: if (!$symb) { $symb=$cursymb; } 2398: } 2399: if (!$symb) { $symb=&symbread(); } 2400: $symb=&Apache::lonnet::escape($symb); 2401: if ($target) { $target="target=\"$target\""; } 2402: return '<a href="/adm/parmset?&command=set&'. 2403: 'symb='.$symb.'&uname='.$uname. 2404: '&udom='.$udom.'" '.$target.'>'.$text.'</a>'; 2405: } 2406: ############################################## 2407: 2408: =pod 2409: 2410: =back 2411: 2412: =cut 2413: 2414: ############################################### 2415: 2416: 2417: sub timehash { 2418: my @ltime=localtime(shift); 2419: return ( 'seconds' => $ltime[0], 2420: 'minutes' => $ltime[1], 2421: 'hours' => $ltime[2], 2422: 'day' => $ltime[3], 2423: 'month' => $ltime[4]+1, 2424: 'year' => $ltime[5]+1900, 2425: 'weekday' => $ltime[6], 2426: 'dayyear' => $ltime[7]+1, 2427: 'dlsav' => $ltime[8] ); 2428: } 2429: 2430: sub maketime { 2431: my %th=@_; 2432: return POSIX::mktime( 2433: ($th{'seconds'},$th{'minutes'},$th{'hours'}, 2434: $th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,-1)); 2435: } 2436: 2437: ######################################### 2438: 2439: sub findallcourses { 2440: my %courses=(); 2441: my $now=time; 2442: foreach (keys %ENV) { 2443: if ($_=~/^user\.role\.\w+\.\/(\w+)\/(\w+)/) { 2444: my ($starttime,$endtime)=$ENV{$_}; 2445: my $active=1; 2446: if ($starttime) { 2447: if ($now<$starttime) { $active=0; } 2448: } 2449: if ($endtime) { 2450: if ($now>$endtime) { $active=0; } 2451: } 2452: if ($active) { $courses{$1.'_'.$2}=1; } 2453: } 2454: } 2455: return keys %courses; 2456: } 2457: 2458: ############################################### 2459: ############################################### 2460: 2461: =pod 2462: 2463: =head1 Domain Template Functions 2464: 2465: =over 4 2466: 2467: =item * &determinedomain() 2468: 2469: Inputs: $domain (usually will be undef) 2470: 2471: Returns: Determines which domain should be used for designs 2472: 2473: =cut 2474: 2475: ############################################### 2476: sub determinedomain { 2477: my $domain=shift; 2478: if (! $domain) { 2479: # Determine domain if we have not been given one 2480: $domain = $Apache::lonnet::perlvar{'lonDefDomain'}; 2481: if ($ENV{'user.domain'}) { $domain=$ENV{'user.domain'}; } 2482: if ($ENV{'request.role.domain'}) { 2483: $domain=$ENV{'request.role.domain'}; 2484: } 2485: } 2486: return $domain; 2487: } 2488: ############################################### 2489: =pod 2490: 2491: =item * &domainlogo() 2492: 2493: Inputs: $domain (usually will be undef) 2494: 2495: Returns: A link to a domain logo, if the domain logo exists. 2496: If the domain logo does not exist, a description of the domain. 2497: 2498: =cut 2499: 2500: ############################################### 2501: sub domainlogo { 2502: my $domain = &determinedomain(shift); 2503: # See if there is a logo 2504: if (-e '/home/httpd/html/adm/lonDomLogos/'.$domain.'.gif') { 2505: my $logo=&lonhttpdurl("/adm/lonDomLogos/$domain.gif"); 2506: return '<img src="'.$logo.'" alt="'.$domain.'" />'; 2507: } elsif(exists($Apache::lonnet::domaindescription{$domain})) { 2508: return $Apache::lonnet::domaindescription{$domain}; 2509: } else { 2510: return ''; 2511: } 2512: } 2513: ############################################## 2514: 2515: =pod 2516: 2517: =item * &designparm() 2518: 2519: Inputs: $which parameter; $domain (usually will be undef) 2520: 2521: Returns: value of designparamter $which 2522: 2523: =cut 2524: 2525: ############################################## 2526: sub designparm { 2527: my ($which,$domain)=@_; 2528: if ($ENV{'browser.blackwhite'} eq 'on') { 2529: if ($which=~/\.(font|alink|vlink|link)$/) { 2530: return '#000000'; 2531: } 2532: if ($which=~/\.(pgbg|sidebg)$/) { 2533: return '#FFFFFF'; 2534: } 2535: if ($which=~/\.tabbg$/) { 2536: return '#CCCCCC'; 2537: } 2538: } 2539: if ($ENV{'environment.color.'.$which}) { 2540: return $ENV{'environment.color.'.$which}; 2541: } 2542: $domain=&determinedomain($domain); 2543: if ($designhash{$domain.'.'.$which}) { 2544: return $designhash{$domain.'.'.$which}; 2545: } else { 2546: return $designhash{'default.'.$which}; 2547: } 2548: } 2549: 2550: ############################################### 2551: ############################################### 2552: 2553: =pod 2554: 2555: =back 2556: 2557: =head1 HTTP Helpers 2558: 2559: =over 4 2560: 2561: =item * &bodytag() 2562: 2563: Returns a uniform header for LON-CAPA web pages. 2564: 2565: Inputs: 2566: 2567: =over 4 2568: 2569: =item * $title, A title to be displayed on the page. 2570: 2571: =item * $function, the current role (can be undef). 2572: 2573: =item * $addentries, extra parameters for the <body> tag. 2574: 2575: =item * $bodyonly, if defined, only return the <body> tag. 2576: 2577: =item * $domain, if defined, force a given domain. 2578: 2579: =item * $forcereg, if page should register as content page (relevant for 2580: text interface only) 2581: 2582: =back 2583: 2584: Returns: A uniform header for LON-CAPA web pages. 2585: If $bodyonly is nonzero, a string containing a <body> tag will be returned. 2586: If $bodyonly is undef or zero, an html string containing a <body> tag and 2587: other decorations will be returned. 2588: 2589: =cut 2590: 2591: sub bodytag { 2592: my ($title,$function,$addentries,$bodyonly,$domain,$forcereg,$customtitle)=@_; 2593: $title=&mt($title); 2594: $function = &get_users_function() if (!$function); 2595: my $img=&designparm($function.'.img',$domain); 2596: my $pgbg=&designparm($function.'.pgbg',$domain); 2597: my $tabbg=&designparm($function.'.tabbg',$domain); 2598: my $font=&designparm($function.'.font',$domain); 2599: my $link=&designparm($function.'.link',$domain); 2600: my $alink=&designparm($function.'.alink',$domain); 2601: my $vlink=&designparm($function.'.vlink',$domain); 2602: my $sidebg=&designparm($function.'.sidebg',$domain); 2603: # Accessibility font enhance 2604: unless ($addentries) { $addentries=''; } 2605: my $addstyle=''; 2606: if ($ENV{'browser.fontenhance'} eq 'on') { 2607: $addstyle=' font-size: x-large;'; 2608: } 2609: # role and realm 2610: my ($role,$realm) 2611: =&Apache::lonnet::plaintext((split(/\./,$ENV{'request.role'}))[0]); 2612: # realm 2613: if ($ENV{'request.course.id'}) { 2614: $realm= 2615: $ENV{'course.'.$ENV{'request.course.id'}.'.description'}; 2616: } 2617: unless ($realm) { $realm=' '; } 2618: # Set messages 2619: my $messages=&domainlogo($domain); 2620: # Port for miniserver 2621: my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'}; 2622: if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; } 2623: # construct main body tag 2624: my $bodytag = <<END; 2625: <style type="text/css"> 2626: h1, h2, h3, th { font-family: Arial, Helvetica, sans-serif } 2627: a:focus { color: red; background: yellow } 2628: </style> 2629: <body bgcolor="$pgbg" text="$font" alink="$alink" vlink="$vlink" link="$link" 2630: style="margin-top: 0px;$addstyle" $addentries> 2631: END 2632: my $upperleft='<img src="http://'.$ENV{'HTTP_HOST'}.':'. 2633: $lonhttpdPort.$img.'" alt="'.$function.'" />'; 2634: if ($bodyonly) { 2635: return $bodytag; 2636: } elsif ($ENV{'browser.interface'} eq 'textual') { 2637: # Accessibility 2638: 2639: return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web', 2640: $forcereg). 2641: '<h1>LON-CAPA: '.$title.'</h1>'; 2642: } elsif ($ENV{'environment.remote'} eq 'off') { 2643: # No Remote 2644: my $roleinfo=(<<ENDROLE); 2645: <td bgcolor="$tabbg" align="right"> 2646: <font size="2" face="Arial, Helvetica, sans-serif"> 2647: $ENV{'environment.firstname'} 2648: $ENV{'environment.middlename'} 2649: $ENV{'environment.lastname'} 2650: $ENV{'environment.generation'} 2651: </font>  2652: <br /> 2653: <font size="2" face="Arial, Helvetica, sans-serif">$role</font>  2654: <br /> 2655: <font size="2" face="Arial, Helvetica, sans-serif">$realm</font>  2656: </td> 2657: ENDROLE 2658: my $titleinfo = '<font face="Arial, Helvetica, sans-serif" size="+3" color="'. 2659: $font.'"><b>'.$title.'</b></font>'; 2660: if ($customtitle) { 2661: $titleinfo = $customtitle; 2662: } 2663: 2664: if ($ENV{'request.state'} eq 'construct') { 2665: my ($uname,$thisdisfn)= 2666: ($ENV{'request.filename'} =~ m|^/home/([^/]+)/public_html/(.*)|); 2667: my $formaction='/priv/'.$uname.'/'.$thisdisfn; 2668: $formaction=~s/\/+/\//g; 2669: unless ($customtitle) { #this is for resources; directories have customtitle, and crumbs and select recent are created in lonpubdir.pm 2670: my $parentpath = ''; 2671: my $lastitem = ''; 2672: if ($thisdisfn =~ m-(.+/)([^/]*)$-) { 2673: $parentpath = $1; 2674: $lastitem = $2; 2675: } else { 2676: $lastitem = $thisdisfn; 2677: } 2678: $titleinfo = &Apache::loncommon::help_open_menu('','','','',3,'Authoring'). 2679: '<font face="Arial, Helvetica, sans-serif"><b>Construction Space</b>:</font> '. 2680: '<form name="dirs" method="post" action="'.$formaction 2681: .'" target="_top"><tt><b>' 2682: .&Apache::lonhtmlcommon::crumbs($uname.'/'.$parentpath,'_top','/priv','','+1',1)."<font size=\"+1\">$lastitem</font></b></tt><br />" 2683: .&Apache::lonhtmlcommon::select_recent('construct','recent','this.form.action=this.form.recent.value;this.form.submit()') 2684: .'</form>' 2685: .&Apache::lonmenu::constspaceform(); 2686: 2687: } 2688: $forcereg=1; 2689: } 2690: my $titletable = '<table bgcolor="'.$pgbg.'" width="100%" border="0" '. 2691: 'cellspacing="3" cellpadding="3">'. 2692: '<tr><td rowspan="3" bgcolor="'.$tabbg.'">'. 2693: $titleinfo.'</td>'.$roleinfo.'</tr></table>'; 2694: if ($ENV{'request.state'} eq 'construct') { 2695: $bodytag .= &Apache::lonmenu::menubuttons($forcereg,'web',$forcereg,$titletable); 2696: } else { 2697: $bodytag .= &Apache::lonmenu::menubuttons($forcereg,'web',$forcereg). 2698: $titletable; 2699: } 2700: return $bodytag; 2701: } 2702: 2703: # 2704: # Top frame rendering, Remote is up 2705: # 2706: my $titleinfo = ' <font size="5" face="Arial, Helvetica, sans-serif"><b>'.$title.'</b></font>'; 2707: if ($customtitle) { 2708: $titleinfo = $customtitle; 2709: } 2710: # 2711: # Extra info if you are the DC 2712: my $dc_info = ''; 2713: if ($ENV{'user.adv'} && exists($ENV{'user.role.dc./'. 2714: $ENV{'course.'.$ENV{'request.course.id'}. 2715: '.domain'}.'/'})) { 2716: my $cid = $ENV{'request.course.id'}; 2717: $dc_info.= $cid.' '.$ENV{'course.'.$cid.'.internal.coursecode'}; 2718: $dc_info = '('.$dc_info.')'; 2719: } 2720: # 2721: return(<<ENDBODY); 2722: $bodytag 2723: <table width="100%" cellspacing="0" border="0" cellpadding="0"> 2724: <tr><td bgcolor="$sidebg"> 2725: $upperleft</td> 2726: <td bgcolor="$sidebg" align="right">$messages </td> 2727: </tr> 2728: <tr> 2729: <td rowspan="3" bgcolor="$tabbg"> 2730: $titleinfo $dc_info 2731: <td bgcolor="$tabbg" align="right"> 2732: <font size="2" face="Arial, Helvetica, sans-serif"> 2733: $ENV{'environment.firstname'} 2734: $ENV{'environment.middlename'} 2735: $ENV{'environment.lastname'} 2736: $ENV{'environment.generation'} 2737: </font>  2738: </td> 2739: </tr> 2740: <tr><td bgcolor="$tabbg" align="right"> 2741: <font size="2" face="Arial, Helvetica, sans-serif">$role</font>  2742: </td></tr> 2743: <tr> 2744: <td bgcolor="$tabbg" align="right"><font size="2" face="Arial, Helvetica, sans-serif">$realm</font> </td></tr> 2745: </table><br /> 2746: ENDBODY 2747: } 2748: 2749: ############################################### 2750: 2751: =pod 2752: 2753: =item get_users_function 2754: 2755: Used by &bodytag to determine the current users primary role. 2756: Returns either 'student','coordinator','admin', or 'author'. 2757: 2758: =cut 2759: 2760: ############################################### 2761: sub get_users_function { 2762: my $function = 'student'; 2763: if ($ENV{'request.role'}=~/^(cc|in|ta|ep)/) { 2764: $function='coordinator'; 2765: } 2766: if ($ENV{'request.role'}=~/^(su|dc|ad|li)/) { 2767: $function='admin'; 2768: } 2769: if (($ENV{'request.role'}=~/^(au|ca)/) || 2770: ($ENV{'REQUEST_URI'}=~/^(\/priv|\~)/)) { 2771: $function='author'; 2772: } 2773: return $function; 2774: } 2775: 2776: ############################################### 2777: 2778: =pod 2779: 2780: =item get_sections 2781: 2782: Determines all the sections for a course including 2783: sections with students and sections containing other roles. 2784: Incoming parameters: domain, course number, reference to 2785: section hash (keys to be section/group IDs), reference to 2786: array containing roles for which sections should be gathered 2787: (optional). If the fourth argument is undefined, sections 2788: are gathered for any role. 2789: 2790: Returns number of sections. 2791: 2792: =cut 2793: 2794: ############################################### 2795: sub get_sections { 2796: my ($cdom,$cnum,$sectioncount,$possible_roles) = @_; 2797: if (!($cdom && $cnum)) { return 0; } 2798: my $cid = $cdom.'_'.$cnum; 2799: my $numsections = 0; 2800: 2801: if (!defined($possible_roles) || (grep/^st$/,@$possible_roles)) { 2802: my ($classlist) = &Apache::loncoursedata::get_classlist($cid,$cdom,$cnum); 2803: my $sec_index = &Apache::loncoursedata::CL_SECTION(); 2804: my $status_index = &Apache::loncoursedata::CL_STATUS(); 2805: while (my ($student,$data) = each %$classlist) { 2806: my ($section,$status) = ($data->[$sec_index], 2807: $data->[$status_index]); 2808: unless ($section eq '-1' || $section =~ /^\s*$/) { 2809: if (!defined($$sectioncount{$section})) { $numsections++; } 2810: $$sectioncount{$section}++; 2811: } 2812: } 2813: } 2814: my %courseroles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum); 2815: foreach my $user (sort(keys(%courseroles))) { 2816: if ($user !~ /^(\w{2})/) { next; } 2817: my ($role) = ($user =~ /^(\w{2})/); 2818: if ($possible_roles && !(grep(/^$role$/,@$possible_roles))) { next; } 2819: my $section; 2820: if ($role eq 'cr' && 2821: $user =~ m-^$role/[^/]*/[^/]*/[^/]*:[^:]*:[^:]*:(\w+)-) { 2822: $section=$1; 2823: } 2824: if ($user =~ /^$role:[^:]*:[^:]*:(\w+)/) { $section=$1; } 2825: if (!defined($section) || $section eq '-1') { next; } 2826: if (!defined($$sectioncount{$section})) { $numsections++; } 2827: $$sectioncount{$section}++; 2828: } 2829: return $numsections; 2830: } 2831: 2832: 2833: sub get_posted_cgi { 2834: my $r=shift; 2835: 2836: my $buffer; 2837: 2838: $r->read($buffer,$r->header_in('Content-length'),0); 2839: unless ($buffer=~/^(\-+\w+)\s+Content\-Disposition\:\s*form\-data/si) { 2840: my @pairs=split(/&/,$buffer); 2841: my $pair; 2842: foreach $pair (@pairs) { 2843: my ($name,$value) = split(/=/,$pair); 2844: $value =~ tr/+/ /; 2845: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; 2846: $name =~ tr/+/ /; 2847: $name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; 2848: &add_to_env("form.$name",$value); 2849: } 2850: } else { 2851: my $contentsep=$1; 2852: my @lines = split (/\n/,$buffer); 2853: my $name=''; 2854: my $value=''; 2855: my $fname=''; 2856: my $fmime=''; 2857: my $i; 2858: for ($i=0;$i<=$#lines;$i++) { 2859: if ($lines[$i]=~/^$contentsep/) { 2860: if ($name) { 2861: chomp($value); 2862: if ($fname) { 2863: $ENV{"form.$name.filename"}=$fname; 2864: $ENV{"form.$name.mimetype"}=$fmime; 2865: } else { 2866: $value=~s/\s+$//s; 2867: } 2868: &add_to_env("form.$name",$value); 2869: } 2870: if ($i<$#lines) { 2871: $i++; 2872: $lines[$i]=~ 2873: /Content\-Disposition\:\s*form\-data\;\s*name\=\"([^\"]+)\"/i; 2874: $name=$1; 2875: $value=''; 2876: if ($lines[$i]=~/filename\=\"([^\"]+)\"/i) { 2877: $fname=$1; 2878: if 2879: ($lines[$i+1]=~/Content\-Type\:\s*([\w\-\/]+)/i) { 2880: $fmime=$1; 2881: $i++; 2882: } else { 2883: $fmime=''; 2884: } 2885: } else { 2886: $fname=''; 2887: $fmime=''; 2888: } 2889: $i++; 2890: } 2891: } else { 2892: $value.=$lines[$i]."\n"; 2893: } 2894: } 2895: } 2896: $ENV{'request.method'}=$ENV{'REQUEST_METHOD'}; 2897: $r->method_number(M_GET); 2898: $r->method('GET'); 2899: $r->headers_in->unset('Content-length'); 2900: } 2901: 2902: =pod 2903: 2904: =item * get_unprocessed_cgi($query,$possible_names) 2905: 2906: Modify the %ENV hash to contain unprocessed CGI form parameters held in 2907: $query. The parameters listed in $possible_names (an array reference), 2908: will be set in $ENV{'form.name'} if they do not already exist. 2909: 2910: Typically called with $ENV{'QUERY_STRING'} as the first parameter. 2911: $possible_names is an ref to an array of form element names. As an example: 2912: get_unprocessed_cgi($ENV{'QUERY_STRING'},['uname','udom']); 2913: will result in $ENV{'form.uname'} and $ENV{'form.udom'} being set. 2914: 2915: =cut 2916: 2917: sub get_unprocessed_cgi { 2918: my ($query,$possible_names)= @_; 2919: # $Apache::lonxml::debug=1; 2920: foreach (split(/&/,$query)) { 2921: my ($name, $value) = split(/=/,$_); 2922: $name = &Apache::lonnet::unescape($name); 2923: if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) { 2924: $value =~ tr/+/ /; 2925: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; 2926: &Apache::lonxml::debug("Seting :$name: to :$value:"); 2927: unless (defined($ENV{'form.'.$name})) { &add_to_env('form.'.$name,$value) }; 2928: } 2929: } 2930: } 2931: 2932: =pod 2933: 2934: =item * cacheheader() 2935: 2936: returns cache-controlling header code 2937: 2938: =cut 2939: 2940: sub cacheheader { 2941: unless ($ENV{'request.method'} eq 'GET') { return ''; } 2942: my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime); 2943: my $output .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" /> 2944: <meta HTTP-EQUIV="Cache-control" CONTENT="no-cache" /> 2945: <meta HTTP-EQUIV="Pragma" CONTENT="no-cache" />'; 2946: return $output; 2947: } 2948: 2949: =pod 2950: 2951: =item * no_cache($r) 2952: 2953: specifies header code to not have cache 2954: 2955: =cut 2956: 2957: sub no_cache { 2958: my ($r) = @_; 2959: if ($ENV{'REQUEST_METHOD'} ne 'GET' && 2960: $ENV{'request.method'} ne 'GET') { return ''; } 2961: my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime(time)); 2962: $r->no_cache(1); 2963: $r->header_out("Expires" => $date); 2964: $r->header_out("Pragma" => "no-cache"); 2965: } 2966: 2967: sub content_type { 2968: my ($r,$type,$charset) = @_; 2969: unless ($charset) { 2970: $charset=&Apache::lonlocal::current_encoding; 2971: } 2972: if ($charset) { $type.='; charset='.$charset; } 2973: if ($r) { 2974: $r->content_type($type); 2975: } else { 2976: print("Content-type: $type\n\n"); 2977: } 2978: } 2979: 2980: =pod 2981: 2982: =item * add_to_env($name,$value) 2983: 2984: adds $name to the %ENV hash with value 2985: $value, if $name already exists, the entry is converted to an array 2986: reference and $value is added to the array. 2987: 2988: =cut 2989: 2990: sub add_to_env { 2991: my ($name,$value)=@_; 2992: if (defined($ENV{$name})) { 2993: if (ref($ENV{$name})) { 2994: #already have multiple values 2995: push(@{ $ENV{$name} },$value); 2996: } else { 2997: #first time seeing multiple values, convert hash entry to an arrayref 2998: my $first=$ENV{$name}; 2999: undef($ENV{$name}); 3000: push(@{ $ENV{$name} },$first,$value); 3001: } 3002: } else { 3003: $ENV{$name}=$value; 3004: } 3005: } 3006: 3007: =pod 3008: 3009: =item * get_env_multiple($name) 3010: 3011: gets $name from the %ENV hash, it seemlessly handles the cases where multiple 3012: values may be defined and end up as an array ref. 3013: 3014: returns an array of values 3015: 3016: =cut 3017: 3018: sub get_env_multiple { 3019: my ($name) = @_; 3020: my @values; 3021: if (defined($ENV{$name})) { 3022: # exists is it an array 3023: if (ref($ENV{$name})) { 3024: @values=@{ $ENV{$name} }; 3025: } else { 3026: $values[0]=$ENV{$name}; 3027: } 3028: } 3029: return(@values); 3030: } 3031: 3032: 3033: =pod 3034: 3035: =back 3036: 3037: =head1 CSV Upload/Handling functions 3038: 3039: =over 4 3040: 3041: =item * upfile_store($r) 3042: 3043: Store uploaded file, $r should be the HTTP Request object, 3044: needs $ENV{'form.upfile'} 3045: returns $datatoken to be put into hidden field 3046: 3047: =cut 3048: 3049: sub upfile_store { 3050: my $r=shift; 3051: $ENV{'form.upfile'}=~s/\r/\n/gs; 3052: $ENV{'form.upfile'}=~s/\f/\n/gs; 3053: $ENV{'form.upfile'}=~s/\n+/\n/gs; 3054: $ENV{'form.upfile'}=~s/\n+$//gs; 3055: 3056: my $datatoken=$ENV{'user.name'}.'_'.$ENV{'user.domain'}. 3057: '_enroll_'.$ENV{'request.course.id'}.'_'.time.'_'.$$; 3058: { 3059: my $datafile = $r->dir_config('lonDaemons'). 3060: '/tmp/'.$datatoken.'.tmp'; 3061: if ( open(my $fh,">$datafile") ) { 3062: print $fh $ENV{'form.upfile'}; 3063: close($fh); 3064: } 3065: } 3066: return $datatoken; 3067: } 3068: 3069: =pod 3070: 3071: =item * load_tmp_file($r) 3072: 3073: Load uploaded file from tmp, $r should be the HTTP Request object, 3074: needs $ENV{'form.datatoken'}, 3075: sets $ENV{'form.upfile'} to the contents of the file 3076: 3077: =cut 3078: 3079: sub load_tmp_file { 3080: my $r=shift; 3081: my @studentdata=(); 3082: { 3083: my $studentfile = $r->dir_config('lonDaemons'). 3084: '/tmp/'.$ENV{'form.datatoken'}.'.tmp'; 3085: if ( open(my $fh,"<$studentfile") ) { 3086: @studentdata=<$fh>; 3087: close($fh); 3088: } 3089: } 3090: $ENV{'form.upfile'}=join('',@studentdata); 3091: } 3092: 3093: =pod 3094: 3095: =item * upfile_record_sep() 3096: 3097: Separate uploaded file into records 3098: returns array of records, 3099: needs $ENV{'form.upfile'} and $ENV{'form.upfiletype'} 3100: 3101: =cut 3102: 3103: sub upfile_record_sep { 3104: if ($ENV{'form.upfiletype'} eq 'xml') { 3105: } else { 3106: return split(/\n/,$ENV{'form.upfile'}); 3107: } 3108: } 3109: 3110: =pod 3111: 3112: =item * record_sep($record) 3113: 3114: Separate a record into fields $record should be an item from the upfile_record_sep(), needs $ENV{'form.upfiletype'} 3115: 3116: =cut 3117: 3118: sub record_sep { 3119: my $record=shift; 3120: my %components=(); 3121: if ($ENV{'form.upfiletype'} eq 'xml') { 3122: } elsif ($ENV{'form.upfiletype'} eq 'space') { 3123: my $i=0; 3124: foreach (split(/\s+/,$record)) { 3125: my $field=$_; 3126: $field=~s/^(\"|\')//; 3127: $field=~s/(\"|\')$//; 3128: $components{$i}=$field; 3129: $i++; 3130: } 3131: } elsif ($ENV{'form.upfiletype'} eq 'tab') { 3132: my $i=0; 3133: foreach (split(/\t/,$record)) { 3134: my $field=$_; 3135: $field=~s/^(\"|\')//; 3136: $field=~s/(\"|\')$//; 3137: $components{$i}=$field; 3138: $i++; 3139: } 3140: } else { 3141: my @allfields=split(/\,/,$record); 3142: my $i=0; 3143: my $j; 3144: for ($j=0;$j<=$#allfields;$j++) { 3145: my $field=$allfields[$j]; 3146: if ($field=~/^\s*(\"|\')/) { 3147: my $delimiter=$1; 3148: while (($field!~/$delimiter$/) && ($j<$#allfields)) { 3149: $j++; 3150: $field.=','.$allfields[$j]; 3151: } 3152: $field=~s/^\s*$delimiter//; 3153: $field=~s/$delimiter\s*$//; 3154: } 3155: $components{$i}=$field; 3156: $i++; 3157: } 3158: } 3159: return %components; 3160: } 3161: 3162: ###################################################### 3163: ###################################################### 3164: 3165: =pod 3166: 3167: =item * upfile_select_html() 3168: 3169: Return HTML code to select a file from the users machine and specify 3170: the file type. 3171: 3172: =cut 3173: 3174: ###################################################### 3175: ###################################################### 3176: sub upfile_select_html { 3177: my %Types = ( 3178: csv => &mt('CSV (comma separated values, spreadsheet)'), 3179: space => &mt('Space separated'), 3180: tab => &mt('Tabulator separated'), 3181: # xml => &mt('HTML/XML'), 3182: ); 3183: my $Str = '<input type="file" name="upfile" size="50" />'. 3184: '<br />Type: <select name="upfiletype">'; 3185: foreach my $type (sort(keys(%Types))) { 3186: $Str .= '<option value="'.$type.'" >'.$Types{$type}."</option>\n"; 3187: } 3188: $Str .= "</select>\n"; 3189: return $Str; 3190: } 3191: 3192: ###################################################### 3193: ###################################################### 3194: 3195: =pod 3196: 3197: =item * csv_print_samples($r,$records) 3198: 3199: Prints a table of sample values from each column uploaded $r is an 3200: Apache Request ref, $records is an arrayref from 3201: &Apache::loncommon::upfile_record_sep 3202: 3203: =cut 3204: 3205: ###################################################### 3206: ###################################################### 3207: sub csv_print_samples { 3208: my ($r,$records) = @_; 3209: my (%sone,%stwo,%sthree); 3210: %sone=&record_sep($$records[0]); 3211: if (defined($$records[1])) {%stwo=&record_sep($$records[1]);} 3212: if (defined($$records[2])) {%sthree=&record_sep($$records[2]);} 3213: # 3214: $r->print(&mt('Samples').'<br /><table border="2"><tr>'); 3215: foreach (sort({$a <=> $b} keys(%sone))) { 3216: $r->print('<th>'.&mt('Column [_1]',($_+1)).'</th>'); } 3217: $r->print('</tr>'); 3218: foreach my $hash (\%sone,\%stwo,\%sthree) { 3219: $r->print('<tr>'); 3220: foreach (sort({$a <=> $b} keys(%sone))) { 3221: $r->print('<td>'); 3222: if (defined($$hash{$_})) { $r->print($$hash{$_}); } 3223: $r->print('</td>'); 3224: } 3225: $r->print('</tr>'); 3226: } 3227: $r->print('</tr></table><br />'."\n"); 3228: } 3229: 3230: ###################################################### 3231: ###################################################### 3232: 3233: =pod 3234: 3235: =item * csv_print_select_table($r,$records,$d) 3236: 3237: Prints a table to create associations between values and table columns. 3238: 3239: $r is an Apache Request ref, 3240: $records is an arrayref from &Apache::loncommon::upfile_record_sep, 3241: $d is an array of 2 element arrays (internal name, displayed name,defaultcol) 3242: 3243: =cut 3244: 3245: ###################################################### 3246: ###################################################### 3247: sub csv_print_select_table { 3248: my ($r,$records,$d) = @_; 3249: my $i=0;my %sone; 3250: %sone=&record_sep($$records[0]); 3251: $r->print(&mt('Associate columns with student attributes.')."\n". 3252: '<table border="2"><tr>'. 3253: '<th>'.&mt('Attribute').'</th>'. 3254: '<th>'.&mt('Column').'</th></tr>'."\n"); 3255: foreach (@$d) { 3256: my ($value,$display,$defaultcol)=@{ $_ }; 3257: $r->print('<tr><td>'.$display.'</td>'); 3258: 3259: $r->print('<td><select name=f'.$i. 3260: ' onchange="javascript:flip(this.form,'.$i.');">'); 3261: $r->print('<option value="none"></option>'); 3262: foreach (sort({$a <=> $b} keys(%sone))) { 3263: $r->print('<option value="'.$_.'"'. 3264: ($_ eq $defaultcol ? ' selected ' : ''). 3265: '>Column '.($_+1).'</option>'); 3266: } 3267: $r->print('</select></td></tr>'."\n"); 3268: $i++; 3269: } 3270: $i--; 3271: return $i; 3272: } 3273: 3274: ###################################################### 3275: ###################################################### 3276: 3277: =pod 3278: 3279: =item * csv_samples_select_table($r,$records,$d) 3280: 3281: Prints a table of sample values from the upload and can make associate samples to internal names. 3282: 3283: $r is an Apache Request ref, 3284: $records is an arrayref from &Apache::loncommon::upfile_record_sep, 3285: $d is an array of 2 element arrays (internal name, displayed name) 3286: 3287: =cut 3288: 3289: ###################################################### 3290: ###################################################### 3291: sub csv_samples_select_table { 3292: my ($r,$records,$d) = @_; 3293: my %sone; my %stwo; my %sthree; 3294: my $i=0; 3295: # 3296: $r->print('<table border=2><tr><th>'. 3297: &mt('Field').'</th><th>'.&mt('Samples').'</th></tr>'); 3298: %sone=&record_sep($$records[0]); 3299: if (defined($$records[1])) {%stwo=&record_sep($$records[1]);} 3300: if (defined($$records[2])) {%sthree=&record_sep($$records[2]);} 3301: # 3302: foreach (sort keys %sone) { 3303: $r->print('<tr><td><select name="f'.$i.'"'. 3304: ' onchange="javascript:flip(this.form,'.$i.');">'); 3305: foreach (@$d) { 3306: my ($value,$display,$defaultcol)=@{ $_ }; 3307: $r->print('<option value="'.$value.'"'. 3308: ($i eq $defaultcol ? ' selected ':'').'>'. 3309: $display.'</option>'); 3310: } 3311: $r->print('</select></td><td>'); 3312: if (defined($sone{$_})) { $r->print($sone{$_}."</br>\n"); } 3313: if (defined($stwo{$_})) { $r->print($stwo{$_}."</br>\n"); } 3314: if (defined($sthree{$_})) { $r->print($sthree{$_}."</br>\n"); } 3315: $r->print('</td></tr>'); 3316: $i++; 3317: } 3318: $i--; 3319: return($i); 3320: } 3321: 3322: ###################################################### 3323: ###################################################### 3324: 3325: =pod 3326: 3327: =item clean_excel_name($name) 3328: 3329: Returns a replacement for $name which does not contain any illegal characters. 3330: 3331: =cut 3332: 3333: ###################################################### 3334: ###################################################### 3335: sub clean_excel_name { 3336: my ($name) = @_; 3337: $name =~ s/[:\*\?\/\\]//g; 3338: if (length($name) > 31) { 3339: $name = substr($name,0,31); 3340: } 3341: return $name; 3342: } 3343: 3344: =pod 3345: 3346: =item * check_if_partid_hidden($id,$symb,$udom,$uname) 3347: 3348: Returns either 1 or undef 3349: 3350: 1 if the part is to be hidden, undef if it is to be shown 3351: 3352: Arguments are: 3353: 3354: $id the id of the part to be checked 3355: $symb, optional the symb of the resource to check 3356: $udom, optional the domain of the user to check for 3357: $uname, optional the username of the user to check for 3358: 3359: =cut 3360: 3361: sub check_if_partid_hidden { 3362: my ($id,$symb,$udom,$uname) = @_; 3363: my $hiddenparts=&Apache::lonnet::EXT('resource.0.hiddenparts', 3364: $symb,$udom,$uname); 3365: my $truth=1; 3366: #if the string starts with !, then the list is the list to show not hide 3367: if ($hiddenparts=~s/^\s*!//) { $truth=undef; } 3368: my @hiddenlist=split(/,/,$hiddenparts); 3369: foreach my $checkid (@hiddenlist) { 3370: if ($checkid =~ /^\s*\Q$id\E\s*$/) { return $truth; } 3371: } 3372: return !$truth; 3373: } 3374: 3375: 3376: ############################################################ 3377: ############################################################ 3378: 3379: =pod 3380: 3381: =back 3382: 3383: =head1 cgi-bin script and graphing routines 3384: 3385: =over 4 3386: 3387: =item get_cgi_id 3388: 3389: Inputs: none 3390: 3391: Returns an id which can be used to pass environment variables 3392: to various cgi-bin scripts. These environment variables will 3393: be removed from the users environment after a given time by 3394: the routine &Apache::lonnet::transfer_profile_to_env. 3395: 3396: =cut 3397: 3398: ############################################################ 3399: ############################################################ 3400: my $uniq=0; 3401: sub get_cgi_id { 3402: $uniq=($uniq+1)%100000; 3403: return (time.'_'.$uniq); 3404: } 3405: 3406: ############################################################ 3407: ############################################################ 3408: 3409: =pod 3410: 3411: =item DrawBarGraph 3412: 3413: Facilitates the plotting of data in a (stacked) bar graph. 3414: Puts plot definition data into the users environment in order for 3415: graph.png to plot it. Returns an <img> tag for the plot. 3416: The bars on the plot are labeled '1','2',...,'n'. 3417: 3418: Inputs: 3419: 3420: =over 4 3421: 3422: =item $Title: string, the title of the plot 3423: 3424: =item $xlabel: string, text describing the X-axis of the plot 3425: 3426: =item $ylabel: string, text describing the Y-axis of the plot 3427: 3428: =item $Max: scalar, the maximum Y value to use in the plot 3429: If $Max is < any data point, the graph will not be rendered. 3430: 3431: =item $colors: array ref holding the colors to be used for the data sets when 3432: they are plotted. If undefined, default values will be used. 3433: 3434: =item $labels: array ref holding the labels to use on the x-axis for the bars. 3435: 3436: =item @Values: An array of array references. Each array reference holds data 3437: to be plotted in a stacked bar chart. 3438: 3439: =item If the final element of @Values is a hash reference the key/value 3440: pairs will be added to the graph definition. 3441: 3442: =back 3443: 3444: Returns: 3445: 3446: An <img> tag which references graph.png and the appropriate identifying 3447: information for the plot. 3448: 3449: =cut 3450: 3451: ############################################################ 3452: ############################################################ 3453: sub DrawBarGraph { 3454: my ($Title,$xlabel,$ylabel,$Max,$colors,$labels,@Values)=@_; 3455: # 3456: if (! defined($colors)) { 3457: $colors = ['#33ff00', 3458: '#0033cc', '#990000', '#aaaa66', '#663399', '#ff9933', 3459: '#66ccff', '#ff9999', '#cccc33', '#660000', '#33cc66', 3460: ]; 3461: } 3462: my $extra_settings = {}; 3463: if (ref($Values[-1]) eq 'HASH') { 3464: $extra_settings = pop(@Values); 3465: } 3466: # 3467: my $identifier = &get_cgi_id(); 3468: my $id = 'cgi.'.$identifier; 3469: if (! @Values || ref($Values[0]) ne 'ARRAY') { 3470: return ''; 3471: } 3472: # 3473: my @Labels; 3474: if (defined($labels)) { 3475: @Labels = @$labels; 3476: } else { 3477: for (my $i=0;$i<@{$Values[0]};$i++) { 3478: push (@Labels,$i+1); 3479: } 3480: } 3481: # 3482: my $NumBars = scalar(@{$Values[0]}); 3483: if ($NumBars < scalar(@Labels)) { $NumBars = scalar(@Labels); } 3484: my %ValuesHash; 3485: my $NumSets=1; 3486: foreach my $array (@Values) { 3487: next if (! ref($array)); 3488: $ValuesHash{$id.'.data.'.$NumSets++} = 3489: join(',',@$array); 3490: } 3491: # 3492: my ($height,$width,$xskip,$bar_width) = (200,120,1,15); 3493: if ($NumBars < 3) { 3494: $width = 120+$NumBars*32; 3495: $xskip = 1; 3496: $bar_width = 30; 3497: } elsif ($NumBars < 5) { 3498: $width = 120+$NumBars*20; 3499: $xskip = 1; 3500: $bar_width = 20; 3501: } elsif ($NumBars < 10) { 3502: $width = 120+$NumBars*15; 3503: $xskip = 1; 3504: $bar_width = 15; 3505: } elsif ($NumBars <= 25) { 3506: $width = 120+$NumBars*11; 3507: $xskip = 5; 3508: $bar_width = 8; 3509: } elsif ($NumBars <= 50) { 3510: $width = 120+$NumBars*8; 3511: $xskip = 5; 3512: $bar_width = 4; 3513: } else { 3514: $width = 120+$NumBars*8; 3515: $xskip = 5; 3516: $bar_width = 4; 3517: } 3518: # 3519: $Max = 1 if ($Max < 1); 3520: if ( int($Max) < $Max ) { 3521: $Max++; 3522: $Max = int($Max); 3523: } 3524: $Title = '' if (! defined($Title)); 3525: $xlabel = '' if (! defined($xlabel)); 3526: $ylabel = '' if (! defined($ylabel)); 3527: $ValuesHash{$id.'.title'} = &Apache::lonnet::escape($Title); 3528: $ValuesHash{$id.'.xlabel'} = &Apache::lonnet::escape($xlabel); 3529: $ValuesHash{$id.'.ylabel'} = &Apache::lonnet::escape($ylabel); 3530: $ValuesHash{$id.'.y_max_value'} = $Max; 3531: $ValuesHash{$id.'.NumBars'} = $NumBars; 3532: $ValuesHash{$id.'.NumSets'} = $NumSets; 3533: $ValuesHash{$id.'.PlotType'} = 'bar'; 3534: $ValuesHash{$id.'.Colors'} = join(',',@{$colors}); 3535: $ValuesHash{$id.'.height'} = $height; 3536: $ValuesHash{$id.'.width'} = $width; 3537: $ValuesHash{$id.'.xskip'} = $xskip; 3538: $ValuesHash{$id.'.bar_width'} = $bar_width; 3539: $ValuesHash{$id.'.labels'} = join(',',@Labels); 3540: # 3541: # Deal with other parameters 3542: while (my ($key,$value) = each(%$extra_settings)) { 3543: $ValuesHash{$id.'.'.$key} = $value; 3544: } 3545: # 3546: &Apache::lonnet::appenv(%ValuesHash); 3547: return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />'; 3548: } 3549: 3550: ############################################################ 3551: ############################################################ 3552: 3553: =pod 3554: 3555: =item DrawXYGraph 3556: 3557: Facilitates the plotting of data in an XY graph. 3558: Puts plot definition data into the users environment in order for 3559: graph.png to plot it. Returns an <img> tag for the plot. 3560: 3561: Inputs: 3562: 3563: =over 4 3564: 3565: =item $Title: string, the title of the plot 3566: 3567: =item $xlabel: string, text describing the X-axis of the plot 3568: 3569: =item $ylabel: string, text describing the Y-axis of the plot 3570: 3571: =item $Max: scalar, the maximum Y value to use in the plot 3572: If $Max is < any data point, the graph will not be rendered. 3573: 3574: =item $colors: Array ref containing the hex color codes for the data to be 3575: plotted in. If undefined, default values will be used. 3576: 3577: =item $Xlabels: Array ref containing the labels to be used for the X-axis. 3578: 3579: =item $Ydata: Array ref containing Array refs. 3580: Each of the contained arrays will be plotted as a separate curve. 3581: 3582: =item %Values: hash indicating or overriding any default values which are 3583: passed to graph.png. 3584: Possible values are: width, xskip, x_ticks, x_tick_offset, among others. 3585: 3586: =back 3587: 3588: Returns: 3589: 3590: An <img> tag which references graph.png and the appropriate identifying 3591: information for the plot. 3592: 3593: =cut 3594: 3595: ############################################################ 3596: ############################################################ 3597: sub DrawXYGraph { 3598: my ($Title,$xlabel,$ylabel,$Max,$colors,$Xlabels,$Ydata,%Values)=@_; 3599: # 3600: # Create the identifier for the graph 3601: my $identifier = &get_cgi_id(); 3602: my $id = 'cgi.'.$identifier; 3603: # 3604: $Title = '' if (! defined($Title)); 3605: $xlabel = '' if (! defined($xlabel)); 3606: $ylabel = '' if (! defined($ylabel)); 3607: my %ValuesHash = 3608: ( 3609: $id.'.title' => &Apache::lonnet::escape($Title), 3610: $id.'.xlabel' => &Apache::lonnet::escape($xlabel), 3611: $id.'.ylabel' => &Apache::lonnet::escape($ylabel), 3612: $id.'.y_max_value'=> $Max, 3613: $id.'.labels' => join(',',@$Xlabels), 3614: $id.'.PlotType' => 'XY', 3615: ); 3616: # 3617: if (defined($colors) && ref($colors) eq 'ARRAY') { 3618: $ValuesHash{$id.'.Colors'} = join(',',@{$colors}); 3619: } 3620: # 3621: if (! ref($Ydata) || ref($Ydata) ne 'ARRAY') { 3622: return ''; 3623: } 3624: my $NumSets=1; 3625: foreach my $array (@{$Ydata}){ 3626: next if (! ref($array)); 3627: $ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array); 3628: } 3629: $ValuesHash{$id.'.NumSets'} = $NumSets-1; 3630: # 3631: # Deal with other parameters 3632: while (my ($key,$value) = each(%Values)) { 3633: $ValuesHash{$id.'.'.$key} = $value; 3634: } 3635: # 3636: &Apache::lonnet::appenv(%ValuesHash); 3637: return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />'; 3638: } 3639: 3640: ############################################################ 3641: ############################################################ 3642: 3643: =pod 3644: 3645: =item DrawXYYGraph 3646: 3647: Facilitates the plotting of data in an XY graph with two Y axes. 3648: Puts plot definition data into the users environment in order for 3649: graph.png to plot it. Returns an <img> tag for the plot. 3650: 3651: Inputs: 3652: 3653: =over 4 3654: 3655: =item $Title: string, the title of the plot 3656: 3657: =item $xlabel: string, text describing the X-axis of the plot 3658: 3659: =item $ylabel: string, text describing the Y-axis of the plot 3660: 3661: =item $colors: Array ref containing the hex color codes for the data to be 3662: plotted in. If undefined, default values will be used. 3663: 3664: =item $Xlabels: Array ref containing the labels to be used for the X-axis. 3665: 3666: =item $Ydata1: The first data set 3667: 3668: =item $Min1: The minimum value of the left Y-axis 3669: 3670: =item $Max1: The maximum value of the left Y-axis 3671: 3672: =item $Ydata2: The second data set 3673: 3674: =item $Min2: The minimum value of the right Y-axis 3675: 3676: =item $Max2: The maximum value of the left Y-axis 3677: 3678: =item %Values: hash indicating or overriding any default values which are 3679: passed to graph.png. 3680: Possible values are: width, xskip, x_ticks, x_tick_offset, among others. 3681: 3682: =back 3683: 3684: Returns: 3685: 3686: An <img> tag which references graph.png and the appropriate identifying 3687: information for the plot. 3688: 3689: =cut 3690: 3691: ############################################################ 3692: ############################################################ 3693: sub DrawXYYGraph { 3694: my ($Title,$xlabel,$ylabel,$colors,$Xlabels,$Ydata1,$Min1,$Max1, 3695: $Ydata2,$Min2,$Max2,%Values)=@_; 3696: # 3697: # Create the identifier for the graph 3698: my $identifier = &get_cgi_id(); 3699: my $id = 'cgi.'.$identifier; 3700: # 3701: $Title = '' if (! defined($Title)); 3702: $xlabel = '' if (! defined($xlabel)); 3703: $ylabel = '' if (! defined($ylabel)); 3704: my %ValuesHash = 3705: ( 3706: $id.'.title' => &Apache::lonnet::escape($Title), 3707: $id.'.xlabel' => &Apache::lonnet::escape($xlabel), 3708: $id.'.ylabel' => &Apache::lonnet::escape($ylabel), 3709: $id.'.labels' => join(',',@$Xlabels), 3710: $id.'.PlotType' => 'XY', 3711: $id.'.NumSets' => 2, 3712: $id.'.two_axes' => 1, 3713: $id.'.y1_max_value' => $Max1, 3714: $id.'.y1_min_value' => $Min1, 3715: $id.'.y2_max_value' => $Max2, 3716: $id.'.y2_min_value' => $Min2, 3717: ); 3718: # 3719: if (defined($colors) && ref($colors) eq 'ARRAY') { 3720: $ValuesHash{$id.'.Colors'} = join(',',@{$colors}); 3721: } 3722: # 3723: if (! ref($Ydata1) || ref($Ydata1) ne 'ARRAY' || 3724: ! ref($Ydata2) || ref($Ydata2) ne 'ARRAY'){ 3725: return ''; 3726: } 3727: my $NumSets=1; 3728: foreach my $array ($Ydata1,$Ydata2){ 3729: next if (! ref($array)); 3730: $ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array); 3731: } 3732: # 3733: # Deal with other parameters 3734: while (my ($key,$value) = each(%Values)) { 3735: $ValuesHash{$id.'.'.$key} = $value; 3736: } 3737: # 3738: &Apache::lonnet::appenv(%ValuesHash); 3739: return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />'; 3740: } 3741: 3742: ############################################################ 3743: ############################################################ 3744: 3745: =pod 3746: 3747: =back 3748: 3749: =head1 Statistics helper routines? 3750: 3751: Bad place for them but what the hell. 3752: 3753: =over 4 3754: 3755: =item &chartlink 3756: 3757: Returns a link to the chart for a specific student. 3758: 3759: Inputs: 3760: 3761: =over 4 3762: 3763: =item $linktext: The text of the link 3764: 3765: =item $sname: The students username 3766: 3767: =item $sdomain: The students domain 3768: 3769: =back 3770: 3771: =back 3772: 3773: =cut 3774: 3775: ############################################################ 3776: ############################################################ 3777: sub chartlink { 3778: my ($linktext, $sname, $sdomain) = @_; 3779: my $link = '<a href="/adm/statistics?reportSelected=student_assessment'. 3780: '&SelectedStudent='.&Apache::lonnet::escape($sname.':'.$sdomain). 3781: '&chartoutputmode='.HTML::Entities::encode('html, with all links'). 3782: '">'.$linktext.'</a>'; 3783: } 3784: 3785: ####################################################### 3786: ####################################################### 3787: 3788: =pod 3789: 3790: =head1 Course Environment Routines 3791: 3792: =over 4 3793: 3794: =item &restore_course_settings 3795: 3796: =item &store_course_settings 3797: 3798: Restores/Store indicated form parameters from the course environment. 3799: Will not overwrite existing values of the form parameters. 3800: 3801: Inputs: 3802: a scalar describing the data (e.g. 'chart', 'problem_analysis') 3803: 3804: a hash ref describing the data to be stored. For example: 3805: 3806: %Save_Parameters = ('Status' => 'scalar', 3807: 'chartoutputmode' => 'scalar', 3808: 'chartoutputdata' => 'scalar', 3809: 'Section' => 'array', 3810: 'StudentData' => 'array', 3811: 'Maps' => 'array'); 3812: 3813: Returns: both routines return nothing 3814: 3815: =cut 3816: 3817: ####################################################### 3818: ####################################################### 3819: sub store_course_settings { 3820: # save to the environment 3821: # appenv the same items, just to be safe 3822: my $courseid = $ENV{'request.course.id'}; 3823: my $coursedom = $ENV{'course.'.$courseid.'.domain'}; 3824: my ($prefix,$Settings) = @_; 3825: my %SaveHash; 3826: my %AppHash; 3827: while (my ($setting,$type) = each(%$Settings)) { 3828: my $basename = 'internal.'.$prefix.'.'.$setting; 3829: my $envname = 'course.'.$courseid.'.'.$basename; 3830: if (exists($ENV{'form.'.$setting})) { 3831: # Save this value away 3832: if ($type eq 'scalar' && 3833: (! exists($ENV{$envname}) || 3834: $ENV{$envname} ne $ENV{'form.'.$setting})) { 3835: $SaveHash{$basename} = $ENV{'form.'.$setting}; 3836: $AppHash{$envname} = $ENV{'form.'.$setting}; 3837: } elsif ($type eq 'array') { 3838: my $stored_form; 3839: if (ref($ENV{'form.'.$setting})) { 3840: $stored_form = join(',', 3841: map { 3842: &Apache::lonnet::escape($_); 3843: } sort(@{$ENV{'form.'.$setting}})); 3844: } else { 3845: $stored_form = 3846: &Apache::lonnet::escape($ENV{'form.'.$setting}); 3847: } 3848: # Determine if the array contents are the same. 3849: if ($stored_form ne $ENV{$envname}) { 3850: $SaveHash{$basename} = $stored_form; 3851: $AppHash{$envname} = $stored_form; 3852: } 3853: } 3854: } 3855: } 3856: my $put_result = &Apache::lonnet::put('environment',\%SaveHash, 3857: $coursedom, 3858: $ENV{'course.'.$courseid.'.num'}); 3859: if ($put_result !~ /^(ok|delayed)/) { 3860: &Apache::lonnet::logthis('unable to save form parameters, '. 3861: 'got error:'.$put_result); 3862: } 3863: # Make sure these settings stick around in this session, too 3864: &Apache::lonnet::appenv(%AppHash); 3865: return; 3866: } 3867: 3868: sub restore_course_settings { 3869: my $courseid = $ENV{'request.course.id'}; 3870: my ($prefix,$Settings) = @_; 3871: while (my ($setting,$type) = each(%$Settings)) { 3872: next if (exists($ENV{'form.'.$setting})); 3873: my $envname = 'course.'.$courseid.'.internal.'.$prefix. 3874: '.'.$setting; 3875: if (exists($ENV{$envname})) { 3876: if ($type eq 'scalar') { 3877: $ENV{'form.'.$setting} = $ENV{$envname}; 3878: } elsif ($type eq 'array') { 3879: $ENV{'form.'.$setting} = [ 3880: map { 3881: &Apache::lonnet::unescape($_); 3882: } split(',',$ENV{$envname}) 3883: ]; 3884: } 3885: } 3886: } 3887: } 3888: 3889: ############################################################ 3890: ############################################################ 3891: 3892: sub propath { 3893: my ($udom,$uname)=@_; 3894: $udom=~s/\W//g; 3895: $uname=~s/\W//g; 3896: my $subdir=$uname.'__'; 3897: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; 3898: my $proname="$Apache::lonnet::perlvar{'lonUsersDir'}/$udom/$subdir/$uname"; 3899: return $proname; 3900: } 3901: 3902: sub icon { 3903: my ($file)=@_; 3904: my $curfext = (split(/\./,$file))[-1]; 3905: my $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/unknown.gif'; 3906: my $embstyle = &Apache::loncommon::fileembstyle($curfext); 3907: if (!(!defined($embstyle) || $embstyle eq 'unk' || $embstyle eq 'hdn')) { 3908: if (-e $Apache::lonnet::perlvar{'lonDocRoot'}.'/'. 3909: $Apache::lonnet::perlvar{'lonIconsURL'}.'/'. 3910: $curfext.".gif") { 3911: $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/'. 3912: $curfext.".gif"; 3913: } 3914: } 3915: return $iconname; 3916: } 3917: 3918: sub lonhttpdurl { 3919: my ($url)=@_; 3920: my $lonhttpd_port=$Apache::lonnet::perlvar{'lonhttpdPort'}; 3921: if (!defined($lonhttpd_port)) { $lonhttpd_port='8080'; } 3922: return 'http://'.$ENV{'SERVER_NAME'}.':'.$lonhttpd_port.$url; 3923: } 3924: 3925: sub connection_aborted { 3926: my ($r)=@_; 3927: $r->print(" ");$r->rflush(); 3928: my $c = $r->connection; 3929: return $c->aborted(); 3930: } 3931: 3932: # Escapes strings that may have embedded 's that will be put into 3933: # strings as 'strings'. 3934: sub escape_single { 3935: my ($input) = @_; 3936: $input =~ s/\\/\\\\/g; # Escape the \'s..(must be first)> 3937: $input =~ s/\'/\\\'/g; # Esacpe the 's.... 3938: return $input; 3939: } 3940: 3941: # Same as escape_single, but escape's "'s This 3942: # can be used for "strings" 3943: sub escape_double { 3944: my ($input) = @_; 3945: $input =~ s/\\/\\\\/g; # Escape the /'s..(must be first)> 3946: $input =~ s/\"/\\\"/g; # Esacpe the "s.... 3947: return $input; 3948: } 3949: 3950: # Escapes the last element of a full URL. 3951: sub escape_url { 3952: my ($url) = @_; 3953: my @urlslices = split(/\//, $url,-1); 3954: my $lastitem = &Apache::lonnet::escape(pop(@urlslices)); 3955: return join('/',@urlslices).'/'.$lastitem; 3956: } 3957: =pod 3958: 3959: =back 3960: 3961: =cut 3962: 3963: 1; 3964: __END__; 3965: