loncom/interface/loncommon.pm - view

File: [LON-CAPA] / loncom / interface / loncommon.pm
Revision 1.229: download - view: text, annotated - select for diffs
Thu Nov 11 23:45:36 2004 UTC (19 years, 6 months ago) by albertel
Branches: MAIN
CVS tags: HEAD


- moving the header generation out of innerregister and into bodytag
- making homework problems grab bodytag in cstr when there isn;'t a remote

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