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

1.10      albertel    1: # The LearningOnline Network with CAPA
1.1       albertel    2: # a pile of common routines
1.10      albertel    3: #
1.692.4.20! raeburn     4: # $Id: loncommon.pm,v 1.692.4.19 2009/10/12 18:28:12 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.685     tempelho   64: use Apache::lonnet();
1.139     matthew    65: use HTML::Entities;
1.334     albertel   66: use Apache::lonhtmlcommon();
                     67: use Apache::loncoursedata();
1.344     albertel   68: use Apache::lontexconvert();
1.444     albertel   69: use Apache::lonclonecourse();
1.479     albertel   70: use LONCAPA qw(:DEFAULT :match);
1.657     raeburn    71: use DateTime::TimeZone;
1.687     raeburn    72: use DateTime::Locale::Catalog;
1.117     www        73: 
1.517     raeburn    74: # ---------------------------------------------- Designs
                     75: use vars qw(%defaultdesign);
                     76: 
1.22      www        77: my $readit;
                     78: 
1.517     raeburn    79: 
1.157     matthew    80: ##
                     81: ## Global Variables
                     82: ##
1.46      matthew    83: 
1.643     foxr       84: 
                     85: # ----------------------------------------------- SSI with retries:
                     86: #
                     87: 
                     88: =pod
                     89: 
1.648     raeburn    90: =head1 Server Side include with retries:
1.643     foxr       91: 
                     92: =over 4
                     93: 
1.648     raeburn    94: =item * &ssi_with_retries(resource,retries form)
1.643     foxr       95: 
                     96: Performs an ssi with some number of retries.  Retries continue either
                     97: until the result is ok or until the retry count supplied by the
                     98: caller is exhausted.  
                     99: 
                    100: Inputs:
1.648     raeburn   101: 
                    102: =over 4
                    103: 
1.643     foxr      104: resource   - Identifies the resource to insert.
1.648     raeburn   105: 
1.643     foxr      106: retries    - Count of the number of retries allowed.
1.648     raeburn   107: 
1.643     foxr      108: form       - Hash that identifies the rendering options.
                    109: 
1.648     raeburn   110: =back
                    111: 
                    112: Returns:
                    113: 
                    114: =over 4
                    115: 
1.643     foxr      116: content    - The content of the response.  If retries were exhausted this is empty.
1.648     raeburn   117: 
1.643     foxr      118: response   - The response from the last attempt (which may or may not have been successful.
                    119: 
1.648     raeburn   120: =back
                    121: 
                    122: =back
                    123: 
1.643     foxr      124: =cut
                    125: 
                    126: sub ssi_with_retries {
                    127:     my ($resource, $retries, %form) = @_;
                    128: 
                    129: 
                    130:     my $ok = 0;			# True if we got a good response.
                    131:     my $content;
                    132:     my $response;
                    133: 
                    134:     # Try to get the ssi done. within the retries count:
                    135: 
                    136:     do {
                    137: 	($content, $response) = &Apache::lonnet::ssi($resource, %form);
                    138: 	$ok      = $response->is_success;
1.650     www       139:         if (!$ok) {
                    140:             &Apache::lonnet::logthis("Failed ssi_with_retries on $resource: ".$response->is_success.', '.$response->code.', '.$response->message);
                    141:         }
1.643     foxr      142: 	$retries--;
                    143:     } while (!$ok && ($retries > 0));
                    144: 
                    145:     if (!$ok) {
                    146: 	$content = '';		# On error return an empty content.
                    147:     }
                    148:     return ($content, $response);
                    149: 
                    150: }
                    151: 
                    152: 
                    153: 
1.20      www       154: # ----------------------------------------------- Filetypes/Languages/Copyright
1.12      harris41  155: my %language;
1.124     www       156: my %supported_language;
1.12      harris41  157: my %cprtag;
1.192     taceyjo1  158: my %scprtag;
1.351     www       159: my %fe; my %fd; my %fm;
1.41      ng        160: my %category_extensions;
1.12      harris41  161: 
1.46      matthew   162: # ---------------------------------------------- Thesaurus variables
1.144     matthew   163: #
                    164: # %Keywords:
                    165: #      A hash used by &keyword to determine if a word is considered a keyword.
                    166: # $thesaurus_db_file 
                    167: #      Scalar containing the full path to the thesaurus database.
1.46      matthew   168: 
                    169: my %Keywords;
                    170: my $thesaurus_db_file;
                    171: 
1.144     matthew   172: #
                    173: # Initialize values from language.tab, copyright.tab, filetypes.tab,
                    174: # thesaurus.tab, and filecategories.tab.
                    175: #
1.18      www       176: BEGIN {
1.46      matthew   177:     # Variable initialization
                    178:     $thesaurus_db_file = $Apache::lonnet::perlvar{'lonTabDir'}."/thesaurus.db";
                    179:     #
1.22      www       180:     unless ($readit) {
1.12      harris41  181: # ------------------------------------------------------------------- languages
                    182:     {
1.158     raeburn   183:         my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}.
                    184:                                    '/language.tab';
                    185:         if ( open(my $fh,"<$langtabfile") ) {
1.356     albertel  186:             while (my $line = <$fh>) {
                    187:                 next if ($line=~/^\#/);
                    188:                 chomp($line);
                    189:                 my ($key,$two,$country,$three,$enc,$val,$sup)=(split(/\t/,$line));
1.158     raeburn   190:                 $language{$key}=$val.' - '.$enc;
                    191:                 if ($sup) {
                    192:                     $supported_language{$key}=$sup;
                    193:                 }
                    194:             }
                    195:             close($fh);
                    196:         }
1.12      harris41  197:     }
                    198: # ------------------------------------------------------------------ copyrights
                    199:     {
1.158     raeburn   200:         my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.
                    201:                                   '/copyright.tab';
                    202:         if ( open (my $fh,"<$copyrightfile") ) {
1.356     albertel  203:             while (my $line = <$fh>) {
                    204:                 next if ($line=~/^\#/);
                    205:                 chomp($line);
                    206:                 my ($key,$val)=(split(/\s+/,$line,2));
1.158     raeburn   207:                 $cprtag{$key}=$val;
                    208:             }
                    209:             close($fh);
                    210:         }
1.12      harris41  211:     }
1.351     www       212: # ----------------------------------------------------------- source copyrights
1.192     taceyjo1  213:     {
                    214:         my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.
                    215:                                   '/source_copyright.tab';
                    216:         if ( open (my $fh,"<$sourcecopyrightfile") ) {
1.356     albertel  217:             while (my $line = <$fh>) {
                    218:                 next if ($line =~ /^\#/);
                    219:                 chomp($line);
                    220:                 my ($key,$val)=(split(/\s+/,$line,2));
1.192     taceyjo1  221:                 $scprtag{$key}=$val;
                    222:             }
                    223:             close($fh);
                    224:         }
                    225:     }
1.63      www       226: 
1.517     raeburn   227: # -------------------------------------------------------------- default domain designs
1.63      www       228:     my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';
1.517     raeburn   229:     my $designfile = $designdir.'/default.tab';
                    230:     if ( open (my $fh,"<$designfile") ) {
                    231:         while (my $line = <$fh>) {
                    232:             next if ($line =~ /^\#/);
                    233:             chomp($line);
                    234:             my ($key,$val)=(split(/\=/,$line));
                    235:             if ($val) { $defaultdesign{$key}=$val; }
                    236:         }
                    237:         close($fh);
1.63      www       238:     }
                    239: 
1.15      harris41  240: # ------------------------------------------------------------- file categories
                    241:     {
1.158     raeburn   242:         my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}.
                    243:                                   '/filecategories.tab';
                    244:         if ( open (my $fh,"<$categoryfile") ) {
1.356     albertel  245: 	    while (my $line = <$fh>) {
                    246: 		next if ($line =~ /^\#/);
                    247: 		chomp($line);
                    248:                 my ($extension,$category)=(split(/\s+/,$line,2));
1.158     raeburn   249:                 push @{$category_extensions{lc($category)}},$extension;
                    250:             }
                    251:             close($fh);
                    252:         }
                    253: 
1.15      harris41  254:     }
1.12      harris41  255: # ------------------------------------------------------------------ file types
                    256:     {
1.158     raeburn   257:         my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}.
                    258:                '/filetypes.tab';
                    259:         if ( open (my $fh,"<$typesfile") ) {
1.356     albertel  260:             while (my $line = <$fh>) {
                    261: 		next if ($line =~ /^\#/);
                    262: 		chomp($line);
                    263:                 my ($ending,$emb,$mime,$descr)=split(/\s+/,$line,4);
1.158     raeburn   264:                 if ($descr ne '') {
                    265:                     $fe{$ending}=lc($emb);
                    266:                     $fd{$ending}=$descr;
1.351     www       267:                     if ($mime ne 'unk') { $fm{$ending}=$mime; }
1.158     raeburn   268:                 }
                    269:             }
                    270:             close($fh);
                    271:         }
1.12      harris41  272:     }
1.22      www       273:     &Apache::lonnet::logthis(
1.46      matthew   274:               "<font color=yellow>INFO: Read file types</font>");
1.22      www       275:     $readit=1;
1.46      matthew   276:     }  # end of unless($readit) 
1.32      matthew   277:     
                    278: }
1.112     bowersj2  279: 
1.42      matthew   280: ###############################################################
                    281: ##           HTML and Javascript Helper Functions            ##
                    282: ###############################################################
                    283: 
                    284: =pod 
                    285: 
1.112     bowersj2  286: =head1 HTML and Javascript Functions
1.42      matthew   287: 
1.112     bowersj2  288: =over 4
                    289: 
1.648     raeburn   290: =item * &browser_and_searcher_javascript()
1.112     bowersj2  291: 
                    292: X<browsing, javascript>X<searching, javascript>Returns a string
                    293: containing javascript with two functions, C<openbrowser> and
                    294: C<opensearcher>. Returned string does not contain E<lt>scriptE<gt>
                    295: tags.
1.42      matthew   296: 
1.648     raeburn   297: =item * &openbrowser(formname,elementname,only,omit) [javascript]
1.42      matthew   298: 
                    299: inputs: formname, elementname, only, omit
                    300: 
                    301: formname and elementname indicate the name of the html form and name of
                    302: the element that the results of the browsing selection are to be placed in. 
                    303: 
                    304: Specifying 'only' will restrict the browser to displaying only files
1.185     www       305: with the given extension.  Can be a comma separated list.
1.42      matthew   306: 
                    307: Specifying 'omit' will restrict the browser to NOT displaying files
1.185     www       308: with the given extension.  Can be a comma separated list.
1.42      matthew   309: 
1.648     raeburn   310: =item * &opensearcher(formname,elementname) [javascript]
1.42      matthew   311: 
                    312: Inputs: formname, elementname
                    313: 
                    314: formname and elementname specify the name of the html form and the name
                    315: of the element the selection from the search results will be placed in.
1.542     raeburn   316: 
1.42      matthew   317: =cut
                    318: 
                    319: sub browser_and_searcher_javascript {
1.199     albertel  320:     my ($mode)=@_;
                    321:     if (!defined($mode)) { $mode='edit'; }
1.453     albertel  322:     my $resurl=&escape_single(&lastresurl());
1.42      matthew   323:     return <<END;
1.219     albertel  324: // <!-- BEGIN LON-CAPA Internal
1.50      matthew   325:     var editbrowser = null;
1.135     albertel  326:     function openbrowser(formname,elementname,only,omit,titleelement) {
1.170     www       327:         var url = '$resurl/?';
1.42      matthew   328:         if (editbrowser == null) {
                    329:             url += 'launch=1&';
                    330:         }
                    331:         url += 'catalogmode=interactive&';
1.199     albertel  332:         url += 'mode=$mode&';
1.611     albertel  333:         url += 'inhibitmenu=yes&';
1.42      matthew   334:         url += 'form=' + formname + '&';
                    335:         if (only != null) {
                    336:             url += 'only=' + only + '&';
1.217     albertel  337:         } else {
                    338:             url += 'only=&';
                    339: 	}
1.42      matthew   340:         if (omit != null) {
                    341:             url += 'omit=' + omit + '&';
1.217     albertel  342:         } else {
                    343:             url += 'omit=&';
                    344: 	}
1.135     albertel  345:         if (titleelement != null) {
                    346:             url += 'titleelement=' + titleelement + '&';
1.217     albertel  347:         } else {
                    348: 	    url += 'titleelement=&';
                    349: 	}
1.42      matthew   350:         url += 'element=' + elementname + '';
                    351:         var title = 'Browser';
1.435     albertel  352:         var options = 'scrollbars=1,resizable=1,menubar=0,toolbar=1,location=1';
1.42      matthew   353:         options += ',width=700,height=600';
                    354:         editbrowser = open(url,title,options,'1');
                    355:         editbrowser.focus();
                    356:     }
                    357:     var editsearcher;
1.135     albertel  358:     function opensearcher(formname,elementname,titleelement) {
1.42      matthew   359:         var url = '/adm/searchcat?';
                    360:         if (editsearcher == null) {
                    361:             url += 'launch=1&';
                    362:         }
                    363:         url += 'catalogmode=interactive&';
1.199     albertel  364:         url += 'mode=$mode&';
1.42      matthew   365:         url += 'form=' + formname + '&';
1.135     albertel  366:         if (titleelement != null) {
                    367:             url += 'titleelement=' + titleelement + '&';
1.217     albertel  368:         } else {
                    369: 	    url += 'titleelement=&';
                    370: 	}
1.42      matthew   371:         url += 'element=' + elementname + '';
                    372:         var title = 'Search';
1.435     albertel  373:         var options = 'scrollbars=1,resizable=1,menubar=0,toolbar=1,location=1';
1.42      matthew   374:         options += ',width=700,height=600';
                    375:         editsearcher = open(url,title,options,'1');
                    376:         editsearcher.focus();
                    377:     }
1.219     albertel  378: // END LON-CAPA Internal -->
1.42      matthew   379: END
1.170     www       380: }
                    381: 
                    382: sub lastresurl {
1.258     albertel  383:     if ($env{'environment.lastresurl'}) {
                    384: 	return $env{'environment.lastresurl'}
1.170     www       385:     } else {
                    386: 	return '/res';
                    387:     }
                    388: }
                    389: 
                    390: sub storeresurl {
                    391:     my $resurl=&Apache::lonnet::clutter(shift);
                    392:     unless ($resurl=~/^\/res/) { return 0; }
                    393:     $resurl=~s/\/$//;
                    394:     &Apache::lonnet::put('environment',{'lastresurl' => $resurl});
1.646     raeburn   395:     &Apache::lonnet::appenv({'environment.lastresurl' => $resurl});
1.170     www       396:     return 1;
1.42      matthew   397: }
                    398: 
1.74      www       399: sub studentbrowser_javascript {
1.111     www       400:    unless (
1.258     albertel  401:             (($env{'request.course.id'}) && 
1.302     albertel  402:              (&Apache::lonnet::allowed('srm',$env{'request.course.id'})
                    403: 	      || &Apache::lonnet::allowed('srm',$env{'request.course.id'}.
                    404: 					  '/'.$env{'request.course.sec'})
                    405: 	      ))
1.258     albertel  406:          || ($env{'request.role'}=~/^(au|dc|su)/)
1.111     www       407:           ) { return ''; }  
1.74      www       408:    return (<<'ENDSTDBRW');
1.692.4.2  raeburn   409: <script type="text/javascript" language="Javascript">
1.692.4.4  raeburn   410: // <![CDATA[
1.74      www       411:     var stdeditbrowser;
1.692.4.2  raeburn   412:     function openstdbrowser(formname,uname,udom,roleflag,ignorefilter,courseadvonly) {
1.74      www       413:         var url = '/adm/pickstudent?';
                    414:         var filter;
1.558     albertel  415: 	if (!ignorefilter) {
                    416: 	    eval('filter=document.'+formname+'.'+uname+'.value;');
                    417: 	}
1.74      www       418:         if (filter != null) {
                    419:            if (filter != '') {
                    420:                url += 'filter='+filter+'&';
                    421: 	   }
                    422:         }
                    423:         url += 'form=' + formname + '&unameelement='+uname+
                    424:                                     '&udomelement='+udom;
1.111     www       425: 	if (roleflag) { url+="&roles=1"; }
1.692.4.2  raeburn   426:         if (courseadvonly) { url+="&courseadvonly=1"; }
1.102     www       427:         var title = 'Student_Browser';
1.74      www       428:         var options = 'scrollbars=1,resizable=1,menubar=0';
                    429:         options += ',width=700,height=600';
                    430:         stdeditbrowser = open(url,title,options,'1');
                    431:         stdeditbrowser.focus();
                    432:     }
1.692.4.4  raeburn   433: // ]]>
1.74      www       434: </script>
                    435: ENDSTDBRW
                    436: }
1.42      matthew   437: 
1.74      www       438: sub selectstudent_link {
1.692.4.2  raeburn   439:    my ($form,$unameele,$udomele,$courseadvonly)=@_;
                    440:    my $callargs = "'".$form."','".$unameele."','".$udomele."'";
1.258     albertel  441:    if ($env{'request.course.id'}) {  
1.302     albertel  442:        if (!&Apache::lonnet::allowed('srm',$env{'request.course.id'})
                    443: 	   && !&Apache::lonnet::allowed('srm',$env{'request.course.id'}.
                    444: 					'/'.$env{'request.course.sec'})) {
1.111     www       445: 	   return '';
                    446:        }
1.692.4.2  raeburn   447:        if ($courseadvonly)  {
                    448:            $callargs .= ",'',1,1";
                    449:        }
                    450:        return '<span class="LC_nobreak">'.
                    451:               '<a href="javascript:openstdbrowser('.$callargs.');">'.
                    452:               &mt('Select User').'</a></span>';
1.74      www       453:    }
1.258     albertel  454:    if ($env{'request.role'}=~/^(au|dc|su)/) {
1.692.4.2  raeburn   455:        $callargs .= ",1";
                    456:        return '<span class="LC_nobreak">'.
                    457:               '<a href="javascript:openstdbrowser('.$callargs.');">'.
                    458:               &mt('Select User').'</a></span>';
1.111     www       459:    }
                    460:    return '';
1.91      www       461: }
                    462: 
1.653     raeburn   463: sub authorbrowser_javascript {
                    464:     return <<"ENDAUTHORBRW";
                    465: <script type="text/javascript">
1.692.4.4  raeburn   466: // <![CDATA[
1.653     raeburn   467: var stdeditbrowser;
                    468: 
                    469: function openauthorbrowser(formname,udom) {
                    470:     var url = '/adm/pickauthor?';
                    471:     url += 'form='+formname+'&roledom='+udom;
                    472:     var title = 'Author_Browser';
                    473:     var options = 'scrollbars=1,resizable=1,menubar=0';
                    474:     options += ',width=700,height=600';
                    475:     stdeditbrowser = open(url,title,options,'1');
                    476:     stdeditbrowser.focus();
                    477: }
1.692.4.4  raeburn   478: // ]]>
1.653     raeburn   479: </script>
                    480: ENDAUTHORBRW
                    481: }
                    482: 
1.91      www       483: sub coursebrowser_javascript {
1.468     raeburn   484:     my ($domainfilter,$sec_element,$formname)=@_;
1.692.4.17  raeburn   485:     my $crs_or_grp_alert = &mt('Please select the type of LON-CAPA entity - Course or Community - for which you wish to add/modify a user role.');
1.692.4.9  raeburn   486:     my $id_functions = &javascript_index_functions();
                    487:     my $output = '
1.692.4.2  raeburn   488: <script type="text/javascript" language="JavaScript">
1.692.4.4  raeburn   489: // <![CDATA[
1.468     raeburn   490:     var stdeditbrowser;'."\n";
1.692.4.9  raeburn   491: 
                    492:     $output .= <<"ENDSTDBRW";
1.377     raeburn   493:     function opencrsbrowser(formname,uname,udom,desc,extra_element,multflag,crstype) {
1.91      www       494:         var url = '/adm/pickcourse?';
1.692.4.18  raeburn   495:         var formid = getFormIdByName(formname);
1.692.4.9  raeburn   496:         var domainfilter = getDomainFromSelectbox(formname,udom);
1.128     albertel  497:         if (domainfilter != null) {
                    498:            if (domainfilter != '') {
                    499:                url += 'domainfilter='+domainfilter+'&';
                    500: 	   }
                    501:         }
1.91      www       502:         url += 'form=' + formname + '&cnumelement='+uname+
1.187     albertel  503: 	                            '&cdomelement='+udom+
                    504:                                     '&cnameelement='+desc;
1.468     raeburn   505:         if (extra_element !=null && extra_element != '') {
1.594     raeburn   506:             if (formname == 'rolechoice' || formname == 'studentform') {
1.468     raeburn   507:                 url += '&roleelement='+extra_element;
                    508:                 if (domainfilter == null || domainfilter == '') {
                    509:                     url += '&domainfilter='+extra_element;
                    510:                 }
1.234     raeburn   511:             }
1.468     raeburn   512:             else {
                    513:                 if (formname == 'portform') {
                    514:                     url += '&setroles='+extra_element;
                    515:                 }
                    516:             }     
1.230     raeburn   517:         }
1.692.4.7  raeburn   518:         if (formname == 'ccrs') {
                    519:             var ownername = document.forms[formid].ccuname.value;
                    520:             var ownerdom =  document.forms[formid].ccdomain.options[document.forms[formid].ccdomain.selectedIndex].value;
                    521:             url += '&cloner='+ownername+':'+ownerdom;
                    522:         }
1.293     raeburn   523:         if (multflag !=null && multflag != '') {
                    524:             url += '&multiple='+multflag;
                    525:         }
1.692.4.6  raeburn   526:         if (crstype == 'Course/Community') {
1.377     raeburn   527:             if (formname == 'cu') {
                    528:                 crstype = document.cu.crstype.options[document.cu.crstype.selectedIndex].value; 
                    529:                 if (crstype == "") {
                    530:                     alert("$crs_or_grp_alert");
                    531:                     return;
                    532:                 }
                    533:             }
                    534:         }
                    535:         if (crstype !=null && crstype != '') {
                    536:             url += '&type='+crstype;
                    537:         }
1.102     www       538:         var title = 'Course_Browser';
1.91      www       539:         var options = 'scrollbars=1,resizable=1,menubar=0';
                    540:         options += ',width=700,height=600';
                    541:         stdeditbrowser = open(url,title,options,'1');
                    542:         stdeditbrowser.focus();
                    543:     }
1.692.4.9  raeburn   544: $id_functions
1.91      www       545: ENDSTDBRW
1.468     raeburn   546:     if ($sec_element ne '') {
                    547:         $output .= &setsec_javascript($sec_element,$formname);
                    548:     }
                    549:     $output .= '
1.692.4.4  raeburn   550: // ]]>
1.468     raeburn   551: </script>';
                    552:     return $output;
                    553: }
                    554: 
1.692.4.9  raeburn   555: sub javascript_index_functions {
                    556:     return <<"ENDJS";
                    557: 
                    558: function getFormIdByName(formname) {
                    559:     for (var i=0;i<document.forms.length;i++) {
                    560:         if (document.forms[i].name == formname) {
                    561:             return i;
                    562:         }
                    563:     }
                    564:     return -1;
                    565: }
                    566: 
                    567: function getIndexByName(formid,item) {
                    568:     for (var i=0;i<document.forms[formid].elements.length;i++) {
                    569:         if (document.forms[formid].elements[i].name == item) {
                    570:             return i;
                    571:         }
                    572:     }
                    573:     return -1;
                    574: }
                    575: 
                    576: function getDomainFromSelectbox(formname,udom) {
                    577:     var userdom;
                    578:     var formid = getFormIdByName(formname);
                    579:     if (formid > -1) {
                    580:         var domid = getIndexByName(formid,udom);
                    581:         if (domid > -1) {
                    582:             if (document.forms[formid].elements[domid].type == 'select-one') {
                    583:                 userdom=document.forms[formid].elements[domid].options[document.forms[formid].elements[domid].selectedIndex].value;
                    584:             }
                    585:             if (document.forms[formid].elements[domid].type == 'hidden') {
                    586:                 userdom=document.forms[formid].elements[domid].value;
                    587:             }
                    588:         }
                    589:     }
                    590:     return userdom;
                    591: }
                    592: 
                    593: ENDJS
                    594: 
                    595: }
                    596: 
                    597: sub userbrowser_javascript {
                    598:     my $id_functions = &javascript_index_functions();
                    599:     return <<"ENDUSERBRW";
                    600: 
1.692.4.17  raeburn   601: function openuserbrowser(formname,uname,udom,ulast,ufirst,uemail,hideudom,crsdom,caller) {
1.692.4.9  raeburn   602:     var url = '/adm/pickuser?';
                    603:     var userdom = getDomainFromSelectbox(formname,udom);
                    604:     if (userdom != null) {
                    605:        if (userdom != '') {
                    606:            url += 'srchdom='+userdom+'&';
                    607:        }
                    608:     }
                    609:     url += 'form=' + formname + '&unameelement='+uname+
                    610:                                 '&udomelement='+udom+
                    611:                                 '&ulastelement='+ulast+
                    612:                                 '&ufirstelement='+ufirst+
                    613:                                 '&uemailelement='+uemail+
                    614:                                 '&hideudomelement='+hideudom+
                    615:                                 '&coursedom='+crsdom;
1.692.4.17  raeburn   616:     if ((caller != null) && (caller != undefined)) {
                    617:         url += '&caller='+caller;
                    618:     }
1.692.4.9  raeburn   619:     var title = 'User_Browser';
                    620:     var options = 'scrollbars=1,resizable=1,menubar=0';
                    621:     options += ',width=700,height=600';
                    622:     var stdeditbrowser = open(url,title,options,'1');
                    623:     stdeditbrowser.focus();
                    624: }
                    625: 
1.692.4.17  raeburn   626: function fix_domain (formname,udom,origdom,uname) {
1.692.4.9  raeburn   627:     var formid = getFormIdByName(formname);
                    628:     if (formid > -1) {
1.692.4.17  raeburn   629:         var unameid = getIndexByName(formid,uname);
1.692.4.9  raeburn   630:         var domid = getIndexByName(formid,udom);
                    631:         var hidedomid = getIndexByName(formid,origdom);
                    632:         if (hidedomid > -1) {
                    633:             var fixeddom = document.forms[formid].elements[hidedomid].value;
1.692.4.17  raeburn   634:             var unameval = document.forms[formid].elements[unameid].value;
                    635:             if ((fixeddom != '') && (fixeddom != undefined) && (fixeddom != null) && (unameval != '') && (unameval != undefined) && (unameval != null)) {
                    636:                 if (domid > -1) {
                    637:                     var slct = document.forms[formid].elements[domid];
                    638:                     if (slct.type == 'select-one') {
                    639:                         var i;
                    640:                         for (i=0;i<slct.length;i++) {
                    641:                             if (slct.options[i].value==fixeddom) { slct.selectedIndex=i; }
                    642:                         }
                    643:                     }
                    644:                     if (slct.type == 'hidden') {
                    645:                         slct.value = fixeddom;
1.692.4.9  raeburn   646:                     }
                    647:                 }
                    648:             }
                    649:         }
                    650:     }
                    651:     return;
                    652: }
                    653: 
                    654: $id_functions
                    655: ENDUSERBRW
                    656: }
                    657: 
                    658: 
1.468     raeburn   659: sub setsec_javascript {
                    660:     my ($sec_element,$formname) = @_;
                    661:     my $setsections = qq|
                    662: function setSect(sectionlist) {
1.629     raeburn   663:     var sectionsArray = new Array();
                    664:     if ((sectionlist != '') && (typeof sectionlist != "undefined")) {
                    665:         sectionsArray = sectionlist.split(",");
                    666:     }
1.468     raeburn   667:     var numSections = sectionsArray.length;
                    668:     document.$formname.$sec_element.length = 0;
                    669:     if (numSections == 0) {
                    670:         document.$formname.$sec_element.multiple=false;
                    671:         document.$formname.$sec_element.size=1;
                    672:         document.$formname.$sec_element.options[0] = new Option('No existing sections','',false,false)
                    673:     } else {
                    674:         if (numSections == 1) {
                    675:             document.$formname.$sec_element.multiple=false;
                    676:             document.$formname.$sec_element.size=1;
                    677:             document.$formname.$sec_element.options[0] = new Option('Select','',true,true);
                    678:             document.$formname.$sec_element.options[1] = new Option('No section','',false,false)
                    679:             document.$formname.$sec_element.options[2] = new Option(sectionsArray[0],sectionsArray[0],false,false);
                    680:         } else {
                    681:             for (var i=0; i<numSections; i++) {
                    682:                 document.$formname.$sec_element.options[i] = new Option(sectionsArray[i],sectionsArray[i],false,false)
                    683:             }
                    684:             document.$formname.$sec_element.multiple=true
                    685:             if (numSections < 3) {
                    686:                 document.$formname.$sec_element.size=numSections;
                    687:             } else {
                    688:                 document.$formname.$sec_element.size=3;
                    689:             }
                    690:             document.$formname.$sec_element.options[0].selected = false
                    691:         }
                    692:     }
1.91      www       693: }
1.468     raeburn   694: |;
                    695:     return $setsections;
                    696: }
                    697: 
1.91      www       698: 
                    699: sub selectcourse_link {
1.377     raeburn   700:    my ($form,$unameele,$udomele,$desc,$extra_element,$multflag,$selecttype)=@_;
1.692.4.6  raeburn   701:    my $linktext = &mt('Select Course');
                    702:    if ($selecttype eq 'Community') {
                    703:        $linktext = &mt('Select Community');
                    704:    }
1.692.4.2  raeburn   705:    return '<span class="LC_nobreak">'
                    706:          ."<a href='"
                    707:          .'javascript:opencrsbrowser("'.$form.'","'.$unameele
                    708:          .'","'.$udomele.'","'.$desc.'","'.$extra_element
                    709:          .'","'.$multflag.'","'.$selecttype.'");'
1.692.4.6  raeburn   710:          ."'>".$linktext.'</a>'
1.692.4.2  raeburn   711:          .'</span>';
1.74      www       712: }
1.42      matthew   713: 
1.653     raeburn   714: sub selectauthor_link {
                    715:    my ($form,$udom)=@_;
                    716:    return '<a href="javascript:openauthorbrowser('."'$form','$udom'".');">'.
                    717:           &mt('Select Author').'</a>';
                    718: }
                    719: 
1.692.4.9  raeburn   720: sub selectuser_link {
                    721:     my ($form,$unameelem,$domelem,$lastelem,$firstelem,$emailelem,$hdomelem,
1.692.4.17  raeburn   722:         $coursedom,$linktext,$caller) = @_;
1.692.4.9  raeburn   723:     return '<a href="javascript:openuserbrowser('."'$form','$unameelem','$domelem',".
1.692.4.17  raeburn   724:            "'$lastelem','$firstelem','$emailelem','$hdomelem','$coursedom','$caller'".
1.692.4.9  raeburn   725:            ');">'.$linktext.'</a>';
                    726: }
                    727: 
1.273     raeburn   728: sub check_uncheck_jscript {
                    729:     my $jscript = <<"ENDSCRT";
                    730: function checkAll(field) {
                    731:     if (field.length > 0) {
                    732:         for (i = 0; i < field.length; i++) {
                    733:             field[i].checked = true ;
                    734:         }
                    735:     } else {
                    736:         field.checked = true
                    737:     }
                    738: }
                    739:  
                    740: function uncheckAll(field) {
                    741:     if (field.length > 0) {
                    742:         for (i = 0; i < field.length; i++) {
                    743:             field[i].checked = false ;
1.543     albertel  744:         }
                    745:     } else {
1.273     raeburn   746:         field.checked = false ;
                    747:     }
                    748: }
                    749: ENDSCRT
                    750:     return $jscript;
                    751: }
                    752: 
1.656     www       753: sub select_timezone {
1.659     raeburn   754:    my ($name,$selected,$onchange,$includeempty)=@_;
                    755:    my $output='<select name="'.$name.'" '.$onchange.'>'."\n";
                    756:    if ($includeempty) {
                    757:        $output .= '<option value=""';
                    758:        if (($selected eq '') || ($selected eq 'local')) {
                    759:            $output .= ' selected="selected" ';
                    760:        }
                    761:        $output .= '> </option>';
                    762:    }
1.657     raeburn   763:    my @timezones = DateTime::TimeZone->all_names;
                    764:    foreach my $tzone (@timezones) {
                    765:        $output.= '<option value="'.$tzone.'"';
                    766:        if ($tzone eq $selected) {
                    767:            $output.=' selected="selected"';
                    768:        }
                    769:        $output.=">$tzone</option>\n";
1.656     www       770:    }
                    771:    $output.="</select>";
                    772:    return $output;
                    773: }
1.273     raeburn   774: 
1.687     raeburn   775: sub select_datelocale {
                    776:     my ($name,$selected,$onchange,$includeempty)=@_;
                    777:     my $output='<select name="'.$name.'" '.$onchange.'>'."\n";
                    778:     if ($includeempty) {
                    779:         $output .= '<option value=""';
                    780:         if ($selected eq '') {
                    781:             $output .= ' selected="selected" ';
                    782:         }
                    783:         $output .= '> </option>';
                    784:     }
                    785:     my (@possibles,%locale_names);
                    786:     my @locales = DateTime::Locale::Catalog::Locales;
                    787:     foreach my $locale (@locales) {
                    788:         if (ref($locale) eq 'HASH') {
                    789:             my $id = $locale->{'id'};
                    790:             if ($id ne '') {
                    791:                 my $en_terr = $locale->{'en_territory'};
                    792:                 my $native_terr = $locale->{'native_territory'};
1.692.4.1  raeburn   793:                 my @languages = &Apache::lonlocal::preferred_languages();
1.687     raeburn   794:                 if (grep(/^en$/,@languages) || !@languages) {
                    795:                     if ($en_terr ne '') {
                    796:                         $locale_names{$id} = '('.$en_terr.')';
                    797:                     } elsif ($native_terr ne '') {
                    798:                         $locale_names{$id} = $native_terr;
                    799:                     }
                    800:                 } else {
                    801:                     if ($native_terr ne '') {
                    802:                         $locale_names{$id} = $native_terr.' ';
                    803:                     } elsif ($en_terr ne '') {
                    804:                         $locale_names{$id} = '('.$en_terr.')';
                    805:                     }
                    806:                 }
                    807:                 push (@possibles,$id);
                    808:             }
                    809:         }
                    810:     }
                    811:     foreach my $item (sort(@possibles)) {
                    812:         $output.= '<option value="'.$item.'"';
                    813:         if ($item eq $selected) {
                    814:             $output.=' selected="selected"';
                    815:         }
                    816:         $output.=">$item";
                    817:         if ($locale_names{$item} ne '') {
                    818:             $output.="  $locale_names{$item}</option>\n";
                    819:         }
                    820:         $output.="</option>\n";
                    821:     }
                    822:     $output.="</select>";
                    823:     return $output;
                    824: }
                    825: 
1.692.4.2  raeburn   826: sub select_language {
                    827:     my ($name,$selected,$includeempty) = @_;
                    828:     my %langchoices;
                    829:     if ($includeempty) {
                    830:         %langchoices = ('' => 'No language preference');
                    831:     }
                    832:     foreach my $id (&languageids()) {
                    833:         my $code = &supportedlanguagecode($id);
                    834:         if ($code) {
                    835:             $langchoices{$code} = &plainlanguagedescription($id);
                    836:         }
                    837:     }
                    838:     return &select_form($selected,$name,%langchoices);
                    839: }
                    840: 
1.42      matthew   841: =pod
1.36      matthew   842: 
1.648     raeburn   843: =item * &linked_select_forms(...)
1.36      matthew   844: 
                    845: linked_select_forms returns a string containing a <script></script> block
                    846: and html for two <select> menus.  The select menus will be linked in that
                    847: changing the value of the first menu will result in new values being placed
                    848: in the second menu.  The values in the select menu will appear in alphabetical
1.609     raeburn   849: order unless a defined order is provided.
1.36      matthew   850: 
                    851: linked_select_forms takes the following ordered inputs:
                    852: 
                    853: =over 4
                    854: 
1.112     bowersj2  855: =item * $formname, the name of the <form> tag
1.36      matthew   856: 
1.112     bowersj2  857: =item * $middletext, the text which appears between the <select> tags
1.36      matthew   858: 
1.112     bowersj2  859: =item * $firstdefault, the default value for the first menu
1.36      matthew   860: 
1.112     bowersj2  861: =item * $firstselectname, the name of the first <select> tag
1.36      matthew   862: 
1.112     bowersj2  863: =item * $secondselectname, the name of the second <select> tag
1.36      matthew   864: 
1.112     bowersj2  865: =item * $hashref, a reference to a hash containing the data for the menus.
1.36      matthew   866: 
1.609     raeburn   867: =item * $menuorder, the order of values in the first menu
                    868: 
1.41      ng        869: =back 
                    870: 
1.36      matthew   871: Below is an example of such a hash.  Only the 'text', 'default', and 
                    872: 'select2' keys must appear as stated.  keys(%menu) are the possible 
                    873: values for the first select menu.  The text that coincides with the 
1.41      ng        874: first menu value is given in $menu{$choice1}->{'text'}.  The values 
1.36      matthew   875: and text for the second menu are given in the hash pointed to by 
                    876: $menu{$choice1}->{'select2'}.  
                    877: 
1.112     bowersj2  878:  my %menu = ( A1 => { text =>"Choice A1" ,
                    879:                        default => "B3",
                    880:                        select2 => { 
                    881:                            B1 => "Choice B1",
                    882:                            B2 => "Choice B2",
                    883:                            B3 => "Choice B3",
                    884:                            B4 => "Choice B4"
1.609     raeburn   885:                            },
                    886:                        order => ['B4','B3','B1','B2'],
1.112     bowersj2  887:                    },
                    888:                A2 => { text =>"Choice A2" ,
                    889:                        default => "C2",
                    890:                        select2 => { 
                    891:                            C1 => "Choice C1",
                    892:                            C2 => "Choice C2",
                    893:                            C3 => "Choice C3"
1.609     raeburn   894:                            },
                    895:                        order => ['C2','C1','C3'],
1.112     bowersj2  896:                    },
                    897:                A3 => { text =>"Choice A3" ,
                    898:                        default => "D6",
                    899:                        select2 => { 
                    900:                            D1 => "Choice D1",
                    901:                            D2 => "Choice D2",
                    902:                            D3 => "Choice D3",
                    903:                            D4 => "Choice D4",
                    904:                            D5 => "Choice D5",
                    905:                            D6 => "Choice D6",
                    906:                            D7 => "Choice D7"
1.609     raeburn   907:                            },
                    908:                        order => ['D4','D3','D2','D1','D7','D6','D5'],
1.112     bowersj2  909:                    }
                    910:                );
1.36      matthew   911: 
                    912: =cut
                    913: 
                    914: sub linked_select_forms {
                    915:     my ($formname,
                    916:         $middletext,
                    917:         $firstdefault,
                    918:         $firstselectname,
                    919:         $secondselectname, 
1.609     raeburn   920:         $hashref,
                    921:         $menuorder,
1.36      matthew   922:         ) = @_;
                    923:     my $second = "document.$formname.$secondselectname";
                    924:     my $first = "document.$formname.$firstselectname";
                    925:     # output the javascript to do the changing
                    926:     my $result = '';
1.692.4.2  raeburn   927:     $result.='<script type="text/javascript" language="JavaScript">'."\n";
1.692.4.4  raeburn   928:     $result.="// <![CDATA[\n";
1.36      matthew   929:     $result.="var select2data = new Object();\n";
                    930:     $" = '","';
                    931:     my $debug = '';
                    932:     foreach my $s1 (sort(keys(%$hashref))) {
                    933:         $result.="select2data.d_$s1 = new Object();\n";        
                    934:         $result.="select2data.d_$s1.def = new String('".
                    935:             $hashref->{$s1}->{'default'}."');\n";
1.609     raeburn   936:         $result.="select2data.d_$s1.values = new Array(";
1.36      matthew   937:         my @s2values = sort(keys( %{ $hashref->{$s1}->{'select2'} } ));
1.609     raeburn   938:         if (ref($hashref->{$s1}->{'order'}) eq 'ARRAY') {
                    939:             @s2values = @{$hashref->{$s1}->{'order'}};
                    940:         }
1.36      matthew   941:         $result.="\"@s2values\");\n";
                    942:         $result.="select2data.d_$s1.texts = new Array(";        
                    943:         my @s2texts;
                    944:         foreach my $value (@s2values) {
                    945:             push @s2texts, $hashref->{$s1}->{'select2'}->{$value};
                    946:         }
                    947:         $result.="\"@s2texts\");\n";
                    948:     }
                    949:     $"=' ';
                    950:     $result.= <<"END";
                    951: 
                    952: function select1_changed() {
                    953:     // Determine new choice
                    954:     var newvalue = "d_" + $first.value;
                    955:     // update select2
                    956:     var values     = select2data[newvalue].values;
                    957:     var texts      = select2data[newvalue].texts;
                    958:     var select2def = select2data[newvalue].def;
                    959:     var i;
                    960:     // out with the old
                    961:     for (i = 0; i < $second.options.length; i++) {
                    962:         $second.options[i] = null;
                    963:     }
                    964:     // in with the nuclear
                    965:     for (i=0;i<values.length; i++) {
                    966:         $second.options[i] = new Option(values[i]);
1.143     matthew   967:         $second.options[i].value = values[i];
1.36      matthew   968:         $second.options[i].text = texts[i];
                    969:         if (values[i] == select2def) {
                    970:             $second.options[i].selected = true;
                    971:         }
                    972:     }
                    973: }
1.692.4.4  raeburn   974: // ]]>
1.36      matthew   975: </script>
                    976: END
                    977:     # output the initial values for the selection lists
                    978:     $result .= "<select size=\"1\" name=\"$firstselectname\" onchange=\"select1_changed()\">\n";
1.609     raeburn   979:     my @order = sort(keys(%{$hashref}));
                    980:     if (ref($menuorder) eq 'ARRAY') {
                    981:         @order = @{$menuorder};
                    982:     }
                    983:     foreach my $value (@order) {
1.36      matthew   984:         $result.="    <option value=\"$value\" ";
1.253     albertel  985:         $result.=" selected=\"selected\" " if ($value eq $firstdefault);
1.119     www       986:         $result.=">".&mt($hashref->{$value}->{'text'})."</option>\n";
1.36      matthew   987:     }
                    988:     $result .= "</select>\n";
                    989:     my %select2 = %{$hashref->{$firstdefault}->{'select2'}};
                    990:     $result .= $middletext;
                    991:     $result .= "<select size=\"1\" name=\"$secondselectname\">\n";
                    992:     my $seconddefault = $hashref->{$firstdefault}->{'default'};
1.609     raeburn   993:     
                    994:     my @secondorder = sort(keys(%select2));
                    995:     if (ref($hashref->{$firstdefault}->{'order'}) eq 'ARRAY') {
                    996:         @secondorder = @{$hashref->{$firstdefault}->{'order'}};
                    997:     }
                    998:     foreach my $value (@secondorder) {
1.36      matthew   999:         $result.="    <option value=\"$value\" ";        
1.253     albertel 1000:         $result.=" selected=\"selected\" " if ($value eq $seconddefault);
1.119     www      1001:         $result.=">".&mt($select2{$value})."</option>\n";
1.36      matthew  1002:     }
                   1003:     $result .= "</select>\n";
                   1004:     #    return $debug;
                   1005:     return $result;
                   1006: }   #  end of sub linked_select_forms {
                   1007: 
1.45      matthew  1008: =pod
1.44      bowersj2 1009: 
1.648     raeburn  1010: =item * &help_open_topic($topic,$text,$stayOnPage,$width,$height)
1.44      bowersj2 1011: 
1.112     bowersj2 1012: Returns a string corresponding to an HTML link to the given help
                   1013: $topic, where $topic corresponds to the name of a .tex file in
                   1014: /home/httpd/html/adm/help/tex, with underscores replaced by
                   1015: spaces. 
                   1016: 
                   1017: $text will optionally be linked to the same topic, allowing you to
                   1018: link text in addition to the graphic. If you do not want to link
                   1019: text, but wish to specify one of the later parameters, pass an
                   1020: empty string. 
                   1021: 
                   1022: $stayOnPage is a value that will be interpreted as a boolean. If true,
                   1023: the link will not open a new window. If false, the link will open
                   1024: a new window using Javascript. (Default is false.) 
                   1025: 
                   1026: $width and $height are optional numerical parameters that will
                   1027: override the width and height of the popped up window, which may
                   1028: be useful for certain help topics with big pictures included. 
1.44      bowersj2 1029: 
                   1030: =cut
                   1031: 
                   1032: sub help_open_topic {
1.48      bowersj2 1033:     my ($topic, $text, $stayOnPage, $width, $height) = @_;
                   1034:     $text = "" if (not defined $text);
1.44      bowersj2 1035:     $stayOnPage = 0 if (not defined $stayOnPage);
1.552     banghart 1036:     if ($env{'browser.interface'} eq 'textual') {
1.79      www      1037: 	$stayOnPage=1;
                   1038:     }
1.44      bowersj2 1039:     $width = 350 if (not defined $width);
                   1040:     $height = 400 if (not defined $height);
                   1041:     my $filename = $topic;
                   1042:     $filename =~ s/ /_/g;
                   1043: 
1.48      bowersj2 1044:     my $template = "";
                   1045:     my $link;
1.572     banghart 1046:     
1.159     www      1047:     $topic=~s/\W/\_/g;
1.44      bowersj2 1048: 
1.572     banghart 1049:     if (!$stayOnPage) {
1.72      bowersj2 1050: 	$link = "javascript:void(open('/adm/help/${filename}.hlp', 'Help_for_$topic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";
1.572     banghart 1051:     } else {
1.48      bowersj2 1052: 	$link = "/adm/help/${filename}.hlp";
                   1053:     }
                   1054: 
                   1055:     # Add the text
1.572     banghart 1056:     if ($text ne "") {
1.77      www      1057: 	$template .= 
1.572     banghart 1058:             "<table bgcolor='#3333AA' cellspacing='1' cellpadding='1' border='0'><tr>".
1.691     bisitz   1059:             "<td bgcolor='#5555FF'><span class=\"LC_nobreak\"><a target=\"_top\" href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
1.48      bowersj2 1060:     }
                   1061: 
                   1062:     # Add the graphic
1.179     matthew  1063:     my $title = &mt('Online Help');
1.667     raeburn  1064:     my $helpicon=&lonhttpdurl("/adm/help/help.png");
1.692.4.2  raeburn  1065:     $template .= '<a target="_top" href="'.$link.'" title="'.$title.'">'.
                   1066:                  '<img src="'.$helpicon.'" border="0" alt="'.&mt('Help: [_1]',$topic).
                   1067:                  '" title="'.$title.'" /></a>';
                   1068:     if ($text ne '') {
                   1069:         $template.='</span></td></tr></table>';
                   1070:     }
1.44      bowersj2 1071:     return $template;
                   1072: 
1.106     bowersj2 1073: }
                   1074: 
                   1075: # This is a quicky function for Latex cheatsheet editing, since it 
                   1076: # appears in at least four places
                   1077: sub helpLatexCheatsheet {
1.692.4.2  raeburn  1078:     my ($topic,$text,$not_author) = @_;
                   1079:     my $out;
1.106     bowersj2 1080:     my $addOther = '';
1.692.4.3  raeburn  1081:     if ($topic) {
1.692.4.2  raeburn  1082: 	$addOther = &Apache::loncommon::help_open_topic($topic,$text,
1.106     bowersj2 1083: 						       undef, undef, 600) .
                   1084: 							   '</td><td>';
                   1085:     }
1.692.4.2  raeburn  1086:     $out = '<table><tr><td>'.
                   1087:            $addOther .
                   1088:            &Apache::loncommon::help_open_topic("Greek_Symbols",&mt('Greek Symbols'),
                   1089:                                                undef,undef,600).
                   1090:            '</td><td>'.
                   1091:            &Apache::loncommon::help_open_topic("Other_Symbols",&mt('Other Symbols'),
                   1092:                                                undef,undef,600).
                   1093:            '</td>';
                   1094:     unless ($not_author) {
                   1095:         $out .= '<td>'.
                   1096:                 &Apache::loncommon::help_open_topic("Authoring_Output_Tags",&mt('Output Tags'),
                   1097:                                                     undef,undef,600).
                   1098:                 '</td>';
                   1099:     }
                   1100:     $out .= '</tr></table>';
                   1101:     return $out;
1.172     www      1102: }
                   1103: 
1.430     albertel 1104: sub general_help {
                   1105:     my $helptopic='Student_Intro';
                   1106:     if ($env{'request.role'}=~/^(ca|au)/) {
                   1107: 	$helptopic='Authoring_Intro';
                   1108:     } elsif ($env{'request.role'}=~/^cc/) {
                   1109: 	$helptopic='Course_Coordination_Intro';
1.672     raeburn  1110:     } elsif ($env{'request.role'}=~/^dc/) {
                   1111:         $helptopic='Domain_Coordination_Intro';
1.430     albertel 1112:     }
                   1113:     return $helptopic;
                   1114: }
                   1115: 
                   1116: sub update_help_link {
                   1117:     my ($topic,$component_help,$faq,$bug,$stayOnPage) = @_;
                   1118:     my $origurl = $ENV{'REQUEST_URI'};
                   1119:     $origurl=~s|^/~|/priv/|;
                   1120:     my $timestamp = time;
                   1121:     foreach my $datum (\$topic,\$component_help,\$faq,\$bug,\$origurl) {
                   1122:         $$datum = &escape($$datum);
                   1123:     }
                   1124: 
                   1125:     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";
                   1126:     my $output .= <<"ENDOUTPUT";
                   1127: <script type="text/javascript">
1.692.4.4  raeburn  1128: // <![CDATA[
1.430     albertel 1129: banner_link = '$banner_link';
1.692.4.4  raeburn  1130: // ]]>
1.430     albertel 1131: </script>
                   1132: ENDOUTPUT
                   1133:     return $output;
                   1134: }
                   1135: 
                   1136: # now just updates the help link and generates a blue icon
1.193     raeburn  1137: sub help_open_menu {
1.430     albertel 1138:     my ($topic,$component_help,$faq,$bug,$stayOnPage,$width,$height,$text) 
1.552     banghart 1139: 	= @_;    
1.430     albertel 1140:     $stayOnPage = 0 if (not defined $stayOnPage);
1.572     banghart 1141:     # only use pop-up help (stayOnPage == 0)
1.552     banghart 1142:     # if environment.remote is on (using remote control UI)
1.572     banghart 1143:     if ($env{'browser.interface'} eq 'textual' ||
                   1144:     	$env{'environment.remote'} eq 'off' ) {
1.552     banghart 1145:         $stayOnPage=1;
1.430     albertel 1146:     }
                   1147:     my $output;
                   1148:     if ($component_help) {
                   1149: 	if (!$text) {
                   1150: 	    $output=&help_open_topic($component_help,undef,$stayOnPage,
                   1151: 				       $width,$height);
                   1152: 	} else {
                   1153: 	    my $help_text;
                   1154: 	    $help_text=&unescape($topic);
                   1155: 	    $output='<table><tr><td>'.
                   1156: 		&help_open_topic($component_help,$help_text,$stayOnPage,
                   1157: 				 $width,$height).'</td></tr></table>';
                   1158: 	}
                   1159:     }
                   1160:     my $banner_link = &update_help_link($topic,$component_help,$faq,$bug,$stayOnPage);
                   1161:     return $output.$banner_link;
                   1162: }
                   1163: 
                   1164: sub top_nav_help {
                   1165:     my ($text) = @_;
1.436     albertel 1166:     $text = &mt($text);
1.572     banghart 1167:     my $stay_on_page = 
1.436     albertel 1168: 	($env{'browser.interface'}  eq 'textual' ||
                   1169: 	 $env{'environment.remote'} eq 'off' );
1.572     banghart 1170:     my $link = ($stay_on_page) ? "javascript:helpMenu('display')"
1.436     albertel 1171: 	                     : "javascript:helpMenu('open')";
1.572     banghart 1172:     my $banner_link = &update_help_link(undef,undef,undef,undef,$stay_on_page);
1.436     albertel 1173: 
1.201     raeburn  1174:     my $title = &mt('Get help');
1.436     albertel 1175: 
                   1176:     return <<"END";
                   1177: $banner_link
                   1178:  <a href="$link" title="$title">$text</a>
                   1179: END
                   1180: }
                   1181: 
                   1182: sub help_menu_js {
                   1183:     my ($text) = @_;
                   1184: 
                   1185:     my $stayOnPage = 
                   1186: 	($env{'browser.interface'}  eq 'textual' ||
                   1187: 	 $env{'environment.remote'} eq 'off' );
                   1188: 
                   1189:     my $width = 620;
                   1190:     my $height = 600;
1.430     albertel 1191:     my $helptopic=&general_help();
                   1192:     my $details_link = '/adm/help/'.$helptopic.'.hlp';
1.261     albertel 1193:     my $nothing=&Apache::lonhtmlcommon::javascript_nothing();
1.331     albertel 1194:     my $start_page =
                   1195:         &Apache::loncommon::start_page('Help Menu', undef,
                   1196: 				       {'frameset'    => 1,
                   1197: 					'js_ready'    => 1,
                   1198: 					'add_entries' => {
                   1199: 					    'border' => '0',
1.579     raeburn  1200: 					    'rows'   => "110,*",},});
1.331     albertel 1201:     my $end_page =
                   1202:         &Apache::loncommon::end_page({'frameset' => 1,
                   1203: 				      'js_ready' => 1,});
                   1204: 
1.436     albertel 1205:     my $template .= <<"ENDTEMPLATE";
                   1206: <script type="text/javascript">
1.253     albertel 1207: // <![CDATA[
1.692.4.10  raeburn  1208: // <!-- BEGIN LON-CAPA Internal
1.430     albertel 1209: var banner_link = '';
1.243     raeburn  1210: function helpMenu(target) {
                   1211:     var caller = this;
                   1212:     if (target == 'open') {
                   1213:         var newWindow = null;
                   1214:         try {
1.262     albertel 1215:             newWindow =  window.open($nothing,"helpmenu","HEIGHT=$height,WIDTH=$width,resizable=yes,scrollbars=yes" )
1.243     raeburn  1216:         }
                   1217:         catch(error) {
                   1218:             writeHelp(caller);
                   1219:             return;
                   1220:         }
                   1221:         if (newWindow) {
                   1222:             caller = newWindow;
                   1223:         }
1.193     raeburn  1224:     }
1.243     raeburn  1225:     writeHelp(caller);
                   1226:     return;
                   1227: }
                   1228: function writeHelp(caller) {
1.430     albertel 1229:     caller.document.writeln('$start_page<frame name="bannerframe"  src="'+banner_link+'" /><frame name="bodyframe" src="$details_link" /> $end_page')
1.243     raeburn  1230:     caller.document.close()
                   1231:     caller.focus()
1.193     raeburn  1232: }
1.219     albertel 1233: // END LON-CAPA Internal -->
1.692.4.10  raeburn  1234: // ]]>
1.436     albertel 1235: </script>
1.193     raeburn  1236: ENDTEMPLATE
                   1237:     return $template;
                   1238: }
                   1239: 
1.172     www      1240: sub help_open_bug {
                   1241:     my ($topic, $text, $stayOnPage, $width, $height) = @_;
1.258     albertel 1242:     unless ($env{'user.adv'}) { return ''; }
1.172     www      1243:     unless ($Apache::lonnet::perlvar{'BugzillaHost'}) { return ''; }
                   1244:     $text = "" if (not defined $text);
                   1245:     $stayOnPage = 0 if (not defined $stayOnPage);
1.258     albertel 1246:     if ($env{'browser.interface'} eq 'textual' ||
                   1247: 	$env{'environment.remote'} eq 'off' ) {
1.172     www      1248: 	$stayOnPage=1;
                   1249:     }
1.184     albertel 1250:     $width = 600 if (not defined $width);
                   1251:     $height = 600 if (not defined $height);
1.172     www      1252: 
                   1253:     $topic=~s/\W+/\+/g;
                   1254:     my $link='';
                   1255:     my $template='';
1.379     albertel 1256:     my $url=$Apache::lonnet::perlvar{'BugzillaHost'}.'enter_bug.cgi?product=LON-CAPA&amp;bug_file_loc='.
                   1257: 	&escape($ENV{'REQUEST_URI'}).'&amp;component='.$topic;
1.172     www      1258:     if (!$stayOnPage)
                   1259:     {
                   1260: 	$link = "javascript:void(open('$url', 'Bugzilla', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";
                   1261:     }
                   1262:     else
                   1263:     {
                   1264: 	$link = $url;
                   1265:     }
                   1266:     # Add the text
                   1267:     if ($text ne "")
                   1268:     {
                   1269: 	$template .= 
                   1270:   "<table bgcolor='#AA3333' cellspacing='1' cellpadding='1' border='0'><tr>".
1.436     albertel 1271:   "<td bgcolor='#FF5555'><a target=\"_top\" href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
1.172     www      1272:     }
                   1273: 
                   1274:     # Add the graphic
1.179     matthew  1275:     my $title = &mt('Report a Bug');
1.215     albertel 1276:     my $bugicon=&lonhttpdurl("/adm/lonMisc/smallBug.gif");
1.172     www      1277:     $template .= <<"ENDTEMPLATE";
1.436     albertel 1278:  <a target="_top" href="$link" title="$title"><img src="$bugicon" border="0" alt="(Bug: $topic)" /></a>
1.172     www      1279: ENDTEMPLATE
                   1280:     if ($text ne '') { $template.='</td></tr></table>' };
                   1281:     return $template;
                   1282: 
                   1283: }
                   1284: 
                   1285: sub help_open_faq {
                   1286:     my ($topic, $text, $stayOnPage, $width, $height) = @_;
1.258     albertel 1287:     unless ($env{'user.adv'}) { return ''; }
1.172     www      1288:     unless ($Apache::lonnet::perlvar{'FAQHost'}) { return ''; }
                   1289:     $text = "" if (not defined $text);
                   1290:     $stayOnPage = 0 if (not defined $stayOnPage);
1.258     albertel 1291:     if ($env{'browser.interface'} eq 'textual' ||
                   1292: 	$env{'environment.remote'} eq 'off' ) {
1.172     www      1293: 	$stayOnPage=1;
                   1294:     }
                   1295:     $width = 350 if (not defined $width);
                   1296:     $height = 400 if (not defined $height);
                   1297: 
                   1298:     $topic=~s/\W+/\+/g;
                   1299:     my $link='';
                   1300:     my $template='';
                   1301:     my $url=$Apache::lonnet::perlvar{'FAQHost'}.'/fom/cache/'.$topic.'.html';
                   1302:     if (!$stayOnPage)
                   1303:     {
                   1304: 	$link = "javascript:void(open('$url', 'FAQ-O-Matic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";
                   1305:     }
                   1306:     else
                   1307:     {
                   1308: 	$link = $url;
                   1309:     }
                   1310: 
                   1311:     # Add the text
                   1312:     if ($text ne "")
                   1313:     {
                   1314: 	$template .= 
1.173     www      1315:   "<table bgcolor='#337733' cellspacing='1' cellpadding='1' border='0'><tr>".
1.436     albertel 1316:   "<td bgcolor='#448844'><a target=\"_top\" href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
1.172     www      1317:     }
                   1318: 
                   1319:     # Add the graphic
1.179     matthew  1320:     my $title = &mt('View the FAQ');
1.215     albertel 1321:     my $faqicon=&lonhttpdurl("/adm/lonMisc/smallFAQ.gif");
1.172     www      1322:     $template .= <<"ENDTEMPLATE";
1.436     albertel 1323:  <a target="_top" href="$link" title="$title"><img src="$faqicon" border="0" alt="(FAQ: $topic)" /></a>
1.172     www      1324: ENDTEMPLATE
                   1325:     if ($text ne '') { $template.='</td></tr></table>' };
                   1326:     return $template;
                   1327: 
1.44      bowersj2 1328: }
1.37      matthew  1329: 
1.180     matthew  1330: ###############################################################
                   1331: ###############################################################
                   1332: 
1.45      matthew  1333: =pod
                   1334: 
1.648     raeburn  1335: =item * &change_content_javascript():
1.256     matthew  1336: 
                   1337: This and the next function allow you to create small sections of an
                   1338: otherwise static HTML page that you can update on the fly with
                   1339: Javascript, even in Netscape 4.
                   1340: 
                   1341: The Javascript fragment returned by this function (no E<lt>scriptE<gt> tag)
                   1342: must be written to the HTML page once. It will prove the Javascript
                   1343: function "change(name, content)". Calling the change function with the
                   1344: name of the section 
                   1345: you want to update, matching the name passed to C<changable_area>, and
                   1346: the new content you want to put in there, will put the content into
                   1347: that area.
                   1348: 
                   1349: B<Note>: Netscape 4 only reserves enough space for the changable area
                   1350: to contain room for the original contents. You need to "make space"
                   1351: for whatever changes you wish to make, and be B<sure> to check your
                   1352: code in Netscape 4. This feature in Netscape 4 is B<not> powerful;
                   1353: it's adequate for updating a one-line status display, but little more.
                   1354: This script will set the space to 100% width, so you only need to
                   1355: worry about height in Netscape 4.
                   1356: 
                   1357: Modern browsers are much less limiting, and if you can commit to the
                   1358: user not using Netscape 4, this feature may be used freely with
                   1359: pretty much any HTML.
                   1360: 
                   1361: =cut
                   1362: 
                   1363: sub change_content_javascript {
                   1364:     # If we're on Netscape 4, we need to use Layer-based code
1.258     albertel 1365:     if ($env{'browser.type'} eq 'netscape' &&
                   1366: 	$env{'browser.version'} =~ /^4\./) {
1.256     matthew  1367: 	return (<<NETSCAPE4);
                   1368: 	function change(name, content) {
                   1369: 	    doc = document.layers[name+"___escape"].layers[0].document;
                   1370: 	    doc.open();
                   1371: 	    doc.write(content);
                   1372: 	    doc.close();
                   1373: 	}
                   1374: NETSCAPE4
                   1375:     } else {
                   1376: 	# Otherwise, we need to use semi-standards-compliant code
                   1377: 	# (technically, "innerHTML" isn't standard but the equivalent
                   1378: 	# is really scary, and every useful browser supports it
                   1379: 	return (<<DOMBASED);
                   1380: 	function change(name, content) {
                   1381: 	    element = document.getElementById(name);
                   1382: 	    element.innerHTML = content;
                   1383: 	}
                   1384: DOMBASED
                   1385:     }
                   1386: }
                   1387: 
                   1388: =pod
                   1389: 
1.648     raeburn  1390: =item * &changable_area($name,$origContent):
1.256     matthew  1391: 
                   1392: This provides a "changable area" that can be modified on the fly via
                   1393: the Javascript code provided in C<change_content_javascript>. $name is
                   1394: the name you will use to reference the area later; do not repeat the
                   1395: same name on a given HTML page more then once. $origContent is what
                   1396: the area will originally contain, which can be left blank.
                   1397: 
                   1398: =cut
                   1399: 
                   1400: sub changable_area {
                   1401:     my ($name, $origContent) = @_;
                   1402: 
1.258     albertel 1403:     if ($env{'browser.type'} eq 'netscape' &&
                   1404: 	$env{'browser.version'} =~ /^4\./) {
1.256     matthew  1405: 	# If this is netscape 4, we need to use the Layer tag
                   1406: 	return "<ilayer width='100%' id='${name}___escape' overflow='none'><layer width='100%' id='$name' overflow='none'>$origContent</layer></ilayer>";
                   1407:     } else {
                   1408: 	return "<span id='$name'>$origContent</span>";
                   1409:     }
                   1410: }
                   1411: 
                   1412: =pod
                   1413: 
1.648     raeburn  1414: =item * &viewport_geometry_js 
1.590     raeburn  1415: 
                   1416: Provides javascript object (Geometry) which can provide information about the viewport geometry for the client browser.
                   1417: 
                   1418: =cut
                   1419: 
                   1420: 
                   1421: sub viewport_geometry_js { 
                   1422:     return <<"GEOMETRY";
                   1423: var Geometry = {};
                   1424: function init_geometry() {
                   1425:     if (Geometry.init) { return };
                   1426:     Geometry.init=1;
                   1427:     if (window.innerHeight) {
                   1428:         Geometry.getViewportHeight   = function() { return window.innerHeight; };
                   1429:         Geometry.getViewportWidth   = function() { return window.innerWidth; };
                   1430:         Geometry.getHorizontalScroll = function() { return window.pageXOffset; };
                   1431:         Geometry.getVerticalScroll   = function() { return window.pageYOffset; };
                   1432:     }
                   1433:     else if (document.documentElement && document.documentElement.clientHeight) {
                   1434:         Geometry.getViewportHeight =
                   1435:             function() { return document.documentElement.clientHeight; };
                   1436:         Geometry.getViewportWidth =
                   1437:             function() { return document.documentElement.clientWidth; };
                   1438: 
                   1439:         Geometry.getHorizontalScroll =
                   1440:             function() { return document.documentElement.scrollLeft; };
                   1441:         Geometry.getVerticalScroll =
                   1442:             function() { return document.documentElement.scrollTop; };
                   1443:     }
                   1444:     else if (document.body.clientHeight) {
                   1445:         Geometry.getViewportHeight =
                   1446:             function() { return document.body.clientHeight; };
                   1447:         Geometry.getViewportWidth =
                   1448:             function() { return document.body.clientWidth; };
                   1449:         Geometry.getHorizontalScroll =
                   1450:             function() { return document.body.scrollLeft; };
                   1451:         Geometry.getVerticalScroll =
                   1452:             function() { return document.body.scrollTop; };
                   1453:     }
                   1454: }
                   1455: 
                   1456: GEOMETRY
                   1457: }
                   1458: 
                   1459: =pod
                   1460: 
1.648     raeburn  1461: =item * &viewport_size_js()
1.590     raeburn  1462: 
                   1463: Provides a javascript function to set values of two form elements - width and height (elements are passed in as arguments to the javascript function) to the dimensions of the user's browser window. 
                   1464: 
                   1465: =cut
                   1466: 
                   1467: sub viewport_size_js {
                   1468:     my $geometry = &viewport_geometry_js();
                   1469:     return <<"DIMS";
                   1470: 
                   1471: $geometry
                   1472: 
                   1473: function getViewportDims(width,height) {
                   1474:     init_geometry();
                   1475:     width.value = Geometry.getViewportWidth();
                   1476:     height.value = Geometry.getViewportHeight();
                   1477:     return;
                   1478: }
                   1479: 
                   1480: DIMS
                   1481: }
                   1482: 
                   1483: =pod
                   1484: 
1.648     raeburn  1485: =item * &resize_textarea_js()
1.565     albertel 1486: 
                   1487: emits the needed javascript to resize a textarea to be as big as possible
                   1488: 
                   1489: creates a function resize_textrea that takes two IDs first should be
                   1490: the id of the element to resize, second should be the id of a div that
                   1491: surrounds everything that comes after the textarea, this routine needs
                   1492: to be attached to the <body> for the onload and onresize events.
                   1493: 
1.648     raeburn  1494: =back
1.565     albertel 1495: 
                   1496: =cut
                   1497: 
                   1498: sub resize_textarea_js {
1.590     raeburn  1499:     my $geometry = &viewport_geometry_js();
1.565     albertel 1500:     return <<"RESIZE";
                   1501:     <script type="text/javascript">
1.692.4.4  raeburn  1502: // <![CDATA[
1.590     raeburn  1503: $geometry
1.565     albertel 1504: 
1.588     albertel 1505: function getX(element) {
                   1506:     var x = 0;
                   1507:     while (element) {
                   1508: 	x += element.offsetLeft;
                   1509: 	element = element.offsetParent;
                   1510:     }
                   1511:     return x;
                   1512: }
                   1513: function getY(element) {
                   1514:     var y = 0;
                   1515:     while (element) {
                   1516: 	y += element.offsetTop;
                   1517: 	element = element.offsetParent;
                   1518:     }
                   1519:     return y;
                   1520: }
                   1521: 
                   1522: 
1.565     albertel 1523: function resize_textarea(textarea_id,bottom_id) {
                   1524:     init_geometry();
                   1525:     var textarea        = document.getElementById(textarea_id);
                   1526:     //alert(textarea);
                   1527: 
1.588     albertel 1528:     var textarea_top    = getY(textarea);
1.565     albertel 1529:     var textarea_height = textarea.offsetHeight;
                   1530:     var bottom          = document.getElementById(bottom_id);
1.588     albertel 1531:     var bottom_top      = getY(bottom);
1.565     albertel 1532:     var bottom_height   = bottom.offsetHeight;
                   1533:     var window_height   = Geometry.getViewportHeight();
1.588     albertel 1534:     var fudge           = 23;
1.565     albertel 1535:     var new_height      = window_height-fudge-textarea_top-bottom_height;
                   1536:     if (new_height < 300) {
                   1537: 	new_height = 300;
                   1538:     }
                   1539:     textarea.style.height=new_height+'px';
                   1540: }
1.692.4.4  raeburn  1541: // ]]>
1.565     albertel 1542: </script>
                   1543: RESIZE
                   1544: 
                   1545: }
                   1546: 
                   1547: =pod
                   1548: 
1.256     matthew  1549: =head1 Excel and CSV file utility routines
                   1550: 
                   1551: =over 4
                   1552: 
                   1553: =cut
                   1554: 
                   1555: ###############################################################
                   1556: ###############################################################
                   1557: 
                   1558: =pod
                   1559: 
1.648     raeburn  1560: =item * &csv_translate($text) 
1.37      matthew  1561: 
1.185     www      1562: Translate $text to allow it to be output as a 'comma separated values' 
1.37      matthew  1563: format.
                   1564: 
                   1565: =cut
                   1566: 
1.180     matthew  1567: ###############################################################
                   1568: ###############################################################
1.37      matthew  1569: sub csv_translate {
                   1570:     my $text = shift;
                   1571:     $text =~ s/\"/\"\"/g;
1.209     albertel 1572:     $text =~ s/\n/ /g;
1.37      matthew  1573:     return $text;
                   1574: }
1.180     matthew  1575: 
                   1576: ###############################################################
                   1577: ###############################################################
                   1578: 
                   1579: =pod
                   1580: 
1.648     raeburn  1581: =item * &define_excel_formats()
1.180     matthew  1582: 
                   1583: Define some commonly used Excel cell formats.
                   1584: 
                   1585: Currently supported formats:
                   1586: 
                   1587: =over 4
                   1588: 
                   1589: =item header
                   1590: 
                   1591: =item bold
                   1592: 
                   1593: =item h1
                   1594: 
                   1595: =item h2
                   1596: 
                   1597: =item h3
                   1598: 
1.256     matthew  1599: =item h4
                   1600: 
                   1601: =item i
                   1602: 
1.180     matthew  1603: =item date
                   1604: 
                   1605: =back
                   1606: 
                   1607: Inputs: $workbook
                   1608: 
                   1609: Returns: $format, a hash reference.
                   1610: 
                   1611: =cut
                   1612: 
                   1613: ###############################################################
                   1614: ###############################################################
                   1615: sub define_excel_formats {
                   1616:     my ($workbook) = @_;
                   1617:     my $format;
                   1618:     $format->{'header'} = $workbook->add_format(bold      => 1, 
                   1619:                                                 bottom    => 1,
                   1620:                                                 align     => 'center');
                   1621:     $format->{'bold'} = $workbook->add_format(bold=>1);
                   1622:     $format->{'h1'}   = $workbook->add_format(bold=>1, size=>18);
                   1623:     $format->{'h2'}   = $workbook->add_format(bold=>1, size=>16);
                   1624:     $format->{'h3'}   = $workbook->add_format(bold=>1, size=>14);
1.255     matthew  1625:     $format->{'h4'}   = $workbook->add_format(bold=>1, size=>12);
1.246     matthew  1626:     $format->{'i'}    = $workbook->add_format(italic=>1);
1.180     matthew  1627:     $format->{'date'} = $workbook->add_format(num_format=>
1.207     matthew  1628:                                             'mm/dd/yyyy hh:mm:ss');
1.180     matthew  1629:     return $format;
                   1630: }
                   1631: 
                   1632: ###############################################################
                   1633: ###############################################################
1.113     bowersj2 1634: 
                   1635: =pod
                   1636: 
1.648     raeburn  1637: =item * &create_workbook()
1.255     matthew  1638: 
                   1639: Create an Excel worksheet.  If it fails, output message on the
                   1640: request object and return undefs.
                   1641: 
                   1642: Inputs: Apache request object
                   1643: 
                   1644: Returns (undef) on failure, 
                   1645:     Excel worksheet object, scalar with filename, and formats 
                   1646:     from &Apache::loncommon::define_excel_formats on success
                   1647: 
                   1648: =cut
                   1649: 
                   1650: ###############################################################
                   1651: ###############################################################
                   1652: sub create_workbook {
                   1653:     my ($r) = @_;
                   1654:         #
                   1655:     # Create the excel spreadsheet
                   1656:     my $filename = '/prtspool/'.
1.258     albertel 1657:         $env{'user.name'}.'_'.$env{'user.domain'}.'_'.
1.255     matthew  1658:         time.'_'.rand(1000000000).'.xls';
                   1659:     my $workbook  = Spreadsheet::WriteExcel->new('/home/httpd'.$filename);
                   1660:     if (! defined($workbook)) {
                   1661:         $r->log_error("Error creating excel spreadsheet $filename: $!");
                   1662:         $r->print('<p>'.&mt("Unable to create new Excel file.  ".
                   1663:                             "This error has been logged.  ".
                   1664:                             "Please alert your LON-CAPA administrator").
                   1665:                   '</p>');
                   1666:         return (undef);
                   1667:     }
                   1668:     #
                   1669:     $workbook->set_tempdir('/home/httpd/perl/tmp');
                   1670:     #
                   1671:     my $format = &Apache::loncommon::define_excel_formats($workbook);
                   1672:     return ($workbook,$filename,$format);
                   1673: }
                   1674: 
                   1675: ###############################################################
                   1676: ###############################################################
                   1677: 
                   1678: =pod
                   1679: 
1.648     raeburn  1680: =item * &create_text_file()
1.113     bowersj2 1681: 
1.542     raeburn  1682: Create a file to write to and eventually make available to the user.
1.256     matthew  1683: If file creation fails, outputs an error message on the request object and 
                   1684: return undefs.
1.113     bowersj2 1685: 
1.256     matthew  1686: Inputs: Apache request object, and file suffix
1.113     bowersj2 1687: 
1.256     matthew  1688: Returns (undef) on failure, 
                   1689:     Filehandle and filename on success.
1.113     bowersj2 1690: 
                   1691: =cut
                   1692: 
1.256     matthew  1693: ###############################################################
                   1694: ###############################################################
                   1695: sub create_text_file {
                   1696:     my ($r,$suffix) = @_;
                   1697:     if (! defined($suffix)) { $suffix = 'txt'; };
                   1698:     my $fh;
                   1699:     my $filename = '/prtspool/'.
1.258     albertel 1700:         $env{'user.name'}.'_'.$env{'user.domain'}.'_'.
1.256     matthew  1701:         time.'_'.rand(1000000000).'.'.$suffix;
                   1702:     $fh = Apache::File->new('>/home/httpd'.$filename);
                   1703:     if (! defined($fh)) {
                   1704:         $r->log_error("Couldn't open $filename for output $!");
1.683     bisitz   1705:         $r->print(&mt('Problems occurred in creating the output file. '
                   1706:                      .'This error has been logged. '
                   1707:                      .'Please alert your LON-CAPA administrator.'));
1.113     bowersj2 1708:     }
1.256     matthew  1709:     return ($fh,$filename)
1.113     bowersj2 1710: }
                   1711: 
                   1712: 
1.256     matthew  1713: =pod 
1.113     bowersj2 1714: 
                   1715: =back
                   1716: 
                   1717: =cut
1.37      matthew  1718: 
                   1719: ###############################################################
1.33      matthew  1720: ##        Home server <option> list generating code          ##
                   1721: ###############################################################
1.35      matthew  1722: 
1.169     www      1723: # ------------------------------------------
                   1724: 
                   1725: sub domain_select {
                   1726:     my ($name,$value,$multiple)=@_;
                   1727:     my %domains=map { 
1.514     albertel 1728: 	$_ => $_.' '. &Apache::lonnet::domain($_,'description') 
1.512     albertel 1729:     } &Apache::lonnet::all_domains();
1.169     www      1730:     if ($multiple) {
                   1731: 	$domains{''}=&mt('Any domain');
1.550     albertel 1732: 	$domains{'select_form_order'} = [sort {lc($a) cmp lc($b) } (keys(%domains))];
1.287     albertel 1733: 	return &multiple_select_form($name,$value,4,\%domains);
1.169     www      1734:     } else {
1.550     albertel 1735: 	$domains{'select_form_order'} = [sort {lc($a) cmp lc($b) } (keys(%domains))];
1.169     www      1736: 	return &select_form($name,$value,%domains);
                   1737:     }
                   1738: }
                   1739: 
1.282     albertel 1740: #-------------------------------------------
                   1741: 
                   1742: =pod
                   1743: 
1.519     raeburn  1744: =head1 Routines for form select boxes
                   1745: 
                   1746: =over 4
                   1747: 
1.648     raeburn  1748: =item * &multiple_select_form($name,$value,$size,$hash,$order)
1.282     albertel 1749: 
                   1750: Returns a string containing a <select> element int multiple mode
                   1751: 
                   1752: 
                   1753: Args:
                   1754:   $name - name of the <select> element
1.506     raeburn  1755:   $value - scalar or array ref of values that should already be selected
1.282     albertel 1756:   $size - number of rows long the select element is
1.283     albertel 1757:   $hash - the elements should be 'option' => 'shown text'
1.282     albertel 1758:           (shown text should already have been &mt())
1.506     raeburn  1759:   $order - (optional) array ref of the order to show the elements in
1.283     albertel 1760: 
1.282     albertel 1761: =cut
                   1762: 
                   1763: #-------------------------------------------
1.169     www      1764: sub multiple_select_form {
1.284     albertel 1765:     my ($name,$value,$size,$hash,$order)=@_;
1.169     www      1766:     my %selected = map { $_ => 1 } ref($value)?@{$value}:($value);
                   1767:     my $output='';
1.191     matthew  1768:     if (! defined($size)) {
                   1769:         $size = 4;
1.283     albertel 1770:         if (scalar(keys(%$hash))<4) {
                   1771:             $size = scalar(keys(%$hash));
1.191     matthew  1772:         }
                   1773:     }
1.692.4.2  raeburn  1774:     $output.="\n".'<select name="'.$name.'" size="'.$size.'" multiple="multiple">';
1.501     banghart 1775:     my @order;
1.506     raeburn  1776:     if (ref($order) eq 'ARRAY')  {
                   1777:         @order = @{$order};
                   1778:     } else {
                   1779:         @order = sort(keys(%$hash));
1.501     banghart 1780:     }
                   1781:     if (exists($$hash{'select_form_order'})) {
                   1782:         @order = @{$$hash{'select_form_order'}};
                   1783:     }
                   1784:         
1.284     albertel 1785:     foreach my $key (@order) {
1.356     albertel 1786:         $output.='<option value="'.&HTML::Entities::encode($key,'"<>&').'" ';
1.284     albertel 1787:         $output.='selected="selected" ' if ($selected{$key});
                   1788:         $output.='>'.$hash->{$key}."</option>\n";
1.169     www      1789:     }
                   1790:     $output.="</select>\n";
                   1791:     return $output;
                   1792: }
                   1793: 
1.88      www      1794: #-------------------------------------------
                   1795: 
                   1796: =pod
                   1797: 
1.648     raeburn  1798: =item * &select_form($defdom,$name,%hash)
1.88      www      1799: 
                   1800: Returns a string containing a <select name='$name' size='1'> form to 
                   1801: allow a user to select options from a hash option_name => displayed text.  
                   1802: See lonrights.pm for an example invocation and use.
                   1803: 
                   1804: =cut
                   1805: 
                   1806: #-------------------------------------------
                   1807: sub select_form {
                   1808:     my ($def,$name,%hash) = @_;
                   1809:     my $selectform = "<select name=\"$name\" size=\"1\">\n";
1.128     albertel 1810:     my @keys;
                   1811:     if (exists($hash{'select_form_order'})) {
                   1812: 	@keys=@{$hash{'select_form_order'}};
                   1813:     } else {
                   1814: 	@keys=sort(keys(%hash));
                   1815:     }
1.356     albertel 1816:     foreach my $key (@keys) {
                   1817:         $selectform.=
                   1818: 	    '<option value="'.&HTML::Entities::encode($key,'"<>&').'" '.
                   1819:             ($key eq $def ? 'selected="selected" ' : '').
                   1820:                 ">".&mt($hash{$key})."</option>\n";
1.88      www      1821:     }
                   1822:     $selectform.="</select>";
                   1823:     return $selectform;
                   1824: }
                   1825: 
1.475     www      1826: # For display filters
                   1827: 
                   1828: sub display_filter {
                   1829:     if (!$env{'form.show'}) { $env{'form.show'}=10; }
1.477     www      1830:     if (!$env{'form.displayfilter'}) { $env{'form.displayfilter'}='currentfolder'; }
1.692.4.2  raeburn  1831:     return '<span class="LC_nobreak"><label>'.&mt('Records [_1]',
1.475     www      1832: 			       &Apache::lonmeta::selectbox('show',$env{'form.show'},undef,
                   1833: 							   (&mt('all'),10,20,50,100,1000,10000))).
1.692.4.2  raeburn  1834: 	   '</label></span> <span class="LC_nobreak">'.
1.475     www      1835:            &mt('Filter [_1]',
1.477     www      1836: 	   &select_form($env{'form.displayfilter'},
                   1837: 			'displayfilter',
                   1838: 			('currentfolder' => 'Current folder/page',
                   1839: 			 'containing' => 'Containing phrase',
                   1840: 			 'none' => 'None'))).
1.692.4.2  raeburn  1841: 			 '<input type="text" name="containingphrase" size="30" value="'.&HTML::Entities::encode($env{'form.containingphrase'}).'" /></span>';
1.475     www      1842: }
                   1843: 
1.167     www      1844: sub gradeleveldescription {
                   1845:     my $gradelevel=shift;
                   1846:     my %gradelevels=(0 => 'Not specified',
                   1847: 		     1 => 'Grade 1',
                   1848: 		     2 => 'Grade 2',
                   1849: 		     3 => 'Grade 3',
                   1850: 		     4 => 'Grade 4',
                   1851: 		     5 => 'Grade 5',
                   1852: 		     6 => 'Grade 6',
                   1853: 		     7 => 'Grade 7',
                   1854: 		     8 => 'Grade 8',
                   1855: 		     9 => 'Grade 9',
                   1856: 		     10 => 'Grade 10',
                   1857: 		     11 => 'Grade 11',
                   1858: 		     12 => 'Grade 12',
                   1859: 		     13 => 'Grade 13',
                   1860: 		     14 => '100 Level',
                   1861: 		     15 => '200 Level',
                   1862: 		     16 => '300 Level',
                   1863: 		     17 => '400 Level',
                   1864: 		     18 => 'Graduate Level');
                   1865:     return &mt($gradelevels{$gradelevel});
                   1866: }
                   1867: 
1.163     www      1868: sub select_level_form {
                   1869:     my ($deflevel,$name)=@_;
                   1870:     unless ($deflevel) { $deflevel=0; }
1.167     www      1871:     my $selectform = "<select name=\"$name\" size=\"1\">\n";
                   1872:     for (my $i=0; $i<=18; $i++) {
                   1873:         $selectform.="<option value=\"$i\" ".
1.253     albertel 1874:             ($i==$deflevel ? 'selected="selected" ' : '').
1.167     www      1875:                 ">".&gradeleveldescription($i)."</option>\n";
                   1876:     }
                   1877:     $selectform.="</select>";
                   1878:     return $selectform;
1.163     www      1879: }
1.167     www      1880: 
1.35      matthew  1881: #-------------------------------------------
                   1882: 
1.45      matthew  1883: =pod
                   1884: 
1.692.4.7  raeburn  1885: =item * &select_dom_form($defdom,$name,$includeempty,$showdomdesc,$onchange)
1.35      matthew  1886: 
                   1887: Returns a string containing a <select name='$name' size='1'> form to 
                   1888: allow a user to select the domain to preform an operation in.  
                   1889: See loncreateuser.pm for an example invocation and use.
                   1890: 
1.90      www      1891: If the $includeempty flag is set, it also includes an empty choice ("no domain
                   1892: selected");
                   1893: 
1.692.4.2  raeburn  1894: If the $showdomdesc flag is set, the domain name is followed by the domain description.
                   1895: 
1.692.4.7  raeburn  1896: The optional $onchange argument specifies what should occur if the domain selector is changed, e.g., 'this.form.submit()' if the form is to be automatically submitted.
1.563     raeburn  1897: 
1.35      matthew  1898: =cut
                   1899: 
                   1900: #-------------------------------------------
1.34      matthew  1901: sub select_dom_form {
1.692.4.7  raeburn  1902:     my ($defdom,$name,$includeempty,$showdomdesc,$onchange) = @_;
                   1903:     if ($onchange) {
                   1904:         $onchange = ' onchange="'.$onchange.'"';
1.692.4.2  raeburn  1905:     }
1.550     albertel 1906:     my @domains = sort {lc($a) cmp lc($b)} (&Apache::lonnet::all_domains());
1.90      www      1907:     if ($includeempty) { @domains=('',@domains); }
1.692.4.2  raeburn  1908:     my $selectdomain = "<select name=\"$name\" size=\"1\"$onchange>\n";
1.356     albertel 1909:     foreach my $dom (@domains) {
                   1910:         $selectdomain.="<option value=\"$dom\" ".
1.563     raeburn  1911:             ($dom eq $defdom ? 'selected="selected" ' : '').'>'.$dom;
                   1912:         if ($showdomdesc) {
                   1913:             if ($dom ne '') {
                   1914:                 my $domdesc = &Apache::lonnet::domain($dom,'description');
                   1915:                 if ($domdesc ne '') {
                   1916:                     $selectdomain .= ' ('.$domdesc.')';
                   1917:                 }
                   1918:             } 
                   1919:         }
                   1920:         $selectdomain .= "</option>\n";
1.34      matthew  1921:     }
                   1922:     $selectdomain.="</select>";
                   1923:     return $selectdomain;
                   1924: }
                   1925: 
1.35      matthew  1926: #-------------------------------------------
                   1927: 
1.45      matthew  1928: =pod
                   1929: 
1.648     raeburn  1930: =item * &home_server_form_item($domain,$name,$defaultflag)
1.35      matthew  1931: 
1.586     raeburn  1932: input: 4 arguments (two required, two optional) - 
                   1933:     $domain - domain of new user
                   1934:     $name - name of form element
                   1935:     $default - Value of 'default' causes a default item to be first 
                   1936:                             option, and selected by default. 
                   1937:     $hide - Value of 'hide' causes hiding of the name of the server, 
                   1938:                             if 1 server found, or default, if 0 found.
1.594     raeburn  1939: output: returns 2 items: 
1.586     raeburn  1940: (a) form element which contains either:
                   1941:    (i) <select name="$name">
                   1942:         <option value="$hostid1">$hostid $servers{$hostid}</option>
                   1943:         <option value="$hostid2">$hostid $servers{$hostid}</option>       
                   1944:        </select>
                   1945:        form item if there are multiple library servers in $domain, or
                   1946:    (ii) an <input type="hidden" name="$name" value="$hostid" /> form item 
                   1947:        if there is only one library server in $domain.
                   1948: 
                   1949: (b) number of library servers found.
                   1950: 
                   1951: See loncreateuser.pm for example of use.
1.35      matthew  1952: 
                   1953: =cut
                   1954: 
                   1955: #-------------------------------------------
1.586     raeburn  1956: sub home_server_form_item {
                   1957:     my ($domain,$name,$default,$hide) = @_;
1.513     albertel 1958:     my %servers = &Apache::lonnet::get_servers($domain,'library');
1.586     raeburn  1959:     my $result;
                   1960:     my $numlib = keys(%servers);
                   1961:     if ($numlib > 1) {
                   1962:         $result .= '<select name="'.$name.'" />'."\n";
                   1963:         if ($default) {
1.692.4.2  raeburn  1964:             $result .= '<option value="default" selected="selected">'.&mt('default').
1.586     raeburn  1965:                        '</option>'."\n";
                   1966:         }
                   1967:         foreach my $hostid (sort(keys(%servers))) {
                   1968:             $result.= '<option value="'.$hostid.'">'.
                   1969: 	              $hostid.' '.$servers{$hostid}."</option>\n";
                   1970:         }
                   1971:         $result .= '</select>'."\n";
                   1972:     } elsif ($numlib == 1) {
                   1973:         my $hostid;
                   1974:         foreach my $item (keys(%servers)) {
                   1975:             $hostid = $item;
                   1976:         }
                   1977:         $result .= '<input type="hidden" name="'.$name.'" value="'.
                   1978:                    $hostid.'" />';
                   1979:                    if (!$hide) {
                   1980:                        $result .= $hostid.' '.$servers{$hostid};
                   1981:                    }
                   1982:                    $result .= "\n";
                   1983:     } elsif ($default) {
                   1984:         $result .= '<input type="hidden" name="'.$name.
                   1985:                    '" value="default" />';
                   1986:                    if (!$hide) {
                   1987:                        $result .= &mt('default');
                   1988:                    }
                   1989:                    $result .= "\n";
1.33      matthew  1990:     }
1.586     raeburn  1991:     return ($result,$numlib);
1.33      matthew  1992: }
1.112     bowersj2 1993: 
                   1994: =pod
                   1995: 
1.534     albertel 1996: =back 
                   1997: 
1.112     bowersj2 1998: =cut
1.87      matthew  1999: 
                   2000: ###############################################################
1.112     bowersj2 2001: ##                  Decoding User Agent                      ##
1.87      matthew  2002: ###############################################################
                   2003: 
                   2004: =pod
                   2005: 
1.112     bowersj2 2006: =head1 Decoding the User Agent
                   2007: 
                   2008: =over 4
                   2009: 
                   2010: =item * &decode_user_agent()
1.87      matthew  2011: 
                   2012: Inputs: $r
                   2013: 
                   2014: Outputs:
                   2015: 
                   2016: =over 4
                   2017: 
1.112     bowersj2 2018: =item * $httpbrowser
1.87      matthew  2019: 
1.112     bowersj2 2020: =item * $clientbrowser
1.87      matthew  2021: 
1.112     bowersj2 2022: =item * $clientversion
1.87      matthew  2023: 
1.112     bowersj2 2024: =item * $clientmathml
1.87      matthew  2025: 
1.112     bowersj2 2026: =item * $clientunicode
1.87      matthew  2027: 
1.112     bowersj2 2028: =item * $clientos
1.87      matthew  2029: 
                   2030: =back
                   2031: 
1.157     matthew  2032: =back 
                   2033: 
1.87      matthew  2034: =cut
                   2035: 
                   2036: ###############################################################
                   2037: ###############################################################
                   2038: sub decode_user_agent {
1.247     albertel 2039:     my ($r)=@_;
1.87      matthew  2040:     my @browsertype=split(/\&/,$Apache::lonnet::perlvar{"lonBrowsDet"});
                   2041:     my %mathcap=split(/\&/,$$Apache::lonnet::perlvar{"lonMathML"});
                   2042:     my $httpbrowser=$ENV{"HTTP_USER_AGENT"};
1.247     albertel 2043:     if (!$httpbrowser && $r) { $httpbrowser=$r->header_in('User-Agent'); }
1.87      matthew  2044:     my $clientbrowser='unknown';
                   2045:     my $clientversion='0';
                   2046:     my $clientmathml='';
                   2047:     my $clientunicode='0';
                   2048:     for (my $i=0;$i<=$#browsertype;$i++) {
                   2049:         my ($bname,$match,$notmatch,$vreg,$minv,$univ)=split(/\:/,$browsertype[$i]);
                   2050: 	if (($httpbrowser=~/$match/i)  && ($httpbrowser!~/$notmatch/i)) {
                   2051: 	    $clientbrowser=$bname;
                   2052:             $httpbrowser=~/$vreg/i;
                   2053: 	    $clientversion=$1;
                   2054:             $clientmathml=($clientversion>=$minv);
                   2055:             $clientunicode=($clientversion>=$univ);
                   2056: 	}
                   2057:     }
                   2058:     my $clientos='unknown';
                   2059:     if (($httpbrowser=~/linux/i) ||
                   2060:         ($httpbrowser=~/unix/i) ||
                   2061:         ($httpbrowser=~/ux/i) ||
                   2062:         ($httpbrowser=~/solaris/i)) { $clientos='unix'; }
                   2063:     if (($httpbrowser=~/vax/i) ||
                   2064:         ($httpbrowser=~/vms/i)) { $clientos='vms'; }
                   2065:     if ($httpbrowser=~/next/i) { $clientos='next'; }
                   2066:     if (($httpbrowser=~/mac/i) ||
                   2067:         ($httpbrowser=~/powerpc/i)) { $clientos='mac'; }
                   2068:     if ($httpbrowser=~/win/i) { $clientos='win'; }
                   2069:     if ($httpbrowser=~/embed/i) { $clientos='pda'; }
                   2070:     return ($httpbrowser,$clientbrowser,$clientversion,$clientmathml,
                   2071:             $clientunicode,$clientos,);
                   2072: }
                   2073: 
1.32      matthew  2074: ###############################################################
                   2075: ##    Authentication changing form generation subroutines    ##
                   2076: ###############################################################
                   2077: ##
                   2078: ## All of the authform_xxxxxxx subroutines take their inputs in a
                   2079: ## hash, and have reasonable default values.
                   2080: ##
                   2081: ##    formname = the name given in the <form> tag.
1.35      matthew  2082: #-------------------------------------------
                   2083: 
1.45      matthew  2084: =pod
                   2085: 
1.112     bowersj2 2086: =head1 Authentication Routines
                   2087: 
                   2088: =over 4
                   2089: 
1.648     raeburn  2090: =item * &authform_xxxxxx()
1.35      matthew  2091: 
                   2092: The authform_xxxxxx subroutines provide javascript and html forms which 
                   2093: handle some of the conveniences required for authentication forms.  
                   2094: This is not an optimal method, but it works.  
                   2095: 
                   2096: =over 4
                   2097: 
1.112     bowersj2 2098: =item * authform_header
1.35      matthew  2099: 
1.112     bowersj2 2100: =item * authform_authorwarning
1.35      matthew  2101: 
1.112     bowersj2 2102: =item * authform_nochange
1.35      matthew  2103: 
1.112     bowersj2 2104: =item * authform_kerberos
1.35      matthew  2105: 
1.112     bowersj2 2106: =item * authform_internal
1.35      matthew  2107: 
1.112     bowersj2 2108: =item * authform_filesystem
1.35      matthew  2109: 
                   2110: =back
                   2111: 
1.648     raeburn  2112: See loncreateuser.pm for invocation and use examples.
1.157     matthew  2113: 
1.35      matthew  2114: =cut
                   2115: 
                   2116: #-------------------------------------------
1.32      matthew  2117: sub authform_header{  
                   2118:     my %in = (
                   2119:         formname => 'cu',
1.80      albertel 2120:         kerb_def_dom => '',
1.32      matthew  2121:         @_,
                   2122:     );
                   2123:     $in{'formname'} = 'document.' . $in{'formname'};
                   2124:     my $result='';
1.80      albertel 2125: 
                   2126: #---------------------------------------------- Code for upper case translation
                   2127:     my $Javascript_toUpperCase;
                   2128:     unless ($in{kerb_def_dom}) {
                   2129:         $Javascript_toUpperCase =<<"END";
                   2130:         switch (choice) {
                   2131:            case 'krb': currentform.elements[choicearg].value =
                   2132:                currentform.elements[choicearg].value.toUpperCase();
                   2133:                break;
                   2134:            default:
                   2135:         }
                   2136: END
                   2137:     } else {
                   2138:         $Javascript_toUpperCase = "";
                   2139:     }
                   2140: 
1.165     raeburn  2141:     my $radioval = "'nochange'";
1.591     raeburn  2142:     if (defined($in{'curr_authtype'})) {
                   2143:         if ($in{'curr_authtype'} ne '') {
                   2144:             $radioval = "'".$in{'curr_authtype'}."arg'";
                   2145:         }
1.174     matthew  2146:     }
1.165     raeburn  2147:     my $argfield = 'null';
1.591     raeburn  2148:     if (defined($in{'mode'})) {
1.165     raeburn  2149:         if ($in{'mode'} eq 'modifycourse')  {
1.591     raeburn  2150:             if (defined($in{'curr_autharg'})) {
                   2151:                 if ($in{'curr_autharg'} ne '') {
1.165     raeburn  2152:                     $argfield = "'$in{'curr_autharg'}'";
                   2153:                 }
                   2154:             }
                   2155:         }
                   2156:     }
                   2157: 
1.32      matthew  2158:     $result.=<<"END";
                   2159: var current = new Object();
1.165     raeburn  2160: current.radiovalue = $radioval;
                   2161: current.argfield = $argfield;
1.32      matthew  2162: 
                   2163: function changed_radio(choice,currentform) {
                   2164:     var choicearg = choice + 'arg';
                   2165:     // If a radio button in changed, we need to change the argfield
                   2166:     if (current.radiovalue != choice) {
                   2167:         current.radiovalue = choice;
                   2168:         if (current.argfield != null) {
                   2169:             currentform.elements[current.argfield].value = '';
                   2170:         }
                   2171:         if (choice == 'nochange') {
                   2172:             current.argfield = null;
                   2173:         } else {
                   2174:             current.argfield = choicearg;
                   2175:             switch(choice) {
                   2176:                 case 'krb': 
                   2177:                     currentform.elements[current.argfield].value = 
                   2178:                         "$in{'kerb_def_dom'}";
                   2179:                 break;
                   2180:               default:
                   2181:                 break;
                   2182:             }
                   2183:         }
                   2184:     }
                   2185:     return;
                   2186: }
1.22      www      2187: 
1.32      matthew  2188: function changed_text(choice,currentform) {
                   2189:     var choicearg = choice + 'arg';
                   2190:     if (currentform.elements[choicearg].value !='') {
1.80      albertel 2191:         $Javascript_toUpperCase
1.32      matthew  2192:         // clear old field
                   2193:         if ((current.argfield != choicearg) && (current.argfield != null)) {
                   2194:             currentform.elements[current.argfield].value = '';
                   2195:         }
                   2196:         current.argfield = choicearg;
                   2197:     }
                   2198:     set_auth_radio_buttons(choice,currentform);
                   2199:     return;
1.20      www      2200: }
1.32      matthew  2201: 
                   2202: function set_auth_radio_buttons(newvalue,currentform) {
                   2203:     var i=0;
                   2204:     while (i < currentform.login.length) {
                   2205:         if (currentform.login[i].value == newvalue) { break; }
                   2206:         i++;
                   2207:     }
                   2208:     if (i == currentform.login.length) {
                   2209:         return;
                   2210:     }
                   2211:     current.radiovalue = newvalue;
                   2212:     currentform.login[i].checked = true;
                   2213:     return;
                   2214: }
                   2215: END
                   2216:     return $result;
                   2217: }
                   2218: 
                   2219: sub authform_authorwarning{
                   2220:     my $result='';
1.144     matthew  2221:     $result='<i>'.
                   2222:         &mt('As a general rule, only authors or co-authors should be '.
                   2223:             'filesystem authenticated '.
                   2224:             '(which allows access to the server filesystem).')."</i>\n";
1.32      matthew  2225:     return $result;
                   2226: }
                   2227: 
                   2228: sub authform_nochange{  
                   2229:     my %in = (
                   2230:               formname => 'document.cu',
                   2231:               kerb_def_dom => 'MSU.EDU',
                   2232:               @_,
                   2233:           );
1.586     raeburn  2234:     my ($authnum,%can_assign) =  &get_assignable_auth($in{'domain'}); 
                   2235:     my $result;
                   2236:     if (keys(%can_assign) == 0) {
                   2237:         $result = &mt('Under you current role you are not permitted to change login settings for this user');  
                   2238:     } else {
                   2239:         $result = '<label>'.&mt('[_1] Do not change login data',
                   2240:                   '<input type="radio" name="login" value="nochange" '.
                   2241:                   'checked="checked" onclick="'.
1.281     albertel 2242:             "javascript:changed_radio('nochange',$in{'formname'});".'" />').
                   2243: 	    '</label>';
1.586     raeburn  2244:     }
1.32      matthew  2245:     return $result;
                   2246: }
                   2247: 
1.591     raeburn  2248: sub authform_kerberos {
1.32      matthew  2249:     my %in = (
                   2250:               formname => 'document.cu',
                   2251:               kerb_def_dom => 'MSU.EDU',
1.80      albertel 2252:               kerb_def_auth => 'krb4',
1.32      matthew  2253:               @_,
                   2254:               );
1.586     raeburn  2255:     my ($check4,$check5,$krbcheck,$krbarg,$krbver,$result,$authtype,
                   2256:         $autharg,$jscall);
                   2257:     my ($authnum,%can_assign) =  &get_assignable_auth($in{'domain'});
1.80      albertel 2258:     if ($in{'kerb_def_auth'} eq 'krb5') {
1.692.4.2  raeburn  2259:        $check5 = ' checked="checked"';
1.80      albertel 2260:     } else {
1.692.4.2  raeburn  2261:        $check4 = ' checked="checked"';
1.80      albertel 2262:     }
1.165     raeburn  2263:     $krbarg = $in{'kerb_def_dom'};
1.591     raeburn  2264:     if (defined($in{'curr_authtype'})) {
                   2265:         if ($in{'curr_authtype'} eq 'krb') {
1.692.4.2  raeburn  2266:             $krbcheck = ' checked="checked"';
1.623     raeburn  2267:             if (defined($in{'mode'})) {
                   2268:                 if ($in{'mode'} eq 'modifyuser') {
                   2269:                     $krbcheck = '';
                   2270:                 }
                   2271:             }
1.591     raeburn  2272:             if (defined($in{'curr_kerb_ver'})) {
                   2273:                 if ($in{'curr_krb_ver'} eq '5') {
1.692.4.2  raeburn  2274:                     $check5 = ' checked="checked"';
1.591     raeburn  2275:                     $check4 = '';
                   2276:                 } else {
1.692.4.2  raeburn  2277:                     $check4 = ' checked="checked"';
1.591     raeburn  2278:                     $check5 = '';
                   2279:                 }
1.586     raeburn  2280:             }
1.591     raeburn  2281:             if (defined($in{'curr_autharg'})) {
1.165     raeburn  2282:                 $krbarg = $in{'curr_autharg'};
                   2283:             }
1.586     raeburn  2284:             if (!$can_assign{'krb4'} && !$can_assign{'krb5'}) {
1.591     raeburn  2285:                 if (defined($in{'curr_autharg'})) {
1.586     raeburn  2286:                     $result = 
                   2287:     &mt('Currently Kerberos authenticated with domain [_1] Version [_2].',
                   2288:         $in{'curr_autharg'},$krbver);
                   2289:                 } else {
                   2290:                     $result =
                   2291:     &mt('Currently Kerberos authenticated, Version [_1].',$krbver);
                   2292:                 }
                   2293:                 return $result; 
                   2294:             }
                   2295:         }
                   2296:     } else {
                   2297:         if ($authnum == 1) {
1.692.4.2  raeburn  2298:             $authtype = '<input type="hidden" name="login" value="krb" />';
1.165     raeburn  2299:         }
                   2300:     }
1.586     raeburn  2301:     if (!$can_assign{'krb4'} && !$can_assign{'krb5'}) {
                   2302:         return;
1.587     raeburn  2303:     } elsif ($authtype eq '') {
1.591     raeburn  2304:         if (defined($in{'mode'})) {
1.587     raeburn  2305:             if ($in{'mode'} eq 'modifycourse') {
                   2306:                 if ($authnum == 1) {
1.692.4.2  raeburn  2307:                     $authtype = '<input type="hidden" name="login" value="krb" />';
1.587     raeburn  2308:                 }
                   2309:             }
                   2310:         }
1.586     raeburn  2311:     }
                   2312:     $jscall = "javascript:changed_radio('krb',$in{'formname'});";
                   2313:     if ($authtype eq '') {
                   2314:         $authtype = '<input type="radio" name="login" value="krb" '.
                   2315:                     'onclick="'.$jscall.'" onchange="'.$jscall.'"'.
                   2316:                     $krbcheck.' />';
                   2317:     }
                   2318:     if (($can_assign{'krb4'} && $can_assign{'krb5'}) ||
                   2319:         ($can_assign{'krb4'} && !$can_assign{'krb5'} && 
                   2320:          $in{'curr_authtype'} eq 'krb5') ||
                   2321:         (!$can_assign{'krb4'} && $can_assign{'krb5'} && 
                   2322:          $in{'curr_authtype'} eq 'krb4')) {
                   2323:         $result .= &mt
1.144     matthew  2324:         ('[_1] Kerberos authenticated with domain [_2] '.
1.281     albertel 2325:          '[_3] Version 4 [_4] Version 5 [_5]',
1.586     raeburn  2326:          '<label>'.$authtype,
1.281     albertel 2327:          '</label><input type="text" size="10" name="krbarg" '.
1.165     raeburn  2328:              'value="'.$krbarg.'" '.
1.144     matthew  2329:              'onchange="'.$jscall.'" />',
1.281     albertel 2330:          '<label><input type="radio" name="krbver" value="4" '.$check4.' />',
                   2331:          '</label><label><input type="radio" name="krbver" value="5" '.$check5.' />',
                   2332: 	 '</label>');
1.586     raeburn  2333:     } elsif ($can_assign{'krb4'}) {
                   2334:         $result .= &mt
                   2335:         ('[_1] Kerberos authenticated with domain [_2] '.
                   2336:          '[_3] Version 4 [_4]',
                   2337:          '<label>'.$authtype,
                   2338:          '</label><input type="text" size="10" name="krbarg" '.
                   2339:              'value="'.$krbarg.'" '.
                   2340:              'onchange="'.$jscall.'" />',
                   2341:          '<label><input type="hidden" name="krbver" value="4" />',
                   2342:          '</label>');
                   2343:     } elsif ($can_assign{'krb5'}) {
                   2344:         $result .= &mt
                   2345:         ('[_1] Kerberos authenticated with domain [_2] '.
                   2346:          '[_3] Version 5 [_4]',
                   2347:          '<label>'.$authtype,
                   2348:          '</label><input type="text" size="10" name="krbarg" '.
                   2349:              'value="'.$krbarg.'" '.
                   2350:              'onchange="'.$jscall.'" />',
                   2351:          '<label><input type="hidden" name="krbver" value="5" />',
                   2352:          '</label>');
                   2353:     }
1.32      matthew  2354:     return $result;
                   2355: }
                   2356: 
                   2357: sub authform_internal{  
1.586     raeburn  2358:     my %in = (
1.32      matthew  2359:                 formname => 'document.cu',
                   2360:                 kerb_def_dom => 'MSU.EDU',
                   2361:                 @_,
                   2362:                 );
1.586     raeburn  2363:     my ($intcheck,$intarg,$result,$authtype,$autharg,$jscall);
                   2364:     my ($authnum,%can_assign) =  &get_assignable_auth($in{'domain'});
1.591     raeburn  2365:     if (defined($in{'curr_authtype'})) {
                   2366:         if ($in{'curr_authtype'} eq 'int') {
1.586     raeburn  2367:             if ($can_assign{'int'}) {
1.692.4.2  raeburn  2368:                 $intcheck = 'checked="checked" ';
1.623     raeburn  2369:                 if (defined($in{'mode'})) {
                   2370:                     if ($in{'mode'} eq 'modifyuser') {
                   2371:                         $intcheck = '';
                   2372:                     }
                   2373:                 }
1.591     raeburn  2374:                 if (defined($in{'curr_autharg'})) {
1.586     raeburn  2375:                     $intarg = $in{'curr_autharg'};
                   2376:                 }
                   2377:             } else {
                   2378:                 $result = &mt('Currently internally authenticated.');
                   2379:                 return $result;
1.165     raeburn  2380:             }
                   2381:         }
1.586     raeburn  2382:     } else {
                   2383:         if ($authnum == 1) {
1.692.4.2  raeburn  2384:             $authtype = '<input type="hidden" name="login" value="int" />';
1.586     raeburn  2385:         }
                   2386:     }
                   2387:     if (!$can_assign{'int'}) {
                   2388:         return;
1.587     raeburn  2389:     } elsif ($authtype eq '') {
1.591     raeburn  2390:         if (defined($in{'mode'})) {
1.587     raeburn  2391:             if ($in{'mode'} eq 'modifycourse') {
                   2392:                 if ($authnum == 1) {
1.692.4.2  raeburn  2393:                     $authtype = '<input type="hidden" name="login" value="int" />';
1.587     raeburn  2394:                 }
                   2395:             }
                   2396:         }
1.165     raeburn  2397:     }
1.586     raeburn  2398:     $jscall = "javascript:changed_radio('int',$in{'formname'});";
                   2399:     if ($authtype eq '') {
                   2400:         $authtype = '<input type="radio" name="login" value="int" '.$intcheck.
                   2401:                     ' onchange="'.$jscall.'" onclick="'.$jscall.'" />';
                   2402:     }
1.605     bisitz   2403:     $autharg = '<input type="password" size="10" name="intarg" value="'.
1.586     raeburn  2404:                $intarg.'" onchange="'.$jscall.'" />';
                   2405:     $result = &mt
1.144     matthew  2406:         ('[_1] Internally authenticated (with initial password [_2])',
1.586     raeburn  2407:          '<label>'.$authtype,'</label>'.$autharg);
1.692.4.4  raeburn  2408:     $result.="<label><input type=\"checkbox\" name=\"visible\" onclick='if (this.checked) { this.form.intarg.type=\"text\" } else { this.form.intarg.type=\"password\" }' />".&mt('Visible input').'</label>';
1.32      matthew  2409:     return $result;
                   2410: }
                   2411: 
                   2412: sub authform_local{  
                   2413:     my %in = (
                   2414:               formname => 'document.cu',
                   2415:               kerb_def_dom => 'MSU.EDU',
                   2416:               @_,
                   2417:               );
1.586     raeburn  2418:     my ($loccheck,$locarg,$result,$authtype,$autharg,$jscall);
                   2419:     my ($authnum,%can_assign) =  &get_assignable_auth($in{'domain'});
1.591     raeburn  2420:     if (defined($in{'curr_authtype'})) {
                   2421:         if ($in{'curr_authtype'} eq 'loc') {
1.586     raeburn  2422:             if ($can_assign{'loc'}) {
1.692.4.2  raeburn  2423:                 $loccheck = 'checked="checked" ';
1.623     raeburn  2424:                 if (defined($in{'mode'})) {
                   2425:                     if ($in{'mode'} eq 'modifyuser') {
                   2426:                         $loccheck = '';
                   2427:                     }
                   2428:                 }
1.591     raeburn  2429:                 if (defined($in{'curr_autharg'})) {
1.586     raeburn  2430:                     $locarg = $in{'curr_autharg'};
                   2431:                 }
                   2432:             } else {
                   2433:                 $result = &mt('Currently using local (institutional) authentication.');
                   2434:                 return $result;
1.165     raeburn  2435:             }
                   2436:         }
1.586     raeburn  2437:     } else {
                   2438:         if ($authnum == 1) {
1.692.4.2  raeburn  2439:             $authtype = '<input type="hidden" name="login" value="loc" />';
1.586     raeburn  2440:         }
                   2441:     }
                   2442:     if (!$can_assign{'loc'}) {
                   2443:         return;
1.587     raeburn  2444:     } elsif ($authtype eq '') {
1.591     raeburn  2445:         if (defined($in{'mode'})) {
1.587     raeburn  2446:             if ($in{'mode'} eq 'modifycourse') {
                   2447:                 if ($authnum == 1) {
1.692.4.2  raeburn  2448:                     $authtype = '<input type="hidden" name="login" value="loc" />';
1.587     raeburn  2449:                 }
                   2450:             }
                   2451:         }
1.165     raeburn  2452:     }
1.586     raeburn  2453:     $jscall = "javascript:changed_radio('loc',$in{'formname'});";
                   2454:     if ($authtype eq '') {
                   2455:         $authtype = '<input type="radio" name="login" value="loc" '.
                   2456:                     $loccheck.' onchange="'.$jscall.'" onclick="'.
                   2457:                     $jscall.'" />';
                   2458:     }
                   2459:     $autharg = '<input type="text" size="10" name="locarg" value="'.
                   2460:                $locarg.'" onchange="'.$jscall.'" />';
                   2461:     $result = &mt('[_1] Local Authentication with argument [_2]',
                   2462:                   '<label>'.$authtype,'</label>'.$autharg);
1.32      matthew  2463:     return $result;
                   2464: }
                   2465: 
                   2466: sub authform_filesystem{  
                   2467:     my %in = (
                   2468:               formname => 'document.cu',
                   2469:               kerb_def_dom => 'MSU.EDU',
                   2470:               @_,
                   2471:               );
1.586     raeburn  2472:     my ($fsyscheck,$result,$authtype,$autharg,$jscall);
                   2473:     my ($authnum,%can_assign) =  &get_assignable_auth($in{'domain'});
1.591     raeburn  2474:     if (defined($in{'curr_authtype'})) {
                   2475:         if ($in{'curr_authtype'} eq 'fsys') {
1.586     raeburn  2476:             if ($can_assign{'fsys'}) {
1.692.4.2  raeburn  2477:                 $fsyscheck = 'checked="checked" ';
1.623     raeburn  2478:                 if (defined($in{'mode'})) {
                   2479:                     if ($in{'mode'} eq 'modifyuser') {
                   2480:                         $fsyscheck = '';
                   2481:                     }
                   2482:                 }
1.586     raeburn  2483:             } else {
                   2484:                 $result = &mt('Currently Filesystem Authenticated.');
                   2485:                 return $result;
                   2486:             }           
                   2487:         }
                   2488:     } else {
                   2489:         if ($authnum == 1) {
1.692.4.2  raeburn  2490:             $authtype = '<input type="hidden" name="login" value="fsys" />';
1.586     raeburn  2491:         }
                   2492:     }
                   2493:     if (!$can_assign{'fsys'}) {
                   2494:         return;
1.587     raeburn  2495:     } elsif ($authtype eq '') {
1.591     raeburn  2496:         if (defined($in{'mode'})) {
1.587     raeburn  2497:             if ($in{'mode'} eq 'modifycourse') {
                   2498:                 if ($authnum == 1) {
1.692.4.2  raeburn  2499:                     $authtype = '<input type="hidden" name="login" value="fsys" />';
1.587     raeburn  2500:                 }
                   2501:             }
                   2502:         }
1.586     raeburn  2503:     }
                   2504:     $jscall = "javascript:changed_radio('fsys',$in{'formname'});";
                   2505:     if ($authtype eq '') {
                   2506:         $authtype = '<input type="radio" name="login" value="fsys" '.
                   2507:                     $fsyscheck.' onchange="'.$jscall.'" onclick="'.
                   2508:                     $jscall.'" />';
                   2509:     }
                   2510:     $autharg = '<input type="text" size="10" name="fsysarg" value=""'.
                   2511:                ' onchange="'.$jscall.'" />';
                   2512:     $result = &mt
1.144     matthew  2513:         ('[_1] Filesystem Authenticated (with initial password [_2])',
1.281     albertel 2514:          '<label><input type="radio" name="login" value="fsys" '.
1.586     raeburn  2515:          $fsyscheck.'onchange="'.$jscall.'" onclick="'.$jscall.'" />',
1.605     bisitz   2516:          '</label><input type="password" size="10" name="fsysarg" value="" '.
1.144     matthew  2517:                   'onchange="'.$jscall.'" />');
1.32      matthew  2518:     return $result;
                   2519: }
                   2520: 
1.586     raeburn  2521: sub get_assignable_auth {
                   2522:     my ($dom) = @_;
                   2523:     if ($dom eq '') {
                   2524:         $dom = $env{'request.role.domain'};
                   2525:     }
                   2526:     my %can_assign = (
                   2527:                           krb4 => 1,
                   2528:                           krb5 => 1,
                   2529:                           int  => 1,
                   2530:                           loc  => 1,
                   2531:                      );
                   2532:     my %domconfig = &Apache::lonnet::get_dom('configuration',['usercreation'],$dom);
                   2533:     if (ref($domconfig{'usercreation'}) eq 'HASH') {
                   2534:         if (ref($domconfig{'usercreation'}{'authtypes'}) eq 'HASH') {
                   2535:             my $authhash = $domconfig{'usercreation'}{'authtypes'};
                   2536:             my $context;
                   2537:             if ($env{'request.role'} =~ /^au/) {
                   2538:                 $context = 'author';
                   2539:             } elsif ($env{'request.role'} =~ /^dc/) {
                   2540:                 $context = 'domain';
                   2541:             } elsif ($env{'request.course.id'}) {
                   2542:                 $context = 'course';
                   2543:             }
                   2544:             if ($context) {
                   2545:                 if (ref($authhash->{$context}) eq 'HASH') {
                   2546:                    %can_assign = %{$authhash->{$context}}; 
                   2547:                 }
                   2548:             }
                   2549:         }
                   2550:     }
                   2551:     my $authnum = 0;
                   2552:     foreach my $key (keys(%can_assign)) {
                   2553:         if ($can_assign{$key}) {
                   2554:             $authnum ++;
                   2555:         }
                   2556:     }
                   2557:     if ($can_assign{'krb4'} && $can_assign{'krb5'}) {
                   2558:         $authnum --;
                   2559:     }
                   2560:     return ($authnum,%can_assign);
                   2561: }
                   2562: 
1.80      albertel 2563: ###############################################################
                   2564: ##    Get Kerberos Defaults for Domain                 ##
                   2565: ###############################################################
                   2566: ##
                   2567: ## Returns default kerberos version and an associated argument
                   2568: ## as listed in file domain.tab. If not listed, provides
                   2569: ## appropriate default domain and kerberos version.
                   2570: ##
                   2571: #-------------------------------------------
                   2572: 
                   2573: =pod
                   2574: 
1.648     raeburn  2575: =item * &get_kerberos_defaults()
1.80      albertel 2576: 
                   2577: get_kerberos_defaults($target_domain) returns the default kerberos
1.641     raeburn  2578: version and domain. If not found, it defaults to version 4 and the 
                   2579: domain of the server.
1.80      albertel 2580: 
1.648     raeburn  2581: =over 4
                   2582: 
1.80      albertel 2583: ($def_version, $def_krb_domain) = &get_kerberos_defaults($target_domain);
                   2584: 
1.648     raeburn  2585: =back
                   2586: 
                   2587: =back
                   2588: 
1.80      albertel 2589: =cut
                   2590: 
                   2591: #-------------------------------------------
                   2592: sub get_kerberos_defaults {
                   2593:     my $domain=shift;
1.641     raeburn  2594:     my ($krbdef,$krbdefdom);
                   2595:     my %domdefaults = &Apache::lonnet::get_domain_defaults($domain);
                   2596:     if (($domdefaults{'auth_def'} =~/^krb(4|5)$/) && ($domdefaults{'auth_arg_def'} ne '')) {
                   2597:         $krbdef = $domdefaults{'auth_def'};
                   2598:         $krbdefdom = $domdefaults{'auth_arg_def'};
                   2599:     } else {
1.80      albertel 2600:         $ENV{'SERVER_NAME'}=~/(\w+\.\w+)$/;
                   2601:         my $krbdefdom=$1;
                   2602:         $krbdefdom=~tr/a-z/A-Z/;
                   2603:         $krbdef = "krb4";
                   2604:     }
                   2605:     return ($krbdef,$krbdefdom);
                   2606: }
1.112     bowersj2 2607: 
1.32      matthew  2608: 
1.46      matthew  2609: ###############################################################
                   2610: ##                Thesaurus Functions                        ##
                   2611: ###############################################################
1.20      www      2612: 
1.46      matthew  2613: =pod
1.20      www      2614: 
1.112     bowersj2 2615: =head1 Thesaurus Functions
                   2616: 
                   2617: =over 4
                   2618: 
1.648     raeburn  2619: =item * &initialize_keywords()
1.46      matthew  2620: 
                   2621: Initializes the package variable %Keywords if it is empty.  Uses the
                   2622: package variable $thesaurus_db_file.
                   2623: 
                   2624: =cut
                   2625: 
                   2626: ###################################################
                   2627: 
                   2628: sub initialize_keywords {
                   2629:     return 1 if (scalar keys(%Keywords));
                   2630:     # If we are here, %Keywords is empty, so fill it up
                   2631:     #   Make sure the file we need exists...
                   2632:     if (! -e $thesaurus_db_file) {
                   2633:         &Apache::lonnet::logthis("Attempt to access $thesaurus_db_file".
                   2634:                                  " failed because it does not exist");
                   2635:         return 0;
                   2636:     }
                   2637:     #   Set up the hash as a database
                   2638:     my %thesaurus_db;
                   2639:     if (! tie(%thesaurus_db,'GDBM_File',
1.53      albertel 2640:               $thesaurus_db_file,&GDBM_READER(),0640)){
1.46      matthew  2641:         &Apache::lonnet::logthis("Could not tie \%thesaurus_db to ".
                   2642:                                  $thesaurus_db_file);
                   2643:         return 0;
                   2644:     } 
                   2645:     #  Get the average number of appearances of a word.
                   2646:     my $avecount = $thesaurus_db{'average.count'};
                   2647:     #  Put keywords (those that appear > average) into %Keywords
                   2648:     while (my ($word,$data)=each (%thesaurus_db)) {
                   2649:         my ($count,undef) = split /:/,$data;
                   2650:         $Keywords{$word}++ if ($count > $avecount);
                   2651:     }
                   2652:     untie %thesaurus_db;
                   2653:     # Remove special values from %Keywords.
1.356     albertel 2654:     foreach my $value ('total.count','average.count') {
                   2655:         delete($Keywords{$value}) if (exists($Keywords{$value}));
1.586     raeburn  2656:   }
1.46      matthew  2657:     return 1;
                   2658: }
                   2659: 
                   2660: ###################################################
                   2661: 
                   2662: =pod
                   2663: 
1.648     raeburn  2664: =item * &keyword($word)
1.46      matthew  2665: 
                   2666: Returns true if $word is a keyword.  A keyword is a word that appears more 
                   2667: than the average number of times in the thesaurus database.  Calls 
                   2668: &initialize_keywords
                   2669: 
                   2670: =cut
                   2671: 
                   2672: ###################################################
1.20      www      2673: 
                   2674: sub keyword {
1.46      matthew  2675:     return if (!&initialize_keywords());
                   2676:     my $word=lc(shift());
                   2677:     $word=~s/\W//g;
                   2678:     return exists($Keywords{$word});
1.20      www      2679: }
1.46      matthew  2680: 
                   2681: ###############################################################
                   2682: 
                   2683: =pod 
1.20      www      2684: 
1.648     raeburn  2685: =item * &get_related_words()
1.46      matthew  2686: 
1.160     matthew  2687: Look up a word in the thesaurus.  Takes a scalar argument and returns
1.46      matthew  2688: an array of words.  If the keyword is not in the thesaurus, an empty array
                   2689: will be returned.  The order of the words returned is determined by the
                   2690: database which holds them.
                   2691: 
                   2692: Uses global $thesaurus_db_file.
                   2693: 
                   2694: =cut
                   2695: 
                   2696: ###############################################################
                   2697: sub get_related_words {
                   2698:     my $keyword = shift;
                   2699:     my %thesaurus_db;
                   2700:     if (! -e $thesaurus_db_file) {
                   2701:         &Apache::lonnet::logthis("Attempt to access $thesaurus_db_file ".
                   2702:                                  "failed because the file does not exist");
                   2703:         return ();
                   2704:     }
                   2705:     if (! tie(%thesaurus_db,'GDBM_File',
1.53      albertel 2706:               $thesaurus_db_file,&GDBM_READER(),0640)){
1.46      matthew  2707:         return ();
                   2708:     } 
                   2709:     my @Words=();
1.429     www      2710:     my $count=0;
1.46      matthew  2711:     if (exists($thesaurus_db{$keyword})) {
1.356     albertel 2712: 	# The first element is the number of times
                   2713: 	# the word appears.  We do not need it now.
1.429     www      2714: 	my (undef,@RelatedWords) = (split(/:/,$thesaurus_db{$keyword}));
                   2715: 	my (undef,$mostfrequentcount)=split(/\,/,$RelatedWords[0]);
                   2716: 	my $threshold=$mostfrequentcount/10;
                   2717:         foreach my $possibleword (@RelatedWords) {
                   2718:             my ($word,$wordcount)=split(/\,/,$possibleword);
                   2719:             if ($wordcount>$threshold) {
                   2720: 		push(@Words,$word);
                   2721:                 $count++;
                   2722:                 if ($count>10) { last; }
                   2723: 	    }
1.20      www      2724:         }
                   2725:     }
1.46      matthew  2726:     untie %thesaurus_db;
                   2727:     return @Words;
1.14      harris41 2728: }
1.46      matthew  2729: 
1.112     bowersj2 2730: =pod
                   2731: 
                   2732: =back
                   2733: 
                   2734: =cut
1.61      www      2735: 
                   2736: # -------------------------------------------------------------- Plaintext name
1.81      albertel 2737: =pod
                   2738: 
1.112     bowersj2 2739: =head1 User Name Functions
                   2740: 
                   2741: =over 4
                   2742: 
1.648     raeburn  2743: =item * &plainname($uname,$udom,$first)
1.81      albertel 2744: 
1.112     bowersj2 2745: Takes a users logon name and returns it as a string in
1.226     albertel 2746: "first middle last generation" form 
                   2747: if $first is set to 'lastname' then it returns it as
                   2748: 'lastname generation, firstname middlename' if their is a lastname
1.81      albertel 2749: 
                   2750: =cut
1.61      www      2751: 
1.295     www      2752: 
1.81      albertel 2753: ###############################################################
1.61      www      2754: sub plainname {
1.226     albertel 2755:     my ($uname,$udom,$first)=@_;
1.537     albertel 2756:     return if (!defined($uname) || !defined($udom));
1.295     www      2757:     my %names=&getnames($uname,$udom);
1.226     albertel 2758:     my $name=&Apache::lonnet::format_name($names{'firstname'},
                   2759: 					  $names{'middlename'},
                   2760: 					  $names{'lastname'},
                   2761: 					  $names{'generation'},$first);
                   2762:     $name=~s/^\s+//;
1.62      www      2763:     $name=~s/\s+$//;
                   2764:     $name=~s/\s+/ /g;
1.353     albertel 2765:     if ($name !~ /\S/) { $name=$uname.':'.$udom; }
1.62      www      2766:     return $name;
1.61      www      2767: }
1.66      www      2768: 
                   2769: # -------------------------------------------------------------------- Nickname
1.81      albertel 2770: =pod
                   2771: 
1.648     raeburn  2772: =item * &nickname($uname,$udom)
1.81      albertel 2773: 
                   2774: Gets a users name and returns it as a string as
                   2775: 
                   2776: "&quot;nickname&quot;"
1.66      www      2777: 
1.81      albertel 2778: if the user has a nickname or
                   2779: 
                   2780: "first middle last generation"
                   2781: 
                   2782: if the user does not
                   2783: 
                   2784: =cut
1.66      www      2785: 
                   2786: sub nickname {
                   2787:     my ($uname,$udom)=@_;
1.537     albertel 2788:     return if (!defined($uname) || !defined($udom));
1.295     www      2789:     my %names=&getnames($uname,$udom);
1.68      albertel 2790:     my $name=$names{'nickname'};
1.66      www      2791:     if ($name) {
                   2792:        $name='&quot;'.$name.'&quot;'; 
                   2793:     } else {
                   2794:        $name=$names{'firstname'}.' '.$names{'middlename'}.' '.
                   2795: 	     $names{'lastname'}.' '.$names{'generation'};
                   2796:        $name=~s/\s+$//;
                   2797:        $name=~s/\s+/ /g;
                   2798:     }
                   2799:     return $name;
                   2800: }
                   2801: 
1.295     www      2802: sub getnames {
                   2803:     my ($uname,$udom)=@_;
1.537     albertel 2804:     return if (!defined($uname) || !defined($udom));
1.433     albertel 2805:     if ($udom eq 'public' && $uname eq 'public') {
                   2806: 	return ('lastname' => &mt('Public'));
                   2807:     }
1.295     www      2808:     my $id=$uname.':'.$udom;
                   2809:     my ($names,$cached)=&Apache::lonnet::is_cached_new('namescache',$id);
                   2810:     if ($cached) {
                   2811: 	return %{$names};
                   2812:     } else {
                   2813: 	my %loadnames=&Apache::lonnet::get('environment',
                   2814:                     ['firstname','middlename','lastname','generation','nickname'],
                   2815: 					 $udom,$uname);
                   2816: 	&Apache::lonnet::do_cache_new('namescache',$id,\%loadnames);
                   2817: 	return %loadnames;
                   2818:     }
                   2819: }
1.61      www      2820: 
1.542     raeburn  2821: # -------------------------------------------------------------------- getemails
1.648     raeburn  2822: 
1.542     raeburn  2823: =pod
                   2824: 
1.648     raeburn  2825: =item * &getemails($uname,$udom)
1.542     raeburn  2826: 
                   2827: Gets a user's email information and returns it as a hash with keys:
                   2828: notification, critnotification, permanentemail
                   2829: 
                   2830: For notification and critnotification, values are comma-separated lists 
1.648     raeburn  2831: of e-mail addresses; for permanentemail, value is a single e-mail address.
1.542     raeburn  2832:  
1.648     raeburn  2833: 
1.542     raeburn  2834: =cut
                   2835: 
1.648     raeburn  2836: 
1.466     albertel 2837: sub getemails {
                   2838:     my ($uname,$udom)=@_;
                   2839:     if ($udom eq 'public' && $uname eq 'public') {
                   2840: 	return;
                   2841:     }
1.467     www      2842:     if (!$udom) { $udom=$env{'user.domain'}; }
                   2843:     if (!$uname) { $uname=$env{'user.name'}; }
1.466     albertel 2844:     my $id=$uname.':'.$udom;
                   2845:     my ($names,$cached)=&Apache::lonnet::is_cached_new('emailscache',$id);
                   2846:     if ($cached) {
                   2847: 	return %{$names};
                   2848:     } else {
                   2849: 	my %loadnames=&Apache::lonnet::get('environment',
                   2850:                     			   ['notification','critnotification',
                   2851: 					    'permanentemail'],
                   2852: 					   $udom,$uname);
                   2853: 	&Apache::lonnet::do_cache_new('emailscache',$id,\%loadnames);
                   2854: 	return %loadnames;
                   2855:     }
                   2856: }
                   2857: 
1.551     albertel 2858: sub flush_email_cache {
                   2859:     my ($uname,$udom)=@_;
                   2860:     if (!$udom)  { $udom =$env{'user.domain'}; }
                   2861:     if (!$uname) { $uname=$env{'user.name'};   }
                   2862:     return if ($udom eq 'public' && $uname eq 'public');
                   2863:     my $id=$uname.':'.$udom;
                   2864:     &Apache::lonnet::devalidate_cache_new('emailscache',$id);
                   2865: }
                   2866: 
1.692.4.2  raeburn  2867: # -------------------------------------------------------------------- getlangs
                   2868: 
                   2869: =pod
                   2870: 
                   2871: =item * &getlangs($uname,$udom)
                   2872: 
                   2873: Gets a user's language preference and returns it as a hash with key:
                   2874: language.
                   2875: 
                   2876: =cut
                   2877: 
                   2878: 
                   2879: sub getlangs {
                   2880:     my ($uname,$udom) = @_;
                   2881:     if (!$udom)  { $udom =$env{'user.domain'}; }
                   2882:     if (!$uname) { $uname=$env{'user.name'};   }
                   2883:     my $id=$uname.':'.$udom;
                   2884:     my ($langs,$cached)=&Apache::lonnet::is_cached_new('userlangs',$id);
                   2885:     if ($cached) {
                   2886:         return %{$langs};
                   2887:     } else {
                   2888:         my %loadlangs=&Apache::lonnet::get('environment',['languages'],
                   2889:                                            $udom,$uname);
                   2890:         &Apache::lonnet::do_cache_new('userlangs',$id,\%loadlangs);
                   2891:         return %loadlangs;
                   2892:     }
                   2893: }
                   2894: 
                   2895: sub flush_langs_cache {
                   2896:     my ($uname,$udom)=@_;
                   2897:     if (!$udom)  { $udom =$env{'user.domain'}; }
                   2898:     if (!$uname) { $uname=$env{'user.name'};   }
                   2899:     return if ($udom eq 'public' && $uname eq 'public');
                   2900:     my $id=$uname.':'.$udom;
                   2901:     &Apache::lonnet::devalidate_cache_new('userlangs',$id);
                   2902: }
                   2903: 
1.61      www      2904: # ------------------------------------------------------------------ Screenname
1.81      albertel 2905: 
                   2906: =pod
                   2907: 
1.648     raeburn  2908: =item * &screenname($uname,$udom)
1.81      albertel 2909: 
                   2910: Gets a users screenname and returns it as a string
                   2911: 
                   2912: =cut
1.61      www      2913: 
                   2914: sub screenname {
                   2915:     my ($uname,$udom)=@_;
1.258     albertel 2916:     if ($uname eq $env{'user.name'} &&
                   2917: 	$udom eq $env{'user.domain'}) {return $env{'environment.screenname'};}
1.212     albertel 2918:     my %names=&Apache::lonnet::get('environment',['screenname'],$udom,$uname);
1.68      albertel 2919:     return $names{'screenname'};
1.62      www      2920: }
                   2921: 
1.692.4.2  raeburn  2922: # ------------------------------------------------------------- Confirm Wrapper
                   2923: =pod
                   2924: 
                   2925: =item confirmwrapper
                   2926: 
                   2927: Wrap messages about completion of operation in box
                   2928: 
                   2929: =cut
                   2930: 
                   2931: sub confirmwrapper {
                   2932:     my ($message)=@_;
                   2933:     if ($message) {
                   2934:         return "\n".'<div class="LC_confirm_box">'."\n"
                   2935:                .$message."\n"
                   2936:                .'</div>'."\n";
                   2937:     } else {
                   2938:         return $message;
                   2939:     }
                   2940: }
1.212     albertel 2941: 
1.62      www      2942: # ------------------------------------------------------------- Message Wrapper
                   2943: 
                   2944: sub messagewrapper {
1.369     www      2945:     my ($link,$username,$domain,$subject,$text)=@_;
1.62      www      2946:     return 
1.441     albertel 2947:         '<a href="/adm/email?compose=individual&amp;'.
                   2948:         'recname='.$username.'&amp;recdom='.$domain.
                   2949: 	'&amp;subject='.&escape($subject).'&amp;text='.&escape($text).'" '.
1.200     matthew  2950:         'title="'.&mt('Send message').'">'.$link.'</a>';
1.74      www      2951: }
                   2952: # --------------------------------------------------------------- Notes Wrapper
                   2953: 
                   2954: sub noteswrapper {
                   2955:     my ($link,$un,$do)=@_;
                   2956:     return 
                   2957: "<a href='/adm/email?recordftf=retrieve&recname=$un&recdom=$do'>$link</a>";
1.62      www      2958: }
                   2959: # ------------------------------------------------------------- Aboutme Wrapper
                   2960: 
                   2961: sub aboutmewrapper {
1.166     www      2962:     my ($link,$username,$domain,$target)=@_;
1.447     raeburn  2963:     if (!defined($username)  && !defined($domain)) {
                   2964:         return;
                   2965:     }
1.205     www      2966:     return '<a href="/adm/'.$domain.'/'.$username.'/aboutme"'.
1.692.4.2  raeburn  2967: 	($target?' target="$target"':'').' title="'.&mt("View this user's personal information page").'">'.$link.'</a>';
1.62      www      2968: }
                   2969: 
                   2970: # ------------------------------------------------------------ Syllabus Wrapper
                   2971: 
                   2972: 
                   2973: sub syllabuswrapper {
1.109     matthew  2974:     my ($linktext,$coursedir,$domain,$fontcolor)=@_;
                   2975:     if ($fontcolor) { 
                   2976:         $linktext='<font color="'.$fontcolor.'">'.$linktext.'</font>'; 
                   2977:     }
1.208     matthew  2978:     return qq{<a href="/public/$domain/$coursedir/syllabus">$linktext</a>};
1.61      www      2979: }
1.14      harris41 2980: 
1.208     matthew  2981: sub track_student_link {
1.692.4.17  raeburn  2982:     my ($linktext,$sname,$sdom,$target,$start,$only_body) = @_;
1.268     albertel 2983:     my $link ="/adm/trackstudent?";
1.208     matthew  2984:     my $title = 'View recent activity';
                   2985:     if (defined($sname) && $sname !~ /^\s*$/ &&
                   2986:         defined($sdom)  && $sdom  !~ /^\s*$/) {
1.268     albertel 2987:         $link .= "selected_student=$sname:$sdom";
1.208     matthew  2988:         $title .= ' of this student';
1.268     albertel 2989:     } 
1.208     matthew  2990:     if (defined($target) && $target !~ /^\s*$/) {
                   2991:         $target = qq{target="$target"};
                   2992:     } else {
                   2993:         $target = '';
                   2994:     }
1.268     albertel 2995:     if ($start) { $link.='&amp;start='.$start; }
1.692.4.17  raeburn  2996:     if ($only_body) { $link .= '&amp;only_body=1'; }
1.554     albertel 2997:     $title = &mt($title);
                   2998:     $linktext = &mt($linktext);
1.448     albertel 2999:     return qq{<a href="$link" title="$title" $target>$linktext</a>}.
                   3000: 	&help_open_topic('View_recent_activity');
1.208     matthew  3001: }
                   3002: 
1.692.4.2  raeburn  3003: sub slot_reservations_link {
                   3004:     my ($linktext,$sname,$sdom,$target) = @_;
                   3005:     my $link ="/adm/slotrequest?command=showresv&amp;origin=aboutme";
                   3006:     my $title = 'View slot reservation history';
                   3007:     if (defined($sname) && $sname !~ /^\s*$/ &&
                   3008:         defined($sdom)  && $sdom  !~ /^\s*$/) {
                   3009:         $link .= "&amp;uname=$sname&amp;udom=$sdom";
                   3010:         $title .= ' of this student';
                   3011:     }
                   3012:     if (defined($target) && $target !~ /^\s*$/) {
                   3013:         $target = qq{target="$target"};
                   3014:     } else {
                   3015:         $target = '';
                   3016:     }
                   3017:     $title = &mt($title);
                   3018:     $linktext = &mt($linktext);
                   3019:     return qq{<a href="$link" title="$title" $target>$linktext</a>};
                   3020: # FIXME uncomment when help item created: &help_open_topic('Slot_Reservation_History');
                   3021: 
                   3022: }
                   3023: 
1.508     www      3024: # ===================================================== Display a student photo
                   3025: 
                   3026: 
1.509     albertel 3027: sub student_image_tag {
1.508     www      3028:     my ($domain,$user)=@_;
                   3029:     my $imgsrc=&Apache::lonnet::studentphoto($domain,$user,'jpg');
                   3030:     if (($imgsrc) && ($imgsrc ne '/adm/lonKaputt/lonlogo_broken.gif')) {
                   3031: 	return '<img src="'.$imgsrc.'" align="right" />';
                   3032:     } else {
                   3033: 	return '';
                   3034:     }
                   3035: }
                   3036: 
1.112     bowersj2 3037: =pod
                   3038: 
                   3039: =back
                   3040: 
                   3041: =head1 Access .tab File Data
                   3042: 
                   3043: =over 4
                   3044: 
1.648     raeburn  3045: =item * &languageids() 
1.112     bowersj2 3046: 
                   3047: returns list of all language ids
                   3048: 
                   3049: =cut
                   3050: 
1.14      harris41 3051: sub languageids {
1.16      harris41 3052:     return sort(keys(%language));
1.14      harris41 3053: }
                   3054: 
1.112     bowersj2 3055: =pod
                   3056: 
1.648     raeburn  3057: =item * &languagedescription() 
1.112     bowersj2 3058: 
                   3059: returns description of a specified language id
                   3060: 
                   3061: =cut
                   3062: 
1.14      harris41 3063: sub languagedescription {
1.125     www      3064:     my $code=shift;
                   3065:     return  ($supported_language{$code}?'* ':'').
                   3066:             $language{$code}.
1.126     www      3067: 	    ($supported_language{$code}?' ('.&mt('interface available').')':'');
1.145     www      3068: }
                   3069: 
                   3070: sub plainlanguagedescription {
                   3071:     my $code=shift;
                   3072:     return $language{$code};
                   3073: }
                   3074: 
                   3075: sub supportedlanguagecode {
                   3076:     my $code=shift;
                   3077:     return $supported_language{$code};
1.97      www      3078: }
                   3079: 
1.112     bowersj2 3080: =pod
                   3081: 
1.648     raeburn  3082: =item * &copyrightids() 
1.112     bowersj2 3083: 
                   3084: returns list of all copyrights
                   3085: 
                   3086: =cut
                   3087: 
                   3088: sub copyrightids {
                   3089:     return sort(keys(%cprtag));
                   3090: }
                   3091: 
                   3092: =pod
                   3093: 
1.648     raeburn  3094: =item * &copyrightdescription() 
1.112     bowersj2 3095: 
                   3096: returns description of a specified copyright id
                   3097: 
                   3098: =cut
                   3099: 
                   3100: sub copyrightdescription {
1.166     www      3101:     return &mt($cprtag{shift(@_)});
1.112     bowersj2 3102: }
1.197     matthew  3103: 
                   3104: =pod
                   3105: 
1.648     raeburn  3106: =item * &source_copyrightids() 
1.192     taceyjo1 3107: 
                   3108: returns list of all source copyrights
                   3109: 
                   3110: =cut
                   3111: 
                   3112: sub source_copyrightids {
                   3113:     return sort(keys(%scprtag));
                   3114: }
                   3115: 
                   3116: =pod
                   3117: 
1.648     raeburn  3118: =item * &source_copyrightdescription() 
1.192     taceyjo1 3119: 
                   3120: returns description of a specified source copyright id
                   3121: 
                   3122: =cut
                   3123: 
                   3124: sub source_copyrightdescription {
                   3125:     return &mt($scprtag{shift(@_)});
                   3126: }
1.112     bowersj2 3127: 
                   3128: =pod
                   3129: 
1.648     raeburn  3130: =item * &filecategories() 
1.112     bowersj2 3131: 
                   3132: returns list of all file categories
                   3133: 
                   3134: =cut
                   3135: 
                   3136: sub filecategories {
                   3137:     return sort(keys(%category_extensions));
                   3138: }
                   3139: 
                   3140: =pod
                   3141: 
1.648     raeburn  3142: =item * &filecategorytypes() 
1.112     bowersj2 3143: 
                   3144: returns list of file types belonging to a given file
                   3145: category
                   3146: 
                   3147: =cut
                   3148: 
                   3149: sub filecategorytypes {
1.356     albertel 3150:     my ($cat) = @_;
                   3151:     return @{$category_extensions{lc($cat)}};
1.112     bowersj2 3152: }
                   3153: 
                   3154: =pod
                   3155: 
1.648     raeburn  3156: =item * &fileembstyle() 
1.112     bowersj2 3157: 
                   3158: returns embedding style for a specified file type
                   3159: 
                   3160: =cut
                   3161: 
                   3162: sub fileembstyle {
                   3163:     return $fe{lc(shift(@_))};
1.169     www      3164: }
                   3165: 
1.351     www      3166: sub filemimetype {
                   3167:     return $fm{lc(shift(@_))};
                   3168: }
                   3169: 
1.169     www      3170: 
                   3171: sub filecategoryselect {
                   3172:     my ($name,$value)=@_;
1.189     matthew  3173:     return &select_form($value,$name,
1.169     www      3174: 			'' => &mt('Any category'),
                   3175: 			map { $_,$_ } sort(keys(%category_extensions)));
1.112     bowersj2 3176: }
                   3177: 
                   3178: =pod
                   3179: 
1.648     raeburn  3180: =item * &filedescription() 
1.112     bowersj2 3181: 
                   3182: returns description for a specified file type
                   3183: 
                   3184: =cut
                   3185: 
                   3186: sub filedescription {
1.188     matthew  3187:     my $file_description = $fd{lc(shift())};
                   3188:     $file_description =~ s:([\[\]]):~$1:g;
                   3189:     return &mt($file_description);
1.112     bowersj2 3190: }
                   3191: 
                   3192: =pod
                   3193: 
1.648     raeburn  3194: =item * &filedescriptionex() 
1.112     bowersj2 3195: 
                   3196: returns description for a specified file type with
                   3197: extra formatting
                   3198: 
                   3199: =cut
                   3200: 
                   3201: sub filedescriptionex {
                   3202:     my $ex=shift;
1.188     matthew  3203:     my $file_description = $fd{lc($ex)};
                   3204:     $file_description =~ s:([\[\]]):~$1:g;
                   3205:     return '.'.$ex.' '.&mt($file_description);
1.112     bowersj2 3206: }
                   3207: 
                   3208: # End of .tab access
                   3209: =pod
                   3210: 
                   3211: =back
                   3212: 
                   3213: =cut
                   3214: 
                   3215: # ------------------------------------------------------------------ File Types
                   3216: sub fileextensions {
                   3217:     return sort(keys(%fe));
                   3218: }
                   3219: 
1.97      www      3220: # ----------------------------------------------------------- Display Languages
                   3221: # returns a hash with all desired display languages
                   3222: #
                   3223: 
                   3224: sub display_languages {
                   3225:     my %languages=();
1.692.4.1  raeburn  3226:     foreach my $lang (&Apache::lonlocal::preferred_languages()) {
1.356     albertel 3227: 	$languages{$lang}=1;
1.97      www      3228:     }
                   3229:     &get_unprocessed_cgi($ENV{'QUERY_STRING'},['displaylanguage']);
1.258     albertel 3230:     if ($env{'form.displaylanguage'}) {
1.356     albertel 3231: 	foreach my $lang (split(/\s*(\,|\;|\:)\s*/,$env{'form.displaylanguage'})) {
                   3232: 	    $languages{$lang}=1;
1.97      www      3233:         }
                   3234:     }
                   3235:     return %languages;
1.14      harris41 3236: }
                   3237: 
1.582     albertel 3238: sub languages {
                   3239:     my ($possible_langs) = @_;
1.692.4.1  raeburn  3240:     my @preferred_langs = &Apache::lonlocal::preferred_languages();
1.582     albertel 3241:     if (!ref($possible_langs)) {
                   3242: 	if( wantarray ) {
                   3243: 	    return @preferred_langs;
                   3244: 	} else {
                   3245: 	    return $preferred_langs[0];
                   3246: 	}
                   3247:     }
                   3248:     my %possibilities = map { $_ => 1 } (@$possible_langs);
                   3249:     my @preferred_possibilities;
                   3250:     foreach my $preferred_lang (@preferred_langs) {
                   3251: 	if (exists($possibilities{$preferred_lang})) {
                   3252: 	    push(@preferred_possibilities, $preferred_lang);
                   3253: 	}
                   3254:     }
                   3255:     if( wantarray ) {
                   3256: 	return @preferred_possibilities;
                   3257:     }
                   3258:     return $preferred_possibilities[0];
                   3259: }
                   3260: 
1.692.4.2  raeburn  3261: sub user_lang {
                   3262:     my ($touname,$toudom,$fromcid) = @_;
                   3263:     my @userlangs;
                   3264:     if (($fromcid ne '') && ($env{'course.'.$fromcid.'.languages'} ne '')) {
                   3265:         @userlangs=(@userlangs,split(/\s*(\,|\;|\:)\s*/,
                   3266:                     $env{'course.'.$fromcid.'.languages'}));
                   3267:     } else {
                   3268:         my %langhash = &getlangs($touname,$toudom);
                   3269:         if ($langhash{'languages'} ne '') {
                   3270:             @userlangs = split(/\s*(\,|\;|\:)\s*/,$langhash{'languages'});
                   3271:         } else {
                   3272:             my %domdefs = &Apache::lonnet::get_domain_defaults($toudom);
                   3273:             if ($domdefs{'lang_def'} ne '') {
                   3274:                 @userlangs = ($domdefs{'lang_def'});
                   3275:             }
                   3276:         }
                   3277:     }
                   3278:     my @languages=&Apache::lonlocal::get_genlanguages(@userlangs);
                   3279:     my $user_lh = Apache::localize->get_handle(@languages);
                   3280:     return $user_lh;
                   3281: }
                   3282: 
1.112     bowersj2 3283: ###############################################################
                   3284: ##               Student Answer Attempts                     ##
                   3285: ###############################################################
                   3286: 
                   3287: =pod
                   3288: 
                   3289: =head1 Alternate Problem Views
                   3290: 
                   3291: =over 4
                   3292: 
1.648     raeburn  3293: =item * &get_previous_attempt($symb, $username, $domain, $course,
1.112     bowersj2 3294:     $getattempt, $regexp, $gradesub)
                   3295: 
                   3296: Return string with previous attempt on problem. Arguments:
                   3297: 
                   3298: =over 4
                   3299: 
                   3300: =item * $symb: Problem, including path
                   3301: 
                   3302: =item * $username: username of the desired student
                   3303: 
                   3304: =item * $domain: domain of the desired student
1.14      harris41 3305: 
1.112     bowersj2 3306: =item * $course: Course ID
1.14      harris41 3307: 
1.112     bowersj2 3308: =item * $getattempt: Leave blank for all attempts, otherwise put
                   3309:     something
1.14      harris41 3310: 
1.112     bowersj2 3311: =item * $regexp: if string matches this regexp, the string will be
                   3312:     sent to $gradesub
1.14      harris41 3313: 
1.112     bowersj2 3314: =item * $gradesub: routine that processes the string if it matches $regexp
1.14      harris41 3315: 
1.112     bowersj2 3316: =back
1.14      harris41 3317: 
1.112     bowersj2 3318: The output string is a table containing all desired attempts, if any.
1.16      harris41 3319: 
1.112     bowersj2 3320: =cut
1.1       albertel 3321: 
                   3322: sub get_previous_attempt {
1.43      ng       3323:   my ($symb,$username,$domain,$course,$getattempt,$regexp,$gradesub)=@_;
1.1       albertel 3324:   my $prevattempts='';
1.43      ng       3325:   no strict 'refs';
1.1       albertel 3326:   if ($symb) {
1.3       albertel 3327:     my (%returnhash)=
                   3328:       &Apache::lonnet::restore($symb,$course,$domain,$username);
1.1       albertel 3329:     if ($returnhash{'version'}) {
                   3330:       my %lasthash=();
                   3331:       my $version;
                   3332:       for ($version=1;$version<=$returnhash{'version'};$version++) {
1.356     albertel 3333:         foreach my $key (sort(split(/\:/,$returnhash{$version.':keys'}))) {
                   3334: 	  $lasthash{$key}=$returnhash{$version.':'.$key};
1.19      harris41 3335:         }
1.1       albertel 3336:       }
1.596     albertel 3337:       $prevattempts=&start_data_table().&start_data_table_header_row();
                   3338:       $prevattempts.='<th>'.&mt('History').'</th>';
1.356     albertel 3339:       foreach my $key (sort(keys(%lasthash))) {
                   3340: 	my ($ign,@parts) = split(/\./,$key);
1.41      ng       3341: 	if ($#parts > 0) {
1.31      albertel 3342: 	  my $data=$parts[-1];
                   3343: 	  pop(@parts);
1.596     albertel 3344: 	  $prevattempts.='<th>'.&mt('Part ').join('.',@parts).'<br />'.$data.'&nbsp;</th>';
1.31      albertel 3345: 	} else {
1.41      ng       3346: 	  if ($#parts == 0) {
                   3347: 	    $prevattempts.='<th>'.$parts[0].'</th>';
                   3348: 	  } else {
                   3349: 	    $prevattempts.='<th>'.$ign.'</th>';
                   3350: 	  }
1.31      albertel 3351: 	}
1.16      harris41 3352:       }
1.596     albertel 3353:       $prevattempts.=&end_data_table_header_row();
1.40      ng       3354:       if ($getattempt eq '') {
                   3355: 	for ($version=1;$version<=$returnhash{'version'};$version++) {
1.596     albertel 3356: 	  $prevattempts.=&start_data_table_row().
                   3357: 	      '<td>'.&mt('Transaction [_1]',$version).'</td>';
1.356     albertel 3358: 	    foreach my $key (sort(keys(%lasthash))) {
1.581     albertel 3359: 		my $value = &format_previous_attempt_value($key,
                   3360: 							   $returnhash{$version.':'.$key});
                   3361: 		$prevattempts.='<td>'.$value.'&nbsp;</td>';   
1.40      ng       3362: 	    }
1.596     albertel 3363: 	  $prevattempts.=&end_data_table_row();
1.40      ng       3364: 	 }
1.1       albertel 3365:       }
1.596     albertel 3366:       $prevattempts.=&start_data_table_row().'<td>'.&mt('Current').'</td>';
1.356     albertel 3367:       foreach my $key (sort(keys(%lasthash))) {
1.581     albertel 3368: 	my $value = &format_previous_attempt_value($key,$lasthash{$key});
1.356     albertel 3369: 	if ($key =~/$regexp$/ && (defined &$gradesub)) {$value = &$gradesub($value)}
1.40      ng       3370: 	$prevattempts.='<td>'.$value.'&nbsp;</td>';
1.16      harris41 3371:       }
1.596     albertel 3372:       $prevattempts.= &end_data_table_row().&end_data_table();
1.1       albertel 3373:     } else {
1.596     albertel 3374:       $prevattempts=
                   3375: 	  &start_data_table().&start_data_table_row().
                   3376: 	  '<td>'.&mt('Nothing submitted - no attempts.').'</td>'.
                   3377: 	  &end_data_table_row().&end_data_table();
1.1       albertel 3378:     }
                   3379:   } else {
1.596     albertel 3380:     $prevattempts=
                   3381: 	  &start_data_table().&start_data_table_row().
                   3382: 	  '<td>'.&mt('No data.').'</td>'.
                   3383: 	  &end_data_table_row().&end_data_table();
1.1       albertel 3384:   }
1.10      albertel 3385: }
                   3386: 
1.581     albertel 3387: sub format_previous_attempt_value {
                   3388:     my ($key,$value) = @_;
                   3389:     if ($key =~ /timestamp/) {
                   3390: 	$value = &Apache::lonlocal::locallocaltime($value);
                   3391:     } elsif (ref($value) eq 'ARRAY') {
                   3392: 	$value = '('.join(', ', @{ $value }).')';
                   3393:     } else {
                   3394: 	$value = &unescape($value);
                   3395:     }
                   3396:     return $value;
                   3397: }
                   3398: 
                   3399: 
1.107     albertel 3400: sub relative_to_absolute {
                   3401:     my ($url,$output)=@_;
                   3402:     my $parser=HTML::TokeParser->new(\$output);
                   3403:     my $token;
                   3404:     my $thisdir=$url;
                   3405:     my @rlinks=();
                   3406:     while ($token=$parser->get_token) {
                   3407: 	if ($token->[0] eq 'S') {
                   3408: 	    if ($token->[1] eq 'a') {
                   3409: 		if ($token->[2]->{'href'}) {
                   3410: 		    $rlinks[$#rlinks+1]=$token->[2]->{'href'};
                   3411: 		}
                   3412: 	    } elsif ($token->[1] eq 'img' || $token->[1] eq 'embed' ) {
                   3413: 		$rlinks[$#rlinks+1]=$token->[2]->{'src'};
                   3414: 	    } elsif ($token->[1] eq 'base') {
                   3415: 		$thisdir=$token->[2]->{'href'};
                   3416: 	    }
                   3417: 	}
                   3418:     }
                   3419:     $thisdir=~s-/[^/]*$--;
1.356     albertel 3420:     foreach my $link (@rlinks) {
1.692.4.2  raeburn  3421: 	unless (($link=~/^https?\:\/\//i) ||
1.356     albertel 3422: 		($link=~/^\//) ||
                   3423: 		($link=~/^javascript:/i) ||
                   3424: 		($link=~/^mailto:/i) ||
                   3425: 		($link=~/^\#/)) {
                   3426: 	    my $newlocation=&Apache::lonnet::hreflocation($thisdir,$link);
                   3427: 	    $output=~s/(\"|\'|\=\s*)\Q$link\E(\"|\'|\s|\>)/$1$newlocation$2/;
1.107     albertel 3428: 	}
                   3429:     }
                   3430: # -------------------------------------------------- Deal with Applet codebases
                   3431:     $output=~s/(\<applet[^\>]+)(codebase\=[^\S\>]+)*([^\>]*)\>/$1.($2?$2:' codebase="'.$thisdir.'"').$3.'>'/gei;
                   3432:     return $output;
                   3433: }
                   3434: 
1.112     bowersj2 3435: =pod
                   3436: 
1.648     raeburn  3437: =item * &get_student_view()
1.112     bowersj2 3438: 
                   3439: show a snapshot of what student was looking at
                   3440: 
                   3441: =cut
                   3442: 
1.10      albertel 3443: sub get_student_view {
1.186     albertel 3444:   my ($symb,$username,$domain,$courseid,$target,$moreenv) = @_;
1.114     www      3445:   my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb);
1.186     albertel 3446:   my (%form);
1.10      albertel 3447:   my @elements=('symb','courseid','domain','username');
                   3448:   foreach my $element (@elements) {
1.186     albertel 3449:       $form{'grade_'.$element}=eval '$'.$element #'
1.10      albertel 3450:   }
1.186     albertel 3451:   if (defined($moreenv)) {
                   3452:       %form=(%form,%{$moreenv});
                   3453:   }
1.236     albertel 3454:   if (defined($target)) { $form{'grade_target'} = $target; }
1.107     albertel 3455:   $feedurl=&Apache::lonnet::clutter($feedurl);
1.650     www      3456:   my ($userview,$response)=&Apache::lonnet::ssi_body($feedurl,%form);
1.11      albertel 3457:   $userview=~s/\<body[^\>]*\>//gi;
                   3458:   $userview=~s/\<\/body\>//gi;
                   3459:   $userview=~s/\<html\>//gi;
                   3460:   $userview=~s/\<\/html\>//gi;
                   3461:   $userview=~s/\<head\>//gi;
                   3462:   $userview=~s/\<\/head\>//gi;
                   3463:   $userview=~s/action\s*\=/would_be_action\=/gi;
1.107     albertel 3464:   $userview=&relative_to_absolute($feedurl,$userview);
1.650     www      3465:   if (wantarray) {
                   3466:      return ($userview,$response);
                   3467:   } else {
                   3468:      return $userview;
                   3469:   }
                   3470: }
                   3471: 
                   3472: sub get_student_view_with_retries {
                   3473:   my ($symb,$retries,$username,$domain,$courseid,$target,$moreenv) = @_;
                   3474: 
                   3475:     my $ok = 0;                 # True if we got a good response.
                   3476:     my $content;
                   3477:     my $response;
                   3478: 
                   3479:     # Try to get the student_view done. within the retries count:
                   3480:     
                   3481:     do {
                   3482:          ($content, $response) = &get_student_view($symb,$username,$domain,$courseid,$target,$moreenv);
                   3483:          $ok      = $response->is_success;
                   3484:          if (!$ok) {
                   3485:             &Apache::lonnet::logthis("Failed get_student_view_with_retries on $symb: ".$response->is_success.', '.$response->code.', '.$response->message);
                   3486:          }
                   3487:          $retries--;
                   3488:     } while (!$ok && ($retries > 0));
                   3489:     
                   3490:     if (!$ok) {
                   3491:        $content = '';          # On error return an empty content.
                   3492:     }
1.651     www      3493:     if (wantarray) {
                   3494:        return ($content, $response);
                   3495:     } else {
                   3496:        return $content;
                   3497:     }
1.11      albertel 3498: }
                   3499: 
1.112     bowersj2 3500: =pod
                   3501: 
1.648     raeburn  3502: =item * &get_student_answers() 
1.112     bowersj2 3503: 
                   3504: show a snapshot of how student was answering problem
                   3505: 
                   3506: =cut
                   3507: 
1.11      albertel 3508: sub get_student_answers {
1.100     sakharuk 3509:   my ($symb,$username,$domain,$courseid,%form) = @_;
1.114     www      3510:   my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb);
1.186     albertel 3511:   my (%moreenv);
1.11      albertel 3512:   my @elements=('symb','courseid','domain','username');
                   3513:   foreach my $element (@elements) {
1.186     albertel 3514:     $moreenv{'grade_'.$element}=eval '$'.$element #'
1.10      albertel 3515:   }
1.186     albertel 3516:   $moreenv{'grade_target'}='answer';
                   3517:   %moreenv=(%form,%moreenv);
1.497     raeburn  3518:   $feedurl = &Apache::lonnet::clutter($feedurl);
                   3519:   my $userview=&Apache::lonnet::ssi($feedurl,%moreenv);
1.10      albertel 3520:   return $userview;
1.1       albertel 3521: }
1.116     albertel 3522: 
                   3523: =pod
                   3524: 
                   3525: =item * &submlink()
                   3526: 
1.242     albertel 3527: Inputs: $text $uname $udom $symb $target
1.116     albertel 3528: 
                   3529: Returns: A link to grades.pm such as to see the SUBM view of a student
                   3530: 
                   3531: =cut
                   3532: 
                   3533: ###############################################
                   3534: sub submlink {
1.242     albertel 3535:     my ($text,$uname,$udom,$symb,$target)=@_;
1.116     albertel 3536:     if (!($uname && $udom)) {
                   3537: 	(my $cursymb, my $courseid,$udom,$uname)=
1.463     albertel 3538: 	    &Apache::lonnet::whichuser($symb);
1.116     albertel 3539: 	if (!$symb) { $symb=$cursymb; }
                   3540:     }
1.254     matthew  3541:     if (!$symb) { $symb=&Apache::lonnet::symbread(); }
1.369     www      3542:     $symb=&escape($symb);
1.242     albertel 3543:     if ($target) { $target="target=\"$target\""; }
                   3544:     return '<a href="/adm/grades?&command=submission&'.
                   3545: 	'symb='.$symb.'&student='.$uname.
                   3546: 	'&userdom='.$udom.'" '.$target.'>'.$text.'</a>';
                   3547: }
                   3548: ##############################################
                   3549: 
                   3550: =pod
                   3551: 
                   3552: =item * &pgrdlink()
                   3553: 
                   3554: Inputs: $text $uname $udom $symb $target
                   3555: 
                   3556: Returns: A link to grades.pm such as to see the PGRD view of a student
                   3557: 
                   3558: =cut
                   3559: 
                   3560: ###############################################
                   3561: sub pgrdlink {
                   3562:     my $link=&submlink(@_);
                   3563:     $link=~s/(&command=submission)/$1&showgrading=yes/;
                   3564:     return $link;
                   3565: }
                   3566: ##############################################
                   3567: 
                   3568: =pod
                   3569: 
                   3570: =item * &pprmlink()
                   3571: 
                   3572: Inputs: $text $uname $udom $symb $target
                   3573: 
                   3574: Returns: A link to parmset.pm such as to see the PPRM view of a
1.283     albertel 3575: student and a specific resource
1.242     albertel 3576: 
                   3577: =cut
                   3578: 
                   3579: ###############################################
                   3580: sub pprmlink {
                   3581:     my ($text,$uname,$udom,$symb,$target)=@_;
                   3582:     if (!($uname && $udom)) {
                   3583: 	(my $cursymb, my $courseid,$udom,$uname)=
1.463     albertel 3584: 	    &Apache::lonnet::whichuser($symb);
1.242     albertel 3585: 	if (!$symb) { $symb=$cursymb; }
                   3586:     }
1.254     matthew  3587:     if (!$symb) { $symb=&Apache::lonnet::symbread(); }
1.369     www      3588:     $symb=&escape($symb);
1.242     albertel 3589:     if ($target) { $target="target=\"$target\""; }
1.595     albertel 3590:     return '<a href="/adm/parmset?command=set&amp;'.
                   3591: 	'symb='.$symb.'&amp;uname='.$uname.
                   3592: 	'&amp;udom='.$udom.'" '.$target.'>'.$text.'</a>';
1.116     albertel 3593: }
                   3594: ##############################################
1.37      matthew  3595: 
1.112     bowersj2 3596: =pod
                   3597: 
                   3598: =back
                   3599: 
                   3600: =cut
                   3601: 
1.37      matthew  3602: ###############################################
1.51      www      3603: 
                   3604: 
                   3605: sub timehash {
1.687     raeburn  3606:     my ($thistime) = @_;
                   3607:     my $timezone = &Apache::lonlocal::gettimezone();
                   3608:     my $dt = DateTime->from_epoch(epoch => $thistime)
                   3609:                      ->set_time_zone($timezone);
                   3610:     my $wday = $dt->day_of_week();
                   3611:     if ($wday == 7) { $wday = 0; }
                   3612:     return ( 'second' => $dt->second(),
                   3613:              'minute' => $dt->minute(),
                   3614:              'hour'   => $dt->hour(),
                   3615:              'day'     => $dt->day_of_month(),
                   3616:              'month'   => $dt->month(),
                   3617:              'year'    => $dt->year(),
                   3618:              'weekday' => $wday,
                   3619:              'dayyear' => $dt->day_of_year(),
                   3620:              'dlsav'   => $dt->is_dst() );
1.51      www      3621: }
                   3622: 
1.370     www      3623: sub utc_string {
                   3624:     my ($date)=@_;
1.371     www      3625:     return strftime("%Y%m%dT%H%M%SZ",gmtime($date));
1.370     www      3626: }
                   3627: 
1.51      www      3628: sub maketime {
                   3629:     my %th=@_;
1.687     raeburn  3630:     my ($epoch_time,$timezone,$dt);
                   3631:     $timezone = &Apache::lonlocal::gettimezone();
                   3632:     eval {
                   3633:         $dt = DateTime->new( year   => $th{'year'},
                   3634:                              month  => $th{'month'},
                   3635:                              day    => $th{'day'},
                   3636:                              hour   => $th{'hour'},
                   3637:                              minute => $th{'minute'},
                   3638:                              second => $th{'second'},
                   3639:                              time_zone => $timezone,
                   3640:                          );
                   3641:     };
                   3642:     if (!$@) {
                   3643:         $epoch_time = $dt->epoch;
                   3644:         if ($epoch_time) {
                   3645:             return $epoch_time;
                   3646:         }
                   3647:     }
1.51      www      3648:     return POSIX::mktime(
                   3649:         ($th{'seconds'},$th{'minutes'},$th{'hours'},
1.210     www      3650:          $th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,-1));
1.70      www      3651: }
                   3652: 
                   3653: #########################################
1.51      www      3654: 
                   3655: sub findallcourses {
1.482     raeburn  3656:     my ($roles,$uname,$udom) = @_;
1.355     albertel 3657:     my %roles;
                   3658:     if (ref($roles)) { %roles = map { $_ => 1 } @{$roles}; }
1.348     albertel 3659:     my %courses;
1.51      www      3660:     my $now=time;
1.482     raeburn  3661:     if (!defined($uname)) {
                   3662:         $uname = $env{'user.name'};
                   3663:     }
                   3664:     if (!defined($udom)) {
                   3665:         $udom = $env{'user.domain'};
                   3666:     }
                   3667:     if (($uname ne $env{'user.name'}) || ($udom ne $env{'user.domain'})) {
                   3668:         my %roleshash = &Apache::lonnet::dump('roles',$udom,$uname);
                   3669:         if (!%roles) {
                   3670:             %roles = (
                   3671:                        cc => 1,
                   3672:                        in => 1,
                   3673:                        ep => 1,
                   3674:                        ta => 1,
                   3675:                        cr => 1,
                   3676:                        st => 1,
                   3677:              );
                   3678:         }
                   3679:         foreach my $entry (keys(%roleshash)) {
                   3680:             my ($trole,$tend,$tstart) = split(/_/,$roleshash{$entry});
                   3681:             if ($trole =~ /^cr/) { 
                   3682:                 next if (!exists($roles{$trole}) && !exists($roles{'cr'}));
                   3683:             } else {
                   3684:                 next if (!exists($roles{$trole}));
                   3685:             }
                   3686:             if ($tend) {
                   3687:                 next if ($tend < $now);
                   3688:             }
                   3689:             if ($tstart) {
                   3690:                 next if ($tstart > $now);
                   3691:             }
                   3692:             my ($cdom,$cnum,$sec,$cnumpart,$secpart,$role,$realsec);
                   3693:             (undef,$cdom,$cnumpart,$secpart) = split(/\//,$entry);
                   3694:             if ($secpart eq '') {
                   3695:                 ($cnum,$role) = split(/_/,$cnumpart); 
                   3696:                 $sec = 'none';
                   3697:                 $realsec = '';
                   3698:             } else {
                   3699:                 $cnum = $cnumpart;
                   3700:                 ($sec,$role) = split(/_/,$secpart);
                   3701:                 $realsec = $sec;
1.490     raeburn  3702:             }
1.482     raeburn  3703:             $courses{$cdom.'_'.$cnum}{$sec} = $trole.'/'.$cdom.'/'.$cnum.'/'.$realsec;
                   3704:         }
                   3705:     } else {
                   3706:         foreach my $key (keys(%env)) {
1.483     albertel 3707: 	    if ( $key=~m{^user\.role\.(\w+)\./($match_domain)/($match_courseid)/?(\w*)$} ||
                   3708:                  $key=~m{^user\.role\.(cr/$match_domain/$match_username/\w+)\./($match_domain)/($match_courseid)/?(\w*)$}) {
1.482     raeburn  3709: 	        my ($role,$cdom,$cnum,$sec) = ($1,$2,$3,$4);
                   3710: 	        next if ($role eq 'ca' || $role eq 'aa');
                   3711: 	        next if (%roles && !exists($roles{$role}));
                   3712: 	        my ($starttime,$endtime)=split(/\./,$env{$key});
                   3713:                 my $active=1;
                   3714:                 if ($starttime) {
                   3715: 		    if ($now<$starttime) { $active=0; }
                   3716:                 }
                   3717:                 if ($endtime) {
                   3718:                     if ($now>$endtime) { $active=0; }
                   3719:                 }
                   3720:                 if ($active) {
                   3721:                     if ($sec eq '') {
                   3722:                         $sec = 'none';
                   3723:                     }
                   3724:                     $courses{$cdom.'_'.$cnum}{$sec} = 
                   3725:                                      $role.'/'.$cdom.'/'.$cnum.'/'.$sec;
1.474     raeburn  3726:                 }
                   3727:             }
1.51      www      3728:         }
                   3729:     }
1.474     raeburn  3730:     return %courses;
1.51      www      3731: }
1.37      matthew  3732: 
1.54      www      3733: ###############################################
1.474     raeburn  3734: 
                   3735: sub blockcheck {
1.482     raeburn  3736:     my ($setters,$activity,$uname,$udom) = @_;
1.490     raeburn  3737: 
                   3738:     if (!defined($udom)) {
                   3739:         $udom = $env{'user.domain'};
                   3740:     }
                   3741:     if (!defined($uname)) {
                   3742:         $uname = $env{'user.name'};
                   3743:     }
                   3744: 
                   3745:     # If uname and udom are for a course, check for blocks in the course.
                   3746: 
                   3747:     if (&Apache::lonnet::is_course($udom,$uname)) {
                   3748:         my %records = &Apache::lonnet::dump('comm_block',$udom,$uname);
1.502     raeburn  3749:         my ($startblock,$endblock)=&get_blocks($setters,$activity,$udom,$uname);
1.490     raeburn  3750:         return ($startblock,$endblock);
                   3751:     }
1.474     raeburn  3752: 
1.502     raeburn  3753:     my $startblock = 0;
                   3754:     my $endblock = 0;
1.482     raeburn  3755:     my %live_courses = &findallcourses(undef,$uname,$udom);
1.474     raeburn  3756: 
1.490     raeburn  3757:     # If uname is for a user, and activity is course-specific, i.e.,
                   3758:     # boards, chat or groups, check for blocking in current course only.
1.474     raeburn  3759: 
1.490     raeburn  3760:     if (($activity eq 'boards' || $activity eq 'chat' ||
                   3761:          $activity eq 'groups') && ($env{'request.course.id'})) {
                   3762:         foreach my $key (keys(%live_courses)) {
                   3763:             if ($key ne $env{'request.course.id'}) {
                   3764:                 delete($live_courses{$key});
                   3765:             }
                   3766:         }
                   3767:     }
                   3768: 
                   3769:     my $otheruser = 0;
                   3770:     my %own_courses;
                   3771:     if ((($uname ne $env{'user.name'})) || ($udom ne $env{'user.domain'})) {
                   3772:         # Resource belongs to user other than current user.
                   3773:         $otheruser = 1;
                   3774:         # Gather courses for current user
                   3775:         %own_courses = 
                   3776:             &findallcourses(undef,$env{'user.name'},$env{'user.domain'});
                   3777:     }
                   3778: 
                   3779:     # Gather active course roles - course coordinator, instructor, 
                   3780:     # exam proctor, ta, student, or custom role.
1.474     raeburn  3781: 
                   3782:     foreach my $course (keys(%live_courses)) {
1.482     raeburn  3783:         my ($cdom,$cnum);
                   3784:         if ((defined($env{'course.'.$course.'.domain'})) && (defined($env{'course.'.$course.'.num'}))) {
                   3785:             $cdom = $env{'course.'.$course.'.domain'};
                   3786:             $cnum = $env{'course.'.$course.'.num'};
                   3787:         } else {
1.490     raeburn  3788:             ($cdom,$cnum) = split(/_/,$course); 
1.482     raeburn  3789:         }
                   3790:         my $no_ownblock = 0;
                   3791:         my $no_userblock = 0;
1.533     raeburn  3792:         if ($otheruser && $activity ne 'com') {
1.490     raeburn  3793:             # Check if current user has 'evb' priv for this
                   3794:             if (defined($own_courses{$course})) {
                   3795:                 foreach my $sec (keys(%{$own_courses{$course}})) {
                   3796:                     my $checkrole = 'cm./'.$cdom.'/'.$cnum;
                   3797:                     if ($sec ne 'none') {
                   3798:                         $checkrole .= '/'.$sec;
                   3799:                     }
                   3800:                     if (&Apache::lonnet::allowed('evb',undef,undef,$checkrole)) {
                   3801:                         $no_ownblock = 1;
                   3802:                         last;
                   3803:                     }
                   3804:                 }
                   3805:             }
                   3806:             # if they have 'evb' priv and are currently not playing student
                   3807:             next if (($no_ownblock) &&
                   3808:                  ($env{'request.role'} !~ m{^st\./$cdom/$cnum}));
                   3809:         }
1.474     raeburn  3810:         foreach my $sec (keys(%{$live_courses{$course}})) {
1.482     raeburn  3811:             my $checkrole = 'cm./'.$cdom.'/'.$cnum;
1.474     raeburn  3812:             if ($sec ne 'none') {
1.482     raeburn  3813:                 $checkrole .= '/'.$sec;
1.474     raeburn  3814:             }
1.490     raeburn  3815:             if ($otheruser) {
                   3816:                 # Resource belongs to user other than current user.
                   3817:                 # Assemble privs for that user, and check for 'evb' priv.
1.482     raeburn  3818:                 my ($trole,$tdom,$tnum,$tsec);
                   3819:                 my $entry = $live_courses{$course}{$sec};
                   3820:                 if ($entry =~ /^cr/) {
                   3821:                     ($trole,$tdom,$tnum,$tsec) = 
                   3822:                       ($entry =~ m|^(cr/$match_domain/$match_username/\w+)\./($match_domain)/($match_username)/?(\w*)$|);
                   3823:                 } else {
                   3824:                     ($trole,$tdom,$tnum,$tsec) = split(/\//,$entry);
                   3825:                 }
                   3826:                 my ($spec,$area,$trest,%allroles,%userroles);
                   3827:                 $area = '/'.$tdom.'/'.$tnum;
                   3828:                 $trest = $tnum;
                   3829:                 if ($tsec ne '') {
                   3830:                     $area .= '/'.$tsec;
                   3831:                     $trest .= '/'.$tsec;
                   3832:                 }
                   3833:                 $spec = $trole.'.'.$area;
                   3834:                 if ($trole =~ /^cr/) {
                   3835:                     &Apache::lonnet::custom_roleprivs(\%allroles,$trole,
                   3836:                                                       $tdom,$spec,$trest,$area);
                   3837:                 } else {
                   3838:                     &Apache::lonnet::standard_roleprivs(\%allroles,$trole,
                   3839:                                                        $tdom,$spec,$trest,$area);
                   3840:                 }
                   3841:                 my ($author,$adv) = &Apache::lonnet::set_userprivs(\%userroles,\%allroles);
1.486     raeburn  3842:                 if ($userroles{'user.priv.'.$checkrole} =~ /evb\&([^\:]*)/) {
                   3843:                     if ($1) {
                   3844:                         $no_userblock = 1;
                   3845:                         last;
                   3846:                     }
                   3847:                 }
1.490     raeburn  3848:             } else {
                   3849:                 # Resource belongs to current user
                   3850:                 # Check for 'evb' priv via lonnet::allowed().
1.482     raeburn  3851:                 if (&Apache::lonnet::allowed('evb',undef,undef,$checkrole)) {
                   3852:                     $no_ownblock = 1;
                   3853:                     last;
                   3854:                 }
1.474     raeburn  3855:             }
                   3856:         }
                   3857:         # if they have the evb priv and are currently not playing student
1.482     raeburn  3858:         next if (($no_ownblock) &&
1.491     albertel 3859:                  ($env{'request.role'} !~ m{^st\./\Q$cdom\E/\Q$cnum\E}));
1.482     raeburn  3860:         next if ($no_userblock);
1.474     raeburn  3861: 
1.490     raeburn  3862:         # Retrieve blocking times and identity of blocker for course
                   3863:         # of specified user, unless user has 'evb' privilege.
1.502     raeburn  3864:         
                   3865:         my ($start,$end)=&get_blocks($setters,$activity,$cdom,$cnum);
                   3866:         if (($start != 0) && 
                   3867:             (($startblock == 0) || ($startblock > $start))) {
                   3868:             $startblock = $start;
                   3869:         }
                   3870:         if (($end != 0)  &&
                   3871:             (($endblock == 0) || ($endblock < $end))) {
                   3872:             $endblock = $end;
                   3873:         }
1.490     raeburn  3874:     }
                   3875:     return ($startblock,$endblock);
                   3876: }
                   3877: 
                   3878: sub get_blocks {
                   3879:     my ($setters,$activity,$cdom,$cnum) = @_;
                   3880:     my $startblock = 0;
                   3881:     my $endblock = 0;
                   3882:     my $course = $cdom.'_'.$cnum;
                   3883:     $setters->{$course} = {};
                   3884:     $setters->{$course}{'staff'} = [];
                   3885:     $setters->{$course}{'times'} = [];
                   3886:     my %records = &Apache::lonnet::dump('comm_block',$cdom,$cnum);
                   3887:     foreach my $record (keys(%records)) {
                   3888:         my ($start,$end) = ($record =~ m/^(\d+)____(\d+)$/);
                   3889:         if ($start <= time && $end >= time) {
                   3890:             my ($staff_name,$staff_dom,$title,$blocks) =
                   3891:                 &parse_block_record($records{$record});
                   3892:             if ($blocks->{$activity} eq 'on') {
                   3893:                 push(@{$$setters{$course}{'staff'}},[$staff_name,$staff_dom]);
                   3894:                 push(@{$$setters{$course}{'times'}}, [$start,$end]);
1.491     albertel 3895:                 if ( ($startblock == 0) || ($startblock > $start) ) {
                   3896:                     $startblock = $start;
1.490     raeburn  3897:                 }
1.491     albertel 3898:                 if ( ($endblock == 0) || ($endblock < $end) ) {
                   3899:                     $endblock = $end;
1.474     raeburn  3900:                 }
                   3901:             }
                   3902:         }
                   3903:     }
                   3904:     return ($startblock,$endblock);
                   3905: }
                   3906: 
                   3907: sub parse_block_record {
                   3908:     my ($record) = @_;
                   3909:     my ($setuname,$setudom,$title,$blocks);
                   3910:     if (ref($record) eq 'HASH') {
                   3911:         ($setuname,$setudom) = split(/:/,$record->{'setter'});
                   3912:         $title = &unescape($record->{'event'});
                   3913:         $blocks = $record->{'blocks'};
                   3914:     } else {
                   3915:         my @data = split(/:/,$record,3);
                   3916:         if (scalar(@data) eq 2) {
                   3917:             $title = $data[1];
                   3918:             ($setuname,$setudom) = split(/@/,$data[0]);
                   3919:         } else {
                   3920:             ($setuname,$setudom,$title) = @data;
                   3921:         }
                   3922:         $blocks = { 'com' => 'on' };
                   3923:     }
                   3924:     return ($setuname,$setudom,$title,$blocks);
                   3925: }
                   3926: 
                   3927: sub build_block_table {
                   3928:     my ($startblock,$endblock,$setters) = @_;
                   3929:     my %lt = &Apache::lonlocal::texthash(
                   3930:         'cacb' => 'Currently active communication blocks',
                   3931:         'cour' => 'Course',
                   3932:         'dura' => 'Duration',
                   3933:         'blse' => 'Block set by'
                   3934:     );
                   3935:     my $output;
1.476     raeburn  3936:     $output = '<br />'.$lt{'cacb'}.':<br />';
1.474     raeburn  3937:     $output .= &start_data_table();
                   3938:     $output .= '
                   3939: <tr>
                   3940:  <th>'.$lt{'cour'}.'</th>
                   3941:  <th>'.$lt{'dura'}.'</th>
                   3942:  <th>'.$lt{'blse'}.'</th>
                   3943: </tr>
                   3944: ';
                   3945:     foreach my $course (keys(%{$setters})) {
                   3946:         my %courseinfo=&Apache::lonnet::coursedescription($course);
                   3947:         for (my $i=0; $i<@{$$setters{$course}{staff}}; $i++) {
                   3948:             my ($uname,$udom) = @{$$setters{$course}{staff}[$i]};
1.490     raeburn  3949:             my $fullname = &plainname($uname,$udom);
                   3950:             if (defined($env{'user.name'}) && defined($env{'user.domain'})
                   3951:                 && $env{'user.name'} ne 'public' 
                   3952:                 && $env{'user.domain'} ne 'public') {
                   3953:                 $fullname = &aboutmewrapper($fullname,$uname,$udom);
                   3954:             }
1.474     raeburn  3955:             my ($openblock,$closeblock) = @{$$setters{$course}{times}[$i]};
                   3956:             $openblock = &Apache::lonlocal::locallocaltime($openblock);
                   3957:             $closeblock= &Apache::lonlocal::locallocaltime($closeblock);
                   3958:             $output .= &Apache::loncommon::start_data_table_row().
                   3959:                        '<td>'.$courseinfo{'description'}.'</td>'.
                   3960:                        '<td>'.$openblock.' to '.$closeblock.'</td>'.
1.490     raeburn  3961:                        '<td>'.$fullname.'</td>'.
1.474     raeburn  3962:                         &Apache::loncommon::end_data_table_row();
                   3963:         }
                   3964:     }
                   3965:     $output .= &end_data_table();
                   3966: }
                   3967: 
1.490     raeburn  3968: sub blocking_status {
                   3969:     my ($activity,$uname,$udom) = @_;
                   3970:     my %setters;
                   3971:     my ($blocked,$output,$ownitem,$is_course);
                   3972:     my ($startblock,$endblock)=&blockcheck(\%setters,$activity,$uname,$udom);
                   3973:     if ($startblock && $endblock) {
                   3974:         $blocked = 1;
                   3975:         if (wantarray) {
                   3976:             my $category;
                   3977:             if ($activity eq 'boards') {
                   3978:                 $category = 'Discussion posts in this course';
                   3979:             } elsif ($activity eq 'blogs') {
                   3980:                 $category = 'Blogs';
                   3981:             } elsif ($activity eq 'port') {
                   3982:                 if (defined($uname) && defined($udom)) {
                   3983:                     if ($uname eq $env{'user.name'} &&
                   3984:                         $udom eq $env{'user.domain'}) {
                   3985:                         $ownitem = 1;
                   3986:                     }
                   3987:                 }
                   3988:                 $is_course = &Apache::lonnet::is_course($udom,$uname);
                   3989:                 if ($ownitem) { 
                   3990:                     $category = 'Your portfolio files';  
                   3991:                 } elsif ($is_course) {
                   3992:                     my $coursedesc;
                   3993:                     foreach my $course (keys(%setters)) {
                   3994:                         my %courseinfo =
                   3995:                              &Apache::lonnet::coursedescription($course);
                   3996:                         $coursedesc = $courseinfo{'description'};
                   3997:                     }
1.692.4.2  raeburn  3998:                     $category = "Group portfolio files in the course '$coursedesc'";
1.490     raeburn  3999:                 } else {
                   4000:                     $category = 'Portfolio files belonging to ';
                   4001:                     if ($env{'user.name'} eq 'public' && 
                   4002:                         $env{'user.domain'} eq 'public') {
                   4003:                         $category .= &plainname($uname,$udom);
                   4004:                     } else {
                   4005:                         $category .= &aboutmewrapper(&plainname($uname,$udom),$uname,$udom);  
                   4006:                     }
                   4007:                 }
                   4008:             } elsif ($activity eq 'groups') {
                   4009:                 $category = 'Groups in this course';
                   4010:             }
                   4011:             my $showstart = &Apache::lonlocal::locallocaltime($startblock);
                   4012:             my $showend = &Apache::lonlocal::locallocaltime($endblock);
                   4013:             $output = '<br />'.&mt('[_1] will be inaccessible between [_2] and [_3] because communication is being blocked.',$category,$showstart,$showend).'<br />';
                   4014:             if (!($activity eq 'port' && !($ownitem) && !($is_course))) { 
                   4015:                 $output .= &build_block_table($startblock,$endblock,\%setters);
                   4016:             }
                   4017:         }
                   4018:     }
                   4019:     if (wantarray) {
                   4020:         return ($blocked,$output);
                   4021:     } else {
                   4022:         return $blocked;
                   4023:     }
                   4024: }
                   4025: 
1.60      matthew  4026: ###############################################
                   4027: 
1.682     raeburn  4028: sub check_ip_acc {
                   4029:     my ($acc)=@_;
                   4030:     &Apache::lonxml::debug("acc is $acc");
                   4031:     if (!defined($acc) || $acc =~ /^\s*$/ || $acc =~/^\s*no\s*$/i) {
                   4032:         return 1;
                   4033:     }
                   4034:     my $allowed=0;
                   4035:     my $ip=$env{'request.host'} || $ENV{'REMOTE_ADDR'};
                   4036: 
                   4037:     my $name;
                   4038:     foreach my $pattern (split(',',$acc)) {
                   4039:         $pattern =~ s/^\s*//;
                   4040:         $pattern =~ s/\s*$//;
                   4041:         if ($pattern =~ /\*$/) {
                   4042:             #35.8.*
                   4043:             $pattern=~s/\*//;
                   4044:             if ($ip =~ /^\Q$pattern\E/) { $allowed=1; }
                   4045:         } elsif ($pattern =~ /(\d+\.\d+\.\d+)\.\[(\d+)-(\d+)\]$/) {
                   4046:             #35.8.3.[34-56]
                   4047:             my $low=$2;
                   4048:             my $high=$3;
                   4049:             $pattern=$1;
                   4050:             if ($ip =~ /^\Q$pattern\E/) {
                   4051:                 my $last=(split(/\./,$ip))[3];
                   4052:                 if ($last <=$high && $last >=$low) { $allowed=1; }
                   4053:             }
                   4054:         } elsif ($pattern =~ /^\*/) {
                   4055:             #*.msu.edu
                   4056:             $pattern=~s/\*//;
                   4057:             if (!defined($name)) {
                   4058:                 use Socket;
                   4059:                 my $netaddr=inet_aton($ip);
                   4060:                 ($name)=gethostbyaddr($netaddr,AF_INET);
                   4061:             }
                   4062:             if ($name =~ /\Q$pattern\E$/i) { $allowed=1; }
                   4063:         } elsif ($pattern =~ /\d+\.\d+\.\d+\.\d+/) {
                   4064:             #127.0.0.1
                   4065:             if ($ip =~ /^\Q$pattern\E/) { $allowed=1; }
                   4066:         } else {
                   4067:             #some.name.com
                   4068:             if (!defined($name)) {
                   4069:                 use Socket;
                   4070:                 my $netaddr=inet_aton($ip);
                   4071:                 ($name)=gethostbyaddr($netaddr,AF_INET);
                   4072:             }
                   4073:             if ($name =~ /\Q$pattern\E$/i) { $allowed=1; }
                   4074:         }
                   4075:         if ($allowed) { last; }
                   4076:     }
                   4077:     return $allowed;
                   4078: }
                   4079: 
                   4080: ###############################################
                   4081: 
1.60      matthew  4082: =pod
                   4083: 
1.112     bowersj2 4084: =head1 Domain Template Functions
                   4085: 
                   4086: =over 4
                   4087: 
                   4088: =item * &determinedomain()
1.60      matthew  4089: 
                   4090: Inputs: $domain (usually will be undef)
                   4091: 
1.63      www      4092: Returns: Determines which domain should be used for designs
1.60      matthew  4093: 
                   4094: =cut
1.54      www      4095: 
1.60      matthew  4096: ###############################################
1.63      www      4097: sub determinedomain {
                   4098:     my $domain=shift;
1.531     albertel 4099:     if (! $domain) {
1.60      matthew  4100:         # Determine domain if we have not been given one
1.692.4.18  raeburn  4101:         $domain = &Apache::lonnet::default_login_domain();
1.258     albertel 4102:         if ($env{'user.domain'}) { $domain=$env{'user.domain'}; }
                   4103:         if ($env{'request.role.domain'}) { 
                   4104:             $domain=$env{'request.role.domain'}; 
1.60      matthew  4105:         }
                   4106:     }
1.63      www      4107:     return $domain;
                   4108: }
                   4109: ###############################################
1.517     raeburn  4110: 
1.518     albertel 4111: sub devalidate_domconfig_cache {
                   4112:     my ($udom)=@_;
                   4113:     &Apache::lonnet::devalidate_cache_new('domainconfig',$udom);
                   4114: }
                   4115: 
                   4116: # ---------------------- Get domain configuration for a domain
                   4117: sub get_domainconf {
                   4118:     my ($udom) = @_;
                   4119:     my $cachetime=1800;
                   4120:     my ($result,$cached)=&Apache::lonnet::is_cached_new('domainconfig',$udom);
                   4121:     if (defined($cached)) { return %{$result}; }
                   4122: 
                   4123:     my %domconfig = &Apache::lonnet::get_dom('configuration',
                   4124: 					     ['login','rolecolors'],$udom);
1.632     raeburn  4125:     my (%designhash,%legacy);
1.518     albertel 4126:     if (keys(%domconfig) > 0) {
                   4127:         if (ref($domconfig{'login'}) eq 'HASH') {
1.632     raeburn  4128:             if (keys(%{$domconfig{'login'}})) {
                   4129:                 foreach my $key (keys(%{$domconfig{'login'}})) {
1.692.4.2  raeburn  4130:                     if (ref($domconfig{'login'}{$key}) eq 'HASH') {
                   4131:                         foreach my $img (keys(%{$domconfig{'login'}{$key}})) {
                   4132:                             $designhash{$udom.'.login.'.$key.'_'.$img} =
                   4133:                                 $domconfig{'login'}{$key}{$img};
                   4134:                         }
                   4135:                     } else {
                   4136:                         $designhash{$udom.'.login.'.$key}=$domconfig{'login'}{$key};
                   4137:                     }
1.632     raeburn  4138:                 }
                   4139:             } else {
                   4140:                 $legacy{'login'} = 1;
1.518     albertel 4141:             }
1.632     raeburn  4142:         } else {
                   4143:             $legacy{'login'} = 1;
1.518     albertel 4144:         }
                   4145:         if (ref($domconfig{'rolecolors'}) eq 'HASH') {
1.632     raeburn  4146:             if (keys(%{$domconfig{'rolecolors'}})) {
                   4147:                 foreach my $role (keys(%{$domconfig{'rolecolors'}})) {
                   4148:                     if (ref($domconfig{'rolecolors'}{$role}) eq 'HASH') {
                   4149:                         foreach my $item (keys(%{$domconfig{'rolecolors'}{$role}})) {
                   4150:                             $designhash{$udom.'.'.$role.'.'.$item}=$domconfig{'rolecolors'}{$role}{$item};
                   4151:                         }
1.518     albertel 4152:                     }
                   4153:                 }
1.632     raeburn  4154:             } else {
                   4155:                 $legacy{'rolecolors'} = 1;
1.518     albertel 4156:             }
1.632     raeburn  4157:         } else {
                   4158:             $legacy{'rolecolors'} = 1;
1.518     albertel 4159:         }
1.632     raeburn  4160:         if (keys(%legacy) > 0) {
                   4161:             my %legacyhash = &get_legacy_domconf($udom);
                   4162:             foreach my $item (keys(%legacyhash)) {
                   4163:                 if ($item =~ /^\Q$udom\E\.login/) {
                   4164:                     if ($legacy{'login'}) { 
                   4165:                         $designhash{$item} = $legacyhash{$item};
                   4166:                     }
                   4167:                 } else {
                   4168:                     if ($legacy{'rolecolors'}) {
                   4169:                         $designhash{$item} = $legacyhash{$item};
                   4170:                     }
1.518     albertel 4171:                 }
                   4172:             }
                   4173:         }
1.632     raeburn  4174:     } else {
                   4175:         %designhash = &get_legacy_domconf($udom); 
1.518     albertel 4176:     }
                   4177:     &Apache::lonnet::do_cache_new('domainconfig',$udom,\%designhash,
                   4178: 				  $cachetime);
                   4179:     return %designhash;
                   4180: }
                   4181: 
1.632     raeburn  4182: sub get_legacy_domconf {
                   4183:     my ($udom) = @_;
                   4184:     my %legacyhash;
                   4185:     my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';
                   4186:     my $designfile =  $designdir.'/'.$udom.'.tab';
                   4187:     if (-e $designfile) {
                   4188:         if ( open (my $fh,"<$designfile") ) {
                   4189:             while (my $line = <$fh>) {
                   4190:                 next if ($line =~ /^\#/);
                   4191:                 chomp($line);
                   4192:                 my ($key,$val)=(split(/\=/,$line));
                   4193:                 if ($val) { $legacyhash{$udom.'.'.$key}=$val; }
                   4194:             }
                   4195:             close($fh);
                   4196:         }
                   4197:     }
                   4198:     if (-e '/home/httpd/html/adm/lonDomLogos/'.$udom.'.gif') {
                   4199:         $legacyhash{$udom.'.login.domlogo'} = "/adm/lonDomLogos/$udom.gif";
                   4200:     }
                   4201:     return %legacyhash;
                   4202: }
                   4203: 
1.63      www      4204: =pod
                   4205: 
1.112     bowersj2 4206: =item * &domainlogo()
1.63      www      4207: 
                   4208: Inputs: $domain (usually will be undef)
                   4209: 
                   4210: Returns: A link to a domain logo, if the domain logo exists.
                   4211: If the domain logo does not exist, a description of the domain.
                   4212: 
                   4213: =cut
1.112     bowersj2 4214: 
1.63      www      4215: ###############################################
                   4216: sub domainlogo {
1.517     raeburn  4217:     my $domain = &determinedomain(shift);
1.518     albertel 4218:     my %designhash = &get_domainconf($domain);    
1.517     raeburn  4219:     # See if there is a logo
                   4220:     if ($designhash{$domain.'.login.domlogo'} ne '') {
1.519     raeburn  4221:         my $imgsrc = $designhash{$domain.'.login.domlogo'};
1.538     albertel 4222:         if ($imgsrc =~ m{^/(adm|res)/}) {
                   4223: 	    if ($imgsrc =~ m{^/res/}) {
                   4224: 		my $local_name = &Apache::lonnet::filelocation('',$imgsrc);
                   4225: 		&Apache::lonnet::repcopy($local_name);
                   4226: 	    }
                   4227: 	   $imgsrc = &lonhttpdurl($imgsrc);
1.519     raeburn  4228:         } 
                   4229:         return '<img src="'.$imgsrc.'" alt="'.$domain.'" />';
1.514     albertel 4230:     } elsif (defined(&Apache::lonnet::domain($domain,'description'))) {
                   4231:         return &Apache::lonnet::domain($domain,'description');
1.59      www      4232:     } else {
1.60      matthew  4233:         return '';
1.59      www      4234:     }
                   4235: }
1.63      www      4236: ##############################################
                   4237: 
                   4238: =pod
                   4239: 
1.112     bowersj2 4240: =item * &designparm()
1.63      www      4241: 
                   4242: Inputs: $which parameter; $domain (usually will be undef)
                   4243: 
                   4244: Returns: value of designparamter $which
                   4245: 
                   4246: =cut
1.112     bowersj2 4247: 
1.397     albertel 4248: 
1.400     albertel 4249: ##############################################
1.397     albertel 4250: sub designparm {
                   4251:     my ($which,$domain)=@_;
1.258     albertel 4252:     if ($env{'browser.blackwhite'} eq 'on') {
1.635     raeburn  4253: 	if ($which=~/\.(font|alink|vlink|link|textcol)$/) {
1.110     www      4254: 	    return '#000000';
                   4255: 	}
1.635     raeburn  4256: 	if ($which=~/\.(pgbg|sidebg|bgcol)$/) {
1.110     www      4257: 	    return '#FFFFFF';
                   4258: 	}
                   4259: 	if ($which=~/\.tabbg$/) {
                   4260: 	    return '#CCCCCC';
                   4261: 	}
                   4262:     }
1.397     albertel 4263:     if (exists($env{'environment.color.'.$which})) {
1.258     albertel 4264: 	return $env{'environment.color.'.$which};
1.96      www      4265:     }
1.63      www      4266:     $domain=&determinedomain($domain);
1.518     albertel 4267:     my %domdesign = &get_domainconf($domain);
1.520     raeburn  4268:     my $output;
1.517     raeburn  4269:     if ($domdesign{$domain.'.'.$which} ne '') {
1.520     raeburn  4270: 	$output = $domdesign{$domain.'.'.$which};
1.63      www      4271:     } else {
1.520     raeburn  4272:         $output = $defaultdesign{$which};
                   4273:     }
                   4274:     if (($which =~ /^(student|coordinator|author|admin)\.img$/) ||
1.635     raeburn  4275:         ($which =~ /login\.(img|logo|domlogo|login)/)) {
1.538     albertel 4276:         if ($output =~ m{^/(adm|res)/}) {
                   4277: 	    if ($output =~ m{^/res/}) {
                   4278: 		my $local_name = &Apache::lonnet::filelocation('',$output);
                   4279: 		&Apache::lonnet::repcopy($local_name);
                   4280: 	    }
1.520     raeburn  4281:             $output = &lonhttpdurl($output);
                   4282:         }
1.63      www      4283:     }
1.520     raeburn  4284:     return $output;
1.63      www      4285: }
1.59      www      4286: 
1.60      matthew  4287: ###############################################
                   4288: ###############################################
                   4289: 
                   4290: =pod
                   4291: 
1.112     bowersj2 4292: =back
                   4293: 
1.549     albertel 4294: =head1 HTML Helpers
1.112     bowersj2 4295: 
                   4296: =over 4
                   4297: 
                   4298: =item * &bodytag()
1.60      matthew  4299: 
                   4300: Returns a uniform header for LON-CAPA web pages.
                   4301: 
                   4302: Inputs: 
                   4303: 
1.112     bowersj2 4304: =over 4
                   4305: 
                   4306: =item * $title, A title to be displayed on the page.
                   4307: 
                   4308: =item * $function, the current role (can be undef).
                   4309: 
                   4310: =item * $addentries, extra parameters for the <body> tag.
                   4311: 
                   4312: =item * $bodyonly, if defined, only return the <body> tag.
                   4313: 
                   4314: =item * $domain, if defined, force a given domain.
                   4315: 
                   4316: =item * $forcereg, if page should register as content page (relevant for 
1.86      www      4317:             text interface only)
1.60      matthew  4318: 
1.326     albertel 4319: =item * $customtitle, alternate text to use instead of $title
                   4320:                       in the title box that appears, this text
                   4321:                       is not auto translated like the $title is
1.309     albertel 4322: 
                   4323: =item * $notopbar, if true, keep the 'what is this' info but remove the
                   4324:                    navigational links
1.317     albertel 4325: 
1.338     albertel 4326: =item * $bgcolor, used to override the bgcolor on a webpage to a specific value
                   4327: 
                   4328: =item * $notitle, if true keep the nav controls, but remove the title bar
                   4329: 
1.361     albertel 4330: =item * $no_inline_link, if true and in remote mode, don't show the 
                   4331:          'Switch To Inline Menu' link
                   4332: 
1.460     albertel 4333: =item * $args, optional argument valid values are
                   4334:             no_auto_mt_title -> prevents &mt()ing the title arg
1.562     albertel 4335:             inherit_jsmath -> when creating popup window in a page,
                   4336:                               should it have jsmath forced on by the
                   4337:                               current page
1.460     albertel 4338: 
1.112     bowersj2 4339: =back
                   4340: 
1.60      matthew  4341: Returns: A uniform header for LON-CAPA web pages.  
                   4342: If $bodyonly is nonzero, a string containing a <body> tag will be returned.
                   4343: If $bodyonly is undef or zero, an html string containing a <body> tag and 
                   4344: other decorations will be returned.
                   4345: 
                   4346: =cut
                   4347: 
1.54      www      4348: sub bodytag {
1.309     albertel 4349:     my ($title,$function,$addentries,$bodyonly,$domain,$forcereg,$customtitle,
1.460     albertel 4350: 	$notopbar,$bgcolor,$notitle,$no_inline_link,$args)=@_;
1.339     albertel 4351: 
1.460     albertel 4352:     if (!$args->{'no_auto_mt_title'}) { $title = &mt($title); }
1.339     albertel 4353: 
1.183     matthew  4354:     $function = &get_users_function() if (!$function);
1.339     albertel 4355:     my $img =    &designparm($function.'.img',$domain);
                   4356:     my $font =   &designparm($function.'.font',$domain);
                   4357:     my $pgbg   = $bgcolor || &designparm($function.'.pgbg',$domain);
                   4358: 
1.692.4.2  raeburn  4359:     my %design = ( 'style'   => 'margin-top: 0',
1.535     albertel 4360: 		   'bgcolor' => $pgbg,
1.339     albertel 4361: 		   'text'    => $font,
                   4362:                    'alink'   => &designparm($function.'.alink',$domain),
                   4363: 		   'vlink'   => &designparm($function.'.vlink',$domain),
                   4364: 		   'link'    => &designparm($function.'.link',$domain),);
1.438     albertel 4365:     @design{keys(%$addentries)} = @$addentries{keys(%$addentries)}; 
1.339     albertel 4366: 
1.63      www      4367:  # role and realm
1.378     raeburn  4368:     my ($role,$realm) = split(/\./,$env{'request.role'},2);
                   4369:     if ($role  eq 'ca') {
1.479     albertel 4370:         my ($rdom,$rname) = ($realm =~ m{^/($match_domain)/($match_username)$});
1.500     albertel 4371:         $realm = &plainname($rname,$rdom);
1.378     raeburn  4372:     } 
1.55      www      4373: # realm
1.258     albertel 4374:     if ($env{'request.course.id'}) {
1.378     raeburn  4375:         if ($env{'request.role'} !~ /^cr/) {
                   4376:             $role = &Apache::lonnet::plaintext($role,&course_type());
                   4377:         }
1.359     albertel 4378: 	$realm = $env{'course.'.$env{'request.course.id'}.'.description'};
1.378     raeburn  4379:     } else {
                   4380:         $role = &Apache::lonnet::plaintext($role);
1.54      www      4381:     }
1.433     albertel 4382: 
1.359     albertel 4383:     if (!$realm) { $realm='&nbsp;'; }
1.55      www      4384: # Set messages
1.60      matthew  4385:     my $messages=&domainlogo($domain);
1.330     albertel 4386: 
1.438     albertel 4387:     my $extra_body_attr = &make_attr_string($forcereg,\%design);
1.329     albertel 4388: 
1.101     www      4389: # construct main body tag
1.359     albertel 4390:     my $bodytag = "<body $extra_body_attr>".
1.562     albertel 4391: 	&Apache::lontexconvert::init_math_support($args->{'inherit_jsmath'});
1.252     albertel 4392: 
1.530     albertel 4393:     if ($bodyonly) {
1.60      matthew  4394:         return $bodytag;
1.258     albertel 4395:     } elsif ($env{'browser.interface'} eq 'textual') {
1.95      www      4396: # Accessibility
1.224     raeburn  4397:           
1.337     albertel 4398: 	$bodytag.=&Apache::lonmenu::menubuttons($forcereg,$forcereg);
1.338     albertel 4399: 	if (!$notitle) {
1.337     albertel 4400: 	    $bodytag.='<h1>LON-CAPA: '.$title.'</h1>';
                   4401: 	}
                   4402: 	return $bodytag;
1.359     albertel 4403:     }
                   4404: 
1.410     albertel 4405:     my $name = &plainname($env{'user.name'},$env{'user.domain'});
1.433     albertel 4406:     if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
                   4407: 	undef($role);
1.434     albertel 4408:     } else {
                   4409: 	$name = &aboutmewrapper($name,$env{'user.name'},$env{'user.domain'});
1.433     albertel 4410:     }
1.359     albertel 4411:     
                   4412:     my $roleinfo=(<<ENDROLE);
                   4413: <td class="LC_title_bar_who">
                   4414: <div class="LC_title_bar_name">
1.410     albertel 4415:     $name
1.361     albertel 4416:     &nbsp;
1.359     albertel 4417: </div>
                   4418: <div class="LC_title_bar_role">
1.361     albertel 4419: $role&nbsp;
1.359     albertel 4420: </div>
                   4421: <div class="LC_title_bar_realm">
1.361     albertel 4422: $realm&nbsp;
1.359     albertel 4423: </div>
1.206     albertel 4424: </td>
                   4425: ENDROLE
1.235     raeburn  4426: 
1.359     albertel 4427:     my $titleinfo = '<span class="LC_title_bar_title">'.$title.'</span>';
                   4428:     if ($customtitle) {
                   4429:         $titleinfo = $customtitle;
                   4430:     }
                   4431:     #
                   4432:     # Extra info if you are the DC
                   4433:     my $dc_info = '';
                   4434:     if ($env{'user.adv'} && exists($env{'user.role.dc./'.
                   4435:                         $env{'course.'.$env{'request.course.id'}.
                   4436:                                  '.domain'}.'/'})) {
                   4437:         my $cid = $env{'request.course.id'};
                   4438:         $dc_info.= $cid.' '.$env{'course.'.$cid.'.internal.coursecode'};
1.380     www      4439:         $dc_info =~ s/\s+$//;
1.359     albertel 4440:         $dc_info = '('.$dc_info.')';
                   4441:     }
                   4442: 
1.644     www      4443:     if (($env{'environment.remote'} eq 'off') || ($args->{'suppress_header_logos'})) {
1.359     albertel 4444:         # No Remote
1.258     albertel 4445: 	if ($env{'request.state'} eq 'construct') {
1.359     albertel 4446: 	    $forcereg=1;
                   4447: 	}
                   4448: 
                   4449: 	if (!$customtitle && $env{'request.state'} eq 'construct') {
                   4450: 	    # this is for resources; directories have customtitle, and crumbs
                   4451:             # and select recent are created in lonpubdir.pm  
1.229     albertel 4452: 	    my ($uname,$thisdisfn)=
1.258     albertel 4453: 		($env{'request.filename'} =~ m|^/home/([^/]+)/public_html/(.*)|);
1.229     albertel 4454: 	    my $formaction='/priv/'.$uname.'/'.$thisdisfn;
                   4455: 	    $formaction=~s/\/+/\//g;
                   4456: 
1.359     albertel 4457: 	    my $parentpath = '';
                   4458: 	    my $lastitem = '';
                   4459: 	    if ($thisdisfn =~ m-(.+/)([^/]*)$-) {
                   4460: 		$parentpath = $1;
                   4461: 		$lastitem = $2;
                   4462: 	    } else {
                   4463: 		$lastitem = $thisdisfn;
                   4464: 	    }
                   4465: 	    $titleinfo = 
1.640     bisitz   4466: 		&Apache::loncommon::help_open_menu('','',3,'Authoring')
                   4467: 		.'<b>'.&mt('Construction Space').'</b>:&nbsp;'
                   4468: 		.'<form name="dirs" method="post" action="'.$formaction
1.359     albertel 4469: 		.'" target="_top"><tt><b>'
                   4470: 		.&Apache::lonhtmlcommon::crumbs($uname.'/'.$parentpath,'_top','/priv','','+1',1)."<font size=\"+1\">$lastitem</font></b></tt><br />"
                   4471: 		.&Apache::lonhtmlcommon::select_recent('construct','recent','this.form.action=this.form.recent.value;this.form.submit()')
                   4472: 		.'</form>'
                   4473: 		.&Apache::lonmenu::constspaceform();
1.235     raeburn  4474:         }
1.359     albertel 4475: 
1.337     albertel 4476:         my $titletable;
1.338     albertel 4477: 	if (!$notitle) {
1.337     albertel 4478: 	    $titletable =
1.359     albertel 4479: 		'<table id="LC_title_bar">'.
                   4480:                          "<tr><td> $titleinfo $dc_info</td>".$roleinfo.
                   4481: 			 '</tr></table>';
1.337     albertel 4482: 	}
1.359     albertel 4483: 	if ($notopbar) {
                   4484: 	    $bodytag .= $titletable;
                   4485: 	} else {
                   4486: 	    if ($env{'request.state'} eq 'construct') {
1.337     albertel 4487:                 $bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg,
                   4488: 							  $titletable);
1.272     raeburn  4489:             } else {
1.336     albertel 4490:                 $bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg).
1.359     albertel 4491: 		    $titletable;
1.272     raeburn  4492:             }
1.235     raeburn  4493:         }
                   4494:         return $bodytag;
1.94      www      4495:     }
1.95      www      4496: 
1.93      www      4497: #
1.95      www      4498: # Top frame rendering, Remote is up
1.93      www      4499: #
1.359     albertel 4500: 
1.517     raeburn  4501:     my $imgsrc = $img;
                   4502:     if ($img =~ /^\/adm/) {
1.575     albertel 4503:         $imgsrc = &lonhttpdurl($img);
1.517     raeburn  4504:     }
                   4505:     my $upperleft='<img src="'.$imgsrc.'" alt="'.$function.'" />';
1.359     albertel 4506: 
1.305     www      4507:     # Explicit link to get inline menu
1.361     albertel 4508:     my $menu= ($no_inline_link?''
                   4509: 	       :'<br /><a href="/adm/remote?action=collapse">'.&mt('Switch to Inline Menu Mode').'</a>');
1.245     matthew  4510:     #
1.338     albertel 4511:     if ($notitle) {
1.337     albertel 4512: 	return $bodytag;
                   4513:     }
1.94      www      4514:     return(<<ENDBODY);
1.60      matthew  4515: $bodytag
1.359     albertel 4516: <table id="LC_title_bar" class="LC_with_remote">
1.368     albertel 4517: <tr><td class="LC_title_bar_role_logo">$upperleft</td>
1.359     albertel 4518:     <td class="LC_title_bar_domain_logo">$messages&nbsp;</td>
1.54      www      4519: </tr>
1.359     albertel 4520: <tr><td>$titleinfo $dc_info $menu</td>
                   4521: $roleinfo
1.368     albertel 4522: </tr>
1.356     albertel 4523: </table>
1.54      www      4524: ENDBODY
1.182     matthew  4525: }
                   4526: 
1.330     albertel 4527: sub make_attr_string {
                   4528:     my ($register,$attr_ref) = @_;
                   4529: 
                   4530:     if ($attr_ref && !ref($attr_ref)) {
                   4531: 	die("addentries Must be a hash ref ".
                   4532: 	    join(':',caller(1))." ".
                   4533: 	    join(':',caller(0))." ");
                   4534:     }
                   4535: 
                   4536:     if ($register) {
1.339     albertel 4537: 	my ($on_load,$on_unload);
                   4538: 	foreach my $key (keys(%{$attr_ref})) {
                   4539: 	    if      (lc($key) eq 'onload') {
                   4540: 		$on_load.=$attr_ref->{$key}.';';
                   4541: 		delete($attr_ref->{$key});
                   4542: 
                   4543: 	    } elsif (lc($key) eq 'onunload') {
                   4544: 		$on_unload.=$attr_ref->{$key}.';';
                   4545: 		delete($attr_ref->{$key});
                   4546: 	    }
                   4547: 	}
                   4548: 	$attr_ref->{'onload'}  =
                   4549: 	    &Apache::lonmenu::loadevents().  $on_load;
                   4550: 	$attr_ref->{'onunload'}=
                   4551: 	    &Apache::lonmenu::unloadevents().$on_unload;
                   4552:     }
                   4553: 
                   4554: # Accessibility font enhance
                   4555:     if ($env{'browser.fontenhance'} eq 'on') {
                   4556: 	my $style;
                   4557: 	foreach my $key (keys(%{$attr_ref})) {
                   4558: 	    if (lc($key) eq 'style') {
                   4559: 		$style.=$attr_ref->{$key}.';';
                   4560: 		delete($attr_ref->{$key});
                   4561: 	    }
                   4562: 	}
                   4563: 	$attr_ref->{'style'}=$style.'; font-size: x-large;';
1.330     albertel 4564:     }
1.339     albertel 4565: 
                   4566:     if ($env{'browser.blackwhite'} eq 'on') {
                   4567: 	delete($attr_ref->{'font'});
                   4568: 	delete($attr_ref->{'link'});
                   4569: 	delete($attr_ref->{'alink'});
                   4570: 	delete($attr_ref->{'vlink'});
                   4571: 	delete($attr_ref->{'bgcolor'});
                   4572: 	delete($attr_ref->{'background'});
                   4573:     }
                   4574: 
1.330     albertel 4575:     my $attr_string;
                   4576:     foreach my $attr (keys(%$attr_ref)) {
                   4577: 	$attr_string .= " $attr=\"".$attr_ref->{$attr}.'" ';
                   4578:     }
                   4579:     return $attr_string;
                   4580: }
                   4581: 
                   4582: 
1.182     matthew  4583: ###############################################
1.251     albertel 4584: ###############################################
                   4585: 
                   4586: =pod
                   4587: 
                   4588: =item * &endbodytag()
                   4589: 
                   4590: Returns a uniform footer for LON-CAPA web pages.
                   4591: 
1.635     raeburn  4592: Inputs: 1 - optional reference to an args hash
                   4593: If in the hash, key for noredirectlink has a value which evaluates to true,
                   4594: a 'Continue' link is not displayed if the page contains an
                   4595: internal redirect in the <head></head> section,
                   4596: i.e., $env{'internal.head.redirect'} exists   
1.251     albertel 4597: 
                   4598: =cut
                   4599: 
                   4600: sub endbodytag {
1.635     raeburn  4601:     my ($args) = @_;
1.251     albertel 4602:     my $endbodytag='</body>';
1.269     albertel 4603:     $endbodytag=&Apache::lontexconvert::jsMath_process()."\n".$endbodytag;
1.315     albertel 4604:     if ( exists( $env{'internal.head.redirect'} ) ) {
1.635     raeburn  4605:         if (!(ref($args) eq 'HASH' && $args->{'noredirectlink'})) {
                   4606: 	    $endbodytag=
                   4607: 	        "<br /><a href=\"$env{'internal.head.redirect'}\">".
                   4608: 	        &mt('Continue').'</a>'.
                   4609: 	        $endbodytag;
                   4610:         }
1.315     albertel 4611:     }
1.251     albertel 4612:     return $endbodytag;
                   4613: }
                   4614: 
1.352     albertel 4615: =pod
                   4616: 
                   4617: =item * &standard_css()
                   4618: 
                   4619: Returns a style sheet
                   4620: 
                   4621: Inputs: (all optional)
                   4622:             domain         -> force to color decorate a page for a specific
                   4623:                                domain
                   4624:             function       -> force usage of a specific rolish color scheme
                   4625:             bgcolor        -> override the default page bgcolor
                   4626: 
                   4627: =cut
                   4628: 
1.343     albertel 4629: sub standard_css {
1.345     albertel 4630:     my ($function,$domain,$bgcolor) = @_;
1.352     albertel 4631:     $function  = &get_users_function() if (!$function);
                   4632:     my $img    = &designparm($function.'.img',   $domain);
                   4633:     my $tabbg  = &designparm($function.'.tabbg', $domain);
                   4634:     my $font   = &designparm($function.'.font',  $domain);
1.345     albertel 4635:     my $sidebg = &designparm($function.'.sidebg',$domain);
1.382     albertel 4636:     my $pgbg_or_bgcolor =
                   4637: 	         $bgcolor ||
1.352     albertel 4638: 	         &designparm($function.'.pgbg',  $domain);
1.382     albertel 4639:     my $pgbg   = &designparm($function.'.pgbg',  $domain);
1.352     albertel 4640:     my $alink  = &designparm($function.'.alink', $domain);
                   4641:     my $vlink  = &designparm($function.'.vlink', $domain);
                   4642:     my $link   = &designparm($function.'.link',  $domain);
                   4643: 
1.602     albertel 4644:     my $sans                 = 'Verdana,Arial,Helvetica,sans-serif';
1.395     albertel 4645:     my $mono                 = 'monospace';
1.692.4.13  raeburn  4646:     my $data_table_head      = $tabbg;
1.692.4.6  raeburn  4647:     my $data_table_light     = '#FAFAFA';
                   4648:     my $data_table_dark      = '#F0F0F0';
1.470     banghart 4649:     my $data_table_darker    = '#CCCCCC';
1.349     albertel 4650:     my $data_table_highlight = '#FFFF00';
1.352     albertel 4651:     my $mail_new             = '#FFBB77';
                   4652:     my $mail_new_hover       = '#DD9955';
                   4653:     my $mail_read            = '#BBBB77';
                   4654:     my $mail_read_hover      = '#999944';
                   4655:     my $mail_replied         = '#AAAA88';
                   4656:     my $mail_replied_hover   = '#888855';
                   4657:     my $mail_other           = '#99BBBB';
                   4658:     my $mail_other_hover     = '#669999';
1.391     albertel 4659:     my $table_header         = '#DDDDDD';
1.489     raeburn  4660:     my $feedback_link_bg     = '#BBBBBB';
1.692.4.3  raeburn  4661:     my $lg_border_color      = '#C8C8C8';
1.392     albertel 4662: 
1.608     albertel 4663:     my $border = ($env{'browser.type'} eq 'explorer' ||
1.692.4.2  raeburn  4664: 		  $env{'browser.type'} eq 'safari'     ) ? '0 2px 0 2px'
                   4665: 	                                                 : '0 3px 0 4px';
1.448     albertel 4666: 
1.523     albertel 4667: 
1.343     albertel 4668:     return <<END;
1.345     albertel 4669: h1, h2, h3, th { font-family: $sans }
1.343     albertel 4670: a:focus { color: red; background: yellow } 
1.692.4.6  raeburn  4671: 
                   4672: hr {
                   4673:   clear: both;
                   4674:   color: $tabbg;
                   4675:   background-color: $tabbg;
                   4676:   height: 3px;
                   4677:   border: none;
                   4678: }
                   4679: 
1.510     albertel 4680: table.thinborder,
1.523     albertel 4681: 
1.510     albertel 4682: table.thinborder tr th {
                   4683:   border-style: solid;
                   4684:   border-width: 1px;
                   4685:   background: $tabbg;
                   4686: }
1.523     albertel 4687: table.thinborder tr td {
1.510     albertel 4688:   border-style: solid;
                   4689:   border-width: 1px
                   4690: }
1.426     albertel 4691: 
1.343     albertel 4692: form, .inline { display: inline; }
                   4693: .center { text-align: center; }
1.593     albertel 4694: .LC_filename {font-family: $mono; white-space:pre;}
1.350     albertel 4695: .LC_error {
                   4696:   color: red;
                   4697:   font-size: larger;
                   4698: }
1.457     albertel 4699: .LC_warning,
                   4700: .LC_diff_removed {
1.394     albertel 4701:   color: red;
                   4702: }
1.532     albertel 4703: 
                   4704: .LC_info,
1.457     albertel 4705: .LC_success,
                   4706: .LC_diff_added {
1.350     albertel 4707:   color: green;
                   4708: }
1.692.4.2  raeburn  4709: 
                   4710: div.LC_confirm_box {
                   4711:   background-color: #FAFAFA;
                   4712:   border: 1px solid $lg_border_color;
                   4713:   margin-right: 0;
                   4714:   padding: 5px;
                   4715: }
                   4716: 
                   4717: div.LC_confirm_box .LC_error img,
                   4718: div.LC_confirm_box .LC_success img {
                   4719:   vertical-align: middle;
1.543     albertel 4720: }
                   4721: 
1.440     albertel 4722: .LC_icon {
1.692.4.2  raeburn  4723:   border: none;
1.440     albertel 4724: }
1.539     albertel 4725: .LC_indexer_icon {
1.692.4.2  raeburn  4726:   border: 0;
1.539     albertel 4727:   height: 22px;
                   4728: }
1.543     albertel 4729: .LC_docs_spacer {
                   4730:   width: 25px;
                   4731:   height: 1px;
1.692.4.2  raeburn  4732:   border: none;
1.543     albertel 4733: }
1.346     albertel 4734: 
1.532     albertel 4735: .LC_internal_info {
1.692.4.2  raeburn  4736:   color: #999999;
1.532     albertel 4737: }
                   4738: 
1.692.4.19  raeburn  4739: .LC_discussion {
                   4740:    background: $tabbg;
                   4741:    border: 1px solid black;
                   4742:    margin: 2px;
                   4743: }
                   4744: 
                   4745: .LC_disc_action_links_bar {
                   4746:    background: $tabbg;
                   4747:    border: none;
                   4748:    margin: 4px;
                   4749: }
                   4750: 
                   4751: .LC_disc_action_left {
                   4752:    text-align: left;
                   4753: }
                   4754: 
                   4755: .LC_disc_action_right {
                   4756:    text-align: right;
                   4757: }
                   4758: 
                   4759: .LC_disc_new_item {
                   4760:    background: white;
                   4761:    border: 2px solid red;
                   4762:    margin: 2px;
                   4763: }
                   4764: 
                   4765: .LC_disc_old_item {
                   4766:    background: white;
                   4767:    border: 1px solid black;
                   4768:    margin: 2px;
                   4769: }
                   4770: 
1.458     albertel 4771: table.LC_pastsubmission {
                   4772:   border: 1px solid black;
                   4773:   margin: 2px;
                   4774: }
                   4775: 
1.606     albertel 4776: table#LC_top_nav, table#LC_menubuttons,table#LC_nav_location {
1.345     albertel 4777:   width: 100%;
                   4778:   background: $pgbg;
1.392     albertel 4779:   border: 2px;
1.402     albertel 4780:   border-collapse: separate;
1.692.4.2  raeburn  4781:   padding: 0;
1.345     albertel 4782: }
1.392     albertel 4783: 
1.606     albertel 4784: table#LC_title_bar, table.LC_breadcrumbs, 
1.393     albertel 4785: table#LC_title_bar.LC_with_remote {
1.359     albertel 4786:   width: 100%;
1.392     albertel 4787:   border-color: $pgbg;
                   4788:   border-style: solid;
                   4789:   border-width: $border;
                   4790: 
1.379     albertel 4791:   background: $pgbg;
                   4792:   font-family: $sans;
1.392     albertel 4793:   border-collapse: collapse;
1.692.4.2  raeburn  4794:   padding: 0;
1.359     albertel 4795: }
1.392     albertel 4796: 
1.409     albertel 4797: table.LC_docs_path {
                   4798:   width: 100%;
                   4799:   border: 0;
                   4800:   background: $pgbg;
                   4801:   font-family: $sans;
                   4802:   border-collapse: collapse;
1.692.4.2  raeburn  4803:   padding: 0;
1.409     albertel 4804: }
                   4805: 
1.359     albertel 4806: table#LC_title_bar td {
                   4807:   background: $tabbg;
                   4808: }
                   4809: table#LC_title_bar td.LC_title_bar_who {
                   4810:   background: $tabbg;
                   4811:   color: $font;
1.427     albertel 4812:   font: small $sans;
1.359     albertel 4813:   text-align: right;
                   4814: }
1.469     banghart 4815: span.LC_metadata {
                   4816:     font-family: $sans;
                   4817: }
1.359     albertel 4818: span.LC_title_bar_title {
1.416     albertel 4819:   font: bold x-large $sans;
1.359     albertel 4820: }
                   4821: table#LC_title_bar td.LC_title_bar_domain_logo {
                   4822:   background: $sidebg;
                   4823:   text-align: right;
1.692.4.2  raeburn  4824:   padding: 0;
1.368     albertel 4825: }
                   4826: table#LC_title_bar td.LC_title_bar_role_logo {
                   4827:   background: $sidebg;
1.692.4.2  raeburn  4828:   padding: 0;
1.359     albertel 4829: }
                   4830: 
1.346     albertel 4831: table#LC_menubuttons_mainmenu {
1.526     www      4832:   width: 100%;
1.692.4.2  raeburn  4833:   border: 0;
1.346     albertel 4834:   border-spacing: 1px;
1.692.4.2  raeburn  4835:   padding: 0 1px;
                   4836:   margin: 0;
1.346     albertel 4837:   border-collapse: separate;
                   4838: }
                   4839: table#LC_menubuttons img, table#LC_menubuttons_mainmenu img {
1.692.4.2  raeburn  4840:   border: none;
1.346     albertel 4841: }
1.345     albertel 4842: table#LC_top_nav td {
                   4843:   background: $tabbg;
1.692.4.2  raeburn  4844:   border: none;
1.407     albertel 4845:   font-size: small;
1.345     albertel 4846: }
                   4847: table#LC_top_nav td a, div#LC_top_nav a {
                   4848:   color: $font;
                   4849:   font-family: $sans;
                   4850: }
1.364     albertel 4851: table#LC_top_nav td.LC_top_nav_logo {
                   4852:   background: $tabbg;
1.432     albertel 4853:   text-align: left;
1.408     albertel 4854:   white-space: nowrap;
1.432     albertel 4855:   width: 31px;
1.408     albertel 4856: }
                   4857: table#LC_top_nav td.LC_top_nav_logo img {
1.692.4.2  raeburn  4858:   border: none;
1.408     albertel 4859:   vertical-align: bottom;
1.364     albertel 4860: }
1.432     albertel 4861: table#LC_top_nav td.LC_top_nav_exit,
                   4862: table#LC_top_nav td.LC_top_nav_help {
                   4863:   width: 2.0em;
                   4864: }
1.442     albertel 4865: table#LC_top_nav td.LC_top_nav_login {
                   4866:   width: 4.0em;
                   4867:   text-align: center;
                   4868: }
1.409     albertel 4869: table.LC_breadcrumbs td, table.LC_docs_path td  {
1.357     albertel 4870:   background: $tabbg;
                   4871:   color: $font;
                   4872:   font-family: $sans;
1.358     albertel 4873:   font-size: smaller;
1.357     albertel 4874: }
1.411     albertel 4875: table.LC_breadcrumbs td.LC_breadcrumbs_component,
1.409     albertel 4876: table.LC_docs_path td.LC_docs_path_component {
1.357     albertel 4877:   background: $tabbg;
                   4878:   color: $font;
                   4879:   font-family: $sans;
                   4880:   font-size: larger;
                   4881:   text-align: right;
                   4882: }
1.383     albertel 4883: td.LC_table_cell_checkbox {
                   4884:   text-align: center;
                   4885: }
1.522     albertel 4886: table#LC_mainmenu td.LC_mainmenu_column {
                   4887:     vertical-align: top;
                   4888: }
                   4889: 
1.346     albertel 4890: .LC_menubuttons_inline_text {
                   4891:   color: $font;
                   4892:   font-family: $sans;
                   4893:   font-size: smaller;
                   4894: }
                   4895: 
1.526     www      4896: .LC_menubuttons_link {
                   4897:   text-decoration: none;
                   4898: }
1.692.4.2  raeburn  4899: /*2008--9-5: new menu style sheet.Changed category*/
1.522     albertel 4900: .LC_menubuttons_category {
1.521     www      4901:   color: $font;
1.526     www      4902:   background: $pgbg;
1.521     www      4903:   font-family: $sans;
                   4904:   font-size: larger;
                   4905:   font-weight: bold;
                   4906: }
                   4907: 
1.346     albertel 4908: td.LC_menubuttons_text {
1.526     www      4909:   width: 90%;
1.346     albertel 4910:   color: $font;
                   4911:   font-family: $sans;
                   4912: }
1.526     www      4913: 
1.346     albertel 4914: td.LC_menubuttons_img {
                   4915: }
1.526     www      4916: 
1.346     albertel 4917: .LC_current_location {
                   4918:   font-family: $sans;
                   4919:   background: $tabbg;
                   4920: }
                   4921: .LC_new_mail {
                   4922:   font-family: $sans;
1.634     www      4923:   background: $tabbg;
1.346     albertel 4924:   font-weight: bold;
                   4925: }
1.347     albertel 4926: 
1.527     www      4927: .LC_dropadd_labeltext {
                   4928:   font-family: $sans;
                   4929:   text-align: right;
                   4930: }
                   4931: 
                   4932: .LC_preferences_labeltext {
                   4933:   font-family: $sans;
                   4934:   text-align: right;
                   4935: }
                   4936: 
1.666     raeburn  4937: .LC_roleslog_note {
                   4938:   font-size: smaller;
                   4939: }
                   4940: 
1.692.4.2  raeburn  4941: .LC_mail_functions {
                   4942:     font-weight: bold;
                   4943: }
                   4944: 
1.440     albertel 4945: table.LC_aboutme_port {
1.692.4.2  raeburn  4946:   border: none;
1.440     albertel 4947:   border-collapse: collapse;
1.692.4.2  raeburn  4948:   border-spacing: 0;
1.440     albertel 4949: }
1.349     albertel 4950: table.LC_data_table, table.LC_mail_list {
1.347     albertel 4951:   border: 1px solid #000000;
1.402     albertel 4952:   border-collapse: separate;
1.426     albertel 4953:   border-spacing: 1px;
1.610     albertel 4954:   background: $pgbg;
1.347     albertel 4955: }
1.422     albertel 4956: .LC_data_table_dense {
                   4957:   font-size: small;
                   4958: }
1.507     raeburn  4959: table.LC_nested_outer {
                   4960:   border: 1px solid #000000;
1.589     raeburn  4961:   border-collapse: collapse;
1.692.4.2  raeburn  4962:   border-spacing: 0;
1.507     raeburn  4963:   width: 100%;
                   4964: }
1.692.4.11  raeburn  4965: table.LC_innerpickbox,
1.507     raeburn  4966: table.LC_nested {
1.692.4.2  raeburn  4967:   border: none;
1.589     raeburn  4968:   border-collapse: collapse;
1.692.4.2  raeburn  4969:   border-spacing: 0;
1.507     raeburn  4970:   width: 100%;
                   4971: }
1.523     albertel 4972: table.LC_data_table tr th, table.LC_calendar tr th, table.LC_mail_list tr th,
1.692.4.11  raeburn  4973: table.LC_prior_tries tr th,
                   4974: table.LC_innerpickbox tr th {
1.349     albertel 4975:   font-weight: bold;
                   4976:   background-color: $data_table_head;
1.421     albertel 4977:   font-size: smaller;
1.347     albertel 4978: }
1.692.4.11  raeburn  4979: table.LC_innerpickbox tr th,
                   4980: table.LC_innerpickbox tr td {
                   4981:   vertical-align: top;
                   4982: }
1.692.4.2  raeburn  4983: table.LC_data_table tr.LC_info_row > td {
                   4984:   background-color: #CCCCCC;
                   4985:   font-weight: bold;
                   4986:   text-align: left;
                   4987: }
1.610     albertel 4988: table.LC_data_table tr.LC_odd_row > td, 
1.692.4.2  raeburn  4989: table.LC_pick_box tr > td.LC_odd_row,
1.440     albertel 4990: table.LC_aboutme_port tr td {
1.349     albertel 4991:   background-color: $data_table_light;
1.425     albertel 4992:   padding: 2px;
1.347     albertel 4993: }
1.610     albertel 4994: table.LC_data_table tr.LC_even_row > td,
1.692.4.2  raeburn  4995: table.LC_pick_box tr > td.LC_even_row,
1.440     albertel 4996: table.LC_aboutme_port tr.LC_even_row td {
1.349     albertel 4997:   background-color: $data_table_dark;
1.692.4.2  raeburn  4998:   padding: 2px;
1.347     albertel 4999: }
1.425     albertel 5000: table.LC_data_table tr.LC_data_table_highlight td {
                   5001:   background-color: $data_table_darker;
                   5002: }
1.639     raeburn  5003: table.LC_data_table tr td.LC_leftcol_header {
                   5004:   background-color: $data_table_head;
                   5005:   font-weight: bold;
                   5006: }
1.451     albertel 5007: table.LC_data_table tr.LC_empty_row td,
1.507     raeburn  5008: table.LC_nested tr.LC_empty_row td {
1.347     albertel 5009:   background-color: #FFFFFF;
1.421     albertel 5010:   font-weight: bold;
                   5011:   font-style: italic;
                   5012:   text-align: center;
                   5013:   padding: 8px;
1.347     albertel 5014: }
1.507     raeburn  5015: table.LC_nested tr.LC_empty_row td {
1.465     albertel 5016:   padding: 4ex
                   5017: }
1.507     raeburn  5018: table.LC_nested_outer tr th {
                   5019:   font-weight: bold;
                   5020:   background-color: $data_table_head;
                   5021:   font-size: smaller;
                   5022:   border-bottom: 1px solid #000000;
                   5023: }
                   5024: table.LC_nested_outer tr td.LC_subheader {
                   5025:   background-color: $data_table_head;
                   5026:   font-weight: bold;
                   5027:   font-size: small;
                   5028:   border-bottom: 1px solid #000000;
                   5029:   text-align: right;
1.451     albertel 5030: }
1.507     raeburn  5031: table.LC_nested tr.LC_info_row td {
1.692.4.2  raeburn  5032:   background-color: #CCCCCC;
1.451     albertel 5033:   font-weight: bold;
                   5034:   font-size: small;
1.507     raeburn  5035:   text-align: center;
                   5036: }
1.589     raeburn  5037: table.LC_nested tr.LC_info_row td.LC_left_item,
                   5038: table.LC_nested_outer tr th.LC_left_item {
1.507     raeburn  5039:   text-align: left;
1.451     albertel 5040: }
1.507     raeburn  5041: table.LC_nested td {
1.692.4.2  raeburn  5042:   background-color: #FFFFFF;
1.451     albertel 5043:   font-size: small;
1.507     raeburn  5044: }
                   5045: table.LC_nested_outer tr th.LC_right_item,
                   5046: table.LC_nested tr.LC_info_row td.LC_right_item,
                   5047: table.LC_nested tr.LC_odd_row td.LC_right_item,
                   5048: table.LC_nested tr td.LC_right_item {
1.451     albertel 5049:   text-align: right;
                   5050: }
                   5051: 
1.507     raeburn  5052: table.LC_nested tr.LC_odd_row td {
1.692.4.2  raeburn  5053:   background-color: #EEEEEE;
1.451     albertel 5054: }
                   5055: 
1.473     raeburn  5056: table.LC_createuser {
                   5057: }
                   5058: 
                   5059: table.LC_createuser tr.LC_section_row td {
                   5060:   font-size: smaller;
                   5061: }
                   5062: 
                   5063: table.LC_createuser tr.LC_info_row td  {
1.692.4.2  raeburn  5064:   background-color: #CCCCCC;
1.473     raeburn  5065:   font-weight: bold;
                   5066:   text-align: center;
                   5067: }
                   5068: 
1.349     albertel 5069: table.LC_calendar {
                   5070:   border: 1px solid #000000;
                   5071:   border-collapse: collapse;
                   5072: }
                   5073: table.LC_calendar_pickdate {
                   5074:   font-size: xx-small;
                   5075: }
                   5076: table.LC_calendar tr td {
                   5077:   border: 1px solid #000000;
                   5078:   vertical-align: top;
                   5079: }
                   5080: table.LC_calendar tr td.LC_calendar_day_empty {
                   5081:   background-color: $data_table_dark;
                   5082: }
                   5083: table.LC_calendar tr td.LC_calendar_day_current {
                   5084:   background-color: $data_table_highlight;
                   5085: }
                   5086: 
                   5087: table.LC_mail_list tr.LC_mail_new {
                   5088:   background-color: $mail_new;
                   5089: }
                   5090: table.LC_mail_list tr.LC_mail_new:hover {
                   5091:   background-color: $mail_new_hover;
                   5092: }
                   5093: table.LC_mail_list tr.LC_mail_read {
                   5094:   background-color: $mail_read;
                   5095: }
                   5096: table.LC_mail_list tr.LC_mail_read:hover {
                   5097:   background-color: $mail_read_hover;
                   5098: }
                   5099: table.LC_mail_list tr.LC_mail_replied {
                   5100:   background-color: $mail_replied;
                   5101: }
                   5102: table.LC_mail_list tr.LC_mail_replied:hover {
                   5103:   background-color: $mail_replied_hover;
                   5104: }
                   5105: table.LC_mail_list tr.LC_mail_other {
                   5106:   background-color: $mail_other;
                   5107: }
                   5108: table.LC_mail_list tr.LC_mail_other:hover {
                   5109:   background-color: $mail_other_hover;
                   5110: }
1.494     raeburn  5111: table.LC_mail_list tr.LC_mail_even {
                   5112: }
                   5113: table.LC_mail_list tr.LC_mail_odd {
                   5114: }
                   5115: 
1.385     albertel 5116: 
1.386     albertel 5117: table#LC_portfolio_actions {
                   5118:   width: auto;
                   5119:   background: $pgbg;
1.692.4.2  raeburn  5120:   border: none;
1.386     albertel 5121:   border-spacing: 2px 2px;
1.692.4.2  raeburn  5122:   padding: 0;
                   5123:   margin: 0;
1.386     albertel 5124:   border-collapse: separate;
                   5125: }
                   5126: table#LC_portfolio_actions td.LC_label {
                   5127:   background: $tabbg;
                   5128:   text-align: right;
                   5129: }
                   5130: table#LC_portfolio_actions td.LC_value {
                   5131:   background: $tabbg;
                   5132: }
1.385     albertel 5133: 
1.391     albertel 5134: table#LC_cstr_controls {
                   5135:   width: 100%;
                   5136:   border-collapse: collapse;
                   5137: }
                   5138: table#LC_cstr_controls tr td {
                   5139:   border: 4px solid $pgbg;
                   5140:   padding: 4px;
                   5141:   text-align: center;
                   5142:   background: $tabbg;
                   5143: }
                   5144: table#LC_cstr_controls tr th {
                   5145:   border: 4px solid $pgbg;
                   5146:   background: $table_header;
                   5147:   text-align: center;
                   5148:   font-family: $sans;
                   5149:   font-size: smaller;
                   5150: }
                   5151: 
1.389     albertel 5152: table#LC_browser {
                   5153:  
                   5154: }
                   5155: table#LC_browser tr th {
1.391     albertel 5156:   background: $table_header;
1.389     albertel 5157: }
1.390     albertel 5158: table#LC_browser tr td {
                   5159:   padding: 2px;
                   5160: }
1.389     albertel 5161: table#LC_browser tr.LC_browser_file,
                   5162: table#LC_browser tr.LC_browser_file_published {
                   5163:   background: #CCFF88;
                   5164: }
                   5165: table#LC_browser tr.LC_browser_file_locked,
                   5166: table#LC_browser tr.LC_browser_file_unpublished {
                   5167:   background: #FFAA99;
1.387     albertel 5168: }
1.389     albertel 5169: table#LC_browser tr.LC_browser_file_obsolete {
                   5170:   background: #AAAAAA;
1.387     albertel 5171: }
1.455     albertel 5172: table#LC_browser tr.LC_browser_file_modified,
                   5173: table#LC_browser tr.LC_browser_file_metamodified {
1.389     albertel 5174:   background: #FFFF77;
1.387     albertel 5175: }
1.389     albertel 5176: table#LC_browser tr.LC_browser_folder {
                   5177:   background: #CCCCFF;
1.387     albertel 5178: }
1.692.4.2  raeburn  5179: 
                   5180: table.LC_data_table tr > td.LC_roles_is {
                   5181: /*  background: #77FF77; */
                   5182: }
                   5183: table.LC_data_table tr > td.LC_roles_future {
                   5184:   background: #FFFF77;
                   5185: }
                   5186: table.LC_data_table tr > td.LC_roles_will {
                   5187:   background: #FFAA77;
                   5188: }
                   5189: table.LC_data_table tr > td.LC_roles_expired {
                   5190:   background: #FF7777;
                   5191: }
                   5192: table.LC_data_table tr > td.LC_roles_will_not {
                   5193:   background: #AAFF77;
                   5194: }
                   5195: table.LC_data_table tr > td.LC_roles_selected {
                   5196:   background: #11CC55;
                   5197: }
                   5198: 
1.388     albertel 5199: span.LC_current_location {
                   5200:   font-size: x-large;
                   5201:   background: $pgbg;
                   5202: }
1.387     albertel 5203: 
1.395     albertel 5204: span.LC_parm_menu_item {
                   5205:   font-size: larger;
                   5206:   font-family: $sans;
                   5207: }
                   5208: span.LC_parm_scope_all {
                   5209:   color: red;
                   5210: }
                   5211: span.LC_parm_scope_folder {
                   5212:   color: green;
                   5213: }
                   5214: span.LC_parm_scope_resource {
                   5215:   color: orange;
                   5216: }
                   5217: span.LC_parm_part {
                   5218:   color: blue;
                   5219: }
                   5220: span.LC_parm_folder, span.LC_parm_symb {
                   5221:   font-size: x-small;
                   5222:   font-family: $mono;
                   5223:   color: #AAAAAA;
                   5224: }
                   5225: 
1.396     albertel 5226: td.LC_parm_overview_level_menu, td.LC_parm_overview_map_menu,
                   5227: td.LC_parm_overview_parm_selectors, td.LC_parm_overview_parm_restrictions {
                   5228:   border: 1px solid black;
                   5229:   border-collapse: collapse;
                   5230: }
                   5231: table.LC_parm_overview_restrictions td {
                   5232:   border-width: 1px 4px 1px 4px;
                   5233:   border-style: solid;
                   5234:   border-color: $pgbg;
                   5235:   text-align: center;
                   5236: }
                   5237: table.LC_parm_overview_restrictions th {
                   5238:   background: $tabbg;
                   5239:   border-width: 1px 4px 1px 4px;
                   5240:   border-style: solid;
                   5241:   border-color: $pgbg;
                   5242: }
1.398     albertel 5243: table#LC_helpmenu {
1.692.4.2  raeburn  5244:   border: none;
1.398     albertel 5245:   height: 55px;
1.692.4.2  raeburn  5246:   border-spacing: 0;
1.398     albertel 5247: }
                   5248: 
                   5249: table#LC_helpmenu fieldset legend {
                   5250:   font-size: larger;
                   5251:   font-weight: bold;
                   5252: }
1.397     albertel 5253: table#LC_helpmenu_links {
                   5254:   width: 100%;
                   5255:   border: 1px solid black;
                   5256:   background: $pgbg;
1.692.4.2  raeburn  5257:   padding: 0;
1.397     albertel 5258:   border-spacing: 1px;
                   5259: }
                   5260: table#LC_helpmenu_links tr td {
                   5261:   padding: 1px;
                   5262:   background: $tabbg;
1.399     albertel 5263:   text-align: center;
                   5264:   font-weight: bold;
1.397     albertel 5265: }
1.396     albertel 5266: 
1.397     albertel 5267: table#LC_helpmenu_links a:link, table#LC_helpmenu_links a:visited,
                   5268: table#LC_helpmenu_links a:active {
                   5269:   text-decoration: none;
                   5270:   color: $font;
                   5271: }
                   5272: table#LC_helpmenu_links a:hover {
                   5273:   text-decoration: underline;
                   5274:   color: $vlink;
                   5275: }
1.396     albertel 5276: 
1.417     albertel 5277: .LC_chrt_popup_exists {
                   5278:   border: 1px solid #339933;
                   5279:   margin: -1px;
                   5280: }
                   5281: .LC_chrt_popup_up {
                   5282:   border: 1px solid yellow;
                   5283:   margin: -1px;
                   5284: }
                   5285: .LC_chrt_popup {
                   5286:   border: 1px solid #8888FF;
                   5287:   background: #CCCCFF;
                   5288: }
1.421     albertel 5289: table.LC_pick_box {
                   5290:   border-collapse: separate;
                   5291:   background: white;
                   5292:   border: 1px solid black;
                   5293:   border-spacing: 1px;
                   5294: }
                   5295: table.LC_pick_box td.LC_pick_box_title {
1.692.4.16  raeburn  5296:   background: $tabbg;
1.421     albertel 5297:   font-weight: bold;
                   5298:   text-align: right;
1.692.4.2  raeburn  5299:   vertical-align: top;
1.421     albertel 5300:   width: 184px;
                   5301:   padding: 8px;
                   5302: }
1.645     raeburn  5303: table.LC_pick_box td.LC_selfenroll_pick_box_title {
1.692.4.16  raeburn  5304:   background: $tabbg;
1.645     raeburn  5305:   font-weight: bold;
                   5306:   text-align: right;
                   5307:   width: 350px;
                   5308:   padding: 8px;
                   5309: }
                   5310: 
1.579     raeburn  5311: table.LC_pick_box td.LC_pick_box_value {
                   5312:   text-align: left;
                   5313:   padding: 8px;
                   5314: }
                   5315: table.LC_pick_box td.LC_pick_box_select {
                   5316:   text-align: left;
                   5317:   padding: 8px;
                   5318: }
1.424     albertel 5319: table.LC_pick_box td.LC_pick_box_separator {
1.692.4.2  raeburn  5320:   padding: 0;
1.421     albertel 5321:   height: 1px;
                   5322:   background: black;
                   5323: }
                   5324: table.LC_pick_box td.LC_pick_box_submit {
                   5325:   text-align: right;
                   5326: }
1.579     raeburn  5327: table.LC_pick_box td.LC_evenrow_value {
                   5328:   text-align: left;
                   5329:   padding: 8px;
                   5330:   background-color: $data_table_light;
                   5331: }
                   5332: table.LC_pick_box td.LC_oddrow_value {
                   5333:   text-align: left;
                   5334:   padding: 8px;
                   5335:   background-color: $data_table_light;
                   5336: }
                   5337: table.LC_helpform_receipt {
                   5338:   width: 620px;
                   5339:   border-collapse: separate;
                   5340:   background: white;
                   5341:   border: 1px solid black;
                   5342:   border-spacing: 1px;
                   5343: }
                   5344: table.LC_helpform_receipt td.LC_pick_box_title {
                   5345:   background: $tabbg;
                   5346:   font-weight: bold;
                   5347:   text-align: right;
                   5348:   width: 184px;
                   5349:   padding: 8px;
                   5350: }
                   5351: table.LC_helpform_receipt td.LC_evenrow_value {
                   5352:   text-align: left;
                   5353:   padding: 8px;
                   5354:   background-color: $data_table_light;
                   5355: }
                   5356: table.LC_helpform_receipt td.LC_oddrow_value {
                   5357:   text-align: left;
                   5358:   padding: 8px;
                   5359:   background-color: $data_table_light;
                   5360: }
                   5361: table.LC_helpform_receipt td.LC_pick_box_separator {
1.692.4.2  raeburn  5362:   padding: 0;
1.579     raeburn  5363:   height: 1px;
                   5364:   background: black;
                   5365: }
                   5366: span.LC_helpform_receipt_cat {
                   5367:   font-weight: bold;
                   5368: }
1.424     albertel 5369: table.LC_group_priv_box {
                   5370:   background: white;
                   5371:   border: 1px solid black;
                   5372:   border-spacing: 1px;
                   5373: }
                   5374: table.LC_group_priv_box td.LC_pick_box_title {
                   5375:   background: $tabbg;
                   5376:   font-weight: bold;
                   5377:   text-align: right;
                   5378:   width: 184px;
                   5379: }
                   5380: table.LC_group_priv_box td.LC_groups_fixed {
                   5381:   background: $data_table_light;
                   5382:   text-align: center;
                   5383: }
                   5384: table.LC_group_priv_box td.LC_groups_optional {
                   5385:   background: $data_table_dark;
                   5386:   text-align: center;
                   5387: }
                   5388: table.LC_group_priv_box td.LC_groups_functionality {
                   5389:   background: $data_table_darker;
                   5390:   text-align: center;
                   5391:   font-weight: bold;
                   5392: }
                   5393: table.LC_group_priv td {
                   5394:   text-align: left;
1.692.4.2  raeburn  5395:   padding: 0;
1.424     albertel 5396: }
                   5397: 
1.421     albertel 5398: table.LC_notify_front_page {
                   5399:   background: white;
                   5400:   border: 1px solid black;
                   5401:   padding: 8px;
                   5402: }
                   5403: table.LC_notify_front_page td {
                   5404:   padding: 8px;
                   5405: }
1.424     albertel 5406: .LC_navbuttons {
                   5407:   margin: 2ex 0ex 2ex 0ex;
                   5408: }
1.423     albertel 5409: .LC_topic_bar {
                   5410:   font-family: $sans;
                   5411:   font-weight: bold;
                   5412:   width: 100%;
                   5413:   background: $tabbg;
                   5414:   vertical-align: middle;
                   5415:   margin: 2ex 0ex 2ex 0ex;
1.692.4.2  raeburn  5416:   padding: 3px;
1.423     albertel 5417: }
                   5418: .LC_topic_bar span {
                   5419:   vertical-align: middle;
                   5420: }
                   5421: .LC_topic_bar img {
                   5422:   vertical-align: bottom;
                   5423: }
                   5424: table.LC_course_group_status {
                   5425:   margin: 20px;
                   5426: }
                   5427: table.LC_status_selector td {
                   5428:   vertical-align: top;
                   5429:   text-align: center;
1.424     albertel 5430:   padding: 4px;
                   5431: }
                   5432: table.LC_descriptive_input td.LC_description {
                   5433:   vertical-align: top;
                   5434:   text-align: right;
                   5435:   font-weight: bold;
1.423     albertel 5436: }
1.599     albertel 5437: div.LC_feedback_link {
1.616     albertel 5438:   clear: both;
1.599     albertel 5439:   background: white;
                   5440:   width: 100%;  
1.489     raeburn  5441: }
                   5442: span.LC_feedback_link {
1.599     albertel 5443:   background: $feedback_link_bg;
                   5444:   font-size: larger;
                   5445: }
                   5446: span.LC_message_link {
                   5447:   background: $feedback_link_bg;
                   5448:   font-size: larger;
                   5449:   position: absolute;
                   5450:   right: 1em;
1.489     raeburn  5451: }
1.421     albertel 5452: 
1.515     albertel 5453: table.LC_prior_tries {
1.524     albertel 5454:   border: 1px solid #000000;
                   5455:   border-collapse: separate;
                   5456:   border-spacing: 1px;
1.515     albertel 5457: }
1.523     albertel 5458: 
1.515     albertel 5459: table.LC_prior_tries td {
1.524     albertel 5460:   padding: 2px;
1.515     albertel 5461: }
1.523     albertel 5462: 
                   5463: .LC_answer_correct {
                   5464:   background: #AAFFAA;
                   5465:   color: black;
                   5466: }
                   5467: .LC_answer_charged_try {
                   5468:   background: #FFAAAA ! important;
                   5469:   color: black;
                   5470: }
                   5471: .LC_answer_not_charged_try, 
                   5472: .LC_answer_no_grade,
                   5473: .LC_answer_late {
                   5474:   background: #FFFFAA;
                   5475:   color: black;
                   5476: }
                   5477: .LC_answer_previous {
                   5478:   background: #AAAAFF;
                   5479:   color: black;
                   5480: }
                   5481: .LC_answer_no_message {
                   5482:   background: #FFFFFF;
                   5483:   color: black;
                   5484: }
                   5485: .LC_answer_unknown {
                   5486:   background: orange;
                   5487:   color: black;
                   5488: }
                   5489: 
                   5490: 
1.529     albertel 5491: span.LC_prior_numerical,
                   5492: span.LC_prior_string,
                   5493: span.LC_prior_custom,
                   5494: span.LC_prior_reaction,
                   5495: span.LC_prior_math {
1.523     albertel 5496:   font-family: monospace;
                   5497:   white-space: pre;
                   5498: }
                   5499: 
1.525     albertel 5500: span.LC_prior_string {
                   5501:   font-family: monospace;
                   5502:   white-space: pre;
                   5503: }
                   5504: 
1.523     albertel 5505: table.LC_prior_option {
                   5506:   width: 100%;
                   5507:   border-collapse: collapse;
                   5508: }
1.528     albertel 5509: table.LC_prior_rank, table.LC_prior_match {
                   5510:   border-collapse: collapse;
                   5511: }
                   5512: table.LC_prior_option tr td,
                   5513: table.LC_prior_rank tr td,
                   5514: table.LC_prior_match tr td {
1.524     albertel 5515:   border: 1px solid #000000;
1.515     albertel 5516: }
                   5517: 
1.519     raeburn  5518: span.LC_nobreak {
1.544     albertel 5519:   white-space: nowrap;
1.519     raeburn  5520: }
                   5521: 
1.576     raeburn  5522: span.LC_cusr_emph {
                   5523:   font-style: italic;
                   5524: }
                   5525: 
1.633     raeburn  5526: span.LC_cusr_subheading {
                   5527:   font-weight: normal;
                   5528:   font-size: 85%;
                   5529: }
                   5530: 
1.545     albertel 5531: table.LC_docs_documents {
                   5532:   background: #BBBBBB;
1.692.4.2  raeburn  5533:   border-width: 0;
1.545     albertel 5534:   border-collapse: collapse;
                   5535: }
                   5536: 
                   5537: table.LC_docs_documents td.LC_docs_document {
                   5538:   border: 2px solid black;
                   5539:   padding: 4px;
                   5540: }
                   5541: 
                   5542: .LC_docs_course_commands div {
                   5543:   float: left;
                   5544:   border: 4px solid #AAAAAA;
                   5545:   padding: 4px;
                   5546:   background: #DDDDCC;
                   5547: }
                   5548: 
                   5549: .LC_docs_entry_move {
1.692.4.2  raeburn  5550:   border: none;
1.545     albertel 5551:   border-collapse: collapse;
1.544     albertel 5552: }
                   5553: 
1.545     albertel 5554: .LC_docs_entry_move td {
                   5555:   border: 2px solid #BBBBBB;
                   5556:   background: #DDDDDD;
                   5557: }
                   5558: 
                   5559: .LC_docs_editor td.LC_docs_entry_commands {
                   5560:   background: #DDDDDD;
                   5561:   font-size: x-small;
                   5562: }
1.544     albertel 5563: .LC_docs_copy {
1.545     albertel 5564:   color: #000099;
1.544     albertel 5565: }
                   5566: .LC_docs_cut {
1.545     albertel 5567:   color: #550044;
1.544     albertel 5568: }
                   5569: .LC_docs_rename {
1.545     albertel 5570:   color: #009900;
1.544     albertel 5571: }
                   5572: .LC_docs_remove {
1.545     albertel 5573:   color: #990000;
                   5574: }
                   5575: 
1.547     albertel 5576: .LC_docs_reinit_warn,
                   5577: .LC_docs_ext_edit {
                   5578:   font-size: x-small;
                   5579: }
                   5580: 
1.545     albertel 5581: .LC_docs_editor td.LC_docs_entry_title,
                   5582: .LC_docs_editor td.LC_docs_entry_icon {
                   5583:   background: #FFFFBB;
                   5584: }
                   5585: .LC_docs_editor td.LC_docs_entry_parameter {
                   5586:   background: #BBBBFF;
                   5587:   font-size: x-small;
                   5588:   white-space: nowrap;
                   5589: }
                   5590: 
                   5591: table.LC_docs_adddocs td,
                   5592: table.LC_docs_adddocs th {
                   5593:   border: 1px solid #BBBBBB;
                   5594:   padding: 4px;
                   5595:   background: #DDDDDD;
1.543     albertel 5596: }
                   5597: 
1.584     albertel 5598: table.LC_sty_begin {
                   5599:   background: #BBFFBB;
                   5600: }
                   5601: table.LC_sty_end {
                   5602:   background: #FFBBBB;
                   5603: }
                   5604: 
1.589     raeburn  5605: table.LC_double_column {
1.692.4.2  raeburn  5606:   border-width: 0;
1.589     raeburn  5607:   border-collapse: collapse;
                   5608:   width: 100%;
                   5609:   padding: 2px;
                   5610: }
                   5611: 
                   5612: table.LC_double_column tr td.LC_left_col {
1.590     raeburn  5613:   top: 2px;
1.589     raeburn  5614:   left: 2px;
                   5615:   width: 47%;
                   5616:   vertical-align: top;
                   5617: }
                   5618: 
                   5619: table.LC_double_column tr td.LC_right_col {
                   5620:   top: 2px;
                   5621:   right: 2px; 
                   5622:   width: 47%;
                   5623:   vertical-align: top;
                   5624: }
                   5625: 
1.594     raeburn  5626: span.LC_role_level {
                   5627:   font-weight: bold;
                   5628: }
                   5629: 
1.591     raeburn  5630: div.LC_left_float {
                   5631:   float: left;
                   5632:   padding-right: 5%;
1.597     albertel 5633:   padding-bottom: 4px;
1.591     raeburn  5634: }
                   5635: 
                   5636: div.LC_clear_float_header {
1.597     albertel 5637:   padding-bottom: 2px;
1.591     raeburn  5638: }
                   5639: 
                   5640: div.LC_clear_float_footer {
1.597     albertel 5641:   padding-top: 10px;
1.591     raeburn  5642:   clear: both;
                   5643: }
                   5644: 
1.597     albertel 5645: 
1.601     albertel 5646: div.LC_grade_select_mode {
1.604     albertel 5647:   font-family: $sans;
1.601     albertel 5648: }
                   5649: div.LC_grade_select_mode div div {
                   5650:   margin: 5px;
                   5651: }
                   5652: div.LC_grade_select_mode_selector {
                   5653:   margin: 5px;
                   5654:   float: left;
                   5655: }
                   5656: div.LC_grade_select_mode_selector_header {
                   5657:   font: bold medium $sans;
                   5658: }
                   5659: div.LC_grade_select_mode_type {
                   5660:   clear: left;
                   5661: }
                   5662: 
1.597     albertel 5663: div.LC_grade_show_user {
                   5664:   margin-top: 20px;
                   5665:   border: 1px solid black;
                   5666: }
                   5667: div.LC_grade_user_name {
                   5668:   background: #DDDDEE;
                   5669:   border-bottom: 1px solid black;
                   5670:   font: bold large $sans;
                   5671: }
                   5672: div.LC_grade_show_user_odd_row div.LC_grade_user_name {
                   5673:   background: #DDEEDD;
                   5674: }
                   5675: 
                   5676: div.LC_grade_show_problem,
                   5677: div.LC_grade_submissions,
                   5678: div.LC_grade_message_center,
                   5679: div.LC_grade_info_links,
                   5680: div.LC_grade_assign {
                   5681:   margin: 5px;
                   5682:   width: 99%;
                   5683:   background: #FFFFFF;
                   5684: }
                   5685: div.LC_grade_show_problem_header,
                   5686: div.LC_grade_submissions_header,
                   5687: div.LC_grade_message_center_header,
                   5688: div.LC_grade_assign_header {
                   5689:   font: bold large $sans;
                   5690: }
                   5691: div.LC_grade_show_problem_problem,
                   5692: div.LC_grade_submissions_body,
                   5693: div.LC_grade_message_center_body,
                   5694: div.LC_grade_assign_body {
                   5695:   border: 1px solid black;
                   5696:   width: 99%;
                   5697:   background: #FFFFFF;
                   5698: }
1.598     albertel 5699: span.LC_grade_check_note {
                   5700:   font: normal medium $sans;
                   5701:   display: inline;
                   5702:   position: absolute;
                   5703:   right: 1em;
                   5704: }
1.597     albertel 5705: 
1.613     albertel 5706: table.LC_scantron_action {
                   5707:   width: 100%;
                   5708: }
                   5709: table.LC_scantron_action tr th {
                   5710:   font: normal bold $sans;
                   5711: }
1.600     albertel 5712: 
1.614     albertel 5713: div.LC_edit_problem_header, 
                   5714: div.LC_edit_problem_footer {
1.600     albertel 5715:   font: normal medium $sans;
1.602     albertel 5716:   margin: 2px;
1.600     albertel 5717: }
                   5718: div.LC_edit_problem_header,
1.602     albertel 5719: div.LC_edit_problem_header div,
1.614     albertel 5720: div.LC_edit_problem_footer,
                   5721: div.LC_edit_problem_footer div,
1.602     albertel 5722: div.LC_edit_problem_editxml_header,
                   5723: div.LC_edit_problem_editxml_header div {
1.600     albertel 5724:   margin-top: 5px;
                   5725: }
1.602     albertel 5726: div.LC_edit_problem_header_edit_row {
                   5727:   background: $tabbg;
                   5728:   padding: 3px;
                   5729:   margin-bottom: 5px;
                   5730: }
1.600     albertel 5731: div.LC_edit_problem_header_title {
1.602     albertel 5732:   font: larger bold $sans;
                   5733:   background: $tabbg;
                   5734:   padding: 3px;
                   5735: }
                   5736: table.LC_edit_problem_header_title {
                   5737:   font: larger bold $sans;
                   5738:   width: 100%;
                   5739:   border-color: $pgbg;
                   5740:   border-style: solid;
                   5741:   border-width: $border;
                   5742: 
1.600     albertel 5743:   background: $tabbg;
1.602     albertel 5744:   border-collapse: collapse;
1.692.4.2  raeburn  5745:   padding: 0;
1.602     albertel 5746: }
                   5747: 
                   5748: div.LC_edit_problem_discards {
                   5749:   float: left;
                   5750:   padding-bottom: 5px;
                   5751: }
                   5752: div.LC_edit_problem_saves {
                   5753:   float: right;
                   5754:   padding-bottom: 5px;
1.600     albertel 5755: }
                   5756: hr.LC_edit_problem_divide {
1.602     albertel 5757:   clear: both;
1.600     albertel 5758:   color: $tabbg;
                   5759:   background-color: $tabbg;
                   5760:   height: 3px;
1.692.4.2  raeburn  5761:   border: none;
1.600     albertel 5762: }
1.679     riegler  5763: img.stift{
1.678     riegler  5764:   border-width:0;
1.679     riegler  5765:   vertical-align:middle;
1.677     riegler  5766: }
1.680     riegler  5767: 
1.681     riegler  5768: table#LC_mainmenu{
                   5769:  margin-top:10px;
                   5770:  width:80%;
                   5771: 
                   5772: }
                   5773: 
1.680     riegler  5774: table#LC_mainmenu td.LC_mainmenu_col_fieldset{
                   5775:   vertical-align: top;
                   5776:   width: 45%;
                   5777: }
                   5778: .LC_mainmenu_fieldset_category {
                   5779:   color: $font;
                   5780:   background: $pgbg;
                   5781:   font-family: $sans;
                   5782:   font-size: small;
                   5783:   font-weight: bold;
                   5784: }
                   5785: fieldset#LC_mainmenu_fieldset {
1.692.4.2  raeburn  5786:   margin:0 10px 10px 0;
                   5787: 
                   5788: }
1.680     riegler  5789: 
1.692.4.2  raeburn  5790: div.LC_createcourse {
                   5791:     margin: 10px 10px 10px 10px;
1.680     riegler  5792: }
1.692.4.2  raeburn  5793: 
1.343     albertel 5794: END
                   5795: }
                   5796: 
1.306     albertel 5797: =pod
                   5798: 
                   5799: =item * &headtag()
                   5800: 
                   5801: Returns a uniform footer for LON-CAPA web pages.
                   5802: 
1.307     albertel 5803: Inputs: $title - optional title for the head
                   5804:         $head_extra - optional extra HTML to put inside the <head>
1.315     albertel 5805:         $args - optional arguments
1.319     albertel 5806:             force_register - if is true call registerurl so the remote is 
                   5807:                              informed
1.415     albertel 5808:             redirect       -> array ref of
                   5809:                                    1- seconds before redirect occurs
                   5810:                                    2- url to redirect to
                   5811:                                    3- whether the side effect should occur
1.315     albertel 5812:                            (side effect of setting 
                   5813:                                $env{'internal.head.redirect'} to the url 
                   5814:                                redirected too)
1.352     albertel 5815:             domain         -> force to color decorate a page for a specific
                   5816:                                domain
                   5817:             function       -> force usage of a specific rolish color scheme
                   5818:             bgcolor        -> override the default page bgcolor
1.460     albertel 5819:             no_auto_mt_title
                   5820:                            -> prevent &mt()ing the title arg
1.464     albertel 5821: 
1.306     albertel 5822: =cut
                   5823: 
                   5824: sub headtag {
1.313     albertel 5825:     my ($title,$head_extra,$args) = @_;
1.306     albertel 5826:     
1.363     albertel 5827:     my $function = $args->{'function'} || &get_users_function();
                   5828:     my $domain   = $args->{'domain'}   || &determinedomain();
                   5829:     my $bgcolor  = $args->{'bgcolor'}  || &designparm($function.'.pgbg',$domain);
1.418     albertel 5830:     my $url = join(':',$env{'user.name'},$env{'user.domain'},
1.458     albertel 5831: 		   $Apache::lonnet::perlvar{'lonVersion'},
1.531     albertel 5832: 		   #time(),
1.418     albertel 5833: 		   $env{'environment.color.timestamp'},
1.363     albertel 5834: 		   $function,$domain,$bgcolor);
                   5835: 
1.369     www      5836:     $url = '/adm/css/'.&escape($url).'.css';
1.363     albertel 5837: 
1.308     albertel 5838:     my $result =
                   5839: 	'<head>'.
1.461     albertel 5840: 	&font_settings();
1.319     albertel 5841: 
1.461     albertel 5842:     if (!$args->{'frameset'}) {
                   5843: 	$result .= &Apache::lonhtmlcommon::htmlareaheaders();
                   5844:     }
1.319     albertel 5845:     if ($args->{'force_register'}) {
                   5846: 	$result .= &Apache::lonmenu::registerurl(1);
                   5847:     }
1.436     albertel 5848:     if (!$args->{'no_nav_bar'} 
                   5849: 	&& !$args->{'only_body'}
                   5850: 	&& !$args->{'frameset'}) {
                   5851: 	$result .= &help_menu_js();
                   5852:     }
1.319     albertel 5853: 
1.314     albertel 5854:     if (ref($args->{'redirect'})) {
1.414     albertel 5855: 	my ($time,$url,$inhibit_continue) = @{$args->{'redirect'}};
1.315     albertel 5856: 	$url = &Apache::lonenc::check_encrypt($url);
1.414     albertel 5857: 	if (!$inhibit_continue) {
                   5858: 	    $env{'internal.head.redirect'} = $url;
                   5859: 	}
1.313     albertel 5860: 	$result.=<<ADDMETA
                   5861: <meta http-equiv="pragma" content="no-cache" />
1.344     albertel 5862: <meta http-equiv="Refresh" content="$time; url=$url" />
1.313     albertel 5863: ADDMETA
                   5864:     }
1.306     albertel 5865:     if (!defined($title)) {
                   5866: 	$title = 'The LearningOnline Network with CAPA';
                   5867:     }
1.460     albertel 5868:     if (!$args->{'no_auto_mt_title'}) { $title = &mt($title); }
                   5869:     $result .= '<title> LON-CAPA '.$title.'</title>'
1.414     albertel 5870: 	.'<link rel="stylesheet" type="text/css" href="'.$url.'" />'
                   5871: 	.$head_extra;
1.306     albertel 5872:     return $result;
                   5873: }
                   5874: 
                   5875: =pod
                   5876: 
1.340     albertel 5877: =item * &font_settings()
                   5878: 
                   5879: Returns neccessary <meta> to set the proper encoding
                   5880: 
                   5881: Inputs: none
                   5882: 
                   5883: =cut
                   5884: 
                   5885: sub font_settings {
                   5886:     my $headerstring='';
1.647     www      5887:     if (!$env{'browser.mathml'} && $env{'browser.unicode'}) {
1.340     albertel 5888: 	$headerstring.=
                   5889: 	    '<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />';
                   5890:     }
                   5891:     return $headerstring;
                   5892: }
                   5893: 
1.341     albertel 5894: =pod
                   5895: 
                   5896: =item * &xml_begin()
                   5897: 
                   5898: Returns the needed doctype and <html>
                   5899: 
                   5900: Inputs: none
                   5901: 
                   5902: =cut
                   5903: 
                   5904: sub xml_begin {
                   5905:     my $output='';
                   5906: 
1.592     albertel 5907:     if ($env{'internal.start_page'}==1) {
                   5908: 	&Apache::lonhtmlcommon::init_htmlareafields();
                   5909:     }
1.342     albertel 5910: 
1.341     albertel 5911:     if ($env{'browser.mathml'}) {
                   5912: 	$output='<?xml version="1.0"?>'
                   5913:             #.'<?xml-stylesheet type="text/css" href="/adm/MathML/mathml.css"?>'."\n"
                   5914: #            .'<!DOCTYPE html SYSTEM "/adm/MathML/mathml.dtd" '
                   5915:             
                   5916: #	    .'<!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">] >'
                   5917: 	    .'<!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">'
                   5918:             .'<html xmlns:math="http://www.w3.org/1998/Math/MathML" ' 
                   5919: 	    .'xmlns="http://www.w3.org/1999/xhtml">';
                   5920:     } else {
1.692.4.6  raeburn  5921: 	$output='<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">'.
                   5922:             '<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">';
1.341     albertel 5923:     }
                   5924:     return $output;
                   5925: }
1.340     albertel 5926: 
                   5927: =pod
                   5928: 
1.306     albertel 5929: =item * &endheadtag()
                   5930: 
                   5931: Returns a uniform </head> for LON-CAPA web pages.
                   5932: 
                   5933: Inputs: none
                   5934: 
                   5935: =cut
                   5936: 
                   5937: sub endheadtag {
                   5938:     return '</head>';
                   5939: }
                   5940: 
                   5941: =pod
                   5942: 
                   5943: =item * &head()
                   5944: 
                   5945: Returns a uniform complete <head>..</head> section for LON-CAPA web pages.
                   5946: 
1.648     raeburn  5947: Inputs:
                   5948: 
                   5949: =over 4
                   5950: 
                   5951: $title - optional title for the page
                   5952: 
                   5953: $head_extra - optional extra HTML to put inside the <head>
                   5954: 
                   5955: =back
1.405     albertel 5956: 
1.306     albertel 5957: =cut
                   5958: 
                   5959: sub head {
1.325     albertel 5960:     my ($title,$head_extra,$args) = @_;
                   5961:     return &headtag($title,$head_extra,$args).&endheadtag();
1.306     albertel 5962: }
                   5963: 
                   5964: =pod
                   5965: 
                   5966: =item * &start_page()
                   5967: 
                   5968: Returns a complete <html> .. <body> section for LON-CAPA web pages.
                   5969: 
1.648     raeburn  5970: Inputs:
                   5971: 
                   5972: =over 4
                   5973: 
                   5974: $title - optional title for the page
                   5975: 
                   5976: $head_extra - optional extra HTML to incude inside the <head>
                   5977: 
                   5978: $args - additional optional args supported are:
                   5979: 
                   5980: =over 8
                   5981: 
                   5982:              only_body      -> is true will set &bodytag() onlybodytag
1.317     albertel 5983:                                     arg on
1.648     raeburn  5984:              no_nav_bar     -> is true will set &bodytag() notopbar arg on
                   5985:              add_entries    -> additional attributes to add to the  <body>
                   5986:              domain         -> force to color decorate a page for a 
1.317     albertel 5987:                                     specific domain
1.648     raeburn  5988:              function       -> force usage of a specific rolish color
1.317     albertel 5989:                                     scheme
1.648     raeburn  5990:              redirect       -> see &headtag()
                   5991:              bgcolor        -> override the default page bg color
                   5992:              js_ready       -> return a string ready for being used in 
1.317     albertel 5993:                                     a javascript writeln
1.648     raeburn  5994:              html_encode    -> return a string ready for being used in 
1.320     albertel 5995:                                     a html attribute
1.648     raeburn  5996:              force_register -> if is true will turn on the &bodytag()
1.317     albertel 5997:                                     $forcereg arg
1.648     raeburn  5998:              body_title     -> alternate text to use instead of $title
1.326     albertel 5999:                                     in the title box that appears, this text
                   6000:                                     is not auto translated like the $title is
1.648     raeburn  6001:              frameset       -> if true will start with a <frameset>
1.330     albertel 6002:                                     rather than <body>
1.648     raeburn  6003:              no_title       -> if true the title bar won't be shown
                   6004:              skip_phases    -> hash ref of 
1.338     albertel 6005:                                     head -> skip the <html><head> generation
                   6006:                                     body -> skip all <body> generation
1.648     raeburn  6007:              no_inline_link -> if true and in remote mode, don't show the 
1.361     albertel 6008:                                     'Switch To Inline Menu' link
1.648     raeburn  6009:              no_auto_mt_title -> prevent &mt()ing the title arg
                   6010:              inherit_jsmath -> when creating popup window in a page,
                   6011:                                     should it have jsmath forced on by the
                   6012:                                     current page
1.361     albertel 6013: 
1.648     raeburn  6014: =back
1.460     albertel 6015: 
1.648     raeburn  6016: =back
1.562     albertel 6017: 
1.306     albertel 6018: =cut
                   6019: 
                   6020: sub start_page {
1.309     albertel 6021:     my ($title,$head_extra,$args) = @_;
1.318     albertel 6022:     #&Apache::lonnet::logthis("start_page ".join(':',caller(0)));
1.313     albertel 6023:     my %head_args;
1.352     albertel 6024:     foreach my $arg ('redirect','force_register','domain','function',
1.460     albertel 6025: 		     'bgcolor','frameset','no_nav_bar','only_body',
                   6026: 		     'no_auto_mt_title') {
1.319     albertel 6027: 	if (defined($args->{$arg})) {
1.324     raeburn  6028: 	    $head_args{$arg} = $args->{$arg};
1.319     albertel 6029: 	}
1.313     albertel 6030:     }
1.319     albertel 6031: 
1.315     albertel 6032:     $env{'internal.start_page'}++;
1.338     albertel 6033:     my $result;
                   6034:     if (! exists($args->{'skip_phases'}{'head'}) ) {
                   6035: 	$result.=
1.341     albertel 6036: 	    &xml_begin().
1.338     albertel 6037: 	    &headtag($title,$head_extra,\%head_args).&endheadtag();
                   6038:     }
                   6039:     
                   6040:     if (! exists($args->{'skip_phases'}{'body'}) ) {
                   6041: 	if ($args->{'frameset'}) {
                   6042: 	    my $attr_string = &make_attr_string($args->{'force_register'},
                   6043: 						$args->{'add_entries'});
                   6044: 	    $result .= "\n<frameset $attr_string>\n";
                   6045: 	} else {
                   6046: 	    $result .=
                   6047: 		&bodytag($title, 
                   6048: 			 $args->{'function'},       $args->{'add_entries'},
                   6049: 			 $args->{'only_body'},      $args->{'domain'},
                   6050: 			 $args->{'force_register'}, $args->{'body_title'},
                   6051: 			 $args->{'no_nav_bar'},     $args->{'bgcolor'},
1.460     albertel 6052: 			 $args->{'no_title'},       $args->{'no_inline_link'},
                   6053: 			 $args);
1.338     albertel 6054: 	}
1.330     albertel 6055:     }
1.338     albertel 6056: 
1.315     albertel 6057:     if ($args->{'js_ready'}) {
1.317     albertel 6058: 	$result = &js_ready($result);
1.315     albertel 6059:     }
1.320     albertel 6060:     if ($args->{'html_encode'}) {
                   6061: 	$result = &html_encode($result);
                   6062:     }
1.692.4.2  raeburn  6063:     #Breadcrumbs
                   6064:     if (exists($args->{'bread_crumbs'}) or exists($args->{'bread_crumbs_component'})) {
                   6065:         &Apache::lonhtmlcommon::clear_breadcrumbs();
                   6066:         #if any br links exists, add them to the breadcrumbs
                   6067:         if (exists($args->{'bread_crumbs'}) and ref($args->{'bread_crumbs'}) eq 'ARRAY') {
                   6068:             foreach my $crumb (@{$args->{'bread_crumbs'}}){
                   6069:                 &Apache::lonhtmlcommon::add_breadcrumb($crumb);
                   6070:             }
                   6071:         }
1.306     albertel 6072: 
1.692.4.2  raeburn  6073:         #if bread_crumbs_component exists show it as headline else show only the breadcrumbs
                   6074:         if (exists($args->{'bread_crumbs_component'})){
                   6075:             $result .= &Apache::lonhtmlcommon::breadcrumbs($args->{'bread_crumbs_component'});
                   6076:         } else {
                   6077:             $result .= &Apache::lonhtmlcommon::breadcrumbs();
                   6078:         }
                   6079:     }
                   6080:     return $result;
1.692.4.3  raeburn  6081: }
1.330     albertel 6082: 
1.306     albertel 6083: =pod
                   6084: 
                   6085: =item * &head()
                   6086: 
                   6087: Returns a complete </body></html> section for LON-CAPA web pages.
                   6088: 
1.315     albertel 6089: Inputs:         $args - additional optional args supported are:
                   6090:                  js_ready     -> return a string ready for being used in 
                   6091:                                  a javascript writeln
1.320     albertel 6092:                  html_encode  -> return a string ready for being used in 
                   6093:                                  a html attribute
1.330     albertel 6094:                  frameset     -> if true will start with a <frameset>
                   6095:                                  rather than <body>
1.493     albertel 6096:                  dicsussion   -> if true will get discussion from
                   6097:                                   lonxml::xmlend
                   6098:                                  (you can pass the target and parser arguments
                   6099:                                   through optional 'target' and 'parser' args
                   6100:                                   to this routine)
1.306     albertel 6101: 
                   6102: =cut
                   6103: 
                   6104: sub end_page {
1.315     albertel 6105:     my ($args) = @_;
                   6106:     $env{'internal.end_page'}++;
1.330     albertel 6107:     my $result;
1.335     albertel 6108:     if ($args->{'discussion'}) {
                   6109: 	my ($target,$parser);
                   6110: 	if (ref($args->{'discussion'})) {
                   6111: 	    ($target,$parser) =($args->{'discussion'}{'target'},
                   6112: 				$args->{'discussion'}{'parser'});
                   6113: 	}
                   6114: 	$result .= &Apache::lonxml::xmlend($target,$parser);
                   6115:     }
                   6116: 
1.330     albertel 6117:     if ($args->{'frameset'}) {
                   6118: 	$result .= '</frameset>';
                   6119:     } else {
1.635     raeburn  6120: 	$result .= &endbodytag($args);
1.330     albertel 6121:     }
                   6122:     $result .= "\n</html>";
                   6123: 
1.315     albertel 6124:     if ($args->{'js_ready'}) {
1.317     albertel 6125: 	$result = &js_ready($result);
1.315     albertel 6126:     }
1.335     albertel 6127: 
1.320     albertel 6128:     if ($args->{'html_encode'}) {
                   6129: 	$result = &html_encode($result);
                   6130:     }
1.335     albertel 6131: 
1.315     albertel 6132:     return $result;
                   6133: }
                   6134: 
1.320     albertel 6135: sub html_encode {
                   6136:     my ($result) = @_;
                   6137: 
1.322     albertel 6138:     $result = &HTML::Entities::encode($result,'<>&"');
1.320     albertel 6139:     
                   6140:     return $result;
                   6141: }
1.317     albertel 6142: sub js_ready {
                   6143:     my ($result) = @_;
                   6144: 
1.323     albertel 6145:     $result =~ s/[\n\r]/ /xmsg;
                   6146:     $result =~ s/\\/\\\\/xmsg;
                   6147:     $result =~ s/'/\\'/xmsg;
1.372     albertel 6148:     $result =~ s{</}{<\\/}xmsg;
1.317     albertel 6149:     
                   6150:     return $result;
                   6151: }
                   6152: 
1.315     albertel 6153: sub validate_page {
                   6154:     if (  exists($env{'internal.start_page'})
1.316     albertel 6155: 	  &&     $env{'internal.start_page'} > 1) {
                   6156: 	&Apache::lonnet::logthis('start_page called multiple times '.
1.318     albertel 6157: 				 $env{'internal.start_page'}.' '.
1.316     albertel 6158: 				 $ENV{'request.filename'});
1.315     albertel 6159:     }
                   6160:     if (  exists($env{'internal.end_page'})
1.316     albertel 6161: 	  &&     $env{'internal.end_page'} > 1) {
                   6162: 	&Apache::lonnet::logthis('end_page called multiple times '.
1.318     albertel 6163: 				 $env{'internal.end_page'}.' '.
1.316     albertel 6164: 				 $env{'request.filename'});
1.315     albertel 6165:     }
                   6166:     if (     exists($env{'internal.start_page'})
                   6167: 	&& ! exists($env{'internal.end_page'})) {
1.316     albertel 6168: 	&Apache::lonnet::logthis('start_page called without end_page '.
                   6169: 				 $env{'request.filename'});
1.315     albertel 6170:     }
                   6171:     if (   ! exists($env{'internal.start_page'})
                   6172: 	&&   exists($env{'internal.end_page'})) {
1.316     albertel 6173: 	&Apache::lonnet::logthis('end_page called without start_page'.
                   6174: 				 $env{'request.filename'});
1.315     albertel 6175:     }
1.306     albertel 6176: }
1.315     albertel 6177: 
1.318     albertel 6178: sub simple_error_page {
                   6179:     my ($r,$title,$msg) = @_;
                   6180:     my $page =
                   6181: 	&Apache::loncommon::start_page($title).
                   6182: 	&mt($msg).
                   6183: 	&Apache::loncommon::end_page();
                   6184:     if (ref($r)) {
                   6185: 	$r->print($page);
1.327     albertel 6186: 	return;
1.318     albertel 6187:     }
                   6188:     return $page;
                   6189: }
1.347     albertel 6190: 
                   6191: {
1.610     albertel 6192:     my @row_count;
1.347     albertel 6193:     sub start_data_table {
1.422     albertel 6194: 	my ($add_class) = @_;
                   6195: 	my $css_class = (join(' ','LC_data_table',$add_class));
1.610     albertel 6196: 	unshift(@row_count,0);
1.422     albertel 6197: 	return '<table class="'.$css_class.'">'."\n";
1.347     albertel 6198:     }
                   6199: 
                   6200:     sub end_data_table {
1.610     albertel 6201: 	shift(@row_count);
1.389     albertel 6202: 	return '</table>'."\n";;
1.347     albertel 6203:     }
                   6204: 
                   6205:     sub start_data_table_row {
1.422     albertel 6206: 	my ($add_class) = @_;
1.610     albertel 6207: 	$row_count[0]++;
                   6208: 	my $css_class = ($row_count[0] % 2)?'LC_odd_row':'LC_even_row';
1.428     albertel 6209: 	$css_class = (join(' ',$css_class,$add_class));
1.422     albertel 6210: 	return  '<tr class="'.$css_class.'">'."\n";;
1.347     albertel 6211:     }
1.471     banghart 6212:     
                   6213:     sub continue_data_table_row {
                   6214: 	my ($add_class) = @_;
1.610     albertel 6215: 	my $css_class = ($row_count[0] % 2)?'LC_odd_row':'LC_even_row';
1.471     banghart 6216: 	$css_class = (join(' ',$css_class,$add_class));
                   6217: 	return  '<tr class="'.$css_class.'">'."\n";;
                   6218:     }
1.347     albertel 6219: 
                   6220:     sub end_data_table_row {
1.389     albertel 6221: 	return '</tr>'."\n";;
1.347     albertel 6222:     }
1.367     www      6223: 
1.421     albertel 6224:     sub start_data_table_empty_row {
1.610     albertel 6225: 	$row_count[0]++;
1.421     albertel 6226: 	return  '<tr class="LC_empty_row" >'."\n";;
                   6227:     }
                   6228: 
                   6229:     sub end_data_table_empty_row {
                   6230: 	return '</tr>'."\n";;
                   6231:     }
                   6232: 
1.367     www      6233:     sub start_data_table_header_row {
1.389     albertel 6234: 	return  '<tr class="LC_header_row">'."\n";;
1.367     www      6235:     }
                   6236: 
                   6237:     sub end_data_table_header_row {
1.389     albertel 6238: 	return '</tr>'."\n";;
1.367     www      6239:     }
1.347     albertel 6240: }
                   6241: 
1.548     albertel 6242: =pod
                   6243: 
                   6244: =item * &inhibit_menu_check($arg)
                   6245: 
                   6246: Checks for a inhibitmenu state and generates output to preserve it
                   6247: 
                   6248: Inputs:         $arg - can be any of
                   6249:                      - undef - in which case the return value is a string 
                   6250:                                to add  into arguments list of a uri
                   6251:                      - 'input' - in which case the return value is a HTML
                   6252:                                  <form> <input> field of type hidden to
                   6253:                                  preserve the value
                   6254:                      - a url - in which case the return value is the url with
                   6255:                                the neccesary cgi args added to preserve the
                   6256:                                inhibitmenu state
                   6257:                      - a ref to a url - no return value, but the string is
                   6258:                                         updated to include the neccessary cgi
                   6259:                                         args to preserve the inhibitmenu state
                   6260: 
                   6261: =cut
                   6262: 
                   6263: sub inhibit_menu_check {
                   6264:     my ($arg) = @_;
                   6265:     &get_unprocessed_cgi($ENV{'QUERY_STRING'}, ['inhibitmenu']);
                   6266:     if ($arg eq 'input') {
                   6267: 	if ($env{'form.inhibitmenu'}) {
                   6268: 	    return '<input type="hidden" name="inhibitmenu" value="'.$env{'form.inhibitmenu'}.'" />';
                   6269: 	} else {
                   6270: 	    return
                   6271: 	}
                   6272:     }
                   6273:     if ($env{'form.inhibitmenu'}) {
                   6274: 	if (ref($arg)) {
                   6275: 	    $$arg .= '?inhibitmenu='.$env{'form.inhibitmenu'};
                   6276: 	} elsif ($arg eq '') {
                   6277: 	    $arg .= 'inhibitmenu='.$env{'form.inhibitmenu'};
                   6278: 	} else {
                   6279: 	    $arg .= '?inhibitmenu='.$env{'form.inhibitmenu'};
                   6280: 	}
                   6281:     }
                   6282:     if (!ref($arg)) {
                   6283: 	return $arg;
                   6284:     }
                   6285: }
                   6286: 
1.251     albertel 6287: ###############################################
1.182     matthew  6288: 
                   6289: =pod
                   6290: 
1.549     albertel 6291: =back
                   6292: 
                   6293: =head1 User Information Routines
                   6294: 
                   6295: =over 4
                   6296: 
1.405     albertel 6297: =item * &get_users_function()
1.182     matthew  6298: 
                   6299: Used by &bodytag to determine the current users primary role.
                   6300: Returns either 'student','coordinator','admin', or 'author'.
                   6301: 
                   6302: =cut
                   6303: 
                   6304: ###############################################
                   6305: sub get_users_function {
                   6306:     my $function = 'student';
1.258     albertel 6307:     if ($env{'request.role'}=~/^(cc|in|ta|ep)/) {
1.182     matthew  6308:         $function='coordinator';
                   6309:     }
1.258     albertel 6310:     if ($env{'request.role'}=~/^(su|dc|ad|li)/) {
1.182     matthew  6311:         $function='admin';
                   6312:     }
1.692.4.5  raeburn  6313:     if (($env{'request.role'}=~/^(au|ca|aa)/) ||
1.182     matthew  6314:         ($ENV{'REQUEST_URI'}=~/^(\/priv|\~)/)) {
                   6315:         $function='author';
                   6316:     }
                   6317:     return $function;
1.54      www      6318: }
1.99      www      6319: 
                   6320: ###############################################
                   6321: 
1.233     raeburn  6322: =pod
                   6323: 
1.692.4.2  raeburn  6324: =item * &show_course()
                   6325: 
                   6326: Used by lonmenu.pm and lonroles.pm to determine whether to use the word
                   6327: 'Courses' or 'Roles' in inline navigation and on screen displaying user's roles.
                   6328: Inputs:
                   6329: None
                   6330: 
                   6331: Outputs:
                   6332: Scalar: 1 if 'Course' to be used, 0 otherwise.
                   6333: 
                   6334: =cut
                   6335: 
                   6336: ###############################################
                   6337: sub show_course {
                   6338:     my $course = !$env{'user.adv'};
                   6339:     if (!$env{'user.adv'}) {
                   6340:         foreach my $env (keys(%env)) {
                   6341:             next if ($env !~ m/^user\.priv\./);
                   6342:             if ($env !~ m/^user\.priv\.(?:st|cm)/) {
                   6343:                 $course = 0;
                   6344:                 last;
                   6345:             }
                   6346:         }
                   6347:     }
                   6348:     return $course;
                   6349: }
                   6350: 
                   6351: ###############################################
                   6352: 
                   6353: =pod
                   6354: 
1.542     raeburn  6355: =item * &check_user_status()
1.274     raeburn  6356: 
                   6357: Determines current status of supplied role for a
                   6358: specific user. Roles can be active, previous or future.
                   6359: 
                   6360: Inputs: 
                   6361: user's domain, user's username, course's domain,
1.375     raeburn  6362: course's number, optional section ID.
1.274     raeburn  6363: 
                   6364: Outputs:
                   6365: role status: active, previous or future. 
                   6366: 
                   6367: =cut
                   6368: 
                   6369: sub check_user_status {
1.412     raeburn  6370:     my ($udom,$uname,$cdom,$crs,$role,$sec) = @_;
1.274     raeburn  6371:     my %userinfo = &Apache::lonnet::dump('roles',$udom,$uname);
                   6372:     my @uroles = keys %userinfo;
                   6373:     my $srchstr;
                   6374:     my $active_chk = 'none';
1.412     raeburn  6375:     my $now = time;
1.274     raeburn  6376:     if (@uroles > 0) {
1.412     raeburn  6377:         if (($role eq 'cc') || ($sec eq '') || (!defined($sec))) {
1.274     raeburn  6378:             $srchstr = '/'.$cdom.'/'.$crs.'_'.$role;
                   6379:         } else {
1.412     raeburn  6380:             $srchstr = '/'.$cdom.'/'.$crs.'/'.$sec.'_'.$role;
                   6381:         }
                   6382:         if (grep/^\Q$srchstr\E$/,@uroles) {
1.274     raeburn  6383:             my $role_end = 0;
                   6384:             my $role_start = 0;
                   6385:             $active_chk = 'active';
1.412     raeburn  6386:             if ($userinfo{$srchstr} =~ m/^\Q$role\E_(\d+)/) {
                   6387:                 $role_end = $1;
                   6388:                 if ($userinfo{$srchstr} =~ m/^\Q$role\E_\Q$role_end\E_(\d+)$/) {
                   6389:                     $role_start = $1;
1.274     raeburn  6390:                 }
                   6391:             }
                   6392:             if ($role_start > 0) {
1.412     raeburn  6393:                 if ($now < $role_start) {
1.274     raeburn  6394:                     $active_chk = 'future';
                   6395:                 }
                   6396:             }
                   6397:             if ($role_end > 0) {
1.412     raeburn  6398:                 if ($now > $role_end) {
1.274     raeburn  6399:                     $active_chk = 'previous';
                   6400:                 }
                   6401:             }
                   6402:         }
                   6403:     }
                   6404:     return $active_chk;
                   6405: }
                   6406: 
                   6407: ###############################################
                   6408: 
                   6409: =pod
                   6410: 
1.405     albertel 6411: =item * &get_sections()
1.233     raeburn  6412: 
                   6413: Determines all the sections for a course including
                   6414: sections with students and sections containing other roles.
1.419     raeburn  6415: Incoming parameters: 
                   6416: 
                   6417: 1. domain
                   6418: 2. course number 
                   6419: 3. reference to array containing roles for which sections should 
                   6420: be gathered (optional).
                   6421: 4. reference to array containing status types for which sections 
                   6422: should be gathered (optional).
                   6423: 
                   6424: If the third argument is undefined, sections are gathered for any role. 
                   6425: If the fourth argument is undefined, sections are gathered for any status.
                   6426: Permissible values are 'active' or 'future' or 'previous'.
1.233     raeburn  6427:  
1.374     raeburn  6428: Returns section hash (keys are section IDs, values are
                   6429: number of users in each section), subject to the
1.419     raeburn  6430: optional roles filter, optional status filter 
1.233     raeburn  6431: 
                   6432: =cut
                   6433: 
                   6434: ###############################################
                   6435: sub get_sections {
1.419     raeburn  6436:     my ($cdom,$cnum,$possible_roles,$possible_status) = @_;
1.366     albertel 6437:     if (!defined($cdom) || !defined($cnum)) {
                   6438:         my $cid =  $env{'request.course.id'};
                   6439: 
                   6440: 	return if (!defined($cid));
                   6441: 
                   6442:         $cdom = $env{'course.'.$cid.'.domain'};
                   6443:         $cnum = $env{'course.'.$cid.'.num'};
                   6444:     }
                   6445: 
                   6446:     my %sectioncount;
1.419     raeburn  6447:     my $now = time;
1.240     albertel 6448: 
1.366     albertel 6449:     if (!defined($possible_roles) || (grep(/^st$/,@$possible_roles))) {
1.276     albertel 6450: 	my ($classlist) = &Apache::loncoursedata::get_classlist($cdom,$cnum);
1.240     albertel 6451: 	my $sec_index = &Apache::loncoursedata::CL_SECTION();
                   6452: 	my $status_index = &Apache::loncoursedata::CL_STATUS();
1.419     raeburn  6453:         my $start_index = &Apache::loncoursedata::CL_START();
                   6454:         my $end_index = &Apache::loncoursedata::CL_END();
                   6455:         my $status;
1.366     albertel 6456: 	while (my ($student,$data) = each(%$classlist)) {
1.419     raeburn  6457: 	    my ($section,$stu_status,$start,$end) = ($data->[$sec_index],
                   6458: 				                     $data->[$status_index],
                   6459:                                                      $data->[$start_index],
                   6460:                                                      $data->[$end_index]);
                   6461:             if ($stu_status eq 'Active') {
                   6462:                 $status = 'active';
                   6463:             } elsif ($end < $now) {
                   6464:                 $status = 'previous';
                   6465:             } elsif ($start > $now) {
                   6466:                 $status = 'future';
                   6467:             } 
                   6468: 	    if ($section ne '-1' && $section !~ /^\s*$/) {
                   6469:                 if ((!defined($possible_status)) || (($status ne '') && 
                   6470:                     (grep/^\Q$status\E$/,@{$possible_status}))) { 
                   6471: 		    $sectioncount{$section}++;
                   6472:                 }
1.240     albertel 6473: 	    }
                   6474: 	}
                   6475:     }
                   6476:     my %courseroles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
                   6477:     foreach my $user (sort(keys(%courseroles))) {
                   6478: 	if ($user !~ /^(\w{2})/) { next; }
                   6479: 	my ($role) = ($user =~ /^(\w{2})/);
                   6480: 	if ($possible_roles && !(grep(/^$role$/,@$possible_roles))) { next; }
1.419     raeburn  6481: 	my ($section,$status);
1.240     albertel 6482: 	if ($role eq 'cr' &&
                   6483: 	    $user =~ m-^$role/[^/]*/[^/]*/[^/]*:[^:]*:[^:]*:(\w+)-) {
                   6484: 	    $section=$1;
                   6485: 	}
                   6486: 	if ($user =~ /^$role:[^:]*:[^:]*:(\w+)/) { $section=$1; }
                   6487: 	if (!defined($section) || $section eq '-1') { next; }
1.419     raeburn  6488:         my ($end,$start) = ($courseroles{$user} =~ /^([^:]*):([^:]*)$/);
                   6489:         if ($end == -1 && $start == -1) {
                   6490:             next; #deleted role
                   6491:         }
                   6492:         if (!defined($possible_status)) { 
                   6493:             $sectioncount{$section}++;
                   6494:         } else {
                   6495:             if ((!$end || $end >= $now) && (!$start || $start <= $now)) {
                   6496:                 $status = 'active';
                   6497:             } elsif ($end < $now) {
                   6498:                 $status = 'future';
                   6499:             } elsif ($start > $now) {
                   6500:                 $status = 'previous';
                   6501:             }
                   6502:             if (($status ne '') && (grep/^\Q$status\E$/,@{$possible_status})) {
                   6503:                 $sectioncount{$section}++;
                   6504:             }
                   6505:         }
1.233     raeburn  6506:     }
1.366     albertel 6507:     return %sectioncount;
1.233     raeburn  6508: }
                   6509: 
1.274     raeburn  6510: ###############################################
1.294     raeburn  6511: 
                   6512: =pod
1.405     albertel 6513: 
                   6514: =item * &get_course_users()
                   6515: 
1.275     raeburn  6516: Retrieves usernames:domains for users in the specified course
                   6517: with specific role(s), and access status. 
                   6518: 
                   6519: Incoming parameters:
1.277     albertel 6520: 1. course domain
                   6521: 2. course number
                   6522: 3. access status: users must have - either active, 
1.275     raeburn  6523: previous, future, or all.
1.277     albertel 6524: 4. reference to array of permissible roles
1.288     raeburn  6525: 5. reference to array of section restrictions (optional)
                   6526: 6. reference to results object (hash of hashes).
                   6527: 7. reference to optional userdata hash
1.609     raeburn  6528: 8. reference to optional statushash
1.630     raeburn  6529: 9. flag if privileged users (except those set to unhide in
                   6530:    course settings) should be excluded    
1.609     raeburn  6531: Keys of top level results hash are roles.
1.275     raeburn  6532: Keys of inner hashes are username:domain, with 
                   6533: values set to access type.
1.288     raeburn  6534: Optional userdata hash returns an array with arguments in the 
                   6535: same order as loncoursedata::get_classlist() for student data.
                   6536: 
1.609     raeburn  6537: Optional statushash returns
                   6538: 
1.288     raeburn  6539: Entries for end, start, section and status are blank because
                   6540: of the possibility of multiple values for non-student roles.
                   6541: 
1.275     raeburn  6542: =cut
1.405     albertel 6543: 
1.275     raeburn  6544: ###############################################
1.405     albertel 6545: 
1.275     raeburn  6546: sub get_course_users {
1.630     raeburn  6547:     my ($cdom,$cnum,$types,$roles,$sections,$users,$userdata,$statushash,$hidepriv) = @_;
1.288     raeburn  6548:     my %idx = ();
1.419     raeburn  6549:     my %seclists;
1.288     raeburn  6550: 
                   6551:     $idx{udom} = &Apache::loncoursedata::CL_SDOM();
                   6552:     $idx{uname} =  &Apache::loncoursedata::CL_SNAME();
                   6553:     $idx{end} = &Apache::loncoursedata::CL_END();
                   6554:     $idx{start} = &Apache::loncoursedata::CL_START();
                   6555:     $idx{id} = &Apache::loncoursedata::CL_ID();
                   6556:     $idx{section} = &Apache::loncoursedata::CL_SECTION();
                   6557:     $idx{fullname} = &Apache::loncoursedata::CL_FULLNAME();
                   6558:     $idx{status} = &Apache::loncoursedata::CL_STATUS();
                   6559: 
1.290     albertel 6560:     if (grep(/^st$/,@{$roles})) {
1.276     albertel 6561:         my ($classlist,$keylist)=&Apache::loncoursedata::get_classlist($cdom,$cnum);
1.278     raeburn  6562:         my $now = time;
1.277     albertel 6563:         foreach my $student (keys(%{$classlist})) {
1.288     raeburn  6564:             my $match = 0;
1.412     raeburn  6565:             my $secmatch = 0;
1.419     raeburn  6566:             my $section = $$classlist{$student}[$idx{section}];
1.609     raeburn  6567:             my $status = $$classlist{$student}[$idx{status}];
1.419     raeburn  6568:             if ($section eq '') {
                   6569:                 $section = 'none';
                   6570:             }
1.291     albertel 6571:             if ((ref($sections) eq 'ARRAY') && (@{$sections} > 0)) {
1.420     albertel 6572:                 if (grep(/^all$/,@{$sections})) {
1.412     raeburn  6573:                     $secmatch = 1;
                   6574:                 } elsif ($$classlist{$student}[$idx{section}] eq '') {
1.420     albertel 6575:                     if (grep(/^none$/,@{$sections})) {
1.412     raeburn  6576:                         $secmatch = 1;
                   6577:                     }
                   6578:                 } else {  
1.419     raeburn  6579: 		    if (grep(/^\Q$section\E$/,@{$sections})) {
1.412     raeburn  6580: 		        $secmatch = 1;
                   6581:                     }
1.290     albertel 6582: 		}
1.412     raeburn  6583:                 if (!$secmatch) {
                   6584:                     next;
                   6585:                 }
1.419     raeburn  6586:             }
1.275     raeburn  6587:             if (defined($$types{'active'})) {
1.288     raeburn  6588:                 if ($$classlist{$student}[$idx{status}] eq 'Active') {
1.275     raeburn  6589:                     push(@{$$users{st}{$student}},'active');
1.288     raeburn  6590:                     $match = 1;
1.275     raeburn  6591:                 }
                   6592:             }
                   6593:             if (defined($$types{'previous'})) {
1.609     raeburn  6594:                 if ($$classlist{$student}[$idx{status}] eq 'Expired') {
1.275     raeburn  6595:                     push(@{$$users{st}{$student}},'previous');
1.288     raeburn  6596:                     $match = 1;
1.275     raeburn  6597:                 }
                   6598:             }
                   6599:             if (defined($$types{'future'})) {
1.609     raeburn  6600:                 if ($$classlist{$student}[$idx{status}] eq 'Future') {
1.275     raeburn  6601:                     push(@{$$users{st}{$student}},'future');
1.288     raeburn  6602:                     $match = 1;
1.275     raeburn  6603:                 }
                   6604:             }
1.609     raeburn  6605:             if ($match) {
                   6606:                 push(@{$seclists{$student}},$section);
                   6607:                 if (ref($userdata) eq 'HASH') {
                   6608:                     $$userdata{$student} = $$classlist{$student};
                   6609:                 }
                   6610:                 if (ref($statushash) eq 'HASH') {
                   6611:                     $statushash->{$student}{'st'}{$section} = $status;
                   6612:                 }
1.288     raeburn  6613:             }
1.275     raeburn  6614:         }
                   6615:     }
1.412     raeburn  6616:     if ((@{$roles} > 1) || ((@{$roles} == 1) && ($$roles[0] ne "st"))) {
1.439     raeburn  6617:         my %coursepersonnel = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
                   6618:         my $now = time;
1.609     raeburn  6619:         my %displaystatus = ( previous => 'Expired',
                   6620:                               active   => 'Active',
                   6621:                               future   => 'Future',
                   6622:                             );
1.630     raeburn  6623:         my %nothide;
                   6624:         if ($hidepriv) {
                   6625:             my %coursehash=&Apache::lonnet::coursedescription($cdom.'_'.$cnum);
                   6626:             foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
                   6627:                 if ($user !~ /:/) {
                   6628:                     $nothide{join(':',split(/[\@]/,$user))}=1;
                   6629:                 } else {
                   6630:                     $nothide{$user} = 1;
                   6631:                 }
                   6632:             }
                   6633:         }
1.439     raeburn  6634:         foreach my $person (sort(keys(%coursepersonnel))) {
1.288     raeburn  6635:             my $match = 0;
1.412     raeburn  6636:             my $secmatch = 0;
1.439     raeburn  6637:             my $status;
1.412     raeburn  6638:             my ($role,$user,$usec) = ($person =~ /^([^:]*):([^:]+:[^:]+):([^:]*)/);
1.275     raeburn  6639:             $user =~ s/:$//;
1.439     raeburn  6640:             my ($end,$start) = split(/:/,$coursepersonnel{$person});
                   6641:             if ($end == -1 || $start == -1) {
                   6642:                 next;
                   6643:             }
                   6644:             if (($role) && ((grep(/^\Q$role\E$/,@{$roles})) ||
                   6645:                 (grep(/^cr$/,@{$roles}) && $role =~ /^cr\//))) {
1.412     raeburn  6646:                 my ($uname,$udom) = split(/:/,$user);
                   6647:                 if ((ref($sections) eq 'ARRAY') && (@{$sections} > 0)) {
1.420     albertel 6648:                     if (grep(/^all$/,@{$sections})) {
1.412     raeburn  6649:                         $secmatch = 1;
                   6650:                     } elsif ($usec eq '') {
1.420     albertel 6651:                         if (grep(/^none$/,@{$sections})) {
1.412     raeburn  6652:                             $secmatch = 1;
                   6653:                         }
                   6654:                     } else {
                   6655:                         if (grep(/^\Q$usec\E$/,@{$sections})) {
                   6656:                             $secmatch = 1;
                   6657:                         }
                   6658:                     }
                   6659:                     if (!$secmatch) {
                   6660:                         next;
                   6661:                     }
1.288     raeburn  6662:                 }
1.419     raeburn  6663:                 if ($usec eq '') {
                   6664:                     $usec = 'none';
                   6665:                 }
1.275     raeburn  6666:                 if ($uname ne '' && $udom ne '') {
1.630     raeburn  6667:                     if ($hidepriv) {
                   6668:                         if ((&Apache::lonnet::privileged($uname,$udom)) &&
                   6669:                             (!$nothide{$uname.':'.$udom})) {
                   6670:                             next;
                   6671:                         }
                   6672:                     }
1.503     raeburn  6673:                     if ($end > 0 && $end < $now) {
1.439     raeburn  6674:                         $status = 'previous';
                   6675:                     } elsif ($start > $now) {
                   6676:                         $status = 'future';
                   6677:                     } else {
                   6678:                         $status = 'active';
                   6679:                     }
1.277     albertel 6680:                     foreach my $type (keys(%{$types})) { 
1.275     raeburn  6681:                         if ($status eq $type) {
1.420     albertel 6682:                             if (!grep(/^\Q$type\E$/,@{$$users{$role}{$user}})) {
1.419     raeburn  6683:                                 push(@{$$users{$role}{$user}},$type);
                   6684:                             }
1.288     raeburn  6685:                             $match = 1;
                   6686:                         }
                   6687:                     }
1.419     raeburn  6688:                     if (($match) && (ref($userdata) eq 'HASH')) {
                   6689:                         if (!exists($$userdata{$uname.':'.$udom})) {
                   6690: 			    &get_user_info($udom,$uname,\%idx,$userdata);
                   6691:                         }
1.420     albertel 6692:                         if (!grep(/^\Q$usec\E$/,@{$seclists{$uname.':'.$udom}})) {
1.419     raeburn  6693:                             push(@{$seclists{$uname.':'.$udom}},$usec);
                   6694:                         }
1.609     raeburn  6695:                         if (ref($statushash) eq 'HASH') {
                   6696:                             $statushash->{$uname.':'.$udom}{$role}{$usec} = $displaystatus{$status};
                   6697:                         }
1.275     raeburn  6698:                     }
                   6699:                 }
                   6700:             }
                   6701:         }
1.290     albertel 6702:         if (grep(/^ow$/,@{$roles})) {
1.279     raeburn  6703:             if ((defined($cdom)) && (defined($cnum))) {
                   6704:                 my %csettings = &Apache::lonnet::get('environment',['internal.courseowner'],$cdom,$cnum);
                   6705:                 if ( defined($csettings{'internal.courseowner'}) ) {
                   6706:                     my $owner = $csettings{'internal.courseowner'};
1.609     raeburn  6707:                     next if ($owner eq '');
                   6708:                     my ($ownername,$ownerdom);
                   6709:                     if ($owner =~ /^([^:]+):([^:]+)$/) {
                   6710:                         $ownername = $1;
                   6711:                         $ownerdom = $2;
                   6712:                     } else {
                   6713:                         $ownername = $owner;
                   6714:                         $ownerdom = $cdom;
                   6715:                         $owner = $ownername.':'.$ownerdom;
1.439     raeburn  6716:                     }
                   6717:                     @{$$users{'ow'}{$owner}} = 'any';
1.290     albertel 6718:                     if (defined($userdata) && 
1.609     raeburn  6719: 			!exists($$userdata{$owner})) {
                   6720: 			&get_user_info($ownerdom,$ownername,\%idx,$userdata);
                   6721:                         if (!grep(/^none$/,@{$seclists{$owner}})) {
                   6722:                             push(@{$seclists{$owner}},'none');
                   6723:                         }
                   6724:                         if (ref($statushash) eq 'HASH') {
                   6725:                             $statushash->{$owner}{'ow'}{'none'} = 'Any';
1.419     raeburn  6726:                         }
1.290     albertel 6727: 		    }
1.279     raeburn  6728:                 }
                   6729:             }
                   6730:         }
1.419     raeburn  6731:         foreach my $user (keys(%seclists)) {
                   6732:             @{$seclists{$user}} = (sort {$a <=> $b} @{$seclists{$user}});
                   6733:             $$userdata{$user}[$idx{section}] = join(',',@{$seclists{$user}});
                   6734:         }
1.275     raeburn  6735:     }
                   6736:     return;
                   6737: }
                   6738: 
1.288     raeburn  6739: sub get_user_info {
                   6740:     my ($udom,$uname,$idx,$userdata) = @_;
1.289     albertel 6741:     $$userdata{$uname.':'.$udom}[$$idx{fullname}] = 
                   6742: 	&plainname($uname,$udom,'lastname');
1.291     albertel 6743:     $$userdata{$uname.':'.$udom}[$$idx{uname}] = $uname;
1.297     raeburn  6744:     $$userdata{$uname.':'.$udom}[$$idx{udom}] = $udom;
1.609     raeburn  6745:     my %idhash =  &Apache::lonnet::idrget($udom,($uname));
                   6746:     $$userdata{$uname.':'.$udom}[$$idx{id}] = $idhash{$uname}; 
1.288     raeburn  6747:     return;
                   6748: }
1.275     raeburn  6749: 
1.472     raeburn  6750: ###############################################
                   6751: 
                   6752: =pod
                   6753: 
                   6754: =item * &get_user_quota()
                   6755: 
                   6756: Retrieves quota assigned for storage of portfolio files for a user  
                   6757: 
                   6758: Incoming parameters:
                   6759: 1. user's username
                   6760: 2. user's domain
                   6761: 
                   6762: Returns:
1.536     raeburn  6763: 1. Disk quota (in Mb) assigned to student.
                   6764: 2. (Optional) Type of setting: custom or default
                   6765:    (individually assigned or default for user's 
                   6766:    institutional status).
                   6767: 3. (Optional) - User's institutional status (e.g., faculty, staff
                   6768:    or student - types as defined in localenroll::inst_usertypes 
                   6769:    for user's domain, which determines default quota for user.
                   6770: 4. (Optional) - Default quota which would apply to the user.
1.472     raeburn  6771: 
                   6772: If a value has been stored in the user's environment, 
1.536     raeburn  6773: it will return that, otherwise it returns the maximal default
                   6774: defined for the user's instituional status(es) in the domain.
1.472     raeburn  6775: 
                   6776: =cut
                   6777: 
                   6778: ###############################################
                   6779: 
                   6780: 
                   6781: sub get_user_quota {
                   6782:     my ($uname,$udom) = @_;
1.536     raeburn  6783:     my ($quota,$quotatype,$settingstatus,$defquota);
1.472     raeburn  6784:     if (!defined($udom)) {
                   6785:         $udom = $env{'user.domain'};
                   6786:     }
                   6787:     if (!defined($uname)) {
                   6788:         $uname = $env{'user.name'};
                   6789:     }
                   6790:     if (($udom eq '' || $uname eq '') ||
                   6791:         ($udom eq 'public') && ($uname eq 'public')) {
                   6792:         $quota = 0;
1.536     raeburn  6793:         $quotatype = 'default';
                   6794:         $defquota = 0; 
1.472     raeburn  6795:     } else {
1.536     raeburn  6796:         my $inststatus;
1.472     raeburn  6797:         if ($udom eq $env{'user.domain'} && $uname eq $env{'user.name'}) {
                   6798:             $quota = $env{'environment.portfolioquota'};
1.536     raeburn  6799:             $inststatus = $env{'environment.inststatus'};
1.472     raeburn  6800:         } else {
1.536     raeburn  6801:             my %userenv = 
                   6802:                 &Apache::lonnet::get('environment',['portfolioquota',
                   6803:                                      'inststatus'],$udom,$uname);
1.472     raeburn  6804:             my ($tmp) = keys(%userenv);
                   6805:             if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
                   6806:                 $quota = $userenv{'portfolioquota'};
1.536     raeburn  6807:                 $inststatus = $userenv{'inststatus'};
1.472     raeburn  6808:             } else {
                   6809:                 undef(%userenv);
                   6810:             }
                   6811:         }
1.536     raeburn  6812:         ($defquota,$settingstatus) = &default_quota($udom,$inststatus);
1.472     raeburn  6813:         if ($quota eq '') {
1.536     raeburn  6814:             $quota = $defquota;
                   6815:             $quotatype = 'default';
                   6816:         } else {
                   6817:             $quotatype = 'custom';
1.472     raeburn  6818:         }
                   6819:     }
1.536     raeburn  6820:     if (wantarray) {
                   6821:         return ($quota,$quotatype,$settingstatus,$defquota);
                   6822:     } else {
                   6823:         return $quota;
                   6824:     }
1.472     raeburn  6825: }
                   6826: 
                   6827: ###############################################
                   6828: 
                   6829: =pod
                   6830: 
                   6831: =item * &default_quota()
                   6832: 
1.536     raeburn  6833: Retrieves default quota assigned for storage of user portfolio files,
                   6834: given an (optional) user's institutional status.
1.472     raeburn  6835: 
                   6836: Incoming parameters:
                   6837: 1. domain
1.536     raeburn  6838: 2. (Optional) institutional status(es).  This is a : separated list of 
                   6839:    status types (e.g., faculty, staff, student etc.)
                   6840:    which apply to the user for whom the default is being retrieved.
                   6841:    If the institutional status string in undefined, the domain
                   6842:    default quota will be returned. 
1.472     raeburn  6843: 
                   6844: Returns:
                   6845: 1. Default disk quota (in Mb) for user portfolios in the domain.
1.536     raeburn  6846: 2. (Optional) institutional type which determined the value of the
                   6847:    default quota.
1.472     raeburn  6848: 
                   6849: If a value has been stored in the domain's configuration db,
                   6850: it will return that, otherwise it returns 20 (for backwards 
                   6851: compatibility with domains which have not set up a configuration
                   6852: db file; the original statically defined portfolio quota was 20 Mb). 
                   6853: 
1.536     raeburn  6854: If the user's status includes multiple types (e.g., staff and student),
                   6855: the largest default quota which applies to the user determines the
                   6856: default quota returned.
                   6857: 
1.692.4.15  raeburn  6858: =back
                   6859: 
1.472     raeburn  6860: =cut
                   6861: 
                   6862: ###############################################
                   6863: 
                   6864: 
                   6865: sub default_quota {
1.536     raeburn  6866:     my ($udom,$inststatus) = @_;
                   6867:     my ($defquota,$settingstatus);
                   6868:     my %quotahash = &Apache::lonnet::get_dom('configuration',
1.622     raeburn  6869:                                             ['quotas'],$udom);
                   6870:     if (ref($quotahash{'quotas'}) eq 'HASH') {
1.536     raeburn  6871:         if ($inststatus ne '') {
1.692.4.2  raeburn  6872:             my @statuses = map { &unescape($_); } split(/:/,$inststatus);
1.536     raeburn  6873:             foreach my $item (@statuses) {
1.692.4.2  raeburn  6874:                 if (ref($quotahash{'quotas'}{'defaultquota'}) eq 'HASH') {
                   6875:                     if ($quotahash{'quotas'}{'defaultquota'}{$item} ne '') {
                   6876:                         if ($defquota eq '') {
                   6877:                             $defquota = $quotahash{'quotas'}{'defaultquota'}{$item};
                   6878:                             $settingstatus = $item;
                   6879:                         } elsif ($quotahash{'quotas'}{'defaultquota'}{$item} > $defquota) {
                   6880:                             $defquota = $quotahash{'quotas'}{'defaultquota'}{$item};
                   6881:                             $settingstatus = $item;
                   6882:                         }
                   6883:                     }
                   6884:                 } else {
                   6885:                     if ($quotahash{'quotas'}{$item} ne '') {
                   6886:                         if ($defquota eq '') {
                   6887:                             $defquota = $quotahash{'quotas'}{$item};
                   6888:                             $settingstatus = $item;
                   6889:                         } elsif ($quotahash{'quotas'}{$item} > $defquota) {
                   6890:                             $defquota = $quotahash{'quotas'}{$item};
                   6891:                             $settingstatus = $item;
                   6892:                         }
1.536     raeburn  6893:                     }
                   6894:                 }
                   6895:             }
                   6896:         }
                   6897:         if ($defquota eq '') {
1.692.4.2  raeburn  6898:             if (ref($quotahash{'quotas'}{'defaultquota'}) eq 'HASH') {
                   6899:                 $defquota = $quotahash{'quotas'}{'defaultquota'}{'default'};
                   6900:             } else {
                   6901:                 $defquota = $quotahash{'quotas'}{'default'};
                   6902:             }
1.536     raeburn  6903:             $settingstatus = 'default';
                   6904:         }
                   6905:     } else {
                   6906:         $settingstatus = 'default';
                   6907:         $defquota = 20;
                   6908:     }
                   6909:     if (wantarray) {
                   6910:         return ($defquota,$settingstatus);
1.472     raeburn  6911:     } else {
1.536     raeburn  6912:         return $defquota;
1.472     raeburn  6913:     }
                   6914: }
                   6915: 
1.384     raeburn  6916: sub get_secgrprole_info {
                   6917:     my ($cdom,$cnum,$needroles,$type)  = @_;
                   6918:     my %sections_count = &get_sections($cdom,$cnum);
                   6919:     my @sections =  (sort {$a <=> $b} keys(%sections_count));
                   6920:     my %curr_groups = &Apache::longroup::coursegroups($cdom,$cnum);
                   6921:     my @groups = sort(keys(%curr_groups));
                   6922:     my $allroles = [];
                   6923:     my $rolehash;
                   6924:     my $accesshash = {
                   6925:                      active => 'Currently has access',
                   6926:                      future => 'Will have future access',
                   6927:                      previous => 'Previously had access',
                   6928:                   };
                   6929:     if ($needroles) {
                   6930:         $rolehash = {'all' => 'all'};
1.385     albertel 6931:         my %user_roles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
                   6932: 	if (&Apache::lonnet::error(%user_roles)) {
                   6933: 	    undef(%user_roles);
                   6934: 	}
                   6935:         foreach my $item (keys(%user_roles)) {
1.384     raeburn  6936:             my ($role)=split(/\:/,$item,2);
                   6937:             if ($role eq 'cr') { next; }
                   6938:             if ($role =~ /^cr/) {
                   6939:                 $$rolehash{$role} = (split('/',$role))[3];
                   6940:             } else {
                   6941:                 $$rolehash{$role} = &Apache::lonnet::plaintext($role,$type);
                   6942:             }
                   6943:         }
                   6944:         foreach my $key (sort(keys(%{$rolehash}))) {
                   6945:             push(@{$allroles},$key);
                   6946:         }
                   6947:         push (@{$allroles},'st');
                   6948:         $$rolehash{'st'} = &Apache::lonnet::plaintext('st',$type);
                   6949:     }
                   6950:     return (\@sections,\@groups,$allroles,$rolehash,$accesshash);
                   6951: }
                   6952: 
1.555     raeburn  6953: sub user_picker {
1.627     raeburn  6954:     my ($dom,$srch,$forcenewuser,$caller,$cancreate,$usertype) = @_;
1.555     raeburn  6955:     my $currdom = $dom;
                   6956:     my %curr_selected = (
                   6957:                         srchin => 'dom',
1.580     raeburn  6958:                         srchby => 'lastname',
1.555     raeburn  6959:                       );
                   6960:     my $srchterm;
1.625     raeburn  6961:     if ((ref($srch) eq 'HASH') && ($env{'form.origform'} ne 'crtusername')) {
1.555     raeburn  6962:         if ($srch->{'srchby'} ne '') {
                   6963:             $curr_selected{'srchby'} = $srch->{'srchby'};
                   6964:         }
                   6965:         if ($srch->{'srchin'} ne '') {
                   6966:             $curr_selected{'srchin'} = $srch->{'srchin'};
                   6967:         }
                   6968:         if ($srch->{'srchtype'} ne '') {
                   6969:             $curr_selected{'srchtype'} = $srch->{'srchtype'};
                   6970:         }
                   6971:         if ($srch->{'srchdomain'} ne '') {
                   6972:             $currdom = $srch->{'srchdomain'};
                   6973:         }
                   6974:         $srchterm = $srch->{'srchterm'};
                   6975:     }
                   6976:     my %lt=&Apache::lonlocal::texthash(
1.573     raeburn  6977:                     'usr'       => 'Search criteria',
1.563     raeburn  6978:                     'doma'      => 'Domain/institution to search',
1.558     albertel 6979:                     'uname'     => 'username',
                   6980:                     'lastname'  => 'last name',
1.555     raeburn  6981:                     'lastfirst' => 'last name, first name',
1.558     albertel 6982:                     'crs'       => 'in this course',
1.576     raeburn  6983:                     'dom'       => 'in selected LON-CAPA domain', 
1.558     albertel 6984:                     'alc'       => 'all LON-CAPA',
1.573     raeburn  6985:                     'instd'     => 'in institutional directory for selected domain',
1.558     albertel 6986:                     'exact'     => 'is',
                   6987:                     'contains'  => 'contains',
1.569     raeburn  6988:                     'begins'    => 'begins with',
1.571     raeburn  6989:                     'youm'      => "You must include some text to search for.",
                   6990:                     'thte'      => "The text you are searching for must contain at least two characters when using a 'begins' type search.",
                   6991:                     'thet'      => "The text you are searching for must contain at least three characters when using a 'contains' type search.",
                   6992:                     'yomc'      => "You must choose a domain when using an institutional directory search.",
                   6993:                     'ymcd'      => "You must choose a domain when using a domain search.",
                   6994:                     'whus'      => "When using searching by last,first you must include a comma as separator between last name and first name.",
                   6995:                     'whse'      => "When searching by last,first you must include at least one character in the first name.",
                   6996:                      'thfo'     => "The following need to be corrected before the search can be run:",
1.555     raeburn  6997:                                        );
1.563     raeburn  6998:     my $domform = &select_dom_form($currdom,'srchdomain',1,1);
                   6999:     my $srchinsel = ' <select name="srchin">';
1.555     raeburn  7000: 
                   7001:     my @srchins = ('crs','dom','alc','instd');
                   7002: 
                   7003:     foreach my $option (@srchins) {
                   7004:         # FIXME 'alc' option unavailable until 
                   7005:         #       loncreateuser::print_user_query_page()
                   7006:         #       has been completed.
                   7007:         next if ($option eq 'alc');
1.692.4.11  raeburn  7008:         next if (($option eq 'crs') && ($env{'form.form'} eq 'requestcrs'));
1.555     raeburn  7009:         next if ($option eq 'crs' && !$env{'request.course.id'});
1.563     raeburn  7010:         if ($curr_selected{'srchin'} eq $option) {
                   7011:             $srchinsel .= ' 
                   7012:    <option value="'.$option.'" selected="selected">'.$lt{$option}.'</option>';
                   7013:         } else {
                   7014:             $srchinsel .= '
                   7015:    <option value="'.$option.'">'.$lt{$option}.'</option>';
                   7016:         }
1.555     raeburn  7017:     }
1.563     raeburn  7018:     $srchinsel .= "\n  </select>\n";
1.555     raeburn  7019: 
                   7020:     my $srchbysel =  ' <select name="srchby">';
1.580     raeburn  7021:     foreach my $option ('lastname','lastfirst','uname') {
1.555     raeburn  7022:         if ($curr_selected{'srchby'} eq $option) {
                   7023:             $srchbysel .= '
                   7024:    <option value="'.$option.'" selected="selected">'.$lt{$option}.'</option>';
                   7025:         } else {
                   7026:             $srchbysel .= '
                   7027:    <option value="'.$option.'">'.$lt{$option}.'</option>';
                   7028:          }
                   7029:     }
                   7030:     $srchbysel .= "\n  </select>\n";
                   7031: 
                   7032:     my $srchtypesel = ' <select name="srchtype">';
1.580     raeburn  7033:     foreach my $option ('begins','contains','exact') {
1.555     raeburn  7034:         if ($curr_selected{'srchtype'} eq $option) {
                   7035:             $srchtypesel .= '
                   7036:    <option value="'.$option.'" selected="selected">'.$lt{$option}.'</option>';
                   7037:         } else {
                   7038:             $srchtypesel .= '
                   7039:    <option value="'.$option.'">'.$lt{$option}.'</option>';
                   7040:         }
                   7041:     }
                   7042:     $srchtypesel .= "\n  </select>\n";
                   7043: 
1.558     albertel 7044:     my ($newuserscript,$new_user_create);
1.556     raeburn  7045: 
                   7046:     if ($forcenewuser) {
1.576     raeburn  7047:         if (ref($srch) eq 'HASH') {
                   7048:             if ($srch->{'srchby'} eq 'uname' && $srch->{'srchtype'} eq 'exact' && $srch->{'srchin'} eq 'dom' && $srch->{'srchdomain'} eq $env{'request.role.domain'}) {
1.627     raeburn  7049:                 if ($cancreate) {
                   7050:                     $new_user_create = '<p> <input type="submit" name="forcenew" value="'.&HTML::Entities::encode(&mt('Make new user "[_1]"',$srchterm),'<>&"').'" onclick="javascript:setSearch(\'1\','.$caller.');" /> </p>';
                   7051:                 } else {
1.692.4.2  raeburn  7052:                     my $helplink = 'javascript:helpMenu('."'display'".')';
1.627     raeburn  7053:                     my %usertypetext = (
                   7054:                         official   => 'institutional',
                   7055:                         unofficial => 'non-institutional',
                   7056:                     );
1.692.4.2  raeburn  7057:                     $new_user_create = '<p class="LC_warning">'.
                   7058:                                        &mt("You are not authorized to create new $usertypetext{$usertype} users in this domain.").' '.
                   7059:                                        &mt('Please contact the [_1]helpdesk[_2] for assistance.','<a href="'.$helplink.'">','</a>').'</p><br />';
1.627     raeburn  7060:                 }
1.576     raeburn  7061:             }
                   7062:         }
                   7063: 
1.556     raeburn  7064:         $newuserscript = <<"ENDSCRIPT";
                   7065: 
1.570     raeburn  7066: function setSearch(createnew,callingForm) {
1.556     raeburn  7067:     if (createnew == 1) {
1.570     raeburn  7068:         for (var i=0; i<callingForm.srchby.length; i++) {
                   7069:             if (callingForm.srchby.options[i].value == 'uname') {
                   7070:                 callingForm.srchby.selectedIndex = i;
1.556     raeburn  7071:             }
                   7072:         }
1.570     raeburn  7073:         for (var i=0; i<callingForm.srchin.length; i++) {
                   7074:             if ( callingForm.srchin.options[i].value == 'dom') {
                   7075: 		callingForm.srchin.selectedIndex = i;
1.556     raeburn  7076:             }
                   7077:         }
1.570     raeburn  7078:         for (var i=0; i<callingForm.srchtype.length; i++) {
                   7079:             if (callingForm.srchtype.options[i].value == 'exact') {
                   7080:                 callingForm.srchtype.selectedIndex = i;
1.556     raeburn  7081:             }
                   7082:         }
1.570     raeburn  7083:         for (var i=0; i<callingForm.srchdomain.length; i++) {
                   7084:             if (callingForm.srchdomain.options[i].value == '$env{'request.role.domain'}') {
                   7085:                 callingForm.srchdomain.selectedIndex = i;
1.556     raeburn  7086:             }
                   7087:         }
                   7088:     }
                   7089: }
                   7090: ENDSCRIPT
1.558     albertel 7091: 
1.556     raeburn  7092:     }
                   7093: 
1.555     raeburn  7094:     my $output = <<"END_BLOCK";
1.556     raeburn  7095: <script type="text/javascript">
1.692.4.4  raeburn  7096: // <![CDATA[
1.570     raeburn  7097: function validateEntry(callingForm) {
1.558     albertel 7098: 
1.556     raeburn  7099:     var checkok = 1;
1.558     albertel 7100:     var srchin;
1.570     raeburn  7101:     for (var i=0; i<callingForm.srchin.length; i++) {
                   7102: 	if ( callingForm.srchin[i].checked ) {
                   7103: 	    srchin = callingForm.srchin[i].value;
1.558     albertel 7104: 	}
                   7105:     }
                   7106: 
1.570     raeburn  7107:     var srchtype = callingForm.srchtype.options[callingForm.srchtype.selectedIndex].value;
                   7108:     var srchby = callingForm.srchby.options[callingForm.srchby.selectedIndex].value;
                   7109:     var srchdomain = callingForm.srchdomain.options[callingForm.srchdomain.selectedIndex].value;
                   7110:     var srchterm =  callingForm.srchterm.value;
                   7111:     var srchin = callingForm.srchin.options[callingForm.srchin.selectedIndex].value;
1.556     raeburn  7112:     var msg = "";
                   7113: 
                   7114:     if (srchterm == "") {
                   7115:         checkok = 0;
1.571     raeburn  7116:         msg += "$lt{'youm'}\\n";
1.556     raeburn  7117:     }
                   7118: 
1.569     raeburn  7119:     if (srchtype== 'begins') {
                   7120:         if (srchterm.length < 2) {
                   7121:             checkok = 0;
1.571     raeburn  7122:             msg += "$lt{'thte'}\\n";
1.569     raeburn  7123:         }
                   7124:     }
                   7125: 
1.556     raeburn  7126:     if (srchtype== 'contains') {
                   7127:         if (srchterm.length < 3) {
                   7128:             checkok = 0;
1.571     raeburn  7129:             msg += "$lt{'thet'}\\n";
1.556     raeburn  7130:         }
                   7131:     }
                   7132:     if (srchin == 'instd') {
                   7133:         if (srchdomain == '') {
                   7134:             checkok = 0;
1.571     raeburn  7135:             msg += "$lt{'yomc'}\\n";
1.556     raeburn  7136:         }
                   7137:     }
                   7138:     if (srchin == 'dom') {
                   7139:         if (srchdomain == '') {
                   7140:             checkok = 0;
1.571     raeburn  7141:             msg += "$lt{'ymcd'}\\n";
1.556     raeburn  7142:         }
                   7143:     }
                   7144:     if (srchby == 'lastfirst') {
                   7145:         if (srchterm.indexOf(",") == -1) {
                   7146:             checkok = 0;
1.571     raeburn  7147:             msg += "$lt{'whus'}\\n";
1.556     raeburn  7148:         }
                   7149:         if (srchterm.indexOf(",") == srchterm.length -1) {
                   7150:             checkok = 0;
1.571     raeburn  7151:             msg += "$lt{'whse'}\\n";
1.556     raeburn  7152:         }
                   7153:     }
                   7154:     if (checkok == 0) {
1.571     raeburn  7155:         alert("$lt{'thfo'}\\n"+msg);
1.556     raeburn  7156:         return;
                   7157:     }
                   7158:     if (checkok == 1) {
1.570     raeburn  7159:         callingForm.submit();
1.556     raeburn  7160:     }
                   7161: }
                   7162: 
                   7163: $newuserscript
                   7164: 
1.692.4.4  raeburn  7165: // ]]>
1.556     raeburn  7166: </script>
1.558     albertel 7167: 
                   7168: $new_user_create
                   7169: 
1.555     raeburn  7170: END_BLOCK
1.558     albertel 7171: 
1.692.4.9  raeburn  7172:     $output .= &Apache::lonhtmlcommon::start_pick_box().
                   7173:                &Apache::lonhtmlcommon::row_title($lt{'doma'}).
                   7174:                $domform.
                   7175:                &Apache::lonhtmlcommon::row_closure().
                   7176:                &Apache::lonhtmlcommon::row_title($lt{'usr'}).
                   7177:                $srchbysel.
                   7178:                $srchtypesel.
                   7179:                '<input type="text" size="15" name="srchterm" value="'.$srchterm.'" />'.
                   7180:                $srchinsel.
                   7181:                &Apache::lonhtmlcommon::row_closure(1).
                   7182:                &Apache::lonhtmlcommon::end_pick_box().
                   7183:                '<br />';
1.555     raeburn  7184:     return $output;
                   7185: }
                   7186: 
1.612     raeburn  7187: sub user_rule_check {
1.615     raeburn  7188:     my ($usershash,$checks,$alerts,$rulematch,$inst_results,$curr_rules,$got_rules) = @_;
1.612     raeburn  7189:     my $response;
                   7190:     if (ref($usershash) eq 'HASH') {
                   7191:         foreach my $user (keys(%{$usershash})) {
                   7192:             my ($uname,$udom) = split(/:/,$user);
                   7193:             next if ($udom eq '' || $uname eq '');
1.615     raeburn  7194:             my ($id,$newuser);
1.612     raeburn  7195:             if (ref($usershash->{$user}) eq 'HASH') {
1.615     raeburn  7196:                 $newuser = $usershash->{$user}->{'newuser'};
1.612     raeburn  7197:                 $id = $usershash->{$user}->{'id'};
                   7198:             }
                   7199:             my $inst_response;
                   7200:             if (ref($checks) eq 'HASH') {
                   7201:                 if (defined($checks->{'username'})) {
1.615     raeburn  7202:                     ($inst_response,%{$inst_results->{$user}}) = 
1.612     raeburn  7203:                         &Apache::lonnet::get_instuser($udom,$uname);
                   7204:                 } elsif (defined($checks->{'id'})) {
1.615     raeburn  7205:                     ($inst_response,%{$inst_results->{$user}}) =
1.612     raeburn  7206:                         &Apache::lonnet::get_instuser($udom,undef,$id);
                   7207:                 }
1.615     raeburn  7208:             } else {
                   7209:                 ($inst_response,%{$inst_results->{$user}}) =
                   7210:                     &Apache::lonnet::get_instuser($udom,$uname);
                   7211:                 return;
1.612     raeburn  7212:             }
1.615     raeburn  7213:             if (!$got_rules->{$udom}) {
1.612     raeburn  7214:                 my %domconfig = &Apache::lonnet::get_dom('configuration',
                   7215:                                                   ['usercreation'],$udom);
                   7216:                 if (ref($domconfig{'usercreation'}) eq 'HASH') {
1.615     raeburn  7217:                     foreach my $item ('username','id') {
1.612     raeburn  7218:                         if (ref($domconfig{'usercreation'}{$item.'_rule'}) eq 'ARRAY') {
                   7219:                             $$curr_rules{$udom}{$item} = 
                   7220:                                 $domconfig{'usercreation'}{$item.'_rule'};
1.585     raeburn  7221:                         }
                   7222:                     }
                   7223:                 }
1.615     raeburn  7224:                 $got_rules->{$udom} = 1;  
1.585     raeburn  7225:             }
1.612     raeburn  7226:             foreach my $item (keys(%{$checks})) {
                   7227:                 if (ref($$curr_rules{$udom}) eq 'HASH') {
                   7228:                     if (ref($$curr_rules{$udom}{$item}) eq 'ARRAY') {
                   7229:                         if (@{$$curr_rules{$udom}{$item}} > 0) {
                   7230:                             my %rule_check = &Apache::lonnet::inst_rulecheck($udom,$uname,$id,$item,$$curr_rules{$udom}{$item});
                   7231:                             foreach my $rule (@{$$curr_rules{$udom}{$item}}) {
                   7232:                                 if ($rule_check{$rule}) {
                   7233:                                     $$rulematch{$user}{$item} = $rule;
                   7234:                                     if ($inst_response eq 'ok') {
1.615     raeburn  7235:                                         if (ref($inst_results) eq 'HASH') {
                   7236:                                             if (ref($inst_results->{$user}) eq 'HASH') {
                   7237:                                                 if (keys(%{$inst_results->{$user}}) == 0) {
                   7238:                                                     $$alerts{$item}{$udom}{$uname} = 1;
                   7239:                                                 }
1.612     raeburn  7240:                                             }
                   7241:                                         }
1.615     raeburn  7242:                                     }
                   7243:                                     last;
1.585     raeburn  7244:                                 }
                   7245:                             }
                   7246:                         }
                   7247:                     }
                   7248:                 }
                   7249:             }
                   7250:         }
                   7251:     }
1.612     raeburn  7252:     return;
                   7253: }
                   7254: 
                   7255: sub user_rule_formats {
                   7256:     my ($domain,$domdesc,$curr_rules,$check) = @_;
                   7257:     my %text = ( 
                   7258:                  'username' => 'Usernames',
                   7259:                  'id'       => 'IDs',
                   7260:                );
                   7261:     my $output;
                   7262:     my ($rules,$ruleorder) = &Apache::lonnet::inst_userrules($domain,$check);
                   7263:     if ((ref($rules) eq 'HASH') && (ref($ruleorder) eq 'ARRAY')) {
                   7264:         if (@{$ruleorder} > 0) {
                   7265:             $output = '<br />'.&mt("$text{$check} with the following format(s) may <span class=\"LC_cusr_emph\">only</span> be used for verified users at [_1]:",$domdesc).' <ul>';
                   7266:             foreach my $rule (@{$ruleorder}) {
                   7267:                 if (ref($curr_rules) eq 'ARRAY') {
                   7268:                     if (grep(/^\Q$rule\E$/,@{$curr_rules})) {
                   7269:                         if (ref($rules->{$rule}) eq 'HASH') {
                   7270:                             $output .= '<li>'.$rules->{$rule}{'name'}.': '.
                   7271:                                         $rules->{$rule}{'desc'}.'</li>';
                   7272:                         }
                   7273:                     }
                   7274:                 }
                   7275:             }
                   7276:             $output .= '</ul>';
                   7277:         }
                   7278:     }
                   7279:     return $output;
                   7280: }
                   7281: 
                   7282: sub instrule_disallow_msg {
1.615     raeburn  7283:     my ($checkitem,$domdesc,$count,$mode) = @_;
1.612     raeburn  7284:     my $response;
                   7285:     my %text = (
                   7286:                   item   => 'username',
                   7287:                   items  => 'usernames',
                   7288:                   match  => 'matches',
                   7289:                   do     => 'does',
                   7290:                   action => 'a username',
                   7291:                   one    => 'one',
                   7292:                );
                   7293:     if ($count > 1) {
                   7294:         $text{'item'} = 'usernames';
                   7295:         $text{'match'} ='match';
                   7296:         $text{'do'} = 'do';
                   7297:         $text{'action'} = 'usernames',
                   7298:         $text{'one'} = 'ones';
                   7299:     }
                   7300:     if ($checkitem eq 'id') {
                   7301:         $text{'items'} = 'IDs';
                   7302:         $text{'item'} = 'ID';
                   7303:         $text{'action'} = 'an ID';
1.615     raeburn  7304:         if ($count > 1) {
                   7305:             $text{'item'} = 'IDs';
                   7306:             $text{'action'} = 'IDs';
                   7307:         }
1.612     raeburn  7308:     }
1.674     bisitz   7309:     $response = &mt("The $text{'item'} you chose $text{'match'} the format of $text{'items'} defined for [_1], but the $text{'item'} $text{'do'} not exist in the institutional directory.",'<span class="LC_cusr_emph">'.$domdesc.'</span>').'<br />';
1.615     raeburn  7310:     if ($mode eq 'upload') {
                   7311:         if ($checkitem eq 'username') {
                   7312:             $response .= &mt("You will need to modify your upload file so it will include $text{'action'} with a different format --  $text{'one'} that will not conflict with 'official' institutional $text{'items'}.");
                   7313:         } elsif ($checkitem eq 'id') {
1.674     bisitz   7314:             $response .= &mt("Either upload a file which includes $text{'action'} with a different format --  $text{'one'} that will not conflict with 'official' institutional $text{'items'}, or when associating fields with data columns, omit an association for the Student/Employee ID field.");
1.615     raeburn  7315:         }
1.669     raeburn  7316:     } elsif ($mode eq 'selfcreate') {
                   7317:         if ($checkitem eq 'id') {
                   7318:             $response .= &mt("You must either choose $text{'action'} with a different format --  $text{'one'} that will not conflict with 'official' institutional $text{'items'}, or leave the ID field blank.");
                   7319:         }
1.615     raeburn  7320:     } else {
                   7321:         if ($checkitem eq 'username') {
                   7322:             $response .= &mt("You must choose $text{'action'} with a different format --  $text{'one'} that will not conflict with 'official' institutional $text{'items'}.");
                   7323:         } elsif ($checkitem eq 'id') {
                   7324:             $response .= &mt("You must either choose $text{'action'} with a different format --  $text{'one'} that will not conflict with 'official' institutional $text{'items'}, or leave the ID field blank.");
                   7325:         }
1.612     raeburn  7326:     }
                   7327:     return $response;
1.585     raeburn  7328: }
                   7329: 
1.624     raeburn  7330: sub personal_data_fieldtitles {
                   7331:     my %fieldtitles = &Apache::lonlocal::texthash (
                   7332:                         id => 'Student/Employee ID',
                   7333:                         permanentemail => 'E-mail address',
                   7334:                         lastname => 'Last Name',
                   7335:                         firstname => 'First Name',
                   7336:                         middlename => 'Middle Name',
                   7337:                         generation => 'Generation',
                   7338:                         gen => 'Generation',
1.692.4.2  raeburn  7339:                         inststatus => 'Affiliation',
1.624     raeburn  7340:                    );
                   7341:     return %fieldtitles;
                   7342: }
                   7343: 
1.642     raeburn  7344: sub sorted_inst_types {
                   7345:     my ($dom) = @_;
                   7346:     my ($usertypes,$order) = &Apache::lonnet::retrieve_inst_usertypes($dom);
                   7347:     my $othertitle = &mt('All users');
                   7348:     if ($env{'request.course.id'}) {
1.668     raeburn  7349:         $othertitle  = &mt('Any users');
1.642     raeburn  7350:     }
                   7351:     my @types;
                   7352:     if (ref($order) eq 'ARRAY') {
                   7353:         @types = @{$order};
                   7354:     }
                   7355:     if (@types == 0) {
                   7356:         if (ref($usertypes) eq 'HASH') {
                   7357:             @types = sort(keys(%{$usertypes}));
                   7358:         }
                   7359:     }
                   7360:     if (keys(%{$usertypes}) > 0) {
                   7361:         $othertitle = &mt('Other users');
                   7362:     }
                   7363:     return ($othertitle,$usertypes,\@types);
                   7364: }
                   7365: 
1.645     raeburn  7366: sub get_institutional_codes {
                   7367:     my ($settings,$allcourses,$LC_code) = @_;
                   7368: # Get complete list of course sections to update
                   7369:     my @currsections = ();
                   7370:     my @currxlists = ();
                   7371:     my $coursecode = $$settings{'internal.coursecode'};
                   7372: 
                   7373:     if ($$settings{'internal.sectionnums'} ne '') {
                   7374:         @currsections = split(/,/,$$settings{'internal.sectionnums'});
                   7375:     }
                   7376: 
                   7377:     if ($$settings{'internal.crosslistings'} ne '') {
                   7378:         @currxlists = split(/,/,$$settings{'internal.crosslistings'});
                   7379:     }
                   7380: 
                   7381:     if (@currxlists > 0) {
                   7382:         foreach (@currxlists) {
                   7383:             if (m/^([^:]+):(\w*)$/) {
                   7384:                 unless (grep/^$1$/,@{$allcourses}) {
                   7385:                     push @{$allcourses},$1;
                   7386:                     $$LC_code{$1} = $2;
                   7387:                 }
                   7388:             }
                   7389:         }
                   7390:     }
                   7391:  
                   7392:     if (@currsections > 0) {
                   7393:         foreach (@currsections) {
                   7394:             if (m/^(\w+):(\w*)$/) {
                   7395:                 my $sec = $coursecode.$1;
                   7396:                 my $lc_sec = $2;
                   7397:                 unless (grep/^$sec$/,@{$allcourses}) {
                   7398:                     push @{$allcourses},$sec;
                   7399:                     $$LC_code{$sec} = $lc_sec;
                   7400:                 }
                   7401:             }
                   7402:         }
                   7403:     }
                   7404:     return;
                   7405: }
                   7406: 
1.112     bowersj2 7407: =pod
                   7408: 
1.692.4.2  raeburn  7409: =head1 Slot Helpers
                   7410: 
                   7411: =over 4
                   7412: 
                   7413: =item * sorted_slots()
                   7414: 
                   7415: Sorts an array of slot names in order of slot start time (earliest first).
                   7416: 
                   7417: Inputs:
                   7418: 
                   7419: =over 4
                   7420: 
                   7421: slotsarr  - Reference to array of unsorted slot names.
                   7422: 
                   7423: slots     - Reference to hash of hash, where outer hash keys are slot names.
                   7424: 
                   7425: =back
                   7426: 
                   7427: Returns:
                   7428: 
                   7429: =over 4
                   7430: 
                   7431: sorted   - An array of slot names sorted by the start time of the slot.
                   7432: 
                   7433: =back
                   7434: 
                   7435: =back
                   7436: 
                   7437: =cut
                   7438: 
                   7439: 
                   7440: sub sorted_slots {
                   7441:     my ($slotsarr,$slots) = @_;
                   7442:     my @sorted;
                   7443:     if ((ref($slotsarr) eq 'ARRAY') && (ref($slots) eq 'HASH')) {
                   7444:         @sorted =
                   7445:             sort {
                   7446:                      if (ref($slots->{$a}) && ref($slots->{$b})) {
                   7447:                          return $slots->{$a}{'starttime'} <=> $slots->{$b}{'starttime'}
                   7448:                      }
                   7449:                      if (ref($slots->{$a})) { return -1;}
                   7450:                      if (ref($slots->{$b})) { return 1;}
                   7451:                      return 0;
                   7452:                  } @{$slotsarr};
                   7453:     }
                   7454:     return @sorted;
                   7455: }
                   7456: 
                   7457: =pod
                   7458: 
1.549     albertel 7459: =head1 HTTP Helpers
                   7460: 
                   7461: =over 4
                   7462: 
1.648     raeburn  7463: =item * &get_unprocessed_cgi($query,$possible_names)
1.112     bowersj2 7464: 
1.258     albertel 7465: Modify the %env hash to contain unprocessed CGI form parameters held in
1.112     bowersj2 7466: $query.  The parameters listed in $possible_names (an array reference),
1.258     albertel 7467: will be set in $env{'form.name'} if they do not already exist.
1.112     bowersj2 7468: 
                   7469: Typically called with $ENV{'QUERY_STRING'} as the first parameter.  
                   7470: $possible_names is an ref to an array of form element names.  As an example:
                   7471: get_unprocessed_cgi($ENV{'QUERY_STRING'},['uname','udom']);
1.258     albertel 7472: will result in $env{'form.uname'} and $env{'form.udom'} being set.
1.112     bowersj2 7473: 
                   7474: =cut
1.1       albertel 7475: 
1.6       albertel 7476: sub get_unprocessed_cgi {
1.25      albertel 7477:   my ($query,$possible_names)= @_;
1.26      matthew  7478:   # $Apache::lonxml::debug=1;
1.356     albertel 7479:   foreach my $pair (split(/&/,$query)) {
                   7480:     my ($name, $value) = split(/=/,$pair);
1.369     www      7481:     $name = &unescape($name);
1.25      albertel 7482:     if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) {
                   7483:       $value =~ tr/+/ /;
                   7484:       $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
1.258     albertel 7485:       unless (defined($env{'form.'.$name})) { &add_to_env('form.'.$name,$value) };
1.25      albertel 7486:     }
1.16      harris41 7487:   }
1.6       albertel 7488: }
                   7489: 
1.112     bowersj2 7490: =pod
                   7491: 
1.648     raeburn  7492: =item * &cacheheader() 
1.112     bowersj2 7493: 
                   7494: returns cache-controlling header code
                   7495: 
                   7496: =cut
                   7497: 
1.7       albertel 7498: sub cacheheader {
1.258     albertel 7499:     unless ($env{'request.method'} eq 'GET') { return ''; }
1.216     albertel 7500:     my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
                   7501:     my $output .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" />
1.7       albertel 7502:                 <meta HTTP-EQUIV="Cache-control" CONTENT="no-cache" />
                   7503:                 <meta HTTP-EQUIV="Pragma" CONTENT="no-cache" />';
1.216     albertel 7504:     return $output;
1.7       albertel 7505: }
                   7506: 
1.112     bowersj2 7507: =pod
                   7508: 
1.648     raeburn  7509: =item * &no_cache($r) 
1.112     bowersj2 7510: 
                   7511: specifies header code to not have cache
                   7512: 
                   7513: =cut
                   7514: 
1.9       albertel 7515: sub no_cache {
1.216     albertel 7516:     my ($r) = @_;
                   7517:     if ($ENV{'REQUEST_METHOD'} ne 'GET' &&
1.258     albertel 7518: 	$env{'request.method'} ne 'GET') { return ''; }
1.216     albertel 7519:     my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime(time));
                   7520:     $r->no_cache(1);
                   7521:     $r->header_out("Expires" => $date);
                   7522:     $r->header_out("Pragma" => "no-cache");
1.123     www      7523: }
                   7524: 
                   7525: sub content_type {
1.181     albertel 7526:     my ($r,$type,$charset) = @_;
1.299     foxr     7527:     if ($r) {
                   7528: 	#  Note that printout.pl calls this with undef for $r.
                   7529: 	&no_cache($r);
                   7530:     }
1.258     albertel 7531:     if ($env{'browser.mathml'} && $type eq 'text/html') { $type='text/xml'; }
1.181     albertel 7532:     unless ($charset) {
                   7533: 	$charset=&Apache::lonlocal::current_encoding;
                   7534:     }
                   7535:     if ($charset) { $type.='; charset='.$charset; }
                   7536:     if ($r) {
                   7537: 	$r->content_type($type);
                   7538:     } else {
                   7539: 	print("Content-type: $type\n\n");
                   7540:     }
1.9       albertel 7541: }
1.25      albertel 7542: 
1.112     bowersj2 7543: =pod
                   7544: 
1.648     raeburn  7545: =item * &add_to_env($name,$value) 
1.112     bowersj2 7546: 
1.258     albertel 7547: adds $name to the %env hash with value
1.112     bowersj2 7548: $value, if $name already exists, the entry is converted to an array
                   7549: reference and $value is added to the array.
                   7550: 
                   7551: =cut
                   7552: 
1.25      albertel 7553: sub add_to_env {
                   7554:   my ($name,$value)=@_;
1.258     albertel 7555:   if (defined($env{$name})) {
                   7556:     if (ref($env{$name})) {
1.25      albertel 7557:       #already have multiple values
1.258     albertel 7558:       push(@{ $env{$name} },$value);
1.25      albertel 7559:     } else {
                   7560:       #first time seeing multiple values, convert hash entry to an arrayref
1.258     albertel 7561:       my $first=$env{$name};
                   7562:       undef($env{$name});
                   7563:       push(@{ $env{$name} },$first,$value);
1.25      albertel 7564:     }
                   7565:   } else {
1.258     albertel 7566:     $env{$name}=$value;
1.25      albertel 7567:   }
1.31      albertel 7568: }
1.149     albertel 7569: 
                   7570: =pod
                   7571: 
1.648     raeburn  7572: =item * &get_env_multiple($name) 
1.149     albertel 7573: 
1.258     albertel 7574: gets $name from the %env hash, it seemlessly handles the cases where multiple
1.149     albertel 7575: values may be defined and end up as an array ref.
                   7576: 
                   7577: returns an array of values
                   7578: 
                   7579: =cut
                   7580: 
                   7581: sub get_env_multiple {
                   7582:     my ($name) = @_;
                   7583:     my @values;
1.258     albertel 7584:     if (defined($env{$name})) {
1.149     albertel 7585:         # exists is it an array
1.258     albertel 7586:         if (ref($env{$name})) {
                   7587:             @values=@{ $env{$name} };
1.149     albertel 7588:         } else {
1.258     albertel 7589:             $values[0]=$env{$name};
1.149     albertel 7590:         }
                   7591:     }
                   7592:     return(@values);
                   7593: }
                   7594: 
1.660     raeburn  7595: sub ask_for_embedded_content {
                   7596:     my ($actionurl,$state,$allfiles,$codebase,$args)=@_;
                   7597:     my $upload_output = '
                   7598:    <form name="upload_embedded" action="'.$actionurl.'"
                   7599:                   method="post" enctype="multipart/form-data">';
                   7600:     $upload_output .= $state;
1.661     raeburn  7601:     $upload_output .= '<b>Upload embedded files</b>:<br />'.&start_data_table();
1.660     raeburn  7602: 
                   7603:     my $num = 0;
                   7604:     foreach my $embed_file (sort {lc($a) cmp lc($b)} keys(%{$allfiles})) {
                   7605:         $upload_output .= &start_data_table_row().
                   7606:             '<td>'.$embed_file.'</td><td>';
                   7607:         if ($args->{'ignore_remote_references'}
                   7608:             && $embed_file =~ m{^\w+://}) {
                   7609:             $upload_output.='<span class="LC_warning">'.&mt("URL points to other server.").'</span>';
                   7610:         } elsif ($args->{'error_on_invalid_names'}
                   7611:             && $embed_file ne &Apache::lonnet::clean_filename($embed_file,{'keep_path' => 1,})) {
                   7612: 
                   7613:             $upload_output.='<span class="LC_warning">'.&mt("Invalid characters").'</span>';
                   7614: 
                   7615:         } else {
                   7616:             $upload_output .='
1.661     raeburn  7617:            <input name="embedded_item_'.$num.'" type="file" value="" />
1.660     raeburn  7618:            <input name="embedded_orig_'.$num.'" type="hidden" value="'.&escape($embed_file).'" />';
                   7619:             my $attrib = join(':',@{$$allfiles{$embed_file}});
                   7620:             $upload_output .=
                   7621:                 "\n\t\t".
                   7622:                 '<input name="embedded_attrib_'.$num.'" type="hidden" value="'.
                   7623:                 $attrib.'" />';
                   7624:             if (exists($$codebase{$embed_file})) {
                   7625:                 $upload_output .=
                   7626:                     "\n\t\t".
                   7627:                     '<input name="codebase_'.$num.'" type="hidden" value="'.
                   7628:                     &escape($$codebase{$embed_file}).'" />';
                   7629:             }
                   7630:         }
                   7631:         $upload_output .= '</td>'.&Apache::loncommon::end_data_table_row();
                   7632:         $num++;
                   7633:     }
                   7634:     $upload_output .= &Apache::loncommon::end_data_table().'<br />
                   7635:    <input type ="hidden" name="number_embedded_items" value="'.$num.'" />
                   7636:    <input type ="submit" value="'.&mt('Upload Listed Files').'" />
                   7637:    '.&mt('(only files for which a location has been provided will be uploaded)').'
                   7638:    </form>';
                   7639:     return $upload_output;
                   7640: }
                   7641: 
1.661     raeburn  7642: sub upload_embedded {
                   7643:     my ($context,$dirpath,$uname,$udom,$dir_root,$url_root,$group,$disk_quota,
                   7644:         $current_disk_usage) = @_;
                   7645:     my $output;
                   7646:     for (my $i=0; $i<$env{'form.number_embedded_items'}; $i++) {
                   7647:         next if (!exists($env{'form.embedded_item_'.$i.'.filename'}));
                   7648:         my $orig_uploaded_filename =
                   7649:             $env{'form.embedded_item_'.$i.'.filename'};
                   7650: 
                   7651:         $env{'form.embedded_orig_'.$i} =
                   7652:             &unescape($env{'form.embedded_orig_'.$i});
                   7653:         my ($path,$fname) =
                   7654:             ($env{'form.embedded_orig_'.$i} =~ m{(.*/)([^/]*)});
                   7655:         # no path, whole string is fname
                   7656:         if (!$fname) { $fname = $env{'form.embedded_orig_'.$i} };
                   7657: 
                   7658:         $path = $env{'form.currentpath'}.$path;
                   7659:         $fname = &Apache::lonnet::clean_filename($fname);
                   7660:         # See if there is anything left
                   7661:         next if ($fname eq '');
                   7662: 
                   7663:         # Check if file already exists as a file or directory.
                   7664:         my ($state,$msg);
                   7665:         if ($context eq 'portfolio') {
                   7666:             my $port_path = $dirpath;
                   7667:             if ($group ne '') {
                   7668:                 $port_path = "groups/$group/$port_path";
                   7669:             }
                   7670:             ($state,$msg) = &check_for_upload($path,$fname,$group,'embedded_item_'.$i,
                   7671:                                               $dir_root,$port_path,$disk_quota,
                   7672:                                               $current_disk_usage,$uname,$udom);
                   7673:             if ($state eq 'will_exceed_quota'
                   7674:                 || $state eq 'file_locked'
                   7675:                 || $state eq 'file_exists' ) {
                   7676:                 $output .= $msg;
                   7677:                 next;
                   7678:             }
                   7679:         } elsif (($context eq 'author') || ($context eq 'testbank')) {
                   7680:             ($state,$msg) = &check_for_existing($path,$fname,'embedded_item_'.$i);
                   7681:             if ($state eq 'exists') {
                   7682:                 $output .= $msg;
                   7683:                 next;
                   7684:             }
                   7685:         }
                   7686:         # Check if extension is valid
                   7687:         if (($fname =~ /\.(\w+)$/) &&
                   7688:             (&Apache::loncommon::fileembstyle($1) eq 'hdn')) {
                   7689:             $output .= &mt('Invalid file extension ([_1]) - reserved for LONCAPA use - rename the file with a different extension and re-upload. ',$1);
                   7690:             next;
                   7691:         } elsif (($fname =~ /\.(\w+)$/) &&
                   7692:                  (!defined(&Apache::loncommon::fileembstyle($1)))) {
                   7693:             $output .= &mt('Unrecognized file extension ([_1]) - rename the file with a proper extension and re-upload.',$1);
                   7694:             next;
                   7695:         } elsif ($fname=~/\.(\d+)\.(\w+)$/) {
                   7696:             $output .= &mt('File name not allowed - rename the file to remove the number immediately before the file extension([_1]) and re-upload.',$2);
                   7697:             next;
                   7698:         }
                   7699: 
                   7700:         $env{'form.embedded_item_'.$i.'.filename'}=$fname;
                   7701:         if ($context eq 'portfolio') {
                   7702:             my $result=
                   7703:                 &Apache::lonnet::userfileupload('embedded_item_'.$i,'',
                   7704:                                                 $dirpath.$path);
                   7705:             if ($result !~ m|^/uploaded/|) {
                   7706:                 $output .= '<span class="LC_error">'
                   7707:                       .&mt('An error occurred ([_1]) while trying to upload [_2] for embedded element [_3].'
                   7708:                            ,$result,$orig_uploaded_filename,$env{'form.embedded_orig_'.$i})
                   7709:                       .'</span><br />';
                   7710:                 next;
                   7711:             } else {
                   7712:                 $output .= '<p>'.&mt('Uploaded [_1]','<span class="LC_filename">'.
                   7713:                            $path.$fname.'</span>').'</p>';     
                   7714:             }
                   7715:         } else {
                   7716: # Save the file
                   7717:             my $target = $env{'form.embedded_item_'.$i};
                   7718:             my $fullpath = $dir_root.$dirpath.'/'.$path;
                   7719:             my $dest = $fullpath.$fname;
                   7720:             my $url = $url_root.$dirpath.'/'.$path.$fname;
                   7721:             my @parts=split(/\//,$fullpath);
                   7722:             my $count;
                   7723:             my $filepath = $dir_root;
                   7724:             for ($count=4;$count<=$#parts;$count++) {
                   7725:                 $filepath .= "/$parts[$count]";
                   7726:                 if ((-e $filepath)!=1) {
                   7727:                     mkdir($filepath,0770);
                   7728:                 }
                   7729:             }
                   7730:             my $fh;
                   7731:             if (!open($fh,'>'.$dest)) {
                   7732:                 &Apache::lonnet::logthis('Failed to create '.$dest);
                   7733:                 $output .= '<span class="LC_error">'.
                   7734:                            &mt('An error occurred while trying to upload [_1] for embedded element [_2].',$orig_uploaded_filename,$env{'form.embedded_orig_'.$i}).
                   7735:                            '</span><br />';
                   7736:             } else {
                   7737:                 if (!print $fh $env{'form.embedded_item_'.$i}) {
                   7738:                     &Apache::lonnet::logthis('Failed to write to '.$dest);
                   7739:                     $output .= '<span class="LC_error">'.
                   7740:                               &mt('An error occurred while writing the file [_1] for embedded element [_2].',$orig_uploaded_filename,$env{'form.embedded_orig_'.$i}).
                   7741:                               '</span><br />';
                   7742:                 } else {
                   7743:                     if ($context eq 'testbank') {
                   7744:                         $output .= &mt('Embedded file uploaded successfully:').
                   7745:                                    '&nbsp;<a href="'.$url.'">'.
                   7746:                                    $orig_uploaded_filename.'</a><br />';
                   7747:                     } else {
                   7748:                         $output .= '<font size="+2">'.
                   7749:                                    &mt('View embedded file: [_1]','<a href="'.$url.'">'.
                   7750:                                    $orig_uploaded_filename.'</a>').'</font><br />';
                   7751:                     }
                   7752:                 }
                   7753:                 close($fh);
                   7754:             }
                   7755:         }
                   7756:     }
                   7757:     return $output;
                   7758: }
                   7759: 
                   7760: sub check_for_existing {
                   7761:     my ($path,$fname,$element) = @_;
                   7762:     my ($state,$msg);
                   7763:     if (-d $path.'/'.$fname) {
                   7764:         $state = 'exists';
                   7765:         $msg = &mt('Unable to upload [_1]. A directory by that name was found in [_2].','<span class="LC_filename">'.$fname.'</span>',$path);
                   7766:     } elsif (-e $path.'/'.$fname) {
                   7767:         $state = 'exists';
                   7768:         $msg = &mt('Unable to upload [_1]. A file by that name was found in [_2].','<span class="LC_filename">'.$fname.'</span>',$path);
                   7769:     }
                   7770:     if ($state eq 'exists') {
                   7771:         $msg = '<span class="LC_error">'.$msg.'</span><br />';
                   7772:     }
                   7773:     return ($state,$msg);
                   7774: }
                   7775: 
                   7776: sub check_for_upload {
                   7777:     my ($path,$fname,$group,$element,$portfolio_root,$port_path,
                   7778:         $disk_quota,$current_disk_usage,$uname,$udom) = @_;
                   7779:     my $filesize = (length($env{'form.'.$element})) / 1000; #express in k (1024?)
                   7780:     my $getpropath = 1;
                   7781:     my @dir_list = &Apache::lonnet::dirlist($portfolio_root.$path,$udom,$uname,
                   7782:                                             $getpropath);
                   7783:     my $found_file = 0;
                   7784:     my $locked_file = 0;
                   7785:     foreach my $line (@dir_list) {
                   7786:         my ($file_name)=split(/\&/,$line,2);
                   7787:         if ($file_name eq $fname){
                   7788:             $file_name = $path.$file_name;
                   7789:             if ($group ne '') {
                   7790:                 $file_name = $group.$file_name;
                   7791:             }
                   7792:             $found_file = 1;
                   7793:             if (&Apache::lonnet::is_locked($file_name,$udom,$uname) eq 'true') {
                   7794:                 $locked_file = 1;
                   7795:             }
                   7796:         }
                   7797:     }
                   7798:     if (($current_disk_usage + $filesize) > $disk_quota){
                   7799:         my $msg = '<span class="LC_error">'.
                   7800:                 &mt('Unable to upload [_1]. (size = [_2] kilobytes). Disk quota will be exceeded.','<span class="LC_filename">'.$fname.'</span>',$filesize).'</span>'.
                   7801:                   '<br />'.&mt('Disk quota is [_1] kilobytes. Your current disk usage is [_2] kilobytes.',$disk_quota,$current_disk_usage);
                   7802:         return ('will_exceed_quota',$msg);
                   7803:     } elsif ($found_file) {
                   7804:         if ($locked_file) {
                   7805:             my $msg = '<span class="LC_error">';
                   7806:             $msg .= &mt('Unable to upload [_1]. A locked file by that name was found in [_2].','<span class="LC_filename">'.$fname.'</span>','<span class="LC_filename">'.$port_path.$env{'form.currentpath'}.'</span>');
                   7807:             $msg .= '</span><br />';
                   7808:             $msg .= &mt('You will be able to rename or delete existing [_1] after a grade has been assigned.','<span class="LC_filename">'.$fname.'</span>');
                   7809:             return ('file_locked',$msg);
                   7810:         } else {
                   7811:             my $msg = '<span class="LC_error">';
                   7812:             $msg .= &mt('Unable to upload [_1]. A file by that name was found in [_2].','<span class="LC_filename">'.$fname.'</span>',$port_path.$env{'form.currentpath'});
                   7813:             $msg .= '</span>';
                   7814:             $msg .= '<br />';
                   7815:             $msg .= &mt('To upload, rename or delete existing [_1] in [_2].','<span class="LC_filename">'.$fname.'</span>', $port_path.$env{'form.currentpath'});
                   7816:             return ('file_exists',$msg);
                   7817:         }
                   7818:     }
                   7819: }
                   7820: 
1.31      albertel 7821: 
1.41      ng       7822: =pod
1.45      matthew  7823: 
1.464     albertel 7824: =back
1.41      ng       7825: 
1.112     bowersj2 7826: =head1 CSV Upload/Handling functions
1.38      albertel 7827: 
1.41      ng       7828: =over 4
                   7829: 
1.648     raeburn  7830: =item * &upfile_store($r)
1.41      ng       7831: 
                   7832: Store uploaded file, $r should be the HTTP Request object,
1.258     albertel 7833: needs $env{'form.upfile'}
1.41      ng       7834: returns $datatoken to be put into hidden field
                   7835: 
                   7836: =cut
1.31      albertel 7837: 
                   7838: sub upfile_store {
                   7839:     my $r=shift;
1.258     albertel 7840:     $env{'form.upfile'}=~s/\r/\n/gs;
                   7841:     $env{'form.upfile'}=~s/\f/\n/gs;
                   7842:     $env{'form.upfile'}=~s/\n+/\n/gs;
                   7843:     $env{'form.upfile'}=~s/\n+$//gs;
1.31      albertel 7844: 
1.258     albertel 7845:     my $datatoken=$env{'user.name'}.'_'.$env{'user.domain'}.
                   7846: 	'_enroll_'.$env{'request.course.id'}.'_'.time.'_'.$$;
1.31      albertel 7847:     {
1.158     raeburn  7848:         my $datafile = $r->dir_config('lonDaemons').
                   7849:                            '/tmp/'.$datatoken.'.tmp';
                   7850:         if ( open(my $fh,">$datafile") ) {
1.258     albertel 7851:             print $fh $env{'form.upfile'};
1.158     raeburn  7852:             close($fh);
                   7853:         }
1.31      albertel 7854:     }
                   7855:     return $datatoken;
                   7856: }
                   7857: 
1.56      matthew  7858: =pod
                   7859: 
1.648     raeburn  7860: =item * &load_tmp_file($r)
1.41      ng       7861: 
                   7862: Load uploaded file from tmp, $r should be the HTTP Request object,
1.258     albertel 7863: needs $env{'form.datatoken'},
                   7864: sets $env{'form.upfile'} to the contents of the file
1.41      ng       7865: 
                   7866: =cut
1.31      albertel 7867: 
                   7868: sub load_tmp_file {
                   7869:     my $r=shift;
                   7870:     my @studentdata=();
                   7871:     {
1.158     raeburn  7872:         my $studentfile = $r->dir_config('lonDaemons').
1.258     albertel 7873:                               '/tmp/'.$env{'form.datatoken'}.'.tmp';
1.158     raeburn  7874:         if ( open(my $fh,"<$studentfile") ) {
                   7875:             @studentdata=<$fh>;
                   7876:             close($fh);
                   7877:         }
1.31      albertel 7878:     }
1.258     albertel 7879:     $env{'form.upfile'}=join('',@studentdata);
1.31      albertel 7880: }
                   7881: 
1.56      matthew  7882: =pod
                   7883: 
1.648     raeburn  7884: =item * &upfile_record_sep()
1.41      ng       7885: 
                   7886: Separate uploaded file into records
                   7887: returns array of records,
1.258     albertel 7888: needs $env{'form.upfile'} and $env{'form.upfiletype'}
1.41      ng       7889: 
                   7890: =cut
1.31      albertel 7891: 
                   7892: sub upfile_record_sep {
1.258     albertel 7893:     if ($env{'form.upfiletype'} eq 'xml') {
1.31      albertel 7894:     } else {
1.248     albertel 7895: 	my @records;
1.258     albertel 7896: 	foreach my $line (split(/\n/,$env{'form.upfile'})) {
1.248     albertel 7897: 	    if ($line=~/^\s*$/) { next; }
                   7898: 	    push(@records,$line);
                   7899: 	}
                   7900: 	return @records;
1.31      albertel 7901:     }
                   7902: }
                   7903: 
1.56      matthew  7904: =pod
                   7905: 
1.648     raeburn  7906: =item * &record_sep($record)
1.41      ng       7907: 
1.258     albertel 7908: Separate a record into fields $record should be an item from the upfile_record_sep(), needs $env{'form.upfiletype'}
1.41      ng       7909: 
                   7910: =cut
                   7911: 
1.263     www      7912: sub takeleft {
                   7913:     my $index=shift;
                   7914:     return substr('0000'.$index,-4,4);
                   7915: }
                   7916: 
1.31      albertel 7917: sub record_sep {
                   7918:     my $record=shift;
                   7919:     my %components=();
1.258     albertel 7920:     if ($env{'form.upfiletype'} eq 'xml') {
                   7921:     } elsif ($env{'form.upfiletype'} eq 'space') {
1.31      albertel 7922:         my $i=0;
1.356     albertel 7923:         foreach my $field (split(/\s+/,$record)) {
1.31      albertel 7924:             $field=~s/^(\"|\')//;
                   7925:             $field=~s/(\"|\')$//;
1.263     www      7926:             $components{&takeleft($i)}=$field;
1.31      albertel 7927:             $i++;
                   7928:         }
1.258     albertel 7929:     } elsif ($env{'form.upfiletype'} eq 'tab') {
1.31      albertel 7930:         my $i=0;
1.356     albertel 7931:         foreach my $field (split(/\t/,$record)) {
1.31      albertel 7932:             $field=~s/^(\"|\')//;
                   7933:             $field=~s/(\"|\')$//;
1.263     www      7934:             $components{&takeleft($i)}=$field;
1.31      albertel 7935:             $i++;
                   7936:         }
                   7937:     } else {
1.561     www      7938:         my $separator=',';
1.480     banghart 7939:         if ($env{'form.upfiletype'} eq 'semisv') {
1.561     www      7940:             $separator=';';
1.480     banghart 7941:         }
1.31      albertel 7942:         my $i=0;
1.561     www      7943: # the character we are looking for to indicate the end of a quote or a record 
                   7944:         my $looking_for=$separator;
                   7945: # do not add the characters to the fields
                   7946:         my $ignore=0;
                   7947: # we just encountered a separator (or the beginning of the record)
                   7948:         my $just_found_separator=1;
                   7949: # store the field we are working on here
                   7950:         my $field='';
                   7951: # work our way through all characters in record
                   7952:         foreach my $character ($record=~/(.)/g) {
                   7953:             if ($character eq $looking_for) {
                   7954:                if ($character ne $separator) {
                   7955: # Found the end of a quote, again looking for separator
                   7956:                   $looking_for=$separator;
                   7957:                   $ignore=1;
                   7958:                } else {
                   7959: # Found a separator, store away what we got
                   7960:                   $components{&takeleft($i)}=$field;
                   7961: 	          $i++;
                   7962:                   $just_found_separator=1;
                   7963:                   $ignore=0;
                   7964:                   $field='';
                   7965:                }
                   7966:                next;
                   7967:             }
                   7968: # single or double quotation marks after a separator indicate beginning of a quote
                   7969: # we are now looking for the end of the quote and need to ignore separators
                   7970:             if ((($character eq '"') || ($character eq "'")) && ($just_found_separator))  {
                   7971:                $looking_for=$character;
                   7972:                next;
                   7973:             }
                   7974: # ignore would be true after we reached the end of a quote
                   7975:             if ($ignore) { next; }
                   7976:             if (($just_found_separator) && ($character=~/\s/)) { next; }
                   7977:             $field.=$character;
                   7978:             $just_found_separator=0; 
1.31      albertel 7979:         }
1.561     www      7980: # catch the very last entry, since we never encountered the separator
                   7981:         $components{&takeleft($i)}=$field;
1.31      albertel 7982:     }
                   7983:     return %components;
                   7984: }
                   7985: 
1.144     matthew  7986: ######################################################
                   7987: ######################################################
                   7988: 
1.56      matthew  7989: =pod
                   7990: 
1.648     raeburn  7991: =item * &upfile_select_html()
1.41      ng       7992: 
1.144     matthew  7993: Return HTML code to select a file from the users machine and specify 
                   7994: the file type.
1.41      ng       7995: 
                   7996: =cut
                   7997: 
1.144     matthew  7998: ######################################################
                   7999: ######################################################
1.31      albertel 8000: sub upfile_select_html {
1.144     matthew  8001:     my %Types = (
                   8002:                  csv   => &mt('CSV (comma separated values, spreadsheet)'),
1.480     banghart 8003:                  semisv => &mt('Semicolon separated values'),
1.144     matthew  8004:                  space => &mt('Space separated'),
                   8005:                  tab   => &mt('Tabulator separated'),
                   8006: #                 xml   => &mt('HTML/XML'),
                   8007:                  );
                   8008:     my $Str = '<input type="file" name="upfile" size="50" />'.
1.692.4.2  raeburn  8009:         '<br />'.&mt('Type').': <select name="upfiletype">';
1.144     matthew  8010:     foreach my $type (sort(keys(%Types))) {
                   8011:         $Str .= '<option value="'.$type.'" >'.$Types{$type}."</option>\n";
                   8012:     }
                   8013:     $Str .= "</select>\n";
                   8014:     return $Str;
1.31      albertel 8015: }
                   8016: 
1.301     albertel 8017: sub get_samples {
                   8018:     my ($records,$toget) = @_;
                   8019:     my @samples=({});
                   8020:     my $got=0;
                   8021:     foreach my $rec (@$records) {
                   8022: 	my %temp = &record_sep($rec);
                   8023: 	if (! grep(/\S/, values(%temp))) { next; }
                   8024: 	if (%temp) {
                   8025: 	    $samples[$got]=\%temp;
                   8026: 	    $got++;
                   8027: 	    if ($got == $toget) { last; }
                   8028: 	}
                   8029:     }
                   8030:     return \@samples;
                   8031: }
                   8032: 
1.144     matthew  8033: ######################################################
                   8034: ######################################################
                   8035: 
1.56      matthew  8036: =pod
                   8037: 
1.648     raeburn  8038: =item * &csv_print_samples($r,$records)
1.41      ng       8039: 
                   8040: Prints a table of sample values from each column uploaded $r is an
                   8041: Apache Request ref, $records is an arrayref from
                   8042: &Apache::loncommon::upfile_record_sep
                   8043: 
                   8044: =cut
                   8045: 
1.144     matthew  8046: ######################################################
                   8047: ######################################################
1.31      albertel 8048: sub csv_print_samples {
                   8049:     my ($r,$records) = @_;
1.662     bisitz   8050:     my $samples = &get_samples($records,5);
1.301     albertel 8051: 
1.594     raeburn  8052:     $r->print(&mt('Samples').'<br />'.&start_data_table().
                   8053:               &start_data_table_header_row());
1.356     albertel 8054:     foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) { 
1.692.4.6  raeburn  8055:         $r->print('<th>'.&mt('Column [_1]',($sample+1)).'</th>');
                   8056:     }
1.594     raeburn  8057:     $r->print(&end_data_table_header_row());
1.301     albertel 8058:     foreach my $hash (@$samples) {
1.594     raeburn  8059: 	$r->print(&start_data_table_row());
1.356     albertel 8060: 	foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
1.31      albertel 8061: 	    $r->print('<td>');
1.356     albertel 8062: 	    if (defined($$hash{$sample})) { $r->print($$hash{$sample}); }
1.31      albertel 8063: 	    $r->print('</td>');
                   8064: 	}
1.594     raeburn  8065: 	$r->print(&end_data_table_row());
1.31      albertel 8066:     }
1.594     raeburn  8067:     $r->print(&end_data_table().'<br />'."\n");
1.31      albertel 8068: }
                   8069: 
1.144     matthew  8070: ######################################################
                   8071: ######################################################
                   8072: 
1.56      matthew  8073: =pod
                   8074: 
1.648     raeburn  8075: =item * &csv_print_select_table($r,$records,$d)
1.41      ng       8076: 
                   8077: Prints a table to create associations between values and table columns.
1.144     matthew  8078: 
1.41      ng       8079: $r is an Apache Request ref,
                   8080: $records is an arrayref from &Apache::loncommon::upfile_record_sep,
1.174     matthew  8081: $d is an array of 2 element arrays (internal name, displayed name,defaultcol)
1.41      ng       8082: 
                   8083: =cut
                   8084: 
1.144     matthew  8085: ######################################################
                   8086: ######################################################
1.31      albertel 8087: sub csv_print_select_table {
                   8088:     my ($r,$records,$d) = @_;
1.301     albertel 8089:     my $i=0;
                   8090:     my $samples = &get_samples($records,1);
1.144     matthew  8091:     $r->print(&mt('Associate columns with student attributes.')."\n".
1.594     raeburn  8092: 	      &start_data_table().&start_data_table_header_row().
1.144     matthew  8093:               '<th>'.&mt('Attribute').'</th>'.
1.594     raeburn  8094:               '<th>'.&mt('Column').'</th>'.
                   8095:               &end_data_table_header_row()."\n");
1.356     albertel 8096:     foreach my $array_ref (@$d) {
                   8097: 	my ($value,$display,$defaultcol)=@{ $array_ref };
1.689     bisitz   8098: 	$r->print(&start_data_table_row().'<td>'.$display.'</td>');
1.31      albertel 8099: 
1.692.4.8  raeburn  8100: 	$r->print('<td><select name"f'.$i.'"'.
1.32      matthew  8101: 		  ' onchange="javascript:flip(this.form,'.$i.');">');
1.31      albertel 8102: 	$r->print('<option value="none"></option>');
1.356     albertel 8103: 	foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
                   8104: 	    $r->print('<option value="'.$sample.'"'.
                   8105:                       ($sample eq $defaultcol ? ' selected="selected" ' : '').
1.662     bisitz   8106:                       '>'.&mt('Column [_1]',($sample+1)).'</option>');
1.31      albertel 8107: 	}
1.594     raeburn  8108: 	$r->print('</select></td>'.&end_data_table_row()."\n");
1.31      albertel 8109: 	$i++;
                   8110:     }
1.594     raeburn  8111:     $r->print(&end_data_table());
1.31      albertel 8112:     $i--;
                   8113:     return $i;
                   8114: }
1.56      matthew  8115: 
1.144     matthew  8116: ######################################################
                   8117: ######################################################
                   8118: 
1.56      matthew  8119: =pod
1.31      albertel 8120: 
1.648     raeburn  8121: =item * &csv_samples_select_table($r,$records,$d)
1.41      ng       8122: 
                   8123: Prints a table of sample values from the upload and can make associate samples to internal names.
                   8124: 
                   8125: $r is an Apache Request ref,
                   8126: $records is an arrayref from &Apache::loncommon::upfile_record_sep,
                   8127: $d is an array of 2 element arrays (internal name, displayed name)
                   8128: 
                   8129: =cut
                   8130: 
1.144     matthew  8131: ######################################################
                   8132: ######################################################
1.31      albertel 8133: sub csv_samples_select_table {
                   8134:     my ($r,$records,$d) = @_;
                   8135:     my $i=0;
1.144     matthew  8136:     #
1.662     bisitz   8137:     my $max_samples = 5;
                   8138:     my $samples = &get_samples($records,$max_samples);
1.594     raeburn  8139:     $r->print(&start_data_table().
                   8140:               &start_data_table_header_row().'<th>'.
                   8141:               &mt('Field').'</th><th>'.&mt('Samples').'</th>'.
                   8142:               &end_data_table_header_row());
1.301     albertel 8143: 
                   8144:     foreach my $key (sort(keys(%{ $samples->[0] }))) {
1.594     raeburn  8145: 	$r->print(&start_data_table_row().'<td><select name="f'.$i.'"'.
1.32      matthew  8146: 		  ' onchange="javascript:flip(this.form,'.$i.');">');
1.301     albertel 8147: 	foreach my $option (@$d) {
                   8148: 	    my ($value,$display,$defaultcol)=@{ $option };
1.174     matthew  8149: 	    $r->print('<option value="'.$value.'"'.
1.253     albertel 8150:                       ($i eq $defaultcol ? ' selected="selected" ':'').'>'.
1.174     matthew  8151:                       $display.'</option>');
1.31      albertel 8152: 	}
                   8153: 	$r->print('</select></td><td>');
1.662     bisitz   8154: 	foreach my $line (0..($max_samples-1)) {
1.301     albertel 8155: 	    if (defined($samples->[$line]{$key})) { 
                   8156: 		$r->print($samples->[$line]{$key}."<br />\n"); 
                   8157: 	    }
                   8158: 	}
1.594     raeburn  8159: 	$r->print('</td>'.&end_data_table_row());
1.31      albertel 8160: 	$i++;
                   8161:     }
1.594     raeburn  8162:     $r->print(&end_data_table());
1.31      albertel 8163:     $i--;
                   8164:     return($i);
1.115     matthew  8165: }
                   8166: 
1.144     matthew  8167: ######################################################
                   8168: ######################################################
                   8169: 
1.115     matthew  8170: =pod
                   8171: 
1.648     raeburn  8172: =item * &clean_excel_name($name)
1.115     matthew  8173: 
                   8174: Returns a replacement for $name which does not contain any illegal characters.
                   8175: 
                   8176: =cut
                   8177: 
1.144     matthew  8178: ######################################################
                   8179: ######################################################
1.115     matthew  8180: sub clean_excel_name {
                   8181:     my ($name) = @_;
                   8182:     $name =~ s/[:\*\?\/\\]//g;
                   8183:     if (length($name) > 31) {
                   8184:         $name = substr($name,0,31);
                   8185:     }
                   8186:     return $name;
1.25      albertel 8187: }
1.84      albertel 8188: 
1.85      albertel 8189: =pod
                   8190: 
1.648     raeburn  8191: =item * &check_if_partid_hidden($id,$symb,$udom,$uname)
1.85      albertel 8192: 
                   8193: Returns either 1 or undef
                   8194: 
                   8195: 1 if the part is to be hidden, undef if it is to be shown
                   8196: 
                   8197: Arguments are:
                   8198: 
                   8199: $id the id of the part to be checked
                   8200: $symb, optional the symb of the resource to check
                   8201: $udom, optional the domain of the user to check for
                   8202: $uname, optional the username of the user to check for
                   8203: 
                   8204: =cut
1.84      albertel 8205: 
                   8206: sub check_if_partid_hidden {
                   8207:     my ($id,$symb,$udom,$uname) = @_;
1.133     albertel 8208:     my $hiddenparts=&Apache::lonnet::EXT('resource.0.hiddenparts',
1.84      albertel 8209: 					 $symb,$udom,$uname);
1.141     albertel 8210:     my $truth=1;
                   8211:     #if the string starts with !, then the list is the list to show not hide
                   8212:     if ($hiddenparts=~s/^\s*!//) { $truth=undef; }
1.84      albertel 8213:     my @hiddenlist=split(/,/,$hiddenparts);
                   8214:     foreach my $checkid (@hiddenlist) {
1.141     albertel 8215: 	if ($checkid =~ /^\s*\Q$id\E\s*$/) { return $truth; }
1.84      albertel 8216:     }
1.141     albertel 8217:     return !$truth;
1.84      albertel 8218: }
1.127     matthew  8219: 
1.138     matthew  8220: 
                   8221: ############################################################
                   8222: ############################################################
                   8223: 
                   8224: =pod
                   8225: 
1.157     matthew  8226: =back 
                   8227: 
1.138     matthew  8228: =head1 cgi-bin script and graphing routines
                   8229: 
1.157     matthew  8230: =over 4
                   8231: 
1.648     raeburn  8232: =item * &get_cgi_id()
1.138     matthew  8233: 
                   8234: Inputs: none
                   8235: 
                   8236: Returns an id which can be used to pass environment variables
                   8237: to various cgi-bin scripts.  These environment variables will
                   8238: be removed from the users environment after a given time by
                   8239: the routine &Apache::lonnet::transfer_profile_to_env.
                   8240: 
                   8241: =cut
                   8242: 
                   8243: ############################################################
                   8244: ############################################################
1.152     albertel 8245: my $uniq=0;
1.136     matthew  8246: sub get_cgi_id {
1.154     albertel 8247:     $uniq=($uniq+1)%100000;
1.280     albertel 8248:     return (time.'_'.$$.'_'.$uniq);
1.136     matthew  8249: }
                   8250: 
1.127     matthew  8251: ############################################################
                   8252: ############################################################
                   8253: 
                   8254: =pod
                   8255: 
1.648     raeburn  8256: =item * &DrawBarGraph()
1.127     matthew  8257: 
1.138     matthew  8258: Facilitates the plotting of data in a (stacked) bar graph.
                   8259: Puts plot definition data into the users environment in order for 
                   8260: graph.png to plot it.  Returns an <img> tag for the plot.
                   8261: The bars on the plot are labeled '1','2',...,'n'.
                   8262: 
                   8263: Inputs:
                   8264: 
                   8265: =over 4
                   8266: 
                   8267: =item $Title: string, the title of the plot
                   8268: 
                   8269: =item $xlabel: string, text describing the X-axis of the plot
                   8270: 
                   8271: =item $ylabel: string, text describing the Y-axis of the plot
                   8272: 
                   8273: =item $Max: scalar, the maximum Y value to use in the plot
                   8274: If $Max is < any data point, the graph will not be rendered.
                   8275: 
1.140     matthew  8276: =item $colors: array ref holding the colors to be used for the data sets when
1.138     matthew  8277: they are plotted.  If undefined, default values will be used.
                   8278: 
1.178     matthew  8279: =item $labels: array ref holding the labels to use on the x-axis for the bars.
                   8280: 
1.138     matthew  8281: =item @Values: An array of array references.  Each array reference holds data
                   8282: to be plotted in a stacked bar chart.
                   8283: 
1.239     matthew  8284: =item If the final element of @Values is a hash reference the key/value
                   8285: pairs will be added to the graph definition.
                   8286: 
1.138     matthew  8287: =back
                   8288: 
                   8289: Returns:
                   8290: 
                   8291: An <img> tag which references graph.png and the appropriate identifying
                   8292: information for the plot.
                   8293: 
1.127     matthew  8294: =cut
                   8295: 
                   8296: ############################################################
                   8297: ############################################################
1.134     matthew  8298: sub DrawBarGraph {
1.178     matthew  8299:     my ($Title,$xlabel,$ylabel,$Max,$colors,$labels,@Values)=@_;
1.134     matthew  8300:     #
                   8301:     if (! defined($colors)) {
                   8302:         $colors = ['#33ff00', 
                   8303:                   '#0033cc', '#990000', '#aaaa66', '#663399', '#ff9933',
                   8304:                   '#66ccff', '#ff9999', '#cccc33', '#660000', '#33cc66',
                   8305:                   ]; 
                   8306:     }
1.228     matthew  8307:     my $extra_settings = {};
                   8308:     if (ref($Values[-1]) eq 'HASH') {
                   8309:         $extra_settings = pop(@Values);
                   8310:     }
1.127     matthew  8311:     #
1.136     matthew  8312:     my $identifier = &get_cgi_id();
                   8313:     my $id = 'cgi.'.$identifier;        
1.129     matthew  8314:     if (! @Values || ref($Values[0]) ne 'ARRAY') {
1.127     matthew  8315:         return '';
                   8316:     }
1.225     matthew  8317:     #
                   8318:     my @Labels;
                   8319:     if (defined($labels)) {
                   8320:         @Labels = @$labels;
                   8321:     } else {
                   8322:         for (my $i=0;$i<@{$Values[0]};$i++) {
                   8323:             push (@Labels,$i+1);
                   8324:         }
                   8325:     }
                   8326:     #
1.129     matthew  8327:     my $NumBars = scalar(@{$Values[0]});
1.225     matthew  8328:     if ($NumBars < scalar(@Labels)) { $NumBars = scalar(@Labels); }
1.129     matthew  8329:     my %ValuesHash;
                   8330:     my $NumSets=1;
                   8331:     foreach my $array (@Values) {
                   8332:         next if (! ref($array));
1.136     matthew  8333:         $ValuesHash{$id.'.data.'.$NumSets++} = 
1.132     matthew  8334:             join(',',@$array);
1.129     matthew  8335:     }
1.127     matthew  8336:     #
1.136     matthew  8337:     my ($height,$width,$xskip,$bar_width) = (200,120,1,15);
1.225     matthew  8338:     if ($NumBars < 3) {
                   8339:         $width = 120+$NumBars*32;
1.220     matthew  8340:         $xskip = 1;
1.225     matthew  8341:         $bar_width = 30;
                   8342:     } elsif ($NumBars < 5) {
                   8343:         $width = 120+$NumBars*20;
                   8344:         $xskip = 1;
                   8345:         $bar_width = 20;
1.220     matthew  8346:     } elsif ($NumBars < 10) {
1.136     matthew  8347:         $width = 120+$NumBars*15;
                   8348:         $xskip = 1;
                   8349:         $bar_width = 15;
                   8350:     } elsif ($NumBars <= 25) {
                   8351:         $width = 120+$NumBars*11;
                   8352:         $xskip = 5;
                   8353:         $bar_width = 8;
                   8354:     } elsif ($NumBars <= 50) {
                   8355:         $width = 120+$NumBars*8;
                   8356:         $xskip = 5;
                   8357:         $bar_width = 4;
                   8358:     } else {
                   8359:         $width = 120+$NumBars*8;
                   8360:         $xskip = 5;
                   8361:         $bar_width = 4;
                   8362:     }
                   8363:     #
1.137     matthew  8364:     $Max = 1 if ($Max < 1);
                   8365:     if ( int($Max) < $Max ) {
                   8366:         $Max++;
                   8367:         $Max = int($Max);
                   8368:     }
1.127     matthew  8369:     $Title  = '' if (! defined($Title));
                   8370:     $xlabel = '' if (! defined($xlabel));
                   8371:     $ylabel = '' if (! defined($ylabel));
1.369     www      8372:     $ValuesHash{$id.'.title'}    = &escape($Title);
                   8373:     $ValuesHash{$id.'.xlabel'}   = &escape($xlabel);
                   8374:     $ValuesHash{$id.'.ylabel'}   = &escape($ylabel);
1.137     matthew  8375:     $ValuesHash{$id.'.y_max_value'} = $Max;
1.136     matthew  8376:     $ValuesHash{$id.'.NumBars'}  = $NumBars;
                   8377:     $ValuesHash{$id.'.NumSets'}  = $NumSets;
                   8378:     $ValuesHash{$id.'.PlotType'} = 'bar';
                   8379:     $ValuesHash{$id.'.Colors'}   = join(',',@{$colors});
                   8380:     $ValuesHash{$id.'.height'}   = $height;
                   8381:     $ValuesHash{$id.'.width'}    = $width;
                   8382:     $ValuesHash{$id.'.xskip'}    = $xskip;
                   8383:     $ValuesHash{$id.'.bar_width'} = $bar_width;
                   8384:     $ValuesHash{$id.'.labels'} = join(',',@Labels);
1.127     matthew  8385:     #
1.228     matthew  8386:     # Deal with other parameters
                   8387:     while (my ($key,$value) = each(%$extra_settings)) {
                   8388:         $ValuesHash{$id.'.'.$key} = $value;
                   8389:     }
                   8390:     #
1.646     raeburn  8391:     &Apache::lonnet::appenv(\%ValuesHash);
1.137     matthew  8392:     return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
                   8393: }
                   8394: 
                   8395: ############################################################
                   8396: ############################################################
                   8397: 
                   8398: =pod
                   8399: 
1.648     raeburn  8400: =item * &DrawXYGraph()
1.137     matthew  8401: 
1.138     matthew  8402: Facilitates the plotting of data in an XY graph.
                   8403: Puts plot definition data into the users environment in order for 
                   8404: graph.png to plot it.  Returns an <img> tag for the plot.
                   8405: 
                   8406: Inputs:
                   8407: 
                   8408: =over 4
                   8409: 
                   8410: =item $Title: string, the title of the plot
                   8411: 
                   8412: =item $xlabel: string, text describing the X-axis of the plot
                   8413: 
                   8414: =item $ylabel: string, text describing the Y-axis of the plot
                   8415: 
                   8416: =item $Max: scalar, the maximum Y value to use in the plot
                   8417: If $Max is < any data point, the graph will not be rendered.
                   8418: 
                   8419: =item $colors: Array ref containing the hex color codes for the data to be 
                   8420: plotted in.  If undefined, default values will be used.
                   8421: 
                   8422: =item $Xlabels: Array ref containing the labels to be used for the X-axis.
                   8423: 
                   8424: =item $Ydata: Array ref containing Array refs.  
1.185     www      8425: Each of the contained arrays will be plotted as a separate curve.
1.138     matthew  8426: 
                   8427: =item %Values: hash indicating or overriding any default values which are 
                   8428: passed to graph.png.  
                   8429: Possible values are: width, xskip, x_ticks, x_tick_offset, among others.
                   8430: 
                   8431: =back
                   8432: 
                   8433: Returns:
                   8434: 
                   8435: An <img> tag which references graph.png and the appropriate identifying
                   8436: information for the plot.
                   8437: 
1.137     matthew  8438: =cut
                   8439: 
                   8440: ############################################################
                   8441: ############################################################
                   8442: sub DrawXYGraph {
                   8443:     my ($Title,$xlabel,$ylabel,$Max,$colors,$Xlabels,$Ydata,%Values)=@_;
                   8444:     #
                   8445:     # Create the identifier for the graph
                   8446:     my $identifier = &get_cgi_id();
                   8447:     my $id = 'cgi.'.$identifier;
                   8448:     #
                   8449:     $Title  = '' if (! defined($Title));
                   8450:     $xlabel = '' if (! defined($xlabel));
                   8451:     $ylabel = '' if (! defined($ylabel));
                   8452:     my %ValuesHash = 
                   8453:         (
1.369     www      8454:          $id.'.title'  => &escape($Title),
                   8455:          $id.'.xlabel' => &escape($xlabel),
                   8456:          $id.'.ylabel' => &escape($ylabel),
1.137     matthew  8457:          $id.'.y_max_value'=> $Max,
                   8458:          $id.'.labels'     => join(',',@$Xlabels),
                   8459:          $id.'.PlotType'   => 'XY',
                   8460:          );
                   8461:     #
                   8462:     if (defined($colors) && ref($colors) eq 'ARRAY') {
                   8463:         $ValuesHash{$id.'.Colors'}   = join(',',@{$colors});
                   8464:     }
                   8465:     #
                   8466:     if (! ref($Ydata) || ref($Ydata) ne 'ARRAY') {
                   8467:         return '';
                   8468:     }
                   8469:     my $NumSets=1;
1.138     matthew  8470:     foreach my $array (@{$Ydata}){
1.137     matthew  8471:         next if (! ref($array));
                   8472:         $ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array);
                   8473:     }
1.138     matthew  8474:     $ValuesHash{$id.'.NumSets'} = $NumSets-1;
1.137     matthew  8475:     #
                   8476:     # Deal with other parameters
                   8477:     while (my ($key,$value) = each(%Values)) {
                   8478:         $ValuesHash{$id.'.'.$key} = $value;
1.127     matthew  8479:     }
                   8480:     #
1.646     raeburn  8481:     &Apache::lonnet::appenv(\%ValuesHash);
1.136     matthew  8482:     return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
                   8483: }
                   8484: 
                   8485: ############################################################
                   8486: ############################################################
                   8487: 
                   8488: =pod
                   8489: 
1.648     raeburn  8490: =item * &DrawXYYGraph()
1.138     matthew  8491: 
                   8492: Facilitates the plotting of data in an XY graph with two Y axes.
                   8493: Puts plot definition data into the users environment in order for 
                   8494: graph.png to plot it.  Returns an <img> tag for the plot.
                   8495: 
                   8496: Inputs:
                   8497: 
                   8498: =over 4
                   8499: 
                   8500: =item $Title: string, the title of the plot
                   8501: 
                   8502: =item $xlabel: string, text describing the X-axis of the plot
                   8503: 
                   8504: =item $ylabel: string, text describing the Y-axis of the plot
                   8505: 
                   8506: =item $colors: Array ref containing the hex color codes for the data to be 
                   8507: plotted in.  If undefined, default values will be used.
                   8508: 
                   8509: =item $Xlabels: Array ref containing the labels to be used for the X-axis.
                   8510: 
                   8511: =item $Ydata1: The first data set
                   8512: 
                   8513: =item $Min1: The minimum value of the left Y-axis
                   8514: 
                   8515: =item $Max1: The maximum value of the left Y-axis
                   8516: 
                   8517: =item $Ydata2: The second data set
                   8518: 
                   8519: =item $Min2: The minimum value of the right Y-axis
                   8520: 
                   8521: =item $Max2: The maximum value of the left Y-axis
                   8522: 
                   8523: =item %Values: hash indicating or overriding any default values which are 
                   8524: passed to graph.png.  
                   8525: Possible values are: width, xskip, x_ticks, x_tick_offset, among others.
                   8526: 
                   8527: =back
                   8528: 
                   8529: Returns:
                   8530: 
                   8531: An <img> tag which references graph.png and the appropriate identifying
                   8532: information for the plot.
1.136     matthew  8533: 
                   8534: =cut
                   8535: 
                   8536: ############################################################
                   8537: ############################################################
1.137     matthew  8538: sub DrawXYYGraph {
                   8539:     my ($Title,$xlabel,$ylabel,$colors,$Xlabels,$Ydata1,$Min1,$Max1,
                   8540:                                         $Ydata2,$Min2,$Max2,%Values)=@_;
1.136     matthew  8541:     #
                   8542:     # Create the identifier for the graph
                   8543:     my $identifier = &get_cgi_id();
                   8544:     my $id = 'cgi.'.$identifier;
                   8545:     #
                   8546:     $Title  = '' if (! defined($Title));
                   8547:     $xlabel = '' if (! defined($xlabel));
                   8548:     $ylabel = '' if (! defined($ylabel));
                   8549:     my %ValuesHash = 
                   8550:         (
1.369     www      8551:          $id.'.title'  => &escape($Title),
                   8552:          $id.'.xlabel' => &escape($xlabel),
                   8553:          $id.'.ylabel' => &escape($ylabel),
1.136     matthew  8554:          $id.'.labels' => join(',',@$Xlabels),
                   8555:          $id.'.PlotType' => 'XY',
                   8556:          $id.'.NumSets' => 2,
1.137     matthew  8557:          $id.'.two_axes' => 1,
                   8558:          $id.'.y1_max_value' => $Max1,
                   8559:          $id.'.y1_min_value' => $Min1,
                   8560:          $id.'.y2_max_value' => $Max2,
                   8561:          $id.'.y2_min_value' => $Min2,
1.136     matthew  8562:          );
                   8563:     #
1.137     matthew  8564:     if (defined($colors) && ref($colors) eq 'ARRAY') {
                   8565:         $ValuesHash{$id.'.Colors'}   = join(',',@{$colors});
                   8566:     }
                   8567:     #
                   8568:     if (! ref($Ydata1) || ref($Ydata1) ne 'ARRAY' ||
                   8569:         ! ref($Ydata2) || ref($Ydata2) ne 'ARRAY'){
1.136     matthew  8570:         return '';
                   8571:     }
                   8572:     my $NumSets=1;
1.137     matthew  8573:     foreach my $array ($Ydata1,$Ydata2){
1.136     matthew  8574:         next if (! ref($array));
                   8575:         $ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array);
1.137     matthew  8576:     }
                   8577:     #
                   8578:     # Deal with other parameters
                   8579:     while (my ($key,$value) = each(%Values)) {
                   8580:         $ValuesHash{$id.'.'.$key} = $value;
1.136     matthew  8581:     }
                   8582:     #
1.646     raeburn  8583:     &Apache::lonnet::appenv(\%ValuesHash);
1.130     albertel 8584:     return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
1.139     matthew  8585: }
                   8586: 
                   8587: ############################################################
                   8588: ############################################################
                   8589: 
                   8590: =pod
                   8591: 
1.157     matthew  8592: =back 
                   8593: 
1.139     matthew  8594: =head1 Statistics helper routines?  
                   8595: 
                   8596: Bad place for them but what the hell.
                   8597: 
1.157     matthew  8598: =over 4
                   8599: 
1.648     raeburn  8600: =item * &chartlink()
1.139     matthew  8601: 
                   8602: Returns a link to the chart for a specific student.  
                   8603: 
                   8604: Inputs:
                   8605: 
                   8606: =over 4
                   8607: 
                   8608: =item $linktext: The text of the link
                   8609: 
                   8610: =item $sname: The students username
                   8611: 
                   8612: =item $sdomain: The students domain
                   8613: 
                   8614: =back
                   8615: 
1.157     matthew  8616: =back
                   8617: 
1.139     matthew  8618: =cut
                   8619: 
                   8620: ############################################################
                   8621: ############################################################
                   8622: sub chartlink {
                   8623:     my ($linktext, $sname, $sdomain) = @_;
                   8624:     my $link = '<a href="/adm/statistics?reportSelected=student_assessment'.
1.369     www      8625:         '&amp;SelectedStudent='.&escape($sname.':'.$sdomain).
1.219     albertel 8626:         '&amp;chartoutputmode='.HTML::Entities::encode('html, with all links').
1.139     matthew  8627:        '">'.$linktext.'</a>';
1.153     matthew  8628: }
                   8629: 
                   8630: #######################################################
                   8631: #######################################################
                   8632: 
                   8633: =pod
                   8634: 
                   8635: =head1 Course Environment Routines
1.157     matthew  8636: 
                   8637: =over 4
1.153     matthew  8638: 
1.648     raeburn  8639: =item * &restore_course_settings()
1.153     matthew  8640: 
1.648     raeburn  8641: =item * &store_course_settings()
1.153     matthew  8642: 
                   8643: Restores/Store indicated form parameters from the course environment.
                   8644: Will not overwrite existing values of the form parameters.
                   8645: 
                   8646: Inputs: 
                   8647: a scalar describing the data (e.g. 'chart', 'problem_analysis')
                   8648: 
                   8649: a hash ref describing the data to be stored.  For example:
                   8650:    
                   8651: %Save_Parameters = ('Status' => 'scalar',
                   8652:     'chartoutputmode' => 'scalar',
                   8653:     'chartoutputdata' => 'scalar',
                   8654:     'Section' => 'array',
1.373     raeburn  8655:     'Group' => 'array',
1.153     matthew  8656:     'StudentData' => 'array',
                   8657:     'Maps' => 'array');
                   8658: 
                   8659: Returns: both routines return nothing
                   8660: 
1.631     raeburn  8661: =back
                   8662: 
1.153     matthew  8663: =cut
                   8664: 
                   8665: #######################################################
                   8666: #######################################################
                   8667: sub store_course_settings {
1.496     albertel 8668:     return &store_settings($env{'request.course.id'},@_);
                   8669: }
                   8670: 
                   8671: sub store_settings {
1.153     matthew  8672:     # save to the environment
                   8673:     # appenv the same items, just to be safe
1.300     albertel 8674:     my $udom  = $env{'user.domain'};
                   8675:     my $uname = $env{'user.name'};
1.496     albertel 8676:     my ($context,$prefix,$Settings) = @_;
1.153     matthew  8677:     my %SaveHash;
                   8678:     my %AppHash;
                   8679:     while (my ($setting,$type) = each(%$Settings)) {
1.496     albertel 8680:         my $basename = join('.','internal',$context,$prefix,$setting);
1.300     albertel 8681:         my $envname = 'environment.'.$basename;
1.258     albertel 8682:         if (exists($env{'form.'.$setting})) {
1.153     matthew  8683:             # Save this value away
                   8684:             if ($type eq 'scalar' &&
1.258     albertel 8685:                 (! exists($env{$envname}) || 
                   8686:                  $env{$envname} ne $env{'form.'.$setting})) {
                   8687:                 $SaveHash{$basename} = $env{'form.'.$setting};
                   8688:                 $AppHash{$envname}   = $env{'form.'.$setting};
1.153     matthew  8689:             } elsif ($type eq 'array') {
                   8690:                 my $stored_form;
1.258     albertel 8691:                 if (ref($env{'form.'.$setting})) {
1.153     matthew  8692:                     $stored_form = join(',',
                   8693:                                         map {
1.369     www      8694:                                             &escape($_);
1.258     albertel 8695:                                         } sort(@{$env{'form.'.$setting}}));
1.153     matthew  8696:                 } else {
                   8697:                     $stored_form = 
1.369     www      8698:                         &escape($env{'form.'.$setting});
1.153     matthew  8699:                 }
                   8700:                 # Determine if the array contents are the same.
1.258     albertel 8701:                 if ($stored_form ne $env{$envname}) {
1.153     matthew  8702:                     $SaveHash{$basename} = $stored_form;
                   8703:                     $AppHash{$envname}   = $stored_form;
                   8704:                 }
                   8705:             }
                   8706:         }
                   8707:     }
                   8708:     my $put_result = &Apache::lonnet::put('environment',\%SaveHash,
1.300     albertel 8709:                                           $udom,$uname);
1.153     matthew  8710:     if ($put_result !~ /^(ok|delayed)/) {
                   8711:         &Apache::lonnet::logthis('unable to save form parameters, '.
                   8712:                                  'got error:'.$put_result);
                   8713:     }
                   8714:     # Make sure these settings stick around in this session, too
1.646     raeburn  8715:     &Apache::lonnet::appenv(\%AppHash);
1.153     matthew  8716:     return;
                   8717: }
                   8718: 
                   8719: sub restore_course_settings {
1.499     albertel 8720:     return &restore_settings($env{'request.course.id'},@_);
1.496     albertel 8721: }
                   8722: 
                   8723: sub restore_settings {
                   8724:     my ($context,$prefix,$Settings) = @_;
1.153     matthew  8725:     while (my ($setting,$type) = each(%$Settings)) {
1.258     albertel 8726:         next if (exists($env{'form.'.$setting}));
1.496     albertel 8727:         my $envname = 'environment.internal.'.$context.'.'.$prefix.
1.153     matthew  8728:             '.'.$setting;
1.258     albertel 8729:         if (exists($env{$envname})) {
1.153     matthew  8730:             if ($type eq 'scalar') {
1.258     albertel 8731:                 $env{'form.'.$setting} = $env{$envname};
1.153     matthew  8732:             } elsif ($type eq 'array') {
1.258     albertel 8733:                 $env{'form.'.$setting} = [ 
1.153     matthew  8734:                                            map { 
1.369     www      8735:                                                &unescape($_); 
1.258     albertel 8736:                                            } split(',',$env{$envname})
1.153     matthew  8737:                                            ];
                   8738:             }
                   8739:         }
                   8740:     }
1.127     matthew  8741: }
                   8742: 
1.618     raeburn  8743: #######################################################
                   8744: #######################################################
                   8745: 
                   8746: =pod
                   8747: 
                   8748: =head1 Domain E-mail Routines  
                   8749: 
                   8750: =over 4
                   8751: 
1.648     raeburn  8752: =item * &build_recipient_list()
1.618     raeburn  8753: 
1.692.4.14  raeburn  8754: Build recipient lists for five types of e-mail:
1.692.4.2  raeburn  8755: (a) Error Reports, (b) Package Updates, (c) lonstatus warnings/errors
1.692.4.14  raeburn  8756: (d) Help requests, (e) Course requests needing approval,  generated by
                   8757: lonerrorhandler.pm, CHECKRPMS, loncron, lonsupportreq.pm and
                   8758: loncoursequeueadmin.pm respectively.
1.618     raeburn  8759: 
                   8760: Inputs:
1.619     raeburn  8761: defmail (scalar - email address of default recipient), 
1.618     raeburn  8762: mailing type (scalar - errormail, packagesmail, or helpdeskmail), 
1.619     raeburn  8763: defdom (domain for which to retrieve configuration settings),
                   8764: origmail (scalar - email address of recipient from loncapa.conf, 
                   8765: i.e., predates configuration by DC via domainprefs.pm 
1.618     raeburn  8766: 
1.655     raeburn  8767: Returns: comma separated list of addresses to which to send e-mail.
                   8768: 
                   8769: =back
1.618     raeburn  8770: 
                   8771: =cut
                   8772: 
                   8773: ############################################################
                   8774: ############################################################
                   8775: sub build_recipient_list {
1.619     raeburn  8776:     my ($defmail,$mailing,$defdom,$origmail) = @_;
1.618     raeburn  8777:     my @recipients;
                   8778:     my $otheremails;
                   8779:     my %domconfig =
                   8780:          &Apache::lonnet::get_dom('configuration',['contacts'],$defdom);
                   8781:     if (ref($domconfig{'contacts'}) eq 'HASH') {
1.692.4.2  raeburn  8782:         if (exists($domconfig{'contacts'}{$mailing})) {
                   8783:             if (ref($domconfig{'contacts'}{$mailing}) eq 'HASH') {
                   8784:                 my @contacts = ('adminemail','supportemail');
                   8785:                 foreach my $item (@contacts) {
                   8786:                     if ($domconfig{'contacts'}{$mailing}{$item}) {
                   8787:                         my $addr = $domconfig{'contacts'}{$item};
                   8788:                         if (!grep(/^\Q$addr\E$/,@recipients)) {
                   8789:                             push(@recipients,$addr);
                   8790:                         }
1.619     raeburn  8791:                     }
1.692.4.2  raeburn  8792:                     $otheremails = $domconfig{'contacts'}{$mailing}{'others'};
1.618     raeburn  8793:                 }
                   8794:             }
1.692.4.2  raeburn  8795:         } elsif ($origmail ne '') {
                   8796:             push(@recipients,$origmail);
1.618     raeburn  8797:         }
1.619     raeburn  8798:     } elsif ($origmail ne '') {
                   8799:         push(@recipients,$origmail);
1.618     raeburn  8800:     }
1.688     raeburn  8801:     if (defined($defmail)) {
                   8802:         if ($defmail ne '') {
                   8803:             push(@recipients,$defmail);
                   8804:         }
1.618     raeburn  8805:     }
                   8806:     if ($otheremails) {
1.619     raeburn  8807:         my @others;
                   8808:         if ($otheremails =~ /,/) {
                   8809:             @others = split(/,/,$otheremails);
1.618     raeburn  8810:         } else {
1.619     raeburn  8811:             push(@others,$otheremails);
                   8812:         }
                   8813:         foreach my $addr (@others) {
                   8814:             if (!grep(/^\Q$addr\E$/,@recipients)) {
                   8815:                 push(@recipients,$addr);
                   8816:             }
1.618     raeburn  8817:         }
                   8818:     }
1.619     raeburn  8819:     my $recipientlist = join(',',@recipients); 
1.618     raeburn  8820:     return $recipientlist;
                   8821: }
                   8822: 
1.127     matthew  8823: ############################################################
                   8824: ############################################################
1.154     albertel 8825: 
1.655     raeburn  8826: =pod
                   8827: 
                   8828: =head1 Course Catalog Routines
                   8829: 
                   8830: =over 4
                   8831: 
                   8832: =item * &gather_categories()
                   8833: 
                   8834: Converts category definitions - keys of categories hash stored in  
                   8835: coursecategories in configuration.db on the primary library server in a 
                   8836: domain - to an array.  Also generates javascript and idx hash used to 
                   8837: generate Domain Coordinator interface for editing Course Categories.
                   8838: 
                   8839: Inputs:
1.663     raeburn  8840: 
1.655     raeburn  8841: categories (reference to hash of category definitions).
1.663     raeburn  8842: 
1.655     raeburn  8843: cats (reference to array of arrays/hashes which encapsulates hierarchy of
                   8844:       categories and subcategories).
1.663     raeburn  8845: 
1.655     raeburn  8846: idx (reference to hash of counters used in Domain Coordinator interface for 
                   8847:       editing Course Categories).
1.663     raeburn  8848: 
1.655     raeburn  8849: jsarray (reference to array of categories used to create Javascript arrays for
                   8850:          Domain Coordinator interface for editing Course Categories).
                   8851: 
                   8852: Returns: nothing
                   8853: 
                   8854: Side effects: populates cats, idx and jsarray. 
                   8855: 
                   8856: =cut
                   8857: 
                   8858: sub gather_categories {
                   8859:     my ($categories,$cats,$idx,$jsarray) = @_;
                   8860:     my %counters;
                   8861:     my $num = 0;
                   8862:     foreach my $item (keys(%{$categories})) {
                   8863:         my ($cat,$container,$depth) = map { &unescape($_); } split(/:/,$item);
                   8864:         if ($container eq '' && $depth == 0) {
                   8865:             $cats->[$depth][$categories->{$item}] = $cat;
                   8866:         } else {
                   8867:             $cats->[$depth]{$container}[$categories->{$item}] = $cat;
                   8868:         }
                   8869:         my ($escitem,$tail) = split(/:/,$item,2);
                   8870:         if ($counters{$tail} eq '') {
                   8871:             $counters{$tail} = $num;
                   8872:             $num ++;
                   8873:         }
                   8874:         if (ref($idx) eq 'HASH') {
                   8875:             $idx->{$item} = $counters{$tail};
                   8876:         }
                   8877:         if (ref($jsarray) eq 'ARRAY') {
                   8878:             push(@{$jsarray->[$counters{$tail}]},$item);
                   8879:         }
                   8880:     }
                   8881:     return;
                   8882: }
                   8883: 
                   8884: =pod
                   8885: 
                   8886: =item * &extract_categories()
                   8887: 
                   8888: Used to generate breadcrumb trails for course categories.
                   8889: 
                   8890: Inputs:
1.663     raeburn  8891: 
1.655     raeburn  8892: categories (reference to hash of category definitions).
1.663     raeburn  8893: 
1.655     raeburn  8894: cats (reference to array of arrays/hashes which encapsulates hierarchy of
                   8895:       categories and subcategories).
1.663     raeburn  8896: 
1.655     raeburn  8897: trails (reference to array of breacrumb trails for each category).
1.663     raeburn  8898: 
1.655     raeburn  8899: allitems (reference to hash - key is category key 
                   8900:          (format: escaped(name):escaped(parent category):depth in hierarchy).
1.663     raeburn  8901: 
1.655     raeburn  8902: idx (reference to hash of counters used in Domain Coordinator interface for
                   8903:       editing Course Categories).
1.663     raeburn  8904: 
1.655     raeburn  8905: jsarray (reference to array of categories used to create Javascript arrays for
                   8906:          Domain Coordinator interface for editing Course Categories).
                   8907: 
1.665     raeburn  8908: subcats (reference to hash of arrays containing all subcategories within each 
                   8909:          category, -recursive)
                   8910: 
1.655     raeburn  8911: Returns: nothing
                   8912: 
                   8913: Side effects: populates trails and allitems hash references.
                   8914: 
                   8915: =cut
                   8916: 
                   8917: sub extract_categories {
1.665     raeburn  8918:     my ($categories,$cats,$trails,$allitems,$idx,$jsarray,$subcats) = @_;
1.655     raeburn  8919:     if (ref($categories) eq 'HASH') {
                   8920:         &gather_categories($categories,$cats,$idx,$jsarray);
                   8921:         if (ref($cats->[0]) eq 'ARRAY') {
                   8922:             for (my $i=0; $i<@{$cats->[0]}; $i++) {
                   8923:                 my $name = $cats->[0][$i];
                   8924:                 my $item = &escape($name).'::0';
                   8925:                 my $trailstr;
                   8926:                 if ($name eq 'instcode') {
                   8927:                     $trailstr = &mt('Official courses (with institutional codes)');
                   8928:                 } else {
                   8929:                     $trailstr = $name;
                   8930:                 }
                   8931:                 if ($allitems->{$item} eq '') {
                   8932:                     push(@{$trails},$trailstr);
                   8933:                     $allitems->{$item} = scalar(@{$trails})-1;
                   8934:                 }
                   8935:                 my @parents = ($name);
                   8936:                 if (ref($cats->[1]{$name}) eq 'ARRAY') {
                   8937:                     for (my $j=0; $j<@{$cats->[1]{$name}}; $j++) {
                   8938:                         my $category = $cats->[1]{$name}[$j];
1.665     raeburn  8939:                         if (ref($subcats) eq 'HASH') {
                   8940:                             push(@{$subcats->{$item}},&escape($category).':'.&escape($name).':1');
                   8941:                         }
                   8942:                         &recurse_categories($cats,2,$category,$trails,$allitems,\@parents,$subcats);
                   8943:                     }
                   8944:                 } else {
                   8945:                     if (ref($subcats) eq 'HASH') {
                   8946:                         $subcats->{$item} = [];
1.655     raeburn  8947:                     }
                   8948:                 }
                   8949:             }
                   8950:         }
                   8951:     }
                   8952:     return;
                   8953: }
                   8954: 
                   8955: =pod
                   8956: 
                   8957: =item *&recurse_categories()
                   8958: 
                   8959: Recursively used to generate breadcrumb trails for course categories.
                   8960: 
                   8961: Inputs:
1.663     raeburn  8962: 
1.655     raeburn  8963: cats (reference to array of arrays/hashes which encapsulates hierarchy of
                   8964:       categories and subcategories).
1.663     raeburn  8965: 
1.655     raeburn  8966: depth (current depth in hierarchy of categories and sub-categories - 0 indexed).
1.663     raeburn  8967: 
                   8968: category (current course category, for which breadcrumb trail is being generated).
                   8969: 
                   8970: trails (reference to array of breadcrumb trails for each category).
                   8971: 
1.655     raeburn  8972: allitems (reference to hash - key is category key
                   8973:          (format: escaped(name):escaped(parent category):depth in hierarchy).
1.663     raeburn  8974: 
1.655     raeburn  8975: parents (array containing containers directories for current category, 
                   8976:          back to top level). 
                   8977: 
                   8978: Returns: nothing
                   8979: 
                   8980: Side effects: populates trails and allitems hash references
                   8981: 
                   8982: =cut
                   8983: 
                   8984: sub recurse_categories {
1.665     raeburn  8985:     my ($cats,$depth,$category,$trails,$allitems,$parents,$subcats) = @_;
1.655     raeburn  8986:     my $shallower = $depth - 1;
                   8987:     if (ref($cats->[$depth]{$category}) eq 'ARRAY') {
                   8988:         for (my $k=0; $k<@{$cats->[$depth]{$category}}; $k++) {
                   8989:             my $name = $cats->[$depth]{$category}[$k];
                   8990:             my $item = &escape($category).':'.&escape($parents->[-1]).':'.$shallower;
                   8991:             my $trailstr = join(' -&gt; ',(@{$parents},$category));
                   8992:             if ($allitems->{$item} eq '') {
                   8993:                 push(@{$trails},$trailstr);
                   8994:                 $allitems->{$item} = scalar(@{$trails})-1;
                   8995:             }
                   8996:             my $deeper = $depth+1;
                   8997:             push(@{$parents},$category);
1.665     raeburn  8998:             if (ref($subcats) eq 'HASH') {
                   8999:                 my $subcat = &escape($name).':'.$category.':'.$depth;
                   9000:                 for (my $j=@{$parents}; $j>=0; $j--) {
                   9001:                     my $higher;
                   9002:                     if ($j > 0) {
                   9003:                         $higher = &escape($parents->[$j]).':'.
                   9004:                                   &escape($parents->[$j-1]).':'.$j;
                   9005:                     } else {
                   9006:                         $higher = &escape($parents->[$j]).'::'.$j;
                   9007:                     }
                   9008:                     push(@{$subcats->{$higher}},$subcat);
                   9009:                 }
                   9010:             }
                   9011:             &recurse_categories($cats,$deeper,$name,$trails,$allitems,$parents,
                   9012:                                 $subcats);
1.655     raeburn  9013:             pop(@{$parents});
                   9014:         }
                   9015:     } else {
                   9016:         my $item = &escape($category).':'.&escape($parents->[-1]).':'.$shallower;
                   9017:         my $trailstr = join(' -&gt; ',(@{$parents},$category));
                   9018:         if ($allitems->{$item} eq '') {
                   9019:             push(@{$trails},$trailstr);
                   9020:             $allitems->{$item} = scalar(@{$trails})-1;
                   9021:         }
                   9022:     }
                   9023:     return;
                   9024: }
                   9025: 
1.663     raeburn  9026: =pod
                   9027: 
                   9028: =item *&assign_categories_table()
                   9029: 
                   9030: Create a datatable for display of hierarchical categories in a domain,
                   9031: with checkboxes to allow a course to be categorized. 
                   9032: 
                   9033: Inputs:
                   9034: 
                   9035: cathash - reference to hash of categories defined for the domain (from
                   9036:           configuration.db)
                   9037: 
                   9038: currcat - scalar with an & separated list of categories assigned to a course. 
                   9039: 
                   9040: Returns: $output (markup to be displayed) 
                   9041: 
                   9042: =cut
                   9043: 
                   9044: sub assign_categories_table {
                   9045:     my ($cathash,$currcat) = @_;
                   9046:     my $output;
                   9047:     if (ref($cathash) eq 'HASH') {
                   9048:         my (@cats,@trails,%allitems,%idx,@jsarray,@path,$maxdepth);
                   9049:         &extract_categories($cathash,\@cats,\@trails,\%allitems,\%idx,\@jsarray);
                   9050:         $maxdepth = scalar(@cats);
                   9051:         if (@cats > 0) {
                   9052:             my $itemcount = 0;
                   9053:             if (ref($cats[0]) eq 'ARRAY') {
                   9054:                 $output = &Apache::loncommon::start_data_table();
                   9055:                 my @currcategories;
                   9056:                 if ($currcat ne '') {
                   9057:                     @currcategories = split('&',$currcat);
                   9058:                 }
                   9059:                 for (my $i=0; $i<@{$cats[0]}; $i++) {
                   9060:                     my $parent = $cats[0][$i];
                   9061:                     my $css_class = $itemcount%2?' class="LC_odd_row"':'';
                   9062:                     next if ($parent eq 'instcode');
                   9063:                     my $item = &escape($parent).'::0';
                   9064:                     my $checked = '';
                   9065:                     if (@currcategories > 0) {
                   9066:                         if (grep(/^\Q$item\E$/,@currcategories)) {
                   9067:                             $checked = ' checked="checked" ';
                   9068:                         }
                   9069:                     }
1.675     raeburn  9070:                     $output .= '<tr '.$css_class.'><td><span class="LC_nobreak">'.
                   9071:                                '<input type="checkbox" name="usecategory" value="'.
                   9072:                                $item.'"'.$checked.' />'.$parent.'</span>'.
                   9073:                                '<input type="hidden" name="catname" value="'.$parent.'" /></td>';
1.663     raeburn  9074:                     my $depth = 1;
                   9075:                     push(@path,$parent);
                   9076:                     $output .= &assign_category_rows($itemcount,\@cats,$depth,$parent,\@path,\@currcategories);
                   9077:                     pop(@path);
                   9078:                     $output .= '</tr><tr><td colspan="'.$maxdepth.'" class="LC_row_separator"></td></tr>';
                   9079:                     $itemcount ++;
                   9080:                 }
                   9081:                 $output .= &Apache::loncommon::end_data_table();
                   9082:             }
                   9083:         }
                   9084:     }
                   9085:     return $output;
                   9086: }
                   9087: 
                   9088: =pod
                   9089: 
                   9090: =item *&assign_category_rows()
                   9091: 
                   9092: Create a datatable row for display of nested categories in a domain,
                   9093: with checkboxes to allow a course to be categorized,called recursively.
                   9094: 
                   9095: Inputs:
                   9096: 
                   9097: itemcount - track row number for alternating colors
                   9098: 
                   9099: cats - reference to array of arrays/hashes which encapsulates hierarchy of
                   9100:       categories and subcategories.
                   9101: 
                   9102: depth - current depth in hierarchy of categories and sub-categories - 0 indexed.
                   9103: 
                   9104: parent - parent of current category item
                   9105: 
                   9106: path - Array containing all categories back up through the hierarchy from the
                   9107:        current category to the top level.
                   9108: 
                   9109: currcategories - reference to array of current categories assigned to the course
                   9110: 
                   9111: Returns: $output (markup to be displayed).
                   9112: 
                   9113: =cut
                   9114: 
                   9115: sub assign_category_rows {
                   9116:     my ($itemcount,$cats,$depth,$parent,$path,$currcategories) = @_;
                   9117:     my ($text,$name,$item,$chgstr);
                   9118:     if (ref($cats) eq 'ARRAY') {
                   9119:         my $maxdepth = scalar(@{$cats});
                   9120:         if (ref($cats->[$depth]) eq 'HASH') {
                   9121:             if (ref($cats->[$depth]{$parent}) eq 'ARRAY') {
                   9122:                 my $numchildren = @{$cats->[$depth]{$parent}};
                   9123:                 my $css_class = $itemcount%2?' class="LC_odd_row"':'';
                   9124:                 $text .= '<td><table class="LC_datatable">';
                   9125:                 for (my $j=0; $j<$numchildren; $j++) {
                   9126:                     $name = $cats->[$depth]{$parent}[$j];
                   9127:                     $item = &escape($name).':'.&escape($parent).':'.$depth;
                   9128:                     my $deeper = $depth+1;
                   9129:                     my $checked = '';
                   9130:                     if (ref($currcategories) eq 'ARRAY') {
                   9131:                         if (@{$currcategories} > 0) {
                   9132:                             if (grep(/^\Q$item\E$/,@{$currcategories})) {
                   9133:                                 $checked = ' checked="checked" ';
                   9134:                             }
                   9135:                         }
                   9136:                     }
1.664     raeburn  9137:                     $text .= '<tr><td><span class="LC_nobreak"><label>'.
                   9138:                              '<input type="checkbox" name="usecategory" value="'.
1.675     raeburn  9139:                              $item.'"'.$checked.' />'.$name.'</label></span>'.
                   9140:                              '<input type="hidden" name="catname" value="'.$name.'" />'.
                   9141:                              '</td><td>';
1.663     raeburn  9142:                     if (ref($path) eq 'ARRAY') {
                   9143:                         push(@{$path},$name);
                   9144:                         $text .= &assign_category_rows($itemcount,$cats,$deeper,$name,$path,$currcategories);
                   9145:                         pop(@{$path});
                   9146:                     }
                   9147:                     $text .= '</td></tr>';
                   9148:                 }
                   9149:                 $text .= '</table></td>';
                   9150:             }
                   9151:         }
                   9152:     }
                   9153:     return $text;
                   9154: }
                   9155: 
1.655     raeburn  9156: ############################################################
                   9157: ############################################################
                   9158: 
                   9159: 
1.443     albertel 9160: sub commit_customrole {
1.664     raeburn  9161:     my ($udom,$uname,$url,$three,$four,$five,$start,$end,$context) = @_;
1.630     raeburn  9162:     my $output = &mt('Assigning custom role').' "'.$five.'" by '.$four.':'.$three.' in '.$url.
1.443     albertel 9163:                          ($start?', '.&mt('starting').' '.localtime($start):'').
                   9164:                          ($end?', ending '.localtime($end):'').': <b>'.
                   9165:               &Apache::lonnet::assigncustomrole(
1.664     raeburn  9166:                  $udom,$uname,$url,$three,$four,$five,$end,$start,undef,undef,$context).
1.443     albertel 9167:                  '</b><br />';
                   9168:     return $output;
                   9169: }
                   9170: 
                   9171: sub commit_standardrole {
1.541     raeburn  9172:     my ($udom,$uname,$url,$three,$start,$end,$one,$two,$sec,$context) = @_;
                   9173:     my ($output,$logmsg,$linefeed);
                   9174:     if ($context eq 'auto') {
                   9175:         $linefeed = "\n";
                   9176:     } else {
                   9177:         $linefeed = "<br />\n";
                   9178:     }  
1.443     albertel 9179:     if ($three eq 'st') {
1.541     raeburn  9180:         my $result = &commit_studentrole(\$logmsg,$udom,$uname,$url,$three,$start,$end,
                   9181:                                          $one,$two,$sec,$context);
                   9182:         if (($result =~ /^error/) || ($result eq 'not_in_class') || 
1.626     raeburn  9183:             ($result eq 'unknown_course') || ($result eq 'refused')) {
                   9184:             $output = $logmsg.' '.&mt('Error: ').$result."\n"; 
1.443     albertel 9185:         } else {
1.541     raeburn  9186:             $output = $logmsg.$linefeed.&mt('Assigning').' '.$three.' in '.$url.
1.443     albertel 9187:                ($start?', '.&mt('starting').' '.localtime($start):'').
1.541     raeburn  9188:                ($end?', '.&mt('ending').' '.localtime($end):'').': ';
                   9189:             if ($context eq 'auto') {
                   9190:                 $output .= $result.$linefeed.&mt('Add to classlist').': ok';
                   9191:             } else {
                   9192:                $output .= '<b>'.$result.'</b>'.$linefeed.
                   9193:                &mt('Add to classlist').': <b>ok</b>';
                   9194:             }
                   9195:             $output .= $linefeed;
1.443     albertel 9196:         }
                   9197:     } else {
                   9198:         $output = &mt('Assigning').' '.$three.' in '.$url.
                   9199:                ($start?', '.&mt('starting').' '.localtime($start):'').
1.541     raeburn  9200:                ($end?', '.&mt('ending').' '.localtime($end):'').': ';
1.652     raeburn  9201:         my $result = &Apache::lonnet::assignrole($udom,$uname,$url,$three,$end,$start,'','',$context);
1.541     raeburn  9202:         if ($context eq 'auto') {
                   9203:             $output .= $result.$linefeed;
                   9204:         } else {
                   9205:             $output .= '<b>'.$result.'</b>'.$linefeed;
                   9206:         }
1.443     albertel 9207:     }
                   9208:     return $output;
                   9209: }
                   9210: 
                   9211: sub commit_studentrole {
1.541     raeburn  9212:     my ($logmsg,$udom,$uname,$url,$three,$start,$end,$one,$two,$sec,$context) = @_;
1.626     raeburn  9213:     my ($result,$linefeed,$oldsecurl,$newsecurl);
1.541     raeburn  9214:     if ($context eq 'auto') {
                   9215:         $linefeed = "\n";
                   9216:     } else {
                   9217:         $linefeed = '<br />'."\n";
                   9218:     }
1.443     albertel 9219:     if (defined($one) && defined($two)) {
                   9220:         my $cid=$one.'_'.$two;
                   9221:         my $oldsec=&Apache::lonnet::getsection($udom,$uname,$cid);
                   9222:         my $secchange = 0;
                   9223:         my $expire_role_result;
                   9224:         my $modify_section_result;
1.628     raeburn  9225:         if ($oldsec ne '-1') { 
                   9226:             if ($oldsec ne $sec) {
1.443     albertel 9227:                 $secchange = 1;
1.628     raeburn  9228:                 my $now = time;
1.443     albertel 9229:                 my $uurl='/'.$cid;
                   9230:                 $uurl=~s/\_/\//g;
                   9231:                 if ($oldsec) {
                   9232:                     $uurl.='/'.$oldsec;
                   9233:                 }
1.626     raeburn  9234:                 $oldsecurl = $uurl;
1.628     raeburn  9235:                 $expire_role_result = 
1.652     raeburn  9236:                     &Apache::lonnet::assignrole($udom,$uname,$uurl,'st',$now,'','',$context);
1.628     raeburn  9237:                 if ($env{'request.course.sec'} ne '') { 
                   9238:                     if ($expire_role_result eq 'refused') {
                   9239:                         my @roles = ('st');
                   9240:                         my @statuses = ('previous');
                   9241:                         my @roledoms = ($one);
                   9242:                         my $withsec = 1;
                   9243:                         my %roleshash = 
                   9244:                             &Apache::lonnet::get_my_roles($uname,$udom,'userroles',
                   9245:                                               \@statuses,\@roles,\@roledoms,$withsec);
                   9246:                         if (defined ($roleshash{$two.':'.$one.':st:'.$oldsec})) {
                   9247:                             my ($oldstart,$oldend) = 
                   9248:                                 split(':',$roleshash{$two.':'.$one.':st:'.$oldsec});
                   9249:                             if ($oldend > 0 && $oldend <= $now) {
                   9250:                                 $expire_role_result = 'ok';
                   9251:                             }
                   9252:                         }
                   9253:                     }
                   9254:                 }
1.443     albertel 9255:                 $result = $expire_role_result;
                   9256:             }
                   9257:         }
                   9258:         if (($expire_role_result eq 'ok') || ($secchange == 0)) {
1.652     raeburn  9259:             $modify_section_result = &Apache::lonnet::modify_student_enrollment($udom,$uname,undef,undef,undef,undef,undef,$sec,$end,$start,'','',$cid,'',$context);
1.443     albertel 9260:             if ($modify_section_result =~ /^ok/) {
                   9261:                 if ($secchange == 1) {
1.628     raeburn  9262:                     if ($sec eq '') {
                   9263:                         $$logmsg .= &mt('Section for [_1] switched from (possibly expired) old section: [_2] to student role without a section.',$uname,$oldsec).$linefeed;
                   9264:                     } else {
                   9265:                         $$logmsg .= &mt('Section for [_1] switched from (possibly expired) old section: [_2] to new section: [_3].',$uname,$oldsec,$sec).$linefeed;
                   9266:                     }
1.443     albertel 9267:                 } elsif ($oldsec eq '-1') {
1.628     raeburn  9268:                     if ($sec eq '') {
                   9269:                         $$logmsg .= &mt('New student role without a section for [_1] in course [_2].',$uname,$cid).$linefeed;
                   9270:                     } else {
                   9271:                         $$logmsg .= &mt('New student role for [_1] in section [_2] in course [_3].',$uname,$sec,$cid).$linefeed;
                   9272:                     }
1.443     albertel 9273:                 } else {
1.628     raeburn  9274:                     if ($sec eq '') {
                   9275:                         $$logmsg .= &mt('Student [_1] assigned to course [_2] without a section.',$uname,$cid).$linefeed;
                   9276:                     } else {
                   9277:                         $$logmsg .= &mt('Student [_1] assigned to section [_2] in course [_3].',$uname,$sec,$cid).$linefeed;
                   9278:                     }
1.443     albertel 9279:                 }
                   9280:             } else {
1.628     raeburn  9281:                 if ($secchange) {       
                   9282:                     $$logmsg .= &mt('Error when attempting section change for [_1] from old section "[_2]" to new section: "[_3]" in course [_4] -error:',$uname,$oldsec,$sec,$cid).' '.$modify_section_result.$linefeed;
                   9283:                 } else {
                   9284:                     $$logmsg .= &mt('Error when attempting to modify role for [_1] for section: "[_2]" in course [_3] -error:',$uname,$sec,$cid).' '.$modify_section_result.$linefeed;
                   9285:                 }
1.443     albertel 9286:             }
                   9287:             $result = $modify_section_result;
                   9288:         } elsif ($secchange == 1) {
1.628     raeburn  9289:             if ($oldsec eq '') {
                   9290:                 $$logmsg .= &mt('Error when attempting to expire existing role without a section for [_1] in course [_3] -error: ',$uname,$cid).' '.$expire_role_result.$linefeed;
                   9291:             } else {
                   9292:                 $$logmsg .= &mt('Error when attempting to expire existing role for [_1] in section [_2] in course [_3] -error: ',$uname,$oldsec,$cid).' '.$expire_role_result.$linefeed;
                   9293:             }
1.626     raeburn  9294:             if ($expire_role_result eq 'refused') {
                   9295:                 my $newsecurl = '/'.$cid;
                   9296:                 $newsecurl =~ s/\_/\//g;
                   9297:                 if ($sec ne '') {
                   9298:                     $newsecurl.='/'.$sec;
                   9299:                 }
                   9300:                 if (&Apache::lonnet::allowed('cst',$newsecurl) && !(&Apache::lonnet::allowed('cst',$oldsecurl))) {
                   9301:                     if ($sec eq '') {
                   9302:                         $$logmsg .= &mt('Although your current role has privileges to add students to section "[_1]", you do not have privileges to modify existing enrollments unaffiliated with any section.',$sec).$linefeed;
                   9303:                     } else {
                   9304:                         $$logmsg .= &mt('Although your current role has privileges to add students to section "[_1]", you do not have privileges to modify existing enrollments in other sections.',$sec).$linefeed;
                   9305:                     }
                   9306:                 }
                   9307:             }
1.443     albertel 9308:         }
                   9309:     } else {
1.626     raeburn  9310:         $$logmsg .= &mt('Incomplete course id defined.').$linefeed.&mt('Addition of user [_1] from domain [_2] to course [_3], section [_4] not completed.',$uname,$udom,$one.'_'.$two,$sec).$linefeed;
1.443     albertel 9311:         $result = "error: incomplete course id\n";
                   9312:     }
                   9313:     return $result;
                   9314: }
                   9315: 
                   9316: ############################################################
                   9317: ############################################################
                   9318: 
1.566     albertel 9319: sub check_clone {
1.578     raeburn  9320:     my ($args,$linefeed) = @_;
1.566     albertel 9321:     my $cloneid='/'.$args->{'clonedomain'}.'/'.$args->{'clonecourse'};
                   9322:     my ($clonecrsudom,$clonecrsunum)= &LONCAPA::split_courseid($cloneid);
                   9323:     my $clonehome=&Apache::lonnet::homeserver($clonecrsunum,$clonecrsudom);
                   9324:     my $clonemsg;
                   9325:     my $can_clone = 0;
                   9326: 
                   9327:     if ($clonehome eq 'no_host') {
1.578     raeburn  9328:         $clonemsg = &mt('No new course created.').$linefeed.&mt('A new course could not be cloned from the specified original - [_1] - because it is a non-existent course.',$args->{'clonecourse'}.':'.$args->{'clonedomain'});     
1.566     albertel 9329:     } else {
                   9330: 	my %clonedesc = &Apache::lonnet::coursedescription($cloneid,{'one_time' => 1});
1.692.4.12  raeburn  9331:         if (($env{'request.role.domain'} eq $args->{'clonedomain'}) && 
                   9332:             (&Apache::lonnet::allowed('ccc',$env{'request.role.domain'}))) {
                   9333:  	    $can_clone = 1;
1.566     albertel 9334: 	} else {
                   9335: 	    my %clonehash = &Apache::lonnet::get('environment',['cloners'],
                   9336: 						 $args->{'clonedomain'},$args->{'clonecourse'});
                   9337: 	    my @cloners = split(/,/,$clonehash{'cloners'});
1.578     raeburn  9338:             if (grep(/^\*$/,@cloners)) {
                   9339:                 $can_clone = 1;
                   9340:             } elsif (grep(/^\*\:\Q$args->{'ccdomain'}\E$/,@cloners)) {
                   9341:                 $can_clone = 1;
                   9342:             } else {
                   9343: 	        my %roleshash =
                   9344: 		    &Apache::lonnet::get_my_roles($args->{'ccuname'},
                   9345: 					 $args->{'ccdomain'},
                   9346:                                          'userroles',['active'],['cc'],
                   9347: 					 [$args->{'clonedomain'}]);
                   9348: 	        if (($roleshash{$args->{'clonecourse'}.':'.$args->{'clonedomain'}.':cc'}) || (grep(/^\Q$args->{'ccuname'}\E:\Q$args->{'ccdomain'}\E$/,@cloners))) {
                   9349: 		    $can_clone = 1;
                   9350: 	        } else {
                   9351:                     $clonemsg = &mt('No new course created.').$linefeed.&mt('The new course could not be cloned from the existing course because the new course owner ([_1]) does not have cloning rights in the existing course ([_2]).',$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'});
                   9352: 	        }
1.566     albertel 9353: 	    }
1.578     raeburn  9354:         }
1.566     albertel 9355:     }
                   9356:     return ($can_clone, $clonemsg, $cloneid, $clonehome);
                   9357: }
                   9358: 
1.444     albertel 9359: sub construct_course {
1.692.4.14  raeburn  9360:     my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context,$cnum,$category) = @_;
1.444     albertel 9361:     my $outcome;
1.541     raeburn  9362:     my $linefeed =  '<br />'."\n";
                   9363:     if ($context eq 'auto') {
                   9364:         $linefeed = "\n";
                   9365:     }
1.566     albertel 9366: 
                   9367: #
                   9368: # Are we cloning?
                   9369: #
                   9370:     my ($can_clone, $clonemsg, $cloneid, $clonehome);
                   9371:     if (($args->{'clonecourse'}) && ($args->{'clonedomain'})) {
1.578     raeburn  9372: 	($can_clone, $clonemsg, $cloneid, $clonehome) = &check_clone($args,$linefeed);
1.566     albertel 9373: 	if ($context ne 'auto') {
1.578     raeburn  9374:             if ($clonemsg ne '') {
                   9375: 	        $clonemsg = '<span class="LC_error">'.$clonemsg.'</span>';
                   9376:             }
1.566     albertel 9377: 	}
                   9378: 	$outcome .= $clonemsg.$linefeed;
                   9379: 
                   9380:         if (!$can_clone) {
                   9381: 	    return (0,$outcome);
                   9382: 	}
                   9383:     }
                   9384: 
1.444     albertel 9385: #
                   9386: # Open course
                   9387: #
                   9388:     my $crstype = lc($args->{'crstype'});
                   9389:     my %cenv=();
                   9390:     $$courseid=&Apache::lonnet::createcourse($args->{'course_domain'},
                   9391:                                              $args->{'cdescr'},
                   9392:                                              $args->{'curl'},
                   9393:                                              $args->{'course_home'},
                   9394:                                              $args->{'nonstandard'},
                   9395:                                              $args->{'crscode'},
                   9396:                                              $args->{'ccuname'}.':'.
                   9397:                                              $args->{'ccdomain'},
1.692.4.12  raeburn  9398:                                              $args->{'crstype'},
1.692.4.14  raeburn  9399:                                              $cnum,$context,$category);
1.692.4.12  raeburn  9400: 
1.444     albertel 9401: 
                   9402:     # Note: The testing routines depend on this being output; see 
                   9403:     # Utils::Course. This needs to at least be output as a comment
                   9404:     # if anyone ever decides to not show this, and Utils::Course::new
                   9405:     # will need to be suitably modified.
1.541     raeburn  9406:     $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed;
1.444     albertel 9407: #
                   9408: # Check if created correctly
                   9409: #
1.479     albertel 9410:     ($$crsudom,$$crsunum)= &LONCAPA::split_courseid($$courseid);
1.444     albertel 9411:     my $crsuhome=&Apache::lonnet::homeserver($$crsunum,$$crsudom);
1.541     raeburn  9412:     $outcome .= &mt('Created on').': '.$crsuhome.$linefeed;
1.566     albertel 9413: 
1.444     albertel 9414: #
1.566     albertel 9415: # Do the cloning
                   9416: #   
                   9417:     if ($can_clone && $cloneid) {
                   9418: 	$clonemsg = &mt('Cloning [_1] from [_2]',$crstype,$clonehome);
                   9419: 	if ($context ne 'auto') {
                   9420: 	    $clonemsg = '<span class="LC_success">'.$clonemsg.'</span>';
                   9421: 	}
                   9422: 	$outcome .= $clonemsg.$linefeed;
                   9423: 	my %oldcenv=&Apache::lonnet::dump('environment',$$crsudom,$$crsunum);
1.444     albertel 9424: # Copy all files
1.637     www      9425: 	&Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'},$args->{'dateshift'});
1.444     albertel 9426: # Restore URL
1.566     albertel 9427: 	$cenv{'url'}=$oldcenv{'url'};
1.444     albertel 9428: # Restore title
1.566     albertel 9429: 	$cenv{'description'}=$oldcenv{'description'};
1.444     albertel 9430: # Mark as cloned
1.566     albertel 9431: 	$cenv{'clonedfrom'}=$cloneid;
1.638     www      9432: # Need to clone grading mode
                   9433:         my %newenv=&Apache::lonnet::get('environment',['grading'],$$crsudom,$$crsunum);
                   9434:         $cenv{'grading'}=$newenv{'grading'};
                   9435: # Do not clone these environment entries
                   9436:         &Apache::lonnet::del('environment',
                   9437:                   ['default_enrollment_start_date',
                   9438:                    'default_enrollment_end_date',
                   9439:                    'question.email',
                   9440:                    'policy.email',
                   9441:                    'comment.email',
                   9442:                    'pch.users.denied',
1.692.4.2  raeburn  9443:                    'plc.users.denied',
                   9444:                    'hidefromcat',
                   9445:                    'categories'],
1.638     www      9446:                    $$crsudom,$$crsunum);
1.444     albertel 9447:     }
1.566     albertel 9448: 
1.444     albertel 9449: #
                   9450: # Set environment (will override cloned, if existing)
                   9451: #
                   9452:     my @sections = ();
                   9453:     my @xlists = ();
                   9454:     if ($args->{'crstype'}) {
                   9455:         $cenv{'type'}=$args->{'crstype'};
                   9456:     }
                   9457:     if ($args->{'crsid'}) {
                   9458:         $cenv{'courseid'}=$args->{'crsid'};
                   9459:     }
                   9460:     if ($args->{'crscode'}) {
                   9461:         $cenv{'internal.coursecode'}=$args->{'crscode'};
                   9462:     }
                   9463:     if ($args->{'crsquota'} ne '') {
                   9464:         $cenv{'internal.coursequota'}=$args->{'crsquota'};
                   9465:     } else {
                   9466:         $cenv{'internal.coursequota'}=$args->{'crsquota'} = 20;
                   9467:     }
                   9468:     if ($args->{'ccuname'}) {
                   9469:         $cenv{'internal.courseowner'} = $args->{'ccuname'}.
                   9470:                                         ':'.$args->{'ccdomain'};
                   9471:     } else {
                   9472:         $cenv{'internal.courseowner'} = $args->{'curruser'};
                   9473:     }
                   9474:     my @badclasses = (); # Used to accumulate sections/crosslistings that did not pass classlist access check for course owner.
                   9475:     if ($args->{'crssections'}) {
                   9476:         $cenv{'internal.sectionnums'} = '';
                   9477:         if ($args->{'crssections'} =~ m/,/) {
                   9478:             @sections = split/,/,$args->{'crssections'};
                   9479:         } else {
                   9480:             $sections[0] = $args->{'crssections'};
                   9481:         }
                   9482:         if (@sections > 0) {
                   9483:             foreach my $item (@sections) {
                   9484:                 my ($sec,$gp) = split/:/,$item;
                   9485:                 my $class = $args->{'crscode'}.$sec;
                   9486:                 my $addcheck = &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$class,$cenv{'internal.courseowner'});
                   9487:                 $cenv{'internal.sectionnums'} .= $item.',';
                   9488:                 unless ($addcheck eq 'ok') {
                   9489:                     push @badclasses, $class;
                   9490:                 }
                   9491:             }
                   9492:             $cenv{'internal.sectionnums'} =~ s/,$//;
                   9493:         }
                   9494:     }
                   9495: # do not hide course coordinator from staff listing, 
                   9496: # even if privileged
                   9497:     $cenv{'nothideprivileged'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
                   9498: # add crosslistings
                   9499:     if ($args->{'crsxlist'}) {
                   9500:         $cenv{'internal.crosslistings'}='';
                   9501:         if ($args->{'crsxlist'} =~ m/,/) {
                   9502:             @xlists = split/,/,$args->{'crsxlist'};
                   9503:         } else {
                   9504:             $xlists[0] = $args->{'crsxlist'};
                   9505:         }
                   9506:         if (@xlists > 0) {
                   9507:             foreach my $item (@xlists) {
                   9508:                 my ($xl,$gp) = split/:/,$item;
                   9509:                 my $addcheck =  &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$xl,$cenv{'internal.courseowner'});
                   9510:                 $cenv{'internal.crosslistings'} .= $item.',';
                   9511:                 unless ($addcheck eq 'ok') {
                   9512:                     push @badclasses, $xl;
                   9513:                 }
                   9514:             }
                   9515:             $cenv{'internal.crosslistings'} =~ s/,$//;
                   9516:         }
                   9517:     }
                   9518:     if ($args->{'autoadds'}) {
                   9519:         $cenv{'internal.autoadds'}=$args->{'autoadds'};
                   9520:     }
                   9521:     if ($args->{'autodrops'}) {
                   9522:         $cenv{'internal.autodrops'}=$args->{'autodrops'};
                   9523:     }
                   9524: # check for notification of enrollment changes
                   9525:     my @notified = ();
                   9526:     if ($args->{'notify_owner'}) {
                   9527:         if ($args->{'ccuname'} ne '') {
                   9528:             push(@notified,$args->{'ccuname'}.':'.$args->{'ccdomain'});
                   9529:         }
                   9530:     }
                   9531:     if ($args->{'notify_dc'}) {
                   9532:         if ($uname ne '') { 
1.630     raeburn  9533:             push(@notified,$uname.':'.$udom);
1.444     albertel 9534:         }
                   9535:     }
                   9536:     if (@notified > 0) {
                   9537:         my $notifylist;
                   9538:         if (@notified > 1) {
                   9539:             $notifylist = join(',',@notified);
                   9540:         } else {
                   9541:             $notifylist = $notified[0];
                   9542:         }
                   9543:         $cenv{'internal.notifylist'} = $notifylist;
                   9544:     }
                   9545:     if (@badclasses > 0) {
                   9546:         my %lt=&Apache::lonlocal::texthash(
                   9547:                 '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',
                   9548:                 'dnhr' => 'does not have rights to access enrollment in these classes',
                   9549:                 'adby' => 'as determined by the policies of your institution on access to official classlists'
                   9550:         );
1.541     raeburn  9551:         my $badclass_msg = $cenv{'internal.courseowner'}.') - '.$lt{'dnhr'}.
                   9552:                            ' ('.$lt{'adby'}.')';
                   9553:         if ($context eq 'auto') {
                   9554:             $outcome .= $badclass_msg.$linefeed;
1.566     albertel 9555:             $outcome .= '<div class="LC_warning">'.$badclass_msg.$linefeed.'<ul>'."\n";
1.541     raeburn  9556:             foreach my $item (@badclasses) {
                   9557:                 if ($context eq 'auto') {
                   9558:                     $outcome .= " - $item\n";
                   9559:                 } else {
                   9560:                     $outcome .= "<li>$item</li>\n";
                   9561:                 }
                   9562:             }
                   9563:             if ($context eq 'auto') {
                   9564:                 $outcome .= $linefeed;
                   9565:             } else {
1.566     albertel 9566:                 $outcome .= "</ul><br /><br /></div>\n";
1.541     raeburn  9567:             }
                   9568:         } 
1.444     albertel 9569:     }
                   9570:     if ($args->{'no_end_date'}) {
                   9571:         $args->{'endaccess'} = 0;
                   9572:     }
                   9573:     $cenv{'internal.autostart'}=$args->{'enrollstart'};
                   9574:     $cenv{'internal.autoend'}=$args->{'enrollend'};
                   9575:     $cenv{'default_enrollment_start_date'}=$args->{'startaccess'};
                   9576:     $cenv{'default_enrollment_end_date'}=$args->{'endaccess'};
                   9577:     if ($args->{'showphotos'}) {
                   9578:       $cenv{'internal.showphotos'}=$args->{'showphotos'};
                   9579:     }
                   9580:     $cenv{'internal.authtype'} = $args->{'authtype'};
                   9581:     $cenv{'internal.autharg'} = $args->{'autharg'}; 
                   9582:     if ( ($cenv{'internal.authtype'} =~ /^krb/) && ($cenv{'internal.autoadds'} == 1)) {
                   9583:         if (! defined($cenv{'internal.autharg'}) || $cenv{'internal.autharg'}  eq '') {
1.541     raeburn  9584:             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'); 
                   9585:             if ($context eq 'auto') {
                   9586:                 $outcome .= $krb_msg;
                   9587:             } else {
1.566     albertel 9588:                 $outcome .= '<span class="LC_error">'.$krb_msg.'</span>';
1.541     raeburn  9589:             }
                   9590:             $outcome .= $linefeed;
1.444     albertel 9591:         }
                   9592:     }
                   9593:     if (($args->{'ccdomain'}) && ($args->{'ccuname'})) {
                   9594:        if ($args->{'setpolicy'}) {
                   9595:            $cenv{'policy.email'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
                   9596:        }
                   9597:        if ($args->{'setcontent'}) {
                   9598:            $cenv{'question.email'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
                   9599:        }
                   9600:     }
                   9601:     if ($args->{'reshome'}) {
                   9602: 	$cenv{'reshome'}=$args->{'reshome'}.'/';
                   9603: 	$cenv{'reshome'}=~s/\/+$/\//;
                   9604:     }
                   9605: #
                   9606: # course has keyed access
                   9607: #
                   9608:     if ($args->{'setkeys'}) {
                   9609:        $cenv{'keyaccess'}='yes';
                   9610:     }
                   9611: # if specified, key authority is not course, but user
                   9612: # only active if keyaccess is yes
                   9613:     if ($args->{'keyauth'}) {
1.487     albertel 9614: 	my ($user,$domain) = split(':',$args->{'keyauth'});
                   9615: 	$user = &LONCAPA::clean_username($user);
                   9616: 	$domain = &LONCAPA::clean_username($domain);
1.488     foxr     9617: 	if ($user ne '' && $domain ne '') {
1.487     albertel 9618: 	    $cenv{'keyauth'}=$user.':'.$domain;
1.444     albertel 9619: 	}
                   9620:     }
                   9621: 
                   9622:     if ($args->{'disresdis'}) {
                   9623:         $cenv{'pch.roles.denied'}='st';
                   9624:     }
                   9625:     if ($args->{'disablechat'}) {
                   9626:         $cenv{'plc.roles.denied'}='st';
                   9627:     }
                   9628: 
                   9629:     # Record we've not yet viewed the Course Initialization Helper for this 
                   9630:     # course
                   9631:     $cenv{'course.helper.not.run'} = 1;
                   9632:     #
                   9633:     # Use new Randomseed
                   9634:     #
                   9635:     $cenv{'rndseed'}=&Apache::lonnet::latest_rnd_algorithm_id();;
                   9636:     $cenv{'receiptalg'}=&Apache::lonnet::latest_receipt_algorithm_id();;
                   9637:     #
                   9638:     # The encryption code and receipt prefix for this course
                   9639:     #
                   9640:     $cenv{'internal.encseed'}=$Apache::lonnet::perlvar{'lonReceipt'}.$$.time.int(rand(9999));
                   9641:     $cenv{'internal.encpref'}=100+int(9*rand(99));
                   9642:     #
                   9643:     # By default, use standard grading
                   9644:     if (!defined($cenv{'grading'})) { $cenv{'grading'} = 'standard'; }
                   9645: 
1.541     raeburn  9646:     $outcome .= $linefeed.&mt('Setting environment').': '.                 
                   9647:           &Apache::lonnet::put('environment',\%cenv,$$crsudom,$$crsunum).$linefeed;
1.444     albertel 9648: #
                   9649: # Open all assignments
                   9650: #
                   9651:     if ($args->{'openall'}) {
                   9652:        my $storeunder=$$crsudom.'_'.$$crsunum.'.0.opendate';
                   9653:        my %storecontent = ($storeunder         => time,
                   9654:                            $storeunder.'.type' => 'date_start');
                   9655:        
                   9656:        $outcome .= &mt('Opening all assignments').': '.&Apache::lonnet::cput
1.541     raeburn  9657:                  ('resourcedata',\%storecontent,$$crsudom,$$crsunum).$linefeed;
1.444     albertel 9658:    }
                   9659: #
                   9660: # Set first page
                   9661: #
                   9662:     unless (($args->{'nonstandard'}) || ($args->{'firstres'} eq 'blank')
                   9663: 	    || ($cloneid)) {
1.445     albertel 9664: 	use LONCAPA::map;
1.444     albertel 9665: 	$outcome .= &mt('Setting first resource').': ';
1.445     albertel 9666: 
                   9667: 	my $map = '/uploaded/'.$$crsudom.'/'.$$crsunum.'/default.sequence';
                   9668:         my ($errtext,$fatal)=&LONCAPA::map::mapread($map);
                   9669: 
1.444     albertel 9670:         $outcome .= ($fatal?$errtext:'read ok').' - ';
                   9671:         my $title; my $url;
                   9672:         if ($args->{'firstres'} eq 'syl') {
1.690     bisitz   9673: 	    $title=&mt('Syllabus');
1.444     albertel 9674:             $url='/public/'.$$crsudom.'/'.$$crsunum.'/syllabus';
                   9675:         } else {
1.690     bisitz   9676:             $title=&mt('Navigate Contents');
1.444     albertel 9677:             $url='/adm/navmaps';
                   9678:         }
1.445     albertel 9679: 
                   9680:         $LONCAPA::map::resources[1]=$title.':'.$url.':false:start:res';
                   9681: 	(my $outtext,$errtext) = &LONCAPA::map::storemap($map,1);
                   9682: 
                   9683: 	if ($errtext) { $fatal=2; }
1.541     raeburn  9684:         $outcome .= ($fatal?$errtext:'write ok').$linefeed;
1.444     albertel 9685:     }
1.566     albertel 9686: 
                   9687:     return (1,$outcome);
1.444     albertel 9688: }
                   9689: 
                   9690: ############################################################
                   9691: ############################################################
                   9692: 
1.378     raeburn  9693: sub course_type {
                   9694:     my ($cid) = @_;
                   9695:     if (!defined($cid)) {
                   9696:         $cid = $env{'request.course.id'};
                   9697:     }
1.404     albertel 9698:     if (defined($env{'course.'.$cid.'.type'})) {
                   9699:         return $env{'course.'.$cid.'.type'};
1.378     raeburn  9700:     } else {
                   9701:         return 'Course';
1.377     raeburn  9702:     }
                   9703: }
1.156     albertel 9704: 
1.406     raeburn  9705: sub group_term {
                   9706:     my $crstype = &course_type();
                   9707:     my %names = (
1.692.4.6  raeburn  9708:                   'Course'    => 'group',
                   9709:                   'Community' => 'group',
1.406     raeburn  9710:                 );
                   9711:     return $names{$crstype};
                   9712: }
                   9713: 
1.692.4.20! raeburn  9714: sub course_types {
        !          9715:     my @types = ('official','unofficial','community');
        !          9716:     my %typename = (
        !          9717:                          official   => 'Official course',
        !          9718:                          unofficial => 'Unofficial course',
        !          9719:                          community  => 'Community',
        !          9720:                    );
        !          9721:     return (\@types,\%typename);
        !          9722: }
        !          9723: 
1.156     albertel 9724: sub icon {
                   9725:     my ($file)=@_;
1.505     albertel 9726:     my $curfext = lc((split(/\./,$file))[-1]);
1.168     albertel 9727:     my $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/unknown.gif';
1.156     albertel 9728:     my $embstyle = &Apache::loncommon::fileembstyle($curfext);
1.168     albertel 9729:     if (!(!defined($embstyle) || $embstyle eq 'unk' || $embstyle eq 'hdn')) {
                   9730: 	if (-e  $Apache::lonnet::perlvar{'lonDocRoot'}.'/'.
                   9731: 	          $Apache::lonnet::perlvar{'lonIconsURL'}.'/'.
                   9732: 	            $curfext.".gif") {
                   9733: 	    $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/'.
                   9734: 		$curfext.".gif";
                   9735: 	}
                   9736:     }
1.249     albertel 9737:     return &lonhttpdurl($iconname);
1.154     albertel 9738: } 
1.84      albertel 9739: 
1.575     albertel 9740: sub lonhttpdurl {
1.692     www      9741: #
                   9742: # Had been used for "small fry" static images on separate port 8080.
                   9743: # Modify here if lightweight http functionality desired again.
                   9744: # Currently eliminated due to increasing firewall issues.
                   9745: #
1.575     albertel 9746:     my ($url)=@_;
1.692     www      9747:     return $url;
1.215     albertel 9748: }
                   9749: 
1.213     albertel 9750: sub connection_aborted {
                   9751:     my ($r)=@_;
                   9752:     $r->print(" ");$r->rflush();
                   9753:     my $c = $r->connection;
                   9754:     return $c->aborted();
                   9755: }
                   9756: 
1.221     foxr     9757: #    Escapes strings that may have embedded 's that will be put into
1.222     foxr     9758: #    strings as 'strings'.
                   9759: sub escape_single {
1.221     foxr     9760:     my ($input) = @_;
1.223     albertel 9761:     $input =~ s/\\/\\\\/g;	# Escape the \'s..(must be first)>
1.221     foxr     9762:     $input =~ s/\'/\\\'/g;	# Esacpe the 's....
                   9763:     return $input;
                   9764: }
1.223     albertel 9765: 
1.222     foxr     9766: #  Same as escape_single, but escape's "'s  This 
                   9767: #  can be used for  "strings"
                   9768: sub escape_double {
                   9769:     my ($input) = @_;
                   9770:     $input =~ s/\\/\\\\/g;	# Escape the /'s..(must be first)>
                   9771:     $input =~ s/\"/\\\"/g;	# Esacpe the "s....
                   9772:     return $input;
                   9773: }
1.223     albertel 9774:  
1.222     foxr     9775: #   Escapes the last element of a full URL.
                   9776: sub escape_url {
                   9777:     my ($url)   = @_;
1.238     raeburn  9778:     my @urlslices = split(/\//, $url,-1);
1.369     www      9779:     my $lastitem = &escape(pop(@urlslices));
1.223     albertel 9780:     return join('/',@urlslices).'/'.$lastitem;
1.222     foxr     9781: }
1.462     albertel 9782: 
1.692.4.2  raeburn  9783: sub compare_arrays {
                   9784:     my ($arrayref1,$arrayref2) = @_;
                   9785:     my (@difference,%count);
                   9786:     @difference = ();
                   9787:     %count = ();
                   9788:     if ((ref($arrayref1) eq 'ARRAY') && (ref($arrayref2) eq 'ARRAY')) {
                   9789:         foreach my $element (@{$arrayref1}, @{$arrayref2}) { $count{$element}++; }
                   9790:         foreach my $element (keys(%count)) {
                   9791:             if ($count{$element} == 1) {
                   9792:                 push(@difference,$element);
                   9793:             }
                   9794:         }
                   9795:     }
                   9796:     return @difference;
                   9797: }
                   9798: 
1.462     albertel 9799: # -------------------------------------------------------- Initliaze user login
                   9800: sub init_user_environment {
1.463     albertel 9801:     my ($r, $username, $domain, $authhost, $form, $args) = @_;
1.462     albertel 9802:     my $lonids=$Apache::lonnet::perlvar{'lonIDsDir'};
                   9803: 
                   9804:     my $public=($username eq 'public' && $domain eq 'public');
                   9805: 
                   9806: # See if old ID present, if so, remove
                   9807: 
                   9808:     my ($filename,$cookie,$userroles);
                   9809:     my $now=time;
                   9810: 
                   9811:     if ($public) {
                   9812: 	my $max_public=100;
                   9813: 	my $oldest;
                   9814: 	my $oldest_time=0;
                   9815: 	for(my $next=1;$next<=$max_public;$next++) {
                   9816: 	    if (-e $lonids."/publicuser_$next.id") {
                   9817: 		my $mtime=(stat($lonids."/publicuser_$next.id"))[9];
                   9818: 		if ($mtime<$oldest_time || !$oldest_time) {
                   9819: 		    $oldest_time=$mtime;
                   9820: 		    $oldest=$next;
                   9821: 		}
                   9822: 	    } else {
                   9823: 		$cookie="publicuser_$next";
                   9824: 		last;
                   9825: 	    }
                   9826: 	}
                   9827: 	if (!$cookie) { $cookie="publicuser_$oldest"; }
                   9828:     } else {
1.463     albertel 9829: 	# if this isn't a robot, kill any existing non-robot sessions
                   9830: 	if (!$args->{'robot'}) {
                   9831: 	    opendir(DIR,$lonids);
                   9832: 	    while ($filename=readdir(DIR)) {
                   9833: 		if ($filename=~/^$username\_\d+\_$domain\_$authhost\.id$/) {
                   9834: 		    unlink($lonids.'/'.$filename);
                   9835: 		}
1.462     albertel 9836: 	    }
1.463     albertel 9837: 	    closedir(DIR);
1.462     albertel 9838: 	}
                   9839: # Give them a new cookie
1.463     albertel 9840: 	my $id = ($args->{'robot'} ? 'robot'.$args->{'robot'}
1.684     www      9841: 		                   : $now.$$.int(rand(10000)));
1.463     albertel 9842: 	$cookie="$username\_$id\_$domain\_$authhost";
1.462     albertel 9843:     
                   9844: # Initialize roles
                   9845: 
                   9846: 	$userroles=&Apache::lonnet::rolesinit($domain,$username,$authhost);
                   9847:     }
                   9848: # ------------------------------------ Check browser type and MathML capability
                   9849: 
                   9850:     my ($httpbrowser,$clientbrowser,$clientversion,$clientmathml,
                   9851:         $clientunicode,$clientos) = &decode_user_agent($r);
                   9852: 
                   9853: # -------------------------------------- Any accessibility options to remember?
                   9854:     if (($form->{'interface'}) && ($form->{'remember'} eq 'true')) {
                   9855: 	foreach my $option ('imagesuppress','appletsuppress',
                   9856: 			    'embedsuppress','fontenhance','blackwhite') {
                   9857: 	    if ($form->{$option} eq 'true') {
                   9858: 		&Apache::lonnet::put('environment',{$option => 'on'},
                   9859: 				     $domain,$username);
                   9860: 	    } else {
                   9861: 		&Apache::lonnet::del('environment',[$option],
                   9862: 				     $domain,$username);
                   9863: 	    }
                   9864: 	}
                   9865:     }
                   9866: # ------------------------------------------------------------- Get environment
                   9867: 
                   9868:     my %userenv = &Apache::lonnet::dump('environment',$domain,$username);
                   9869:     my ($tmp) = keys(%userenv);
                   9870:     if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
                   9871: 	# default remote control to off
                   9872: 	if ($userenv{'remote'} ne 'on') { $userenv{'remote'} = 'off'; }
                   9873:     } else {
                   9874: 	undef(%userenv);
                   9875:     }
                   9876:     if (($userenv{'interface'}) && (!$form->{'interface'})) {
                   9877: 	$form->{'interface'}=$userenv{'interface'};
                   9878:     }
                   9879:     $env{'environment.remote'}=$userenv{'remote'};
                   9880:     if ($userenv{'texengine'} eq 'ttm') { $clientmathml=1; }
                   9881: 
                   9882: # --------------- Do not trust query string to be put directly into environment
                   9883:     foreach my $option ('imagesuppress','appletsuppress',
                   9884: 			'embedsuppress','fontenhance','blackwhite',
                   9885: 			'interface','localpath','localres') {
                   9886: 	$form->{$option}=~s/[\n\r\=]//gs;
                   9887:     }
                   9888: # --------------------------------------------------------- Write first profile
                   9889: 
                   9890:     {
                   9891: 	my %initial_env = 
                   9892: 	    ("user.name"          => $username,
                   9893: 	     "user.domain"        => $domain,
                   9894: 	     "user.home"          => $authhost,
                   9895: 	     "browser.type"       => $clientbrowser,
                   9896: 	     "browser.version"    => $clientversion,
                   9897: 	     "browser.mathml"     => $clientmathml,
                   9898: 	     "browser.unicode"    => $clientunicode,
                   9899: 	     "browser.os"         => $clientos,
                   9900: 	     "server.domain"      => $Apache::lonnet::perlvar{'lonDefDomain'},
                   9901: 	     "request.course.fn"  => '',
                   9902: 	     "request.course.uri" => '',
                   9903: 	     "request.course.sec" => '',
                   9904: 	     "request.role"       => 'cm',
                   9905: 	     "request.role.adv"   => $env{'user.adv'},
                   9906: 	     "request.host"       => $ENV{'REMOTE_ADDR'},);
                   9907: 
                   9908:         if ($form->{'localpath'}) {
                   9909: 	    $initial_env{"browser.localpath"}  = $form->{'localpath'};
                   9910: 	    $initial_env{"browser.localres"}   = $form->{'localres'};
                   9911:         }
                   9912: 	
                   9913: 	if ($public) {
                   9914: 	    $initial_env{"environment.remote"} = "off";
                   9915: 	}
                   9916: 	if ($form->{'interface'}) {
                   9917: 	    $form->{'interface'}=~s/\W//gs;
                   9918: 	    $initial_env{"browser.interface"} = $form->{'interface'};
                   9919: 	    $env{'browser.interface'}=$form->{'interface'};
                   9920: 	    foreach my $option ('imagesuppress','appletsuppress',
                   9921: 				'embedsuppress','fontenhance','blackwhite') {
                   9922: 		if (($form->{$option} eq 'true') ||
                   9923: 		    ($userenv{$option} eq 'on')) {
                   9924: 		    $initial_env{"browser.$option"} = "on";
                   9925: 		}
                   9926: 	    }
                   9927: 	}
                   9928: 
1.692.4.2  raeburn  9929:         foreach my $tool ('aboutme','blog','portfolio') {
                   9930:             $userenv{'availabletools.'.$tool} =
                   9931:                 &Apache::lonnet::usertools_access($username,$domain,$tool,'reload');
                   9932:         }
                   9933: 
1.692.4.6  raeburn  9934:         foreach my $crstype ('official','unofficial','community') {
1.692.4.2  raeburn  9935:             $userenv{'canrequest.'.$crstype} =
                   9936:                 &Apache::lonnet::usertools_access($username,$domain,$crstype,
                   9937:                                                   'reload','requestcourses');
                   9938:         }
                   9939: 
1.462     albertel 9940: 	$env{'user.environment'} = "$lonids/$cookie.id";
                   9941: 	
                   9942: 	if (tie(my %disk_env,'GDBM_File',"$lonids/$cookie.id",
                   9943: 		 &GDBM_WRCREAT(),0640)) {
                   9944: 	    &_add_to_env(\%disk_env,\%initial_env);
                   9945: 	    &_add_to_env(\%disk_env,\%userenv,'environment.');
                   9946: 	    &_add_to_env(\%disk_env,$userroles);
1.463     albertel 9947: 	    if (ref($args->{'extra_env'})) {
                   9948: 		&_add_to_env(\%disk_env,$args->{'extra_env'});
                   9949: 	    }
1.462     albertel 9950: 	    untie(%disk_env);
                   9951: 	} else {
                   9952: 	    &Apache::lonnet::logthis("<font color=\"blue\">WARNING: ".
                   9953: 			   'Could not create environment storage in lonauth: '.$!.'</font>');
                   9954: 	    return 'error: '.$!;
                   9955: 	}
                   9956:     }
                   9957:     $env{'request.role'}='cm';
                   9958:     $env{'request.role.adv'}=$env{'user.adv'};
                   9959:     $env{'browser.type'}=$clientbrowser;
                   9960: 
                   9961:     return $cookie;
                   9962: 
                   9963: }
                   9964: 
                   9965: sub _add_to_env {
                   9966:     my ($idf,$env_data,$prefix) = @_;
1.676     raeburn  9967:     if (ref($env_data) eq 'HASH') {
                   9968:         while (my ($key,$value) = each(%$env_data)) {
                   9969: 	    $idf->{$prefix.$key} = $value;
                   9970: 	    $env{$prefix.$key}   = $value;
                   9971:         }
1.462     albertel 9972:     }
                   9973: }
                   9974: 
1.685     tempelho 9975: # --- Get the symbolic name of a problem and the url
                   9976: sub get_symb {
                   9977:     my ($request,$silent) = @_;
1.692.4.2  raeburn  9978:     (my $url=$env{'form.url'}) =~ s-^https?\://($ENV{'SERVER_NAME'}|$ENV{'HTTP_HOST'})--;
1.685     tempelho 9979:     my $symb=($env{'form.symb'} ne '' ? $env{'form.symb'} : (&Apache::lonnet::symbread($url)));
                   9980:     if ($symb eq '') {
                   9981:         if (!$silent) {
                   9982:             $request->print("Unable to handle ambiguous references:$url:.");
                   9983:             return ();
                   9984:         }
                   9985:     }
                   9986:     &Apache::lonenc::check_decrypt(\$symb);
                   9987:     return ($symb);
                   9988: }
                   9989: 
                   9990: # --------------------------------------------------------------Get annotation
                   9991: 
                   9992: sub get_annotation {
                   9993:     my ($symb,$enc) = @_;
                   9994: 
                   9995:     my $key = $symb;
                   9996:     if (!$enc) {
                   9997:         $key =
                   9998:             &Apache::lonnet::clutter((&Apache::lonnet::decode_symb($symb))[2]);
                   9999:     }
                   10000:     my %annotation=&Apache::lonnet::get('nohist_annotations',[$key]);
                   10001:     return $annotation{$key};
                   10002: }
                   10003: 
                   10004: sub clean_symb {
1.692.4.2  raeburn  10005:     my ($symb,$delete_enc) = @_;
1.685     tempelho 10006: 
                   10007:     &Apache::lonenc::check_decrypt(\$symb);
                   10008:     my $enc = $env{'request.enc'};
1.692.4.2  raeburn  10009:     if ($delete_enc) {
                   10010:         delete($env{'request.enc'});
                   10011:     }
1.685     tempelho 10012: 
                   10013:     return ($symb,$enc);
                   10014: }
1.462     albertel 10015: 
1.41      ng       10016: =pod
                   10017: 
                   10018: =back
                   10019: 
1.112     bowersj2 10020: =cut
1.41      ng       10021: 
1.112     bowersj2 10022: 1;
                   10023: __END__;
1.41      ng       10024: 

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