Annotation of loncom/interface/loncommon.pm, revision 1.445

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

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