File:  [LON-CAPA] / loncom / interface / loncommon.pm
Revision 1.251: download - view: text, annotated - select for diffs
Fri Feb 25 04:56:05 2005 UTC (19 years, 3 months ago) by albertel
Branches: MAIN
CVS tags: HEAD
- creation of a routine for </body>, 3 replaced 189 more to go

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

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>