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

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

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