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

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

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