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

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

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