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

1.10      albertel    1: # The LearningOnline Network with CAPA
1.1       albertel    2: # a pile of common routines
1.10      albertel    3: #
1.564.2.7! albertel    4: # $Id: loncommon.pm,v 1.564.2.6 2007/09/04 23:59:03 albertel Exp $
1.10      albertel    5: #
                      6: # Copyright Michigan State University Board of Trustees
                      7: #
                      8: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
                      9: #
                     10: # LON-CAPA is free software; you can redistribute it and/or modify
                     11: # it under the terms of the GNU General Public License as published by
                     12: # the Free Software Foundation; either version 2 of the License, or
                     13: # (at your option) any later version.
                     14: #
                     15: # LON-CAPA is distributed in the hope that it will be useful,
                     16: # but WITHOUT ANY WARRANTY; without even the implied warranty of
                     17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     18: # GNU General Public License for more details.
                     19: #
                     20: # You should have received a copy of the GNU General Public License
                     21: # along with LON-CAPA; if not, write to the Free Software
                     22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
                     23: #
                     24: # /home/httpd/html/adm/gpl.txt
                     25: #
                     26: # http://www.lon-capa.org/
                     27: #
1.1       albertel   28: 
                     29: # Makes a table out of the previous attempts
1.2       albertel   30: # Inputs result_from_symbread, user, domain, course_id
1.16      harris41   31: # Reads in non-network-related .tab files
1.1       albertel   32: 
1.35      matthew    33: # POD header:
                     34: 
1.45      matthew    35: =pod
                     36: 
1.35      matthew    37: =head1 NAME
                     38: 
                     39: Apache::loncommon - pile of common routines
                     40: 
                     41: =head1 SYNOPSIS
                     42: 
1.112     bowersj2   43: Common routines for manipulating connections, student answers,
                     44:     domains, common Javascript fragments, etc.
1.35      matthew    45: 
1.112     bowersj2   46: =head1 OVERVIEW
1.35      matthew    47: 
1.112     bowersj2   48: A collection of commonly used subroutines that don't have a natural
                     49: home anywhere else. This collection helps remove
1.35      matthew    50: redundancy from other modules and increase efficiency of memory usage.
                     51: 
                     52: =cut 
                     53: 
                     54: # End of POD header
1.1       albertel   55: package Apache::loncommon;
                     56: 
                     57: use strict;
1.258     albertel   58: use Apache::lonnet;
1.46      matthew    59: use GDBM_File;
1.51      www        60: use POSIX qw(strftime mktime);
1.82      www        61: use Apache::lonmenu();
1.498     albertel   62: use Apache::lonenc();
1.117     www        63: use Apache::lonlocal;
1.139     matthew    64: use HTML::Entities;
1.334     albertel   65: use Apache::lonhtmlcommon();
                     66: use Apache::loncoursedata();
1.344     albertel   67: use Apache::lontexconvert();
1.444     albertel   68: use Apache::lonclonecourse();
1.479     albertel   69: use LONCAPA qw(:DEFAULT :match);
1.117     www        70: 
1.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.330     albertel 3461: 
1.438     albertel 3462:     my $extra_body_attr = &make_attr_string($forcereg,\%design);
1.329     albertel 3463: 
1.101     www      3464: # construct main body tag
1.359     albertel 3465:     my $bodytag = "<body $extra_body_attr>".
1.562     albertel 3466: 	&Apache::lontexconvert::init_math_support($args->{'inherit_jsmath'});
1.252     albertel 3467: 
1.530     albertel 3468:     if ($bodyonly) {
1.60      matthew  3469:         return $bodytag;
1.258     albertel 3470:     } elsif ($env{'browser.interface'} eq 'textual') {
1.95      www      3471: # Accessibility
1.224     raeburn  3472:           
1.337     albertel 3473: 	$bodytag.=&Apache::lonmenu::menubuttons($forcereg,$forcereg);
1.338     albertel 3474: 	if (!$notitle) {
1.337     albertel 3475: 	    $bodytag.='<h1>LON-CAPA: '.$title.'</h1>';
                   3476: 	}
                   3477: 	return $bodytag;
1.359     albertel 3478:     }
                   3479: 
1.410     albertel 3480:     my $name = &plainname($env{'user.name'},$env{'user.domain'});
1.433     albertel 3481:     if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
                   3482: 	undef($role);
1.434     albertel 3483:     } else {
                   3484: 	$name = &aboutmewrapper($name,$env{'user.name'},$env{'user.domain'});
1.433     albertel 3485:     }
1.359     albertel 3486:     
                   3487:     my $roleinfo=(<<ENDROLE);
                   3488: <td class="LC_title_bar_who">
                   3489: <div class="LC_title_bar_name">
1.410     albertel 3490:     $name
1.361     albertel 3491:     &nbsp;
1.359     albertel 3492: </div>
                   3493: <div class="LC_title_bar_role">
1.361     albertel 3494: $role&nbsp;
1.359     albertel 3495: </div>
                   3496: <div class="LC_title_bar_realm">
1.361     albertel 3497: $realm&nbsp;
1.359     albertel 3498: </div>
1.206     albertel 3499: </td>
                   3500: ENDROLE
1.235     raeburn  3501: 
1.359     albertel 3502:     my $titleinfo = '<span class="LC_title_bar_title">'.$title.'</span>';
                   3503:     if ($customtitle) {
                   3504:         $titleinfo = $customtitle;
                   3505:     }
                   3506:     #
                   3507:     # Extra info if you are the DC
                   3508:     my $dc_info = '';
                   3509:     if ($env{'user.adv'} && exists($env{'user.role.dc./'.
                   3510:                         $env{'course.'.$env{'request.course.id'}.
                   3511:                                  '.domain'}.'/'})) {
                   3512:         my $cid = $env{'request.course.id'};
                   3513:         $dc_info.= $cid.' '.$env{'course.'.$cid.'.internal.coursecode'};
1.380     www      3514:         $dc_info =~ s/\s+$//;
1.359     albertel 3515:         $dc_info = '('.$dc_info.')';
                   3516:     }
                   3517: 
                   3518:     if ($env{'environment.remote'} eq 'off') {
                   3519:         # No Remote
1.258     albertel 3520: 	if ($env{'request.state'} eq 'construct') {
1.359     albertel 3521: 	    $forcereg=1;
                   3522: 	}
                   3523: 
                   3524: 	if (!$customtitle && $env{'request.state'} eq 'construct') {
                   3525: 	    # this is for resources; directories have customtitle, and crumbs
                   3526:             # and select recent are created in lonpubdir.pm  
1.229     albertel 3527: 	    my ($uname,$thisdisfn)=
1.258     albertel 3528: 		($env{'request.filename'} =~ m|^/home/([^/]+)/public_html/(.*)|);
1.229     albertel 3529: 	    my $formaction='/priv/'.$uname.'/'.$thisdisfn;
                   3530: 	    $formaction=~s/\/+/\//g;
                   3531: 
1.359     albertel 3532: 	    my $parentpath = '';
                   3533: 	    my $lastitem = '';
                   3534: 	    if ($thisdisfn =~ m-(.+/)([^/]*)$-) {
                   3535: 		$parentpath = $1;
                   3536: 		$lastitem = $2;
                   3537: 	    } else {
                   3538: 		$lastitem = $thisdisfn;
                   3539: 	    }
                   3540: 	    $titleinfo = 
1.401     albertel 3541: 		&Apache::loncommon::help_open_menu('','',3,'Authoring').
1.359     albertel 3542: 		'<b>Construction Space</b>:&nbsp;'. 
                   3543: 		'<form name="dirs" method="post" action="'.$formaction
                   3544: 		.'" target="_top"><tt><b>'
                   3545: 		.&Apache::lonhtmlcommon::crumbs($uname.'/'.$parentpath,'_top','/priv','','+1',1)."<font size=\"+1\">$lastitem</font></b></tt><br />"
                   3546: 		.&Apache::lonhtmlcommon::select_recent('construct','recent','this.form.action=this.form.recent.value;this.form.submit()')
                   3547: 		.'</form>'
                   3548: 		.&Apache::lonmenu::constspaceform();
1.235     raeburn  3549:         }
1.359     albertel 3550: 
1.337     albertel 3551:         my $titletable;
1.338     albertel 3552: 	if (!$notitle) {
1.337     albertel 3553: 	    $titletable =
1.359     albertel 3554: 		'<table id="LC_title_bar">'.
                   3555:                          "<tr><td> $titleinfo $dc_info</td>".$roleinfo.
                   3556: 			 '</tr></table>';
1.337     albertel 3557: 	}
1.359     albertel 3558: 	if ($notopbar) {
                   3559: 	    $bodytag .= $titletable;
                   3560: 	} else {
                   3561: 	    if ($env{'request.state'} eq 'construct') {
1.337     albertel 3562:                 $bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg,
                   3563: 							  $titletable);
1.272     raeburn  3564:             } else {
1.336     albertel 3565:                 $bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg).
1.359     albertel 3566: 		    $titletable;
1.272     raeburn  3567:             }
1.235     raeburn  3568:         }
                   3569:         return $bodytag;
1.94      www      3570:     }
1.95      www      3571: 
1.93      www      3572: #
1.95      www      3573: # Top frame rendering, Remote is up
1.93      www      3574: #
1.359     albertel 3575: 
1.517     raeburn  3576:     my $imgsrc = $img;
                   3577:     if ($img =~ /^\/adm/) {
1.564.2.4  albertel 3578:         $imgsrc = &lonhttpdurl($img);
1.517     raeburn  3579:     }
                   3580:     my $upperleft='<img src="'.$imgsrc.'" alt="'.$function.'" />';
1.359     albertel 3581: 
1.305     www      3582:     # Explicit link to get inline menu
1.361     albertel 3583:     my $menu= ($no_inline_link?''
                   3584: 	       :'<br /><a href="/adm/remote?action=collapse">'.&mt('Switch to Inline Menu Mode').'</a>');
1.245     matthew  3585:     #
1.338     albertel 3586:     if ($notitle) {
1.337     albertel 3587: 	return $bodytag;
                   3588:     }
1.94      www      3589:     return(<<ENDBODY);
1.60      matthew  3590: $bodytag
1.359     albertel 3591: <table id="LC_title_bar" class="LC_with_remote">
1.368     albertel 3592: <tr><td class="LC_title_bar_role_logo">$upperleft</td>
1.359     albertel 3593:     <td class="LC_title_bar_domain_logo">$messages&nbsp;</td>
1.54      www      3594: </tr>
1.359     albertel 3595: <tr><td>$titleinfo $dc_info $menu</td>
                   3596: $roleinfo
1.368     albertel 3597: </tr>
1.356     albertel 3598: </table>
1.54      www      3599: ENDBODY
1.182     matthew  3600: }
                   3601: 
1.330     albertel 3602: sub make_attr_string {
                   3603:     my ($register,$attr_ref) = @_;
                   3604: 
                   3605:     if ($attr_ref && !ref($attr_ref)) {
                   3606: 	die("addentries Must be a hash ref ".
                   3607: 	    join(':',caller(1))." ".
                   3608: 	    join(':',caller(0))." ");
                   3609:     }
                   3610: 
                   3611:     if ($register) {
1.339     albertel 3612: 	my ($on_load,$on_unload);
                   3613: 	foreach my $key (keys(%{$attr_ref})) {
                   3614: 	    if      (lc($key) eq 'onload') {
                   3615: 		$on_load.=$attr_ref->{$key}.';';
                   3616: 		delete($attr_ref->{$key});
                   3617: 
                   3618: 	    } elsif (lc($key) eq 'onunload') {
                   3619: 		$on_unload.=$attr_ref->{$key}.';';
                   3620: 		delete($attr_ref->{$key});
                   3621: 	    }
                   3622: 	}
                   3623: 	$attr_ref->{'onload'}  =
                   3624: 	    &Apache::lonmenu::loadevents().  $on_load;
                   3625: 	$attr_ref->{'onunload'}=
                   3626: 	    &Apache::lonmenu::unloadevents().$on_unload;
                   3627:     }
                   3628: 
                   3629: # Accessibility font enhance
                   3630:     if ($env{'browser.fontenhance'} eq 'on') {
                   3631: 	my $style;
                   3632: 	foreach my $key (keys(%{$attr_ref})) {
                   3633: 	    if (lc($key) eq 'style') {
                   3634: 		$style.=$attr_ref->{$key}.';';
                   3635: 		delete($attr_ref->{$key});
                   3636: 	    }
                   3637: 	}
                   3638: 	$attr_ref->{'style'}=$style.'; font-size: x-large;';
1.330     albertel 3639:     }
1.339     albertel 3640: 
                   3641:     if ($env{'browser.blackwhite'} eq 'on') {
                   3642: 	delete($attr_ref->{'font'});
                   3643: 	delete($attr_ref->{'link'});
                   3644: 	delete($attr_ref->{'alink'});
                   3645: 	delete($attr_ref->{'vlink'});
                   3646: 	delete($attr_ref->{'bgcolor'});
                   3647: 	delete($attr_ref->{'background'});
                   3648:     }
                   3649: 
1.330     albertel 3650:     my $attr_string;
                   3651:     foreach my $attr (keys(%$attr_ref)) {
                   3652: 	$attr_string .= " $attr=\"".$attr_ref->{$attr}.'" ';
                   3653:     }
                   3654:     return $attr_string;
                   3655: }
                   3656: 
                   3657: 
1.182     matthew  3658: ###############################################
1.251     albertel 3659: ###############################################
                   3660: 
                   3661: =pod
                   3662: 
                   3663: =item * &endbodytag()
                   3664: 
                   3665: Returns a uniform footer for LON-CAPA web pages.
                   3666: 
1.306     albertel 3667: Inputs: none
1.251     albertel 3668: 
                   3669: =cut
                   3670: 
                   3671: sub endbodytag {
                   3672:     my $endbodytag='</body>';
1.269     albertel 3673:     $endbodytag=&Apache::lontexconvert::jsMath_process()."\n".$endbodytag;
1.315     albertel 3674:     if ( exists( $env{'internal.head.redirect'} ) ) {
                   3675: 	$endbodytag=
                   3676: 	    "<br /><a href=\"$env{'internal.head.redirect'}\">".
                   3677: 	    &mt('Continue').'</a>'.
                   3678: 	    $endbodytag;
                   3679:     }
1.251     albertel 3680:     return $endbodytag;
                   3681: }
                   3682: 
1.352     albertel 3683: =pod
                   3684: 
                   3685: =item * &standard_css()
                   3686: 
                   3687: Returns a style sheet
                   3688: 
                   3689: Inputs: (all optional)
                   3690:             domain         -> force to color decorate a page for a specific
                   3691:                                domain
                   3692:             function       -> force usage of a specific rolish color scheme
                   3693:             bgcolor        -> override the default page bgcolor
                   3694: 
                   3695: =cut
                   3696: 
1.343     albertel 3697: sub standard_css {
1.345     albertel 3698:     my ($function,$domain,$bgcolor) = @_;
1.352     albertel 3699:     $function  = &get_users_function() if (!$function);
                   3700:     my $img    = &designparm($function.'.img',   $domain);
                   3701:     my $tabbg  = &designparm($function.'.tabbg', $domain);
                   3702:     my $font   = &designparm($function.'.font',  $domain);
1.345     albertel 3703:     my $sidebg = &designparm($function.'.sidebg',$domain);
1.382     albertel 3704:     my $pgbg_or_bgcolor =
                   3705: 	         $bgcolor ||
1.352     albertel 3706: 	         &designparm($function.'.pgbg',  $domain);
1.382     albertel 3707:     my $pgbg   = &designparm($function.'.pgbg',  $domain);
1.352     albertel 3708:     my $alink  = &designparm($function.'.alink', $domain);
                   3709:     my $vlink  = &designparm($function.'.vlink', $domain);
                   3710:     my $link   = &designparm($function.'.link',  $domain);
                   3711: 
                   3712:     my $sans                 = 'Arial,Helvetica,sans-serif';
1.395     albertel 3713:     my $mono                 = 'monospace';
1.352     albertel 3714:     my $data_table_head      = $tabbg;
                   3715:     my $data_table_light     = '#EEEEEE';
1.470     banghart 3716:     my $data_table_dark      = '#DDDDDD';
                   3717:     my $data_table_darker    = '#CCCCCC';
1.349     albertel 3718:     my $data_table_highlight = '#FFFF00';
1.352     albertel 3719:     my $mail_new             = '#FFBB77';
                   3720:     my $mail_new_hover       = '#DD9955';
                   3721:     my $mail_read            = '#BBBB77';
                   3722:     my $mail_read_hover      = '#999944';
                   3723:     my $mail_replied         = '#AAAA88';
                   3724:     my $mail_replied_hover   = '#888855';
                   3725:     my $mail_other           = '#99BBBB';
                   3726:     my $mail_other_hover     = '#669999';
1.391     albertel 3727:     my $table_header         = '#DDDDDD';
1.489     raeburn  3728:     my $feedback_link_bg     = '#BBBBBB';
1.392     albertel 3729: 
                   3730:     my $border = ($env{'browser.type'} eq 'explorer') ? '0px 2px 0px 2px'
                   3731: 	                                              : '0px 3px 0px 4px';
1.448     albertel 3732: 
1.523     albertel 3733: 
1.343     albertel 3734:     return <<END;
1.345     albertel 3735: h1, h2, h3, th { font-family: $sans }
1.343     albertel 3736: a:focus { color: red; background: yellow } 
1.510     albertel 3737: table.thinborder,
1.523     albertel 3738: 
1.510     albertel 3739: table.thinborder tr th {
                   3740:   border-style: solid;
                   3741:   border-width: 1px;
                   3742:   background: $tabbg;
                   3743: }
1.523     albertel 3744: table.thinborder tr td {
1.510     albertel 3745:   border-style: solid;
                   3746:   border-width: 1px
                   3747: }
1.426     albertel 3748: 
1.343     albertel 3749: form, .inline { display: inline; }
                   3750: .center { text-align: center; }
1.395     albertel 3751: .LC_filename {font-family: $mono;}
1.350     albertel 3752: .LC_error {
                   3753:   color: red;
                   3754:   font-size: larger;
                   3755: }
1.457     albertel 3756: .LC_warning,
                   3757: .LC_diff_removed {
1.394     albertel 3758:   color: red;
                   3759: }
1.532     albertel 3760: 
                   3761: .LC_info,
1.457     albertel 3762: .LC_success,
                   3763: .LC_diff_added {
1.350     albertel 3764:   color: green;
                   3765: }
1.543     albertel 3766: .LC_unknown {
                   3767:   color: yellow;
                   3768: }
                   3769: 
1.440     albertel 3770: .LC_icon {
                   3771:   border: 0px;
                   3772: }
1.539     albertel 3773: .LC_indexer_icon {
                   3774:   border: 0px;
                   3775:   height: 22px;
                   3776: }
1.543     albertel 3777: .LC_docs_spacer {
                   3778:   width: 25px;
                   3779:   height: 1px;
                   3780:   border: 0px;
                   3781: }
1.346     albertel 3782: 
1.532     albertel 3783: .LC_internal_info {
                   3784:   color: #999;
                   3785: }
                   3786: 
1.458     albertel 3787: table.LC_pastsubmission {
                   3788:   border: 1px solid black;
                   3789:   margin: 2px;
                   3790: }
                   3791: 
1.392     albertel 3792: table#LC_top_nav, table#LC_menubuttons {
1.345     albertel 3793:   width: 100%;
                   3794:   background: $pgbg;
1.392     albertel 3795:   border: 2px;
1.402     albertel 3796:   border-collapse: separate;
1.403     albertel 3797:   padding: 0px;
1.345     albertel 3798: }
1.392     albertel 3799: 
1.409     albertel 3800: table#LC_title_bar, table.LC_breadcrumbs, table#LC_nav_location,
1.393     albertel 3801: table#LC_title_bar.LC_with_remote {
1.359     albertel 3802:   width: 100%;
1.392     albertel 3803:   border-color: $pgbg;
                   3804:   border-style: solid;
                   3805:   border-width: $border;
                   3806: 
1.379     albertel 3807:   background: $pgbg;
                   3808:   font-family: $sans;
1.392     albertel 3809:   border-collapse: collapse;
1.403     albertel 3810:   padding: 0px;
1.359     albertel 3811: }
1.392     albertel 3812: 
1.409     albertel 3813: table.LC_docs_path {
                   3814:   width: 100%;
                   3815:   border: 0;
                   3816:   background: $pgbg;
                   3817:   font-family: $sans;
                   3818:   border-collapse: collapse;
                   3819:   padding: 0px;
                   3820: }
                   3821: 
1.359     albertel 3822: table#LC_title_bar td {
                   3823:   background: $tabbg;
                   3824: }
                   3825: table#LC_title_bar td.LC_title_bar_who {
                   3826:   background: $tabbg;
                   3827:   color: $font;
1.427     albertel 3828:   font: small $sans;
1.359     albertel 3829:   text-align: right;
                   3830: }
1.469     banghart 3831: span.LC_metadata {
                   3832:     font-family: $sans;
                   3833: }
1.359     albertel 3834: span.LC_title_bar_title {
1.416     albertel 3835:   font: bold x-large $sans;
1.359     albertel 3836: }
                   3837: table#LC_title_bar td.LC_title_bar_domain_logo {
                   3838:   background: $sidebg;
                   3839:   text-align: right;
1.368     albertel 3840:   padding: 0px;
                   3841: }
                   3842: table#LC_title_bar td.LC_title_bar_role_logo {
                   3843:   background: $sidebg;
                   3844:   padding: 0px;
1.359     albertel 3845: }
                   3846: 
1.346     albertel 3847: table#LC_menubuttons_mainmenu {
1.526     www      3848:   width: 100%;
1.346     albertel 3849:   border: 0px;
                   3850:   border-spacing: 1px;
1.372     albertel 3851:   padding: 0px 1px;
1.346     albertel 3852:   margin: 0px;
                   3853:   border-collapse: separate;
                   3854: }
                   3855: table#LC_menubuttons img, table#LC_menubuttons_mainmenu img {
                   3856:   border: 0px;
                   3857: }
1.345     albertel 3858: table#LC_top_nav td {
                   3859:   background: $tabbg;
1.392     albertel 3860:   border: 0px;
1.407     albertel 3861:   font-size: small;
1.345     albertel 3862: }
                   3863: table#LC_top_nav td a, div#LC_top_nav a {
                   3864:   color: $font;
                   3865:   font-family: $sans;
                   3866: }
1.364     albertel 3867: table#LC_top_nav td.LC_top_nav_logo {
                   3868:   background: $tabbg;
1.432     albertel 3869:   text-align: left;
1.408     albertel 3870:   white-space: nowrap;
1.432     albertel 3871:   width: 31px;
1.408     albertel 3872: }
                   3873: table#LC_top_nav td.LC_top_nav_logo img {
1.432     albertel 3874:   border: 0px;
1.408     albertel 3875:   vertical-align: bottom;
1.364     albertel 3876: }
1.432     albertel 3877: table#LC_top_nav td.LC_top_nav_exit,
                   3878: table#LC_top_nav td.LC_top_nav_help {
                   3879:   width: 2.0em;
                   3880: }
1.442     albertel 3881: table#LC_top_nav td.LC_top_nav_login {
                   3882:   width: 4.0em;
                   3883:   text-align: center;
                   3884: }
1.409     albertel 3885: table.LC_breadcrumbs td, table.LC_docs_path td  {
1.357     albertel 3886:   background: $tabbg;
                   3887:   color: $font;
                   3888:   font-family: $sans;
1.358     albertel 3889:   font-size: smaller;
1.357     albertel 3890: }
1.411     albertel 3891: table.LC_breadcrumbs td.LC_breadcrumbs_component,
1.409     albertel 3892: table.LC_docs_path td.LC_docs_path_component {
1.357     albertel 3893:   background: $tabbg;
                   3894:   color: $font;
                   3895:   font-family: $sans;
                   3896:   font-size: larger;
                   3897:   text-align: right;
                   3898: }
1.383     albertel 3899: td.LC_table_cell_checkbox {
                   3900:   text-align: center;
                   3901: }
                   3902: 
1.522     albertel 3903: table#LC_mainmenu td.LC_mainmenu_column {
                   3904:     vertical-align: top;
                   3905: }
                   3906: 
1.346     albertel 3907: .LC_menubuttons_inline_text {
                   3908:   color: $font;
                   3909:   font-family: $sans;
                   3910:   font-size: smaller;
                   3911: }
                   3912: 
1.526     www      3913: .LC_menubuttons_link {
                   3914:   text-decoration: none;
                   3915: }
                   3916: 
1.522     albertel 3917: .LC_menubuttons_category {
1.521     www      3918:   color: $font;
1.526     www      3919:   background: $pgbg;
1.521     www      3920:   font-family: $sans;
                   3921:   font-size: larger;
                   3922:   font-weight: bold;
                   3923: }
                   3924: 
1.346     albertel 3925: td.LC_menubuttons_text {
1.526     www      3926:   width: 90%;
1.346     albertel 3927:   color: $font;
                   3928:   font-family: $sans;
                   3929: }
1.526     www      3930: 
1.346     albertel 3931: td.LC_menubuttons_img {
                   3932: }
1.526     www      3933: 
1.346     albertel 3934: .LC_current_location {
                   3935:   font-family: $sans;
                   3936:   background: $tabbg;
                   3937: }
                   3938: .LC_new_mail {
                   3939:   font-family: $sans;
                   3940:   font-weight: bold;
                   3941: }
1.347     albertel 3942: 
1.526     www      3943: .LC_rolesmenu_is {
                   3944:   font-family: $sans;
                   3945: }
                   3946: 
                   3947: .LC_rolesmenu_selected {
                   3948:   font-family: $sans;
                   3949: }
                   3950: 
                   3951: .LC_rolesmenu_future {
                   3952:   font-family: $sans;
                   3953: }
                   3954: 
                   3955: 
                   3956: .LC_rolesmenu_will {
                   3957:   font-family: $sans;
                   3958: }
                   3959: 
                   3960: .LC_rolesmenu_will_not {
                   3961:   font-family: $sans;
                   3962: }
                   3963: 
                   3964: .LC_rolesmenu_expired {
                   3965:   font-family: $sans;
                   3966: }
                   3967: 
                   3968: .LC_rolesinfo {
                   3969:   font-family: $sans;
                   3970: }
                   3971: 
1.527     www      3972: .LC_dropadd_labeltext {
                   3973:   font-family: $sans;
                   3974:   text-align: right;
                   3975: }
                   3976: 
                   3977: .LC_preferences_labeltext {
                   3978:   font-family: $sans;
                   3979:   text-align: right;
                   3980: }
                   3981: 
1.440     albertel 3982: table.LC_aboutme_port {
                   3983:   border: 0px;
                   3984:   border-collapse: collapse;
                   3985:   border-spacing: 0px;
                   3986: }
1.349     albertel 3987: table.LC_data_table, table.LC_mail_list {
1.347     albertel 3988:   border: 1px solid #000000;
1.402     albertel 3989:   border-collapse: separate;
1.426     albertel 3990:   border-spacing: 1px;
1.347     albertel 3991: }
1.422     albertel 3992: .LC_data_table_dense {
                   3993:   font-size: small;
                   3994: }
1.507     raeburn  3995: table.LC_nested_outer {
                   3996:   border: 1px solid #000000;
                   3997:   border-collapse: separate;
                   3998:   border-spacing: 0px;
                   3999:   width: 100%;
                   4000: }
                   4001: table.LC_nested {
                   4002:   border: 0px;
                   4003:   border-collapse: separate;
                   4004:   border-spacing: 0px;
                   4005:   width: 100%;
                   4006: }
1.523     albertel 4007: table.LC_data_table tr th, table.LC_calendar tr th, table.LC_mail_list tr th,
                   4008: table.LC_prior_tries tr th {
1.349     albertel 4009:   font-weight: bold;
                   4010:   background-color: $data_table_head;
1.421     albertel 4011:   font-size: smaller;
1.347     albertel 4012: }
1.440     albertel 4013: table.LC_data_table tr td, 
                   4014: table.LC_aboutme_port tr td {
1.349     albertel 4015:   background-color: $data_table_light;
1.425     albertel 4016:   padding: 2px;
1.347     albertel 4017: }
1.440     albertel 4018: table.LC_data_table tr.LC_even_row td,
                   4019: table.LC_aboutme_port tr.LC_even_row td {
1.349     albertel 4020:   background-color: $data_table_dark;
1.347     albertel 4021: }
1.425     albertel 4022: table.LC_data_table tr.LC_data_table_highlight td {
                   4023:   background-color: $data_table_darker;
                   4024: }
1.451     albertel 4025: table.LC_data_table tr.LC_empty_row td,
1.507     raeburn  4026: table.LC_nested tr.LC_empty_row td {
1.347     albertel 4027:   background-color: #FFFFFF;
1.421     albertel 4028:   font-weight: bold;
                   4029:   font-style: italic;
                   4030:   text-align: center;
                   4031:   padding: 8px;
1.347     albertel 4032: }
1.507     raeburn  4033: table.LC_nested tr.LC_empty_row td {
1.465     albertel 4034:   padding: 4ex
                   4035: }
1.507     raeburn  4036: table.LC_nested_outer tr th {
                   4037:   font-weight: bold;
                   4038:   background-color: $data_table_head;
                   4039:   font-size: smaller;
                   4040:   border-bottom: 1px solid #000000;
                   4041: }
                   4042: table.LC_nested_outer tr td.LC_subheader {
                   4043:   background-color: $data_table_head;
                   4044:   font-weight: bold;
                   4045:   font-size: small;
                   4046:   border-bottom: 1px solid #000000;
                   4047:   text-align: right;
1.451     albertel 4048: }
1.507     raeburn  4049: table.LC_nested tr.LC_info_row td {
1.451     albertel 4050:   background-color: #CCC;
                   4051:   font-weight: bold;
                   4052:   font-size: small;
1.507     raeburn  4053:   text-align: center;
                   4054: }
                   4055: table.LC_nested tr.LC_info_row td.LC_left_item {
                   4056:   text-align: left;
1.451     albertel 4057: }
1.507     raeburn  4058: table.LC_nested td {
1.451     albertel 4059:   background-color: #FFF;
                   4060:   font-size: small;
1.507     raeburn  4061: }
                   4062: table.LC_nested_outer tr th.LC_right_item,
                   4063: table.LC_nested tr.LC_info_row td.LC_right_item,
                   4064: table.LC_nested tr.LC_odd_row td.LC_right_item,
                   4065: table.LC_nested tr td.LC_right_item {
1.451     albertel 4066:   text-align: right;
                   4067: }
                   4068: 
1.507     raeburn  4069: table.LC_nested tr.LC_odd_row td {
1.451     albertel 4070:   background-color: #EEE;
                   4071: }
                   4072: 
1.473     raeburn  4073: table.LC_createuser {
                   4074: }
                   4075: 
                   4076: table.LC_createuser tr.LC_section_row td {
                   4077:   font-size: smaller;
                   4078: }
                   4079: 
                   4080: table.LC_createuser tr.LC_info_row td  {
                   4081:   background-color: #CCC;
                   4082:   font-weight: bold;
                   4083:   text-align: center;
                   4084: }
                   4085: 
1.349     albertel 4086: table.LC_calendar {
                   4087:   border: 1px solid #000000;
                   4088:   border-collapse: collapse;
                   4089: }
                   4090: table.LC_calendar_pickdate {
                   4091:   font-size: xx-small;
                   4092: }
                   4093: table.LC_calendar tr td {
                   4094:   border: 1px solid #000000;
                   4095:   vertical-align: top;
                   4096: }
                   4097: table.LC_calendar tr td.LC_calendar_day_empty {
                   4098:   background-color: $data_table_dark;
                   4099: }
                   4100: table.LC_calendar tr td.LC_calendar_day_current {
                   4101:   background-color: $data_table_highlight;
                   4102: }
                   4103: 
                   4104: table.LC_mail_list tr.LC_mail_new {
                   4105:   background-color: $mail_new;
                   4106: }
                   4107: table.LC_mail_list tr.LC_mail_new:hover {
                   4108:   background-color: $mail_new_hover;
                   4109: }
                   4110: table.LC_mail_list tr.LC_mail_read {
                   4111:   background-color: $mail_read;
                   4112: }
                   4113: table.LC_mail_list tr.LC_mail_read:hover {
                   4114:   background-color: $mail_read_hover;
                   4115: }
                   4116: table.LC_mail_list tr.LC_mail_replied {
                   4117:   background-color: $mail_replied;
                   4118: }
                   4119: table.LC_mail_list tr.LC_mail_replied:hover {
                   4120:   background-color: $mail_replied_hover;
                   4121: }
                   4122: table.LC_mail_list tr.LC_mail_other {
                   4123:   background-color: $mail_other;
                   4124: }
                   4125: table.LC_mail_list tr.LC_mail_other:hover {
                   4126:   background-color: $mail_other_hover;
                   4127: }
1.494     raeburn  4128: table.LC_mail_list tr.LC_mail_even {
                   4129: }
                   4130: table.LC_mail_list tr.LC_mail_odd {
                   4131: }
                   4132: 
1.385     albertel 4133: 
1.386     albertel 4134: table#LC_portfolio_actions {
                   4135:   width: auto;
                   4136:   background: $pgbg;
                   4137:   border: 0px;
                   4138:   border-spacing: 2px 2px;
                   4139:   padding: 0px;
                   4140:   margin: 0px;
                   4141:   border-collapse: separate;
                   4142: }
                   4143: table#LC_portfolio_actions td.LC_label {
                   4144:   background: $tabbg;
                   4145:   text-align: right;
                   4146: }
                   4147: table#LC_portfolio_actions td.LC_value {
                   4148:   background: $tabbg;
                   4149: }
1.385     albertel 4150: 
1.391     albertel 4151: table#LC_cstr_controls {
                   4152:   width: 100%;
                   4153:   border-collapse: collapse;
                   4154: }
                   4155: table#LC_cstr_controls tr td {
                   4156:   border: 4px solid $pgbg;
                   4157:   padding: 4px;
                   4158:   text-align: center;
                   4159:   background: $tabbg;
                   4160: }
                   4161: table#LC_cstr_controls tr th {
                   4162:   border: 4px solid $pgbg;
                   4163:   background: $table_header;
                   4164:   text-align: center;
                   4165:   font-family: $sans;
                   4166:   font-size: smaller;
                   4167: }
                   4168: 
1.389     albertel 4169: table#LC_browser {
                   4170:  
                   4171: }
                   4172: table#LC_browser tr th {
1.391     albertel 4173:   background: $table_header;
1.389     albertel 4174: }
1.390     albertel 4175: table#LC_browser tr td {
                   4176:   padding: 2px;
                   4177: }
1.389     albertel 4178: table#LC_browser tr.LC_browser_file,
                   4179: table#LC_browser tr.LC_browser_file_published {
                   4180:   background: #CCFF88;
                   4181: }
                   4182: table#LC_browser tr.LC_browser_file_locked,
                   4183: table#LC_browser tr.LC_browser_file_unpublished {
                   4184:   background: #FFAA99;
1.387     albertel 4185: }
1.389     albertel 4186: table#LC_browser tr.LC_browser_file_obsolete {
                   4187:   background: #AAAAAA;
1.387     albertel 4188: }
1.455     albertel 4189: table#LC_browser tr.LC_browser_file_modified,
                   4190: table#LC_browser tr.LC_browser_file_metamodified {
1.389     albertel 4191:   background: #FFFF77;
1.387     albertel 4192: }
1.389     albertel 4193: table#LC_browser tr.LC_browser_folder {
                   4194:   background: #CCCCFF;
1.387     albertel 4195: }
1.388     albertel 4196: span.LC_current_location {
                   4197:   font-size: x-large;
                   4198:   background: $pgbg;
                   4199: }
1.387     albertel 4200: 
1.395     albertel 4201: span.LC_parm_menu_item {
                   4202:   font-size: larger;
                   4203:   font-family: $sans;
                   4204: }
                   4205: span.LC_parm_scope_all {
                   4206:   color: red;
                   4207: }
                   4208: span.LC_parm_scope_folder {
                   4209:   color: green;
                   4210: }
                   4211: span.LC_parm_scope_resource {
                   4212:   color: orange;
                   4213: }
                   4214: span.LC_parm_part {
                   4215:   color: blue;
                   4216: }
                   4217: span.LC_parm_folder, span.LC_parm_symb {
                   4218:   font-size: x-small;
                   4219:   font-family: $mono;
                   4220:   color: #AAAAAA;
                   4221: }
                   4222: 
1.396     albertel 4223: td.LC_parm_overview_level_menu, td.LC_parm_overview_map_menu,
                   4224: td.LC_parm_overview_parm_selectors, td.LC_parm_overview_parm_restrictions {
                   4225:   border: 1px solid black;
                   4226:   border-collapse: collapse;
                   4227: }
                   4228: table.LC_parm_overview_restrictions td {
                   4229:   border-width: 1px 4px 1px 4px;
                   4230:   border-style: solid;
                   4231:   border-color: $pgbg;
                   4232:   text-align: center;
                   4233: }
                   4234: table.LC_parm_overview_restrictions th {
                   4235:   background: $tabbg;
                   4236:   border-width: 1px 4px 1px 4px;
                   4237:   border-style: solid;
                   4238:   border-color: $pgbg;
                   4239: }
1.398     albertel 4240: table#LC_helpmenu {
                   4241:   border: 0px;
                   4242:   height: 55px;
                   4243:   border-spacing: 0px;
                   4244: }
                   4245: 
                   4246: table#LC_helpmenu fieldset legend {
                   4247:   font-size: larger;
                   4248:   font-weight: bold;
                   4249: }
1.397     albertel 4250: table#LC_helpmenu_links {
                   4251:   width: 100%;
                   4252:   border: 1px solid black;
                   4253:   background: $pgbg;
                   4254:   padding: 0px;
                   4255:   border-spacing: 1px;
                   4256: }
                   4257: table#LC_helpmenu_links tr td {
                   4258:   padding: 1px;
                   4259:   background: $tabbg;
1.399     albertel 4260:   text-align: center;
                   4261:   font-weight: bold;
1.397     albertel 4262: }
1.396     albertel 4263: 
1.397     albertel 4264: table#LC_helpmenu_links a:link, table#LC_helpmenu_links a:visited,
                   4265: table#LC_helpmenu_links a:active {
                   4266:   text-decoration: none;
                   4267:   color: $font;
                   4268: }
                   4269: table#LC_helpmenu_links a:hover {
                   4270:   text-decoration: underline;
                   4271:   color: $vlink;
                   4272: }
1.396     albertel 4273: 
1.417     albertel 4274: .LC_chrt_popup_exists {
                   4275:   border: 1px solid #339933;
                   4276:   margin: -1px;
                   4277: }
                   4278: .LC_chrt_popup_up {
                   4279:   border: 1px solid yellow;
                   4280:   margin: -1px;
                   4281: }
                   4282: .LC_chrt_popup {
                   4283:   border: 1px solid #8888FF;
                   4284:   background: #CCCCFF;
                   4285: }
                   4286: 
1.421     albertel 4287: table.LC_pick_box {
                   4288:   width: 100%;
                   4289:   border-collapse: separate;
                   4290:   background: white;
                   4291:   border: 1px solid black;
                   4292:   border-spacing: 1px;
                   4293: }
                   4294: table.LC_pick_box td.LC_pick_box_title {
                   4295:   background: $tabbg;
                   4296:   font-weight: bold;
                   4297:   text-align: right;
                   4298:   width: 184px;
                   4299:   padding: 8px;
                   4300: }
1.424     albertel 4301: table.LC_pick_box td.LC_pick_box_separator {
1.421     albertel 4302:   padding: 0px;
                   4303:   height: 1px;
                   4304:   background: black;
                   4305: }
                   4306: table.LC_pick_box td.LC_pick_box_submit {
                   4307:   text-align: right;
                   4308: }
                   4309: 
1.424     albertel 4310: table.LC_group_priv_box {
                   4311:   background: white;
                   4312:   border: 1px solid black;
                   4313:   border-spacing: 1px;
                   4314: }
                   4315: table.LC_group_priv_box td.LC_pick_box_title {
                   4316:   background: $tabbg;
                   4317:   font-weight: bold;
                   4318:   text-align: right;
                   4319:   width: 184px;
                   4320: }
                   4321: table.LC_group_priv_box td.LC_groups_fixed {
                   4322:   background: $data_table_light;
                   4323:   text-align: center;
                   4324: }
                   4325: table.LC_group_priv_box td.LC_groups_optional {
                   4326:   background: $data_table_dark;
                   4327:   text-align: center;
                   4328: }
                   4329: table.LC_group_priv_box td.LC_groups_functionality {
                   4330:   background: $data_table_darker;
                   4331:   text-align: center;
                   4332:   font-weight: bold;
                   4333: }
                   4334: table.LC_group_priv td {
                   4335:   text-align: left;
                   4336:   padding: 0px;
                   4337: }
                   4338: 
1.421     albertel 4339: table.LC_notify_front_page {
                   4340:   background: white;
                   4341:   border: 1px solid black;
                   4342:   padding: 8px;
                   4343: }
                   4344: table.LC_notify_front_page td {
                   4345:   padding: 8px;
                   4346: }
1.424     albertel 4347: .LC_navbuttons {
                   4348:   margin: 2ex 0ex 2ex 0ex;
                   4349: }
1.423     albertel 4350: .LC_topic_bar {
                   4351:   font-family: $sans;
                   4352:   font-weight: bold;
                   4353:   width: 100%;
                   4354:   background: $tabbg;
                   4355:   vertical-align: middle;
                   4356:   margin: 2ex 0ex 2ex 0ex;
                   4357: }
                   4358: .LC_topic_bar span {
                   4359:   vertical-align: middle;
                   4360: }
                   4361: .LC_topic_bar img {
                   4362:   vertical-align: bottom;
                   4363: }
                   4364: table.LC_course_group_status {
                   4365:   margin: 20px;
                   4366: }
                   4367: table.LC_status_selector td {
                   4368:   vertical-align: top;
                   4369:   text-align: center;
1.424     albertel 4370:   padding: 4px;
                   4371: }
                   4372: table.LC_descriptive_input td.LC_description {
                   4373:   vertical-align: top;
                   4374:   text-align: right;
                   4375:   font-weight: bold;
1.423     albertel 4376: }
1.489     raeburn  4377: table.LC_feedback_link {
                   4378:     background: $feedback_link_bg;
                   4379: }
                   4380: span.LC_feedback_link {
                   4381:     background: $feedback_link_bg;
                   4382:     font-size: larger;
                   4383: }
1.421     albertel 4384: 
1.515     albertel 4385: table.LC_prior_tries {
1.524     albertel 4386:   border: 1px solid #000000;
                   4387:   border-collapse: separate;
                   4388:   border-spacing: 1px;
1.515     albertel 4389: }
1.523     albertel 4390: 
1.515     albertel 4391: table.LC_prior_tries td {
1.524     albertel 4392:   padding: 2px;
1.515     albertel 4393: }
1.523     albertel 4394: 
                   4395: .LC_answer_correct {
                   4396:   background: #AAFFAA;
                   4397:   color: black;
                   4398: }
                   4399: .LC_answer_charged_try {
                   4400:   background: #FFAAAA ! important;
                   4401:   color: black;
                   4402: }
                   4403: .LC_answer_not_charged_try, 
                   4404: .LC_answer_no_grade,
                   4405: .LC_answer_late {
                   4406:   background: #FFFFAA;
                   4407:   color: black;
                   4408: }
                   4409: .LC_answer_previous {
                   4410:   background: #AAAAFF;
                   4411:   color: black;
                   4412: }
                   4413: .LC_answer_no_message {
                   4414:   background: #FFFFFF;
                   4415:   color: black;
                   4416: }
                   4417: .LC_answer_unknown {
                   4418:   background: orange;
                   4419:   color: black;
                   4420: }
                   4421: 
                   4422: 
1.529     albertel 4423: span.LC_prior_numerical,
                   4424: span.LC_prior_string,
                   4425: span.LC_prior_custom,
                   4426: span.LC_prior_reaction,
                   4427: span.LC_prior_math {
1.523     albertel 4428:   font-family: monospace;
                   4429:   white-space: pre;
                   4430: }
                   4431: 
1.525     albertel 4432: span.LC_prior_string {
                   4433:   font-family: monospace;
                   4434:   white-space: pre;
                   4435: }
                   4436: 
1.523     albertel 4437: table.LC_prior_option {
                   4438:   width: 100%;
                   4439:   border-collapse: collapse;
                   4440: }
1.528     albertel 4441: table.LC_prior_rank, table.LC_prior_match {
                   4442:   border-collapse: collapse;
                   4443: }
                   4444: table.LC_prior_option tr td,
                   4445: table.LC_prior_rank tr td,
                   4446: table.LC_prior_match tr td {
1.524     albertel 4447:   border: 1px solid #000000;
1.515     albertel 4448: }
                   4449: 
1.519     raeburn  4450: span.LC_nobreak {
1.544     albertel 4451:   white-space: nowrap;
1.519     raeburn  4452: }
                   4453: 
1.545     albertel 4454: table.LC_docs_documents {
                   4455:   background: #BBBBBB;
1.547     albertel 4456:   border-width: 0px;
1.545     albertel 4457:   border-collapse: collapse;
                   4458: }
                   4459: 
                   4460: table.LC_docs_documents td.LC_docs_document {
                   4461:   border: 2px solid black;
                   4462:   padding: 4px;
                   4463: }
                   4464: 
                   4465: .LC_docs_course_commands div {
                   4466:   float: left;
                   4467:   border: 4px solid #AAAAAA;
                   4468:   padding: 4px;
                   4469:   background: #DDDDCC;
                   4470: }
                   4471: 
                   4472: .LC_docs_entry_move {
                   4473:   border: 0px;
                   4474:   border-collapse: collapse;
1.544     albertel 4475: }
                   4476: 
1.545     albertel 4477: .LC_docs_entry_move td {
                   4478:   border: 2px solid #BBBBBB;
                   4479:   background: #DDDDDD;
                   4480: }
                   4481: 
                   4482: .LC_docs_editor td.LC_docs_entry_commands {
                   4483:   background: #DDDDDD;
                   4484:   font-size: x-small;
                   4485: }
1.544     albertel 4486: .LC_docs_copy {
1.545     albertel 4487:   color: #000099;
1.544     albertel 4488: }
                   4489: .LC_docs_cut {
1.545     albertel 4490:   color: #550044;
1.544     albertel 4491: }
                   4492: .LC_docs_rename {
1.545     albertel 4493:   color: #009900;
1.544     albertel 4494: }
                   4495: .LC_docs_remove {
1.545     albertel 4496:   color: #990000;
                   4497: }
                   4498: 
1.547     albertel 4499: .LC_docs_reinit_warn,
                   4500: .LC_docs_ext_edit {
                   4501:   font-size: x-small;
                   4502: }
                   4503: 
1.545     albertel 4504: .LC_docs_editor td.LC_docs_entry_title,
                   4505: .LC_docs_editor td.LC_docs_entry_icon {
                   4506:   background: #FFFFBB;
                   4507: }
                   4508: .LC_docs_editor td.LC_docs_entry_parameter {
                   4509:   background: #BBBBFF;
                   4510:   font-size: x-small;
                   4511:   white-space: nowrap;
                   4512: }
                   4513: 
                   4514: table.LC_docs_adddocs td,
                   4515: table.LC_docs_adddocs th {
                   4516:   border: 1px solid #BBBBBB;
                   4517:   padding: 4px;
                   4518:   background: #DDDDDD;
1.543     albertel 4519: }
                   4520: 
1.343     albertel 4521: END
                   4522: }
                   4523: 
1.306     albertel 4524: =pod
                   4525: 
                   4526: =item * &headtag()
                   4527: 
                   4528: Returns a uniform footer for LON-CAPA web pages.
                   4529: 
1.307     albertel 4530: Inputs: $title - optional title for the head
                   4531:         $head_extra - optional extra HTML to put inside the <head>
1.315     albertel 4532:         $args - optional arguments
1.319     albertel 4533:             force_register - if is true call registerurl so the remote is 
                   4534:                              informed
1.415     albertel 4535:             redirect       -> array ref of
                   4536:                                    1- seconds before redirect occurs
                   4537:                                    2- url to redirect to
                   4538:                                    3- whether the side effect should occur
1.315     albertel 4539:                            (side effect of setting 
                   4540:                                $env{'internal.head.redirect'} to the url 
                   4541:                                redirected too)
1.352     albertel 4542:             domain         -> force to color decorate a page for a specific
                   4543:                                domain
                   4544:             function       -> force usage of a specific rolish color scheme
                   4545:             bgcolor        -> override the default page bgcolor
1.460     albertel 4546:             no_auto_mt_title
                   4547:                            -> prevent &mt()ing the title arg
1.464     albertel 4548: 
1.306     albertel 4549: =cut
                   4550: 
                   4551: sub headtag {
1.313     albertel 4552:     my ($title,$head_extra,$args) = @_;
1.306     albertel 4553:     
1.363     albertel 4554:     my $function = $args->{'function'} || &get_users_function();
                   4555:     my $domain   = $args->{'domain'}   || &determinedomain();
                   4556:     my $bgcolor  = $args->{'bgcolor'}  || &designparm($function.'.pgbg',$domain);
1.418     albertel 4557:     my $url = join(':',$env{'user.name'},$env{'user.domain'},
1.458     albertel 4558: 		   $Apache::lonnet::perlvar{'lonVersion'},
1.531     albertel 4559: 		   #time(),
1.418     albertel 4560: 		   $env{'environment.color.timestamp'},
1.363     albertel 4561: 		   $function,$domain,$bgcolor);
                   4562: 
1.369     www      4563:     $url = '/adm/css/'.&escape($url).'.css';
1.363     albertel 4564: 
1.308     albertel 4565:     my $result =
                   4566: 	'<head>'.
1.461     albertel 4567: 	&font_settings();
1.319     albertel 4568: 
1.461     albertel 4569:     if (!$args->{'frameset'}) {
                   4570: 	$result .= &Apache::lonhtmlcommon::htmlareaheaders();
                   4571:     }
1.319     albertel 4572:     if ($args->{'force_register'}) {
                   4573: 	$result .= &Apache::lonmenu::registerurl(1);
                   4574:     }
1.436     albertel 4575:     if (!$args->{'no_nav_bar'} 
                   4576: 	&& !$args->{'only_body'}
                   4577: 	&& !$args->{'frameset'}) {
                   4578: 	$result .= &help_menu_js();
                   4579:     }
1.319     albertel 4580: 
1.314     albertel 4581:     if (ref($args->{'redirect'})) {
1.414     albertel 4582: 	my ($time,$url,$inhibit_continue) = @{$args->{'redirect'}};
1.315     albertel 4583: 	$url = &Apache::lonenc::check_encrypt($url);
1.414     albertel 4584: 	if (!$inhibit_continue) {
                   4585: 	    $env{'internal.head.redirect'} = $url;
                   4586: 	}
1.313     albertel 4587: 	$result.=<<ADDMETA
                   4588: <meta http-equiv="pragma" content="no-cache" />
1.344     albertel 4589: <meta http-equiv="Refresh" content="$time; url=$url" />
1.313     albertel 4590: ADDMETA
                   4591:     }
1.306     albertel 4592:     if (!defined($title)) {
                   4593: 	$title = 'The LearningOnline Network with CAPA';
                   4594:     }
1.460     albertel 4595:     if (!$args->{'no_auto_mt_title'}) { $title = &mt($title); }
                   4596:     $result .= '<title> LON-CAPA '.$title.'</title>'
1.414     albertel 4597: 	.'<link rel="stylesheet" type="text/css" href="'.$url.'" />'
                   4598: 	.$head_extra;
1.306     albertel 4599:     return $result;
                   4600: }
                   4601: 
                   4602: =pod
                   4603: 
1.340     albertel 4604: =item * &font_settings()
                   4605: 
                   4606: Returns neccessary <meta> to set the proper encoding
                   4607: 
                   4608: Inputs: none
                   4609: 
                   4610: =cut
                   4611: 
                   4612: sub font_settings {
                   4613:     my $headerstring='';
                   4614:     if (($env{'browser.os'} eq 'mac') && (!$env{'browser.mathml'})) { 
                   4615: 	$headerstring.=
                   4616: 	    '<meta Content-Type="text/html; charset=x-mac-roman" />';
                   4617:     } elsif (!$env{'browser.mathml'} && $env{'browser.unicode'}) {
                   4618: 	$headerstring.=
                   4619: 	    '<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />';
                   4620:     }
                   4621:     return $headerstring;
                   4622: }
                   4623: 
1.341     albertel 4624: =pod
                   4625: 
                   4626: =item * &xml_begin()
                   4627: 
                   4628: Returns the needed doctype and <html>
                   4629: 
                   4630: Inputs: none
                   4631: 
                   4632: =cut
                   4633: 
                   4634: sub xml_begin {
                   4635:     my $output='';
                   4636: 
1.342     albertel 4637:     &Apache::lonhtmlcommon::init_htmlareafields();
                   4638: 
1.341     albertel 4639:     if ($env{'browser.mathml'}) {
                   4640: 	$output='<?xml version="1.0"?>'
                   4641:             #.'<?xml-stylesheet type="text/css" href="/adm/MathML/mathml.css"?>'."\n"
                   4642: #            .'<!DOCTYPE html SYSTEM "/adm/MathML/mathml.dtd" '
                   4643:             
                   4644: #	    .'<!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">] >'
                   4645: 	    .'<!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">'
                   4646:             .'<html xmlns:math="http://www.w3.org/1998/Math/MathML" ' 
                   4647: 	    .'xmlns="http://www.w3.org/1999/xhtml">';
                   4648:     } else {
                   4649: 	$output='<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"><html>';
                   4650:     }
                   4651:     return $output;
                   4652: }
1.340     albertel 4653: 
                   4654: =pod
                   4655: 
1.306     albertel 4656: =item * &endheadtag()
                   4657: 
                   4658: Returns a uniform </head> for LON-CAPA web pages.
                   4659: 
                   4660: Inputs: none
                   4661: 
                   4662: =cut
                   4663: 
                   4664: sub endheadtag {
                   4665:     return '</head>';
                   4666: }
                   4667: 
                   4668: =pod
                   4669: 
                   4670: =item * &head()
                   4671: 
                   4672: Returns a uniform complete <head>..</head> section for LON-CAPA web pages.
                   4673: 
                   4674: Inputs: $title - optional title for the page
1.307     albertel 4675:         $head_extra - optional extra HTML to put inside the <head>
1.405     albertel 4676: 
1.306     albertel 4677: =cut
                   4678: 
                   4679: sub head {
1.325     albertel 4680:     my ($title,$head_extra,$args) = @_;
                   4681:     return &headtag($title,$head_extra,$args).&endheadtag();
1.306     albertel 4682: }
                   4683: 
                   4684: =pod
                   4685: 
                   4686: =item * &start_page()
                   4687: 
                   4688: Returns a complete <html> .. <body> section for LON-CAPA web pages.
                   4689: 
                   4690: Inputs: $title - optional title for the page
                   4691:         $head_extra - optional extra HTML to incude inside the <head>
1.315     albertel 4692:         $args - additional optional args supported are:
1.317     albertel 4693:                   only_body      -> is true will set &bodytag() onlybodytag
                   4694:                                     arg on
                   4695:                   no_nav_bar     -> is true will set &bodytag() notopbar arg on
                   4696:                   add_entries    -> additional attributes to add to the  <body>
                   4697:                   domain         -> force to color decorate a page for a 
                   4698:                                     specific domain
                   4699:                   function       -> force usage of a specific rolish color
                   4700:                                     scheme
                   4701:                   redirect       -> see &headtag()
                   4702:                   bgcolor        -> override the default page bg color
                   4703:                   js_ready       -> return a string ready for being used in 
                   4704:                                     a javascript writeln
1.320     albertel 4705:                   html_encode    -> return a string ready for being used in 
                   4706:                                     a html attribute
1.317     albertel 4707:                   force_register -> if is true will turn on the &bodytag()
                   4708:                                     $forcereg arg
1.326     albertel 4709:                   body_title     -> alternate text to use instead of $title
                   4710:                                     in the title box that appears, this text
                   4711:                                     is not auto translated like the $title is
1.330     albertel 4712:                   frameset       -> if true will start with a <frameset>
                   4713:                                     rather than <body>
1.338     albertel 4714:                   no_title       -> if true the title bar won't be shown
                   4715:                   skip_phases    -> hash ref of 
                   4716:                                     head -> skip the <html><head> generation
                   4717:                                     body -> skip all <body> generation
1.337     albertel 4718: 
1.361     albertel 4719:                   no_inline_link -> if true and in remote mode, don't show the 
                   4720:                                     'Switch To Inline Menu' link
                   4721: 
1.460     albertel 4722:                   no_auto_mt_title -> prevent &mt()ing the title arg
                   4723: 
1.562     albertel 4724:                   inherit_jsmath -> when creating popup window in a page,
                   4725:                                     should it have jsmath forced on by the
                   4726:                                     current page
                   4727: 
1.306     albertel 4728: =cut
                   4729: 
                   4730: sub start_page {
1.309     albertel 4731:     my ($title,$head_extra,$args) = @_;
1.318     albertel 4732:     #&Apache::lonnet::logthis("start_page ".join(':',caller(0)));
1.313     albertel 4733:     my %head_args;
1.352     albertel 4734:     foreach my $arg ('redirect','force_register','domain','function',
1.460     albertel 4735: 		     'bgcolor','frameset','no_nav_bar','only_body',
                   4736: 		     'no_auto_mt_title') {
1.319     albertel 4737: 	if (defined($args->{$arg})) {
1.324     raeburn  4738: 	    $head_args{$arg} = $args->{$arg};
1.319     albertel 4739: 	}
1.313     albertel 4740:     }
1.319     albertel 4741: 
1.315     albertel 4742:     $env{'internal.start_page'}++;
1.338     albertel 4743:     my $result;
                   4744:     if (! exists($args->{'skip_phases'}{'head'}) ) {
                   4745: 	$result.=
1.341     albertel 4746: 	    &xml_begin().
1.338     albertel 4747: 	    &headtag($title,$head_extra,\%head_args).&endheadtag();
                   4748:     }
                   4749:     
                   4750:     if (! exists($args->{'skip_phases'}{'body'}) ) {
                   4751: 	if ($args->{'frameset'}) {
                   4752: 	    my $attr_string = &make_attr_string($args->{'force_register'},
                   4753: 						$args->{'add_entries'});
                   4754: 	    $result .= "\n<frameset $attr_string>\n";
                   4755: 	} else {
                   4756: 	    $result .=
                   4757: 		&bodytag($title, 
                   4758: 			 $args->{'function'},       $args->{'add_entries'},
                   4759: 			 $args->{'only_body'},      $args->{'domain'},
                   4760: 			 $args->{'force_register'}, $args->{'body_title'},
                   4761: 			 $args->{'no_nav_bar'},     $args->{'bgcolor'},
1.460     albertel 4762: 			 $args->{'no_title'},       $args->{'no_inline_link'},
                   4763: 			 $args);
1.338     albertel 4764: 	}
1.330     albertel 4765:     }
1.338     albertel 4766: 
1.315     albertel 4767:     if ($args->{'js_ready'}) {
1.317     albertel 4768: 	$result = &js_ready($result);
1.315     albertel 4769:     }
1.320     albertel 4770:     if ($args->{'html_encode'}) {
                   4771: 	$result = &html_encode($result);
                   4772:     }
1.315     albertel 4773:     return $result;
1.306     albertel 4774: }
                   4775: 
1.330     albertel 4776: 
1.306     albertel 4777: =pod
                   4778: 
                   4779: =item * &head()
                   4780: 
                   4781: Returns a complete </body></html> section for LON-CAPA web pages.
                   4782: 
1.315     albertel 4783: Inputs:         $args - additional optional args supported are:
                   4784:                  js_ready     -> return a string ready for being used in 
                   4785:                                  a javascript writeln
1.320     albertel 4786:                  html_encode  -> return a string ready for being used in 
                   4787:                                  a html attribute
1.330     albertel 4788:                  frameset     -> if true will start with a <frameset>
                   4789:                                  rather than <body>
1.493     albertel 4790:                  dicsussion   -> if true will get discussion from
                   4791:                                   lonxml::xmlend
                   4792:                                  (you can pass the target and parser arguments
                   4793:                                   through optional 'target' and 'parser' args
                   4794:                                   to this routine)
1.306     albertel 4795: 
                   4796: =cut
                   4797: 
                   4798: sub end_page {
1.315     albertel 4799:     my ($args) = @_;
                   4800:     $env{'internal.end_page'}++;
1.330     albertel 4801:     my $result;
1.335     albertel 4802:     if ($args->{'discussion'}) {
                   4803: 	my ($target,$parser);
                   4804: 	if (ref($args->{'discussion'})) {
                   4805: 	    ($target,$parser) =($args->{'discussion'}{'target'},
                   4806: 				$args->{'discussion'}{'parser'});
                   4807: 	}
                   4808: 	$result .= &Apache::lonxml::xmlend($target,$parser);
                   4809:     }
                   4810: 
1.330     albertel 4811:     if ($args->{'frameset'}) {
                   4812: 	$result .= '</frameset>';
                   4813:     } else {
                   4814: 	$result .= &endbodytag();
                   4815:     }
                   4816:     $result .= "\n</html>";
                   4817: 
1.315     albertel 4818:     if ($args->{'js_ready'}) {
1.317     albertel 4819: 	$result = &js_ready($result);
1.315     albertel 4820:     }
1.335     albertel 4821: 
1.320     albertel 4822:     if ($args->{'html_encode'}) {
                   4823: 	$result = &html_encode($result);
                   4824:     }
1.335     albertel 4825: 
1.315     albertel 4826:     return $result;
                   4827: }
                   4828: 
1.320     albertel 4829: sub html_encode {
                   4830:     my ($result) = @_;
                   4831: 
1.322     albertel 4832:     $result = &HTML::Entities::encode($result,'<>&"');
1.320     albertel 4833:     
                   4834:     return $result;
                   4835: }
1.317     albertel 4836: sub js_ready {
                   4837:     my ($result) = @_;
                   4838: 
1.323     albertel 4839:     $result =~ s/[\n\r]/ /xmsg;
                   4840:     $result =~ s/\\/\\\\/xmsg;
                   4841:     $result =~ s/'/\\'/xmsg;
1.372     albertel 4842:     $result =~ s{</}{<\\/}xmsg;
1.317     albertel 4843:     
                   4844:     return $result;
                   4845: }
                   4846: 
1.315     albertel 4847: sub validate_page {
                   4848:     if (  exists($env{'internal.start_page'})
1.316     albertel 4849: 	  &&     $env{'internal.start_page'} > 1) {
                   4850: 	&Apache::lonnet::logthis('start_page called multiple times '.
1.318     albertel 4851: 				 $env{'internal.start_page'}.' '.
1.316     albertel 4852: 				 $ENV{'request.filename'});
1.315     albertel 4853:     }
                   4854:     if (  exists($env{'internal.end_page'})
1.316     albertel 4855: 	  &&     $env{'internal.end_page'} > 1) {
                   4856: 	&Apache::lonnet::logthis('end_page called multiple times '.
1.318     albertel 4857: 				 $env{'internal.end_page'}.' '.
1.316     albertel 4858: 				 $env{'request.filename'});
1.315     albertel 4859:     }
                   4860:     if (     exists($env{'internal.start_page'})
                   4861: 	&& ! exists($env{'internal.end_page'})) {
1.316     albertel 4862: 	&Apache::lonnet::logthis('start_page called without end_page '.
                   4863: 				 $env{'request.filename'});
1.315     albertel 4864:     }
                   4865:     if (   ! exists($env{'internal.start_page'})
                   4866: 	&&   exists($env{'internal.end_page'})) {
1.316     albertel 4867: 	&Apache::lonnet::logthis('end_page called without start_page'.
                   4868: 				 $env{'request.filename'});
1.315     albertel 4869:     }
1.306     albertel 4870: }
1.315     albertel 4871: 
1.318     albertel 4872: sub simple_error_page {
                   4873:     my ($r,$title,$msg) = @_;
                   4874:     my $page =
                   4875: 	&Apache::loncommon::start_page($title).
                   4876: 	&mt($msg).
                   4877: 	&Apache::loncommon::end_page();
                   4878:     if (ref($r)) {
                   4879: 	$r->print($page);
1.327     albertel 4880: 	return;
1.318     albertel 4881:     }
                   4882:     return $page;
                   4883: }
1.347     albertel 4884: 
                   4885: {
                   4886:     my $row_count;
                   4887:     sub start_data_table {
1.422     albertel 4888: 	my ($add_class) = @_;
                   4889: 	my $css_class = (join(' ','LC_data_table',$add_class));
1.347     albertel 4890: 	undef($row_count);
1.422     albertel 4891: 	return '<table class="'.$css_class.'">'."\n";
1.347     albertel 4892:     }
                   4893: 
                   4894:     sub end_data_table {
                   4895: 	undef($row_count);
1.389     albertel 4896: 	return '</table>'."\n";;
1.347     albertel 4897:     }
                   4898: 
                   4899:     sub start_data_table_row {
1.422     albertel 4900: 	my ($add_class) = @_;
1.347     albertel 4901: 	$row_count++;
1.422     albertel 4902: 	my $css_class = ($row_count % 2)?'':'LC_even_row';
1.428     albertel 4903: 	$css_class = (join(' ',$css_class,$add_class));
1.422     albertel 4904: 	return  '<tr class="'.$css_class.'">'."\n";;
1.347     albertel 4905:     }
1.471     banghart 4906:     
                   4907:     sub continue_data_table_row {
                   4908: 	my ($add_class) = @_;
                   4909: 	my $css_class = ($row_count % 2)?'':'LC_even_row';
                   4910: 	$css_class = (join(' ',$css_class,$add_class));
                   4911: 	return  '<tr class="'.$css_class.'">'."\n";;
                   4912:     }
1.347     albertel 4913: 
                   4914:     sub end_data_table_row {
1.389     albertel 4915: 	return '</tr>'."\n";;
1.347     albertel 4916:     }
1.367     www      4917: 
1.421     albertel 4918:     sub start_data_table_empty_row {
                   4919: 	$row_count++;
                   4920: 	return  '<tr class="LC_empty_row" >'."\n";;
                   4921:     }
                   4922: 
                   4923:     sub end_data_table_empty_row {
                   4924: 	return '</tr>'."\n";;
                   4925:     }
                   4926: 
1.367     www      4927:     sub start_data_table_header_row {
1.389     albertel 4928: 	return  '<tr class="LC_header_row">'."\n";;
1.367     www      4929:     }
                   4930: 
                   4931:     sub end_data_table_header_row {
1.389     albertel 4932: 	return '</tr>'."\n";;
1.367     www      4933:     }
1.347     albertel 4934: }
                   4935: 
1.548     albertel 4936: =pod
                   4937: 
                   4938: =item * &inhibit_menu_check($arg)
                   4939: 
                   4940: Checks for a inhibitmenu state and generates output to preserve it
                   4941: 
                   4942: Inputs:         $arg - can be any of
                   4943:                      - undef - in which case the return value is a string 
                   4944:                                to add  into arguments list of a uri
                   4945:                      - 'input' - in which case the return value is a HTML
                   4946:                                  <form> <input> field of type hidden to
                   4947:                                  preserve the value
                   4948:                      - a url - in which case the return value is the url with
                   4949:                                the neccesary cgi args added to preserve the
                   4950:                                inhibitmenu state
                   4951:                      - a ref to a url - no return value, but the string is
                   4952:                                         updated to include the neccessary cgi
                   4953:                                         args to preserve the inhibitmenu state
                   4954: 
                   4955: =cut
                   4956: 
                   4957: sub inhibit_menu_check {
                   4958:     my ($arg) = @_;
                   4959:     &get_unprocessed_cgi($ENV{'QUERY_STRING'}, ['inhibitmenu']);
                   4960:     if ($arg eq 'input') {
                   4961: 	if ($env{'form.inhibitmenu'}) {
                   4962: 	    return '<input type="hidden" name="inhibitmenu" value="'.$env{'form.inhibitmenu'}.'" />';
                   4963: 	} else {
                   4964: 	    return
                   4965: 	}
                   4966:     }
                   4967:     if ($env{'form.inhibitmenu'}) {
                   4968: 	if (ref($arg)) {
                   4969: 	    $$arg .= '?inhibitmenu='.$env{'form.inhibitmenu'};
                   4970: 	} elsif ($arg eq '') {
                   4971: 	    $arg .= 'inhibitmenu='.$env{'form.inhibitmenu'};
                   4972: 	} else {
                   4973: 	    $arg .= '?inhibitmenu='.$env{'form.inhibitmenu'};
                   4974: 	}
                   4975:     }
                   4976:     if (!ref($arg)) {
                   4977: 	return $arg;
                   4978:     }
                   4979: }
                   4980: 
1.251     albertel 4981: ###############################################
1.182     matthew  4982: 
                   4983: =pod
                   4984: 
1.549     albertel 4985: =back
                   4986: 
                   4987: =head1 User Information Routines
                   4988: 
                   4989: =over 4
                   4990: 
1.405     albertel 4991: =item * &get_users_function()
1.182     matthew  4992: 
                   4993: Used by &bodytag to determine the current users primary role.
                   4994: Returns either 'student','coordinator','admin', or 'author'.
                   4995: 
                   4996: =cut
                   4997: 
                   4998: ###############################################
                   4999: sub get_users_function {
                   5000:     my $function = 'student';
1.258     albertel 5001:     if ($env{'request.role'}=~/^(cc|in|ta|ep)/) {
1.182     matthew  5002:         $function='coordinator';
                   5003:     }
1.258     albertel 5004:     if ($env{'request.role'}=~/^(su|dc|ad|li)/) {
1.182     matthew  5005:         $function='admin';
                   5006:     }
1.258     albertel 5007:     if (($env{'request.role'}=~/^(au|ca)/) ||
1.182     matthew  5008:         ($ENV{'REQUEST_URI'}=~/^(\/priv|\~)/)) {
                   5009:         $function='author';
                   5010:     }
                   5011:     return $function;
1.54      www      5012: }
1.99      www      5013: 
                   5014: ###############################################
                   5015: 
1.233     raeburn  5016: =pod
                   5017: 
1.542     raeburn  5018: =item * &check_user_status()
1.274     raeburn  5019: 
                   5020: Determines current status of supplied role for a
                   5021: specific user. Roles can be active, previous or future.
                   5022: 
                   5023: Inputs: 
                   5024: user's domain, user's username, course's domain,
1.375     raeburn  5025: course's number, optional section ID.
1.274     raeburn  5026: 
                   5027: Outputs:
                   5028: role status: active, previous or future. 
                   5029: 
                   5030: =cut
                   5031: 
                   5032: sub check_user_status {
1.412     raeburn  5033:     my ($udom,$uname,$cdom,$crs,$role,$sec) = @_;
1.274     raeburn  5034:     my %userinfo = &Apache::lonnet::dump('roles',$udom,$uname);
                   5035:     my @uroles = keys %userinfo;
                   5036:     my $srchstr;
                   5037:     my $active_chk = 'none';
1.412     raeburn  5038:     my $now = time;
1.274     raeburn  5039:     if (@uroles > 0) {
1.412     raeburn  5040:         if (($role eq 'cc') || ($sec eq '') || (!defined($sec))) {
1.274     raeburn  5041:             $srchstr = '/'.$cdom.'/'.$crs.'_'.$role;
                   5042:         } else {
1.412     raeburn  5043:             $srchstr = '/'.$cdom.'/'.$crs.'/'.$sec.'_'.$role;
                   5044:         }
                   5045:         if (grep/^\Q$srchstr\E$/,@uroles) {
1.274     raeburn  5046:             my $role_end = 0;
                   5047:             my $role_start = 0;
                   5048:             $active_chk = 'active';
1.412     raeburn  5049:             if ($userinfo{$srchstr} =~ m/^\Q$role\E_(\d+)/) {
                   5050:                 $role_end = $1;
                   5051:                 if ($userinfo{$srchstr} =~ m/^\Q$role\E_\Q$role_end\E_(\d+)$/) {
                   5052:                     $role_start = $1;
1.274     raeburn  5053:                 }
                   5054:             }
                   5055:             if ($role_start > 0) {
1.412     raeburn  5056:                 if ($now < $role_start) {
1.274     raeburn  5057:                     $active_chk = 'future';
                   5058:                 }
                   5059:             }
                   5060:             if ($role_end > 0) {
1.412     raeburn  5061:                 if ($now > $role_end) {
1.274     raeburn  5062:                     $active_chk = 'previous';
                   5063:                 }
                   5064:             }
                   5065:         }
                   5066:     }
                   5067:     return $active_chk;
                   5068: }
                   5069: 
                   5070: ###############################################
                   5071: 
                   5072: =pod
                   5073: 
1.405     albertel 5074: =item * &get_sections()
1.233     raeburn  5075: 
                   5076: Determines all the sections for a course including
                   5077: sections with students and sections containing other roles.
1.419     raeburn  5078: Incoming parameters: 
                   5079: 
                   5080: 1. domain
                   5081: 2. course number 
                   5082: 3. reference to array containing roles for which sections should 
                   5083: be gathered (optional).
                   5084: 4. reference to array containing status types for which sections 
                   5085: should be gathered (optional).
                   5086: 
                   5087: If the third argument is undefined, sections are gathered for any role. 
                   5088: If the fourth argument is undefined, sections are gathered for any status.
                   5089: Permissible values are 'active' or 'future' or 'previous'.
1.233     raeburn  5090:  
1.374     raeburn  5091: Returns section hash (keys are section IDs, values are
                   5092: number of users in each section), subject to the
1.419     raeburn  5093: optional roles filter, optional status filter 
1.233     raeburn  5094: 
                   5095: =cut
                   5096: 
                   5097: ###############################################
                   5098: sub get_sections {
1.419     raeburn  5099:     my ($cdom,$cnum,$possible_roles,$possible_status) = @_;
1.366     albertel 5100:     if (!defined($cdom) || !defined($cnum)) {
                   5101:         my $cid =  $env{'request.course.id'};
                   5102: 
                   5103: 	return if (!defined($cid));
                   5104: 
                   5105:         $cdom = $env{'course.'.$cid.'.domain'};
                   5106:         $cnum = $env{'course.'.$cid.'.num'};
                   5107:     }
                   5108: 
                   5109:     my %sectioncount;
1.419     raeburn  5110:     my $now = time;
1.240     albertel 5111: 
1.366     albertel 5112:     if (!defined($possible_roles) || (grep(/^st$/,@$possible_roles))) {
1.276     albertel 5113: 	my ($classlist) = &Apache::loncoursedata::get_classlist($cdom,$cnum);
1.240     albertel 5114: 	my $sec_index = &Apache::loncoursedata::CL_SECTION();
                   5115: 	my $status_index = &Apache::loncoursedata::CL_STATUS();
1.419     raeburn  5116:         my $start_index = &Apache::loncoursedata::CL_START();
                   5117:         my $end_index = &Apache::loncoursedata::CL_END();
                   5118:         my $status;
1.366     albertel 5119: 	while (my ($student,$data) = each(%$classlist)) {
1.419     raeburn  5120: 	    my ($section,$stu_status,$start,$end) = ($data->[$sec_index],
                   5121: 				                     $data->[$status_index],
                   5122:                                                      $data->[$start_index],
                   5123:                                                      $data->[$end_index]);
                   5124:             if ($stu_status eq 'Active') {
                   5125:                 $status = 'active';
                   5126:             } elsif ($end < $now) {
                   5127:                 $status = 'previous';
                   5128:             } elsif ($start > $now) {
                   5129:                 $status = 'future';
                   5130:             } 
                   5131: 	    if ($section ne '-1' && $section !~ /^\s*$/) {
                   5132:                 if ((!defined($possible_status)) || (($status ne '') && 
                   5133:                     (grep/^\Q$status\E$/,@{$possible_status}))) { 
                   5134: 		    $sectioncount{$section}++;
                   5135:                 }
1.240     albertel 5136: 	    }
                   5137: 	}
                   5138:     }
                   5139:     my %courseroles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
                   5140:     foreach my $user (sort(keys(%courseroles))) {
                   5141: 	if ($user !~ /^(\w{2})/) { next; }
                   5142: 	my ($role) = ($user =~ /^(\w{2})/);
                   5143: 	if ($possible_roles && !(grep(/^$role$/,@$possible_roles))) { next; }
1.419     raeburn  5144: 	my ($section,$status);
1.240     albertel 5145: 	if ($role eq 'cr' &&
                   5146: 	    $user =~ m-^$role/[^/]*/[^/]*/[^/]*:[^:]*:[^:]*:(\w+)-) {
                   5147: 	    $section=$1;
                   5148: 	}
                   5149: 	if ($user =~ /^$role:[^:]*:[^:]*:(\w+)/) { $section=$1; }
                   5150: 	if (!defined($section) || $section eq '-1') { next; }
1.419     raeburn  5151:         my ($end,$start) = ($courseroles{$user} =~ /^([^:]*):([^:]*)$/);
                   5152:         if ($end == -1 && $start == -1) {
                   5153:             next; #deleted role
                   5154:         }
                   5155:         if (!defined($possible_status)) { 
                   5156:             $sectioncount{$section}++;
                   5157:         } else {
                   5158:             if ((!$end || $end >= $now) && (!$start || $start <= $now)) {
                   5159:                 $status = 'active';
                   5160:             } elsif ($end < $now) {
                   5161:                 $status = 'future';
                   5162:             } elsif ($start > $now) {
                   5163:                 $status = 'previous';
                   5164:             }
                   5165:             if (($status ne '') && (grep/^\Q$status\E$/,@{$possible_status})) {
                   5166:                 $sectioncount{$section}++;
                   5167:             }
                   5168:         }
1.233     raeburn  5169:     }
1.366     albertel 5170:     return %sectioncount;
1.233     raeburn  5171: }
                   5172: 
1.274     raeburn  5173: ###############################################
1.294     raeburn  5174: 
                   5175: =pod
1.405     albertel 5176: 
                   5177: =item * &get_course_users()
                   5178: 
1.275     raeburn  5179: Retrieves usernames:domains for users in the specified course
                   5180: with specific role(s), and access status. 
                   5181: 
                   5182: Incoming parameters:
1.277     albertel 5183: 1. course domain
                   5184: 2. course number
                   5185: 3. access status: users must have - either active, 
1.275     raeburn  5186: previous, future, or all.
1.277     albertel 5187: 4. reference to array of permissible roles
1.288     raeburn  5188: 5. reference to array of section restrictions (optional)
                   5189: 6. reference to results object (hash of hashes).
                   5190: 7. reference to optional userdata hash
1.275     raeburn  5191: Keys of top level hash are roles.
                   5192: Keys of inner hashes are username:domain, with 
                   5193: values set to access type.
1.288     raeburn  5194: Optional userdata hash returns an array with arguments in the 
                   5195: same order as loncoursedata::get_classlist() for student data.
                   5196: 
                   5197: Entries for end, start, section and status are blank because
                   5198: of the possibility of multiple values for non-student roles.
                   5199: 
1.275     raeburn  5200: =cut
1.405     albertel 5201: 
1.275     raeburn  5202: ###############################################
1.405     albertel 5203: 
1.275     raeburn  5204: sub get_course_users {
1.288     raeburn  5205:     my ($cdom,$cnum,$types,$roles,$sections,$users,$userdata) = @_;
                   5206:     my %idx = ();
1.419     raeburn  5207:     my %seclists;
1.288     raeburn  5208: 
                   5209:     $idx{udom} = &Apache::loncoursedata::CL_SDOM();
                   5210:     $idx{uname} =  &Apache::loncoursedata::CL_SNAME();
                   5211:     $idx{end} = &Apache::loncoursedata::CL_END();
                   5212:     $idx{start} = &Apache::loncoursedata::CL_START();
                   5213:     $idx{id} = &Apache::loncoursedata::CL_ID();
                   5214:     $idx{section} = &Apache::loncoursedata::CL_SECTION();
                   5215:     $idx{fullname} = &Apache::loncoursedata::CL_FULLNAME();
                   5216:     $idx{status} = &Apache::loncoursedata::CL_STATUS();
                   5217: 
1.290     albertel 5218:     if (grep(/^st$/,@{$roles})) {
1.276     albertel 5219:         my ($classlist,$keylist)=&Apache::loncoursedata::get_classlist($cdom,$cnum);
1.278     raeburn  5220:         my $now = time;
1.277     albertel 5221:         foreach my $student (keys(%{$classlist})) {
1.288     raeburn  5222:             my $match = 0;
1.412     raeburn  5223:             my $secmatch = 0;
1.419     raeburn  5224:             my $section = $$classlist{$student}[$idx{section}];
                   5225:             if ($section eq '') {
                   5226:                 $section = 'none';
                   5227:             }
1.291     albertel 5228:             if ((ref($sections) eq 'ARRAY') && (@{$sections} > 0)) {
1.420     albertel 5229:                 if (grep(/^all$/,@{$sections})) {
1.412     raeburn  5230:                     $secmatch = 1;
                   5231:                 } elsif ($$classlist{$student}[$idx{section}] eq '') {
1.420     albertel 5232:                     if (grep(/^none$/,@{$sections})) {
1.412     raeburn  5233:                         $secmatch = 1;
                   5234:                     }
                   5235:                 } else {  
1.419     raeburn  5236: 		    if (grep(/^\Q$section\E$/,@{$sections})) {
1.412     raeburn  5237: 		        $secmatch = 1;
                   5238:                     }
1.290     albertel 5239: 		}
1.412     raeburn  5240:                 if (!$secmatch) {
                   5241:                     next;
                   5242:                 }
1.419     raeburn  5243:             }
1.420     albertel 5244:             push(@{$seclists{$student}},$section); 
1.275     raeburn  5245:             if (defined($$types{'active'})) {
1.288     raeburn  5246:                 if ($$classlist{$student}[$idx{status}] eq 'Active') {
1.275     raeburn  5247:                     push(@{$$users{st}{$student}},'active');
1.288     raeburn  5248:                     $match = 1;
1.275     raeburn  5249:                 }
                   5250:             }
                   5251:             if (defined($$types{'previous'})) {
1.288     raeburn  5252:                 if ($$classlist{$student}[$idx{end}] <= $now) {
1.275     raeburn  5253:                     push(@{$$users{st}{$student}},'previous');
1.288     raeburn  5254:                     $match = 1;
1.275     raeburn  5255:                 }
                   5256:             }
                   5257:             if (defined($$types{'future'})) {
1.288     raeburn  5258:                 if (($$classlist{$student}[$idx{start}] > $now) && ($$classlist{$student}[$idx{end}] > $now) || ($$classlist{$student}[$idx{end}] == 0) || ($$classlist{$student}[$idx{end}] eq '')) {
1.275     raeburn  5259:                     push(@{$$users{st}{$student}},'future');
1.288     raeburn  5260:                     $match = 1;
1.275     raeburn  5261:                 }
                   5262:             }
1.412     raeburn  5263:             if ($match && ref($userdata) eq 'HASH') {
1.288     raeburn  5264:                 $$userdata{$student} = $$classlist{$student};
                   5265:             }
1.275     raeburn  5266:         }
                   5267:     }
1.412     raeburn  5268:     if ((@{$roles} > 1) || ((@{$roles} == 1) && ($$roles[0] ne "st"))) {
1.439     raeburn  5269:         my %coursepersonnel = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
                   5270:         my $now = time;
                   5271:         foreach my $person (sort(keys(%coursepersonnel))) {
1.288     raeburn  5272:             my $match = 0;
1.412     raeburn  5273:             my $secmatch = 0;
1.439     raeburn  5274:             my $status;
1.412     raeburn  5275:             my ($role,$user,$usec) = ($person =~ /^([^:]*):([^:]+:[^:]+):([^:]*)/);
1.275     raeburn  5276:             $user =~ s/:$//;
1.439     raeburn  5277:             my ($end,$start) = split(/:/,$coursepersonnel{$person});
                   5278:             if ($end == -1 || $start == -1) {
                   5279:                 next;
                   5280:             }
                   5281:             if (($role) && ((grep(/^\Q$role\E$/,@{$roles})) ||
                   5282:                 (grep(/^cr$/,@{$roles}) && $role =~ /^cr\//))) {
1.412     raeburn  5283:                 my ($uname,$udom) = split(/:/,$user);
                   5284:                 if ((ref($sections) eq 'ARRAY') && (@{$sections} > 0)) {
1.420     albertel 5285:                     if (grep(/^all$/,@{$sections})) {
1.412     raeburn  5286:                         $secmatch = 1;
                   5287:                     } elsif ($usec eq '') {
1.420     albertel 5288:                         if (grep(/^none$/,@{$sections})) {
1.412     raeburn  5289:                             $secmatch = 1;
                   5290:                         }
                   5291:                     } else {
                   5292:                         if (grep(/^\Q$usec\E$/,@{$sections})) {
                   5293:                             $secmatch = 1;
                   5294:                         }
                   5295:                     }
                   5296:                     if (!$secmatch) {
                   5297:                         next;
                   5298:                     }
1.288     raeburn  5299:                 }
1.419     raeburn  5300:                 if ($usec eq '') {
                   5301:                     $usec = 'none';
                   5302:                 }
1.275     raeburn  5303:                 if ($uname ne '' && $udom ne '') {
1.503     raeburn  5304:                     if ($end > 0 && $end < $now) {
1.439     raeburn  5305:                         $status = 'previous';
                   5306:                     } elsif ($start > $now) {
                   5307:                         $status = 'future';
                   5308:                     } else {
                   5309:                         $status = 'active';
                   5310:                     }
1.277     albertel 5311:                     foreach my $type (keys(%{$types})) { 
1.275     raeburn  5312:                         if ($status eq $type) {
1.420     albertel 5313:                             if (!grep(/^\Q$type\E$/,@{$$users{$role}{$user}})) {
1.419     raeburn  5314:                                 push(@{$$users{$role}{$user}},$type);
                   5315:                             }
1.288     raeburn  5316:                             $match = 1;
                   5317:                         }
                   5318:                     }
1.419     raeburn  5319:                     if (($match) && (ref($userdata) eq 'HASH')) {
                   5320:                         if (!exists($$userdata{$uname.':'.$udom})) {
                   5321: 			    &get_user_info($udom,$uname,\%idx,$userdata);
                   5322:                         }
1.420     albertel 5323:                         if (!grep(/^\Q$usec\E$/,@{$seclists{$uname.':'.$udom}})) {
1.419     raeburn  5324:                             push(@{$seclists{$uname.':'.$udom}},$usec);
                   5325:                         }
1.275     raeburn  5326:                     }
                   5327:                 }
                   5328:             }
                   5329:         }
1.290     albertel 5330:         if (grep(/^ow$/,@{$roles})) {
1.279     raeburn  5331:             if ((defined($cdom)) && (defined($cnum))) {
                   5332:                 my %csettings = &Apache::lonnet::get('environment',['internal.courseowner'],$cdom,$cnum);
                   5333:                 if ( defined($csettings{'internal.courseowner'}) ) {
                   5334:                     my $owner = $csettings{'internal.courseowner'};
1.439     raeburn  5335:                     if ($owner !~ /^[^:]+:[^:]+$/) {
                   5336:                         $owner = $owner.':'.$cdom;
                   5337:                     }
                   5338:                     @{$$users{'ow'}{$owner}} = 'any';
1.290     albertel 5339:                     if (defined($userdata) && 
                   5340: 			!exists($$userdata{$owner.':'.$cdom})) {
                   5341: 			&get_user_info($cdom,$owner,\%idx,$userdata);
1.420     albertel 5342:                         if (!grep(/^none$/,@{$seclists{$owner.':'.$cdom}})) {
1.419     raeburn  5343:                             push(@{$seclists{$owner.':'.$cdom}},'none');
                   5344:                         }
1.290     albertel 5345: 		    }
1.279     raeburn  5346:                 }
                   5347:             }
                   5348:         }
1.419     raeburn  5349:         foreach my $user (keys(%seclists)) {
                   5350:             @{$seclists{$user}} = (sort {$a <=> $b} @{$seclists{$user}});
                   5351:             $$userdata{$user}[$idx{section}] = join(',',@{$seclists{$user}});
                   5352:         }
1.275     raeburn  5353:     }
                   5354:     return;
                   5355: }
                   5356: 
1.288     raeburn  5357: sub get_user_info {
                   5358:     my ($udom,$uname,$idx,$userdata) = @_;
1.289     albertel 5359:     $$userdata{$uname.':'.$udom}[$$idx{fullname}] = 
                   5360: 	&plainname($uname,$udom,'lastname');
1.291     albertel 5361:     $$userdata{$uname.':'.$udom}[$$idx{uname}] = $uname;
1.297     raeburn  5362:     $$userdata{$uname.':'.$udom}[$$idx{udom}] = $udom;
1.288     raeburn  5363:     return;
                   5364: }
1.275     raeburn  5365: 
1.472     raeburn  5366: ###############################################
                   5367: 
                   5368: =pod
                   5369: 
                   5370: =item * &get_user_quota()
                   5371: 
                   5372: Retrieves quota assigned for storage of portfolio files for a user  
                   5373: 
                   5374: Incoming parameters:
                   5375: 1. user's username
                   5376: 2. user's domain
                   5377: 
                   5378: Returns:
1.536     raeburn  5379: 1. Disk quota (in Mb) assigned to student.
                   5380: 2. (Optional) Type of setting: custom or default
                   5381:    (individually assigned or default for user's 
                   5382:    institutional status).
                   5383: 3. (Optional) - User's institutional status (e.g., faculty, staff
                   5384:    or student - types as defined in localenroll::inst_usertypes 
                   5385:    for user's domain, which determines default quota for user.
                   5386: 4. (Optional) - Default quota which would apply to the user.
1.472     raeburn  5387: 
                   5388: If a value has been stored in the user's environment, 
1.536     raeburn  5389: it will return that, otherwise it returns the maximal default
                   5390: defined for the user's instituional status(es) in the domain.
1.472     raeburn  5391: 
                   5392: =cut
                   5393: 
                   5394: ###############################################
                   5395: 
                   5396: 
                   5397: sub get_user_quota {
                   5398:     my ($uname,$udom) = @_;
1.536     raeburn  5399:     my ($quota,$quotatype,$settingstatus,$defquota);
1.472     raeburn  5400:     if (!defined($udom)) {
                   5401:         $udom = $env{'user.domain'};
                   5402:     }
                   5403:     if (!defined($uname)) {
                   5404:         $uname = $env{'user.name'};
                   5405:     }
                   5406:     if (($udom eq '' || $uname eq '') ||
                   5407:         ($udom eq 'public') && ($uname eq 'public')) {
                   5408:         $quota = 0;
1.536     raeburn  5409:         $quotatype = 'default';
                   5410:         $defquota = 0; 
1.472     raeburn  5411:     } else {
1.536     raeburn  5412:         my $inststatus;
1.472     raeburn  5413:         if ($udom eq $env{'user.domain'} && $uname eq $env{'user.name'}) {
                   5414:             $quota = $env{'environment.portfolioquota'};
1.536     raeburn  5415:             $inststatus = $env{'environment.inststatus'};
1.472     raeburn  5416:         } else {
1.536     raeburn  5417:             my %userenv = 
                   5418:                 &Apache::lonnet::get('environment',['portfolioquota',
                   5419:                                      'inststatus'],$udom,$uname);
1.472     raeburn  5420:             my ($tmp) = keys(%userenv);
                   5421:             if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
                   5422:                 $quota = $userenv{'portfolioquota'};
1.536     raeburn  5423:                 $inststatus = $userenv{'inststatus'};
1.472     raeburn  5424:             } else {
                   5425:                 undef(%userenv);
                   5426:             }
                   5427:         }
1.536     raeburn  5428:         ($defquota,$settingstatus) = &default_quota($udom,$inststatus);
1.472     raeburn  5429:         if ($quota eq '') {
1.536     raeburn  5430:             $quota = $defquota;
                   5431:             $quotatype = 'default';
                   5432:         } else {
                   5433:             $quotatype = 'custom';
1.472     raeburn  5434:         }
                   5435:     }
1.536     raeburn  5436:     if (wantarray) {
                   5437:         return ($quota,$quotatype,$settingstatus,$defquota);
                   5438:     } else {
                   5439:         return $quota;
                   5440:     }
1.472     raeburn  5441: }
                   5442: 
                   5443: ###############################################
                   5444: 
                   5445: =pod
                   5446: 
                   5447: =item * &default_quota()
                   5448: 
1.536     raeburn  5449: Retrieves default quota assigned for storage of user portfolio files,
                   5450: given an (optional) user's institutional status.
1.472     raeburn  5451: 
                   5452: Incoming parameters:
                   5453: 1. domain
1.536     raeburn  5454: 2. (Optional) institutional status(es).  This is a : separated list of 
                   5455:    status types (e.g., faculty, staff, student etc.)
                   5456:    which apply to the user for whom the default is being retrieved.
                   5457:    If the institutional status string in undefined, the domain
                   5458:    default quota will be returned. 
1.472     raeburn  5459: 
                   5460: Returns:
                   5461: 1. Default disk quota (in Mb) for user portfolios in the domain.
1.536     raeburn  5462: 2. (Optional) institutional type which determined the value of the
                   5463:    default quota.
1.472     raeburn  5464: 
                   5465: If a value has been stored in the domain's configuration db,
                   5466: it will return that, otherwise it returns 20 (for backwards 
                   5467: compatibility with domains which have not set up a configuration
                   5468: db file; the original statically defined portfolio quota was 20 Mb). 
                   5469: 
1.536     raeburn  5470: If the user's status includes multiple types (e.g., staff and student),
                   5471: the largest default quota which applies to the user determines the
                   5472: default quota returned.
                   5473: 
1.472     raeburn  5474: =cut
                   5475: 
                   5476: ###############################################
                   5477: 
                   5478: 
                   5479: sub default_quota {
1.536     raeburn  5480:     my ($udom,$inststatus) = @_;
                   5481:     my ($defquota,$settingstatus);
                   5482:     my %quotahash = &Apache::lonnet::get_dom('configuration',
                   5483:                                             ['quota'],$udom);
                   5484:     if (ref($quotahash{'quota'}) eq 'HASH') {
                   5485:         if ($inststatus ne '') {
                   5486:             my @statuses = split(/:/,$inststatus);
                   5487:             foreach my $item (@statuses) {
                   5488:                 if ($quotahash{'quota'}{$item} ne '') {
                   5489:                     if ($defquota eq '') {
                   5490:                         $defquota = $quotahash{'quota'}{$item};
                   5491:                         $settingstatus = $item;
                   5492:                     } elsif ($quotahash{'quota'}{$item} > $defquota) {
                   5493:                         $defquota = $quotahash{'quota'}{$item};
                   5494:                         $settingstatus = $item;
                   5495:                     }
                   5496:                 }
                   5497:             }
                   5498:         }
                   5499:         if ($defquota eq '') {
                   5500:             $defquota = $quotahash{'quota'}{'default'};
                   5501:             $settingstatus = 'default';
                   5502:         }
                   5503:     } else {
                   5504:         $settingstatus = 'default';
                   5505:         $defquota = 20;
                   5506:     }
                   5507:     if (wantarray) {
                   5508:         return ($defquota,$settingstatus);
1.472     raeburn  5509:     } else {
1.536     raeburn  5510:         return $defquota;
1.472     raeburn  5511:     }
                   5512: }
                   5513: 
1.384     raeburn  5514: sub get_secgrprole_info {
                   5515:     my ($cdom,$cnum,$needroles,$type)  = @_;
                   5516:     my %sections_count = &get_sections($cdom,$cnum);
                   5517:     my @sections =  (sort {$a <=> $b} keys(%sections_count));
                   5518:     my %curr_groups = &Apache::longroup::coursegroups($cdom,$cnum);
                   5519:     my @groups = sort(keys(%curr_groups));
                   5520:     my $allroles = [];
                   5521:     my $rolehash;
                   5522:     my $accesshash = {
                   5523:                      active => 'Currently has access',
                   5524:                      future => 'Will have future access',
                   5525:                      previous => 'Previously had access',
                   5526:                   };
                   5527:     if ($needroles) {
                   5528:         $rolehash = {'all' => 'all'};
1.385     albertel 5529:         my %user_roles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
                   5530: 	if (&Apache::lonnet::error(%user_roles)) {
                   5531: 	    undef(%user_roles);
                   5532: 	}
                   5533:         foreach my $item (keys(%user_roles)) {
1.384     raeburn  5534:             my ($role)=split(/\:/,$item,2);
                   5535:             if ($role eq 'cr') { next; }
                   5536:             if ($role =~ /^cr/) {
                   5537:                 $$rolehash{$role} = (split('/',$role))[3];
                   5538:             } else {
                   5539:                 $$rolehash{$role} = &Apache::lonnet::plaintext($role,$type);
                   5540:             }
                   5541:         }
                   5542:         foreach my $key (sort(keys(%{$rolehash}))) {
                   5543:             push(@{$allroles},$key);
                   5544:         }
                   5545:         push (@{$allroles},'st');
                   5546:         $$rolehash{'st'} = &Apache::lonnet::plaintext('st',$type);
                   5547:     }
                   5548:     return (\@sections,\@groups,$allroles,$rolehash,$accesshash);
                   5549: }
                   5550: 
1.555     raeburn  5551: sub user_picker {
1.564.2.6  albertel 5552:     my ($dom,$srch,$forcenewuser,$caller) = @_;
1.555     raeburn  5553:     my $currdom = $dom;
                   5554:     my %curr_selected = (
                   5555:                         srchin => 'dom',
                   5556:                         srchby => 'uname',
                   5557:                       );
                   5558:     my $srchterm;
                   5559:     if (ref($srch) eq 'HASH') {
                   5560:         if ($srch->{'srchby'} ne '') {
                   5561:             $curr_selected{'srchby'} = $srch->{'srchby'};
                   5562:         }
                   5563:         if ($srch->{'srchin'} ne '') {
                   5564:             $curr_selected{'srchin'} = $srch->{'srchin'};
                   5565:         }
                   5566:         if ($srch->{'srchtype'} ne '') {
                   5567:             $curr_selected{'srchtype'} = $srch->{'srchtype'};
                   5568:         }
                   5569:         if ($srch->{'srchdomain'} ne '') {
                   5570:             $currdom = $srch->{'srchdomain'};
                   5571:         }
                   5572:         $srchterm = $srch->{'srchterm'};
                   5573:     }
                   5574:     my %lt=&Apache::lonlocal::texthash(
1.564.2.7! albertel 5575:                     'usr'       => 'Search criteria',
1.563     raeburn  5576:                     'doma'      => 'Domain/institution to search',
1.558     albertel 5577:                     'uname'     => 'username',
                   5578:                     'lastname'  => 'last name',
1.555     raeburn  5579:                     'lastfirst' => 'last name, first name',
1.558     albertel 5580:                     'crs'       => 'in this course',
1.564.2.7! albertel 5581:                     'dom'       => 'in selected domain', 
1.558     albertel 5582:                     'alc'       => 'all LON-CAPA',
1.564.2.7! albertel 5583:                     'instd'     => 'in institutional directory for selected domain',
1.558     albertel 5584:                     'exact'     => 'is',
                   5585:                     'contains'  => 'contains',
1.564.2.5  albertel 5586:                     'begins'    => 'begins with',
1.564.2.6  albertel 5587:                     'youm'      => "You must include some text to search for.",
                   5588:                     'thte'      => "The text you are searching for must contain at least two characters when using a 'begins' type search.",
                   5589:                     'thet'      => "The text you are searching for must contain at least three characters when using a 'contains' type search.",
                   5590:                     'yomc'      => "You must choose a domain when using an institutional directory search.",
                   5591:                     'ymcd'      => "You must choose a domain when using a domain search.",
                   5592:                     'whus'      => "When using searching by last,first you must include a comma as separator between last name and first name.",
                   5593:                     'whse'      => "When searching by last,first you must include at least one character in the first name.",
                   5594:                      'thfo'     => "The following need to be corrected before the search can be run:",
1.555     raeburn  5595:                                        );
1.563     raeburn  5596:     my $domform = &select_dom_form($currdom,'srchdomain',1,1);
                   5597:     my $srchinsel = ' <select name="srchin">';
1.555     raeburn  5598: 
                   5599:     my @srchins = ('crs','dom','alc','instd');
                   5600: 
                   5601:     foreach my $option (@srchins) {
                   5602:         # FIXME 'alc' option unavailable until 
                   5603:         #       loncreateuser::print_user_query_page()
                   5604:         #       has been completed.
                   5605:         next if ($option eq 'alc');
                   5606:         next if ($option eq 'crs' && !$env{'request.course.id'});
1.563     raeburn  5607:         if ($curr_selected{'srchin'} eq $option) {
                   5608:             $srchinsel .= ' 
                   5609:    <option value="'.$option.'" selected="selected">'.$lt{$option}.'</option>';
                   5610:         } else {
                   5611:             $srchinsel .= '
                   5612:    <option value="'.$option.'">'.$lt{$option}.'</option>';
                   5613:         }
1.555     raeburn  5614:     }
1.563     raeburn  5615:     $srchinsel .= "\n  </select>\n";
1.555     raeburn  5616: 
                   5617:     my $srchbysel =  ' <select name="srchby">';
                   5618:     foreach my $option ('uname','lastname','lastfirst') {
                   5619:         if ($curr_selected{'srchby'} eq $option) {
                   5620:             $srchbysel .= '
                   5621:    <option value="'.$option.'" selected="selected">'.$lt{$option}.'</option>';
                   5622:         } else {
                   5623:             $srchbysel .= '
                   5624:    <option value="'.$option.'">'.$lt{$option}.'</option>';
                   5625:          }
                   5626:     }
                   5627:     $srchbysel .= "\n  </select>\n";
                   5628: 
                   5629:     my $srchtypesel = ' <select name="srchtype">';
1.564.2.5  albertel 5630:     foreach my $option ('exact','begins','contains') {
1.555     raeburn  5631:         if ($curr_selected{'srchtype'} eq $option) {
                   5632:             $srchtypesel .= '
                   5633:    <option value="'.$option.'" selected="selected">'.$lt{$option}.'</option>';
                   5634:         } else {
                   5635:             $srchtypesel .= '
                   5636:    <option value="'.$option.'">'.$lt{$option}.'</option>';
                   5637:         }
                   5638:     }
                   5639:     $srchtypesel .= "\n  </select>\n";
                   5640: 
1.558     albertel 5641:     my ($newuserscript,$new_user_create);
1.556     raeburn  5642: 
                   5643:     if ($forcenewuser) {
1.564.2.6  albertel 5644: 	$new_user_create = '<p> <input type="submit" name="forcenew" value="'.&HTML::Entities::encode(&mt('Make new user "[_1]"',$srchterm),'<>&"').'" onclick="javascript:setSearch(\'1\','.$caller.');" /> </p>';
1.556     raeburn  5645:         $newuserscript = <<"ENDSCRIPT";
                   5646: 
1.564.2.6  albertel 5647: function setSearch(createnew,callingForm) {
1.556     raeburn  5648:     if (createnew == 1) {
1.564.2.6  albertel 5649:         for (var i=0; i<callingForm.srchby.length; i++) {
                   5650:             if (callingForm.srchby.options[i].value == 'uname') {
                   5651:                 callingForm.srchby.selectedIndex = i;
1.556     raeburn  5652:             }
                   5653:         }
1.564.2.6  albertel 5654:         for (var i=0; i<callingForm.srchin.length; i++) {
                   5655:             if ( callingForm.srchin.options[i].value == 'dom') {
                   5656: 		callingForm.srchin.selectedIndex = i;
1.556     raeburn  5657:             }
                   5658:         }
1.564.2.6  albertel 5659:         for (var i=0; i<callingForm.srchtype.length; i++) {
                   5660:             if (callingForm.srchtype.options[i].value == 'exact') {
                   5661:                 callingForm.srchtype.selectedIndex = i;
1.556     raeburn  5662:             }
                   5663:         }
1.564.2.6  albertel 5664:         for (var i=0; i<callingForm.srchdomain.length; i++) {
                   5665:             if (callingForm.srchdomain.options[i].value == '$env{'request.role.domain'}') {
                   5666:                 callingForm.srchdomain.selectedIndex = i;
1.556     raeburn  5667:             }
                   5668:         }
                   5669:     }
                   5670: }
                   5671: ENDSCRIPT
1.558     albertel 5672: 
1.556     raeburn  5673:     }
                   5674: 
1.555     raeburn  5675:     my $output = <<"END_BLOCK";
1.556     raeburn  5676: <script type="text/javascript">
1.564.2.6  albertel 5677: function validateEntry(callingForm) {
1.558     albertel 5678: 
1.556     raeburn  5679:     var checkok = 1;
1.558     albertel 5680:     var srchin;
1.564.2.6  albertel 5681:     for (var i=0; i<callingForm.srchin.length; i++) {
                   5682: 	if ( callingForm.srchin[i].checked ) {
                   5683: 	    srchin = callingForm.srchin[i].value;
1.558     albertel 5684: 	}
                   5685:     }
                   5686: 
1.564.2.6  albertel 5687:     var srchtype = callingForm.srchtype.options[callingForm.srchtype.selectedIndex].value;
                   5688:     var srchby = callingForm.srchby.options[callingForm.srchby.selectedIndex].value;
                   5689:     var srchdomain = callingForm.srchdomain.options[callingForm.srchdomain.selectedIndex].value;
                   5690:     var srchterm =  callingForm.srchterm.value;
                   5691:     var srchin = callingForm.srchin.options[callingForm.srchin.selectedIndex].value;
1.556     raeburn  5692:     var msg = "";
                   5693: 
                   5694:     if (srchterm == "") {
                   5695:         checkok = 0;
1.564.2.6  albertel 5696:         msg += "$lt{'youm'}\\n";
1.556     raeburn  5697:     }
                   5698: 
1.564.2.5  albertel 5699:     if (srchtype== 'begins') {
                   5700:         if (srchterm.length < 2) {
                   5701:             checkok = 0;
1.564.2.6  albertel 5702:             msg += "$lt{'thte'}\\n";
1.564.2.5  albertel 5703:         }
                   5704:     }
                   5705: 
1.556     raeburn  5706:     if (srchtype== 'contains') {
                   5707:         if (srchterm.length < 3) {
                   5708:             checkok = 0;
1.564.2.6  albertel 5709:             msg += "$lt{'thet'}\\n";
1.556     raeburn  5710:         }
                   5711:     }
                   5712:     if (srchin == 'instd') {
                   5713:         if (srchdomain == '') {
                   5714:             checkok = 0;
1.564.2.6  albertel 5715:             msg += "$lt{'yomc'}\\n";
1.556     raeburn  5716:         }
                   5717:     }
                   5718:     if (srchin == 'dom') {
                   5719:         if (srchdomain == '') {
                   5720:             checkok = 0;
1.564.2.6  albertel 5721:             msg += "$lt{'ymcd'}\\n";
1.556     raeburn  5722:         }
                   5723:     }
                   5724:     if (srchby == 'lastfirst') {
                   5725:         if (srchterm.indexOf(",") == -1) {
                   5726:             checkok = 0;
1.564.2.6  albertel 5727:             msg += "$lt{'whus'}\\n";
1.556     raeburn  5728:         }
                   5729:         if (srchterm.indexOf(",") == srchterm.length -1) {
                   5730:             checkok = 0;
1.564.2.6  albertel 5731:             msg += "$lt{'whse'}\\n";
1.556     raeburn  5732:         }
                   5733:     }
                   5734:     if (checkok == 0) {
1.564.2.6  albertel 5735:         alert("$lt{'thfo'}\\n"+msg);
1.556     raeburn  5736:         return;
                   5737:     }
                   5738:     if (checkok == 1) {
1.564.2.6  albertel 5739:         callingForm.submit();
1.556     raeburn  5740:     }
                   5741: }
                   5742: 
                   5743: $newuserscript
                   5744: 
                   5745: </script>
1.558     albertel 5746: 
                   5747: $new_user_create
                   5748: 
1.555     raeburn  5749: <table>
1.558     albertel 5750:  <tr>
1.564.2.7! albertel 5751:   <td>$lt{'doma'}:</td>
        !          5752:   <td>$domform</td>
        !          5753:   </td>
        !          5754:  </tr>
        !          5755:  <tr>
        !          5756:   <td>$lt{'usr'}:</td>
1.563     raeburn  5757:   <td>$srchbysel
                   5758:       $srchtypesel 
                   5759:       <input type="text" size="15" name="srchterm" value="$srchterm" />
1.564     albertel 5760:       $srchinsel 
1.563     raeburn  5761:   </td>
                   5762:  </tr>
1.555     raeburn  5763: </table>
                   5764: <br />
                   5765: END_BLOCK
1.558     albertel 5766: 
1.555     raeburn  5767:     return $output;
                   5768: }
                   5769: 
1.556     raeburn  5770: 
                   5771: 
1.112     bowersj2 5772: =pod
                   5773: 
1.549     albertel 5774: =back
                   5775: 
                   5776: =head1 HTTP Helpers
                   5777: 
                   5778: =over 4
                   5779: 
1.112     bowersj2 5780: =item * get_unprocessed_cgi($query,$possible_names)
                   5781: 
1.258     albertel 5782: Modify the %env hash to contain unprocessed CGI form parameters held in
1.112     bowersj2 5783: $query.  The parameters listed in $possible_names (an array reference),
1.258     albertel 5784: will be set in $env{'form.name'} if they do not already exist.
1.112     bowersj2 5785: 
                   5786: Typically called with $ENV{'QUERY_STRING'} as the first parameter.  
                   5787: $possible_names is an ref to an array of form element names.  As an example:
                   5788: get_unprocessed_cgi($ENV{'QUERY_STRING'},['uname','udom']);
1.258     albertel 5789: will result in $env{'form.uname'} and $env{'form.udom'} being set.
1.112     bowersj2 5790: 
                   5791: =cut
1.1       albertel 5792: 
1.6       albertel 5793: sub get_unprocessed_cgi {
1.25      albertel 5794:   my ($query,$possible_names)= @_;
1.26      matthew  5795:   # $Apache::lonxml::debug=1;
1.356     albertel 5796:   foreach my $pair (split(/&/,$query)) {
                   5797:     my ($name, $value) = split(/=/,$pair);
1.369     www      5798:     $name = &unescape($name);
1.25      albertel 5799:     if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) {
                   5800:       $value =~ tr/+/ /;
                   5801:       $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
1.258     albertel 5802:       unless (defined($env{'form.'.$name})) { &add_to_env('form.'.$name,$value) };
1.25      albertel 5803:     }
1.16      harris41 5804:   }
1.6       albertel 5805: }
                   5806: 
1.112     bowersj2 5807: =pod
                   5808: 
                   5809: =item * cacheheader() 
                   5810: 
                   5811: returns cache-controlling header code
                   5812: 
                   5813: =cut
                   5814: 
1.7       albertel 5815: sub cacheheader {
1.258     albertel 5816:     unless ($env{'request.method'} eq 'GET') { return ''; }
1.216     albertel 5817:     my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
                   5818:     my $output .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" />
1.7       albertel 5819:                 <meta HTTP-EQUIV="Cache-control" CONTENT="no-cache" />
                   5820:                 <meta HTTP-EQUIV="Pragma" CONTENT="no-cache" />';
1.216     albertel 5821:     return $output;
1.7       albertel 5822: }
                   5823: 
1.112     bowersj2 5824: =pod
                   5825: 
                   5826: =item * no_cache($r) 
                   5827: 
                   5828: specifies header code to not have cache
                   5829: 
                   5830: =cut
                   5831: 
1.9       albertel 5832: sub no_cache {
1.216     albertel 5833:     my ($r) = @_;
                   5834:     if ($ENV{'REQUEST_METHOD'} ne 'GET' &&
1.258     albertel 5835: 	$env{'request.method'} ne 'GET') { return ''; }
1.216     albertel 5836:     my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime(time));
                   5837:     $r->no_cache(1);
                   5838:     $r->header_out("Expires" => $date);
                   5839:     $r->header_out("Pragma" => "no-cache");
1.123     www      5840: }
                   5841: 
                   5842: sub content_type {
1.181     albertel 5843:     my ($r,$type,$charset) = @_;
1.299     foxr     5844:     if ($r) {
                   5845: 	#  Note that printout.pl calls this with undef for $r.
                   5846: 	&no_cache($r);
                   5847:     }
1.258     albertel 5848:     if ($env{'browser.mathml'} && $type eq 'text/html') { $type='text/xml'; }
1.181     albertel 5849:     unless ($charset) {
                   5850: 	$charset=&Apache::lonlocal::current_encoding;
                   5851:     }
                   5852:     if ($charset) { $type.='; charset='.$charset; }
                   5853:     if ($r) {
                   5854: 	$r->content_type($type);
                   5855:     } else {
                   5856: 	print("Content-type: $type\n\n");
                   5857:     }
1.9       albertel 5858: }
1.25      albertel 5859: 
1.112     bowersj2 5860: =pod
                   5861: 
                   5862: =item * add_to_env($name,$value) 
                   5863: 
1.258     albertel 5864: adds $name to the %env hash with value
1.112     bowersj2 5865: $value, if $name already exists, the entry is converted to an array
                   5866: reference and $value is added to the array.
                   5867: 
                   5868: =cut
                   5869: 
1.25      albertel 5870: sub add_to_env {
                   5871:   my ($name,$value)=@_;
1.258     albertel 5872:   if (defined($env{$name})) {
                   5873:     if (ref($env{$name})) {
1.25      albertel 5874:       #already have multiple values
1.258     albertel 5875:       push(@{ $env{$name} },$value);
1.25      albertel 5876:     } else {
                   5877:       #first time seeing multiple values, convert hash entry to an arrayref
1.258     albertel 5878:       my $first=$env{$name};
                   5879:       undef($env{$name});
                   5880:       push(@{ $env{$name} },$first,$value);
1.25      albertel 5881:     }
                   5882:   } else {
1.258     albertel 5883:     $env{$name}=$value;
1.25      albertel 5884:   }
1.31      albertel 5885: }
1.149     albertel 5886: 
                   5887: =pod
                   5888: 
                   5889: =item * get_env_multiple($name) 
                   5890: 
1.258     albertel 5891: gets $name from the %env hash, it seemlessly handles the cases where multiple
1.149     albertel 5892: values may be defined and end up as an array ref.
                   5893: 
                   5894: returns an array of values
                   5895: 
                   5896: =cut
                   5897: 
                   5898: sub get_env_multiple {
                   5899:     my ($name) = @_;
                   5900:     my @values;
1.258     albertel 5901:     if (defined($env{$name})) {
1.149     albertel 5902:         # exists is it an array
1.258     albertel 5903:         if (ref($env{$name})) {
                   5904:             @values=@{ $env{$name} };
1.149     albertel 5905:         } else {
1.258     albertel 5906:             $values[0]=$env{$name};
1.149     albertel 5907:         }
                   5908:     }
                   5909:     return(@values);
                   5910: }
                   5911: 
1.31      albertel 5912: 
1.41      ng       5913: =pod
1.45      matthew  5914: 
1.464     albertel 5915: =back
1.41      ng       5916: 
1.112     bowersj2 5917: =head1 CSV Upload/Handling functions
1.38      albertel 5918: 
1.41      ng       5919: =over 4
                   5920: 
1.112     bowersj2 5921: =item * upfile_store($r)
1.41      ng       5922: 
                   5923: Store uploaded file, $r should be the HTTP Request object,
1.258     albertel 5924: needs $env{'form.upfile'}
1.41      ng       5925: returns $datatoken to be put into hidden field
                   5926: 
                   5927: =cut
1.31      albertel 5928: 
                   5929: sub upfile_store {
                   5930:     my $r=shift;
1.258     albertel 5931:     $env{'form.upfile'}=~s/\r/\n/gs;
                   5932:     $env{'form.upfile'}=~s/\f/\n/gs;
                   5933:     $env{'form.upfile'}=~s/\n+/\n/gs;
                   5934:     $env{'form.upfile'}=~s/\n+$//gs;
1.31      albertel 5935: 
1.258     albertel 5936:     my $datatoken=$env{'user.name'}.'_'.$env{'user.domain'}.
                   5937: 	'_enroll_'.$env{'request.course.id'}.'_'.time.'_'.$$;
1.31      albertel 5938:     {
1.158     raeburn  5939:         my $datafile = $r->dir_config('lonDaemons').
                   5940:                            '/tmp/'.$datatoken.'.tmp';
                   5941:         if ( open(my $fh,">$datafile") ) {
1.258     albertel 5942:             print $fh $env{'form.upfile'};
1.158     raeburn  5943:             close($fh);
                   5944:         }
1.31      albertel 5945:     }
                   5946:     return $datatoken;
                   5947: }
                   5948: 
1.56      matthew  5949: =pod
                   5950: 
1.112     bowersj2 5951: =item * load_tmp_file($r)
1.41      ng       5952: 
                   5953: Load uploaded file from tmp, $r should be the HTTP Request object,
1.258     albertel 5954: needs $env{'form.datatoken'},
                   5955: sets $env{'form.upfile'} to the contents of the file
1.41      ng       5956: 
                   5957: =cut
1.31      albertel 5958: 
                   5959: sub load_tmp_file {
                   5960:     my $r=shift;
                   5961:     my @studentdata=();
                   5962:     {
1.158     raeburn  5963:         my $studentfile = $r->dir_config('lonDaemons').
1.258     albertel 5964:                               '/tmp/'.$env{'form.datatoken'}.'.tmp';
1.158     raeburn  5965:         if ( open(my $fh,"<$studentfile") ) {
                   5966:             @studentdata=<$fh>;
                   5967:             close($fh);
                   5968:         }
1.31      albertel 5969:     }
1.258     albertel 5970:     $env{'form.upfile'}=join('',@studentdata);
1.31      albertel 5971: }
                   5972: 
1.56      matthew  5973: =pod
                   5974: 
1.112     bowersj2 5975: =item * upfile_record_sep()
1.41      ng       5976: 
                   5977: Separate uploaded file into records
                   5978: returns array of records,
1.258     albertel 5979: needs $env{'form.upfile'} and $env{'form.upfiletype'}
1.41      ng       5980: 
                   5981: =cut
1.31      albertel 5982: 
                   5983: sub upfile_record_sep {
1.258     albertel 5984:     if ($env{'form.upfiletype'} eq 'xml') {
1.31      albertel 5985:     } else {
1.248     albertel 5986: 	my @records;
1.258     albertel 5987: 	foreach my $line (split(/\n/,$env{'form.upfile'})) {
1.248     albertel 5988: 	    if ($line=~/^\s*$/) { next; }
                   5989: 	    push(@records,$line);
                   5990: 	}
                   5991: 	return @records;
1.31      albertel 5992:     }
                   5993: }
                   5994: 
1.56      matthew  5995: =pod
                   5996: 
1.112     bowersj2 5997: =item * record_sep($record)
1.41      ng       5998: 
1.258     albertel 5999: Separate a record into fields $record should be an item from the upfile_record_sep(), needs $env{'form.upfiletype'}
1.41      ng       6000: 
                   6001: =cut
                   6002: 
1.263     www      6003: sub takeleft {
                   6004:     my $index=shift;
                   6005:     return substr('0000'.$index,-4,4);
                   6006: }
                   6007: 
1.31      albertel 6008: sub record_sep {
                   6009:     my $record=shift;
                   6010:     my %components=();
1.258     albertel 6011:     if ($env{'form.upfiletype'} eq 'xml') {
                   6012:     } elsif ($env{'form.upfiletype'} eq 'space') {
1.31      albertel 6013:         my $i=0;
1.356     albertel 6014:         foreach my $field (split(/\s+/,$record)) {
1.31      albertel 6015:             $field=~s/^(\"|\')//;
                   6016:             $field=~s/(\"|\')$//;
1.263     www      6017:             $components{&takeleft($i)}=$field;
1.31      albertel 6018:             $i++;
                   6019:         }
1.258     albertel 6020:     } elsif ($env{'form.upfiletype'} eq 'tab') {
1.31      albertel 6021:         my $i=0;
1.356     albertel 6022:         foreach my $field (split(/\t/,$record)) {
1.31      albertel 6023:             $field=~s/^(\"|\')//;
                   6024:             $field=~s/(\"|\')$//;
1.263     www      6025:             $components{&takeleft($i)}=$field;
1.31      albertel 6026:             $i++;
                   6027:         }
                   6028:     } else {
1.561     www      6029:         my $separator=',';
1.480     banghart 6030:         if ($env{'form.upfiletype'} eq 'semisv') {
1.561     www      6031:             $separator=';';
1.480     banghart 6032:         }
1.31      albertel 6033:         my $i=0;
1.561     www      6034: # the character we are looking for to indicate the end of a quote or a record 
                   6035:         my $looking_for=$separator;
                   6036: # do not add the characters to the fields
                   6037:         my $ignore=0;
                   6038: # we just encountered a separator (or the beginning of the record)
                   6039:         my $just_found_separator=1;
                   6040: # store the field we are working on here
                   6041:         my $field='';
                   6042: # work our way through all characters in record
                   6043:         foreach my $character ($record=~/(.)/g) {
                   6044:             if ($character eq $looking_for) {
                   6045:                if ($character ne $separator) {
                   6046: # Found the end of a quote, again looking for separator
                   6047:                   $looking_for=$separator;
                   6048:                   $ignore=1;
                   6049:                } else {
                   6050: # Found a separator, store away what we got
                   6051:                   $components{&takeleft($i)}=$field;
                   6052: 	          $i++;
                   6053:                   $just_found_separator=1;
                   6054:                   $ignore=0;
                   6055:                   $field='';
                   6056:                }
                   6057:                next;
                   6058:             }
                   6059: # single or double quotation marks after a separator indicate beginning of a quote
                   6060: # we are now looking for the end of the quote and need to ignore separators
                   6061:             if ((($character eq '"') || ($character eq "'")) && ($just_found_separator))  {
                   6062:                $looking_for=$character;
                   6063:                next;
                   6064:             }
                   6065: # ignore would be true after we reached the end of a quote
                   6066:             if ($ignore) { next; }
                   6067:             if (($just_found_separator) && ($character=~/\s/)) { next; }
                   6068:             $field.=$character;
                   6069:             $just_found_separator=0; 
1.31      albertel 6070:         }
1.561     www      6071: # catch the very last entry, since we never encountered the separator
                   6072:         $components{&takeleft($i)}=$field;
1.31      albertel 6073:     }
                   6074:     return %components;
                   6075: }
                   6076: 
1.144     matthew  6077: ######################################################
                   6078: ######################################################
                   6079: 
1.56      matthew  6080: =pod
                   6081: 
1.112     bowersj2 6082: =item * upfile_select_html()
1.41      ng       6083: 
1.144     matthew  6084: Return HTML code to select a file from the users machine and specify 
                   6085: the file type.
1.41      ng       6086: 
                   6087: =cut
                   6088: 
1.144     matthew  6089: ######################################################
                   6090: ######################################################
1.31      albertel 6091: sub upfile_select_html {
1.144     matthew  6092:     my %Types = (
                   6093:                  csv   => &mt('CSV (comma separated values, spreadsheet)'),
1.480     banghart 6094:                  semisv => &mt('Semicolon separated values'),
1.144     matthew  6095:                  space => &mt('Space separated'),
                   6096:                  tab   => &mt('Tabulator separated'),
                   6097: #                 xml   => &mt('HTML/XML'),
                   6098:                  );
                   6099:     my $Str = '<input type="file" name="upfile" size="50" />'.
                   6100:         '<br />Type: <select name="upfiletype">';
                   6101:     foreach my $type (sort(keys(%Types))) {
                   6102:         $Str .= '<option value="'.$type.'" >'.$Types{$type}."</option>\n";
                   6103:     }
                   6104:     $Str .= "</select>\n";
                   6105:     return $Str;
1.31      albertel 6106: }
                   6107: 
1.301     albertel 6108: sub get_samples {
                   6109:     my ($records,$toget) = @_;
                   6110:     my @samples=({});
                   6111:     my $got=0;
                   6112:     foreach my $rec (@$records) {
                   6113: 	my %temp = &record_sep($rec);
                   6114: 	if (! grep(/\S/, values(%temp))) { next; }
                   6115: 	if (%temp) {
                   6116: 	    $samples[$got]=\%temp;
                   6117: 	    $got++;
                   6118: 	    if ($got == $toget) { last; }
                   6119: 	}
                   6120:     }
                   6121:     return \@samples;
                   6122: }
                   6123: 
1.144     matthew  6124: ######################################################
                   6125: ######################################################
                   6126: 
1.56      matthew  6127: =pod
                   6128: 
1.112     bowersj2 6129: =item * csv_print_samples($r,$records)
1.41      ng       6130: 
                   6131: Prints a table of sample values from each column uploaded $r is an
                   6132: Apache Request ref, $records is an arrayref from
                   6133: &Apache::loncommon::upfile_record_sep
                   6134: 
                   6135: =cut
                   6136: 
1.144     matthew  6137: ######################################################
                   6138: ######################################################
1.31      albertel 6139: sub csv_print_samples {
                   6140:     my ($r,$records) = @_;
1.301     albertel 6141:     my $samples = &get_samples($records,3);
                   6142: 
1.144     matthew  6143:     $r->print(&mt('Samples').'<br /><table border="2"><tr>');
1.356     albertel 6144:     foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) { 
                   6145:         $r->print('<th>'.&mt('Column&nbsp;[_1]',($sample+1)).'</th>'); }
1.31      albertel 6146:     $r->print('</tr>');
1.301     albertel 6147:     foreach my $hash (@$samples) {
1.31      albertel 6148: 	$r->print('<tr>');
1.356     albertel 6149: 	foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
1.31      albertel 6150: 	    $r->print('<td>');
1.356     albertel 6151: 	    if (defined($$hash{$sample})) { $r->print($$hash{$sample}); }
1.31      albertel 6152: 	    $r->print('</td>');
                   6153: 	}
                   6154: 	$r->print('</tr>');
                   6155:     }
                   6156:     $r->print('</tr></table><br />'."\n");
                   6157: }
                   6158: 
1.144     matthew  6159: ######################################################
                   6160: ######################################################
                   6161: 
1.56      matthew  6162: =pod
                   6163: 
1.112     bowersj2 6164: =item * csv_print_select_table($r,$records,$d)
1.41      ng       6165: 
                   6166: Prints a table to create associations between values and table columns.
1.144     matthew  6167: 
1.41      ng       6168: $r is an Apache Request ref,
                   6169: $records is an arrayref from &Apache::loncommon::upfile_record_sep,
1.174     matthew  6170: $d is an array of 2 element arrays (internal name, displayed name,defaultcol)
1.41      ng       6171: 
                   6172: =cut
                   6173: 
1.144     matthew  6174: ######################################################
                   6175: ######################################################
1.31      albertel 6176: sub csv_print_select_table {
                   6177:     my ($r,$records,$d) = @_;
1.301     albertel 6178:     my $i=0;
                   6179:     my $samples = &get_samples($records,1);
1.144     matthew  6180:     $r->print(&mt('Associate columns with student attributes.')."\n".
                   6181: 	     '<table border="2"><tr>'.
                   6182:               '<th>'.&mt('Attribute').'</th>'.
                   6183:               '<th>'.&mt('Column').'</th></tr>'."\n");
1.356     albertel 6184:     foreach my $array_ref (@$d) {
                   6185: 	my ($value,$display,$defaultcol)=@{ $array_ref };
1.31      albertel 6186: 	$r->print('<tr><td>'.$display.'</td>');
                   6187: 
                   6188: 	$r->print('<td><select name=f'.$i.
1.32      matthew  6189: 		  ' onchange="javascript:flip(this.form,'.$i.');">');
1.31      albertel 6190: 	$r->print('<option value="none"></option>');
1.356     albertel 6191: 	foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
                   6192: 	    $r->print('<option value="'.$sample.'"'.
                   6193:                       ($sample eq $defaultcol ? ' selected="selected" ' : '').
                   6194:                       '>Column '.($sample+1).'</option>');
1.31      albertel 6195: 	}
                   6196: 	$r->print('</select></td></tr>'."\n");
                   6197: 	$i++;
                   6198:     }
                   6199:     $i--;
                   6200:     return $i;
                   6201: }
1.56      matthew  6202: 
1.144     matthew  6203: ######################################################
                   6204: ######################################################
                   6205: 
1.56      matthew  6206: =pod
1.31      albertel 6207: 
1.112     bowersj2 6208: =item * csv_samples_select_table($r,$records,$d)
1.41      ng       6209: 
                   6210: Prints a table of sample values from the upload and can make associate samples to internal names.
                   6211: 
                   6212: $r is an Apache Request ref,
                   6213: $records is an arrayref from &Apache::loncommon::upfile_record_sep,
                   6214: $d is an array of 2 element arrays (internal name, displayed name)
                   6215: 
                   6216: =cut
                   6217: 
1.144     matthew  6218: ######################################################
                   6219: ######################################################
1.31      albertel 6220: sub csv_samples_select_table {
                   6221:     my ($r,$records,$d) = @_;
                   6222:     my $i=0;
1.144     matthew  6223:     #
1.301     albertel 6224:     my $samples = &get_samples($records,3);
1.144     matthew  6225:     $r->print('<table border=2><tr><th>'.
                   6226:               &mt('Field').'</th><th>'.&mt('Samples').'</th></tr>');
1.301     albertel 6227: 
                   6228:     foreach my $key (sort(keys(%{ $samples->[0] }))) {
1.144     matthew  6229: 	$r->print('<tr><td><select name="f'.$i.'"'.
1.32      matthew  6230: 		  ' onchange="javascript:flip(this.form,'.$i.');">');
1.301     albertel 6231: 	foreach my $option (@$d) {
                   6232: 	    my ($value,$display,$defaultcol)=@{ $option };
1.174     matthew  6233: 	    $r->print('<option value="'.$value.'"'.
1.253     albertel 6234:                       ($i eq $defaultcol ? ' selected="selected" ':'').'>'.
1.174     matthew  6235:                       $display.'</option>');
1.31      albertel 6236: 	}
                   6237: 	$r->print('</select></td><td>');
1.301     albertel 6238: 	foreach my $line (0..2) {
                   6239: 	    if (defined($samples->[$line]{$key})) { 
                   6240: 		$r->print($samples->[$line]{$key}."<br />\n"); 
                   6241: 	    }
                   6242: 	}
1.31      albertel 6243: 	$r->print('</td></tr>');
                   6244: 	$i++;
                   6245:     }
                   6246:     $i--;
                   6247:     return($i);
1.115     matthew  6248: }
                   6249: 
1.144     matthew  6250: ######################################################
                   6251: ######################################################
                   6252: 
1.115     matthew  6253: =pod
                   6254: 
                   6255: =item clean_excel_name($name)
                   6256: 
                   6257: Returns a replacement for $name which does not contain any illegal characters.
                   6258: 
                   6259: =cut
                   6260: 
1.144     matthew  6261: ######################################################
                   6262: ######################################################
1.115     matthew  6263: sub clean_excel_name {
                   6264:     my ($name) = @_;
                   6265:     $name =~ s/[:\*\?\/\\]//g;
                   6266:     if (length($name) > 31) {
                   6267:         $name = substr($name,0,31);
                   6268:     }
                   6269:     return $name;
1.25      albertel 6270: }
1.84      albertel 6271: 
1.85      albertel 6272: =pod
                   6273: 
1.112     bowersj2 6274: =item * check_if_partid_hidden($id,$symb,$udom,$uname)
1.85      albertel 6275: 
                   6276: Returns either 1 or undef
                   6277: 
                   6278: 1 if the part is to be hidden, undef if it is to be shown
                   6279: 
                   6280: Arguments are:
                   6281: 
                   6282: $id the id of the part to be checked
                   6283: $symb, optional the symb of the resource to check
                   6284: $udom, optional the domain of the user to check for
                   6285: $uname, optional the username of the user to check for
                   6286: 
                   6287: =cut
1.84      albertel 6288: 
                   6289: sub check_if_partid_hidden {
                   6290:     my ($id,$symb,$udom,$uname) = @_;
1.133     albertel 6291:     my $hiddenparts=&Apache::lonnet::EXT('resource.0.hiddenparts',
1.84      albertel 6292: 					 $symb,$udom,$uname);
1.141     albertel 6293:     my $truth=1;
                   6294:     #if the string starts with !, then the list is the list to show not hide
                   6295:     if ($hiddenparts=~s/^\s*!//) { $truth=undef; }
1.84      albertel 6296:     my @hiddenlist=split(/,/,$hiddenparts);
                   6297:     foreach my $checkid (@hiddenlist) {
1.141     albertel 6298: 	if ($checkid =~ /^\s*\Q$id\E\s*$/) { return $truth; }
1.84      albertel 6299:     }
1.141     albertel 6300:     return !$truth;
1.84      albertel 6301: }
1.127     matthew  6302: 
1.138     matthew  6303: 
                   6304: ############################################################
                   6305: ############################################################
                   6306: 
                   6307: =pod
                   6308: 
1.157     matthew  6309: =back 
                   6310: 
1.138     matthew  6311: =head1 cgi-bin script and graphing routines
                   6312: 
1.157     matthew  6313: =over 4
                   6314: 
1.138     matthew  6315: =item get_cgi_id
                   6316: 
                   6317: Inputs: none
                   6318: 
                   6319: Returns an id which can be used to pass environment variables
                   6320: to various cgi-bin scripts.  These environment variables will
                   6321: be removed from the users environment after a given time by
                   6322: the routine &Apache::lonnet::transfer_profile_to_env.
                   6323: 
                   6324: =cut
                   6325: 
                   6326: ############################################################
                   6327: ############################################################
1.152     albertel 6328: my $uniq=0;
1.136     matthew  6329: sub get_cgi_id {
1.154     albertel 6330:     $uniq=($uniq+1)%100000;
1.280     albertel 6331:     return (time.'_'.$$.'_'.$uniq);
1.136     matthew  6332: }
                   6333: 
1.127     matthew  6334: ############################################################
                   6335: ############################################################
                   6336: 
                   6337: =pod
                   6338: 
1.134     matthew  6339: =item DrawBarGraph
1.127     matthew  6340: 
1.138     matthew  6341: Facilitates the plotting of data in a (stacked) bar graph.
                   6342: Puts plot definition data into the users environment in order for 
                   6343: graph.png to plot it.  Returns an <img> tag for the plot.
                   6344: The bars on the plot are labeled '1','2',...,'n'.
                   6345: 
                   6346: Inputs:
                   6347: 
                   6348: =over 4
                   6349: 
                   6350: =item $Title: string, the title of the plot
                   6351: 
                   6352: =item $xlabel: string, text describing the X-axis of the plot
                   6353: 
                   6354: =item $ylabel: string, text describing the Y-axis of the plot
                   6355: 
                   6356: =item $Max: scalar, the maximum Y value to use in the plot
                   6357: If $Max is < any data point, the graph will not be rendered.
                   6358: 
1.140     matthew  6359: =item $colors: array ref holding the colors to be used for the data sets when
1.138     matthew  6360: they are plotted.  If undefined, default values will be used.
                   6361: 
1.178     matthew  6362: =item $labels: array ref holding the labels to use on the x-axis for the bars.
                   6363: 
1.138     matthew  6364: =item @Values: An array of array references.  Each array reference holds data
                   6365: to be plotted in a stacked bar chart.
                   6366: 
1.239     matthew  6367: =item If the final element of @Values is a hash reference the key/value
                   6368: pairs will be added to the graph definition.
                   6369: 
1.138     matthew  6370: =back
                   6371: 
                   6372: Returns:
                   6373: 
                   6374: An <img> tag which references graph.png and the appropriate identifying
                   6375: information for the plot.
                   6376: 
1.127     matthew  6377: =cut
                   6378: 
                   6379: ############################################################
                   6380: ############################################################
1.134     matthew  6381: sub DrawBarGraph {
1.178     matthew  6382:     my ($Title,$xlabel,$ylabel,$Max,$colors,$labels,@Values)=@_;
1.134     matthew  6383:     #
                   6384:     if (! defined($colors)) {
                   6385:         $colors = ['#33ff00', 
                   6386:                   '#0033cc', '#990000', '#aaaa66', '#663399', '#ff9933',
                   6387:                   '#66ccff', '#ff9999', '#cccc33', '#660000', '#33cc66',
                   6388:                   ]; 
                   6389:     }
1.228     matthew  6390:     my $extra_settings = {};
                   6391:     if (ref($Values[-1]) eq 'HASH') {
                   6392:         $extra_settings = pop(@Values);
                   6393:     }
1.127     matthew  6394:     #
1.136     matthew  6395:     my $identifier = &get_cgi_id();
                   6396:     my $id = 'cgi.'.$identifier;        
1.129     matthew  6397:     if (! @Values || ref($Values[0]) ne 'ARRAY') {
1.127     matthew  6398:         return '';
                   6399:     }
1.225     matthew  6400:     #
                   6401:     my @Labels;
                   6402:     if (defined($labels)) {
                   6403:         @Labels = @$labels;
                   6404:     } else {
                   6405:         for (my $i=0;$i<@{$Values[0]};$i++) {
                   6406:             push (@Labels,$i+1);
                   6407:         }
                   6408:     }
                   6409:     #
1.129     matthew  6410:     my $NumBars = scalar(@{$Values[0]});
1.225     matthew  6411:     if ($NumBars < scalar(@Labels)) { $NumBars = scalar(@Labels); }
1.129     matthew  6412:     my %ValuesHash;
                   6413:     my $NumSets=1;
                   6414:     foreach my $array (@Values) {
                   6415:         next if (! ref($array));
1.136     matthew  6416:         $ValuesHash{$id.'.data.'.$NumSets++} = 
1.132     matthew  6417:             join(',',@$array);
1.129     matthew  6418:     }
1.127     matthew  6419:     #
1.136     matthew  6420:     my ($height,$width,$xskip,$bar_width) = (200,120,1,15);
1.225     matthew  6421:     if ($NumBars < 3) {
                   6422:         $width = 120+$NumBars*32;
1.220     matthew  6423:         $xskip = 1;
1.225     matthew  6424:         $bar_width = 30;
                   6425:     } elsif ($NumBars < 5) {
                   6426:         $width = 120+$NumBars*20;
                   6427:         $xskip = 1;
                   6428:         $bar_width = 20;
1.220     matthew  6429:     } elsif ($NumBars < 10) {
1.136     matthew  6430:         $width = 120+$NumBars*15;
                   6431:         $xskip = 1;
                   6432:         $bar_width = 15;
                   6433:     } elsif ($NumBars <= 25) {
                   6434:         $width = 120+$NumBars*11;
                   6435:         $xskip = 5;
                   6436:         $bar_width = 8;
                   6437:     } elsif ($NumBars <= 50) {
                   6438:         $width = 120+$NumBars*8;
                   6439:         $xskip = 5;
                   6440:         $bar_width = 4;
                   6441:     } else {
                   6442:         $width = 120+$NumBars*8;
                   6443:         $xskip = 5;
                   6444:         $bar_width = 4;
                   6445:     }
                   6446:     #
1.137     matthew  6447:     $Max = 1 if ($Max < 1);
                   6448:     if ( int($Max) < $Max ) {
                   6449:         $Max++;
                   6450:         $Max = int($Max);
                   6451:     }
1.127     matthew  6452:     $Title  = '' if (! defined($Title));
                   6453:     $xlabel = '' if (! defined($xlabel));
                   6454:     $ylabel = '' if (! defined($ylabel));
1.369     www      6455:     $ValuesHash{$id.'.title'}    = &escape($Title);
                   6456:     $ValuesHash{$id.'.xlabel'}   = &escape($xlabel);
                   6457:     $ValuesHash{$id.'.ylabel'}   = &escape($ylabel);
1.137     matthew  6458:     $ValuesHash{$id.'.y_max_value'} = $Max;
1.136     matthew  6459:     $ValuesHash{$id.'.NumBars'}  = $NumBars;
                   6460:     $ValuesHash{$id.'.NumSets'}  = $NumSets;
                   6461:     $ValuesHash{$id.'.PlotType'} = 'bar';
                   6462:     $ValuesHash{$id.'.Colors'}   = join(',',@{$colors});
                   6463:     $ValuesHash{$id.'.height'}   = $height;
                   6464:     $ValuesHash{$id.'.width'}    = $width;
                   6465:     $ValuesHash{$id.'.xskip'}    = $xskip;
                   6466:     $ValuesHash{$id.'.bar_width'} = $bar_width;
                   6467:     $ValuesHash{$id.'.labels'} = join(',',@Labels);
1.127     matthew  6468:     #
1.228     matthew  6469:     # Deal with other parameters
                   6470:     while (my ($key,$value) = each(%$extra_settings)) {
                   6471:         $ValuesHash{$id.'.'.$key} = $value;
                   6472:     }
                   6473:     #
1.137     matthew  6474:     &Apache::lonnet::appenv(%ValuesHash);
                   6475:     return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
                   6476: }
                   6477: 
                   6478: ############################################################
                   6479: ############################################################
                   6480: 
                   6481: =pod
                   6482: 
                   6483: =item DrawXYGraph
                   6484: 
1.138     matthew  6485: Facilitates the plotting of data in an XY graph.
                   6486: Puts plot definition data into the users environment in order for 
                   6487: graph.png to plot it.  Returns an <img> tag for the plot.
                   6488: 
                   6489: Inputs:
                   6490: 
                   6491: =over 4
                   6492: 
                   6493: =item $Title: string, the title of the plot
                   6494: 
                   6495: =item $xlabel: string, text describing the X-axis of the plot
                   6496: 
                   6497: =item $ylabel: string, text describing the Y-axis of the plot
                   6498: 
                   6499: =item $Max: scalar, the maximum Y value to use in the plot
                   6500: If $Max is < any data point, the graph will not be rendered.
                   6501: 
                   6502: =item $colors: Array ref containing the hex color codes for the data to be 
                   6503: plotted in.  If undefined, default values will be used.
                   6504: 
                   6505: =item $Xlabels: Array ref containing the labels to be used for the X-axis.
                   6506: 
                   6507: =item $Ydata: Array ref containing Array refs.  
1.185     www      6508: Each of the contained arrays will be plotted as a separate curve.
1.138     matthew  6509: 
                   6510: =item %Values: hash indicating or overriding any default values which are 
                   6511: passed to graph.png.  
                   6512: Possible values are: width, xskip, x_ticks, x_tick_offset, among others.
                   6513: 
                   6514: =back
                   6515: 
                   6516: Returns:
                   6517: 
                   6518: An <img> tag which references graph.png and the appropriate identifying
                   6519: information for the plot.
                   6520: 
1.137     matthew  6521: =cut
                   6522: 
                   6523: ############################################################
                   6524: ############################################################
                   6525: sub DrawXYGraph {
                   6526:     my ($Title,$xlabel,$ylabel,$Max,$colors,$Xlabels,$Ydata,%Values)=@_;
                   6527:     #
                   6528:     # Create the identifier for the graph
                   6529:     my $identifier = &get_cgi_id();
                   6530:     my $id = 'cgi.'.$identifier;
                   6531:     #
                   6532:     $Title  = '' if (! defined($Title));
                   6533:     $xlabel = '' if (! defined($xlabel));
                   6534:     $ylabel = '' if (! defined($ylabel));
                   6535:     my %ValuesHash = 
                   6536:         (
1.369     www      6537:          $id.'.title'  => &escape($Title),
                   6538:          $id.'.xlabel' => &escape($xlabel),
                   6539:          $id.'.ylabel' => &escape($ylabel),
1.137     matthew  6540:          $id.'.y_max_value'=> $Max,
                   6541:          $id.'.labels'     => join(',',@$Xlabels),
                   6542:          $id.'.PlotType'   => 'XY',
                   6543:          );
                   6544:     #
                   6545:     if (defined($colors) && ref($colors) eq 'ARRAY') {
                   6546:         $ValuesHash{$id.'.Colors'}   = join(',',@{$colors});
                   6547:     }
                   6548:     #
                   6549:     if (! ref($Ydata) || ref($Ydata) ne 'ARRAY') {
                   6550:         return '';
                   6551:     }
                   6552:     my $NumSets=1;
1.138     matthew  6553:     foreach my $array (@{$Ydata}){
1.137     matthew  6554:         next if (! ref($array));
                   6555:         $ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array);
                   6556:     }
1.138     matthew  6557:     $ValuesHash{$id.'.NumSets'} = $NumSets-1;
1.137     matthew  6558:     #
                   6559:     # Deal with other parameters
                   6560:     while (my ($key,$value) = each(%Values)) {
                   6561:         $ValuesHash{$id.'.'.$key} = $value;
1.127     matthew  6562:     }
                   6563:     #
1.136     matthew  6564:     &Apache::lonnet::appenv(%ValuesHash);
                   6565:     return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
                   6566: }
                   6567: 
                   6568: ############################################################
                   6569: ############################################################
                   6570: 
                   6571: =pod
                   6572: 
1.138     matthew  6573: =item DrawXYYGraph
                   6574: 
                   6575: Facilitates the plotting of data in an XY graph with two Y axes.
                   6576: Puts plot definition data into the users environment in order for 
                   6577: graph.png to plot it.  Returns an <img> tag for the plot.
                   6578: 
                   6579: Inputs:
                   6580: 
                   6581: =over 4
                   6582: 
                   6583: =item $Title: string, the title of the plot
                   6584: 
                   6585: =item $xlabel: string, text describing the X-axis of the plot
                   6586: 
                   6587: =item $ylabel: string, text describing the Y-axis of the plot
                   6588: 
                   6589: =item $colors: Array ref containing the hex color codes for the data to be 
                   6590: plotted in.  If undefined, default values will be used.
                   6591: 
                   6592: =item $Xlabels: Array ref containing the labels to be used for the X-axis.
                   6593: 
                   6594: =item $Ydata1: The first data set
                   6595: 
                   6596: =item $Min1: The minimum value of the left Y-axis
                   6597: 
                   6598: =item $Max1: The maximum value of the left Y-axis
                   6599: 
                   6600: =item $Ydata2: The second data set
                   6601: 
                   6602: =item $Min2: The minimum value of the right Y-axis
                   6603: 
                   6604: =item $Max2: The maximum value of the left Y-axis
                   6605: 
                   6606: =item %Values: hash indicating or overriding any default values which are 
                   6607: passed to graph.png.  
                   6608: Possible values are: width, xskip, x_ticks, x_tick_offset, among others.
                   6609: 
                   6610: =back
                   6611: 
                   6612: Returns:
                   6613: 
                   6614: An <img> tag which references graph.png and the appropriate identifying
                   6615: information for the plot.
1.136     matthew  6616: 
                   6617: =cut
                   6618: 
                   6619: ############################################################
                   6620: ############################################################
1.137     matthew  6621: sub DrawXYYGraph {
                   6622:     my ($Title,$xlabel,$ylabel,$colors,$Xlabels,$Ydata1,$Min1,$Max1,
                   6623:                                         $Ydata2,$Min2,$Max2,%Values)=@_;
1.136     matthew  6624:     #
                   6625:     # Create the identifier for the graph
                   6626:     my $identifier = &get_cgi_id();
                   6627:     my $id = 'cgi.'.$identifier;
                   6628:     #
                   6629:     $Title  = '' if (! defined($Title));
                   6630:     $xlabel = '' if (! defined($xlabel));
                   6631:     $ylabel = '' if (! defined($ylabel));
                   6632:     my %ValuesHash = 
                   6633:         (
1.369     www      6634:          $id.'.title'  => &escape($Title),
                   6635:          $id.'.xlabel' => &escape($xlabel),
                   6636:          $id.'.ylabel' => &escape($ylabel),
1.136     matthew  6637:          $id.'.labels' => join(',',@$Xlabels),
                   6638:          $id.'.PlotType' => 'XY',
                   6639:          $id.'.NumSets' => 2,
1.137     matthew  6640:          $id.'.two_axes' => 1,
                   6641:          $id.'.y1_max_value' => $Max1,
                   6642:          $id.'.y1_min_value' => $Min1,
                   6643:          $id.'.y2_max_value' => $Max2,
                   6644:          $id.'.y2_min_value' => $Min2,
1.136     matthew  6645:          );
                   6646:     #
1.137     matthew  6647:     if (defined($colors) && ref($colors) eq 'ARRAY') {
                   6648:         $ValuesHash{$id.'.Colors'}   = join(',',@{$colors});
                   6649:     }
                   6650:     #
                   6651:     if (! ref($Ydata1) || ref($Ydata1) ne 'ARRAY' ||
                   6652:         ! ref($Ydata2) || ref($Ydata2) ne 'ARRAY'){
1.136     matthew  6653:         return '';
                   6654:     }
                   6655:     my $NumSets=1;
1.137     matthew  6656:     foreach my $array ($Ydata1,$Ydata2){
1.136     matthew  6657:         next if (! ref($array));
                   6658:         $ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array);
1.137     matthew  6659:     }
                   6660:     #
                   6661:     # Deal with other parameters
                   6662:     while (my ($key,$value) = each(%Values)) {
                   6663:         $ValuesHash{$id.'.'.$key} = $value;
1.136     matthew  6664:     }
                   6665:     #
                   6666:     &Apache::lonnet::appenv(%ValuesHash);
1.130     albertel 6667:     return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
1.139     matthew  6668: }
                   6669: 
                   6670: ############################################################
                   6671: ############################################################
                   6672: 
                   6673: =pod
                   6674: 
1.157     matthew  6675: =back 
                   6676: 
1.139     matthew  6677: =head1 Statistics helper routines?  
                   6678: 
                   6679: Bad place for them but what the hell.
                   6680: 
1.157     matthew  6681: =over 4
                   6682: 
1.139     matthew  6683: =item &chartlink
                   6684: 
                   6685: Returns a link to the chart for a specific student.  
                   6686: 
                   6687: Inputs:
                   6688: 
                   6689: =over 4
                   6690: 
                   6691: =item $linktext: The text of the link
                   6692: 
                   6693: =item $sname: The students username
                   6694: 
                   6695: =item $sdomain: The students domain
                   6696: 
                   6697: =back
                   6698: 
1.157     matthew  6699: =back
                   6700: 
1.139     matthew  6701: =cut
                   6702: 
                   6703: ############################################################
                   6704: ############################################################
                   6705: sub chartlink {
                   6706:     my ($linktext, $sname, $sdomain) = @_;
                   6707:     my $link = '<a href="/adm/statistics?reportSelected=student_assessment'.
1.369     www      6708:         '&amp;SelectedStudent='.&escape($sname.':'.$sdomain).
1.219     albertel 6709:         '&amp;chartoutputmode='.HTML::Entities::encode('html, with all links').
1.139     matthew  6710:        '">'.$linktext.'</a>';
1.153     matthew  6711: }
                   6712: 
                   6713: #######################################################
                   6714: #######################################################
                   6715: 
                   6716: =pod
                   6717: 
                   6718: =head1 Course Environment Routines
1.157     matthew  6719: 
                   6720: =over 4
1.153     matthew  6721: 
                   6722: =item &restore_course_settings 
                   6723: 
                   6724: =item &store_course_settings
                   6725: 
                   6726: Restores/Store indicated form parameters from the course environment.
                   6727: Will not overwrite existing values of the form parameters.
                   6728: 
                   6729: Inputs: 
                   6730: a scalar describing the data (e.g. 'chart', 'problem_analysis')
                   6731: 
                   6732: a hash ref describing the data to be stored.  For example:
                   6733:    
                   6734: %Save_Parameters = ('Status' => 'scalar',
                   6735:     'chartoutputmode' => 'scalar',
                   6736:     'chartoutputdata' => 'scalar',
                   6737:     'Section' => 'array',
1.373     raeburn  6738:     'Group' => 'array',
1.153     matthew  6739:     'StudentData' => 'array',
                   6740:     'Maps' => 'array');
                   6741: 
                   6742: Returns: both routines return nothing
                   6743: 
                   6744: =cut
                   6745: 
                   6746: #######################################################
                   6747: #######################################################
                   6748: sub store_course_settings {
1.496     albertel 6749:     return &store_settings($env{'request.course.id'},@_);
                   6750: }
                   6751: 
                   6752: sub store_settings {
1.153     matthew  6753:     # save to the environment
                   6754:     # appenv the same items, just to be safe
1.300     albertel 6755:     my $udom  = $env{'user.domain'};
                   6756:     my $uname = $env{'user.name'};
1.496     albertel 6757:     my ($context,$prefix,$Settings) = @_;
1.153     matthew  6758:     my %SaveHash;
                   6759:     my %AppHash;
                   6760:     while (my ($setting,$type) = each(%$Settings)) {
1.496     albertel 6761:         my $basename = join('.','internal',$context,$prefix,$setting);
1.300     albertel 6762:         my $envname = 'environment.'.$basename;
1.258     albertel 6763:         if (exists($env{'form.'.$setting})) {
1.153     matthew  6764:             # Save this value away
                   6765:             if ($type eq 'scalar' &&
1.258     albertel 6766:                 (! exists($env{$envname}) || 
                   6767:                  $env{$envname} ne $env{'form.'.$setting})) {
                   6768:                 $SaveHash{$basename} = $env{'form.'.$setting};
                   6769:                 $AppHash{$envname}   = $env{'form.'.$setting};
1.153     matthew  6770:             } elsif ($type eq 'array') {
                   6771:                 my $stored_form;
1.258     albertel 6772:                 if (ref($env{'form.'.$setting})) {
1.153     matthew  6773:                     $stored_form = join(',',
                   6774:                                         map {
1.369     www      6775:                                             &escape($_);
1.258     albertel 6776:                                         } sort(@{$env{'form.'.$setting}}));
1.153     matthew  6777:                 } else {
                   6778:                     $stored_form = 
1.369     www      6779:                         &escape($env{'form.'.$setting});
1.153     matthew  6780:                 }
                   6781:                 # Determine if the array contents are the same.
1.258     albertel 6782:                 if ($stored_form ne $env{$envname}) {
1.153     matthew  6783:                     $SaveHash{$basename} = $stored_form;
                   6784:                     $AppHash{$envname}   = $stored_form;
                   6785:                 }
                   6786:             }
                   6787:         }
                   6788:     }
                   6789:     my $put_result = &Apache::lonnet::put('environment',\%SaveHash,
1.300     albertel 6790:                                           $udom,$uname);
1.153     matthew  6791:     if ($put_result !~ /^(ok|delayed)/) {
                   6792:         &Apache::lonnet::logthis('unable to save form parameters, '.
                   6793:                                  'got error:'.$put_result);
                   6794:     }
                   6795:     # Make sure these settings stick around in this session, too
                   6796:     &Apache::lonnet::appenv(%AppHash);
                   6797:     return;
                   6798: }
                   6799: 
                   6800: sub restore_course_settings {
1.499     albertel 6801:     return &restore_settings($env{'request.course.id'},@_);
1.496     albertel 6802: }
                   6803: 
                   6804: sub restore_settings {
                   6805:     my ($context,$prefix,$Settings) = @_;
1.153     matthew  6806:     while (my ($setting,$type) = each(%$Settings)) {
1.258     albertel 6807:         next if (exists($env{'form.'.$setting}));
1.496     albertel 6808:         my $envname = 'environment.internal.'.$context.'.'.$prefix.
1.153     matthew  6809:             '.'.$setting;
1.258     albertel 6810:         if (exists($env{$envname})) {
1.153     matthew  6811:             if ($type eq 'scalar') {
1.258     albertel 6812:                 $env{'form.'.$setting} = $env{$envname};
1.153     matthew  6813:             } elsif ($type eq 'array') {
1.258     albertel 6814:                 $env{'form.'.$setting} = [ 
1.153     matthew  6815:                                            map { 
1.369     www      6816:                                                &unescape($_); 
1.258     albertel 6817:                                            } split(',',$env{$envname})
1.153     matthew  6818:                                            ];
                   6819:             }
                   6820:         }
                   6821:     }
1.127     matthew  6822: }
                   6823: 
                   6824: ############################################################
                   6825: ############################################################
1.154     albertel 6826: 
1.443     albertel 6827: sub commit_customrole {
                   6828:     my ($udom,$uname,$url,$three,$four,$five,$start,$end) = @_;
                   6829:     my $output = &mt('Assigning custom role').' "'.$five.'" by '.$four.'@'.$three.' in '.$url.
                   6830:                          ($start?', '.&mt('starting').' '.localtime($start):'').
                   6831:                          ($end?', ending '.localtime($end):'').': <b>'.
                   6832:               &Apache::lonnet::assigncustomrole(
                   6833:                  $udom,$uname,$url,$three,$four,$five,$end,$start).
                   6834:                  '</b><br />';
                   6835:     return $output;
                   6836: }
                   6837: 
                   6838: sub commit_standardrole {
1.541     raeburn  6839:     my ($udom,$uname,$url,$three,$start,$end,$one,$two,$sec,$context) = @_;
                   6840:     my ($output,$logmsg,$linefeed);
                   6841:     if ($context eq 'auto') {
                   6842:         $linefeed = "\n";
                   6843:     } else {
                   6844:         $linefeed = "<br />\n";
                   6845:     }  
1.443     albertel 6846:     if ($three eq 'st') {
1.541     raeburn  6847:         my $result = &commit_studentrole(\$logmsg,$udom,$uname,$url,$three,$start,$end,
                   6848:                                          $one,$two,$sec,$context);
                   6849:         if (($result =~ /^error/) || ($result eq 'not_in_class') || 
                   6850:             ($result eq 'unknown_course')) {
1.443     albertel 6851:             $output = "Error: $result\n"; 
                   6852:         } else {
1.541     raeburn  6853:             $output = $logmsg.$linefeed.&mt('Assigning').' '.$three.' in '.$url.
1.443     albertel 6854:                ($start?', '.&mt('starting').' '.localtime($start):'').
1.541     raeburn  6855:                ($end?', '.&mt('ending').' '.localtime($end):'').': ';
                   6856:             if ($context eq 'auto') {
                   6857:                 $output .= $result.$linefeed.&mt('Add to classlist').': ok';
                   6858:             } else {
                   6859:                $output .= '<b>'.$result.'</b>'.$linefeed.
                   6860:                &mt('Add to classlist').': <b>ok</b>';
                   6861:             }
                   6862:             $output .= $linefeed;
1.443     albertel 6863:         }
                   6864:     } else {
                   6865:         $output = &mt('Assigning').' '.$three.' in '.$url.
                   6866:                ($start?', '.&mt('starting').' '.localtime($start):'').
1.541     raeburn  6867:                ($end?', '.&mt('ending').' '.localtime($end):'').': ';
                   6868:         my $result = &Apache::lonnet::assignrole($udom,$uname,$url,$three,$end,$start);
                   6869:         if ($context eq 'auto') {
                   6870:             $output .= $result.$linefeed;
                   6871:         } else {
                   6872:             $output .= '<b>'.$result.'</b>'.$linefeed;
                   6873:         }
1.443     albertel 6874:     }
                   6875:     return $output;
                   6876: }
                   6877: 
                   6878: sub commit_studentrole {
1.541     raeburn  6879:     my ($logmsg,$udom,$uname,$url,$three,$start,$end,$one,$two,$sec,$context) = @_;
                   6880:     my ($result,$linefeed);
                   6881:     if ($context eq 'auto') {
                   6882:         $linefeed = "\n";
                   6883:     } else {
                   6884:         $linefeed = '<br />'."\n";
                   6885:     }
1.443     albertel 6886:     if (defined($one) && defined($two)) {
                   6887:         my $cid=$one.'_'.$two;
                   6888:         my $oldsec=&Apache::lonnet::getsection($udom,$uname,$cid);
                   6889:         my $secchange = 0;
                   6890:         my $expire_role_result;
                   6891:         my $modify_section_result;
                   6892:         unless ($oldsec eq '-1') {
                   6893:             unless ($sec eq $oldsec) {
                   6894:                 $secchange = 1;
                   6895:                 my $uurl='/'.$cid;
                   6896:                 $uurl=~s/\_/\//g;
                   6897:                 if ($oldsec) {
                   6898:                     $uurl.='/'.$oldsec;
                   6899:                 }
                   6900:                 $expire_role_result = &Apache::lonnet::assignrole($udom,$uname,$uurl,'st',time);
                   6901:                 $result = $expire_role_result;
                   6902:             }
                   6903:         }
                   6904:         if (($expire_role_result eq 'ok') || ($secchange == 0)) {
                   6905:             $modify_section_result = &Apache::lonnet::modify_student_enrollment($udom,$uname,undef,undef,undef,undef,undef,$sec,$end,$start,'','',$cid);
                   6906:             if ($modify_section_result =~ /^ok/) {
                   6907:                 if ($secchange == 1) {
                   6908:                     $$logmsg .= "Section for $uname switched from old section: $oldsec to new section: $sec".$linefeed;
                   6909:                 } elsif ($oldsec eq '-1') {
                   6910:                     $$logmsg .= "New student role for $uname in section $sec in course $cid".$linefeed;
                   6911:                 } else {
                   6912:                     $$logmsg .= "Student $uname assigned to unchanged section $sec in course $cid".$linefeed;
                   6913:                 }
                   6914:             } else {
                   6915:                 $$logmsg .= "Error when attempting section change for $uname from old section $oldsec to new section: $sec in course $cid -error: $modify_section_result".$linefeed;
                   6916:             }
                   6917:             $result = $modify_section_result;
                   6918:         } elsif ($secchange == 1) {
                   6919:             $$logmsg .= "Error when attempting to expire role for $uname in old section $oldsec in course $cid -error: $expire_role_result".$linefeed;
                   6920:         }
                   6921:     } else {
                   6922:         $$logmsg .= "Incomplete course id defined.  Addition of user $uname from domain $udom to course $one\_$two, section $sec not completed.$linefeed";
                   6923:         $result = "error: incomplete course id\n";
                   6924:     }
                   6925:     return $result;
                   6926: }
                   6927: 
                   6928: ############################################################
                   6929: ############################################################
                   6930: 
1.564.2.1  albertel 6931: sub check_clone {
                   6932:     my ($args) = @_;
                   6933:     my $cloneid='/'.$args->{'clonedomain'}.'/'.$args->{'clonecourse'};
                   6934:     my ($clonecrsudom,$clonecrsunum)= &LONCAPA::split_courseid($cloneid);
                   6935:     my $clonehome=&Apache::lonnet::homeserver($clonecrsunum,$clonecrsudom);
                   6936:     my $clonemsg;
                   6937:     my $can_clone = 0;
                   6938: 
                   6939:     if ($clonehome eq 'no_host') {
                   6940: 	$clonemsg = &mt('Attempting to clone non-existing [_1]',
                   6941: 			$args->{'crstype'});
                   6942:     } else {
                   6943: 	my %clonedesc = &Apache::lonnet::coursedescription($cloneid,{'one_time' => 1});
1.564.2.2  albertel 6944: 	if ($env{'request.role.domain'} eq $args->{'clonedomain'}) {
1.564.2.1  albertel 6945: 	    $can_clone = 1;
                   6946: 	} else {
                   6947: 	    my %clonehash = &Apache::lonnet::get('environment',['cloners'],
                   6948: 						 $args->{'clonedomain'},$args->{'clonecourse'});
                   6949: 	    my @cloners = split(/,/,$clonehash{'cloners'});
                   6950: 	    my %roleshash =
                   6951: 		&Apache::lonnet::get_my_roles($args->{'ccuname'},
                   6952: 					      $args->{'ccdomain'},'userroles',['active'],['cc'],
                   6953: 					      [$args->{'clonedomain'}]);
                   6954: 	    if (($roleshash{$args->{'clonecourse'}.':'.$args->{'clonedomain'}.':cc'}) || (grep(/^\Q$args->{'ccuname'}\E:\Q$args->{'ccdomain'}\E$/,@cloners))) {
                   6955: 		$can_clone = 1;
                   6956: 	    } else {
                   6957: 		$clonemsg = &mt('The new course was not cloned from an existing course because the new course owner ([_1]) does not have cloning rights in the existing course ([_2]).',$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'});
                   6958: 	    }
                   6959: 	}
                   6960:     }
                   6961: 
                   6962:     return ($can_clone, $clonemsg, $cloneid, $clonehome);
                   6963: }
                   6964: 
1.444     albertel 6965: sub construct_course {
1.541     raeburn  6966:     my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context) = @_;
1.444     albertel 6967:     my $outcome;
1.541     raeburn  6968:     my $linefeed =  '<br />'."\n";
                   6969:     if ($context eq 'auto') {
                   6970:         $linefeed = "\n";
                   6971:     }
1.564.2.1  albertel 6972: 
                   6973: #
                   6974: # Are we cloning?
                   6975: #
                   6976:     my ($can_clone, $clonemsg, $cloneid, $clonehome);
                   6977:     if (($args->{'clonecourse'}) && ($args->{'clonedomain'})) {
                   6978: 	($can_clone, $clonemsg, $cloneid, $clonehome) = &check_clone($args);
                   6979: 	if ($context ne 'auto') {
                   6980: 	    $clonemsg = '<span class="LC_error">'.$clonemsg.'</span>';
                   6981: 	}
                   6982: 	$outcome .= $clonemsg.$linefeed;
                   6983: 
                   6984:         if (!$can_clone) {
                   6985: 	    return (0,$outcome);
                   6986: 	}
                   6987:     }
                   6988: 
1.444     albertel 6989: #
                   6990: # Open course
                   6991: #
                   6992:     my $crstype = lc($args->{'crstype'});
                   6993:     my %cenv=();
                   6994:     $$courseid=&Apache::lonnet::createcourse($args->{'course_domain'},
                   6995:                                              $args->{'cdescr'},
                   6996:                                              $args->{'curl'},
                   6997:                                              $args->{'course_home'},
                   6998:                                              $args->{'nonstandard'},
                   6999:                                              $args->{'crscode'},
                   7000:                                              $args->{'ccuname'}.':'.
                   7001:                                              $args->{'ccdomain'},
                   7002:                                              $args->{'crstype'});
                   7003: 
                   7004:     # Note: The testing routines depend on this being output; see 
                   7005:     # Utils::Course. This needs to at least be output as a comment
                   7006:     # if anyone ever decides to not show this, and Utils::Course::new
                   7007:     # will need to be suitably modified.
1.541     raeburn  7008:     $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed;
1.444     albertel 7009: #
                   7010: # Check if created correctly
                   7011: #
1.479     albertel 7012:     ($$crsudom,$$crsunum)= &LONCAPA::split_courseid($$courseid);
1.444     albertel 7013:     my $crsuhome=&Apache::lonnet::homeserver($$crsunum,$$crsudom);
1.541     raeburn  7014:     $outcome .= &mt('Created on').': '.$crsuhome.$linefeed;
1.564.2.1  albertel 7015: 
1.444     albertel 7016: #
1.564.2.1  albertel 7017: # Do the cloning
                   7018: #   
                   7019:     if ($can_clone && $cloneid) {
                   7020: 	$clonemsg = &mt('Cloning [_1] from [_2]',$crstype,$clonehome);
                   7021: 	if ($context ne 'auto') {
                   7022: 	    $clonemsg = '<span class="LC_success">'.$clonemsg.'</span>';
                   7023: 	}
                   7024: 	$outcome .= $clonemsg.$linefeed;
                   7025: 	my %oldcenv=&Apache::lonnet::dump('environment',$$crsudom,$$crsunum);
1.444     albertel 7026: # Copy all files
1.564.2.1  albertel 7027: 	&Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid);
1.444     albertel 7028: # Restore URL
1.564.2.1  albertel 7029: 	$cenv{'url'}=$oldcenv{'url'};
1.444     albertel 7030: # Restore title
1.564.2.1  albertel 7031: 	$cenv{'description'}=$oldcenv{'description'};
1.444     albertel 7032: # restore grading mode
1.564.2.1  albertel 7033: 	if (defined($oldcenv{'grading'})) {
                   7034: 	    $cenv{'grading'}=$oldcenv{'grading'};
1.444     albertel 7035: 	}
1.564.2.1  albertel 7036: # Mark as cloned
                   7037: 	$cenv{'clonedfrom'}=$cloneid;
                   7038: 	delete($cenv{'default_enrollment_start_date'});
                   7039: 	delete($cenv{'default_enrollment_end_date'});
1.444     albertel 7040:     }
1.564.2.1  albertel 7041: 
1.444     albertel 7042: #
                   7043: # Set environment (will override cloned, if existing)
                   7044: #
                   7045:     my @sections = ();
                   7046:     my @xlists = ();
                   7047:     if ($args->{'crstype'}) {
                   7048:         $cenv{'type'}=$args->{'crstype'};
                   7049:     }
                   7050:     if ($args->{'crsid'}) {
                   7051:         $cenv{'courseid'}=$args->{'crsid'};
                   7052:     }
                   7053:     if ($args->{'crscode'}) {
                   7054:         $cenv{'internal.coursecode'}=$args->{'crscode'};
                   7055:     }
                   7056:     if ($args->{'crsquota'} ne '') {
                   7057:         $cenv{'internal.coursequota'}=$args->{'crsquota'};
                   7058:     } else {
                   7059:         $cenv{'internal.coursequota'}=$args->{'crsquota'} = 20;
                   7060:     }
                   7061:     if ($args->{'ccuname'}) {
                   7062:         $cenv{'internal.courseowner'} = $args->{'ccuname'}.
                   7063:                                         ':'.$args->{'ccdomain'};
                   7064:     } else {
                   7065:         $cenv{'internal.courseowner'} = $args->{'curruser'};
                   7066:     }
                   7067: 
                   7068:     my @badclasses = (); # Used to accumulate sections/crosslistings that did not pass classlist access check for course owner.
                   7069:     if ($args->{'crssections'}) {
                   7070:         $cenv{'internal.sectionnums'} = '';
                   7071:         if ($args->{'crssections'} =~ m/,/) {
                   7072:             @sections = split/,/,$args->{'crssections'};
                   7073:         } else {
                   7074:             $sections[0] = $args->{'crssections'};
                   7075:         }
                   7076:         if (@sections > 0) {
                   7077:             foreach my $item (@sections) {
                   7078:                 my ($sec,$gp) = split/:/,$item;
                   7079:                 my $class = $args->{'crscode'}.$sec;
                   7080:                 my $addcheck = &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$class,$cenv{'internal.courseowner'});
                   7081:                 $cenv{'internal.sectionnums'} .= $item.',';
                   7082:                 unless ($addcheck eq 'ok') {
                   7083:                     push @badclasses, $class;
                   7084:                 }
                   7085:             }
                   7086:             $cenv{'internal.sectionnums'} =~ s/,$//;
                   7087:         }
                   7088:     }
                   7089: # do not hide course coordinator from staff listing, 
                   7090: # even if privileged
                   7091:     $cenv{'nothideprivileged'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
                   7092: # add crosslistings
                   7093:     if ($args->{'crsxlist'}) {
                   7094:         $cenv{'internal.crosslistings'}='';
                   7095:         if ($args->{'crsxlist'} =~ m/,/) {
                   7096:             @xlists = split/,/,$args->{'crsxlist'};
                   7097:         } else {
                   7098:             $xlists[0] = $args->{'crsxlist'};
                   7099:         }
                   7100:         if (@xlists > 0) {
                   7101:             foreach my $item (@xlists) {
                   7102:                 my ($xl,$gp) = split/:/,$item;
                   7103:                 my $addcheck =  &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$xl,$cenv{'internal.courseowner'});
                   7104:                 $cenv{'internal.crosslistings'} .= $item.',';
                   7105:                 unless ($addcheck eq 'ok') {
                   7106:                     push @badclasses, $xl;
                   7107:                 }
                   7108:             }
                   7109:             $cenv{'internal.crosslistings'} =~ s/,$//;
                   7110:         }
                   7111:     }
                   7112:     if ($args->{'autoadds'}) {
                   7113:         $cenv{'internal.autoadds'}=$args->{'autoadds'};
                   7114:     }
                   7115:     if ($args->{'autodrops'}) {
                   7116:         $cenv{'internal.autodrops'}=$args->{'autodrops'};
                   7117:     }
                   7118: # check for notification of enrollment changes
                   7119:     my @notified = ();
                   7120:     if ($args->{'notify_owner'}) {
                   7121:         if ($args->{'ccuname'} ne '') {
                   7122:             push(@notified,$args->{'ccuname'}.':'.$args->{'ccdomain'});
                   7123:         }
                   7124:     }
                   7125:     if ($args->{'notify_dc'}) {
                   7126:         if ($uname ne '') { 
                   7127:             push(@notified,$uname.'@'.$udom);
                   7128:         }
                   7129:     }
                   7130:     if (@notified > 0) {
                   7131:         my $notifylist;
                   7132:         if (@notified > 1) {
                   7133:             $notifylist = join(',',@notified);
                   7134:         } else {
                   7135:             $notifylist = $notified[0];
                   7136:         }
                   7137:         $cenv{'internal.notifylist'} = $notifylist;
                   7138:     }
                   7139:     if (@badclasses > 0) {
                   7140:         my %lt=&Apache::lonlocal::texthash(
                   7141:                 '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',
                   7142:                 'dnhr' => 'does not have rights to access enrollment in these classes',
                   7143:                 'adby' => 'as determined by the policies of your institution on access to official classlists'
                   7144:         );
1.541     raeburn  7145:         my $badclass_msg = $cenv{'internal.courseowner'}.') - '.$lt{'dnhr'}.
                   7146:                            ' ('.$lt{'adby'}.')';
                   7147:         if ($context eq 'auto') {
                   7148:             $outcome .= $badclass_msg.$linefeed;
1.564.2.1  albertel 7149:             $outcome .= '<div class="LC_warning">'.$badclass_msg.$linefeed.'<ul>'."\n";
1.541     raeburn  7150:             foreach my $item (@badclasses) {
                   7151:                 if ($context eq 'auto') {
                   7152:                     $outcome .= " - $item\n";
                   7153:                 } else {
                   7154:                     $outcome .= "<li>$item</li>\n";
                   7155:                 }
                   7156:             }
                   7157:             if ($context eq 'auto') {
                   7158:                 $outcome .= $linefeed;
                   7159:             } else {
1.564.2.1  albertel 7160:                 $outcome .= "</ul><br /><br /></div>\n";
1.541     raeburn  7161:             }
                   7162:         } 
1.444     albertel 7163:     }
                   7164:     if ($args->{'no_end_date'}) {
                   7165:         $args->{'endaccess'} = 0;
                   7166:     }
                   7167:     $cenv{'internal.autostart'}=$args->{'enrollstart'};
                   7168:     $cenv{'internal.autoend'}=$args->{'enrollend'};
                   7169:     $cenv{'default_enrollment_start_date'}=$args->{'startaccess'};
                   7170:     $cenv{'default_enrollment_end_date'}=$args->{'endaccess'};
                   7171:     if ($args->{'showphotos'}) {
                   7172:       $cenv{'internal.showphotos'}=$args->{'showphotos'};
                   7173:     }
                   7174:     $cenv{'internal.authtype'} = $args->{'authtype'};
                   7175:     $cenv{'internal.autharg'} = $args->{'autharg'}; 
                   7176:     if ( ($cenv{'internal.authtype'} =~ /^krb/) && ($cenv{'internal.autoadds'} == 1)) {
                   7177:         if (! defined($cenv{'internal.autharg'}) || $cenv{'internal.autharg'}  eq '') {
1.541     raeburn  7178:             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'); 
                   7179:             if ($context eq 'auto') {
                   7180:                 $outcome .= $krb_msg;
                   7181:             } else {
1.564.2.1  albertel 7182:                 $outcome .= '<span class="LC_error">'.$krb_msg.'</span>';
1.541     raeburn  7183:             }
                   7184:             $outcome .= $linefeed;
1.444     albertel 7185:         }
                   7186:     }
                   7187:     if (($args->{'ccdomain'}) && ($args->{'ccuname'})) {
                   7188:        if ($args->{'setpolicy'}) {
                   7189:            $cenv{'policy.email'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
                   7190:        }
                   7191:        if ($args->{'setcontent'}) {
                   7192:            $cenv{'question.email'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
                   7193:        }
                   7194:     }
                   7195:     if ($args->{'reshome'}) {
                   7196: 	$cenv{'reshome'}=$args->{'reshome'}.'/';
                   7197: 	$cenv{'reshome'}=~s/\/+$/\//;
                   7198:     }
                   7199: #
                   7200: # course has keyed access
                   7201: #
                   7202:     if ($args->{'setkeys'}) {
                   7203:        $cenv{'keyaccess'}='yes';
                   7204:     }
                   7205: # if specified, key authority is not course, but user
                   7206: # only active if keyaccess is yes
                   7207:     if ($args->{'keyauth'}) {
1.487     albertel 7208: 	my ($user,$domain) = split(':',$args->{'keyauth'});
                   7209: 	$user = &LONCAPA::clean_username($user);
                   7210: 	$domain = &LONCAPA::clean_username($domain);
1.488     foxr     7211: 	if ($user ne '' && $domain ne '') {
1.487     albertel 7212: 	    $cenv{'keyauth'}=$user.':'.$domain;
1.444     albertel 7213: 	}
                   7214:     }
                   7215: 
                   7216:     if ($args->{'disresdis'}) {
                   7217:         $cenv{'pch.roles.denied'}='st';
                   7218:     }
                   7219:     if ($args->{'disablechat'}) {
                   7220:         $cenv{'plc.roles.denied'}='st';
                   7221:     }
                   7222: 
                   7223:     # Record we've not yet viewed the Course Initialization Helper for this 
                   7224:     # course
                   7225:     $cenv{'course.helper.not.run'} = 1;
                   7226:     #
                   7227:     # Use new Randomseed
                   7228:     #
                   7229:     $cenv{'rndseed'}=&Apache::lonnet::latest_rnd_algorithm_id();;
                   7230:     $cenv{'receiptalg'}=&Apache::lonnet::latest_receipt_algorithm_id();;
                   7231:     #
                   7232:     # The encryption code and receipt prefix for this course
                   7233:     #
                   7234:     $cenv{'internal.encseed'}=$Apache::lonnet::perlvar{'lonReceipt'}.$$.time.int(rand(9999));
                   7235:     $cenv{'internal.encpref'}=100+int(9*rand(99));
                   7236:     #
                   7237:     # By default, use standard grading
                   7238:     if (!defined($cenv{'grading'})) { $cenv{'grading'} = 'standard'; }
                   7239: 
1.541     raeburn  7240:     $outcome .= $linefeed.&mt('Setting environment').': '.                 
                   7241:           &Apache::lonnet::put('environment',\%cenv,$$crsudom,$$crsunum).$linefeed;
1.444     albertel 7242: #
                   7243: # Open all assignments
                   7244: #
                   7245:     if ($args->{'openall'}) {
                   7246:        my $storeunder=$$crsudom.'_'.$$crsunum.'.0.opendate';
                   7247:        my %storecontent = ($storeunder         => time,
                   7248:                            $storeunder.'.type' => 'date_start');
                   7249:        
                   7250:        $outcome .= &mt('Opening all assignments').': '.&Apache::lonnet::cput
1.541     raeburn  7251:                  ('resourcedata',\%storecontent,$$crsudom,$$crsunum).$linefeed;
1.444     albertel 7252:    }
                   7253: #
                   7254: # Set first page
                   7255: #
                   7256:     unless (($args->{'nonstandard'}) || ($args->{'firstres'} eq 'blank')
                   7257: 	    || ($cloneid)) {
1.445     albertel 7258: 	use LONCAPA::map;
1.444     albertel 7259: 	$outcome .= &mt('Setting first resource').': ';
1.445     albertel 7260: 
                   7261: 	my $map = '/uploaded/'.$$crsudom.'/'.$$crsunum.'/default.sequence';
                   7262:         my ($errtext,$fatal)=&LONCAPA::map::mapread($map);
                   7263: 
1.444     albertel 7264:         $outcome .= ($fatal?$errtext:'read ok').' - ';
                   7265:         my $title; my $url;
                   7266:         if ($args->{'firstres'} eq 'syl') {
                   7267: 	    $title='Syllabus';
                   7268:             $url='/public/'.$$crsudom.'/'.$$crsunum.'/syllabus';
                   7269:         } else {
                   7270:             $title='Navigate Contents';
                   7271:             $url='/adm/navmaps';
                   7272:         }
1.445     albertel 7273: 
                   7274:         $LONCAPA::map::resources[1]=$title.':'.$url.':false:start:res';
                   7275: 	(my $outtext,$errtext) = &LONCAPA::map::storemap($map,1);
                   7276: 
                   7277: 	if ($errtext) { $fatal=2; }
1.541     raeburn  7278:         $outcome .= ($fatal?$errtext:'write ok').$linefeed;
1.444     albertel 7279:     }
1.564.2.1  albertel 7280: 
                   7281:     return (1,$outcome);
1.444     albertel 7282: }
                   7283: 
                   7284: ############################################################
                   7285: ############################################################
                   7286: 
1.378     raeburn  7287: sub course_type {
                   7288:     my ($cid) = @_;
                   7289:     if (!defined($cid)) {
                   7290:         $cid = $env{'request.course.id'};
                   7291:     }
1.404     albertel 7292:     if (defined($env{'course.'.$cid.'.type'})) {
                   7293:         return $env{'course.'.$cid.'.type'};
1.378     raeburn  7294:     } else {
                   7295:         return 'Course';
1.377     raeburn  7296:     }
                   7297: }
1.156     albertel 7298: 
1.406     raeburn  7299: sub group_term {
                   7300:     my $crstype = &course_type();
                   7301:     my %names = (
                   7302:                   'Course' => 'group',
                   7303:                   'Group' => 'team',
                   7304:                 );
                   7305:     return $names{$crstype};
                   7306: }
                   7307: 
1.156     albertel 7308: sub icon {
                   7309:     my ($file)=@_;
1.505     albertel 7310:     my $curfext = lc((split(/\./,$file))[-1]);
1.168     albertel 7311:     my $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/unknown.gif';
1.156     albertel 7312:     my $embstyle = &Apache::loncommon::fileembstyle($curfext);
1.168     albertel 7313:     if (!(!defined($embstyle) || $embstyle eq 'unk' || $embstyle eq 'hdn')) {
                   7314: 	if (-e  $Apache::lonnet::perlvar{'lonDocRoot'}.'/'.
                   7315: 	          $Apache::lonnet::perlvar{'lonIconsURL'}.'/'.
                   7316: 	            $curfext.".gif") {
                   7317: 	    $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/'.
                   7318: 		$curfext.".gif";
                   7319: 	}
                   7320:     }
1.249     albertel 7321:     return &lonhttpdurl($iconname);
1.154     albertel 7322: } 
1.84      albertel 7323: 
1.564.2.4  albertel 7324: sub lonhttpd_port {
1.215     albertel 7325:     my $lonhttpd_port=$Apache::lonnet::perlvar{'lonhttpdPort'};
                   7326:     if (!defined($lonhttpd_port)) { $lonhttpd_port='8080'; }
1.564.2.3  albertel 7327:     # IE doesn't like a secure page getting images from a non-secure
                   7328:     # port (when logging we haven't parsed the browser type so default
                   7329:     # back to secure
                   7330:     if ((!exists($env{'browser.type'}) || $env{'browser.type'} eq 'explorer')
                   7331: 	&& $ENV{'SERVER_PORT'} == 443) {
1.564.2.4  albertel 7332: 	return 443;
                   7333:     }
                   7334:     return $lonhttpd_port;
                   7335: 
                   7336: }
                   7337: 
                   7338: sub lonhttpdurl {
                   7339:     my ($url)=@_;
                   7340: 
                   7341:     my $lonhttpd_port = &lonhttpd_port();
                   7342:     if ($lonhttpd_port == 443) {
1.564.2.3  albertel 7343: 	return 'https://'.$ENV{'SERVER_NAME'}.$url;
                   7344:     }
1.215     albertel 7345:     return 'http://'.$ENV{'SERVER_NAME'}.':'.$lonhttpd_port.$url;
                   7346: }
                   7347: 
1.213     albertel 7348: sub connection_aborted {
                   7349:     my ($r)=@_;
                   7350:     $r->print(" ");$r->rflush();
                   7351:     my $c = $r->connection;
                   7352:     return $c->aborted();
                   7353: }
                   7354: 
1.221     foxr     7355: #    Escapes strings that may have embedded 's that will be put into
1.222     foxr     7356: #    strings as 'strings'.
                   7357: sub escape_single {
1.221     foxr     7358:     my ($input) = @_;
1.223     albertel 7359:     $input =~ s/\\/\\\\/g;	# Escape the \'s..(must be first)>
1.221     foxr     7360:     $input =~ s/\'/\\\'/g;	# Esacpe the 's....
                   7361:     return $input;
                   7362: }
1.223     albertel 7363: 
1.222     foxr     7364: #  Same as escape_single, but escape's "'s  This 
                   7365: #  can be used for  "strings"
                   7366: sub escape_double {
                   7367:     my ($input) = @_;
                   7368:     $input =~ s/\\/\\\\/g;	# Escape the /'s..(must be first)>
                   7369:     $input =~ s/\"/\\\"/g;	# Esacpe the "s....
                   7370:     return $input;
                   7371: }
1.223     albertel 7372:  
1.222     foxr     7373: #   Escapes the last element of a full URL.
                   7374: sub escape_url {
                   7375:     my ($url)   = @_;
1.238     raeburn  7376:     my @urlslices = split(/\//, $url,-1);
1.369     www      7377:     my $lastitem = &escape(pop(@urlslices));
1.223     albertel 7378:     return join('/',@urlslices).'/'.$lastitem;
1.222     foxr     7379: }
1.462     albertel 7380: 
                   7381: # -------------------------------------------------------- Initliaze user login
                   7382: sub init_user_environment {
1.463     albertel 7383:     my ($r, $username, $domain, $authhost, $form, $args) = @_;
1.462     albertel 7384:     my $lonids=$Apache::lonnet::perlvar{'lonIDsDir'};
                   7385: 
                   7386:     my $public=($username eq 'public' && $domain eq 'public');
                   7387: 
                   7388: # See if old ID present, if so, remove
                   7389: 
                   7390:     my ($filename,$cookie,$userroles);
                   7391:     my $now=time;
                   7392: 
                   7393:     if ($public) {
                   7394: 	my $max_public=100;
                   7395: 	my $oldest;
                   7396: 	my $oldest_time=0;
                   7397: 	for(my $next=1;$next<=$max_public;$next++) {
                   7398: 	    if (-e $lonids."/publicuser_$next.id") {
                   7399: 		my $mtime=(stat($lonids."/publicuser_$next.id"))[9];
                   7400: 		if ($mtime<$oldest_time || !$oldest_time) {
                   7401: 		    $oldest_time=$mtime;
                   7402: 		    $oldest=$next;
                   7403: 		}
                   7404: 	    } else {
                   7405: 		$cookie="publicuser_$next";
                   7406: 		last;
                   7407: 	    }
                   7408: 	}
                   7409: 	if (!$cookie) { $cookie="publicuser_$oldest"; }
                   7410:     } else {
1.463     albertel 7411: 	# if this isn't a robot, kill any existing non-robot sessions
                   7412: 	if (!$args->{'robot'}) {
                   7413: 	    opendir(DIR,$lonids);
                   7414: 	    while ($filename=readdir(DIR)) {
                   7415: 		if ($filename=~/^$username\_\d+\_$domain\_$authhost\.id$/) {
                   7416: 		    unlink($lonids.'/'.$filename);
                   7417: 		}
1.462     albertel 7418: 	    }
1.463     albertel 7419: 	    closedir(DIR);
1.462     albertel 7420: 	}
                   7421: # Give them a new cookie
1.463     albertel 7422: 	my $id = ($args->{'robot'} ? 'robot'.$args->{'robot'}
                   7423: 		                   : $now);
                   7424: 	$cookie="$username\_$id\_$domain\_$authhost";
1.462     albertel 7425:     
                   7426: # Initialize roles
                   7427: 
                   7428: 	$userroles=&Apache::lonnet::rolesinit($domain,$username,$authhost);
                   7429:     }
                   7430: # ------------------------------------ Check browser type and MathML capability
                   7431: 
                   7432:     my ($httpbrowser,$clientbrowser,$clientversion,$clientmathml,
                   7433:         $clientunicode,$clientos) = &decode_user_agent($r);
                   7434: 
                   7435: # -------------------------------------- Any accessibility options to remember?
                   7436:     if (($form->{'interface'}) && ($form->{'remember'} eq 'true')) {
                   7437: 	foreach my $option ('imagesuppress','appletsuppress',
                   7438: 			    'embedsuppress','fontenhance','blackwhite') {
                   7439: 	    if ($form->{$option} eq 'true') {
                   7440: 		&Apache::lonnet::put('environment',{$option => 'on'},
                   7441: 				     $domain,$username);
                   7442: 	    } else {
                   7443: 		&Apache::lonnet::del('environment',[$option],
                   7444: 				     $domain,$username);
                   7445: 	    }
                   7446: 	}
                   7447:     }
                   7448: # ------------------------------------------------------------- Get environment
                   7449: 
                   7450:     my %userenv = &Apache::lonnet::dump('environment',$domain,$username);
                   7451:     my ($tmp) = keys(%userenv);
                   7452:     if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
                   7453: 	# default remote control to off
                   7454: 	if ($userenv{'remote'} ne 'on') { $userenv{'remote'} = 'off'; }
                   7455:     } else {
                   7456: 	undef(%userenv);
                   7457:     }
                   7458:     if (($userenv{'interface'}) && (!$form->{'interface'})) {
                   7459: 	$form->{'interface'}=$userenv{'interface'};
                   7460:     }
                   7461:     $env{'environment.remote'}=$userenv{'remote'};
                   7462:     if ($userenv{'texengine'} eq 'ttm') { $clientmathml=1; }
                   7463: 
                   7464: # --------------- Do not trust query string to be put directly into environment
                   7465:     foreach my $option ('imagesuppress','appletsuppress',
                   7466: 			'embedsuppress','fontenhance','blackwhite',
                   7467: 			'interface','localpath','localres') {
                   7468: 	$form->{$option}=~s/[\n\r\=]//gs;
                   7469:     }
                   7470: # --------------------------------------------------------- Write first profile
                   7471: 
                   7472:     {
                   7473: 	my %initial_env = 
                   7474: 	    ("user.name"          => $username,
                   7475: 	     "user.domain"        => $domain,
                   7476: 	     "user.home"          => $authhost,
                   7477: 	     "browser.type"       => $clientbrowser,
                   7478: 	     "browser.version"    => $clientversion,
                   7479: 	     "browser.mathml"     => $clientmathml,
                   7480: 	     "browser.unicode"    => $clientunicode,
                   7481: 	     "browser.os"         => $clientos,
                   7482: 	     "server.domain"      => $Apache::lonnet::perlvar{'lonDefDomain'},
                   7483: 	     "request.course.fn"  => '',
                   7484: 	     "request.course.uri" => '',
                   7485: 	     "request.course.sec" => '',
                   7486: 	     "request.role"       => 'cm',
                   7487: 	     "request.role.adv"   => $env{'user.adv'},
                   7488: 	     "request.host"       => $ENV{'REMOTE_ADDR'},);
                   7489: 
                   7490:         if ($form->{'localpath'}) {
                   7491: 	    $initial_env{"browser.localpath"}  = $form->{'localpath'};
                   7492: 	    $initial_env{"browser.localres"}   = $form->{'localres'};
                   7493:         }
                   7494: 	
                   7495: 	if ($public) {
                   7496: 	    $initial_env{"environment.remote"} = "off";
                   7497: 	}
                   7498: 	if ($form->{'interface'}) {
                   7499: 	    $form->{'interface'}=~s/\W//gs;
                   7500: 	    $initial_env{"browser.interface"} = $form->{'interface'};
                   7501: 	    $env{'browser.interface'}=$form->{'interface'};
                   7502: 	    foreach my $option ('imagesuppress','appletsuppress',
                   7503: 				'embedsuppress','fontenhance','blackwhite') {
                   7504: 		if (($form->{$option} eq 'true') ||
                   7505: 		    ($userenv{$option} eq 'on')) {
                   7506: 		    $initial_env{"browser.$option"} = "on";
                   7507: 		}
                   7508: 	    }
                   7509: 	}
                   7510: 
                   7511: 	$env{'user.environment'} = "$lonids/$cookie.id";
                   7512: 	
                   7513: 	if (tie(my %disk_env,'GDBM_File',"$lonids/$cookie.id",
                   7514: 		 &GDBM_WRCREAT(),0640)) {
                   7515: 	    &_add_to_env(\%disk_env,\%initial_env);
                   7516: 	    &_add_to_env(\%disk_env,\%userenv,'environment.');
                   7517: 	    &_add_to_env(\%disk_env,$userroles);
1.463     albertel 7518: 	    if (ref($args->{'extra_env'})) {
                   7519: 		&_add_to_env(\%disk_env,$args->{'extra_env'});
                   7520: 	    }
1.462     albertel 7521: 	    untie(%disk_env);
                   7522: 	} else {
                   7523: 	    &Apache::lonnet::logthis("<font color=\"blue\">WARNING: ".
                   7524: 			   'Could not create environment storage in lonauth: '.$!.'</font>');
                   7525: 	    return 'error: '.$!;
                   7526: 	}
                   7527:     }
                   7528:     $env{'request.role'}='cm';
                   7529:     $env{'request.role.adv'}=$env{'user.adv'};
                   7530:     $env{'browser.type'}=$clientbrowser;
                   7531: 
                   7532:     return $cookie;
                   7533: 
                   7534: }
                   7535: 
                   7536: sub _add_to_env {
                   7537:     my ($idf,$env_data,$prefix) = @_;
                   7538:     while (my ($key,$value) = each(%$env_data)) {
                   7539: 	$idf->{$prefix.$key} = $value;
                   7540: 	$env{$prefix.$key}   = $value;
                   7541:     }
                   7542: }
                   7543: 
                   7544: 
1.41      ng       7545: =pod
                   7546: 
                   7547: =back
                   7548: 
1.112     bowersj2 7549: =cut
1.41      ng       7550: 
1.112     bowersj2 7551: 1;
                   7552: __END__;
1.41      ng       7553: 

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