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

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

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