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

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

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