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