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