![]() ![]() | ![]() |
iCalendar working, at least with Apple iCal
1: # The LearningOnline Network with CAPA 2: # a pile of common routines 3: # 4: # $Id: loncommon.pm,v 1.371 2006/05/12 15:53:10 www Exp $ 5: # 6: # Copyright Michigan State University Board of Trustees 7: # 8: # This file is part of the LearningOnline Network with CAPA (LON-CAPA). 9: # 10: # LON-CAPA is free software; you can redistribute it and/or modify 11: # it under the terms of the GNU General Public License as published by 12: # the Free Software Foundation; either version 2 of the License, or 13: # (at your option) any later version. 14: # 15: # LON-CAPA is distributed in the hope that it will be useful, 16: # but WITHOUT ANY WARRANTY; without even the implied warranty of 17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18: # GNU General Public License for more details. 19: # 20: # You should have received a copy of the GNU General Public License 21: # along with LON-CAPA; if not, write to the Free Software 22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 23: # 24: # /home/httpd/html/adm/gpl.txt 25: # 26: # http://www.lon-capa.org/ 27: # 28: 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::lonmenu(); 62: use Apache::lonlocal; 63: use HTML::Entities; 64: use Apache::lonhtmlcommon(); 65: use Apache::loncoursedata(); 66: use Apache::lontexconvert(); 67: use LONCAPA; 68: 69: my $readit; 70: 71: ## 72: ## Global Variables 73: ## 74: 75: # ----------------------------------------------- Filetypes/Languages/Copyright 76: my %language; 77: my %supported_language; 78: my %cprtag; 79: my %scprtag; 80: my %fe; my %fd; my %fm; 81: my %category_extensions; 82: 83: # ---------------------------------------------- Designs 84: 85: my %designhash; 86: 87: # ---------------------------------------------- Thesaurus variables 88: # 89: # %Keywords: 90: # A hash used by &keyword to determine if a word is considered a keyword. 91: # $thesaurus_db_file 92: # Scalar containing the full path to the thesaurus database. 93: 94: my %Keywords; 95: my $thesaurus_db_file; 96: 97: # 98: # Initialize values from language.tab, copyright.tab, filetypes.tab, 99: # thesaurus.tab, and filecategories.tab. 100: # 101: BEGIN { 102: # Variable initialization 103: $thesaurus_db_file = $Apache::lonnet::perlvar{'lonTabDir'}."/thesaurus.db"; 104: # 105: unless ($readit) { 106: # ------------------------------------------------------------------- languages 107: { 108: my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}. 109: '/language.tab'; 110: if ( open(my $fh,"<$langtabfile") ) { 111: while (my $line = <$fh>) { 112: next if ($line=~/^\#/); 113: chomp($line); 114: my ($key,$two,$country,$three,$enc,$val,$sup)=(split(/\t/,$line)); 115: $language{$key}=$val.' - '.$enc; 116: if ($sup) { 117: $supported_language{$key}=$sup; 118: } 119: } 120: close($fh); 121: } 122: } 123: # ------------------------------------------------------------------ copyrights 124: { 125: my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. 126: '/copyright.tab'; 127: if ( open (my $fh,"<$copyrightfile") ) { 128: while (my $line = <$fh>) { 129: next if ($line=~/^\#/); 130: chomp($line); 131: my ($key,$val)=(split(/\s+/,$line,2)); 132: $cprtag{$key}=$val; 133: } 134: close($fh); 135: } 136: } 137: # ----------------------------------------------------------- source copyrights 138: { 139: my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. 140: '/source_copyright.tab'; 141: if ( open (my $fh,"<$sourcecopyrightfile") ) { 142: while (my $line = <$fh>) { 143: next if ($line =~ /^\#/); 144: chomp($line); 145: my ($key,$val)=(split(/\s+/,$line,2)); 146: $scprtag{$key}=$val; 147: } 148: close($fh); 149: } 150: } 151: 152: # -------------------------------------------------------------- domain designs 153: 154: my $filename; 155: my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors'; 156: opendir(DIR,$designdir); 157: while ($filename=readdir(DIR)) { 158: if ($filename!~/\.tab$/) { next; } 159: my ($domain)=($filename=~/^(\w+)\./); 160: { 161: my $designfile = $designdir.'/'.$filename; 162: if ( open (my $fh,"<$designfile") ) { 163: while (my $line = <$fh>) { 164: next if ($line =~ /^\#/); 165: chomp($line); 166: my ($key,$val)=(split(/\=/,$line)); 167: if ($val) { $designhash{$domain.'.'.$key}=$val; } 168: } 169: close($fh); 170: } 171: } 172: 173: } 174: closedir(DIR); 175: 176: 177: # ------------------------------------------------------------- file categories 178: { 179: my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}. 180: '/filecategories.tab'; 181: if ( open (my $fh,"<$categoryfile") ) { 182: while (my $line = <$fh>) { 183: next if ($line =~ /^\#/); 184: chomp($line); 185: my ($extension,$category)=(split(/\s+/,$line,2)); 186: push @{$category_extensions{lc($category)}},$extension; 187: } 188: close($fh); 189: } 190: 191: } 192: # ------------------------------------------------------------------ file types 193: { 194: my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}. 195: '/filetypes.tab'; 196: if ( open (my $fh,"<$typesfile") ) { 197: while (my $line = <$fh>) { 198: next if ($line =~ /^\#/); 199: chomp($line); 200: my ($ending,$emb,$mime,$descr)=split(/\s+/,$line,4); 201: if ($descr ne '') { 202: $fe{$ending}=lc($emb); 203: $fd{$ending}=$descr; 204: if ($mime ne 'unk') { $fm{$ending}=$mime; } 205: } 206: } 207: close($fh); 208: } 209: } 210: &Apache::lonnet::logthis( 211: "<font color=yellow>INFO: Read file types</font>"); 212: $readit=1; 213: } # end of unless($readit) 214: 215: } 216: 217: ############################################################### 218: ## HTML and Javascript Helper Functions ## 219: ############################################################### 220: 221: =pod 222: 223: =head1 HTML and Javascript Functions 224: 225: =over 4 226: 227: =item * browser_and_searcher_javascript () 228: 229: X<browsing, javascript>X<searching, javascript>Returns a string 230: containing javascript with two functions, C<openbrowser> and 231: C<opensearcher>. Returned string does not contain E<lt>scriptE<gt> 232: tags. 233: 234: =item * openbrowser(formname,elementname,only,omit) [javascript] 235: 236: inputs: formname, elementname, only, omit 237: 238: formname and elementname indicate the name of the html form and name of 239: the element that the results of the browsing selection are to be placed in. 240: 241: Specifying 'only' will restrict the browser to displaying only files 242: with the given extension. Can be a comma separated list. 243: 244: Specifying 'omit' will restrict the browser to NOT displaying files 245: with the given extension. Can be a comma separated list. 246: 247: =item * opensearcher(formname, elementname) [javascript] 248: 249: Inputs: formname, elementname 250: 251: formname and elementname specify the name of the html form and the name 252: of the element the selection from the search results will be placed in. 253: 254: =cut 255: 256: sub browser_and_searcher_javascript { 257: my ($mode)=@_; 258: if (!defined($mode)) { $mode='edit'; } 259: my $resurl=&lastresurl(); 260: return <<END; 261: // <!-- BEGIN LON-CAPA Internal 262: var editbrowser = null; 263: function openbrowser(formname,elementname,only,omit,titleelement) { 264: var url = '$resurl/?'; 265: if (editbrowser == null) { 266: url += 'launch=1&'; 267: } 268: url += 'catalogmode=interactive&'; 269: url += 'mode=$mode&'; 270: url += 'form=' + formname + '&'; 271: if (only != null) { 272: url += 'only=' + only + '&'; 273: } else { 274: url += 'only=&'; 275: } 276: if (omit != null) { 277: url += 'omit=' + omit + '&'; 278: } else { 279: url += 'omit=&'; 280: } 281: if (titleelement != null) { 282: url += 'titleelement=' + titleelement + '&'; 283: } else { 284: url += 'titleelement=&'; 285: } 286: url += 'element=' + elementname + ''; 287: var title = 'Browser'; 288: var options = 'scrollbars=1,resizable=1,menubar=1,location=1'; 289: options += ',width=700,height=600'; 290: editbrowser = open(url,title,options,'1'); 291: editbrowser.focus(); 292: } 293: var editsearcher; 294: function opensearcher(formname,elementname,titleelement) { 295: var url = '/adm/searchcat?'; 296: if (editsearcher == null) { 297: url += 'launch=1&'; 298: } 299: url += 'catalogmode=interactive&'; 300: url += 'mode=$mode&'; 301: url += 'form=' + formname + '&'; 302: if (titleelement != null) { 303: url += 'titleelement=' + titleelement + '&'; 304: } else { 305: url += 'titleelement=&'; 306: } 307: url += 'element=' + elementname + ''; 308: var title = 'Search'; 309: var options = 'scrollbars=1,resizable=1,menubar=0'; 310: options += ',width=700,height=600'; 311: editsearcher = open(url,title,options,'1'); 312: editsearcher.focus(); 313: } 314: // END LON-CAPA Internal --> 315: END 316: } 317: 318: sub lastresurl { 319: if ($env{'environment.lastresurl'}) { 320: return $env{'environment.lastresurl'} 321: } else { 322: return '/res'; 323: } 324: } 325: 326: sub storeresurl { 327: my $resurl=&Apache::lonnet::clutter(shift); 328: unless ($resurl=~/^\/res/) { return 0; } 329: $resurl=~s/\/$//; 330: &Apache::lonnet::put('environment',{'lastresurl' => $resurl}); 331: &Apache::lonnet::appenv('environment.lastresurl' => $resurl); 332: return 1; 333: } 334: 335: sub studentbrowser_javascript { 336: unless ( 337: (($env{'request.course.id'}) && 338: (&Apache::lonnet::allowed('srm',$env{'request.course.id'}) 339: || &Apache::lonnet::allowed('srm',$env{'request.course.id'}. 340: '/'.$env{'request.course.sec'}) 341: )) 342: || ($env{'request.role'}=~/^(au|dc|su)/) 343: ) { return ''; } 344: return (<<'ENDSTDBRW'); 345: <script type="text/javascript" language="Javascript" > 346: var stdeditbrowser; 347: function openstdbrowser(formname,uname,udom,roleflag) { 348: var url = '/adm/pickstudent?'; 349: var filter; 350: eval('filter=document.'+formname+'.'+uname+'.value;'); 351: if (filter != null) { 352: if (filter != '') { 353: url += 'filter='+filter+'&'; 354: } 355: } 356: url += 'form=' + formname + '&unameelement='+uname+ 357: '&udomelement='+udom; 358: if (roleflag) { url+="&roles=1"; } 359: var title = 'Student_Browser'; 360: var options = 'scrollbars=1,resizable=1,menubar=0'; 361: options += ',width=700,height=600'; 362: stdeditbrowser = open(url,title,options,'1'); 363: stdeditbrowser.focus(); 364: } 365: </script> 366: ENDSTDBRW 367: } 368: 369: sub selectstudent_link { 370: my ($form,$unameele,$udomele)=@_; 371: if ($env{'request.course.id'}) { 372: if (!&Apache::lonnet::allowed('srm',$env{'request.course.id'}) 373: && !&Apache::lonnet::allowed('srm',$env{'request.course.id'}. 374: '/'.$env{'request.course.sec'})) { 375: return ''; 376: } 377: return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele. 378: '","'.$udomele.'");'."'>".&mt('Select User')."</a>"; 379: } 380: if ($env{'request.role'}=~/^(au|dc|su)/) { 381: return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele. 382: '","'.$udomele.'",1);'."'>".&mt('Select User')."</a>"; 383: } 384: return ''; 385: } 386: 387: sub coursebrowser_javascript { 388: my ($domainfilter)=@_; 389: return (<<ENDSTDBRW); 390: <script type="text/javascript" language="Javascript" > 391: var stdeditbrowser; 392: function opencrsbrowser(formname,uname,udom,desc,extra_element,multflag) { 393: var url = '/adm/pickcourse?'; 394: var filter; 395: if (filter != null) { 396: if (filter != '') { 397: url += 'filter='+filter+'&'; 398: } 399: } 400: var domainfilter='$domainfilter'; 401: if (domainfilter != null) { 402: if (domainfilter != '') { 403: url += 'domainfilter='+domainfilter+'&'; 404: } 405: } 406: url += 'form=' + formname + '&cnumelement='+uname+ 407: '&cdomelement='+udom+ 408: '&cnameelement='+desc; 409: if (extra_element !=null && extra_element != '' && formname == 'rolechoice') { 410: url += '&roleelement='+extra_element; 411: if (domainfilter == null || domainfilter == '') { 412: url += '&domainfilter='+extra_element; 413: } 414: } 415: if (multflag !=null && multflag != '') { 416: url += '&multiple='+multflag; 417: } 418: var title = 'Course_Browser'; 419: var options = 'scrollbars=1,resizable=1,menubar=0'; 420: options += ',width=700,height=600'; 421: stdeditbrowser = open(url,title,options,'1'); 422: stdeditbrowser.focus(); 423: } 424: </script> 425: ENDSTDBRW 426: } 427: 428: sub selectcourse_link { 429: my ($form,$unameele,$udomele,$desc,$extra_element,$multflag)=@_; 430: return "<a href='".'javascript:opencrsbrowser("'.$form.'","'.$unameele. 431: '","'.$udomele.'","'.$desc.'","'.$extra_element.'","'.$multflag.'");'."'>".&mt('Select Course')."</a>"; 432: } 433: 434: sub check_uncheck_jscript { 435: my $jscript = <<"ENDSCRT"; 436: function checkAll(field) { 437: if (field.length > 0) { 438: for (i = 0; i < field.length; i++) { 439: field[i].checked = true ; 440: } 441: } else { 442: field.checked = true 443: } 444: } 445: 446: function uncheckAll(field) { 447: if (field.length > 0) { 448: for (i = 0; i < field.length; i++) { 449: field[i].checked = false ; 450: } } else { 451: field.checked = false ; 452: } 453: } 454: ENDSCRT 455: return $jscript; 456: } 457: 458: 459: =pod 460: 461: =item * linked_select_forms(...) 462: 463: linked_select_forms returns a string containing a <script></script> block 464: and html for two <select> menus. The select menus will be linked in that 465: changing the value of the first menu will result in new values being placed 466: in the second menu. The values in the select menu will appear in alphabetical 467: order. 468: 469: linked_select_forms takes the following ordered inputs: 470: 471: =over 4 472: 473: =item * $formname, the name of the <form> tag 474: 475: =item * $middletext, the text which appears between the <select> tags 476: 477: =item * $firstdefault, the default value for the first menu 478: 479: =item * $firstselectname, the name of the first <select> tag 480: 481: =item * $secondselectname, the name of the second <select> tag 482: 483: =item * $hashref, a reference to a hash containing the data for the menus. 484: 485: =back 486: 487: Below is an example of such a hash. Only the 'text', 'default', and 488: 'select2' keys must appear as stated. keys(%menu) are the possible 489: values for the first select menu. The text that coincides with the 490: first menu value is given in $menu{$choice1}->{'text'}. The values 491: and text for the second menu are given in the hash pointed to by 492: $menu{$choice1}->{'select2'}. 493: 494: my %menu = ( A1 => { text =>"Choice A1" , 495: default => "B3", 496: select2 => { 497: B1 => "Choice B1", 498: B2 => "Choice B2", 499: B3 => "Choice B3", 500: B4 => "Choice B4" 501: } 502: }, 503: A2 => { text =>"Choice A2" , 504: default => "C2", 505: select2 => { 506: C1 => "Choice C1", 507: C2 => "Choice C2", 508: C3 => "Choice C3" 509: } 510: }, 511: A3 => { text =>"Choice A3" , 512: default => "D6", 513: select2 => { 514: D1 => "Choice D1", 515: D2 => "Choice D2", 516: D3 => "Choice D3", 517: D4 => "Choice D4", 518: D5 => "Choice D5", 519: D6 => "Choice D6", 520: D7 => "Choice D7" 521: } 522: } 523: ); 524: 525: =cut 526: 527: sub linked_select_forms { 528: my ($formname, 529: $middletext, 530: $firstdefault, 531: $firstselectname, 532: $secondselectname, 533: $hashref 534: ) = @_; 535: my $second = "document.$formname.$secondselectname"; 536: my $first = "document.$formname.$firstselectname"; 537: # output the javascript to do the changing 538: my $result = ''; 539: $result.="<script type=\"text/javascript\">\n"; 540: $result.="var select2data = new Object();\n"; 541: $" = '","'; 542: my $debug = ''; 543: foreach my $s1 (sort(keys(%$hashref))) { 544: $result.="select2data.d_$s1 = new Object();\n"; 545: $result.="select2data.d_$s1.def = new String('". 546: $hashref->{$s1}->{'default'}."');\n"; 547: $result.="select2data.d_$s1.values = new Array("; 548: my @s2values = sort(keys( %{ $hashref->{$s1}->{'select2'} } )); 549: $result.="\"@s2values\");\n"; 550: $result.="select2data.d_$s1.texts = new Array("; 551: my @s2texts; 552: foreach my $value (@s2values) { 553: push @s2texts, $hashref->{$s1}->{'select2'}->{$value}; 554: } 555: $result.="\"@s2texts\");\n"; 556: } 557: $"=' '; 558: $result.= <<"END"; 559: 560: function select1_changed() { 561: // Determine new choice 562: var newvalue = "d_" + $first.value; 563: // update select2 564: var values = select2data[newvalue].values; 565: var texts = select2data[newvalue].texts; 566: var select2def = select2data[newvalue].def; 567: var i; 568: // out with the old 569: for (i = 0; i < $second.options.length; i++) { 570: $second.options[i] = null; 571: } 572: // in with the nuclear 573: for (i=0;i<values.length; i++) { 574: $second.options[i] = new Option(values[i]); 575: $second.options[i].value = values[i]; 576: $second.options[i].text = texts[i]; 577: if (values[i] == select2def) { 578: $second.options[i].selected = true; 579: } 580: } 581: } 582: </script> 583: END 584: # output the initial values for the selection lists 585: $result .= "<select size=\"1\" name=\"$firstselectname\" onchange=\"select1_changed()\">\n"; 586: foreach my $value (sort(keys(%$hashref))) { 587: $result.=" <option value=\"$value\" "; 588: $result.=" selected=\"selected\" " if ($value eq $firstdefault); 589: $result.=">".&mt($hashref->{$value}->{'text'})."</option>\n"; 590: } 591: $result .= "</select>\n"; 592: my %select2 = %{$hashref->{$firstdefault}->{'select2'}}; 593: $result .= $middletext; 594: $result .= "<select size=\"1\" name=\"$secondselectname\">\n"; 595: my $seconddefault = $hashref->{$firstdefault}->{'default'}; 596: foreach my $value (sort(keys(%select2))) { 597: $result.=" <option value=\"$value\" "; 598: $result.=" selected=\"selected\" " if ($value eq $seconddefault); 599: $result.=">".&mt($select2{$value})."</option>\n"; 600: } 601: $result .= "</select>\n"; 602: # return $debug; 603: return $result; 604: } # end of sub linked_select_forms { 605: 606: =pod 607: 608: =item * help_open_topic($topic, $text, $stayOnPage, $width, $height) 609: 610: Returns a string corresponding to an HTML link to the given help 611: $topic, where $topic corresponds to the name of a .tex file in 612: /home/httpd/html/adm/help/tex, with underscores replaced by 613: spaces. 614: 615: $text will optionally be linked to the same topic, allowing you to 616: link text in addition to the graphic. If you do not want to link 617: text, but wish to specify one of the later parameters, pass an 618: empty string. 619: 620: $stayOnPage is a value that will be interpreted as a boolean. If true, 621: the link will not open a new window. If false, the link will open 622: a new window using Javascript. (Default is false.) 623: 624: $width and $height are optional numerical parameters that will 625: override the width and height of the popped up window, which may 626: be useful for certain help topics with big pictures included. 627: 628: =cut 629: 630: sub help_open_topic { 631: my ($topic, $text, $stayOnPage, $width, $height) = @_; 632: $text = "" if (not defined $text); 633: $stayOnPage = 0 if (not defined $stayOnPage); 634: if ($env{'browser.interface'} eq 'textual' || 635: $env{'environment.remote'} eq 'off' ) { 636: $stayOnPage=1; 637: } 638: $width = 350 if (not defined $width); 639: $height = 400 if (not defined $height); 640: my $filename = $topic; 641: $filename =~ s/ /_/g; 642: 643: my $template = ""; 644: my $link; 645: 646: $topic=~s/\W/\_/g; 647: 648: if (!$stayOnPage) 649: { 650: $link = "javascript:void(open('/adm/help/${filename}.hlp', 'Help_for_$topic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))"; 651: } 652: else 653: { 654: $link = "/adm/help/${filename}.hlp"; 655: } 656: 657: # Add the text 658: if ($text ne "") 659: { 660: $template .= 661: "<table bgcolor='#3333AA' cellspacing='1' cellpadding='1' border='0'><tr>". 662: "<td bgcolor='#5555FF'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>"; 663: } 664: 665: # Add the graphic 666: my $title = &mt('Online Help'); 667: my $helpicon=&lonhttpdurl("/adm/help/gif/smallHelp.gif"); 668: $template .= <<"ENDTEMPLATE"; 669: <a href="$link" title="$title"><img src="$helpicon" border="0" alt="(Help: $topic)" /></a> 670: ENDTEMPLATE 671: if ($text ne '') { $template.='</td></tr></table>' }; 672: return $template; 673: 674: } 675: 676: # This is a quicky function for Latex cheatsheet editing, since it 677: # appears in at least four places 678: sub helpLatexCheatsheet { 679: my $other = shift; 680: my $addOther = ''; 681: if ($other) { 682: $addOther = Apache::loncommon::help_open_topic($other, shift, 683: undef, undef, 600) . 684: '</td><td>'; 685: } 686: return '<table><tr><td>'. 687: $addOther . 688: &Apache::loncommon::help_open_topic("Greek_Symbols",'Greek Symbols', 689: undef,undef,600) 690: .'</td><td>'. 691: &Apache::loncommon::help_open_topic("Other_Symbols",'Other Symbols', 692: undef,undef,600) 693: .'</td></tr></table>'; 694: } 695: 696: sub help_open_menu { 697: my ($color,$topic,$component_help,$function,$faq,$bug,$stayOnPage,$width,$height,$text) = @_; 698: $text = "" if (not defined $text); 699: $stayOnPage = 0 if (not defined $stayOnPage); 700: if ($env{'browser.interface'} eq 'textual' || 701: $env{'environment.remote'} eq 'off' ) { 702: $stayOnPage=1; 703: } 704: $width = 620 if (not defined $width); 705: $height = 600 if (not defined $height); 706: my $link=''; 707: my $title = &mt('Get help'); 708: my $origurl = $ENV{'REQUEST_URI'}; 709: $origurl=~s|^/~|/priv/|; 710: my $timestamp = time; 711: foreach my $datum (\$color,\$function,\$topic,\$component_help,\$faq, 712: \$bug,\$origurl) { 713: $$datum = &escape($$datum); 714: } 715: if (!$stayOnPage) { 716: $link = "javascript:helpMenu('open')"; 717: } else { 718: $link = "javascript:helpMenu('display')"; 719: } 720: 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"; 721: 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"; 722: my $template; 723: if ($text ne "") { 724: $template .= 725: "<table bgcolor='#CC3300' cellspacing='1' cellpadding='1' border='0'><tr>". 726: "<td bgcolor='#CC6600'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>"; 727: } 728: my $nothing=&Apache::lonhtmlcommon::javascript_nothing(); 729: my $helpicon=&lonhttpdurl("/adm/lonIcons/helpgateway.gif"); 730: my $start_page = 731: &Apache::loncommon::start_page('Help Menu', undef, 732: {'frameset' => 1, 733: 'js_ready' => 1, 734: 'add_entries' => { 735: 'border' => '0', 736: 'rows' => "105,*",},}); 737: my $end_page = 738: &Apache::loncommon::end_page({'frameset' => 1, 739: 'js_ready' => 1,}); 740: 741: $template .= <<"ENDTEMPLATE"; 742: <script type="text/javascript"> 743: // <!-- BEGIN LON-CAPA Internal 744: // <![CDATA[ 745: function helpMenu(target) { 746: var caller = this; 747: if (target == 'open') { 748: var newWindow = null; 749: try { 750: newWindow = window.open($nothing,"helpmenu","HEIGHT=$height,WIDTH=$width,resizable=yes,scrollbars=yes" ) 751: } 752: catch(error) { 753: writeHelp(caller); 754: return; 755: } 756: if (newWindow) { 757: caller = newWindow; 758: } 759: } 760: writeHelp(caller); 761: return; 762: } 763: function writeHelp(caller) { 764: caller.document.writeln('$start_page<frame name="bannerframe" src="$banner_link" /><frame name="bodyframe" src="$details_link" /> $end_page') 765: caller.document.close() 766: caller.focus() 767: } 768: // ]]> 769: // END LON-CAPA Internal --> 770: </script> 771: <a href="$link" title="$title"><img src="$helpicon" border="0" alt="(Help Menu)" /></a> 772: ENDTEMPLATE 773: if ($component_help) { 774: if (!$text) { 775: $template=&help_open_topic($component_help,undef,$stayOnPage, 776: $width,$height).' '.$template; 777: } else { 778: my $help_text; 779: $help_text=&unescape($topic); 780: $template='<table><tr><td>'. 781: &help_open_topic($component_help,$help_text,$stayOnPage, 782: $width,$height).'</td><td>'.$template. 783: '</td></tr></table>'; 784: } 785: } 786: if ($text ne '') { $template.='</td></tr></table>' }; 787: return $template; 788: } 789: 790: sub help_open_bug { 791: my ($topic, $text, $stayOnPage, $width, $height) = @_; 792: unless ($env{'user.adv'}) { return ''; } 793: unless ($Apache::lonnet::perlvar{'BugzillaHost'}) { return ''; } 794: $text = "" if (not defined $text); 795: $stayOnPage = 0 if (not defined $stayOnPage); 796: if ($env{'browser.interface'} eq 'textual' || 797: $env{'environment.remote'} eq 'off' ) { 798: $stayOnPage=1; 799: } 800: $width = 600 if (not defined $width); 801: $height = 600 if (not defined $height); 802: 803: $topic=~s/\W+/\+/g; 804: my $link=''; 805: my $template=''; 806: my $url=$Apache::lonnet::perlvar{'BugzillaHost'}.'enter_bug.cgi?product=LON-CAPA&bug_file_loc='. 807: &escape($ENV{'REQUEST_URI'}).'&component='.$topic; 808: if (!$stayOnPage) 809: { 810: $link = "javascript:void(open('$url', 'Bugzilla', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))"; 811: } 812: else 813: { 814: $link = $url; 815: } 816: # Add the text 817: if ($text ne "") 818: { 819: $template .= 820: "<table bgcolor='#AA3333' cellspacing='1' cellpadding='1' border='0'><tr>". 821: "<td bgcolor='#FF5555'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>"; 822: } 823: 824: # Add the graphic 825: my $title = &mt('Report a Bug'); 826: my $bugicon=&lonhttpdurl("/adm/lonMisc/smallBug.gif"); 827: $template .= <<"ENDTEMPLATE"; 828: <a href="$link" title="$title"><img src="$bugicon" border="0" alt="(Bug: $topic)" /></a> 829: ENDTEMPLATE 830: if ($text ne '') { $template.='</td></tr></table>' }; 831: return $template; 832: 833: } 834: 835: sub help_open_faq { 836: my ($topic, $text, $stayOnPage, $width, $height) = @_; 837: unless ($env{'user.adv'}) { return ''; } 838: unless ($Apache::lonnet::perlvar{'FAQHost'}) { return ''; } 839: $text = "" if (not defined $text); 840: $stayOnPage = 0 if (not defined $stayOnPage); 841: if ($env{'browser.interface'} eq 'textual' || 842: $env{'environment.remote'} eq 'off' ) { 843: $stayOnPage=1; 844: } 845: $width = 350 if (not defined $width); 846: $height = 400 if (not defined $height); 847: 848: $topic=~s/\W+/\+/g; 849: my $link=''; 850: my $template=''; 851: my $url=$Apache::lonnet::perlvar{'FAQHost'}.'/fom/cache/'.$topic.'.html'; 852: if (!$stayOnPage) 853: { 854: $link = "javascript:void(open('$url', 'FAQ-O-Matic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))"; 855: } 856: else 857: { 858: $link = $url; 859: } 860: 861: # Add the text 862: if ($text ne "") 863: { 864: $template .= 865: "<table bgcolor='#337733' cellspacing='1' cellpadding='1' border='0'><tr>". 866: "<td bgcolor='#448844'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>"; 867: } 868: 869: # Add the graphic 870: my $title = &mt('View the FAQ'); 871: my $faqicon=&lonhttpdurl("/adm/lonMisc/smallFAQ.gif"); 872: $template .= <<"ENDTEMPLATE"; 873: <a href="$link" title="$title"><img src="$faqicon" border="0" alt="(FAQ: $topic)" /></a> 874: ENDTEMPLATE 875: if ($text ne '') { $template.='</td></tr></table>' }; 876: return $template; 877: 878: } 879: 880: ############################################################### 881: ############################################################### 882: 883: =pod 884: 885: =item * change_content_javascript(): 886: 887: This and the next function allow you to create small sections of an 888: otherwise static HTML page that you can update on the fly with 889: Javascript, even in Netscape 4. 890: 891: The Javascript fragment returned by this function (no E<lt>scriptE<gt> tag) 892: must be written to the HTML page once. It will prove the Javascript 893: function "change(name, content)". Calling the change function with the 894: name of the section 895: you want to update, matching the name passed to C<changable_area>, and 896: the new content you want to put in there, will put the content into 897: that area. 898: 899: B<Note>: Netscape 4 only reserves enough space for the changable area 900: to contain room for the original contents. You need to "make space" 901: for whatever changes you wish to make, and be B<sure> to check your 902: code in Netscape 4. This feature in Netscape 4 is B<not> powerful; 903: it's adequate for updating a one-line status display, but little more. 904: This script will set the space to 100% width, so you only need to 905: worry about height in Netscape 4. 906: 907: Modern browsers are much less limiting, and if you can commit to the 908: user not using Netscape 4, this feature may be used freely with 909: pretty much any HTML. 910: 911: =cut 912: 913: sub change_content_javascript { 914: # If we're on Netscape 4, we need to use Layer-based code 915: if ($env{'browser.type'} eq 'netscape' && 916: $env{'browser.version'} =~ /^4\./) { 917: return (<<NETSCAPE4); 918: function change(name, content) { 919: doc = document.layers[name+"___escape"].layers[0].document; 920: doc.open(); 921: doc.write(content); 922: doc.close(); 923: } 924: NETSCAPE4 925: } else { 926: # Otherwise, we need to use semi-standards-compliant code 927: # (technically, "innerHTML" isn't standard but the equivalent 928: # is really scary, and every useful browser supports it 929: return (<<DOMBASED); 930: function change(name, content) { 931: element = document.getElementById(name); 932: element.innerHTML = content; 933: } 934: DOMBASED 935: } 936: } 937: 938: =pod 939: 940: =item * changable_area($name, $origContent): 941: 942: This provides a "changable area" that can be modified on the fly via 943: the Javascript code provided in C<change_content_javascript>. $name is 944: the name you will use to reference the area later; do not repeat the 945: same name on a given HTML page more then once. $origContent is what 946: the area will originally contain, which can be left blank. 947: 948: =cut 949: 950: sub changable_area { 951: my ($name, $origContent) = @_; 952: 953: if ($env{'browser.type'} eq 'netscape' && 954: $env{'browser.version'} =~ /^4\./) { 955: # If this is netscape 4, we need to use the Layer tag 956: return "<ilayer width='100%' id='${name}___escape' overflow='none'><layer width='100%' id='$name' overflow='none'>$origContent</layer></ilayer>"; 957: } else { 958: return "<span id='$name'>$origContent</span>"; 959: } 960: } 961: 962: =pod 963: 964: =back 965: 966: =head1 Excel and CSV file utility routines 967: 968: =over 4 969: 970: =cut 971: 972: ############################################################### 973: ############################################################### 974: 975: =pod 976: 977: =item * csv_translate($text) 978: 979: Translate $text to allow it to be output as a 'comma separated values' 980: format. 981: 982: =cut 983: 984: ############################################################### 985: ############################################################### 986: sub csv_translate { 987: my $text = shift; 988: $text =~ s/\"/\"\"/g; 989: $text =~ s/\n/ /g; 990: return $text; 991: } 992: 993: ############################################################### 994: ############################################################### 995: 996: =pod 997: 998: =item * define_excel_formats 999: 1000: Define some commonly used Excel cell formats. 1001: 1002: Currently supported formats: 1003: 1004: =over 4 1005: 1006: =item header 1007: 1008: =item bold 1009: 1010: =item h1 1011: 1012: =item h2 1013: 1014: =item h3 1015: 1016: =item h4 1017: 1018: =item i 1019: 1020: =item date 1021: 1022: =back 1023: 1024: Inputs: $workbook 1025: 1026: Returns: $format, a hash reference. 1027: 1028: =cut 1029: 1030: ############################################################### 1031: ############################################################### 1032: sub define_excel_formats { 1033: my ($workbook) = @_; 1034: my $format; 1035: $format->{'header'} = $workbook->add_format(bold => 1, 1036: bottom => 1, 1037: align => 'center'); 1038: $format->{'bold'} = $workbook->add_format(bold=>1); 1039: $format->{'h1'} = $workbook->add_format(bold=>1, size=>18); 1040: $format->{'h2'} = $workbook->add_format(bold=>1, size=>16); 1041: $format->{'h3'} = $workbook->add_format(bold=>1, size=>14); 1042: $format->{'h4'} = $workbook->add_format(bold=>1, size=>12); 1043: $format->{'i'} = $workbook->add_format(italic=>1); 1044: $format->{'date'} = $workbook->add_format(num_format=> 1045: 'mm/dd/yyyy hh:mm:ss'); 1046: return $format; 1047: } 1048: 1049: ############################################################### 1050: ############################################################### 1051: 1052: =pod 1053: 1054: =item * create_workbook 1055: 1056: Create an Excel worksheet. If it fails, output message on the 1057: request object and return undefs. 1058: 1059: Inputs: Apache request object 1060: 1061: Returns (undef) on failure, 1062: Excel worksheet object, scalar with filename, and formats 1063: from &Apache::loncommon::define_excel_formats on success 1064: 1065: =cut 1066: 1067: ############################################################### 1068: ############################################################### 1069: sub create_workbook { 1070: my ($r) = @_; 1071: # 1072: # Create the excel spreadsheet 1073: my $filename = '/prtspool/'. 1074: $env{'user.name'}.'_'.$env{'user.domain'}.'_'. 1075: time.'_'.rand(1000000000).'.xls'; 1076: my $workbook = Spreadsheet::WriteExcel->new('/home/httpd'.$filename); 1077: if (! defined($workbook)) { 1078: $r->log_error("Error creating excel spreadsheet $filename: $!"); 1079: $r->print('<p>'.&mt("Unable to create new Excel file. ". 1080: "This error has been logged. ". 1081: "Please alert your LON-CAPA administrator"). 1082: '</p>'); 1083: return (undef); 1084: } 1085: # 1086: $workbook->set_tempdir('/home/httpd/perl/tmp'); 1087: # 1088: my $format = &Apache::loncommon::define_excel_formats($workbook); 1089: return ($workbook,$filename,$format); 1090: } 1091: 1092: ############################################################### 1093: ############################################################### 1094: 1095: =pod 1096: 1097: =item * create_text_file 1098: 1099: Create a file to write to and eventually make available to the usre. 1100: If file creation fails, outputs an error message on the request object and 1101: return undefs. 1102: 1103: Inputs: Apache request object, and file suffix 1104: 1105: Returns (undef) on failure, 1106: Filehandle and filename on success. 1107: 1108: =cut 1109: 1110: ############################################################### 1111: ############################################################### 1112: sub create_text_file { 1113: my ($r,$suffix) = @_; 1114: if (! defined($suffix)) { $suffix = 'txt'; }; 1115: my $fh; 1116: my $filename = '/prtspool/'. 1117: $env{'user.name'}.'_'.$env{'user.domain'}.'_'. 1118: time.'_'.rand(1000000000).'.'.$suffix; 1119: $fh = Apache::File->new('>/home/httpd'.$filename); 1120: if (! defined($fh)) { 1121: $r->log_error("Couldn't open $filename for output $!"); 1122: $r->print("Problems occured in creating the output file. ". 1123: "This error has been logged. ". 1124: "Please alert your LON-CAPA administrator."); 1125: } 1126: return ($fh,$filename) 1127: } 1128: 1129: 1130: =pod 1131: 1132: =back 1133: 1134: =cut 1135: 1136: ############################################################### 1137: ## Home server <option> list generating code ## 1138: ############################################################### 1139: 1140: =pod 1141: 1142: =head1 Home Server option list generating code 1143: 1144: =over 4 1145: 1146: =item * get_domains() 1147: 1148: Returns an array containing each of the domains listed in the hosts.tab 1149: file. 1150: 1151: =cut 1152: 1153: #------------------------------------------- 1154: sub get_domains { 1155: # The code below was stolen from "The Perl Cookbook", p 102, 1st ed. 1156: my @domains; 1157: my %seen; 1158: foreach my $dom (sort(values(%Apache::lonnet::hostdom))) { 1159: push(@domains,$dom) unless $seen{$dom}++; 1160: } 1161: return @domains; 1162: } 1163: 1164: # ------------------------------------------ 1165: 1166: sub domain_select { 1167: my ($name,$value,$multiple)=@_; 1168: my %domains=map { 1169: $_ => $_.' '.$Apache::lonnet::domaindescription{$_} 1170: } &get_domains; 1171: if ($multiple) { 1172: $domains{''}=&mt('Any domain'); 1173: return &multiple_select_form($name,$value,4,\%domains); 1174: } else { 1175: return &select_form($name,$value,%domains); 1176: } 1177: } 1178: 1179: #------------------------------------------- 1180: 1181: =pod 1182: 1183: =item * multiple_select_form($name,$value,$size,$hash,$order) 1184: 1185: Returns a string containing a <select> element int multiple mode 1186: 1187: 1188: Args: 1189: $name - name of the <select> element 1190: $value - sclara or array ref of values that should already be selected 1191: $size - number of rows long the select element is 1192: $hash - the elements should be 'option' => 'shown text' 1193: (shown text should already have been &mt()) 1194: $order - (optional) array ref of the order to show the elments in 1195: 1196: =cut 1197: 1198: #------------------------------------------- 1199: sub multiple_select_form { 1200: my ($name,$value,$size,$hash,$order)=@_; 1201: my %selected = map { $_ => 1 } ref($value)?@{$value}:($value); 1202: my $output=''; 1203: if (! defined($size)) { 1204: $size = 4; 1205: if (scalar(keys(%$hash))<4) { 1206: $size = scalar(keys(%$hash)); 1207: } 1208: } 1209: $output.="\n<select name='$name' size='$size' multiple='1'>"; 1210: my @order = ref($order) ? @$order 1211: : sort(keys(%$hash)); 1212: foreach my $key (@order) { 1213: $output.='<option value="'.&HTML::Entities::encode($key,'"<>&').'" '; 1214: $output.='selected="selected" ' if ($selected{$key}); 1215: $output.='>'.$hash->{$key}."</option>\n"; 1216: } 1217: $output.="</select>\n"; 1218: return $output; 1219: } 1220: 1221: #------------------------------------------- 1222: 1223: =pod 1224: 1225: =item * select_form($defdom,$name,%hash) 1226: 1227: Returns a string containing a <select name='$name' size='1'> form to 1228: allow a user to select options from a hash option_name => displayed text. 1229: See lonrights.pm for an example invocation and use. 1230: 1231: =cut 1232: 1233: #------------------------------------------- 1234: sub select_form { 1235: my ($def,$name,%hash) = @_; 1236: my $selectform = "<select name=\"$name\" size=\"1\">\n"; 1237: my @keys; 1238: if (exists($hash{'select_form_order'})) { 1239: @keys=@{$hash{'select_form_order'}}; 1240: } else { 1241: @keys=sort(keys(%hash)); 1242: } 1243: foreach my $key (@keys) { 1244: $selectform.= 1245: '<option value="'.&HTML::Entities::encode($key,'"<>&').'" '. 1246: ($key eq $def ? 'selected="selected" ' : ''). 1247: ">".&mt($hash{$key})."</option>\n"; 1248: } 1249: $selectform.="</select>"; 1250: return $selectform; 1251: } 1252: 1253: sub gradeleveldescription { 1254: my $gradelevel=shift; 1255: my %gradelevels=(0 => 'Not specified', 1256: 1 => 'Grade 1', 1257: 2 => 'Grade 2', 1258: 3 => 'Grade 3', 1259: 4 => 'Grade 4', 1260: 5 => 'Grade 5', 1261: 6 => 'Grade 6', 1262: 7 => 'Grade 7', 1263: 8 => 'Grade 8', 1264: 9 => 'Grade 9', 1265: 10 => 'Grade 10', 1266: 11 => 'Grade 11', 1267: 12 => 'Grade 12', 1268: 13 => 'Grade 13', 1269: 14 => '100 Level', 1270: 15 => '200 Level', 1271: 16 => '300 Level', 1272: 17 => '400 Level', 1273: 18 => 'Graduate Level'); 1274: return &mt($gradelevels{$gradelevel}); 1275: } 1276: 1277: sub select_level_form { 1278: my ($deflevel,$name)=@_; 1279: unless ($deflevel) { $deflevel=0; } 1280: my $selectform = "<select name=\"$name\" size=\"1\">\n"; 1281: for (my $i=0; $i<=18; $i++) { 1282: $selectform.="<option value=\"$i\" ". 1283: ($i==$deflevel ? 'selected="selected" ' : ''). 1284: ">".&gradeleveldescription($i)."</option>\n"; 1285: } 1286: $selectform.="</select>"; 1287: return $selectform; 1288: } 1289: 1290: #------------------------------------------- 1291: 1292: =pod 1293: 1294: =item * select_dom_form($defdom,$name,$includeempty) 1295: 1296: Returns a string containing a <select name='$name' size='1'> form to 1297: allow a user to select the domain to preform an operation in. 1298: See loncreateuser.pm for an example invocation and use. 1299: 1300: If the $includeempty flag is set, it also includes an empty choice ("no domain 1301: selected"); 1302: 1303: =cut 1304: 1305: #------------------------------------------- 1306: sub select_dom_form { 1307: my ($defdom,$name,$includeempty) = @_; 1308: my @domains = get_domains(); 1309: if ($includeempty) { @domains=('',@domains); } 1310: my $selectdomain = "<select name=\"$name\" size=\"1\">\n"; 1311: foreach my $dom (@domains) { 1312: $selectdomain.="<option value=\"$dom\" ". 1313: ($dom eq $defdom ? 'selected="selected" ' : ''). 1314: ">$dom</option>\n"; 1315: } 1316: $selectdomain.="</select>"; 1317: return $selectdomain; 1318: } 1319: 1320: #------------------------------------------- 1321: 1322: =pod 1323: 1324: =item * get_library_servers($domain) 1325: 1326: Returns a hash which contains keys like '103l3' and values like 1327: 'kirk.lite.msu.edu'. All of the keys will be for machines in the 1328: given $domain. 1329: 1330: =cut 1331: 1332: #------------------------------------------- 1333: sub get_library_servers { 1334: my $domain = shift; 1335: my %library_servers; 1336: foreach my $hostid (keys(%Apache::lonnet::libserv)) { 1337: if ($Apache::lonnet::hostdom{$hostid} eq $domain) { 1338: $library_servers{$hostid} = $Apache::lonnet::hostname{$hostid}; 1339: } 1340: } 1341: return %library_servers; 1342: } 1343: 1344: #------------------------------------------- 1345: 1346: =pod 1347: 1348: =item * home_server_option_list($domain) 1349: 1350: returns a string which contains an <option> list to be used in a 1351: <select> form input. See loncreateuser.pm for an example. 1352: 1353: =cut 1354: 1355: #------------------------------------------- 1356: sub home_server_option_list { 1357: my $domain = shift; 1358: my %servers = &get_library_servers($domain); 1359: my $result = ''; 1360: foreach my $hostid (sort(keys(%servers))) { 1361: $result.= 1362: '<option value="'.$hostid.'">'. 1363: $hostid.' '.$servers{$hostid}."</option>\n"; 1364: } 1365: return $result; 1366: } 1367: 1368: =pod 1369: 1370: =back 1371: 1372: =cut 1373: 1374: ############################################################### 1375: ## Decoding User Agent ## 1376: ############################################################### 1377: 1378: =pod 1379: 1380: =head1 Decoding the User Agent 1381: 1382: =over 4 1383: 1384: =item * &decode_user_agent() 1385: 1386: Inputs: $r 1387: 1388: Outputs: 1389: 1390: =over 4 1391: 1392: =item * $httpbrowser 1393: 1394: =item * $clientbrowser 1395: 1396: =item * $clientversion 1397: 1398: =item * $clientmathml 1399: 1400: =item * $clientunicode 1401: 1402: =item * $clientos 1403: 1404: =back 1405: 1406: =back 1407: 1408: =cut 1409: 1410: ############################################################### 1411: ############################################################### 1412: sub decode_user_agent { 1413: my ($r)=@_; 1414: my @browsertype=split(/\&/,$Apache::lonnet::perlvar{"lonBrowsDet"}); 1415: my %mathcap=split(/\&/,$$Apache::lonnet::perlvar{"lonMathML"}); 1416: my $httpbrowser=$ENV{"HTTP_USER_AGENT"}; 1417: if (!$httpbrowser && $r) { $httpbrowser=$r->header_in('User-Agent'); } 1418: my $clientbrowser='unknown'; 1419: my $clientversion='0'; 1420: my $clientmathml=''; 1421: my $clientunicode='0'; 1422: for (my $i=0;$i<=$#browsertype;$i++) { 1423: my ($bname,$match,$notmatch,$vreg,$minv,$univ)=split(/\:/,$browsertype[$i]); 1424: if (($httpbrowser=~/$match/i) && ($httpbrowser!~/$notmatch/i)) { 1425: $clientbrowser=$bname; 1426: $httpbrowser=~/$vreg/i; 1427: $clientversion=$1; 1428: $clientmathml=($clientversion>=$minv); 1429: $clientunicode=($clientversion>=$univ); 1430: } 1431: } 1432: my $clientos='unknown'; 1433: if (($httpbrowser=~/linux/i) || 1434: ($httpbrowser=~/unix/i) || 1435: ($httpbrowser=~/ux/i) || 1436: ($httpbrowser=~/solaris/i)) { $clientos='unix'; } 1437: if (($httpbrowser=~/vax/i) || 1438: ($httpbrowser=~/vms/i)) { $clientos='vms'; } 1439: if ($httpbrowser=~/next/i) { $clientos='next'; } 1440: if (($httpbrowser=~/mac/i) || 1441: ($httpbrowser=~/powerpc/i)) { $clientos='mac'; } 1442: if ($httpbrowser=~/win/i) { $clientos='win'; } 1443: if ($httpbrowser=~/embed/i) { $clientos='pda'; } 1444: return ($httpbrowser,$clientbrowser,$clientversion,$clientmathml, 1445: $clientunicode,$clientos,); 1446: } 1447: 1448: ############################################################### 1449: ## Authentication changing form generation subroutines ## 1450: ############################################################### 1451: ## 1452: ## All of the authform_xxxxxxx subroutines take their inputs in a 1453: ## hash, and have reasonable default values. 1454: ## 1455: ## formname = the name given in the <form> tag. 1456: #------------------------------------------- 1457: 1458: =pod 1459: 1460: =head1 Authentication Routines 1461: 1462: =over 4 1463: 1464: =item * authform_xxxxxx 1465: 1466: The authform_xxxxxx subroutines provide javascript and html forms which 1467: handle some of the conveniences required for authentication forms. 1468: This is not an optimal method, but it works. 1469: 1470: See loncreateuser.pm for invocation and use examples. 1471: 1472: =over 4 1473: 1474: =item * authform_header 1475: 1476: =item * authform_authorwarning 1477: 1478: =item * authform_nochange 1479: 1480: =item * authform_kerberos 1481: 1482: =item * authform_internal 1483: 1484: =item * authform_filesystem 1485: 1486: =back 1487: 1488: =back 1489: 1490: =cut 1491: 1492: #------------------------------------------- 1493: sub authform_header{ 1494: my %in = ( 1495: formname => 'cu', 1496: kerb_def_dom => '', 1497: @_, 1498: ); 1499: $in{'formname'} = 'document.' . $in{'formname'}; 1500: my $result=''; 1501: 1502: #---------------------------------------------- Code for upper case translation 1503: my $Javascript_toUpperCase; 1504: unless ($in{kerb_def_dom}) { 1505: $Javascript_toUpperCase =<<"END"; 1506: switch (choice) { 1507: case 'krb': currentform.elements[choicearg].value = 1508: currentform.elements[choicearg].value.toUpperCase(); 1509: break; 1510: default: 1511: } 1512: END 1513: } else { 1514: $Javascript_toUpperCase = ""; 1515: } 1516: 1517: my $radioval = "'nochange'"; 1518: if (exists($in{'curr_authtype'}) && 1519: defined($in{'curr_authtype'}) && 1520: $in{'curr_authtype'} ne '') { 1521: $radioval = "'$in{'curr_authtype'}arg'"; 1522: } 1523: my $argfield = 'null'; 1524: if ( grep/^mode$/,(keys %in) ) { 1525: if ($in{'mode'} eq 'modifycourse') { 1526: if ( grep/^curr_authtype$/,(keys %in) ) { 1527: $radioval = "'$in{'curr_authtype'}'"; 1528: } 1529: if ( grep/^curr_autharg$/,(keys %in) ) { 1530: unless ($in{'curr_autharg'} eq '') { 1531: $argfield = "'$in{'curr_autharg'}'"; 1532: } 1533: } 1534: } 1535: } 1536: 1537: $result.=<<"END"; 1538: var current = new Object(); 1539: current.radiovalue = $radioval; 1540: current.argfield = $argfield; 1541: 1542: function changed_radio(choice,currentform) { 1543: var choicearg = choice + 'arg'; 1544: // If a radio button in changed, we need to change the argfield 1545: if (current.radiovalue != choice) { 1546: current.radiovalue = choice; 1547: if (current.argfield != null) { 1548: currentform.elements[current.argfield].value = ''; 1549: } 1550: if (choice == 'nochange') { 1551: current.argfield = null; 1552: } else { 1553: current.argfield = choicearg; 1554: switch(choice) { 1555: case 'krb': 1556: currentform.elements[current.argfield].value = 1557: "$in{'kerb_def_dom'}"; 1558: break; 1559: default: 1560: break; 1561: } 1562: } 1563: } 1564: return; 1565: } 1566: 1567: function changed_text(choice,currentform) { 1568: var choicearg = choice + 'arg'; 1569: if (currentform.elements[choicearg].value !='') { 1570: $Javascript_toUpperCase 1571: // clear old field 1572: if ((current.argfield != choicearg) && (current.argfield != null)) { 1573: currentform.elements[current.argfield].value = ''; 1574: } 1575: current.argfield = choicearg; 1576: } 1577: set_auth_radio_buttons(choice,currentform); 1578: return; 1579: } 1580: 1581: function set_auth_radio_buttons(newvalue,currentform) { 1582: var i=0; 1583: while (i < currentform.login.length) { 1584: if (currentform.login[i].value == newvalue) { break; } 1585: i++; 1586: } 1587: if (i == currentform.login.length) { 1588: return; 1589: } 1590: current.radiovalue = newvalue; 1591: currentform.login[i].checked = true; 1592: return; 1593: } 1594: END 1595: return $result; 1596: } 1597: 1598: sub authform_authorwarning{ 1599: my $result=''; 1600: $result='<i>'. 1601: &mt('As a general rule, only authors or co-authors should be '. 1602: 'filesystem authenticated '. 1603: '(which allows access to the server filesystem).')."</i>\n"; 1604: return $result; 1605: } 1606: 1607: sub authform_nochange{ 1608: my %in = ( 1609: formname => 'document.cu', 1610: kerb_def_dom => 'MSU.EDU', 1611: @_, 1612: ); 1613: my $result = '<label>'.&mt('[_1] Do not change login data', 1614: '<input type="radio" name="login" value="nochange" '. 1615: 'checked="checked" onclick="'. 1616: "javascript:changed_radio('nochange',$in{'formname'});".'" />'). 1617: '</label>'; 1618: return $result; 1619: } 1620: 1621: sub authform_kerberos{ 1622: my %in = ( 1623: formname => 'document.cu', 1624: kerb_def_dom => 'MSU.EDU', 1625: kerb_def_auth => 'krb4', 1626: @_, 1627: ); 1628: my ($check4,$check5,$krbarg); 1629: if ($in{'kerb_def_auth'} eq 'krb5') { 1630: $check5 = " checked=\"on\""; 1631: } else { 1632: $check4 = " checked=\"on\""; 1633: } 1634: $krbarg = $in{'kerb_def_dom'}; 1635: 1636: my $krbcheck = ""; 1637: if ( grep/^curr_authtype$/,(keys %in) ) { 1638: if ($in{'curr_authtype'} =~ m/^krb/) { 1639: $krbcheck = " checked=\"on\""; 1640: if ( grep/^curr_autharg$/,(keys %in) ) { 1641: $krbarg = $in{'curr_autharg'}; 1642: } 1643: } 1644: } 1645: 1646: my $jscall = "javascript:changed_radio('krb',$in{'formname'});"; 1647: my $result .= &mt 1648: ('[_1] Kerberos authenticated with domain [_2] '. 1649: '[_3] Version 4 [_4] Version 5 [_5]', 1650: '<label><input type="radio" name="login" value="krb" '. 1651: 'onclick="'.$jscall.'" onchange="'.$jscall.'"'.$krbcheck.' />', 1652: '</label><input type="text" size="10" name="krbarg" '. 1653: 'value="'.$krbarg.'" '. 1654: 'onchange="'.$jscall.'" />', 1655: '<label><input type="radio" name="krbver" value="4" '.$check4.' />', 1656: '</label><label><input type="radio" name="krbver" value="5" '.$check5.' />', 1657: '</label>'); 1658: return $result; 1659: } 1660: 1661: sub authform_internal{ 1662: my %args = ( 1663: formname => 'document.cu', 1664: kerb_def_dom => 'MSU.EDU', 1665: @_, 1666: ); 1667: 1668: my $intcheck = ""; 1669: my $intarg = 'value=""'; 1670: if ( grep/^curr_authtype$/,(keys %args) ) { 1671: if ($args{'curr_authtype'} eq 'int') { 1672: $intcheck = " checked=\"on\""; 1673: if ( grep/^curr_autharg$/,(keys %args) ) { 1674: $intarg = "value=\"$args{'curr_autharg'}\""; 1675: } 1676: } 1677: } 1678: 1679: my $jscall = "javascript:changed_radio('int',$args{'formname'});"; 1680: my $result.=&mt 1681: ('[_1] Internally authenticated (with initial password [_2])', 1682: '<label><input type="radio" name="login" value="int" '.$intcheck. 1683: ' onchange="'.$jscall.'" onclick="'.$jscall.'" />', 1684: '</label><input type="text" size="10" name="intarg" '.$intarg. 1685: ' onchange="'.$jscall.'" />'); 1686: return $result; 1687: } 1688: 1689: sub authform_local{ 1690: my %in = ( 1691: formname => 'document.cu', 1692: kerb_def_dom => 'MSU.EDU', 1693: @_, 1694: ); 1695: 1696: my $loccheck = ""; 1697: my $locarg = 'value=""'; 1698: if ( grep/^curr_authtype$/,(keys %in) ) { 1699: if ($in{'curr_authtype'} eq 'loc') { 1700: $loccheck = " checked=\"on\""; 1701: if ( grep/^curr_autharg$/,(keys %in) ) { 1702: $locarg = "value=\"$in{'curr_autharg'}\""; 1703: } 1704: } 1705: } 1706: 1707: my $jscall = "javascript:changed_radio('loc',$in{'formname'});"; 1708: my $result.=&mt('[_1] Local Authentication with argument [_2]', 1709: '<label><input type="radio" name="login" value="loc" '.$loccheck. 1710: ' onchange="'.$jscall.'" onclick="'.$jscall.'" />', 1711: '</label><input type="text" size="10" name="locarg" '.$locarg. 1712: ' onchange="'.$jscall.'" />'); 1713: return $result; 1714: } 1715: 1716: sub authform_filesystem{ 1717: my %in = ( 1718: formname => 'document.cu', 1719: kerb_def_dom => 'MSU.EDU', 1720: @_, 1721: ); 1722: my $jscall = "javascript:changed_radio('fsys',$in{'formname'});"; 1723: my $result.= &mt 1724: ('[_1] Filesystem Authenticated (with initial password [_2])', 1725: '<label><input type="radio" name="login" value="fsys" '. 1726: 'onchange="'.$jscall.'" onclick="'.$jscall.'" />', 1727: '</label><input type="text" size="10" name="fsysarg" value="" '. 1728: 'onchange="'.$jscall.'" />'); 1729: return $result; 1730: } 1731: 1732: ############################################################### 1733: ## Get Authentication Defaults for Domain ## 1734: ############################################################### 1735: 1736: =pod 1737: 1738: =head1 Domains and Authentication 1739: 1740: Returns default authentication type and an associated argument as 1741: listed in file 'domain.tab'. 1742: 1743: =over 4 1744: 1745: =item * get_auth_defaults 1746: 1747: get_auth_defaults($target_domain) returns the default authentication 1748: type and an associated argument (initial password or a kerberos domain). 1749: These values are stored in lonTabs/domain.tab 1750: 1751: ($def_auth, $def_arg) = &get_auth_defaults($target_domain); 1752: 1753: If target_domain is not found in domain.tab, returns nothing (''). 1754: 1755: =cut 1756: 1757: #------------------------------------------- 1758: sub get_auth_defaults { 1759: my $domain=shift; 1760: return ($Apache::lonnet::domain_auth_def{$domain},$Apache::lonnet::domain_auth_arg_def{$domain}); 1761: } 1762: ############################################################### 1763: ## End Get Authentication Defaults for Domain ## 1764: ############################################################### 1765: 1766: ############################################################### 1767: ## Get Kerberos Defaults for Domain ## 1768: ############################################################### 1769: ## 1770: ## Returns default kerberos version and an associated argument 1771: ## as listed in file domain.tab. If not listed, provides 1772: ## appropriate default domain and kerberos version. 1773: ## 1774: #------------------------------------------- 1775: 1776: =pod 1777: 1778: =item * get_kerberos_defaults 1779: 1780: get_kerberos_defaults($target_domain) returns the default kerberos 1781: version and domain. If not found in domain.tabs, it defaults to 1782: version 4 and the domain of the server. 1783: 1784: ($def_version, $def_krb_domain) = &get_kerberos_defaults($target_domain); 1785: 1786: =cut 1787: 1788: #------------------------------------------- 1789: sub get_kerberos_defaults { 1790: my $domain=shift; 1791: my ($krbdef,$krbdefdom) = 1792: &Apache::loncommon::get_auth_defaults($domain); 1793: unless ($krbdef =~/^krb/ && $krbdefdom) { 1794: $ENV{'SERVER_NAME'}=~/(\w+\.\w+)$/; 1795: my $krbdefdom=$1; 1796: $krbdefdom=~tr/a-z/A-Z/; 1797: $krbdef = "krb4"; 1798: } 1799: return ($krbdef,$krbdefdom); 1800: } 1801: 1802: =pod 1803: 1804: =back 1805: 1806: =cut 1807: 1808: ############################################################### 1809: ## Thesaurus Functions ## 1810: ############################################################### 1811: 1812: =pod 1813: 1814: =head1 Thesaurus Functions 1815: 1816: =over 4 1817: 1818: =item * initialize_keywords 1819: 1820: Initializes the package variable %Keywords if it is empty. Uses the 1821: package variable $thesaurus_db_file. 1822: 1823: =cut 1824: 1825: ################################################### 1826: 1827: sub initialize_keywords { 1828: return 1 if (scalar keys(%Keywords)); 1829: # If we are here, %Keywords is empty, so fill it up 1830: # Make sure the file we need exists... 1831: if (! -e $thesaurus_db_file) { 1832: &Apache::lonnet::logthis("Attempt to access $thesaurus_db_file". 1833: " failed because it does not exist"); 1834: return 0; 1835: } 1836: # Set up the hash as a database 1837: my %thesaurus_db; 1838: if (! tie(%thesaurus_db,'GDBM_File', 1839: $thesaurus_db_file,&GDBM_READER(),0640)){ 1840: &Apache::lonnet::logthis("Could not tie \%thesaurus_db to ". 1841: $thesaurus_db_file); 1842: return 0; 1843: } 1844: # Get the average number of appearances of a word. 1845: my $avecount = $thesaurus_db{'average.count'}; 1846: # Put keywords (those that appear > average) into %Keywords 1847: while (my ($word,$data)=each (%thesaurus_db)) { 1848: my ($count,undef) = split /:/,$data; 1849: $Keywords{$word}++ if ($count > $avecount); 1850: } 1851: untie %thesaurus_db; 1852: # Remove special values from %Keywords. 1853: foreach my $value ('total.count','average.count') { 1854: delete($Keywords{$value}) if (exists($Keywords{$value})); 1855: } 1856: return 1; 1857: } 1858: 1859: ################################################### 1860: 1861: =pod 1862: 1863: =item * keyword($word) 1864: 1865: Returns true if $word is a keyword. A keyword is a word that appears more 1866: than the average number of times in the thesaurus database. Calls 1867: &initialize_keywords 1868: 1869: =cut 1870: 1871: ################################################### 1872: 1873: sub keyword { 1874: return if (!&initialize_keywords()); 1875: my $word=lc(shift()); 1876: $word=~s/\W//g; 1877: return exists($Keywords{$word}); 1878: } 1879: 1880: ############################################################### 1881: 1882: =pod 1883: 1884: =item * get_related_words 1885: 1886: Look up a word in the thesaurus. Takes a scalar argument and returns 1887: an array of words. If the keyword is not in the thesaurus, an empty array 1888: will be returned. The order of the words returned is determined by the 1889: database which holds them. 1890: 1891: Uses global $thesaurus_db_file. 1892: 1893: =cut 1894: 1895: ############################################################### 1896: sub get_related_words { 1897: my $keyword = shift; 1898: my %thesaurus_db; 1899: if (! -e $thesaurus_db_file) { 1900: &Apache::lonnet::logthis("Attempt to access $thesaurus_db_file ". 1901: "failed because the file does not exist"); 1902: return (); 1903: } 1904: if (! tie(%thesaurus_db,'GDBM_File', 1905: $thesaurus_db_file,&GDBM_READER(),0640)){ 1906: return (); 1907: } 1908: my @Words=(); 1909: if (exists($thesaurus_db{$keyword})) { 1910: # The first element is the number of times 1911: # the word appears. We do not need it now. 1912: (undef,@Words) = (split(/:/,$thesaurus_db{$keyword})); 1913: for (my $i=0;$i<=$#Words;$i++) { 1914: ($Words[$i],undef)= split(/\,/,$Words[$i]); 1915: } 1916: } 1917: untie %thesaurus_db; 1918: return @Words; 1919: } 1920: 1921: =pod 1922: 1923: =back 1924: 1925: =cut 1926: 1927: # -------------------------------------------------------------- Plaintext name 1928: =pod 1929: 1930: =head1 User Name Functions 1931: 1932: =over 4 1933: 1934: =item * plainname($uname,$udom,$first) 1935: 1936: Takes a users logon name and returns it as a string in 1937: "first middle last generation" form 1938: if $first is set to 'lastname' then it returns it as 1939: 'lastname generation, firstname middlename' if their is a lastname 1940: 1941: =cut 1942: 1943: 1944: ############################################################### 1945: sub plainname { 1946: my ($uname,$udom,$first)=@_; 1947: my %names=&getnames($uname,$udom); 1948: my $name=&Apache::lonnet::format_name($names{'firstname'}, 1949: $names{'middlename'}, 1950: $names{'lastname'}, 1951: $names{'generation'},$first); 1952: $name=~s/^\s+//; 1953: $name=~s/\s+$//; 1954: $name=~s/\s+/ /g; 1955: if ($name !~ /\S/) { $name=$uname.':'.$udom; } 1956: return $name; 1957: } 1958: 1959: # -------------------------------------------------------------------- Nickname 1960: =pod 1961: 1962: =item * nickname($uname,$udom) 1963: 1964: Gets a users name and returns it as a string as 1965: 1966: ""nickname"" 1967: 1968: if the user has a nickname or 1969: 1970: "first middle last generation" 1971: 1972: if the user does not 1973: 1974: =cut 1975: 1976: sub nickname { 1977: my ($uname,$udom)=@_; 1978: my %names=&getnames($uname,$udom); 1979: my $name=$names{'nickname'}; 1980: if ($name) { 1981: $name='"'.$name.'"'; 1982: } else { 1983: $name=$names{'firstname'}.' '.$names{'middlename'}.' '. 1984: $names{'lastname'}.' '.$names{'generation'}; 1985: $name=~s/\s+$//; 1986: $name=~s/\s+/ /g; 1987: } 1988: return $name; 1989: } 1990: 1991: sub getnames { 1992: my ($uname,$udom)=@_; 1993: my $id=$uname.':'.$udom; 1994: my ($names,$cached)=&Apache::lonnet::is_cached_new('namescache',$id); 1995: if ($cached) { 1996: return %{$names}; 1997: } else { 1998: my %loadnames=&Apache::lonnet::get('environment', 1999: ['firstname','middlename','lastname','generation','nickname'], 2000: $udom,$uname); 2001: &Apache::lonnet::do_cache_new('namescache',$id,\%loadnames); 2002: return %loadnames; 2003: } 2004: } 2005: 2006: # ------------------------------------------------------------------ Screenname 2007: 2008: =pod 2009: 2010: =item * screenname($uname,$udom) 2011: 2012: Gets a users screenname and returns it as a string 2013: 2014: =cut 2015: 2016: sub screenname { 2017: my ($uname,$udom)=@_; 2018: if ($uname eq $env{'user.name'} && 2019: $udom eq $env{'user.domain'}) {return $env{'environment.screenname'};} 2020: my %names=&Apache::lonnet::get('environment',['screenname'],$udom,$uname); 2021: return $names{'screenname'}; 2022: } 2023: 2024: 2025: # ------------------------------------------------------------- Message Wrapper 2026: 2027: sub messagewrapper { 2028: my ($link,$username,$domain,$subject,$text)=@_; 2029: return 2030: '<a href="/adm/email?compose=individual&'. 2031: 'recname='.$username.'&recdom='.$domain. 2032: '&subject='.&escape($subject).'&text='.&escape($text).'" '. 2033: 'title="'.&mt('Send message').'">'.$link.'</a>'; 2034: } 2035: # --------------------------------------------------------------- Notes Wrapper 2036: 2037: sub noteswrapper { 2038: my ($link,$un,$do)=@_; 2039: return 2040: "<a href='/adm/email?recordftf=retrieve&recname=$un&recdom=$do'>$link</a>"; 2041: } 2042: # ------------------------------------------------------------- Aboutme Wrapper 2043: 2044: sub aboutmewrapper { 2045: my ($link,$username,$domain,$target)=@_; 2046: return '<a href="/adm/'.$domain.'/'.$username.'/aboutme"'. 2047: ($target?' target="$target"':'').' title="'.&mt('View this users personal page').'">'.$link.'</a>'; 2048: } 2049: 2050: # ------------------------------------------------------------ Syllabus Wrapper 2051: 2052: 2053: sub syllabuswrapper { 2054: my ($linktext,$coursedir,$domain,$fontcolor)=@_; 2055: if ($fontcolor) { 2056: $linktext='<font color="'.$fontcolor.'">'.$linktext.'</font>'; 2057: } 2058: return qq{<a href="/public/$domain/$coursedir/syllabus">$linktext</a>}; 2059: } 2060: 2061: sub track_student_link { 2062: my ($linktext,$sname,$sdom,$target,$start) = @_; 2063: my $link ="/adm/trackstudent?"; 2064: my $title = 'View recent activity'; 2065: if (defined($sname) && $sname !~ /^\s*$/ && 2066: defined($sdom) && $sdom !~ /^\s*$/) { 2067: $link .= "selected_student=$sname:$sdom"; 2068: $title .= ' of this student'; 2069: } 2070: if (defined($target) && $target !~ /^\s*$/) { 2071: $target = qq{target="$target"}; 2072: } else { 2073: $target = ''; 2074: } 2075: if ($start) { $link.='&start='.$start; } 2076: return qq{<a href="$link" title="$title" $target>$linktext</a>}; 2077: } 2078: 2079: =pod 2080: 2081: =back 2082: 2083: =head1 Access .tab File Data 2084: 2085: =over 4 2086: 2087: =item * languageids() 2088: 2089: returns list of all language ids 2090: 2091: =cut 2092: 2093: sub languageids { 2094: return sort(keys(%language)); 2095: } 2096: 2097: =pod 2098: 2099: =item * languagedescription() 2100: 2101: returns description of a specified language id 2102: 2103: =cut 2104: 2105: sub languagedescription { 2106: my $code=shift; 2107: return ($supported_language{$code}?'* ':''). 2108: $language{$code}. 2109: ($supported_language{$code}?' ('.&mt('interface available').')':''); 2110: } 2111: 2112: sub plainlanguagedescription { 2113: my $code=shift; 2114: return $language{$code}; 2115: } 2116: 2117: sub supportedlanguagecode { 2118: my $code=shift; 2119: return $supported_language{$code}; 2120: } 2121: 2122: =pod 2123: 2124: =item * copyrightids() 2125: 2126: returns list of all copyrights 2127: 2128: =cut 2129: 2130: sub copyrightids { 2131: return sort(keys(%cprtag)); 2132: } 2133: 2134: =pod 2135: 2136: =item * copyrightdescription() 2137: 2138: returns description of a specified copyright id 2139: 2140: =cut 2141: 2142: sub copyrightdescription { 2143: return &mt($cprtag{shift(@_)}); 2144: } 2145: 2146: =pod 2147: 2148: =item * source_copyrightids() 2149: 2150: returns list of all source copyrights 2151: 2152: =cut 2153: 2154: sub source_copyrightids { 2155: return sort(keys(%scprtag)); 2156: } 2157: 2158: =pod 2159: 2160: =item * source_copyrightdescription() 2161: 2162: returns description of a specified source copyright id 2163: 2164: =cut 2165: 2166: sub source_copyrightdescription { 2167: return &mt($scprtag{shift(@_)}); 2168: } 2169: 2170: =pod 2171: 2172: =item * filecategories() 2173: 2174: returns list of all file categories 2175: 2176: =cut 2177: 2178: sub filecategories { 2179: return sort(keys(%category_extensions)); 2180: } 2181: 2182: =pod 2183: 2184: =item * filecategorytypes() 2185: 2186: returns list of file types belonging to a given file 2187: category 2188: 2189: =cut 2190: 2191: sub filecategorytypes { 2192: my ($cat) = @_; 2193: return @{$category_extensions{lc($cat)}}; 2194: } 2195: 2196: =pod 2197: 2198: =item * fileembstyle() 2199: 2200: returns embedding style for a specified file type 2201: 2202: =cut 2203: 2204: sub fileembstyle { 2205: return $fe{lc(shift(@_))}; 2206: } 2207: 2208: sub filemimetype { 2209: return $fm{lc(shift(@_))}; 2210: } 2211: 2212: 2213: sub filecategoryselect { 2214: my ($name,$value)=@_; 2215: return &select_form($value,$name, 2216: '' => &mt('Any category'), 2217: map { $_,$_ } sort(keys(%category_extensions))); 2218: } 2219: 2220: =pod 2221: 2222: =item * filedescription() 2223: 2224: returns description for a specified file type 2225: 2226: =cut 2227: 2228: sub filedescription { 2229: my $file_description = $fd{lc(shift())}; 2230: $file_description =~ s:([\[\]]):~$1:g; 2231: return &mt($file_description); 2232: } 2233: 2234: =pod 2235: 2236: =item * filedescriptionex() 2237: 2238: returns description for a specified file type with 2239: extra formatting 2240: 2241: =cut 2242: 2243: sub filedescriptionex { 2244: my $ex=shift; 2245: my $file_description = $fd{lc($ex)}; 2246: $file_description =~ s:([\[\]]):~$1:g; 2247: return '.'.$ex.' '.&mt($file_description); 2248: } 2249: 2250: # End of .tab access 2251: =pod 2252: 2253: =back 2254: 2255: =cut 2256: 2257: # ------------------------------------------------------------------ File Types 2258: sub fileextensions { 2259: return sort(keys(%fe)); 2260: } 2261: 2262: # ----------------------------------------------------------- Display Languages 2263: # returns a hash with all desired display languages 2264: # 2265: 2266: sub display_languages { 2267: my %languages=(); 2268: foreach my $lang (&preferred_languages()) { 2269: $languages{$lang}=1; 2270: } 2271: &get_unprocessed_cgi($ENV{'QUERY_STRING'},['displaylanguage']); 2272: if ($env{'form.displaylanguage'}) { 2273: foreach my $lang (split(/\s*(\,|\;|\:)\s*/,$env{'form.displaylanguage'})) { 2274: $languages{$lang}=1; 2275: } 2276: } 2277: return %languages; 2278: } 2279: 2280: sub preferred_languages { 2281: my @languages=(); 2282: if ($env{'course.'.$env{'request.course.id'}.'.languages'}) { 2283: @languages=(@languages,split(/\s*(\,|\;|\:)\s*/, 2284: $env{'course.'.$env{'request.course.id'}.'.languages'})); 2285: } 2286: if ($env{'environment.languages'}) { 2287: @languages=split(/\s*(\,|\;|\:)\s*/,$env{'environment.languages'}); 2288: } 2289: my $browser=(split(/\;/,$ENV{'HTTP_ACCEPT_LANGUAGE'}))[0]; 2290: if ($browser) { 2291: @languages=(@languages,split(/\s*(\,|\;|\:)\s*/,$browser)); 2292: } 2293: if ($Apache::lonnet::domain_lang_def{$env{'user.domain'}}) { 2294: @languages=(@languages, 2295: $Apache::lonnet::domain_lang_def{$env{'user.domain'}}); 2296: } 2297: if ($Apache::lonnet::domain_lang_def{$env{'request.role.domain'}}) { 2298: @languages=(@languages, 2299: $Apache::lonnet::domain_lang_def{$env{'request.role.domain'}}); 2300: } 2301: if ($Apache::lonnet::domain_lang_def{ 2302: $Apache::lonnet::perlvar{'lonDefDomain'}}) { 2303: @languages=(@languages, 2304: $Apache::lonnet::domain_lang_def{ 2305: $Apache::lonnet::perlvar{'lonDefDomain'}}); 2306: } 2307: # turn "en-ca" into "en-ca,en" 2308: my @genlanguages; 2309: foreach my $lang (@languages) { 2310: unless ($lang=~/\w/) { next; } 2311: push (@genlanguages,$lang); 2312: if ($lang=~/(\-|\_)/) { 2313: push(@genlanguages,(split(/(\-|\_)/,$lang))[0]); 2314: } 2315: } 2316: return @genlanguages; 2317: } 2318: 2319: ############################################################### 2320: ## Student Answer Attempts ## 2321: ############################################################### 2322: 2323: =pod 2324: 2325: =head1 Alternate Problem Views 2326: 2327: =over 4 2328: 2329: =item * get_previous_attempt($symb, $username, $domain, $course, 2330: $getattempt, $regexp, $gradesub) 2331: 2332: Return string with previous attempt on problem. Arguments: 2333: 2334: =over 4 2335: 2336: =item * $symb: Problem, including path 2337: 2338: =item * $username: username of the desired student 2339: 2340: =item * $domain: domain of the desired student 2341: 2342: =item * $course: Course ID 2343: 2344: =item * $getattempt: Leave blank for all attempts, otherwise put 2345: something 2346: 2347: =item * $regexp: if string matches this regexp, the string will be 2348: sent to $gradesub 2349: 2350: =item * $gradesub: routine that processes the string if it matches $regexp 2351: 2352: =back 2353: 2354: The output string is a table containing all desired attempts, if any. 2355: 2356: =cut 2357: 2358: sub get_previous_attempt { 2359: my ($symb,$username,$domain,$course,$getattempt,$regexp,$gradesub)=@_; 2360: my $prevattempts=''; 2361: no strict 'refs'; 2362: if ($symb) { 2363: my (%returnhash)= 2364: &Apache::lonnet::restore($symb,$course,$domain,$username); 2365: if ($returnhash{'version'}) { 2366: my %lasthash=(); 2367: my $version; 2368: for ($version=1;$version<=$returnhash{'version'};$version++) { 2369: foreach my $key (sort(split(/\:/,$returnhash{$version.':keys'}))) { 2370: $lasthash{$key}=$returnhash{$version.':'.$key}; 2371: } 2372: } 2373: $prevattempts='<table border="0" width="100%"><tr><td bgcolor="#777777">'; 2374: $prevattempts.='<table border="0" width="100%"><tr bgcolor="#e6ffff"><td>History</td>'; 2375: foreach my $key (sort(keys(%lasthash))) { 2376: my ($ign,@parts) = split(/\./,$key); 2377: if ($#parts > 0) { 2378: my $data=$parts[-1]; 2379: pop(@parts); 2380: $prevattempts.='<td>Part '.join('.',@parts).'<br />'.$data.' </td>'; 2381: } else { 2382: if ($#parts == 0) { 2383: $prevattempts.='<th>'.$parts[0].'</th>'; 2384: } else { 2385: $prevattempts.='<th>'.$ign.'</th>'; 2386: } 2387: } 2388: } 2389: if ($getattempt eq '') { 2390: for ($version=1;$version<=$returnhash{'version'};$version++) { 2391: $prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Transaction '.$version.'</td>'; 2392: foreach my $key (sort(keys(%lasthash))) { 2393: my $value; 2394: if ($key =~ /timestamp/) { 2395: $value=scalar(localtime($returnhash{$version.':'.$key})); 2396: } else { 2397: $value=$returnhash{$version.':'.$key}; 2398: } 2399: $prevattempts.='<td>'.&unescape($value).' </td>'; 2400: } 2401: } 2402: } 2403: $prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Current</td>'; 2404: foreach my $key (sort(keys(%lasthash))) { 2405: my $value; 2406: if ($key =~ /timestamp/) { 2407: $value=scalar(localtime($lasthash{$key})); 2408: } else { 2409: $value=$lasthash{$key}; 2410: } 2411: $value=&unescape($value); 2412: if ($key =~/$regexp$/ && (defined &$gradesub)) {$value = &$gradesub($value)} 2413: $prevattempts.='<td>'.$value.' </td>'; 2414: } 2415: $prevattempts.='</tr></table></td></tr></table>'; 2416: } else { 2417: $prevattempts='Nothing submitted - no attempts.'; 2418: } 2419: } else { 2420: $prevattempts='No data.'; 2421: } 2422: } 2423: 2424: sub relative_to_absolute { 2425: my ($url,$output)=@_; 2426: my $parser=HTML::TokeParser->new(\$output); 2427: my $token; 2428: my $thisdir=$url; 2429: my @rlinks=(); 2430: while ($token=$parser->get_token) { 2431: if ($token->[0] eq 'S') { 2432: if ($token->[1] eq 'a') { 2433: if ($token->[2]->{'href'}) { 2434: $rlinks[$#rlinks+1]=$token->[2]->{'href'}; 2435: } 2436: } elsif ($token->[1] eq 'img' || $token->[1] eq 'embed' ) { 2437: $rlinks[$#rlinks+1]=$token->[2]->{'src'}; 2438: } elsif ($token->[1] eq 'base') { 2439: $thisdir=$token->[2]->{'href'}; 2440: } 2441: } 2442: } 2443: $thisdir=~s-/[^/]*$--; 2444: foreach my $link (@rlinks) { 2445: unless (($link=~/^http:\/\//i) || 2446: ($link=~/^\//) || 2447: ($link=~/^javascript:/i) || 2448: ($link=~/^mailto:/i) || 2449: ($link=~/^\#/)) { 2450: my $newlocation=&Apache::lonnet::hreflocation($thisdir,$link); 2451: $output=~s/(\"|\'|\=\s*)\Q$link\E(\"|\'|\s|\>)/$1$newlocation$2/; 2452: } 2453: } 2454: # -------------------------------------------------- Deal with Applet codebases 2455: $output=~s/(\<applet[^\>]+)(codebase\=[^\S\>]+)*([^\>]*)\>/$1.($2?$2:' codebase="'.$thisdir.'"').$3.'>'/gei; 2456: return $output; 2457: } 2458: 2459: =pod 2460: 2461: =item * get_student_view 2462: 2463: show a snapshot of what student was looking at 2464: 2465: =cut 2466: 2467: sub get_student_view { 2468: my ($symb,$username,$domain,$courseid,$target,$moreenv) = @_; 2469: my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb); 2470: my (%form); 2471: my @elements=('symb','courseid','domain','username'); 2472: foreach my $element (@elements) { 2473: $form{'grade_'.$element}=eval '$'.$element #' 2474: } 2475: if (defined($moreenv)) { 2476: %form=(%form,%{$moreenv}); 2477: } 2478: if (defined($target)) { $form{'grade_target'} = $target; } 2479: $feedurl=&Apache::lonnet::clutter($feedurl); 2480: my $userview=&Apache::lonnet::ssi_body($feedurl,%form); 2481: $userview=~s/\<body[^\>]*\>//gi; 2482: $userview=~s/\<\/body\>//gi; 2483: $userview=~s/\<html\>//gi; 2484: $userview=~s/\<\/html\>//gi; 2485: $userview=~s/\<head\>//gi; 2486: $userview=~s/\<\/head\>//gi; 2487: $userview=~s/action\s*\=/would_be_action\=/gi; 2488: $userview=&relative_to_absolute($feedurl,$userview); 2489: return $userview; 2490: } 2491: 2492: =pod 2493: 2494: =item * get_student_answers() 2495: 2496: show a snapshot of how student was answering problem 2497: 2498: =cut 2499: 2500: sub get_student_answers { 2501: my ($symb,$username,$domain,$courseid,%form) = @_; 2502: my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb); 2503: my (%moreenv); 2504: my @elements=('symb','courseid','domain','username'); 2505: foreach my $element (@elements) { 2506: $moreenv{'grade_'.$element}=eval '$'.$element #' 2507: } 2508: $moreenv{'grade_target'}='answer'; 2509: %moreenv=(%form,%moreenv); 2510: my $userview=&Apache::lonnet::ssi('/res/'.$feedurl,%moreenv); 2511: return $userview; 2512: } 2513: 2514: =pod 2515: 2516: =item * &submlink() 2517: 2518: Inputs: $text $uname $udom $symb $target 2519: 2520: Returns: A link to grades.pm such as to see the SUBM view of a student 2521: 2522: =cut 2523: 2524: ############################################### 2525: sub submlink { 2526: my ($text,$uname,$udom,$symb,$target)=@_; 2527: if (!($uname && $udom)) { 2528: (my $cursymb, my $courseid,$udom,$uname)= 2529: &Apache::lonxml::whichuser($symb); 2530: if (!$symb) { $symb=$cursymb; } 2531: } 2532: if (!$symb) { $symb=&Apache::lonnet::symbread(); } 2533: $symb=&escape($symb); 2534: if ($target) { $target="target=\"$target\""; } 2535: return '<a href="/adm/grades?&command=submission&'. 2536: 'symb='.$symb.'&student='.$uname. 2537: '&userdom='.$udom.'" '.$target.'>'.$text.'</a>'; 2538: } 2539: ############################################## 2540: 2541: =pod 2542: 2543: =item * &pgrdlink() 2544: 2545: Inputs: $text $uname $udom $symb $target 2546: 2547: Returns: A link to grades.pm such as to see the PGRD view of a student 2548: 2549: =cut 2550: 2551: ############################################### 2552: sub pgrdlink { 2553: my $link=&submlink(@_); 2554: $link=~s/(&command=submission)/$1&showgrading=yes/; 2555: return $link; 2556: } 2557: ############################################## 2558: 2559: =pod 2560: 2561: =item * &pprmlink() 2562: 2563: Inputs: $text $uname $udom $symb $target 2564: 2565: Returns: A link to parmset.pm such as to see the PPRM view of a 2566: student and a specific resource 2567: 2568: =cut 2569: 2570: ############################################### 2571: sub pprmlink { 2572: my ($text,$uname,$udom,$symb,$target)=@_; 2573: if (!($uname && $udom)) { 2574: (my $cursymb, my $courseid,$udom,$uname)= 2575: &Apache::lonxml::whichuser($symb); 2576: if (!$symb) { $symb=$cursymb; } 2577: } 2578: if (!$symb) { $symb=&Apache::lonnet::symbread(); } 2579: $symb=&escape($symb); 2580: if ($target) { $target="target=\"$target\""; } 2581: return '<a href="/adm/parmset?&command=set&'. 2582: 'symb='.$symb.'&uname='.$uname. 2583: '&udom='.$udom.'" '.$target.'>'.$text.'</a>'; 2584: } 2585: ############################################## 2586: 2587: =pod 2588: 2589: =back 2590: 2591: =cut 2592: 2593: ############################################### 2594: 2595: 2596: sub timehash { 2597: my @ltime=localtime(shift); 2598: return ( 'seconds' => $ltime[0], 2599: 'minutes' => $ltime[1], 2600: 'hours' => $ltime[2], 2601: 'day' => $ltime[3], 2602: 'month' => $ltime[4]+1, 2603: 'year' => $ltime[5]+1900, 2604: 'weekday' => $ltime[6], 2605: 'dayyear' => $ltime[7]+1, 2606: 'dlsav' => $ltime[8] ); 2607: } 2608: 2609: sub utc_string { 2610: my ($date)=@_; 2611: return strftime("%Y%m%dT%H%M%SZ",gmtime($date)); 2612: } 2613: 2614: sub maketime { 2615: my %th=@_; 2616: return POSIX::mktime( 2617: ($th{'seconds'},$th{'minutes'},$th{'hours'}, 2618: $th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,-1)); 2619: } 2620: 2621: ######################################### 2622: 2623: sub findallcourses { 2624: my ($roles) = @_; 2625: my %roles; 2626: if (ref($roles)) { %roles = map { $_ => 1 } @{$roles}; } 2627: my %courses; 2628: my $now=time; 2629: foreach my $key (keys(%env)) { 2630: if ( $key=~m{^user\.role\.(\w+)\./(\w+)/(\w+)} ) { 2631: my ($role,$domain,$id) = ($1,$2,$3); 2632: next if ($role eq 'ca' || $role eq 'aa'); 2633: next if (%roles && !exists($roles{$role})); 2634: my ($starttime,$endtime)=split(/\./,$env{$key}); 2635: my $active=1; 2636: if ($starttime) { 2637: if ($now<$starttime) { $active=0; } 2638: } 2639: if ($endtime) { 2640: if ($now>$endtime) { $active=0; } 2641: } 2642: if ($active) { $courses{$domain.'_'.$id}=1; } 2643: } 2644: } 2645: return keys(%courses); 2646: } 2647: 2648: ############################################### 2649: ############################################### 2650: 2651: =pod 2652: 2653: =head1 Domain Template Functions 2654: 2655: =over 4 2656: 2657: =item * &determinedomain() 2658: 2659: Inputs: $domain (usually will be undef) 2660: 2661: Returns: Determines which domain should be used for designs 2662: 2663: =cut 2664: 2665: ############################################### 2666: sub determinedomain { 2667: my $domain=shift; 2668: if (! $domain) { 2669: # Determine domain if we have not been given one 2670: $domain = $Apache::lonnet::perlvar{'lonDefDomain'}; 2671: if ($env{'user.domain'}) { $domain=$env{'user.domain'}; } 2672: if ($env{'request.role.domain'}) { 2673: $domain=$env{'request.role.domain'}; 2674: } 2675: } 2676: return $domain; 2677: } 2678: ############################################### 2679: =pod 2680: 2681: =item * &domainlogo() 2682: 2683: Inputs: $domain (usually will be undef) 2684: 2685: Returns: A link to a domain logo, if the domain logo exists. 2686: If the domain logo does not exist, a description of the domain. 2687: 2688: =cut 2689: 2690: ############################################### 2691: sub domainlogo { 2692: my $domain = &determinedomain(shift); 2693: # See if there is a logo 2694: if (-e '/home/httpd/html/adm/lonDomLogos/'.$domain.'.gif') { 2695: my $logo=&lonhttpdurl("/adm/lonDomLogos/$domain.gif"); 2696: return '<img src="'.$logo.'" alt="'.$domain.'" />'; 2697: } elsif(exists($Apache::lonnet::domaindescription{$domain})) { 2698: return $Apache::lonnet::domaindescription{$domain}; 2699: } else { 2700: return ''; 2701: } 2702: } 2703: ############################################## 2704: 2705: =pod 2706: 2707: =item * &designparm() 2708: 2709: Inputs: $which parameter; $domain (usually will be undef) 2710: 2711: Returns: value of designparamter $which 2712: 2713: =cut 2714: 2715: ############################################## 2716: sub designparm { 2717: my ($which,$domain)=@_; 2718: if ($env{'browser.blackwhite'} eq 'on') { 2719: if ($which=~/\.(font|alink|vlink|link)$/) { 2720: return '#000000'; 2721: } 2722: if ($which=~/\.(pgbg|sidebg)$/) { 2723: return '#FFFFFF'; 2724: } 2725: if ($which=~/\.tabbg$/) { 2726: return '#CCCCCC'; 2727: } 2728: } 2729: if ($env{'environment.color.'.$which}) { 2730: return $env{'environment.color.'.$which}; 2731: } 2732: $domain=&determinedomain($domain); 2733: if ($designhash{$domain.'.'.$which}) { 2734: return $designhash{$domain.'.'.$which}; 2735: } else { 2736: return $designhash{'default.'.$which}; 2737: } 2738: } 2739: 2740: ############################################### 2741: ############################################### 2742: 2743: =pod 2744: 2745: =back 2746: 2747: =head1 HTTP Helpers 2748: 2749: =over 4 2750: 2751: =item * &bodytag() 2752: 2753: Returns a uniform header for LON-CAPA web pages. 2754: 2755: Inputs: 2756: 2757: =over 4 2758: 2759: =item * $title, A title to be displayed on the page. 2760: 2761: =item * $function, the current role (can be undef). 2762: 2763: =item * $addentries, extra parameters for the <body> tag. 2764: 2765: =item * $bodyonly, if defined, only return the <body> tag. 2766: 2767: =item * $domain, if defined, force a given domain. 2768: 2769: =item * $forcereg, if page should register as content page (relevant for 2770: text interface only) 2771: 2772: =item * $customtitle, alternate text to use instead of $title 2773: in the title box that appears, this text 2774: is not auto translated like the $title is 2775: 2776: =item * $notopbar, if true, keep the 'what is this' info but remove the 2777: navigational links 2778: 2779: =item * $bgcolor, used to override the bgcolor on a webpage to a specific value 2780: 2781: =item * $notitle, if true keep the nav controls, but remove the title bar 2782: 2783: =item * $no_inline_link, if true and in remote mode, don't show the 2784: 'Switch To Inline Menu' link 2785: 2786: 2787: =back 2788: 2789: Returns: A uniform header for LON-CAPA web pages. 2790: If $bodyonly is nonzero, a string containing a <body> tag will be returned. 2791: If $bodyonly is undef or zero, an html string containing a <body> tag and 2792: other decorations will be returned. 2793: 2794: =cut 2795: 2796: sub bodytag { 2797: my ($title,$function,$addentries,$bodyonly,$domain,$forcereg,$customtitle, 2798: $notopbar,$bgcolor,$notitle,$no_inline_link)=@_; 2799: 2800: $title=&mt($title); 2801: 2802: $function = &get_users_function() if (!$function); 2803: my $img = &designparm($function.'.img',$domain); 2804: my $font = &designparm($function.'.font',$domain); 2805: my $pgbg = $bgcolor || &designparm($function.'.pgbg',$domain); 2806: 2807: my %design = ( 'style' => 'margin-top: 0px', 2808: 'bgcolor' => $pgbg, 2809: 'text' => $font, 2810: 'alink' => &designparm($function.'.alink',$domain), 2811: 'vlink' => &designparm($function.'.vlink',$domain), 2812: 'link' => &designparm($function.'.link',$domain),); 2813: @$addentries{keys(%design)} = @design{keys(%design)}; 2814: 2815: # role and realm 2816: my ($role,$realm) = 2817: &Apache::lonnet::plaintext((split(/\./,$env{'request.role'}))[0]); 2818: # realm 2819: if ($env{'request.course.id'}) { 2820: $realm = $env{'course.'.$env{'request.course.id'}.'.description'}; 2821: } 2822: if (!$realm) { $realm=' '; } 2823: # Set messages 2824: my $messages=&domainlogo($domain); 2825: # Port for miniserver 2826: my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'}; 2827: if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; } 2828: 2829: my $extra_body_attr = &make_attr_string($forcereg,$addentries); 2830: 2831: # construct main body tag 2832: my $bodytag = "<body $extra_body_attr>". 2833: &Apache::lontexconvert::init_math_support(); 2834: 2835: if ($bodyonly 2836: || ($env{'request.state'} eq 'construct' 2837: && $env{'environment.remote'} ne 'off' )) { 2838: return $bodytag; 2839: } elsif ($env{'browser.interface'} eq 'textual') { 2840: # Accessibility 2841: 2842: $bodytag.=&Apache::lonmenu::menubuttons($forcereg,$forcereg); 2843: if (!$notitle) { 2844: $bodytag.='<h1>LON-CAPA: '.$title.'</h1>'; 2845: } 2846: return $bodytag; 2847: } 2848: 2849: 2850: 2851: my $roleinfo=(<<ENDROLE); 2852: <td class="LC_title_bar_who"> 2853: <div class="LC_title_bar_name"> 2854: $env{'environment.firstname'} 2855: $env{'environment.middlename'} 2856: $env{'environment.lastname'} 2857: $env{'environment.generation'} 2858: 2859: </div> 2860: <div class="LC_title_bar_role"> 2861: $role 2862: </div> 2863: <div class="LC_title_bar_realm"> 2864: $realm 2865: </div> 2866: </td> 2867: ENDROLE 2868: 2869: my $titleinfo = '<span class="LC_title_bar_title">'.$title.'</span>'; 2870: if ($customtitle) { 2871: $titleinfo = $customtitle; 2872: } 2873: # 2874: # Extra info if you are the DC 2875: my $dc_info = ''; 2876: if ($env{'user.adv'} && exists($env{'user.role.dc./'. 2877: $env{'course.'.$env{'request.course.id'}. 2878: '.domain'}.'/'})) { 2879: my $cid = $env{'request.course.id'}; 2880: $dc_info.= $cid.' '.$env{'course.'.$cid.'.internal.coursecode'}; 2881: $dc_info = '('.$dc_info.')'; 2882: } 2883: 2884: if ($env{'environment.remote'} eq 'off') { 2885: # No Remote 2886: if ($env{'request.state'} eq 'construct') { 2887: $forcereg=1; 2888: } 2889: 2890: if (!$customtitle && $env{'request.state'} eq 'construct') { 2891: # this is for resources; directories have customtitle, and crumbs 2892: # and select recent are created in lonpubdir.pm 2893: my ($uname,$thisdisfn)= 2894: ($env{'request.filename'} =~ m|^/home/([^/]+)/public_html/(.*)|); 2895: my $formaction='/priv/'.$uname.'/'.$thisdisfn; 2896: $formaction=~s/\/+/\//g; 2897: 2898: my $parentpath = ''; 2899: my $lastitem = ''; 2900: if ($thisdisfn =~ m-(.+/)([^/]*)$-) { 2901: $parentpath = $1; 2902: $lastitem = $2; 2903: } else { 2904: $lastitem = $thisdisfn; 2905: } 2906: $titleinfo = 2907: &Apache::loncommon::help_open_menu('','','','',3,'Authoring'). 2908: '<b>Construction Space</b>: '. 2909: '<form name="dirs" method="post" action="'.$formaction 2910: .'" target="_top"><tt><b>' 2911: .&Apache::lonhtmlcommon::crumbs($uname.'/'.$parentpath,'_top','/priv','','+1',1)."<font size=\"+1\">$lastitem</font></b></tt><br />" 2912: .&Apache::lonhtmlcommon::select_recent('construct','recent','this.form.action=this.form.recent.value;this.form.submit()') 2913: .'</form>' 2914: .&Apache::lonmenu::constspaceform(); 2915: } 2916: 2917: my $titletable; 2918: if (!$notitle) { 2919: $titletable = 2920: '<table id="LC_title_bar">'. 2921: "<tr><td> $titleinfo $dc_info</td>".$roleinfo. 2922: '</tr></table>'; 2923: } 2924: if ($notopbar) { 2925: $bodytag .= $titletable; 2926: } else { 2927: if ($env{'request.state'} eq 'construct') { 2928: $bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg, 2929: $titletable); 2930: } else { 2931: $bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg). 2932: $titletable; 2933: } 2934: } 2935: return $bodytag; 2936: } 2937: 2938: # 2939: # Top frame rendering, Remote is up 2940: # 2941: 2942: my $upperleft='<img src="http://'.$ENV{'HTTP_HOST'}.':'. 2943: $lonhttpdPort.$img.'" alt="'.$function.'" />'; 2944: 2945: # Explicit link to get inline menu 2946: my $menu= ($no_inline_link?'' 2947: :'<br /><a href="/adm/remote?action=collapse">'.&mt('Switch to Inline Menu Mode').'</a>'); 2948: # 2949: if ($notitle) { 2950: return $bodytag; 2951: } 2952: return(<<ENDBODY); 2953: $bodytag 2954: <table id="LC_title_bar" class="LC_with_remote"> 2955: <tr><td class="LC_title_bar_role_logo">$upperleft</td> 2956: <td class="LC_title_bar_domain_logo">$messages </td> 2957: </tr> 2958: <tr><td>$titleinfo $dc_info $menu</td> 2959: $roleinfo 2960: </tr> 2961: </table> 2962: ENDBODY 2963: } 2964: 2965: sub make_attr_string { 2966: my ($register,$attr_ref) = @_; 2967: 2968: if ($attr_ref && !ref($attr_ref)) { 2969: die("addentries Must be a hash ref ". 2970: join(':',caller(1))." ". 2971: join(':',caller(0))." "); 2972: } 2973: 2974: if ($register) { 2975: my ($on_load,$on_unload); 2976: foreach my $key (keys(%{$attr_ref})) { 2977: if (lc($key) eq 'onload') { 2978: $on_load.=$attr_ref->{$key}.';'; 2979: delete($attr_ref->{$key}); 2980: 2981: } elsif (lc($key) eq 'onunload') { 2982: $on_unload.=$attr_ref->{$key}.';'; 2983: delete($attr_ref->{$key}); 2984: } 2985: } 2986: $attr_ref->{'onload'} = 2987: &Apache::lonmenu::loadevents(). $on_load; 2988: $attr_ref->{'onunload'}= 2989: &Apache::lonmenu::unloadevents().$on_unload; 2990: } 2991: 2992: # Accessibility font enhance 2993: if ($env{'browser.fontenhance'} eq 'on') { 2994: my $style; 2995: foreach my $key (keys(%{$attr_ref})) { 2996: if (lc($key) eq 'style') { 2997: $style.=$attr_ref->{$key}.';'; 2998: delete($attr_ref->{$key}); 2999: } 3000: } 3001: $attr_ref->{'style'}=$style.'; font-size: x-large;'; 3002: } 3003: 3004: if ($env{'browser.blackwhite'} eq 'on') { 3005: delete($attr_ref->{'font'}); 3006: delete($attr_ref->{'link'}); 3007: delete($attr_ref->{'alink'}); 3008: delete($attr_ref->{'vlink'}); 3009: delete($attr_ref->{'bgcolor'}); 3010: delete($attr_ref->{'background'}); 3011: } 3012: 3013: my $attr_string; 3014: foreach my $attr (keys(%$attr_ref)) { 3015: $attr_string .= " $attr=\"".$attr_ref->{$attr}.'" '; 3016: } 3017: return $attr_string; 3018: } 3019: 3020: 3021: ############################################### 3022: ############################################### 3023: 3024: =pod 3025: 3026: =back 3027: 3028: =head1 HTML Helpers 3029: 3030: =over 4 3031: 3032: =item * &endbodytag() 3033: 3034: Returns a uniform footer for LON-CAPA web pages. 3035: 3036: Inputs: none 3037: 3038: =back 3039: 3040: =cut 3041: 3042: sub endbodytag { 3043: my $endbodytag='</body>'; 3044: $endbodytag=&Apache::lontexconvert::jsMath_process()."\n".$endbodytag; 3045: if ( exists( $env{'internal.head.redirect'} ) ) { 3046: $endbodytag= 3047: "<br /><a href=\"$env{'internal.head.redirect'}\">". 3048: &mt('Continue').'</a>'. 3049: $endbodytag; 3050: } 3051: return $endbodytag; 3052: } 3053: 3054: =pod 3055: 3056: =over 4 3057: 3058: =item * &standard_css() 3059: 3060: Returns a style sheet 3061: 3062: Inputs: (all optional) 3063: domain -> force to color decorate a page for a specific 3064: domain 3065: function -> force usage of a specific rolish color scheme 3066: bgcolor -> override the default page bgcolor 3067: 3068: =back 3069: 3070: =cut 3071: 3072: sub standard_css { 3073: my ($function,$domain,$bgcolor) = @_; 3074: $function = &get_users_function() if (!$function); 3075: my $img = &designparm($function.'.img', $domain); 3076: my $tabbg = &designparm($function.'.tabbg', $domain); 3077: my $font = &designparm($function.'.font', $domain); 3078: my $sidebg = &designparm($function.'.sidebg',$domain); 3079: my $pgbg = $bgcolor || 3080: &designparm($function.'.pgbg', $domain); 3081: my $alink = &designparm($function.'.alink', $domain); 3082: my $vlink = &designparm($function.'.vlink', $domain); 3083: my $link = &designparm($function.'.link', $domain); 3084: 3085: my $sans = 'Arial,Helvetica,sans-serif'; 3086: my $data_table_head = $tabbg; 3087: my $data_table_light = '#EEEEEE'; 3088: my $data_table_dark = '#DDD'; 3089: my $data_table_highlight = '#FFFF00'; 3090: my $mail_new = '#FFBB77'; 3091: my $mail_new_hover = '#DD9955'; 3092: my $mail_read = '#BBBB77'; 3093: my $mail_read_hover = '#999944'; 3094: my $mail_replied = '#AAAA88'; 3095: my $mail_replied_hover = '#888855'; 3096: my $mail_other = '#99BBBB'; 3097: my $mail_other_hover = '#669999'; 3098: 3099: return <<END; 3100: h1, h2, h3, th { font-family: $sans } 3101: a:focus { color: red; background: yellow } 3102: table.thinborder { border-collapse: collapse; } 3103: table.thinborder tr th, table.thinborder tr td { border-style: solid; border-width: 1px} 3104: form, .inline { display: inline; } 3105: .center { text-align: center; } 3106: .filename {font-family: monospace;} 3107: .LC_error { 3108: color: red; 3109: font-size: larger; 3110: } 3111: .LC_success { 3112: color: green; 3113: } 3114: 3115: table#LC_top_nav, table#LC_menubuttons, table#LC_nav_location, table#LC_breadcrumbs { 3116: width: 100%; 3117: background: $pgbg; 3118: border: 0px; 3119: border-spacing: 2px 1px; 3120: padding: 0px; 3121: margin: 0px; 3122: border-collapse: separate; 3123: } 3124: table#LC_title_bar { 3125: width: 100%; 3126: border: 0; 3127: border-spacing: 0px 1px; 3128: padding: 0px 2px 0px 2px; 3129: background: $pgbg; 3130: font-family: $sans; 3131: border-collapse: collapse; 3132: } 3133: table#LC_title_bar.LC_with_remote { 3134: width: 100%; 3135: border: 0; 3136: border-spacing: 0; 3137: background: $pgbg; 3138: font-family: $sans; 3139: border-collapse: collapse; 3140: } 3141: table#LC_title_bar td { 3142: padding: 3px; 3143: background: $tabbg; 3144: } 3145: table#LC_title_bar td.LC_title_bar_who { 3146: background: $tabbg; 3147: color: $font; 3148: font: medium $sans; 3149: text-align: right; 3150: } 3151: span.LC_title_bar_title { 3152: font: bold xx-large $sans; 3153: } 3154: table#LC_title_bar td.LC_title_bar_domain_logo { 3155: background: $sidebg; 3156: text-align: right; 3157: padding: 0px; 3158: } 3159: table#LC_title_bar td.LC_title_bar_role_logo { 3160: background: $sidebg; 3161: padding: 0px; 3162: } 3163: 3164: table#LC_menubuttons_mainmenu { 3165: background: $pgbg; 3166: border: 0px; 3167: border-spacing: 1px; 3168: padding: 0px; 3169: margin: 0px; 3170: border-collapse: separate; 3171: } 3172: table#LC_menubuttons img, table#LC_menubuttons_mainmenu img { 3173: border: 0px; 3174: } 3175: table#LC_top_nav td { 3176: background: $tabbg; 3177: } 3178: table#LC_top_nav td a, div#LC_top_nav a { 3179: color: $font; 3180: font-family: $sans; 3181: } 3182: table#LC_top_nav td.LC_top_nav_logo { 3183: background: $tabbg; 3184: text-align: right; 3185: } 3186: table#LC_breadcrumbs td { 3187: background: $tabbg; 3188: color: $font; 3189: font-family: $sans; 3190: font-size: smaller; 3191: } 3192: table#LC_breadcrumbs td.LC_breadcrumb_component { 3193: background: $tabbg; 3194: color: $font; 3195: font-family: $sans; 3196: font-size: larger; 3197: text-align: right; 3198: } 3199: .LC_menubuttons_inline_text { 3200: color: $font; 3201: font-family: $sans; 3202: font-size: smaller; 3203: } 3204: 3205: td.LC_menubuttons_text { 3206: color: $font; 3207: font-family: $sans; 3208: } 3209: td.LC_menubuttons_img { 3210: background: $tabbg; 3211: } 3212: .LC_current_location { 3213: font-family: $sans; 3214: background: $tabbg; 3215: } 3216: .LC_new_mail { 3217: font-family: $sans; 3218: font-weight: bold; 3219: } 3220: 3221: table.LC_data_table, table.LC_mail_list { 3222: border: 1px solid #000000; 3223: border-collapse: seperate; 3224: } 3225: table.LC_data_table tr th, table.LC_calendar tr th, table.LC_mail_list tr th { 3226: font-weight: bold; 3227: background-color: $data_table_head; 3228: } 3229: table.LC_data_table tr td { 3230: background-color: $data_table_light; 3231: } 3232: table.LC_data_table tr.LC_even_row td { 3233: background-color: $data_table_dark; 3234: } 3235: table.LC_data_table tr.LC_empty td { 3236: background-color: #FFFFFF; 3237: } 3238: 3239: table.LC_calendar { 3240: border: 1px solid #000000; 3241: border-collapse: collapse; 3242: } 3243: table.LC_calendar_pickdate { 3244: font-size: xx-small; 3245: } 3246: table.LC_calendar tr td { 3247: border: 1px solid #000000; 3248: vertical-align: top; 3249: } 3250: table.LC_calendar tr td.LC_calendar_day_empty { 3251: background-color: $data_table_dark; 3252: } 3253: table.LC_calendar tr td.LC_calendar_day_current { 3254: background-color: $data_table_highlight; 3255: } 3256: 3257: table.LC_mail_list tr.LC_mail_new { 3258: background-color: $mail_new; 3259: } 3260: table.LC_mail_list tr.LC_mail_new:hover { 3261: background-color: $mail_new_hover; 3262: } 3263: table.LC_mail_list tr.LC_mail_read { 3264: background-color: $mail_read; 3265: } 3266: table.LC_mail_list tr.LC_mail_read:hover { 3267: background-color: $mail_read_hover; 3268: } 3269: table.LC_mail_list tr.LC_mail_replied { 3270: background-color: $mail_replied; 3271: } 3272: table.LC_mail_list tr.LC_mail_replied:hover { 3273: background-color: $mail_replied_hover; 3274: } 3275: table.LC_mail_list tr.LC_mail_other { 3276: background-color: $mail_other; 3277: } 3278: table.LC_mail_list tr.LC_mail_other:hover { 3279: background-color: $mail_other_hover; 3280: } 3281: END 3282: } 3283: 3284: =pod 3285: 3286: =over 4 3287: 3288: =item * &headtag() 3289: 3290: Returns a uniform footer for LON-CAPA web pages. 3291: 3292: Inputs: $title - optional title for the head 3293: $head_extra - optional extra HTML to put inside the <head> 3294: $args - optional arguments 3295: force_register - if is true call registerurl so the remote is 3296: informed 3297: redirect -> array ref of seconds before redirect occurs 3298: url to redirect to 3299: (side effect of setting 3300: $env{'internal.head.redirect'} to the url 3301: redirected too) 3302: domain -> force to color decorate a page for a specific 3303: domain 3304: function -> force usage of a specific rolish color scheme 3305: bgcolor -> override the default page bgcolor 3306: 3307: =back 3308: 3309: =cut 3310: 3311: sub headtag { 3312: my ($title,$head_extra,$args) = @_; 3313: 3314: my $function = $args->{'function'} || &get_users_function(); 3315: my $domain = $args->{'domain'} || &determinedomain(); 3316: my $bgcolor = $args->{'bgcolor'} || &designparm($function.'.pgbg',$domain); 3317: my $url = join(':',$env{'user.name'},$env{'user.domain'}, 3318: $env{'environment.color.timestamp'}, 3319: $function,$domain,$bgcolor); 3320: 3321: $url = '/adm/css/'.&escape($url).'.css'; 3322: 3323: my $result = 3324: '<head>'. 3325: '<link rel="stylesheet" type="text/css" href="'.$url.'" />'. 3326: &font_settings(). 3327: &Apache::lonhtmlcommon::htmlareaheaders(); 3328: 3329: if ($args->{'force_register'}) { 3330: $result .= &Apache::lonmenu::registerurl(1); 3331: } 3332: 3333: if (ref($args->{'redirect'})) { 3334: my ($time,$url) = @{$args->{'redirect'}}; 3335: $url = &Apache::lonenc::check_encrypt($url); 3336: $env{'internal.head.redirect'} = $url; 3337: $result.=<<ADDMETA 3338: <meta http-equiv="pragma" content="no-cache" /> 3339: <meta http-equiv="Refresh" content="$time; url=$url" /> 3340: ADDMETA 3341: } 3342: if (!defined($title)) { 3343: $title = 'The LearningOnline Network with CAPA'; 3344: } 3345: 3346: $result .= '<title> LON-CAPA '.&mt($title).'</title>'.$head_extra; 3347: return $result; 3348: } 3349: 3350: =pod 3351: 3352: =over 4 3353: 3354: =item * &font_settings() 3355: 3356: Returns neccessary <meta> to set the proper encoding 3357: 3358: Inputs: none 3359: 3360: =back 3361: 3362: =cut 3363: 3364: sub font_settings { 3365: my $headerstring=''; 3366: if (($env{'browser.os'} eq 'mac') && (!$env{'browser.mathml'})) { 3367: $headerstring.= 3368: '<meta Content-Type="text/html; charset=x-mac-roman" />'; 3369: } elsif (!$env{'browser.mathml'} && $env{'browser.unicode'}) { 3370: $headerstring.= 3371: '<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />'; 3372: } 3373: return $headerstring; 3374: } 3375: 3376: =pod 3377: 3378: =over 4 3379: 3380: =item * &xml_begin() 3381: 3382: Returns the needed doctype and <html> 3383: 3384: Inputs: none 3385: 3386: =back 3387: 3388: =cut 3389: 3390: sub xml_begin { 3391: my $output=''; 3392: 3393: &Apache::lonhtmlcommon::init_htmlareafields(); 3394: 3395: if ($env{'browser.mathml'}) { 3396: $output='<?xml version="1.0"?>' 3397: #.'<?xml-stylesheet type="text/css" href="/adm/MathML/mathml.css"?>'."\n" 3398: # .'<!DOCTYPE html SYSTEM "/adm/MathML/mathml.dtd" ' 3399: 3400: # .'<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd" [<!ENTITY mathns "http://www.w3.org/1998/Math/MathML">] >' 3401: .'<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1 plus MathML 2.0 plus SVG 1.1//EN" "http://www.w3.org/2002/04/xhtml-math-svg/xhtml-math-svg.dtd">' 3402: .'<html xmlns:math="http://www.w3.org/1998/Math/MathML" ' 3403: .'xmlns="http://www.w3.org/1999/xhtml">'; 3404: } else { 3405: $output='<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"><html>'; 3406: } 3407: return $output; 3408: } 3409: 3410: =pod 3411: 3412: =over 4 3413: 3414: =item * &endheadtag() 3415: 3416: Returns a uniform </head> for LON-CAPA web pages. 3417: 3418: Inputs: none 3419: 3420: =back 3421: 3422: =cut 3423: 3424: sub endheadtag { 3425: return '</head>'; 3426: } 3427: 3428: =pod 3429: 3430: =over 4 3431: 3432: =item * &head() 3433: 3434: Returns a uniform complete <head>..</head> section for LON-CAPA web pages. 3435: 3436: Inputs: $title - optional title for the page 3437: $head_extra - optional extra HTML to put inside the <head> 3438: =back 3439: 3440: =cut 3441: 3442: sub head { 3443: my ($title,$head_extra,$args) = @_; 3444: return &headtag($title,$head_extra,$args).&endheadtag(); 3445: } 3446: 3447: =pod 3448: 3449: =over 4 3450: 3451: =item * &start_page() 3452: 3453: Returns a complete <html> .. <body> section for LON-CAPA web pages. 3454: 3455: Inputs: $title - optional title for the page 3456: $head_extra - optional extra HTML to incude inside the <head> 3457: $args - additional optional args supported are: 3458: only_body -> is true will set &bodytag() onlybodytag 3459: arg on 3460: no_nav_bar -> is true will set &bodytag() notopbar arg on 3461: add_entries -> additional attributes to add to the <body> 3462: domain -> force to color decorate a page for a 3463: specific domain 3464: function -> force usage of a specific rolish color 3465: scheme 3466: redirect -> see &headtag() 3467: bgcolor -> override the default page bg color 3468: js_ready -> return a string ready for being used in 3469: a javascript writeln 3470: html_encode -> return a string ready for being used in 3471: a html attribute 3472: force_register -> if is true will turn on the &bodytag() 3473: $forcereg arg 3474: body_title -> alternate text to use instead of $title 3475: in the title box that appears, this text 3476: is not auto translated like the $title is 3477: frameset -> if true will start with a <frameset> 3478: rather than <body> 3479: no_title -> if true the title bar won't be shown 3480: skip_phases -> hash ref of 3481: head -> skip the <html><head> generation 3482: body -> skip all <body> generation 3483: 3484: no_inline_link -> if true and in remote mode, don't show the 3485: 'Switch To Inline Menu' link 3486: 3487: =back 3488: 3489: =cut 3490: 3491: sub start_page { 3492: my ($title,$head_extra,$args) = @_; 3493: #&Apache::lonnet::logthis("start_page ".join(':',caller(0))); 3494: my %head_args; 3495: foreach my $arg ('redirect','force_register','domain','function', 3496: 'bgcolor') { 3497: if (defined($args->{$arg})) { 3498: $head_args{$arg} = $args->{$arg}; 3499: } 3500: } 3501: 3502: $env{'internal.start_page'}++; 3503: my $result; 3504: if (! exists($args->{'skip_phases'}{'head'}) ) { 3505: $result.= 3506: &xml_begin(). 3507: &headtag($title,$head_extra,\%head_args).&endheadtag(); 3508: } 3509: 3510: if (! exists($args->{'skip_phases'}{'body'}) ) { 3511: if ($args->{'frameset'}) { 3512: my $attr_string = &make_attr_string($args->{'force_register'}, 3513: $args->{'add_entries'}); 3514: $result .= "\n<frameset $attr_string>\n"; 3515: } else { 3516: $result .= 3517: &bodytag($title, 3518: $args->{'function'}, $args->{'add_entries'}, 3519: $args->{'only_body'}, $args->{'domain'}, 3520: $args->{'force_register'}, $args->{'body_title'}, 3521: $args->{'no_nav_bar'}, $args->{'bgcolor'}, 3522: $args->{'no_title'}, $args->{'no_inline_link'}); 3523: } 3524: } 3525: 3526: if ($args->{'js_ready'}) { 3527: $result = &js_ready($result); 3528: } 3529: if ($args->{'html_encode'}) { 3530: $result = &html_encode($result); 3531: } 3532: return $result; 3533: } 3534: 3535: 3536: =pod 3537: 3538: =over 4 3539: 3540: =item * &head() 3541: 3542: Returns a complete </body></html> section for LON-CAPA web pages. 3543: 3544: Inputs: $args - additional optional args supported are: 3545: js_ready -> return a string ready for being used in 3546: a javascript writeln 3547: html_encode -> return a string ready for being used in 3548: a html attribute 3549: frameset -> if true will start with a <frameset> 3550: rather than <body> 3551: =back 3552: 3553: =cut 3554: 3555: sub end_page { 3556: my ($args) = @_; 3557: #&Apache::lonnet::logthis("end_page ".join(':',caller(0))); 3558: $env{'internal.end_page'}++; 3559: my $result; 3560: if ($args->{'discussion'}) { 3561: my ($target,$parser); 3562: if (ref($args->{'discussion'})) { 3563: ($target,$parser) =($args->{'discussion'}{'target'}, 3564: $args->{'discussion'}{'parser'}); 3565: } 3566: $result .= &Apache::lonxml::xmlend($target,$parser); 3567: } 3568: 3569: if ($args->{'frameset'}) { 3570: $result .= '</frameset>'; 3571: } else { 3572: $result .= &endbodytag(); 3573: } 3574: $result .= "\n</html>"; 3575: 3576: if ($args->{'js_ready'}) { 3577: $result = &js_ready($result); 3578: } 3579: 3580: if ($args->{'html_encode'}) { 3581: $result = &html_encode($result); 3582: } 3583: 3584: return $result; 3585: } 3586: 3587: sub html_encode { 3588: my ($result) = @_; 3589: 3590: $result = &HTML::Entities::encode($result,'<>&"'); 3591: 3592: return $result; 3593: } 3594: sub js_ready { 3595: my ($result) = @_; 3596: 3597: $result =~ s/[\n\r]/ /xmsg; 3598: $result =~ s/\\/\\\\/xmsg; 3599: $result =~ s/'/\\'/xmsg; 3600: $result =~ s{</script>}{</scrip'+'t>}xmsg; 3601: 3602: return $result; 3603: } 3604: 3605: sub validate_page { 3606: if ( exists($env{'internal.start_page'}) 3607: && $env{'internal.start_page'} > 1) { 3608: &Apache::lonnet::logthis('start_page called multiple times '. 3609: $env{'internal.start_page'}.' '. 3610: $ENV{'request.filename'}); 3611: } 3612: if ( exists($env{'internal.end_page'}) 3613: && $env{'internal.end_page'} > 1) { 3614: &Apache::lonnet::logthis('end_page called multiple times '. 3615: $env{'internal.end_page'}.' '. 3616: $env{'request.filename'}); 3617: } 3618: if ( exists($env{'internal.start_page'}) 3619: && ! exists($env{'internal.end_page'})) { 3620: &Apache::lonnet::logthis('start_page called without end_page '. 3621: $env{'request.filename'}); 3622: } 3623: if ( ! exists($env{'internal.start_page'}) 3624: && exists($env{'internal.end_page'})) { 3625: &Apache::lonnet::logthis('end_page called without start_page'. 3626: $env{'request.filename'}); 3627: } 3628: } 3629: 3630: sub simple_error_page { 3631: my ($r,$title,$msg) = @_; 3632: my $page = 3633: &Apache::loncommon::start_page($title). 3634: &mt($msg). 3635: &Apache::loncommon::end_page(); 3636: if (ref($r)) { 3637: $r->print($page); 3638: return; 3639: } 3640: return $page; 3641: } 3642: 3643: { 3644: my $row_count; 3645: sub start_data_table { 3646: undef($row_count); 3647: return '<table class="LC_data_table">'; 3648: } 3649: 3650: sub end_data_table { 3651: undef($row_count); 3652: return '</table>'; 3653: } 3654: 3655: sub start_data_table_row { 3656: $row_count++; 3657: return '<tr '.(($row_count % 2)?'':'class="LC_even_row"').'>'; 3658: } 3659: 3660: sub end_data_table_row { 3661: return '</tr>'; 3662: } 3663: 3664: sub start_data_table_header_row { 3665: return '<tr class="LC_header_row">'; 3666: } 3667: 3668: sub end_data_table_header_row { 3669: return '</tr>'; 3670: } 3671: } 3672: 3673: ############################################### 3674: 3675: =pod 3676: 3677: =over 4 3678: 3679: =item get_users_function 3680: 3681: Used by &bodytag to determine the current users primary role. 3682: Returns either 'student','coordinator','admin', or 'author'. 3683: 3684: =cut 3685: 3686: ############################################### 3687: sub get_users_function { 3688: my $function = 'student'; 3689: if ($env{'request.role'}=~/^(cc|in|ta|ep)/) { 3690: $function='coordinator'; 3691: } 3692: if ($env{'request.role'}=~/^(su|dc|ad|li)/) { 3693: $function='admin'; 3694: } 3695: if (($env{'request.role'}=~/^(au|ca)/) || 3696: ($ENV{'REQUEST_URI'}=~/^(\/priv|\~)/)) { 3697: $function='author'; 3698: } 3699: return $function; 3700: } 3701: 3702: ############################################### 3703: 3704: =pod 3705: 3706: =item check_user_status 3707: 3708: Determines current status of supplied role for a 3709: specific user. Roles can be active, previous or future. 3710: 3711: Inputs: 3712: user's domain, user's username, course's domain, 3713: course's number, optional section/group. 3714: 3715: Outputs: 3716: role status: active, previous or future. 3717: 3718: =cut 3719: 3720: sub check_user_status { 3721: my ($udom,$uname,$cdom,$crs,$role,$secgrp) = @_; 3722: my %userinfo = &Apache::lonnet::dump('roles',$udom,$uname); 3723: my @uroles = keys %userinfo; 3724: my $srchstr; 3725: my $active_chk = 'none'; 3726: if (@uroles > 0) { 3727: if (($role eq 'cc') || ($secgrp eq '') || (!defined($secgrp))) { 3728: $srchstr = '/'.$cdom.'/'.$crs.'_'.$role; 3729: } else { 3730: $srchstr = '/'.$cdom.'/'.$crs.'/'.$secgrp.'_'.$role; } 3731: if (grep/^$srchstr$/,@uroles) { 3732: my $role_end = 0; 3733: my $role_start = 0; 3734: $active_chk = 'active'; 3735: if ($userinfo{$srchstr} =~ m/^($role)_(\d+)/) { 3736: $role_end = $2; 3737: if ($userinfo{$srchstr} =~ m/^($role)_($role_end)_(\d+)$/) { 3738: $role_start = $3; 3739: } 3740: } 3741: if ($role_start > 0) { 3742: if (time < $role_start) { 3743: $active_chk = 'future'; 3744: } 3745: } 3746: if ($role_end > 0) { 3747: if (time > $role_end) { 3748: $active_chk = 'previous'; 3749: } 3750: } 3751: } 3752: } 3753: return $active_chk; 3754: } 3755: 3756: ############################################### 3757: 3758: =pod 3759: 3760: =item get_sections 3761: 3762: Determines all the sections for a course including 3763: sections with students and sections containing other roles. 3764: Incoming parameters: domain, course number, reference to 3765: section hash (keys to be section/group IDs), reference to 3766: array containing roles for which sections should be gathered 3767: (optional). If the fourth argument is undefined, sections 3768: are gathered for any role. 3769: 3770: Returns number of sections. 3771: 3772: =cut 3773: 3774: ############################################### 3775: sub get_sections { 3776: my ($cdom,$cnum,$possible_roles) = @_; 3777: if (!defined($cdom) || !defined($cnum)) { 3778: my $cid = $env{'request.course.id'}; 3779: 3780: return if (!defined($cid)); 3781: 3782: $cdom = $env{'course.'.$cid.'.domain'}; 3783: $cnum = $env{'course.'.$cid.'.num'}; 3784: } 3785: 3786: my %sectioncount; 3787: 3788: if (!defined($possible_roles) || (grep(/^st$/,@$possible_roles))) { 3789: my ($classlist) = &Apache::loncoursedata::get_classlist($cdom,$cnum); 3790: my $sec_index = &Apache::loncoursedata::CL_SECTION(); 3791: my $status_index = &Apache::loncoursedata::CL_STATUS(); 3792: while (my ($student,$data) = each(%$classlist)) { 3793: my ($section,$status) = ($data->[$sec_index], 3794: $data->[$status_index]); 3795: unless ($section eq '-1' || $section =~ /^\s*$/) { 3796: $sectioncount{$section}++; 3797: } 3798: } 3799: } 3800: my %courseroles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum); 3801: foreach my $user (sort(keys(%courseroles))) { 3802: if ($user !~ /^(\w{2})/) { next; } 3803: my ($role) = ($user =~ /^(\w{2})/); 3804: if ($possible_roles && !(grep(/^$role$/,@$possible_roles))) { next; } 3805: my $section; 3806: if ($role eq 'cr' && 3807: $user =~ m-^$role/[^/]*/[^/]*/[^/]*:[^:]*:[^:]*:(\w+)-) { 3808: $section=$1; 3809: } 3810: if ($user =~ /^$role:[^:]*:[^:]*:(\w+)/) { $section=$1; } 3811: if (!defined($section) || $section eq '-1') { next; } 3812: $sectioncount{$section}++; 3813: } 3814: return %sectioncount; 3815: } 3816: 3817: ############################################### 3818: 3819: =pod 3820: 3821: =item coursegroups 3822: 3823: Retrieve information about groups in a course, 3824: 3825: Input: 3826: 1. Reference to hash to populate with group information. 3827: 2. Optional course domain 3828: 3. Optional course number 3829: 4. Optional group name 3830: 3831: Course domain and number will be taken from user's 3832: environment if not supplied. Optional group name will' 3833: be passed to lonnet::get_coursegroups() as a regexp to 3834: use in the call to the dump function. 3835: 3836: Output 3837: Returns number of groups in the course (subject to the 3838: optional group name filter). 3839: 3840: Side effects: 3841: Populates the referenced curr_groups hash, with key, 3842: value pairs. Keys are group names, corresponding values 3843: are scalars containing group information in XML. This 3844: can be sent to &get_group_settings() to be parsed. 3845: 3846: =cut 3847: 3848: ############################################### 3849: 3850: sub coursegroups { 3851: my ($cdom,$cnum,$group) = @_; 3852: if (!defined($cdom) || !defined($cnum)) { 3853: my $cid = $env{'request.course.id'}; 3854: 3855: return if (!defined($cid)); 3856: 3857: $cdom = $env{'course.'.$cid.'.domain'}; 3858: $cnum = $env{'course.'.$cid.'.num'}; 3859: } 3860: my %curr_groups = &Apache::lonnet::get_coursegroups($cdom,$cnum,$group); 3861: my ($tmp) = keys(%curr_groups); 3862: if ($tmp=~/^(con_lost|no_such_host|error: [^2] )/) { 3863: undef(%curr_groups); 3864: &logthis('Error retrieving groups: '.$tmp.' in '.$cnum.':'.$cdom); 3865: } elsif ($tmp=~/^error: 2 /) { 3866: undef(%curr_groups); 3867: } 3868: return %curr_groups; 3869: } 3870: 3871: ############################################### 3872: 3873: =pod 3874: 3875: =item get_group_settings 3876: 3877: Uses TokeParser to extract group information from the 3878: XML used to describe course groups. 3879: 3880: Input: 3881: Scalar containing XML - as retrieved from &coursegroups(). 3882: 3883: Output: 3884: Hash containing group information as key=values for (a), and 3885: hash of hashes for (b) 3886: 3887: Keys (in two categories): 3888: (a) groupname, creator, creation, modified, startdate,enddate. 3889: Corresponding values are name of the group, creator of the group 3890: (username:domain), UNIX time for date group was created, and 3891: settings were last modified, and default start and end access 3892: times for group members. 3893: 3894: (b) functions returned in hash of hashes. 3895: Outer hash key is functions. 3896: Inner hash keys are chat,discussion,email,files,homepage,roster. 3897: Corresponding values are either on or off, depending on 3898: whether this type of functionality is available for the group. 3899: 3900: =cut 3901: 3902: ############################################### 3903: 3904: sub get_group_settings { 3905: my ($groupinfo)=@_; 3906: my $parser=HTML::TokeParser->new(\$groupinfo); 3907: my $token; 3908: my $tool = ''; 3909: my $role = ''; 3910: my %content=(); 3911: while ($token=$parser->get_token) { 3912: if ($token->[0] eq 'S') { 3913: my $entry=$token->[1]; 3914: if ($entry eq 'functions' || $entry eq 'autosec') { 3915: %{$content{$entry}} = (); 3916: $tool = $entry; 3917: } elsif ($entry eq 'role') { 3918: if ($tool eq 'autosec') { 3919: $role = $token->[2]{id}; 3920: } 3921: } else { 3922: my $value=$parser->get_text('/'.$entry); 3923: if ($entry eq 'name') { 3924: if ($tool eq 'functions') { 3925: my $function = $token->[2]{id}; 3926: $content{$tool}{$function} = $value; 3927: } 3928: } elsif ($entry eq 'groupname') { 3929: $content{$entry}=&unescape($value); 3930: } elsif (($entry eq 'roles') || ($entry eq 'types') || 3931: ($entry eq 'sectionpick') || ($entry eq 'defpriv')) { 3932: push(@{$content{$entry}},$value); 3933: } elsif ($entry eq 'section') { 3934: if ($tool eq 'autosec' && $role ne '') { 3935: push(@{$content{$tool}{$role}},$value); 3936: } 3937: } else { 3938: $content{$entry}=$value; 3939: } 3940: } 3941: } elsif ($token->[0] eq 'E') { 3942: if ($token->[1] eq 'functions' || $token->[1] eq 'autosec') { 3943: $tool = ''; 3944: } elsif ($token->[1] eq 'role') { 3945: $role = ''; 3946: } 3947: 3948: } 3949: } 3950: return %content; 3951: } 3952: 3953: sub check_group_access { 3954: my ($group) = @_; 3955: my $access = 1; 3956: my $now = time; 3957: my ($start,$end) = split(/\./,$env{'user.role.gr/'.$env{'request.course,id'}.'/'.$group}); 3958: if (($end!=0) && ($end<$now)) { $access = 0; } 3959: if (($start!=0) && ($start>$now)) { $access=0; } 3960: return $access; 3961: } 3962: 3963: ############################################### 3964: 3965: =pod 3966: 3967: =item get_course_users 3968: 3969: Retrieves usernames:domains for users in the specified course 3970: with specific role(s), and access status. 3971: 3972: Incoming parameters: 3973: 1. course domain 3974: 2. course number 3975: 3. access status: users must have - either active, 3976: previous, future, or all. 3977: 4. reference to array of permissible roles 3978: 5. reference to array of section restrictions (optional) 3979: 6. reference to results object (hash of hashes). 3980: 7. reference to optional userdata hash 3981: Keys of top level hash are roles. 3982: Keys of inner hashes are username:domain, with 3983: values set to access type. 3984: Optional userdata hash returns an array with arguments in the 3985: same order as loncoursedata::get_classlist() for student data. 3986: 3987: Entries for end, start, section and status are blank because 3988: of the possibility of multiple values for non-student roles. 3989: 3990: =cut 3991: 3992: ############################################### 3993: 3994: sub get_course_users { 3995: my ($cdom,$cnum,$types,$roles,$sections,$users,$userdata) = @_; 3996: my %idx = (); 3997: 3998: $idx{udom} = &Apache::loncoursedata::CL_SDOM(); 3999: $idx{uname} = &Apache::loncoursedata::CL_SNAME(); 4000: $idx{end} = &Apache::loncoursedata::CL_END(); 4001: $idx{start} = &Apache::loncoursedata::CL_START(); 4002: $idx{id} = &Apache::loncoursedata::CL_ID(); 4003: $idx{section} = &Apache::loncoursedata::CL_SECTION(); 4004: $idx{fullname} = &Apache::loncoursedata::CL_FULLNAME(); 4005: $idx{status} = &Apache::loncoursedata::CL_STATUS(); 4006: 4007: if (grep(/^st$/,@{$roles})) { 4008: my ($classlist,$keylist)=&Apache::loncoursedata::get_classlist($cdom,$cnum); 4009: my $now = time; 4010: foreach my $student (keys(%{$classlist})) { 4011: my $match = 0; 4012: if ((ref($sections) eq 'ARRAY') && (@{$sections} > 0)) { 4013: unless(grep(/^\Q$$classlist{$student}[$idx{section}]\E$/, 4014: @{$sections})) { 4015: next; 4016: } 4017: } 4018: if (defined($$types{'active'})) { 4019: if ($$classlist{$student}[$idx{status}] eq 'Active') { 4020: push(@{$$users{st}{$student}},'active'); 4021: $match = 1; 4022: } 4023: } 4024: if (defined($$types{'previous'})) { 4025: if ($$classlist{$student}[$idx{end}] <= $now) { 4026: push(@{$$users{st}{$student}},'previous'); 4027: $match = 1; 4028: } 4029: } 4030: if (defined($$types{'future'})) { 4031: if (($$classlist{$student}[$idx{start}] > $now) && ($$classlist{$student}[$idx{end}] > $now) || ($$classlist{$student}[$idx{end}] == 0) || ($$classlist{$student}[$idx{end}] eq '')) { 4032: push(@{$$users{st}{$student}},'future'); 4033: $match = 1; 4034: } 4035: } 4036: if ($match && defined($userdata)) { 4037: $$userdata{$student} = $$classlist{$student}; 4038: } 4039: } 4040: } 4041: if ((@{$roles} > 0) && (@{$roles} ne "st")) { 4042: my @coursepersonnel = &Apache::lonnet::getkeys('nohist_userroles',$cdom,$cnum); 4043: foreach my $person (@coursepersonnel) { 4044: my $match = 0; 4045: my ($role,$user) = ($person =~ /^([^:]*):([^:]+:[^:]+)/); 4046: $user =~ s/:$//; 4047: if (($role) && (grep(/^\Q$role\E$/,@{$roles}))) { 4048: my ($uname,$udom,$usec) = split(/:/,$user); 4049: if ($usec ne '' && (ref($sections) eq 'ARRAY') && 4050: @{$sections} > 0) { 4051: unless(grep(/^\Q$usec\E$/,@{$sections})) { 4052: next; 4053: } 4054: } 4055: if ($uname ne '' && $udom ne '') { 4056: my $status = &check_user_status($udom,$uname,$cdom,$cnum,$role); 4057: foreach my $type (keys(%{$types})) { 4058: if ($status eq $type) { 4059: @{$$users{$role}{$user}} = $type; 4060: $match = 1; 4061: } 4062: } 4063: if ($match && defined($userdata) && 4064: !exists($$userdata{$uname.':'.$udom})) { 4065: &get_user_info($udom,$uname,\%idx,$userdata); 4066: } 4067: } 4068: } 4069: } 4070: if (grep(/^ow$/,@{$roles})) { 4071: if ((defined($cdom)) && (defined($cnum))) { 4072: my %csettings = &Apache::lonnet::get('environment',['internal.courseowner'],$cdom,$cnum); 4073: if ( defined($csettings{'internal.courseowner'}) ) { 4074: my $owner = $csettings{'internal.courseowner'}; 4075: @{$$users{'ow'}{$owner.':'.$cdom}} = 'any'; 4076: if (defined($userdata) && 4077: !exists($$userdata{$owner.':'.$cdom})) { 4078: &get_user_info($cdom,$owner,\%idx,$userdata); 4079: } 4080: } 4081: } 4082: } 4083: } 4084: return; 4085: } 4086: 4087: sub get_user_info { 4088: my ($udom,$uname,$idx,$userdata) = @_; 4089: $$userdata{$uname.':'.$udom}[$$idx{fullname}] = 4090: &plainname($uname,$udom,'lastname'); 4091: $$userdata{$uname.':'.$udom}[$$idx{uname}] = $uname; 4092: $$userdata{$uname.':'.$udom}[$$idx{udom}] = $udom; 4093: return; 4094: } 4095: 4096: =pod 4097: 4098: =item * get_unprocessed_cgi($query,$possible_names) 4099: 4100: Modify the %env hash to contain unprocessed CGI form parameters held in 4101: $query. The parameters listed in $possible_names (an array reference), 4102: will be set in $env{'form.name'} if they do not already exist. 4103: 4104: Typically called with $ENV{'QUERY_STRING'} as the first parameter. 4105: $possible_names is an ref to an array of form element names. As an example: 4106: get_unprocessed_cgi($ENV{'QUERY_STRING'},['uname','udom']); 4107: will result in $env{'form.uname'} and $env{'form.udom'} being set. 4108: 4109: =cut 4110: 4111: sub get_unprocessed_cgi { 4112: my ($query,$possible_names)= @_; 4113: # $Apache::lonxml::debug=1; 4114: foreach my $pair (split(/&/,$query)) { 4115: my ($name, $value) = split(/=/,$pair); 4116: $name = &unescape($name); 4117: if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) { 4118: $value =~ tr/+/ /; 4119: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; 4120: unless (defined($env{'form.'.$name})) { &add_to_env('form.'.$name,$value) }; 4121: } 4122: } 4123: } 4124: 4125: =pod 4126: 4127: =item * cacheheader() 4128: 4129: returns cache-controlling header code 4130: 4131: =cut 4132: 4133: sub cacheheader { 4134: unless ($env{'request.method'} eq 'GET') { return ''; } 4135: my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime); 4136: my $output .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" /> 4137: <meta HTTP-EQUIV="Cache-control" CONTENT="no-cache" /> 4138: <meta HTTP-EQUIV="Pragma" CONTENT="no-cache" />'; 4139: return $output; 4140: } 4141: 4142: =pod 4143: 4144: =item * no_cache($r) 4145: 4146: specifies header code to not have cache 4147: 4148: =cut 4149: 4150: sub no_cache { 4151: my ($r) = @_; 4152: if ($ENV{'REQUEST_METHOD'} ne 'GET' && 4153: $env{'request.method'} ne 'GET') { return ''; } 4154: my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime(time)); 4155: $r->no_cache(1); 4156: $r->header_out("Expires" => $date); 4157: $r->header_out("Pragma" => "no-cache"); 4158: } 4159: 4160: sub content_type { 4161: my ($r,$type,$charset) = @_; 4162: if ($r) { 4163: # Note that printout.pl calls this with undef for $r. 4164: &no_cache($r); 4165: } 4166: if ($env{'browser.mathml'} && $type eq 'text/html') { $type='text/xml'; } 4167: unless ($charset) { 4168: $charset=&Apache::lonlocal::current_encoding; 4169: } 4170: if ($charset) { $type.='; charset='.$charset; } 4171: if ($r) { 4172: $r->content_type($type); 4173: } else { 4174: print("Content-type: $type\n\n"); 4175: } 4176: } 4177: 4178: =pod 4179: 4180: =item * add_to_env($name,$value) 4181: 4182: adds $name to the %env hash with value 4183: $value, if $name already exists, the entry is converted to an array 4184: reference and $value is added to the array. 4185: 4186: =cut 4187: 4188: sub add_to_env { 4189: my ($name,$value)=@_; 4190: if (defined($env{$name})) { 4191: if (ref($env{$name})) { 4192: #already have multiple values 4193: push(@{ $env{$name} },$value); 4194: } else { 4195: #first time seeing multiple values, convert hash entry to an arrayref 4196: my $first=$env{$name}; 4197: undef($env{$name}); 4198: push(@{ $env{$name} },$first,$value); 4199: } 4200: } else { 4201: $env{$name}=$value; 4202: } 4203: } 4204: 4205: =pod 4206: 4207: =item * get_env_multiple($name) 4208: 4209: gets $name from the %env hash, it seemlessly handles the cases where multiple 4210: values may be defined and end up as an array ref. 4211: 4212: returns an array of values 4213: 4214: =cut 4215: 4216: sub get_env_multiple { 4217: my ($name) = @_; 4218: my @values; 4219: if (defined($env{$name})) { 4220: # exists is it an array 4221: if (ref($env{$name})) { 4222: @values=@{ $env{$name} }; 4223: } else { 4224: $values[0]=$env{$name}; 4225: } 4226: } 4227: return(@values); 4228: } 4229: 4230: 4231: =pod 4232: 4233: =back 4234: 4235: =head1 CSV Upload/Handling functions 4236: 4237: =over 4 4238: 4239: =item * upfile_store($r) 4240: 4241: Store uploaded file, $r should be the HTTP Request object, 4242: needs $env{'form.upfile'} 4243: returns $datatoken to be put into hidden field 4244: 4245: =cut 4246: 4247: sub upfile_store { 4248: my $r=shift; 4249: $env{'form.upfile'}=~s/\r/\n/gs; 4250: $env{'form.upfile'}=~s/\f/\n/gs; 4251: $env{'form.upfile'}=~s/\n+/\n/gs; 4252: $env{'form.upfile'}=~s/\n+$//gs; 4253: 4254: my $datatoken=$env{'user.name'}.'_'.$env{'user.domain'}. 4255: '_enroll_'.$env{'request.course.id'}.'_'.time.'_'.$$; 4256: { 4257: my $datafile = $r->dir_config('lonDaemons'). 4258: '/tmp/'.$datatoken.'.tmp'; 4259: if ( open(my $fh,">$datafile") ) { 4260: print $fh $env{'form.upfile'}; 4261: close($fh); 4262: } 4263: } 4264: return $datatoken; 4265: } 4266: 4267: =pod 4268: 4269: =item * load_tmp_file($r) 4270: 4271: Load uploaded file from tmp, $r should be the HTTP Request object, 4272: needs $env{'form.datatoken'}, 4273: sets $env{'form.upfile'} to the contents of the file 4274: 4275: =cut 4276: 4277: sub load_tmp_file { 4278: my $r=shift; 4279: my @studentdata=(); 4280: { 4281: my $studentfile = $r->dir_config('lonDaemons'). 4282: '/tmp/'.$env{'form.datatoken'}.'.tmp'; 4283: if ( open(my $fh,"<$studentfile") ) { 4284: @studentdata=<$fh>; 4285: close($fh); 4286: } 4287: } 4288: $env{'form.upfile'}=join('',@studentdata); 4289: } 4290: 4291: =pod 4292: 4293: =item * upfile_record_sep() 4294: 4295: Separate uploaded file into records 4296: returns array of records, 4297: needs $env{'form.upfile'} and $env{'form.upfiletype'} 4298: 4299: =cut 4300: 4301: sub upfile_record_sep { 4302: if ($env{'form.upfiletype'} eq 'xml') { 4303: } else { 4304: my @records; 4305: foreach my $line (split(/\n/,$env{'form.upfile'})) { 4306: if ($line=~/^\s*$/) { next; } 4307: push(@records,$line); 4308: } 4309: return @records; 4310: } 4311: } 4312: 4313: =pod 4314: 4315: =item * record_sep($record) 4316: 4317: Separate a record into fields $record should be an item from the upfile_record_sep(), needs $env{'form.upfiletype'} 4318: 4319: =cut 4320: 4321: sub takeleft { 4322: my $index=shift; 4323: return substr('0000'.$index,-4,4); 4324: } 4325: 4326: sub record_sep { 4327: my $record=shift; 4328: my %components=(); 4329: if ($env{'form.upfiletype'} eq 'xml') { 4330: } elsif ($env{'form.upfiletype'} eq 'space') { 4331: my $i=0; 4332: foreach my $field (split(/\s+/,$record)) { 4333: $field=~s/^(\"|\')//; 4334: $field=~s/(\"|\')$//; 4335: $components{&takeleft($i)}=$field; 4336: $i++; 4337: } 4338: } elsif ($env{'form.upfiletype'} eq 'tab') { 4339: my $i=0; 4340: foreach my $field (split(/\t/,$record)) { 4341: $field=~s/^(\"|\')//; 4342: $field=~s/(\"|\')$//; 4343: $components{&takeleft($i)}=$field; 4344: $i++; 4345: } 4346: } else { 4347: my @allfields=split(/\,/,$record); 4348: my $i=0; 4349: my $j; 4350: for ($j=0;$j<=$#allfields;$j++) { 4351: my $field=$allfields[$j]; 4352: if ($field=~/^\s*(\"|\')/) { 4353: my $delimiter=$1; 4354: while (($field!~/$delimiter$/) && ($j<$#allfields)) { 4355: $j++; 4356: $field.=','.$allfields[$j]; 4357: } 4358: $field=~s/^\s*$delimiter//; 4359: $field=~s/$delimiter\s*$//; 4360: } 4361: $components{&takeleft($i)}=$field; 4362: $i++; 4363: } 4364: } 4365: return %components; 4366: } 4367: 4368: ###################################################### 4369: ###################################################### 4370: 4371: =pod 4372: 4373: =item * upfile_select_html() 4374: 4375: Return HTML code to select a file from the users machine and specify 4376: the file type. 4377: 4378: =cut 4379: 4380: ###################################################### 4381: ###################################################### 4382: sub upfile_select_html { 4383: my %Types = ( 4384: csv => &mt('CSV (comma separated values, spreadsheet)'), 4385: space => &mt('Space separated'), 4386: tab => &mt('Tabulator separated'), 4387: # xml => &mt('HTML/XML'), 4388: ); 4389: my $Str = '<input type="file" name="upfile" size="50" />'. 4390: '<br />Type: <select name="upfiletype">'; 4391: foreach my $type (sort(keys(%Types))) { 4392: $Str .= '<option value="'.$type.'" >'.$Types{$type}."</option>\n"; 4393: } 4394: $Str .= "</select>\n"; 4395: return $Str; 4396: } 4397: 4398: sub get_samples { 4399: my ($records,$toget) = @_; 4400: my @samples=({}); 4401: my $got=0; 4402: foreach my $rec (@$records) { 4403: my %temp = &record_sep($rec); 4404: if (! grep(/\S/, values(%temp))) { next; } 4405: if (%temp) { 4406: $samples[$got]=\%temp; 4407: $got++; 4408: if ($got == $toget) { last; } 4409: } 4410: } 4411: return \@samples; 4412: } 4413: 4414: ###################################################### 4415: ###################################################### 4416: 4417: =pod 4418: 4419: =item * csv_print_samples($r,$records) 4420: 4421: Prints a table of sample values from each column uploaded $r is an 4422: Apache Request ref, $records is an arrayref from 4423: &Apache::loncommon::upfile_record_sep 4424: 4425: =cut 4426: 4427: ###################################################### 4428: ###################################################### 4429: sub csv_print_samples { 4430: my ($r,$records) = @_; 4431: my $samples = &get_samples($records,3); 4432: 4433: $r->print(&mt('Samples').'<br /><table border="2"><tr>'); 4434: foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) { 4435: $r->print('<th>'.&mt('Column [_1]',($sample+1)).'</th>'); } 4436: $r->print('</tr>'); 4437: foreach my $hash (@$samples) { 4438: $r->print('<tr>'); 4439: foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) { 4440: $r->print('<td>'); 4441: if (defined($$hash{$sample})) { $r->print($$hash{$sample}); } 4442: $r->print('</td>'); 4443: } 4444: $r->print('</tr>'); 4445: } 4446: $r->print('</tr></table><br />'."\n"); 4447: } 4448: 4449: ###################################################### 4450: ###################################################### 4451: 4452: =pod 4453: 4454: =item * csv_print_select_table($r,$records,$d) 4455: 4456: Prints a table to create associations between values and table columns. 4457: 4458: $r is an Apache Request ref, 4459: $records is an arrayref from &Apache::loncommon::upfile_record_sep, 4460: $d is an array of 2 element arrays (internal name, displayed name,defaultcol) 4461: 4462: =cut 4463: 4464: ###################################################### 4465: ###################################################### 4466: sub csv_print_select_table { 4467: my ($r,$records,$d) = @_; 4468: my $i=0; 4469: my $samples = &get_samples($records,1); 4470: $r->print(&mt('Associate columns with student attributes.')."\n". 4471: '<table border="2"><tr>'. 4472: '<th>'.&mt('Attribute').'</th>'. 4473: '<th>'.&mt('Column').'</th></tr>'."\n"); 4474: foreach my $array_ref (@$d) { 4475: my ($value,$display,$defaultcol)=@{ $array_ref }; 4476: $r->print('<tr><td>'.$display.'</td>'); 4477: 4478: $r->print('<td><select name=f'.$i. 4479: ' onchange="javascript:flip(this.form,'.$i.');">'); 4480: $r->print('<option value="none"></option>'); 4481: foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) { 4482: $r->print('<option value="'.$sample.'"'. 4483: ($sample eq $defaultcol ? ' selected="selected" ' : ''). 4484: '>Column '.($sample+1).'</option>'); 4485: } 4486: $r->print('</select></td></tr>'."\n"); 4487: $i++; 4488: } 4489: $i--; 4490: return $i; 4491: } 4492: 4493: ###################################################### 4494: ###################################################### 4495: 4496: =pod 4497: 4498: =item * csv_samples_select_table($r,$records,$d) 4499: 4500: Prints a table of sample values from the upload and can make associate samples to internal names. 4501: 4502: $r is an Apache Request ref, 4503: $records is an arrayref from &Apache::loncommon::upfile_record_sep, 4504: $d is an array of 2 element arrays (internal name, displayed name) 4505: 4506: =cut 4507: 4508: ###################################################### 4509: ###################################################### 4510: sub csv_samples_select_table { 4511: my ($r,$records,$d) = @_; 4512: my $i=0; 4513: # 4514: my $samples = &get_samples($records,3); 4515: $r->print('<table border=2><tr><th>'. 4516: &mt('Field').'</th><th>'.&mt('Samples').'</th></tr>'); 4517: 4518: foreach my $key (sort(keys(%{ $samples->[0] }))) { 4519: $r->print('<tr><td><select name="f'.$i.'"'. 4520: ' onchange="javascript:flip(this.form,'.$i.');">'); 4521: foreach my $option (@$d) { 4522: my ($value,$display,$defaultcol)=@{ $option }; 4523: $r->print('<option value="'.$value.'"'. 4524: ($i eq $defaultcol ? ' selected="selected" ':'').'>'. 4525: $display.'</option>'); 4526: } 4527: $r->print('</select></td><td>'); 4528: foreach my $line (0..2) { 4529: if (defined($samples->[$line]{$key})) { 4530: $r->print($samples->[$line]{$key}."<br />\n"); 4531: } 4532: } 4533: $r->print('</td></tr>'); 4534: $i++; 4535: } 4536: $i--; 4537: return($i); 4538: } 4539: 4540: ###################################################### 4541: ###################################################### 4542: 4543: =pod 4544: 4545: =item clean_excel_name($name) 4546: 4547: Returns a replacement for $name which does not contain any illegal characters. 4548: 4549: =cut 4550: 4551: ###################################################### 4552: ###################################################### 4553: sub clean_excel_name { 4554: my ($name) = @_; 4555: $name =~ s/[:\*\?\/\\]//g; 4556: if (length($name) > 31) { 4557: $name = substr($name,0,31); 4558: } 4559: return $name; 4560: } 4561: 4562: =pod 4563: 4564: =item * check_if_partid_hidden($id,$symb,$udom,$uname) 4565: 4566: Returns either 1 or undef 4567: 4568: 1 if the part is to be hidden, undef if it is to be shown 4569: 4570: Arguments are: 4571: 4572: $id the id of the part to be checked 4573: $symb, optional the symb of the resource to check 4574: $udom, optional the domain of the user to check for 4575: $uname, optional the username of the user to check for 4576: 4577: =cut 4578: 4579: sub check_if_partid_hidden { 4580: my ($id,$symb,$udom,$uname) = @_; 4581: my $hiddenparts=&Apache::lonnet::EXT('resource.0.hiddenparts', 4582: $symb,$udom,$uname); 4583: my $truth=1; 4584: #if the string starts with !, then the list is the list to show not hide 4585: if ($hiddenparts=~s/^\s*!//) { $truth=undef; } 4586: my @hiddenlist=split(/,/,$hiddenparts); 4587: foreach my $checkid (@hiddenlist) { 4588: if ($checkid =~ /^\s*\Q$id\E\s*$/) { return $truth; } 4589: } 4590: return !$truth; 4591: } 4592: 4593: 4594: ############################################################ 4595: ############################################################ 4596: 4597: =pod 4598: 4599: =back 4600: 4601: =head1 cgi-bin script and graphing routines 4602: 4603: =over 4 4604: 4605: =item get_cgi_id 4606: 4607: Inputs: none 4608: 4609: Returns an id which can be used to pass environment variables 4610: to various cgi-bin scripts. These environment variables will 4611: be removed from the users environment after a given time by 4612: the routine &Apache::lonnet::transfer_profile_to_env. 4613: 4614: =cut 4615: 4616: ############################################################ 4617: ############################################################ 4618: my $uniq=0; 4619: sub get_cgi_id { 4620: $uniq=($uniq+1)%100000; 4621: return (time.'_'.$$.'_'.$uniq); 4622: } 4623: 4624: ############################################################ 4625: ############################################################ 4626: 4627: =pod 4628: 4629: =item DrawBarGraph 4630: 4631: Facilitates the plotting of data in a (stacked) bar graph. 4632: Puts plot definition data into the users environment in order for 4633: graph.png to plot it. Returns an <img> tag for the plot. 4634: The bars on the plot are labeled '1','2',...,'n'. 4635: 4636: Inputs: 4637: 4638: =over 4 4639: 4640: =item $Title: string, the title of the plot 4641: 4642: =item $xlabel: string, text describing the X-axis of the plot 4643: 4644: =item $ylabel: string, text describing the Y-axis of the plot 4645: 4646: =item $Max: scalar, the maximum Y value to use in the plot 4647: If $Max is < any data point, the graph will not be rendered. 4648: 4649: =item $colors: array ref holding the colors to be used for the data sets when 4650: they are plotted. If undefined, default values will be used. 4651: 4652: =item $labels: array ref holding the labels to use on the x-axis for the bars. 4653: 4654: =item @Values: An array of array references. Each array reference holds data 4655: to be plotted in a stacked bar chart. 4656: 4657: =item If the final element of @Values is a hash reference the key/value 4658: pairs will be added to the graph definition. 4659: 4660: =back 4661: 4662: Returns: 4663: 4664: An <img> tag which references graph.png and the appropriate identifying 4665: information for the plot. 4666: 4667: =cut 4668: 4669: ############################################################ 4670: ############################################################ 4671: sub DrawBarGraph { 4672: my ($Title,$xlabel,$ylabel,$Max,$colors,$labels,@Values)=@_; 4673: # 4674: if (! defined($colors)) { 4675: $colors = ['#33ff00', 4676: '#0033cc', '#990000', '#aaaa66', '#663399', '#ff9933', 4677: '#66ccff', '#ff9999', '#cccc33', '#660000', '#33cc66', 4678: ]; 4679: } 4680: my $extra_settings = {}; 4681: if (ref($Values[-1]) eq 'HASH') { 4682: $extra_settings = pop(@Values); 4683: } 4684: # 4685: my $identifier = &get_cgi_id(); 4686: my $id = 'cgi.'.$identifier; 4687: if (! @Values || ref($Values[0]) ne 'ARRAY') { 4688: return ''; 4689: } 4690: # 4691: my @Labels; 4692: if (defined($labels)) { 4693: @Labels = @$labels; 4694: } else { 4695: for (my $i=0;$i<@{$Values[0]};$i++) { 4696: push (@Labels,$i+1); 4697: } 4698: } 4699: # 4700: my $NumBars = scalar(@{$Values[0]}); 4701: if ($NumBars < scalar(@Labels)) { $NumBars = scalar(@Labels); } 4702: my %ValuesHash; 4703: my $NumSets=1; 4704: foreach my $array (@Values) { 4705: next if (! ref($array)); 4706: $ValuesHash{$id.'.data.'.$NumSets++} = 4707: join(',',@$array); 4708: } 4709: # 4710: my ($height,$width,$xskip,$bar_width) = (200,120,1,15); 4711: if ($NumBars < 3) { 4712: $width = 120+$NumBars*32; 4713: $xskip = 1; 4714: $bar_width = 30; 4715: } elsif ($NumBars < 5) { 4716: $width = 120+$NumBars*20; 4717: $xskip = 1; 4718: $bar_width = 20; 4719: } elsif ($NumBars < 10) { 4720: $width = 120+$NumBars*15; 4721: $xskip = 1; 4722: $bar_width = 15; 4723: } elsif ($NumBars <= 25) { 4724: $width = 120+$NumBars*11; 4725: $xskip = 5; 4726: $bar_width = 8; 4727: } elsif ($NumBars <= 50) { 4728: $width = 120+$NumBars*8; 4729: $xskip = 5; 4730: $bar_width = 4; 4731: } else { 4732: $width = 120+$NumBars*8; 4733: $xskip = 5; 4734: $bar_width = 4; 4735: } 4736: # 4737: $Max = 1 if ($Max < 1); 4738: if ( int($Max) < $Max ) { 4739: $Max++; 4740: $Max = int($Max); 4741: } 4742: $Title = '' if (! defined($Title)); 4743: $xlabel = '' if (! defined($xlabel)); 4744: $ylabel = '' if (! defined($ylabel)); 4745: $ValuesHash{$id.'.title'} = &escape($Title); 4746: $ValuesHash{$id.'.xlabel'} = &escape($xlabel); 4747: $ValuesHash{$id.'.ylabel'} = &escape($ylabel); 4748: $ValuesHash{$id.'.y_max_value'} = $Max; 4749: $ValuesHash{$id.'.NumBars'} = $NumBars; 4750: $ValuesHash{$id.'.NumSets'} = $NumSets; 4751: $ValuesHash{$id.'.PlotType'} = 'bar'; 4752: $ValuesHash{$id.'.Colors'} = join(',',@{$colors}); 4753: $ValuesHash{$id.'.height'} = $height; 4754: $ValuesHash{$id.'.width'} = $width; 4755: $ValuesHash{$id.'.xskip'} = $xskip; 4756: $ValuesHash{$id.'.bar_width'} = $bar_width; 4757: $ValuesHash{$id.'.labels'} = join(',',@Labels); 4758: # 4759: # Deal with other parameters 4760: while (my ($key,$value) = each(%$extra_settings)) { 4761: $ValuesHash{$id.'.'.$key} = $value; 4762: } 4763: # 4764: &Apache::lonnet::appenv(%ValuesHash); 4765: return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />'; 4766: } 4767: 4768: ############################################################ 4769: ############################################################ 4770: 4771: =pod 4772: 4773: =item DrawXYGraph 4774: 4775: Facilitates the plotting of data in an XY graph. 4776: Puts plot definition data into the users environment in order for 4777: graph.png to plot it. Returns an <img> tag for the plot. 4778: 4779: Inputs: 4780: 4781: =over 4 4782: 4783: =item $Title: string, the title of the plot 4784: 4785: =item $xlabel: string, text describing the X-axis of the plot 4786: 4787: =item $ylabel: string, text describing the Y-axis of the plot 4788: 4789: =item $Max: scalar, the maximum Y value to use in the plot 4790: If $Max is < any data point, the graph will not be rendered. 4791: 4792: =item $colors: Array ref containing the hex color codes for the data to be 4793: plotted in. If undefined, default values will be used. 4794: 4795: =item $Xlabels: Array ref containing the labels to be used for the X-axis. 4796: 4797: =item $Ydata: Array ref containing Array refs. 4798: Each of the contained arrays will be plotted as a separate curve. 4799: 4800: =item %Values: hash indicating or overriding any default values which are 4801: passed to graph.png. 4802: Possible values are: width, xskip, x_ticks, x_tick_offset, among others. 4803: 4804: =back 4805: 4806: Returns: 4807: 4808: An <img> tag which references graph.png and the appropriate identifying 4809: information for the plot. 4810: 4811: =cut 4812: 4813: ############################################################ 4814: ############################################################ 4815: sub DrawXYGraph { 4816: my ($Title,$xlabel,$ylabel,$Max,$colors,$Xlabels,$Ydata,%Values)=@_; 4817: # 4818: # Create the identifier for the graph 4819: my $identifier = &get_cgi_id(); 4820: my $id = 'cgi.'.$identifier; 4821: # 4822: $Title = '' if (! defined($Title)); 4823: $xlabel = '' if (! defined($xlabel)); 4824: $ylabel = '' if (! defined($ylabel)); 4825: my %ValuesHash = 4826: ( 4827: $id.'.title' => &escape($Title), 4828: $id.'.xlabel' => &escape($xlabel), 4829: $id.'.ylabel' => &escape($ylabel), 4830: $id.'.y_max_value'=> $Max, 4831: $id.'.labels' => join(',',@$Xlabels), 4832: $id.'.PlotType' => 'XY', 4833: ); 4834: # 4835: if (defined($colors) && ref($colors) eq 'ARRAY') { 4836: $ValuesHash{$id.'.Colors'} = join(',',@{$colors}); 4837: } 4838: # 4839: if (! ref($Ydata) || ref($Ydata) ne 'ARRAY') { 4840: return ''; 4841: } 4842: my $NumSets=1; 4843: foreach my $array (@{$Ydata}){ 4844: next if (! ref($array)); 4845: $ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array); 4846: } 4847: $ValuesHash{$id.'.NumSets'} = $NumSets-1; 4848: # 4849: # Deal with other parameters 4850: while (my ($key,$value) = each(%Values)) { 4851: $ValuesHash{$id.'.'.$key} = $value; 4852: } 4853: # 4854: &Apache::lonnet::appenv(%ValuesHash); 4855: return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />'; 4856: } 4857: 4858: ############################################################ 4859: ############################################################ 4860: 4861: =pod 4862: 4863: =item DrawXYYGraph 4864: 4865: Facilitates the plotting of data in an XY graph with two Y axes. 4866: Puts plot definition data into the users environment in order for 4867: graph.png to plot it. Returns an <img> tag for the plot. 4868: 4869: Inputs: 4870: 4871: =over 4 4872: 4873: =item $Title: string, the title of the plot 4874: 4875: =item $xlabel: string, text describing the X-axis of the plot 4876: 4877: =item $ylabel: string, text describing the Y-axis of the plot 4878: 4879: =item $colors: Array ref containing the hex color codes for the data to be 4880: plotted in. If undefined, default values will be used. 4881: 4882: =item $Xlabels: Array ref containing the labels to be used for the X-axis. 4883: 4884: =item $Ydata1: The first data set 4885: 4886: =item $Min1: The minimum value of the left Y-axis 4887: 4888: =item $Max1: The maximum value of the left Y-axis 4889: 4890: =item $Ydata2: The second data set 4891: 4892: =item $Min2: The minimum value of the right Y-axis 4893: 4894: =item $Max2: The maximum value of the left Y-axis 4895: 4896: =item %Values: hash indicating or overriding any default values which are 4897: passed to graph.png. 4898: Possible values are: width, xskip, x_ticks, x_tick_offset, among others. 4899: 4900: =back 4901: 4902: Returns: 4903: 4904: An <img> tag which references graph.png and the appropriate identifying 4905: information for the plot. 4906: 4907: =cut 4908: 4909: ############################################################ 4910: ############################################################ 4911: sub DrawXYYGraph { 4912: my ($Title,$xlabel,$ylabel,$colors,$Xlabels,$Ydata1,$Min1,$Max1, 4913: $Ydata2,$Min2,$Max2,%Values)=@_; 4914: # 4915: # Create the identifier for the graph 4916: my $identifier = &get_cgi_id(); 4917: my $id = 'cgi.'.$identifier; 4918: # 4919: $Title = '' if (! defined($Title)); 4920: $xlabel = '' if (! defined($xlabel)); 4921: $ylabel = '' if (! defined($ylabel)); 4922: my %ValuesHash = 4923: ( 4924: $id.'.title' => &escape($Title), 4925: $id.'.xlabel' => &escape($xlabel), 4926: $id.'.ylabel' => &escape($ylabel), 4927: $id.'.labels' => join(',',@$Xlabels), 4928: $id.'.PlotType' => 'XY', 4929: $id.'.NumSets' => 2, 4930: $id.'.two_axes' => 1, 4931: $id.'.y1_max_value' => $Max1, 4932: $id.'.y1_min_value' => $Min1, 4933: $id.'.y2_max_value' => $Max2, 4934: $id.'.y2_min_value' => $Min2, 4935: ); 4936: # 4937: if (defined($colors) && ref($colors) eq 'ARRAY') { 4938: $ValuesHash{$id.'.Colors'} = join(',',@{$colors}); 4939: } 4940: # 4941: if (! ref($Ydata1) || ref($Ydata1) ne 'ARRAY' || 4942: ! ref($Ydata2) || ref($Ydata2) ne 'ARRAY'){ 4943: return ''; 4944: } 4945: my $NumSets=1; 4946: foreach my $array ($Ydata1,$Ydata2){ 4947: next if (! ref($array)); 4948: $ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array); 4949: } 4950: # 4951: # Deal with other parameters 4952: while (my ($key,$value) = each(%Values)) { 4953: $ValuesHash{$id.'.'.$key} = $value; 4954: } 4955: # 4956: &Apache::lonnet::appenv(%ValuesHash); 4957: return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />'; 4958: } 4959: 4960: ############################################################ 4961: ############################################################ 4962: 4963: =pod 4964: 4965: =back 4966: 4967: =head1 Statistics helper routines? 4968: 4969: Bad place for them but what the hell. 4970: 4971: =over 4 4972: 4973: =item &chartlink 4974: 4975: Returns a link to the chart for a specific student. 4976: 4977: Inputs: 4978: 4979: =over 4 4980: 4981: =item $linktext: The text of the link 4982: 4983: =item $sname: The students username 4984: 4985: =item $sdomain: The students domain 4986: 4987: =back 4988: 4989: =back 4990: 4991: =cut 4992: 4993: ############################################################ 4994: ############################################################ 4995: sub chartlink { 4996: my ($linktext, $sname, $sdomain) = @_; 4997: my $link = '<a href="/adm/statistics?reportSelected=student_assessment'. 4998: '&SelectedStudent='.&escape($sname.':'.$sdomain). 4999: '&chartoutputmode='.HTML::Entities::encode('html, with all links'). 5000: '">'.$linktext.'</a>'; 5001: } 5002: 5003: ####################################################### 5004: ####################################################### 5005: 5006: =pod 5007: 5008: =head1 Course Environment Routines 5009: 5010: =over 4 5011: 5012: =item &restore_course_settings 5013: 5014: =item &store_course_settings 5015: 5016: Restores/Store indicated form parameters from the course environment. 5017: Will not overwrite existing values of the form parameters. 5018: 5019: Inputs: 5020: a scalar describing the data (e.g. 'chart', 'problem_analysis') 5021: 5022: a hash ref describing the data to be stored. For example: 5023: 5024: %Save_Parameters = ('Status' => 'scalar', 5025: 'chartoutputmode' => 'scalar', 5026: 'chartoutputdata' => 'scalar', 5027: 'Section' => 'array', 5028: 'StudentData' => 'array', 5029: 'Maps' => 'array'); 5030: 5031: Returns: both routines return nothing 5032: 5033: =cut 5034: 5035: ####################################################### 5036: ####################################################### 5037: sub store_course_settings { 5038: # save to the environment 5039: # appenv the same items, just to be safe 5040: my $courseid = $env{'request.course.id'}; 5041: my $udom = $env{'user.domain'}; 5042: my $uname = $env{'user.name'}; 5043: my ($prefix,$Settings) = @_; 5044: my %SaveHash; 5045: my %AppHash; 5046: while (my ($setting,$type) = each(%$Settings)) { 5047: my $basename = join('.','internal',$courseid,$prefix,$setting); 5048: my $envname = 'environment.'.$basename; 5049: if (exists($env{'form.'.$setting})) { 5050: # Save this value away 5051: if ($type eq 'scalar' && 5052: (! exists($env{$envname}) || 5053: $env{$envname} ne $env{'form.'.$setting})) { 5054: $SaveHash{$basename} = $env{'form.'.$setting}; 5055: $AppHash{$envname} = $env{'form.'.$setting}; 5056: } elsif ($type eq 'array') { 5057: my $stored_form; 5058: if (ref($env{'form.'.$setting})) { 5059: $stored_form = join(',', 5060: map { 5061: &escape($_); 5062: } sort(@{$env{'form.'.$setting}})); 5063: } else { 5064: $stored_form = 5065: &escape($env{'form.'.$setting}); 5066: } 5067: # Determine if the array contents are the same. 5068: if ($stored_form ne $env{$envname}) { 5069: $SaveHash{$basename} = $stored_form; 5070: $AppHash{$envname} = $stored_form; 5071: } 5072: } 5073: } 5074: } 5075: my $put_result = &Apache::lonnet::put('environment',\%SaveHash, 5076: $udom,$uname); 5077: if ($put_result !~ /^(ok|delayed)/) { 5078: &Apache::lonnet::logthis('unable to save form parameters, '. 5079: 'got error:'.$put_result); 5080: } 5081: # Make sure these settings stick around in this session, too 5082: &Apache::lonnet::appenv(%AppHash); 5083: return; 5084: } 5085: 5086: sub restore_course_settings { 5087: my $courseid = $env{'request.course.id'}; 5088: my ($prefix,$Settings) = @_; 5089: while (my ($setting,$type) = each(%$Settings)) { 5090: next if (exists($env{'form.'.$setting})); 5091: my $envname = 'environment.internal.'.$courseid.'.'.$prefix. 5092: '.'.$setting; 5093: if (exists($env{$envname})) { 5094: if ($type eq 'scalar') { 5095: $env{'form.'.$setting} = $env{$envname}; 5096: } elsif ($type eq 'array') { 5097: $env{'form.'.$setting} = [ 5098: map { 5099: &unescape($_); 5100: } split(',',$env{$envname}) 5101: ]; 5102: } 5103: } 5104: } 5105: } 5106: 5107: ############################################################ 5108: ############################################################ 5109: 5110: sub propath { 5111: my ($udom,$uname)=@_; 5112: $udom=~s/\W//g; 5113: $uname=~s/\W//g; 5114: my $subdir=$uname.'__'; 5115: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; 5116: my $proname="$Apache::lonnet::perlvar{'lonUsersDir'}/$udom/$subdir/$uname"; 5117: return $proname; 5118: } 5119: 5120: sub icon { 5121: my ($file)=@_; 5122: my $curfext = (split(/\./,$file))[-1]; 5123: my $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/unknown.gif'; 5124: my $embstyle = &Apache::loncommon::fileembstyle($curfext); 5125: if (!(!defined($embstyle) || $embstyle eq 'unk' || $embstyle eq 'hdn')) { 5126: if (-e $Apache::lonnet::perlvar{'lonDocRoot'}.'/'. 5127: $Apache::lonnet::perlvar{'lonIconsURL'}.'/'. 5128: $curfext.".gif") { 5129: $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/'. 5130: $curfext.".gif"; 5131: } 5132: } 5133: return &lonhttpdurl($iconname); 5134: } 5135: 5136: sub lonhttpdurl { 5137: my ($url)=@_; 5138: my $lonhttpd_port=$Apache::lonnet::perlvar{'lonhttpdPort'}; 5139: if (!defined($lonhttpd_port)) { $lonhttpd_port='8080'; } 5140: return 'http://'.$ENV{'SERVER_NAME'}.':'.$lonhttpd_port.$url; 5141: } 5142: 5143: sub connection_aborted { 5144: my ($r)=@_; 5145: $r->print(" ");$r->rflush(); 5146: my $c = $r->connection; 5147: return $c->aborted(); 5148: } 5149: 5150: # Escapes strings that may have embedded 's that will be put into 5151: # strings as 'strings'. 5152: sub escape_single { 5153: my ($input) = @_; 5154: $input =~ s/\\/\\\\/g; # Escape the \'s..(must be first)> 5155: $input =~ s/\'/\\\'/g; # Esacpe the 's.... 5156: return $input; 5157: } 5158: 5159: # Same as escape_single, but escape's "'s This 5160: # can be used for "strings" 5161: sub escape_double { 5162: my ($input) = @_; 5163: $input =~ s/\\/\\\\/g; # Escape the /'s..(must be first)> 5164: $input =~ s/\"/\\\"/g; # Esacpe the "s.... 5165: return $input; 5166: } 5167: 5168: # Escapes the last element of a full URL. 5169: sub escape_url { 5170: my ($url) = @_; 5171: my @urlslices = split(/\//, $url,-1); 5172: my $lastitem = &escape(pop(@urlslices)); 5173: return join('/',@urlslices).'/'.$lastitem; 5174: } 5175: =pod 5176: 5177: =back 5178: 5179: =cut 5180: 5181: 1; 5182: __END__; 5183: