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

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

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