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

1.10      albertel    1: # The LearningOnline Network with CAPA
1.1       albertel    2: # a pile of common routines
1.10      albertel    3: #
1.83    ! albertel    4: # $Id: loncommon.pm,v 1.82 2003/02/14 21:22:04 www 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.12      harris41   28: # YEAR=2001
                     29: # 2/13-12/7 Guy Albertelli
1.18      www        30: # 12/21 Gerd Kortemeyer
1.22      www        31: # 12/25,12/28 Gerd Kortemeyer
1.23      www        32: # YEAR=2002
                     33: # 1/4 Gerd Kortemeyer
1.43      ng         34: # 6/24,7/2 H. K. Ng
1.1       albertel   35: 
                     36: # Makes a table out of the previous attempts
1.2       albertel   37: # Inputs result_from_symbread, user, domain, course_id
1.16      harris41   38: # Reads in non-network-related .tab files
1.1       albertel   39: 
1.35      matthew    40: # POD header:
                     41: 
1.45      matthew    42: =pod
                     43: 
1.35      matthew    44: =head1 NAME
                     45: 
                     46: Apache::loncommon - pile of common routines
                     47: 
                     48: =head1 SYNOPSIS
                     49: 
                     50: Referenced by other mod_perl Apache modules.
                     51: 
                     52: Invocation:
                     53:  &Apache::loncommon::SUBROUTINENAME(ARGUMENTS);
                     54: 
                     55: =head1 INTRODUCTION
                     56: 
                     57: Common collection of used subroutines.  This collection helps remove
                     58: redundancy from other modules and increase efficiency of memory usage.
                     59: 
                     60: Current things done:
                     61: 
                     62:  Makes a table out of the previous homework attempts
                     63:  Inputs result_from_symbread, user, domain, course_id
                     64:  Reads in non-network-related .tab files
                     65: 
                     66: This is part of the LearningOnline Network with CAPA project
                     67: described at http://www.lon-capa.org.
                     68: 
1.41      ng         69: =head2 General Subroutines
1.35      matthew    70: 
                     71: =over 4
                     72: 
                     73: =cut 
                     74: 
                     75: # End of POD header
1.1       albertel   76: package Apache::loncommon;
                     77: 
                     78: use strict;
1.22      www        79: use Apache::lonnet();
1.46      matthew    80: use GDBM_File;
1.51      www        81: use POSIX qw(strftime mktime);
1.1       albertel   82: use Apache::Constants qw(:common);
                     83: use Apache::lonmsg();
1.82      www        84: use Apache::lonmenu();
1.22      www        85: my $readit;
                     86: 
1.46      matthew    87: =pod 
                     88: 
                     89: =item Global Variables
                     90: 
                     91: =over 4
                     92: 
                     93: =cut
1.20      www        94: # ----------------------------------------------- Filetypes/Languages/Copyright
1.12      harris41   95: my %language;
                     96: my %cprtag;
                     97: my %fe; my %fd;
1.41      ng         98: my %category_extensions;
1.12      harris41   99: 
1.63      www       100: # ---------------------------------------------- Designs
                    101: 
                    102: my %designhash;
                    103: 
1.46      matthew   104: # ---------------------------------------------- Thesaurus variables
                    105: 
                    106: =pod
                    107: 
                    108: =item %Keywords  
                    109: 
                    110: A hash used by &keyword to determine if a word is considered a keyword.
                    111: 
                    112: =item $thesaurus_db_file
                    113: 
                    114: Scalar containing the full path to the thesaurus database.                 
                    115: 
                    116: =cut
                    117: 
                    118: my %Keywords;
                    119: my $thesaurus_db_file;
                    120: 
                    121: 
                    122: =pod
                    123: 
                    124: =back
                    125: 
                    126: =cut
1.20      www       127: 
1.12      harris41  128: # ----------------------------------------------------------------------- BEGIN
1.41      ng        129: 
                    130: =pod
                    131: 
1.35      matthew   132: =item BEGIN() 
                    133: 
                    134: Initialize values from language.tab, copyright.tab, filetypes.tab,
1.45      matthew   135: thesaurus.tab, and filecategories.tab.
1.35      matthew   136: 
                    137: =cut
1.45      matthew   138: 
1.35      matthew   139: # ----------------------------------------------------------------------- BEGIN
                    140: 
1.18      www       141: BEGIN {
1.46      matthew   142:     # Variable initialization
                    143:     $thesaurus_db_file = $Apache::lonnet::perlvar{'lonTabDir'}."/thesaurus.db";
                    144:     #
1.22      www       145:     unless ($readit) {
1.12      harris41  146: # ------------------------------------------------------------------- languages
                    147:     {
                    148: 	my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
                    149: 				 '/language.tab');
1.16      harris41  150: 	if ($fh) {
                    151: 	    while (<$fh>) {
                    152: 		next if /^\#/;
                    153: 		chomp;
                    154: 		my ($key,$val)=(split(/\s+/,$_,2));
                    155: 		$language{$key}=$val;
                    156: 	    }
1.12      harris41  157: 	}
                    158:     }
                    159: # ------------------------------------------------------------------ copyrights
                    160:     {
1.16      harris41  161: 	my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonIncludes'}.
                    162: 				  '/copyright.tab');
                    163: 	if ($fh) {
                    164: 	    while (<$fh>) {
                    165: 		next if /^\#/;
                    166: 		chomp;
                    167: 		my ($key,$val)=(split(/\s+/,$_,2));
                    168: 		$cprtag{$key}=$val;
                    169: 	    }
1.12      harris41  170: 	}
                    171:     }
1.63      www       172: 
                    173: # -------------------------------------------------------------- domain designs
                    174: 
                    175:     my $filename;
                    176:     my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';
                    177:     opendir(DIR,$designdir);
                    178:     while ($filename=readdir(DIR)) {
                    179: 	my ($domain)=($filename=~/^(\w+)\./);
                    180:     {
                    181: 	my $fh=Apache::File->new($designdir.'/'.$filename);
                    182: 	if ($fh) {
                    183: 	    while (<$fh>) {
                    184: 		next if /^\#/;
                    185: 		chomp;
                    186: 		my ($key,$val)=(split(/\=/,$_));
                    187: 		if ($val) { $designhash{$domain.'.'.$key}=$val; }
                    188: 	    }
                    189: 	}
                    190:     }
                    191: 
                    192:     }
                    193:     closedir(DIR);
                    194: 
                    195: 
1.15      harris41  196: # ------------------------------------------------------------- file categories
                    197:     {
                    198: 	my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
1.16      harris41  199: 				  '/filecategories.tab');
                    200: 	if ($fh) {
                    201: 	    while (<$fh>) {
                    202: 		next if /^\#/;
                    203: 		chomp;
1.41      ng        204: 		my ($extension,$category)=(split(/\s+/,$_,2));
                    205: 		push @{$category_extensions{lc($category)}},$extension;
1.16      harris41  206: 	    }
1.15      harris41  207: 	}
                    208:     }
1.12      harris41  209: # ------------------------------------------------------------------ file types
                    210:     {
1.16      harris41  211: 	my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
                    212: 	       '/filetypes.tab');
                    213: 	if ($fh) {
                    214:             while (<$fh>) {
                    215: 		next if (/^\#/);
                    216: 		chomp;
                    217: 		my ($ending,$emb,$descr)=split(/\s+/,$_,3);
                    218: 		if ($descr ne '') { 
                    219: 		    $fe{$ending}=lc($emb);
                    220: 		    $fd{$ending}=$descr;
                    221: 		}
1.12      harris41  222: 	    }
                    223: 	}
                    224:     }
1.22      www       225:     &Apache::lonnet::logthis(
1.46      matthew   226:               "<font color=yellow>INFO: Read file types</font>");
1.22      www       227:     $readit=1;
1.46      matthew   228:     }  # end of unless($readit) 
1.32      matthew   229:     
                    230: }
                    231: # ============================================================= END BEGIN BLOCK
1.42      matthew   232: ###############################################################
                    233: ##           HTML and Javascript Helper Functions            ##
                    234: ###############################################################
                    235: 
                    236: =pod 
                    237: 
                    238: =item browser_and_searcher_javascript 
                    239: 
                    240: Returns scalar containing javascript to open a browser window
                    241: or a searcher window.  Also creates 
                    242: 
                    243: =over 4
                    244: 
                    245: =item openbrowser(formname,elementname,only,omit) [javascript]
                    246: 
                    247: inputs: formname, elementname, only, omit
                    248: 
                    249: formname and elementname indicate the name of the html form and name of
                    250: the element that the results of the browsing selection are to be placed in. 
                    251: 
                    252: Specifying 'only' will restrict the browser to displaying only files
                    253: with the given extension.  Can be a comma seperated list.
                    254: 
                    255: Specifying 'omit' will restrict the browser to NOT displaying files
                    256: with the given extension.  Can be a comma seperated list.
                    257: 
                    258: =item opensearcher(formname, elementname) [javascript]
                    259: 
                    260: Inputs: formname, elementname
                    261: 
                    262: formname and elementname specify the name of the html form and the name
                    263: of the element the selection from the search results will be placed in.
                    264: 
                    265: =back
                    266: 
                    267: =cut
                    268: 
                    269: ###############################################################
                    270: sub browser_and_searcher_javascript {
                    271:     return <<END;
1.50      matthew   272:     var editbrowser = null;
1.42      matthew   273:     function openbrowser(formname,elementname,only,omit) {
                    274:         var url = '/res/?';
                    275:         if (editbrowser == null) {
                    276:             url += 'launch=1&';
                    277:         }
                    278:         url += 'catalogmode=interactive&';
                    279:         url += 'mode=edit&';
                    280:         url += 'form=' + formname + '&';
                    281:         if (only != null) {
                    282:             url += 'only=' + only + '&';
                    283:         } 
                    284:         if (omit != null) {
                    285:             url += 'omit=' + omit + '&';
                    286:         }
                    287:         url += 'element=' + elementname + '';
                    288:         var title = 'Browser';
                    289:         var options = 'scrollbars=1,resizable=1,menubar=0';
                    290:         options += ',width=700,height=600';
                    291:         editbrowser = open(url,title,options,'1');
                    292:         editbrowser.focus();
                    293:     }
                    294:     var editsearcher;
                    295:     function opensearcher(formname,elementname) {
                    296:         var url = '/adm/searchcat?';
                    297:         if (editsearcher == null) {
                    298:             url += 'launch=1&';
                    299:         }
                    300:         url += 'catalogmode=interactive&';
                    301:         url += 'mode=edit&';
                    302:         url += 'form=' + formname + '&';
                    303:         url += 'element=' + elementname + '';
                    304:         var title = 'Search';
                    305:         var options = 'scrollbars=1,resizable=1,menubar=0';
                    306:         options += ',width=700,height=600';
                    307:         editsearcher = open(url,title,options,'1');
                    308:         editsearcher.focus();
                    309:     }
                    310: END
                    311: }
                    312: 
1.74      www       313: sub studentbrowser_javascript {
                    314:    unless ($ENV{'request.course.id'}) { return ''; }  
                    315:    unless (&Apache::lonnet::allowed('srm',$ENV{'request.course.id'})) {
                    316:         return '';
                    317:    }
                    318:    return (<<'ENDSTDBRW');
                    319: <script type="text/javascript" language="Javascript" >
                    320:     var stdeditbrowser;
                    321:     function openstdbrowser(formname,uname,udom) {
                    322:         var url = '/adm/pickstudent?';
                    323:         var filter;
                    324:         eval('filter=document.'+formname+'.'+uname+'.value;');
                    325:         if (filter != null) {
                    326:            if (filter != '') {
                    327:                url += 'filter='+filter+'&';
                    328: 	   }
                    329:         }
                    330:         url += 'form=' + formname + '&unameelement='+uname+
                    331:                                     '&udomelement='+udom;
                    332:         var title = 'Student Browser';
                    333:         var options = 'scrollbars=1,resizable=1,menubar=0';
                    334:         options += ',width=700,height=600';
                    335:         stdeditbrowser = open(url,title,options,'1');
                    336:         stdeditbrowser.focus();
                    337:     }
                    338: </script>
                    339: ENDSTDBRW
                    340: }
1.42      matthew   341: 
1.74      www       342: sub selectstudent_link {
                    343:     my ($form,$unameele,$udomele)=@_;
                    344:    unless ($ENV{'request.course.id'}) { return ''; }  
                    345:    unless (&Apache::lonnet::allowed('srm',$ENV{'request.course.id'})) {
                    346:         return '';
                    347:    }
                    348:     return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele.
                    349:         '","'.$udomele.'");'."'>Select</a>";
                    350: }
1.42      matthew   351: 
                    352: ###############################################################
                    353: 
                    354: =pod
1.36      matthew   355: 
                    356: =item linked_select_forms(...)
                    357: 
                    358: linked_select_forms returns a string containing a <script></script> block
                    359: and html for two <select> menus.  The select menus will be linked in that
                    360: changing the value of the first menu will result in new values being placed
                    361: in the second menu.  The values in the select menu will appear in alphabetical
                    362: order.
                    363: 
                    364: linked_select_forms takes the following ordered inputs:
                    365: 
                    366: =over 4
                    367: 
                    368: =item $formname, the name of the <form> tag
                    369: 
                    370: =item $middletext, the text which appears between the <select> tags
                    371: 
                    372: =item $firstdefault, the default value for the first menu
                    373: 
                    374: =item $firstselectname, the name of the first <select> tag
                    375: 
                    376: =item $secondselectname, the name of the second <select> tag
                    377: 
                    378: =item $hashref, a reference to a hash containing the data for the menus.
                    379: 
1.41      ng        380: =back 
                    381: 
1.36      matthew   382: Below is an example of such a hash.  Only the 'text', 'default', and 
                    383: 'select2' keys must appear as stated.  keys(%menu) are the possible 
                    384: values for the first select menu.  The text that coincides with the 
1.41      ng        385: first menu value is given in $menu{$choice1}->{'text'}.  The values 
1.36      matthew   386: and text for the second menu are given in the hash pointed to by 
                    387: $menu{$choice1}->{'select2'}.  
                    388: 
1.41      ng        389: my %menu = ( A1 => { text =>"Choice A1" ,
1.36      matthew   390:                       default => "B3",
                    391:                       select2 => { 
                    392:                           B1 => "Choice B1",
                    393:                           B2 => "Choice B2",
                    394:                           B3 => "Choice B3",
                    395:                           B4 => "Choice B4"
                    396:                           }
                    397:                   },
                    398:               A2 => { text =>"Choice A2" ,
                    399:                       default => "C2",
                    400:                       select2 => { 
                    401:                           C1 => "Choice C1",
                    402:                           C2 => "Choice C2",
                    403:                           C3 => "Choice C3"
                    404:                           }
                    405:                   },
                    406:               A3 => { text =>"Choice A3" ,
                    407:                       default => "D6",
                    408:                       select2 => { 
                    409:                           D1 => "Choice D1",
                    410:                           D2 => "Choice D2",
                    411:                           D3 => "Choice D3",
                    412:                           D4 => "Choice D4",
                    413:                           D5 => "Choice D5",
                    414:                           D6 => "Choice D6",
                    415:                           D7 => "Choice D7"
                    416:                           }
                    417:                   }
                    418:               );
                    419: 
                    420: =cut
                    421: 
                    422: # ------------------------------------------------
                    423: 
                    424: sub linked_select_forms {
                    425:     my ($formname,
                    426:         $middletext,
                    427:         $firstdefault,
                    428:         $firstselectname,
                    429:         $secondselectname, 
                    430:         $hashref
                    431:         ) = @_;
                    432:     my $second = "document.$formname.$secondselectname";
                    433:     my $first = "document.$formname.$firstselectname";
                    434:     # output the javascript to do the changing
                    435:     my $result = '';
                    436:     $result.="<script>\n";
                    437:     $result.="var select2data = new Object();\n";
                    438:     $" = '","';
                    439:     my $debug = '';
                    440:     foreach my $s1 (sort(keys(%$hashref))) {
                    441:         $result.="select2data.d_$s1 = new Object();\n";        
                    442:         $result.="select2data.d_$s1.def = new String('".
                    443:             $hashref->{$s1}->{'default'}."');\n";
                    444:         $result.="select2data.d_$s1.values = new Array(";        
                    445:         my @s2values = sort(keys( %{ $hashref->{$s1}->{'select2'} } ));
                    446:         $result.="\"@s2values\");\n";
                    447:         $result.="select2data.d_$s1.texts = new Array(";        
                    448:         my @s2texts;
                    449:         foreach my $value (@s2values) {
                    450:             push @s2texts, $hashref->{$s1}->{'select2'}->{$value};
                    451:         }
                    452:         $result.="\"@s2texts\");\n";
                    453:     }
                    454:     $"=' ';
                    455:     $result.= <<"END";
                    456: 
                    457: function select1_changed() {
                    458:     // Determine new choice
                    459:     var newvalue = "d_" + $first.value;
                    460:     // update select2
                    461:     var values     = select2data[newvalue].values;
                    462:     var texts      = select2data[newvalue].texts;
                    463:     var select2def = select2data[newvalue].def;
                    464:     var i;
                    465:     // out with the old
                    466:     for (i = 0; i < $second.options.length; i++) {
                    467:         $second.options[i] = null;
                    468:     }
                    469:     // in with the nuclear
                    470:     for (i=0;i<values.length; i++) {
                    471:         $second.options[i] = new Option(values[i]);
                    472:         $second.options[i].text = texts[i];
                    473:         if (values[i] == select2def) {
                    474:             $second.options[i].selected = true;
                    475:         }
                    476:     }
                    477: }
                    478: </script>
                    479: END
                    480:     # output the initial values for the selection lists
                    481:     $result .= "<select size=\"1\" name=\"$firstselectname\" onchange=\"select1_changed()\">\n";
                    482:     foreach my $value (sort(keys(%$hashref))) {
                    483:         $result.="    <option value=\"$value\" ";
                    484:         $result.=" selected=\"true\" " if ($value eq $firstdefault);
                    485:         $result.=">$hashref->{$value}->{'text'}</option>\n";
                    486:     }
                    487:     $result .= "</select>\n";
                    488:     my %select2 = %{$hashref->{$firstdefault}->{'select2'}};
                    489:     $result .= $middletext;
                    490:     $result .= "<select size=\"1\" name=\"$secondselectname\">\n";
                    491:     my $seconddefault = $hashref->{$firstdefault}->{'default'};
                    492:     foreach my $value (sort(keys(%select2))) {
                    493:         $result.="    <option value=\"$value\" ";        
                    494:         $result.=" selected=\"true\" " if ($value eq $seconddefault);
                    495:         $result.=">$select2{$value}</option>\n";
                    496:     }
                    497:     $result .= "</select>\n";
                    498:     #    return $debug;
                    499:     return $result;
                    500: }   #  end of sub linked_select_forms {
                    501: 
1.33      matthew   502: ###############################################################
1.44      bowersj2  503: 
1.45      matthew   504: =pod
1.44      bowersj2  505: 
1.48      bowersj2  506: =item help_open_topic($topic, $text, $stayOnPage, $width, $height)
1.44      bowersj2  507: 
                    508: Returns a string corresponding to an HTML link to the given help $topic, where $topic corresponds to the name of a .tex file in /home/httpd/html/adm/help/tex, with underscores replaced by spaces.
                    509: 
1.48      bowersj2  510: $text will optionally be linked to the same topic, allowing you to link text in addition to the graphic. If you do not want to link text, but wish to specify one of the later parameters, pass an empty string.
                    511: 
1.44      bowersj2  512: $stayOnPage is a value that will be interpreted as a boolean. If true, the link will not open a new window. If false, the link will open a new window using Javascript. (Default is false.)
                    513: 
                    514: $width and $height are optional numerical parameters that will override the width and height of the popped up window, which may be useful for certain help topics with big pictures included.
                    515: 
                    516: =cut
                    517: 
                    518: sub help_open_topic {
1.48      bowersj2  519:     my ($topic, $text, $stayOnPage, $width, $height) = @_;
                    520:     $text = "" if (not defined $text);
1.44      bowersj2  521:     $stayOnPage = 0 if (not defined $stayOnPage);
1.79      www       522:     if ($ENV{'browser.interface'} eq 'textual') {
                    523: 	$stayOnPage=1;
                    524:     }
1.44      bowersj2  525:     $width = 350 if (not defined $width);
                    526:     $height = 400 if (not defined $height);
                    527:     my $filename = $topic;
                    528:     $filename =~ s/ /_/g;
                    529: 
1.48      bowersj2  530:     my $template = "";
                    531:     my $link;
1.44      bowersj2  532: 
                    533:     if (!$stayOnPage)
                    534:     {
1.72      bowersj2  535: 	$link = "javascript:void(open('/adm/help/${filename}.hlp', 'Help_for_$topic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";
1.44      bowersj2  536:     }
                    537:     else
                    538:     {
1.48      bowersj2  539: 	$link = "/adm/help/${filename}.hlp";
                    540:     }
                    541: 
                    542:     # Add the text
                    543:     if ($text ne "")
                    544:     {
1.77      www       545: 	$template .= 
                    546:   "<table bgcolor='#3333AA' cellspacing='1' cellpadding='1' border='0'><tr>".
1.78      www       547:   "<td bgcolor='#5555FF'><a href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
1.48      bowersj2  548:     }
                    549: 
                    550:     # Add the graphic
                    551:     $template .= <<"ENDTEMPLATE";
1.77      www       552:  <a href="$link"><image src="/adm/help/gif/smallHelp.gif" border="0" alt="(Help: $topic)" /></a>
1.44      bowersj2  553: ENDTEMPLATE
1.78      www       554:     if ($text ne '') { $template.='</td></tr></table>' };
1.44      bowersj2  555:     return $template;
                    556: 
                    557: }
1.37      matthew   558: 
1.45      matthew   559: =pod
                    560: 
1.37      matthew   561: =item csv_translate($text) 
                    562: 
                    563: Translate $text to allow it to be output as a 'comma seperated values' 
                    564: format.
                    565: 
                    566: =cut
                    567: 
                    568: sub csv_translate {
                    569:     my $text = shift;
                    570:     $text =~ s/\"/\"\"/g;
                    571:     $text =~ s/\n//g;
                    572:     return $text;
                    573: }
                    574: 
                    575: ###############################################################
1.33      matthew   576: ##        Home server <option> list generating code          ##
                    577: ###############################################################
1.35      matthew   578: #-------------------------------------------
                    579: 
1.45      matthew   580: =pod
                    581: 
1.35      matthew   582: =item get_domains()
                    583: 
                    584: Returns an array containing each of the domains listed in the hosts.tab
                    585: file.
                    586: 
                    587: =cut
                    588: 
                    589: #-------------------------------------------
1.34      matthew   590: sub get_domains {
                    591:     # The code below was stolen from "The Perl Cookbook", p 102, 1st ed.
                    592:     my @domains;
                    593:     my %seen;
                    594:     foreach (sort values(%Apache::lonnet::hostdom)) {
                    595:         push (@domains,$_) unless $seen{$_}++;
                    596:     }
                    597:     return @domains;
                    598: }
                    599: 
1.35      matthew   600: #-------------------------------------------
                    601: 
1.45      matthew   602: =pod
                    603: 
1.35      matthew   604: =item select_dom_form($defdom,$name)
                    605: 
                    606: Returns a string containing a <select name='$name' size='1'> form to 
                    607: allow a user to select the domain to preform an operation in.  
                    608: See loncreateuser.pm for an example invocation and use.
                    609: 
                    610: =cut
                    611: 
                    612: #-------------------------------------------
1.34      matthew   613: sub select_dom_form {
                    614:     my ($defdom,$name) = @_;
                    615:     my @domains = get_domains();
                    616:     my $selectdomain = "<select name=\"$name\" size=\"1\">\n";
                    617:     foreach (@domains) {
                    618:         $selectdomain.="<option value=\"$_\" ".
                    619:             ($_ eq $defdom ? 'selected' : '').
                    620:                 ">$_</option>\n";
                    621:     }
                    622:     $selectdomain.="</select>";
                    623:     return $selectdomain;
                    624: }
                    625: 
1.35      matthew   626: #-------------------------------------------
                    627: 
1.45      matthew   628: =pod
                    629: 
1.52      matthew   630: =item get_library_servers($domain)
1.35      matthew   631: 
                    632: Returns a hash which contains keys like '103l3' and values like 
                    633: 'kirk.lite.msu.edu'.  All of the keys will be for machines in the
                    634: given $domain.
                    635: 
                    636: =cut
                    637: 
                    638: #-------------------------------------------
1.52      matthew   639: sub get_library_servers {
1.33      matthew   640:     my $domain = shift;
1.52      matthew   641:     my %library_servers;
1.33      matthew   642:     foreach (keys(%Apache::lonnet::libserv)) {
                    643:         if ($Apache::lonnet::hostdom{$_} eq $domain) {
1.52      matthew   644:             $library_servers{$_} = $Apache::lonnet::hostname{$_};
1.33      matthew   645:         }
                    646:     }
1.52      matthew   647:     return %library_servers;
1.33      matthew   648: }
                    649: 
1.35      matthew   650: #-------------------------------------------
                    651: 
1.45      matthew   652: =pod
                    653: 
1.35      matthew   654: =item home_server_option_list($domain)
                    655: 
                    656: returns a string which contains an <option> list to be used in a 
                    657: <select> form input.  See loncreateuser.pm for an example.
                    658: 
                    659: =cut
                    660: 
                    661: #-------------------------------------------
1.33      matthew   662: sub home_server_option_list {
                    663:     my $domain = shift;
1.52      matthew   664:     my %servers = &get_library_servers($domain);
1.33      matthew   665:     my $result = '';
                    666:     foreach (sort keys(%servers)) {
                    667:         $result.=
                    668:             '<option value="'.$_.'">'.$_.' '.$servers{$_}."</option>\n";
                    669:     }
                    670:     return $result;
                    671: }
                    672: ###############################################################
                    673: ##    End of home server <option> list generating code       ##
                    674: ###############################################################
1.32      matthew   675: 
                    676: ###############################################################
                    677: ##    Authentication changing form generation subroutines    ##
                    678: ###############################################################
                    679: ##
                    680: ## All of the authform_xxxxxxx subroutines take their inputs in a
                    681: ## hash, and have reasonable default values.
                    682: ##
                    683: ##    formname = the name given in the <form> tag.
1.35      matthew   684: #-------------------------------------------
                    685: 
1.45      matthew   686: =pod
                    687: 
1.35      matthew   688: =item authform_xxxxxx
                    689: 
                    690: The authform_xxxxxx subroutines provide javascript and html forms which 
                    691: handle some of the conveniences required for authentication forms.  
                    692: This is not an optimal method, but it works.  
                    693: 
                    694: See loncreateuser.pm for invocation and use examples.
                    695: 
                    696: =over 4
                    697: 
                    698: =item authform_header
                    699: 
                    700: =item authform_authorwarning
                    701: 
                    702: =item authform_nochange
                    703: 
                    704: =item authform_kerberos
                    705: 
                    706: =item authform_internal
                    707: 
                    708: =item authform_filesystem
                    709: 
                    710: =back
                    711: 
                    712: =cut
                    713: 
                    714: #-------------------------------------------
1.32      matthew   715: sub authform_header{  
                    716:     my %in = (
                    717:         formname => 'cu',
1.80      albertel  718:         kerb_def_dom => '',
1.32      matthew   719:         @_,
                    720:     );
                    721:     $in{'formname'} = 'document.' . $in{'formname'};
                    722:     my $result='';
1.80      albertel  723: 
                    724: #---------------------------------------------- Code for upper case translation
                    725:     my $Javascript_toUpperCase;
                    726:     unless ($in{kerb_def_dom}) {
                    727:         $Javascript_toUpperCase =<<"END";
                    728:         switch (choice) {
                    729:            case 'krb': currentform.elements[choicearg].value =
                    730:                currentform.elements[choicearg].value.toUpperCase();
                    731:                break;
                    732:            default:
                    733:         }
                    734: END
                    735:     } else {
                    736:         $Javascript_toUpperCase = "";
                    737:     }
                    738: 
1.32      matthew   739:     $result.=<<"END";
                    740: var current = new Object();
                    741: current.radiovalue = 'nochange';
                    742: current.argfield = null;
                    743: 
                    744: function changed_radio(choice,currentform) {
                    745:     var choicearg = choice + 'arg';
                    746:     // If a radio button in changed, we need to change the argfield
                    747:     if (current.radiovalue != choice) {
                    748:         current.radiovalue = choice;
                    749:         if (current.argfield != null) {
                    750:             currentform.elements[current.argfield].value = '';
                    751:         }
                    752:         if (choice == 'nochange') {
                    753:             current.argfield = null;
                    754:         } else {
                    755:             current.argfield = choicearg;
                    756:             switch(choice) {
                    757:                 case 'krb': 
                    758:                     currentform.elements[current.argfield].value = 
                    759:                         "$in{'kerb_def_dom'}";
                    760:                 break;
                    761:               default:
                    762:                 break;
                    763:             }
                    764:         }
                    765:     }
                    766:     return;
                    767: }
1.22      www       768: 
1.32      matthew   769: function changed_text(choice,currentform) {
                    770:     var choicearg = choice + 'arg';
                    771:     if (currentform.elements[choicearg].value !='') {
1.80      albertel  772:         $Javascript_toUpperCase
1.32      matthew   773:         // clear old field
                    774:         if ((current.argfield != choicearg) && (current.argfield != null)) {
                    775:             currentform.elements[current.argfield].value = '';
                    776:         }
                    777:         current.argfield = choicearg;
                    778:     }
                    779:     set_auth_radio_buttons(choice,currentform);
                    780:     return;
1.20      www       781: }
1.32      matthew   782: 
                    783: function set_auth_radio_buttons(newvalue,currentform) {
                    784:     var i=0;
                    785:     while (i < currentform.login.length) {
                    786:         if (currentform.login[i].value == newvalue) { break; }
                    787:         i++;
                    788:     }
                    789:     if (i == currentform.login.length) {
                    790:         return;
                    791:     }
                    792:     current.radiovalue = newvalue;
                    793:     currentform.login[i].checked = true;
                    794:     return;
                    795: }
                    796: END
                    797:     return $result;
                    798: }
                    799: 
                    800: sub authform_authorwarning{
                    801:     my $result='';
                    802:     $result=<<"END";
                    803: <i>As a general rule, only authors or co-authors should be filesystem
                    804: authenticated (which allows access to the server filesystem).</i>
                    805: END
                    806:     return $result;
                    807: }
                    808: 
                    809: sub authform_nochange{  
                    810:     my %in = (
                    811:               formname => 'document.cu',
                    812:               kerb_def_dom => 'MSU.EDU',
                    813:               @_,
                    814:           );
                    815:     my $result='';
                    816:     $result.=<<"END";
                    817: <input type="radio" name="login" value="nochange" checked="checked"
1.57      albertel  818:        onclick="javascript:changed_radio('nochange',$in{'formname'});" />
1.32      matthew   819: Do not change login data
                    820: END
                    821:     return $result;
                    822: }
                    823: 
                    824: sub authform_kerberos{  
                    825:     my %in = (
                    826:               formname => 'document.cu',
                    827:               kerb_def_dom => 'MSU.EDU',
1.80      albertel  828:               kerb_def_auth => 'krb4',
1.32      matthew   829:               @_,
                    830:               );
                    831:     my $result='';
1.80      albertel  832:     my $check4;
                    833:     my $check5;
                    834:     if ($in{'kerb_def_auth'} eq 'krb5') {
                    835:        $check5 = " checked=\"on\"";
                    836:     } else {
                    837:        $check4 = " checked=\"on\"";
                    838:     }
1.32      matthew   839:     $result.=<<"END";
                    840: <input type="radio" name="login" value="krb" 
                    841:        onclick="javascript:changed_radio('krb',$in{'formname'});"
1.57      albertel  842:        onchange="javascript:changed_radio('krb',$in{'formname'});" />
1.32      matthew   843: Kerberos authenticated with domain
1.80      albertel  844: <input type="text" size="10" name="krbarg" value="$in{'kerb_def_dom'}"
1.57      albertel  845:        onchange="javascript:changed_text('krb',$in{'formname'});" />
1.80      albertel  846: <input type="radio" name="krbver" value="4" $check4 />Version 4
                    847: <input type="radio" name="krbver" value="5" $check5 />Version 5
1.32      matthew   848: END
                    849:     return $result;
                    850: }
                    851: 
                    852: sub authform_internal{  
                    853:     my %args = (
                    854:                 formname => 'document.cu',
                    855:                 kerb_def_dom => 'MSU.EDU',
                    856:                 @_,
                    857:                 );
                    858:     my $result='';
                    859:     $result.=<<"END";
                    860: <input type="radio" name="login" value="int"
                    861:        onchange="javascript:changed_radio('int',$args{'formname'});"
1.57      albertel  862:        onclick="javascript:changed_radio('int',$args{'formname'});" />
1.32      matthew   863: Internally authenticated (with initial password 
                    864: <input type="text" size="10" name="intarg" value=""
1.75      www       865:        onchange="javascript:changed_text('int',$args{'formname'});" />)
1.32      matthew   866: END
                    867:     return $result;
                    868: }
                    869: 
                    870: sub authform_local{  
                    871:     my %in = (
                    872:               formname => 'document.cu',
                    873:               kerb_def_dom => 'MSU.EDU',
                    874:               @_,
                    875:               );
                    876:     my $result='';
                    877:     $result.=<<"END";
                    878: <input type="radio" name="login" value="loc"
                    879:        onchange="javascript:changed_radio('loc',$in{'formname'});"
1.57      albertel  880:        onclick="javascript:changed_radio('loc',$in{'formname'});" />
1.32      matthew   881: Local Authentication with argument
                    882: <input type="text" size="10" name="locarg" value=""
1.57      albertel  883:        onchange="javascript:changed_text('loc',$in{'formname'});" />
1.32      matthew   884: END
                    885:     return $result;
                    886: }
                    887: 
                    888: sub authform_filesystem{  
                    889:     my %in = (
                    890:               formname => 'document.cu',
                    891:               kerb_def_dom => 'MSU.EDU',
                    892:               @_,
                    893:               );
                    894:     my $result='';
                    895:     $result.=<<"END";
                    896: <input type="radio" name="login" value="fsys" 
                    897:        onchange="javascript:changed_radio('fsys',$in{'formname'});"
1.57      albertel  898:        onclick="javascript:changed_radio('fsys',$in{'formname'});" />
1.32      matthew   899: Filesystem authenticated (with initial password 
                    900: <input type="text" size="10" name="fsysarg" value=""
1.75      www       901:        onchange="javascript:changed_text('fsys',$in{'formname'});">)
1.32      matthew   902: END
                    903:     return $result;
                    904: }
                    905: 
                    906: ###############################################################
                    907: ##   End Authentication changing form generation functions   ##
1.80      albertel  908: ###############################################################
                    909: 
                    910: ###############################################################
                    911: ##    Get Authentication Defaults for Domain                 ##
                    912: ###############################################################
                    913: ##
                    914: ## Returns default authentication type and an associated argument
                    915: ## as listed in file domain.tab
                    916: ##
                    917: #-------------------------------------------
                    918: 
                    919: =pod
                    920: 
                    921: =item get_auth_defaults
                    922: 
                    923: get_auth_defaults($target_domain) returns the default authentication
                    924: type and an associated argument (initial password or a kerberos domain).
                    925: These values are stored in lonTabs/domain.tab
                    926: 
                    927: ($def_auth, $def_arg) = &get_auth_defaults($target_domain);
                    928: 
                    929: If target_domain is not found in domain.tab, returns nothing ('').
                    930: 
                    931: =over 4
                    932: 
                    933: =item get_auth_defaults
                    934: 
                    935: =back
                    936: 
                    937: =cut
                    938: 
                    939: #-------------------------------------------
                    940: sub get_auth_defaults {
                    941:     my $domain=shift;
                    942:     return ($Apache::lonnet::domain_auth_def{$domain},$Apache::lonnet::domain_auth_arg_def{$domain});
                    943: }
                    944: ###############################################################
                    945: ##   End Get Authentication Defaults for Domain              ##
                    946: ###############################################################
                    947: 
                    948: ###############################################################
                    949: ##    Get Kerberos Defaults for Domain                 ##
                    950: ###############################################################
                    951: ##
                    952: ## Returns default kerberos version and an associated argument
                    953: ## as listed in file domain.tab. If not listed, provides
                    954: ## appropriate default domain and kerberos version.
                    955: ##
                    956: #-------------------------------------------
                    957: 
                    958: =pod
                    959: 
                    960: =item get_kerberos_defaults
                    961: 
                    962: get_kerberos_defaults($target_domain) returns the default kerberos
                    963: version and domain. If not found in domain.tabs, it defaults to
                    964: version 4 and the domain of the server.
                    965: 
                    966: ($def_version, $def_krb_domain) = &get_kerberos_defaults($target_domain);
                    967: 
                    968: =over 4
                    969: 
                    970: =item get_kerberos_defaults
                    971: 
                    972: =back
                    973: 
                    974: =cut
                    975: 
                    976: #-------------------------------------------
                    977: sub get_kerberos_defaults {
                    978:     my $domain=shift;
                    979:     my ($krbdef,$krbdefdom) =
                    980:         &Apache::loncommon::get_auth_defaults($domain);
                    981:     unless ($krbdef =~/^krb/ && $krbdefdom) {
                    982:         $ENV{'SERVER_NAME'}=~/(\w+\.\w+)$/;
                    983:         my $krbdefdom=$1;
                    984:         $krbdefdom=~tr/a-z/A-Z/;
                    985:         $krbdef = "krb4";
                    986:     }
                    987:     return ($krbdef,$krbdefdom);
                    988: }
                    989: ###############################################################
                    990: ##   End Get Kerberos Defaults for Domain              ##
1.32      matthew   991: ###############################################################
                    992: 
1.46      matthew   993: ###############################################################
                    994: ##                Thesaurus Functions                        ##
                    995: ###############################################################
1.20      www       996: 
1.46      matthew   997: =pod
1.20      www       998: 
1.46      matthew   999: =item initialize_keywords
                   1000: 
                   1001: Initializes the package variable %Keywords if it is empty.  Uses the
                   1002: package variable $thesaurus_db_file.
                   1003: 
                   1004: =cut
                   1005: 
                   1006: ###################################################
                   1007: 
                   1008: sub initialize_keywords {
                   1009:     return 1 if (scalar keys(%Keywords));
                   1010:     # If we are here, %Keywords is empty, so fill it up
                   1011:     #   Make sure the file we need exists...
                   1012:     if (! -e $thesaurus_db_file) {
                   1013:         &Apache::lonnet::logthis("Attempt to access $thesaurus_db_file".
                   1014:                                  " failed because it does not exist");
                   1015:         return 0;
                   1016:     }
                   1017:     #   Set up the hash as a database
                   1018:     my %thesaurus_db;
                   1019:     if (! tie(%thesaurus_db,'GDBM_File',
1.53      albertel 1020:               $thesaurus_db_file,&GDBM_READER(),0640)){
1.46      matthew  1021:         &Apache::lonnet::logthis("Could not tie \%thesaurus_db to ".
                   1022:                                  $thesaurus_db_file);
                   1023:         return 0;
                   1024:     } 
                   1025:     #  Get the average number of appearances of a word.
                   1026:     my $avecount = $thesaurus_db{'average.count'};
                   1027:     #  Put keywords (those that appear > average) into %Keywords
                   1028:     while (my ($word,$data)=each (%thesaurus_db)) {
                   1029:         my ($count,undef) = split /:/,$data;
                   1030:         $Keywords{$word}++ if ($count > $avecount);
                   1031:     }
                   1032:     untie %thesaurus_db;
                   1033:     # Remove special values from %Keywords.
                   1034:     foreach ('total.count','average.count') {
                   1035:         delete($Keywords{$_}) if (exists($Keywords{$_}));
                   1036:     }
                   1037:     return 1;
                   1038: }
                   1039: 
                   1040: ###################################################
                   1041: 
                   1042: =pod
                   1043: 
                   1044: =item keyword($word)
                   1045: 
                   1046: Returns true if $word is a keyword.  A keyword is a word that appears more 
                   1047: than the average number of times in the thesaurus database.  Calls 
                   1048: &initialize_keywords
                   1049: 
                   1050: =cut
                   1051: 
                   1052: ###################################################
1.20      www      1053: 
                   1054: sub keyword {
1.46      matthew  1055:     return if (!&initialize_keywords());
                   1056:     my $word=lc(shift());
                   1057:     $word=~s/\W//g;
                   1058:     return exists($Keywords{$word});
1.20      www      1059: }
1.46      matthew  1060: 
                   1061: ###############################################################
                   1062: 
                   1063: =pod 
1.20      www      1064: 
1.46      matthew  1065: =item get_related_words
                   1066: 
                   1067: Look up a word in the thesaurus.  Takes a scalar arguement and returns
                   1068: an array of words.  If the keyword is not in the thesaurus, an empty array
                   1069: will be returned.  The order of the words returned is determined by the
                   1070: database which holds them.
                   1071: 
                   1072: Uses global $thesaurus_db_file.
                   1073: 
                   1074: =cut
                   1075: 
                   1076: ###############################################################
                   1077: sub get_related_words {
                   1078:     my $keyword = shift;
                   1079:     my %thesaurus_db;
                   1080:     if (! -e $thesaurus_db_file) {
                   1081:         &Apache::lonnet::logthis("Attempt to access $thesaurus_db_file ".
                   1082:                                  "failed because the file does not exist");
                   1083:         return ();
                   1084:     }
                   1085:     if (! tie(%thesaurus_db,'GDBM_File',
1.53      albertel 1086:               $thesaurus_db_file,&GDBM_READER(),0640)){
1.46      matthew  1087:         return ();
                   1088:     } 
                   1089:     my @Words=();
                   1090:     if (exists($thesaurus_db{$keyword})) {
                   1091:         $_ = $thesaurus_db{$keyword};
                   1092:         (undef,@Words) = split/:/;  # The first element is the number of times
                   1093:                                     # the word appears.  We do not need it now.
                   1094:         for (my $i=0;$i<=$#Words;$i++) {
                   1095:             ($Words[$i],undef)= split/\,/,$Words[$i];
1.20      www      1096:         }
                   1097:     }
1.46      matthew  1098:     untie %thesaurus_db;
                   1099:     return @Words;
1.14      harris41 1100: }
1.46      matthew  1101: 
                   1102: ###############################################################
                   1103: ##              End Thesaurus Functions                      ##
                   1104: ###############################################################
1.61      www      1105: 
                   1106: # -------------------------------------------------------------- Plaintext name
1.81      albertel 1107: =pod
                   1108: 
                   1109: =item plainname($uname,$udom)
                   1110: 
                   1111: Gets a users name and returns it as a string in
                   1112: "first middle last generation"
                   1113: form
                   1114: 
                   1115: =cut
1.61      www      1116: 
1.81      albertel 1117: ###############################################################
1.61      www      1118: sub plainname {
                   1119:     my ($uname,$udom)=@_;
                   1120:     my %names=&Apache::lonnet::get('environment',
                   1121:                     ['firstname','middlename','lastname','generation'],
                   1122: 					 $udom,$uname);
1.62      www      1123:     my $name=$names{'firstname'}.' '.$names{'middlename'}.' '.
1.61      www      1124: 	$names{'lastname'}.' '.$names{'generation'};
1.62      www      1125:     $name=~s/\s+$//;
                   1126:     $name=~s/\s+/ /g;
                   1127:     return $name;
1.61      www      1128: }
1.66      www      1129: 
                   1130: # -------------------------------------------------------------------- Nickname
1.81      albertel 1131: =pod
                   1132: 
                   1133: =item nickname($uname,$udom)
                   1134: 
                   1135: Gets a users name and returns it as a string as
                   1136: 
                   1137: "&quot;nickname&quot;"
1.66      www      1138: 
1.81      albertel 1139: if the user has a nickname or
                   1140: 
                   1141: "first middle last generation"
                   1142: 
                   1143: if the user does not
                   1144: 
                   1145: =cut
1.66      www      1146: 
                   1147: sub nickname {
                   1148:     my ($uname,$udom)=@_;
                   1149:     my %names=&Apache::lonnet::get('environment',
                   1150:   ['nickname','firstname','middlename','lastname','generation'],$udom,$uname);
1.68      albertel 1151:     my $name=$names{'nickname'};
1.66      www      1152:     if ($name) {
                   1153:        $name='&quot;'.$name.'&quot;'; 
                   1154:     } else {
                   1155:        $name=$names{'firstname'}.' '.$names{'middlename'}.' '.
                   1156: 	     $names{'lastname'}.' '.$names{'generation'};
                   1157:        $name=~s/\s+$//;
                   1158:        $name=~s/\s+/ /g;
                   1159:     }
                   1160:     return $name;
                   1161: }
                   1162: 
1.61      www      1163: 
                   1164: # ------------------------------------------------------------------ Screenname
1.81      albertel 1165: 
                   1166: =pod
                   1167: 
                   1168: =item screenname($uname,$udom)
                   1169: 
                   1170: Gets a users screenname and returns it as a string
                   1171: 
                   1172: =cut
1.61      www      1173: 
                   1174: sub screenname {
                   1175:     my ($uname,$udom)=@_;
                   1176:     my %names=
                   1177:  &Apache::lonnet::get('environment',['screenname'],$udom,$uname);
1.68      albertel 1178:     return $names{'screenname'};
1.62      www      1179: }
                   1180: 
                   1181: # ------------------------------------------------------------- Message Wrapper
                   1182: 
                   1183: sub messagewrapper {
                   1184:     my ($link,$un,$do)=@_;
                   1185:     return 
                   1186: "<a href='/adm/email?compose=individual&recname=$un&recdom=$do'>$link</a>";
1.74      www      1187: }
                   1188: # --------------------------------------------------------------- Notes Wrapper
                   1189: 
                   1190: sub noteswrapper {
                   1191:     my ($link,$un,$do)=@_;
                   1192:     return 
                   1193: "<a href='/adm/email?recordftf=retrieve&recname=$un&recdom=$do'>$link</a>";
1.62      www      1194: }
                   1195: # ------------------------------------------------------------- Aboutme Wrapper
                   1196: 
                   1197: sub aboutmewrapper {
1.69      matthew  1198:     my ($link,$username,$domain)=@_;
                   1199:     return "<a href='/adm/$domain/$username/aboutme'>$link</a>";
1.62      www      1200: }
                   1201: 
                   1202: # ------------------------------------------------------------ Syllabus Wrapper
                   1203: 
                   1204: 
                   1205: sub syllabuswrapper {
1.73      www      1206:     my ($link,$un,$do,$tf)=@_;
                   1207:     if ($tf) { $link='<font color="'.$tf.'">'.$link.'</font>'; }
1.62      www      1208:     return "<a href='/public/$do/$un/syllabus'>$link</a>";
1.61      www      1209: }
1.14      harris41 1210: 
                   1211: # ---------------------------------------------------------------- Language IDs
                   1212: sub languageids {
1.16      harris41 1213:     return sort(keys(%language));
1.14      harris41 1214: }
                   1215: 
                   1216: # -------------------------------------------------------- Language Description
                   1217: sub languagedescription {
1.16      harris41 1218:     return $language{shift(@_)};
1.14      harris41 1219: }
                   1220: 
                   1221: # --------------------------------------------------------------- Copyright IDs
                   1222: sub copyrightids {
1.16      harris41 1223:     return sort(keys(%cprtag));
1.14      harris41 1224: }
                   1225: 
                   1226: # ------------------------------------------------------- Copyright Description
                   1227: sub copyrightdescription {
1.16      harris41 1228:     return $cprtag{shift(@_)};
1.14      harris41 1229: }
                   1230: 
                   1231: # ------------------------------------------------------------- File Categories
                   1232: sub filecategories {
1.41      ng       1233:     return sort(keys(%category_extensions));
1.15      harris41 1234: }
1.14      harris41 1235: 
1.17      harris41 1236: # -------------------------------------- File Types within a specified category
1.15      harris41 1237: sub filecategorytypes {
1.41      ng       1238:     return @{$category_extensions{lc($_[0])}};
1.14      harris41 1239: }
                   1240: 
                   1241: # ------------------------------------------------------------------ File Types
                   1242: sub fileextensions {
1.16      harris41 1243:     return sort(keys(%fe));
1.14      harris41 1244: }
                   1245: 
                   1246: # ------------------------------------------------------------- Embedding Style
                   1247: sub fileembstyle {
1.16      harris41 1248:     return $fe{lc(shift(@_))};
1.14      harris41 1249: }
                   1250: 
                   1251: # ------------------------------------------------------------ Description Text
                   1252: sub filedescription {
1.16      harris41 1253:     return $fd{lc(shift(@_))};
                   1254: }
                   1255: 
                   1256: # ------------------------------------------------------------ Description Text
                   1257: sub filedescriptionex {
                   1258:     my $ex=shift;
                   1259:     return '.'.$ex.' '.$fd{lc($ex)};
1.12      harris41 1260: }
1.1       albertel 1261: 
1.40      ng       1262: # ---- Retrieve attempts by students
                   1263: # input
                   1264: # $symb             - problem including path
                   1265: # $username,$domain - that of the student
                   1266: # $course           - course name
                   1267: # $getattempt       - leave blank if want all attempts, else put something.
1.43      ng       1268: # $regexp           - regular expression. If string matches regexp send to
                   1269: # $gradesub         - routine that process the string if it matches regexp
1.40      ng       1270: # 
                   1271: # output
                   1272: # formatted as a table all the attempts, if any.
                   1273: #
1.1       albertel 1274: sub get_previous_attempt {
1.43      ng       1275:   my ($symb,$username,$domain,$course,$getattempt,$regexp,$gradesub)=@_;
1.1       albertel 1276:   my $prevattempts='';
1.43      ng       1277:   no strict 'refs';
1.1       albertel 1278:   if ($symb) {
1.3       albertel 1279:     my (%returnhash)=
                   1280:       &Apache::lonnet::restore($symb,$course,$domain,$username);
1.1       albertel 1281:     if ($returnhash{'version'}) {
                   1282:       my %lasthash=();
                   1283:       my $version;
                   1284:       for ($version=1;$version<=$returnhash{'version'};$version++) {
1.19      harris41 1285:         foreach (sort(split(/\:/,$returnhash{$version.':keys'}))) {
1.1       albertel 1286: 	  $lasthash{$_}=$returnhash{$version.':'.$_};
1.19      harris41 1287:         }
1.1       albertel 1288:       }
1.43      ng       1289:       $prevattempts='<table border="0" width="100%"><tr><td bgcolor="#777777">';
1.40      ng       1290:       $prevattempts.='<table border="0" width="100%"><tr bgcolor="#e6ffff"><td>History</td>';
1.16      harris41 1291:       foreach (sort(keys %lasthash)) {
1.31      albertel 1292: 	my ($ign,@parts) = split(/\./,$_);
1.41      ng       1293: 	if ($#parts > 0) {
1.31      albertel 1294: 	  my $data=$parts[-1];
                   1295: 	  pop(@parts);
1.40      ng       1296: 	  $prevattempts.='<td>Part '.join('.',@parts).'<br />'.$data.'&nbsp;</td>';
1.31      albertel 1297: 	} else {
1.41      ng       1298: 	  if ($#parts == 0) {
                   1299: 	    $prevattempts.='<th>'.$parts[0].'</th>';
                   1300: 	  } else {
                   1301: 	    $prevattempts.='<th>'.$ign.'</th>';
                   1302: 	  }
1.31      albertel 1303: 	}
1.16      harris41 1304:       }
1.40      ng       1305:       if ($getattempt eq '') {
                   1306: 	for ($version=1;$version<=$returnhash{'version'};$version++) {
                   1307: 	  $prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Transaction '.$version.'</td>';
                   1308: 	    foreach (sort(keys %lasthash)) {
                   1309: 	       my $value;
                   1310: 	       if ($_ =~ /timestamp/) {
                   1311: 		  $value=scalar(localtime($returnhash{$version.':'.$_}));
                   1312: 	       } else {
                   1313: 		  $value=$returnhash{$version.':'.$_};
                   1314: 	       }
                   1315: 	       $prevattempts.='<td>'.$value.'&nbsp;</td>';   
                   1316: 	    }
                   1317: 	 }
1.1       albertel 1318:       }
1.40      ng       1319:       $prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Current</td>';
1.16      harris41 1320:       foreach (sort(keys %lasthash)) {
1.5       albertel 1321: 	my $value;
                   1322: 	if ($_ =~ /timestamp/) {
                   1323: 	  $value=scalar(localtime($lasthash{$_}));
                   1324: 	} else {
                   1325: 	  $value=$lasthash{$_};
                   1326: 	}
1.49      ng       1327: 	if ($_ =~/$regexp$/ && (defined &$gradesub)) {$value = &$gradesub($value)}
1.40      ng       1328: 	$prevattempts.='<td>'.$value.'&nbsp;</td>';
1.16      harris41 1329:       }
1.40      ng       1330:       $prevattempts.='</tr></table></td></tr></table>';
1.1       albertel 1331:     } else {
                   1332:       $prevattempts='Nothing submitted - no attempts.';
                   1333:     }
                   1334:   } else {
                   1335:     $prevattempts='No data.';
                   1336:   }
1.10      albertel 1337: }
                   1338: 
                   1339: sub get_student_view {
1.64      sakharuk 1340:   my ($symb,$username,$domain,$courseid,$target) = @_;
1.10      albertel 1341:   my ($map,$id,$feedurl) = split(/___/,$symb);
                   1342:   my (%old,%moreenv);
                   1343:   my @elements=('symb','courseid','domain','username');
                   1344:   foreach my $element (@elements) {
                   1345:     $old{$element}=$ENV{'form.grade_'.$element};
                   1346:     $moreenv{'form.grade_'.$element}=eval '$'.$element #'
                   1347:   }
1.64      sakharuk 1348:   if ($target eq 'tex') {$moreenv{'form.grade_target'} = 'tex';}
1.11      albertel 1349:   &Apache::lonnet::appenv(%moreenv);
                   1350:   my $userview=&Apache::lonnet::ssi('/res/'.$feedurl);
                   1351:   &Apache::lonnet::delenv('form.grade_');
                   1352:   foreach my $element (@elements) {
                   1353:     $ENV{'form.grade_'.$element}=$old{$element};
                   1354:   }
                   1355:   $userview=~s/\<body[^\>]*\>//gi;
                   1356:   $userview=~s/\<\/body\>//gi;
                   1357:   $userview=~s/\<html\>//gi;
                   1358:   $userview=~s/\<\/html\>//gi;
                   1359:   $userview=~s/\<head\>//gi;
                   1360:   $userview=~s/\<\/head\>//gi;
                   1361:   $userview=~s/action\s*\=/would_be_action\=/gi;
                   1362:   return $userview;
                   1363: }
                   1364: 
                   1365: sub get_student_answers {
                   1366:   my ($symb,$username,$domain,$courseid) = @_;
                   1367:   my ($map,$id,$feedurl) = split(/___/,$symb);
                   1368:   my (%old,%moreenv);
                   1369:   my @elements=('symb','courseid','domain','username');
                   1370:   foreach my $element (@elements) {
                   1371:     $old{$element}=$ENV{'form.grade_'.$element};
                   1372:     $moreenv{'form.grade_'.$element}=eval '$'.$element #'
                   1373:   }
                   1374:   $moreenv{'form.grade_target'}='answer';
1.10      albertel 1375:   &Apache::lonnet::appenv(%moreenv);
                   1376:   my $userview=&Apache::lonnet::ssi('/res/'.$feedurl);
                   1377:   &Apache::lonnet::delenv('form.grade_');
                   1378:   foreach my $element (@elements) {
                   1379:     $ENV{'form.grade_'.$element}=$old{$element};
                   1380:   }
                   1381:   return $userview;
1.1       albertel 1382: }
1.37      matthew  1383: 
                   1384: ###############################################
1.51      www      1385: 
                   1386: 
                   1387: sub timehash {
                   1388:     my @ltime=localtime(shift);
                   1389:     return ( 'seconds' => $ltime[0],
                   1390:              'minutes' => $ltime[1],
                   1391:              'hours'   => $ltime[2],
                   1392:              'day'     => $ltime[3],
                   1393:              'month'   => $ltime[4]+1,
                   1394:              'year'    => $ltime[5]+1900,
                   1395:              'weekday' => $ltime[6],
                   1396:              'dayyear' => $ltime[7]+1,
                   1397:              'dlsav'   => $ltime[8] );
                   1398: }
                   1399: 
                   1400: sub maketime {
                   1401:     my %th=@_;
                   1402:     return POSIX::mktime(
                   1403:         ($th{'seconds'},$th{'minutes'},$th{'hours'},
                   1404:          $th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,$th{'dlsav'}));
                   1405: }
                   1406: 
1.70      www      1407: 
                   1408: #########################################
                   1409: #
                   1410: # Retro-fixing of un-backward-compatible time format
                   1411: 
                   1412: sub unsqltime {
                   1413:     my $timestamp=shift;
                   1414:     if ($timestamp=~/^(\d+)\-(\d+)\-(\d+)\s+(\d+)\:(\d+)\:(\d+)$/) {
                   1415:        $timestamp=&maketime(
                   1416: 	   'year'=>$1,'month'=>$2,'day'=>$3,
                   1417:            'hours'=>$4,'minutes'=>$5,'seconds'=>$6);
                   1418:     }
                   1419:     return $timestamp;
                   1420: }
                   1421: 
                   1422: #########################################
1.51      www      1423: 
                   1424: sub findallcourses {
                   1425:     my %courses=();
                   1426:     my $now=time;
                   1427:     foreach (keys %ENV) {
                   1428: 	if ($_=~/^user\.role\.\w+\.\/(\w+)\/(\w+)/) {
                   1429: 	    my ($starttime,$endtime)=$ENV{$_};
                   1430:             my $active=1;
                   1431:             if ($starttime) {
                   1432: 		if ($now<$starttime) { $active=0; }
                   1433:             }
                   1434:             if ($endtime) {
                   1435:                 if ($now>$endtime) { $active=0; }
                   1436:             }
                   1437:             if ($active) { $courses{$1.'_'.$2}=1; }
                   1438:         }
                   1439:     }
                   1440:     return keys %courses;
                   1441: }
1.37      matthew  1442: 
1.54      www      1443: ###############################################
1.60      matthew  1444: ###############################################
                   1445: 
                   1446: =pod
                   1447: 
1.63      www      1448: =item &determinedomain()
1.60      matthew  1449: 
                   1450: Inputs: $domain (usually will be undef)
                   1451: 
1.63      www      1452: Returns: Determines which domain should be used for designs
1.60      matthew  1453: 
                   1454: =cut
1.54      www      1455: 
1.60      matthew  1456: ###############################################
1.63      www      1457: sub determinedomain {
                   1458:     my $domain=shift;
                   1459:    if (! $domain) {
1.60      matthew  1460:         # Determine domain if we have not been given one
                   1461:         $domain = $Apache::lonnet::perlvar{'lonDefDomain'};
                   1462:         if ($ENV{'user.domain'}) { $domain=$ENV{'user.domain'}; }
                   1463:         if ($ENV{'request.role.domain'}) { 
                   1464:             $domain=$ENV{'request.role.domain'}; 
                   1465:         }
                   1466:     }
1.63      www      1467:     return $domain;
                   1468: }
                   1469: ###############################################
                   1470: =pod
                   1471: 
                   1472: =item &domainlogo()
                   1473: 
                   1474: Inputs: $domain (usually will be undef)
                   1475: 
                   1476: Returns: A link to a domain logo, if the domain logo exists.
                   1477: If the domain logo does not exist, a description of the domain.
                   1478: 
                   1479: =cut
                   1480: ###############################################
                   1481: sub domainlogo {
                   1482:     my $domain = &determinedomain(shift);    
                   1483:      # See if there is a logo
1.59      www      1484:     if (-e '/home/httpd/html/adm/lonDomLogos/'.$domain.'.gif') {
1.83    ! albertel 1485: 	my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'};
        !          1486: 	if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; }
        !          1487:         return '<img src="http://'.$ENV{'HTTP_HOST'}.':'.$lonhttpdPort.
        !          1488: 	    '/adm/lonDomLogos/'.$domain.'.gif" />';
1.60      matthew  1489:     } elsif(exists($Apache::lonnet::domaindescription{$domain})) {
                   1490:         return $Apache::lonnet::domaindescription{$domain};
1.59      www      1491:     } else {
1.60      matthew  1492:         return '';
1.59      www      1493:     }
                   1494: }
1.63      www      1495: ##############################################
                   1496: 
                   1497: =pod
                   1498: 
                   1499: =item &designparm()
                   1500: 
                   1501: Inputs: $which parameter; $domain (usually will be undef)
                   1502: 
                   1503: Returns: value of designparamter $which
                   1504: 
                   1505: =cut
                   1506: ##############################################
                   1507: sub designparm {
                   1508:     my ($which,$domain)=@_;
                   1509:     $domain=&determinedomain($domain);
                   1510:     if ($designhash{$domain.'.'.$which}) {
                   1511: 	return $designhash{$domain.'.'.$which};
                   1512:     } else {
                   1513:         return $designhash{'default.'.$which};
                   1514:     }
                   1515: }
1.59      www      1516: 
1.60      matthew  1517: ###############################################
                   1518: ###############################################
                   1519: 
                   1520: =pod
                   1521: 
                   1522: =item &bodytag()
                   1523: 
                   1524: Returns a uniform header for LON-CAPA web pages.
                   1525: 
                   1526: Inputs: 
                   1527: 
                   1528:  $title, A title to be displayed on the page.
                   1529:  $function, the current role (can be undef).
                   1530:  $addentries, extra parameters for the <body> tag.
                   1531:  $bodyonly, if defined, only return the <body> tag.
                   1532:  $domain, if defined, force a given domain.
                   1533: 
                   1534: Returns: A uniform header for LON-CAPA web pages.  
                   1535: If $bodyonly is nonzero, a string containing a <body> tag will be returned.
                   1536: If $bodyonly is undef or zero, an html string containing a <body> tag and 
                   1537: other decorations will be returned.
                   1538: 
                   1539: =cut
                   1540: 
                   1541: ###############################################
1.63      www      1542: 
                   1543: 
1.60      matthew  1544: ###############################################
1.54      www      1545: sub bodytag {
1.60      matthew  1546:     my ($title,$function,$addentries,$bodyonly,$domain)=@_;
1.55      www      1547:     unless ($function) {
                   1548: 	$function='student';
                   1549:         if ($ENV{'request.role'}=~/^(cc|in|ta|ep)/) {
                   1550: 	    $function='coordinator';
                   1551:         }
                   1552: 	if ($ENV{'request.role'}=~/^(su|dc|ad|li)/) {
                   1553:             $function='admin';
                   1554:         }
                   1555:         if (($ENV{'request.role'}=~/^(au|ca)/) ||
                   1556:             ($ENV{'REQUEST_URI'}=~/^(\/priv|\~)/)) {
                   1557:             $function='author';
                   1558:         }
                   1559:     }
1.63      www      1560:     my $img=&designparm($function.'.img',$domain);
                   1561:     my $pgbg=&designparm($function.'.pgbg',$domain);
                   1562:     my $tabbg=&designparm($function.'.tabbg',$domain);
                   1563:     my $font=&designparm($function.'.font',$domain);
                   1564:     my $link=&designparm($function.'.link',$domain);
                   1565:     my $alink=&designparm($function.'.alink',$domain);
                   1566:     my $vlink=&designparm($function.'.vlink',$domain);
                   1567:     my $sidebg=&designparm($function.'.sidebg',$domain);
                   1568: 
                   1569:  # role and realm
1.55      www      1570:     my ($role,$realm)
                   1571:        =&Apache::lonnet::plaintext((split(/\./,$ENV{'request.role'}))[0]);
                   1572: # realm
1.54      www      1573:     if ($ENV{'request.course.id'}) {
1.55      www      1574: 	$realm=
                   1575:          $ENV{'course.'.$ENV{'request.course.id'}.'.description'};
1.54      www      1576:     }
1.55      www      1577:     unless ($realm) { $realm='&nbsp;'; }
                   1578: # Set messages
1.60      matthew  1579:     my $messages=&domainlogo($domain);
1.55      www      1580: # Output
1.83    ! albertel 1581:     my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'};
        !          1582:     if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; }
1.60      matthew  1583:     my $bodytag = <<END;
1.54      www      1584: <body bgcolor="$pgbg" text="$font" alink="$alink" vlink="$vlink" link="$link"
                   1585: $addentries>
1.60      matthew  1586: END
                   1587:     if ($bodyonly) {
                   1588:         return $bodytag;
1.79      www      1589:     } elsif ($ENV{'browser.interface'} eq 'textual') {
1.82      www      1590:         return $bodytag.&Apache::lonmenu::menubuttons(undef,'web').
                   1591:                '<h1>LON-CAPA: '.$title.'</h1>';
1.60      matthew  1592:     } else {
                   1593:         return(<<ENDBODY);
                   1594: $bodytag
1.55      www      1595: <table width="100%" cellspacing="0" border="0" cellpadding="0">
                   1596: <tr><td bgcolor="$font">
1.83    ! albertel 1597: <img src="http://$ENV{'HTTP_HOST'}:$lonhttpdPort$img" /></td>
1.63      www      1598: <td bgcolor="$font"><font color='$sidebg'>$messages</font></td>
1.55      www      1599: </tr>
1.54      www      1600: <tr>
1.55      www      1601: <td rowspan="3" bgcolor="$tabbg">
                   1602: &nbsp;<font size="5"><b>$title</b></font>
1.54      www      1603: <td bgcolor="$tabbg"  align="right">
                   1604: <font size="2">
                   1605:     $ENV{'environment.firstname'}
                   1606:     $ENV{'environment.middlename'}
                   1607:     $ENV{'environment.lastname'}
                   1608:     $ENV{'environment.generation'}
1.55      www      1609:     </font>&nbsp;
1.54      www      1610: </td>
                   1611: </tr>
                   1612: <tr><td bgcolor="$tabbg" align="right">
1.55      www      1613: <font size="2">$role</font>&nbsp;
1.54      www      1614: </td></tr>
1.55      www      1615: <tr>
                   1616: <td bgcolor="$tabbg" align="right"><font size="2">$realm</font>&nbsp;</td></tr>
1.54      www      1617: </table><br>
                   1618: ENDBODY
1.60      matthew  1619:     }
1.54      www      1620: }
1.37      matthew  1621: ###############################################
1.1       albertel 1622: 
1.6       albertel 1623: sub get_unprocessed_cgi {
1.25      albertel 1624:   my ($query,$possible_names)= @_;
1.26      matthew  1625:   # $Apache::lonxml::debug=1;
1.16      harris41 1626:   foreach (split(/&/,$query)) {
1.6       albertel 1627:     my ($name, $value) = split(/=/,$_);
1.25      albertel 1628:     $name = &Apache::lonnet::unescape($name);
                   1629:     if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) {
                   1630:       $value =~ tr/+/ /;
                   1631:       $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
                   1632:       &Apache::lonxml::debug("Seting :$name: to :$value:");
1.30      albertel 1633:       unless (defined($ENV{'form.'.$name})) { &add_to_env('form.'.$name,$value) };
1.25      albertel 1634:     }
1.16      harris41 1635:   }
1.6       albertel 1636: }
                   1637: 
1.7       albertel 1638: sub cacheheader {
1.23      www      1639:   unless ($ENV{'request.method'} eq 'GET') { return ''; }
1.8       albertel 1640:   my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
1.7       albertel 1641:   my $output .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" />
                   1642:                 <meta HTTP-EQUIV="Cache-control" CONTENT="no-cache" />
                   1643:                 <meta HTTP-EQUIV="Pragma" CONTENT="no-cache" />';
                   1644:   return $output;
                   1645: }
                   1646: 
1.9       albertel 1647: sub no_cache {
                   1648:   my ($r) = @_;
1.23      www      1649:   unless ($ENV{'request.method'} eq 'GET') { return ''; }
1.24      albertel 1650:   #my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
1.9       albertel 1651:   $r->no_cache(1);
                   1652:   $r->header_out("Pragma" => "no-cache");
1.24      albertel 1653:   #$r->header_out("Expires" => $date);
1.9       albertel 1654: }
1.25      albertel 1655: 
                   1656: sub add_to_env {
                   1657:   my ($name,$value)=@_;
1.28      albertel 1658:   if (defined($ENV{$name})) {
1.27      albertel 1659:     if (ref($ENV{$name})) {
1.25      albertel 1660:       #already have multiple values
                   1661:       push(@{ $ENV{$name} },$value);
                   1662:     } else {
                   1663:       #first time seeing multiple values, convert hash entry to an arrayref
                   1664:       my $first=$ENV{$name};
                   1665:       undef($ENV{$name});
                   1666:       push(@{ $ENV{$name} },$first,$value);
                   1667:     }
                   1668:   } else {
                   1669:     $ENV{$name}=$value;
                   1670:   }
1.31      albertel 1671: }
                   1672: 
1.41      ng       1673: =pod
1.45      matthew  1674: 
                   1675: =back 
1.41      ng       1676: 
                   1677: =head2 CSV Upload/Handling functions
1.38      albertel 1678: 
1.41      ng       1679: =over 4
                   1680: 
                   1681: =item  upfile_store($r)
                   1682: 
                   1683: Store uploaded file, $r should be the HTTP Request object,
                   1684: needs $ENV{'form.upfile'}
                   1685: returns $datatoken to be put into hidden field
                   1686: 
                   1687: =cut
1.31      albertel 1688: 
                   1689: sub upfile_store {
                   1690:     my $r=shift;
                   1691:     $ENV{'form.upfile'}=~s/\r/\n/gs;
                   1692:     $ENV{'form.upfile'}=~s/\f/\n/gs;
                   1693:     $ENV{'form.upfile'}=~s/\n+/\n/gs;
                   1694:     $ENV{'form.upfile'}=~s/\n+$//gs;
                   1695: 
                   1696:     my $datatoken=$ENV{'user.name'}.'_'.$ENV{'user.domain'}.
                   1697: 	'_enroll_'.$ENV{'request.course.id'}.'_'.time.'_'.$$;
                   1698:     {
                   1699: 	my $fh=Apache::File->new('>'.$r->dir_config('lonDaemons').
                   1700: 				 '/tmp/'.$datatoken.'.tmp');
                   1701: 	print $fh $ENV{'form.upfile'};
                   1702:     }
                   1703:     return $datatoken;
                   1704: }
                   1705: 
1.56      matthew  1706: =pod
                   1707: 
1.41      ng       1708: =item load_tmp_file($r)
                   1709: 
                   1710: Load uploaded file from tmp, $r should be the HTTP Request object,
                   1711: needs $ENV{'form.datatoken'},
                   1712: sets $ENV{'form.upfile'} to the contents of the file
                   1713: 
                   1714: =cut
1.31      albertel 1715: 
                   1716: sub load_tmp_file {
                   1717:     my $r=shift;
                   1718:     my @studentdata=();
                   1719:     {
                   1720: 	my $fh;
                   1721: 	if ($fh=Apache::File->new($r->dir_config('lonDaemons').
                   1722: 				  '/tmp/'.$ENV{'form.datatoken'}.'.tmp')) {
                   1723: 	    @studentdata=<$fh>;
                   1724: 	}
                   1725:     }
                   1726:     $ENV{'form.upfile'}=join('',@studentdata);
                   1727: }
                   1728: 
1.56      matthew  1729: =pod
                   1730: 
1.41      ng       1731: =item upfile_record_sep()
                   1732: 
                   1733: Separate uploaded file into records
                   1734: returns array of records,
                   1735: needs $ENV{'form.upfile'} and $ENV{'form.upfiletype'}
                   1736: 
                   1737: =cut
1.31      albertel 1738: 
                   1739: sub upfile_record_sep {
                   1740:     if ($ENV{'form.upfiletype'} eq 'xml') {
                   1741:     } else {
                   1742: 	return split(/\n/,$ENV{'form.upfile'});
                   1743:     }
                   1744: }
                   1745: 
1.56      matthew  1746: =pod
                   1747: 
1.41      ng       1748: =item record_sep($record)
                   1749: 
                   1750: Separate a record into fields $record should be an item from the upfile_record_sep(), needs $ENV{'form.upfiletype'}
                   1751: 
                   1752: =cut
                   1753: 
1.31      albertel 1754: sub record_sep {
                   1755:     my $record=shift;
                   1756:     my %components=();
                   1757:     if ($ENV{'form.upfiletype'} eq 'xml') {
                   1758:     } elsif ($ENV{'form.upfiletype'} eq 'space') {
                   1759:         my $i=0;
                   1760:         foreach (split(/\s+/,$record)) {
                   1761:             my $field=$_;
                   1762:             $field=~s/^(\"|\')//;
                   1763:             $field=~s/(\"|\')$//;
                   1764:             $components{$i}=$field;
                   1765:             $i++;
                   1766:         }
                   1767:     } elsif ($ENV{'form.upfiletype'} eq 'tab') {
                   1768:         my $i=0;
                   1769:         foreach (split(/\t+/,$record)) {
                   1770:             my $field=$_;
                   1771:             $field=~s/^(\"|\')//;
                   1772:             $field=~s/(\"|\')$//;
                   1773:             $components{$i}=$field;
                   1774:             $i++;
                   1775:         }
                   1776:     } else {
                   1777:         my @allfields=split(/\,/,$record);
                   1778:         my $i=0;
                   1779:         my $j;
                   1780:         for ($j=0;$j<=$#allfields;$j++) {
                   1781:             my $field=$allfields[$j];
                   1782:             if ($field=~/^\s*(\"|\')/) {
                   1783: 		my $delimiter=$1;
                   1784:                 while (($field!~/$delimiter$/) && ($j<$#allfields)) {
                   1785: 		    $j++;
                   1786: 		    $field.=','.$allfields[$j];
                   1787: 		}
                   1788:                 $field=~s/^\s*$delimiter//;
                   1789:                 $field=~s/$delimiter\s*$//;
                   1790:             }
                   1791:             $components{$i}=$field;
                   1792: 	    $i++;
                   1793:         }
                   1794:     }
                   1795:     return %components;
                   1796: }
                   1797: 
1.56      matthew  1798: =pod
                   1799: 
1.41      ng       1800: =item upfile_select_html()
                   1801: 
                   1802: return HTML code to select file and specify its type
                   1803: 
                   1804: =cut
                   1805: 
1.31      albertel 1806: sub upfile_select_html {
                   1807:     return (<<'ENDUPFORM');
1.57      albertel 1808: <input type="file" name="upfile" size="50" />
1.31      albertel 1809: <br />Type: <select name="upfiletype">
                   1810: <option value="csv">CSV (comma separated values, spreadsheet)</option>
                   1811: <option value="space">Space separated</option>
                   1812: <option value="tab">Tabulator separated</option>
                   1813: <option value="xml">HTML/XML</option>
                   1814: </select>
                   1815: ENDUPFORM
                   1816: }
                   1817: 
1.56      matthew  1818: =pod
                   1819: 
1.41      ng       1820: =item csv_print_samples($r,$records)
                   1821: 
                   1822: Prints a table of sample values from each column uploaded $r is an
                   1823: Apache Request ref, $records is an arrayref from
                   1824: &Apache::loncommon::upfile_record_sep
                   1825: 
                   1826: =cut
                   1827: 
1.31      albertel 1828: sub csv_print_samples {
                   1829:     my ($r,$records) = @_;
                   1830:     my (%sone,%stwo,%sthree);
                   1831:     %sone=&record_sep($$records[0]);
                   1832:     if (defined($$records[1])) {%stwo=&record_sep($$records[1]);}
                   1833:     if (defined($$records[2])) {%sthree=&record_sep($$records[2]);}
                   1834: 
                   1835:     $r->print('Samples<br /><table border="2"><tr>');
                   1836:     foreach (sort({$a <=> $b} keys(%sone))) { $r->print('<th>Column&nbsp;'.($_+1).'</th>'); }
                   1837:     $r->print('</tr>');
                   1838:     foreach my $hash (\%sone,\%stwo,\%sthree) {
                   1839: 	$r->print('<tr>');
                   1840: 	foreach (sort({$a <=> $b} keys(%sone))) {
                   1841: 	    $r->print('<td>');
                   1842: 	    if (defined($$hash{$_})) { $r->print($$hash{$_}); }
                   1843: 	    $r->print('</td>');
                   1844: 	}
                   1845: 	$r->print('</tr>');
                   1846:     }
                   1847:     $r->print('</tr></table><br />'."\n");
                   1848: }
                   1849: 
1.56      matthew  1850: =pod
                   1851: 
1.41      ng       1852: =item csv_print_select_table($r,$records,$d)
                   1853: 
                   1854: Prints a table to create associations between values and table columns.
                   1855: $r is an Apache Request ref,
                   1856: $records is an arrayref from &Apache::loncommon::upfile_record_sep,
                   1857: $d is an array of 2 element arrays (internal name, displayed name)
                   1858: 
                   1859: =cut
                   1860: 
1.31      albertel 1861: sub csv_print_select_table {
                   1862:     my ($r,$records,$d) = @_;
                   1863:     my $i=0;my %sone;
                   1864:     %sone=&record_sep($$records[0]);
                   1865:     $r->print('Associate columns with student attributes.'."\n".
                   1866: 	     '<table border="2"><tr><th>Attribute</th><th>Column</th></tr>'."\n");
                   1867:     foreach (@$d) {
                   1868: 	my ($value,$display)=@{ $_ };
                   1869: 	$r->print('<tr><td>'.$display.'</td>');
                   1870: 
                   1871: 	$r->print('<td><select name=f'.$i.
1.32      matthew  1872: 		  ' onchange="javascript:flip(this.form,'.$i.');">');
1.31      albertel 1873: 	$r->print('<option value="none"></option>');
                   1874: 	foreach (sort({$a <=> $b} keys(%sone))) {
                   1875: 	    $r->print('<option value="'.$_.'">Column '.($_+1).'</option>');
                   1876: 	}
                   1877: 	$r->print('</select></td></tr>'."\n");
                   1878: 	$i++;
                   1879:     }
                   1880:     $i--;
                   1881:     return $i;
                   1882: }
1.56      matthew  1883: 
                   1884: =pod
1.31      albertel 1885: 
1.41      ng       1886: =item csv_samples_select_table($r,$records,$d)
                   1887: 
                   1888: Prints a table of sample values from the upload and can make associate samples to internal names.
                   1889: 
                   1890: $r is an Apache Request ref,
                   1891: $records is an arrayref from &Apache::loncommon::upfile_record_sep,
                   1892: $d is an array of 2 element arrays (internal name, displayed name)
                   1893: 
                   1894: =cut
                   1895: 
1.31      albertel 1896: sub csv_samples_select_table {
                   1897:     my ($r,$records,$d) = @_;
                   1898:     my %sone; my %stwo; my %sthree;
                   1899:     my $i=0;
                   1900: 
                   1901:     $r->print('<table border=2><tr><th>Field</th><th>Samples</th></tr>');
                   1902:     %sone=&record_sep($$records[0]);
                   1903:     if (defined($$records[1])) {%stwo=&record_sep($$records[1]);}
                   1904:     if (defined($$records[2])) {%sthree=&record_sep($$records[2]);}
                   1905: 
                   1906:     foreach (sort keys %sone) {
                   1907: 	$r->print('<tr><td><select name=f'.$i.
1.32      matthew  1908: 		  ' onchange="javascript:flip(this.form,'.$i.');">');
1.31      albertel 1909: 	foreach (@$d) {
                   1910: 	    my ($value,$display)=@{ $_ };
                   1911: 	    $r->print('<option value='.$value.'>'.$display.'</option>');
                   1912: 	}
                   1913: 	$r->print('</select></td><td>');
                   1914: 	if (defined($sone{$_})) { $r->print($sone{$_}."</br>\n"); }
                   1915: 	if (defined($stwo{$_})) { $r->print($stwo{$_}."</br>\n"); }
                   1916: 	if (defined($sthree{$_})) { $r->print($sthree{$_}."</br>\n"); }
                   1917: 	$r->print('</td></tr>');
                   1918: 	$i++;
                   1919:     }
                   1920:     $i--;
                   1921:     return($i);
1.25      albertel 1922: }
1.1       albertel 1923: 1;
                   1924: __END__;
1.17      harris41 1925: 
1.41      ng       1926: =pod
                   1927: 
                   1928: =back
                   1929: 
                   1930: =head2 Access .tab File Data
                   1931: 
                   1932: =over 4
                   1933: 
1.35      matthew  1934: =item languageids() 
1.17      harris41 1935: 
1.35      matthew  1936: returns list of all language ids
1.17      harris41 1937: 
1.35      matthew  1938: =item languagedescription() 
1.17      harris41 1939: 
1.35      matthew  1940: returns description of a specified language id
1.17      harris41 1941: 
1.35      matthew  1942: =item copyrightids() 
1.17      harris41 1943: 
1.35      matthew  1944: returns list of all copyrights
1.17      harris41 1945: 
1.35      matthew  1946: =item copyrightdescription() 
1.17      harris41 1947: 
1.35      matthew  1948: returns description of a specified copyright id
1.17      harris41 1949: 
1.35      matthew  1950: =item filecategories() 
1.17      harris41 1951: 
1.35      matthew  1952: returns list of all file categories
1.17      harris41 1953: 
1.35      matthew  1954: =item filecategorytypes() 
1.17      harris41 1955: 
1.35      matthew  1956: returns list of file types belonging to a given file
1.17      harris41 1957: category
                   1958: 
1.35      matthew  1959: =item fileembstyle() 
1.17      harris41 1960: 
1.35      matthew  1961: returns embedding style for a specified file type
1.17      harris41 1962: 
1.35      matthew  1963: =item filedescription() 
1.17      harris41 1964: 
1.35      matthew  1965: returns description for a specified file type
1.17      harris41 1966: 
1.35      matthew  1967: =item filedescriptionex() 
1.17      harris41 1968: 
1.35      matthew  1969: returns description for a specified file type with
1.17      harris41 1970: extra formatting
                   1971: 
1.41      ng       1972: =back
                   1973: 
                   1974: =head2 Alternate Problem Views
                   1975: 
                   1976: =over 4
                   1977: 
1.35      matthew  1978: =item get_previous_attempt() 
1.17      harris41 1979: 
1.35      matthew  1980: return string with previous attempt on problem
1.17      harris41 1981: 
1.35      matthew  1982: =item get_student_view() 
1.17      harris41 1983: 
1.35      matthew  1984: show a snapshot of what student was looking at
1.17      harris41 1985: 
1.35      matthew  1986: =item get_student_answers() 
1.17      harris41 1987: 
1.35      matthew  1988: show a snapshot of how student was answering problem
1.17      harris41 1989: 
1.41      ng       1990: =back
                   1991: 
                   1992: =head2 HTTP Helper
                   1993: 
                   1994: =over 4
                   1995: 
                   1996: =item get_unprocessed_cgi($query,$possible_names)
                   1997: 
                   1998: Modify the %ENV hash to contain unprocessed CGI form parameters held in
                   1999: $query.  The parameters listed in $possible_names (an array reference),
                   2000: will be set in $ENV{'form.name'} if they do not already exist.
1.17      harris41 2001: 
1.41      ng       2002: Typically called with $ENV{'QUERY_STRING'} as the first parameter.  
                   2003: $possible_names is an ref to an array of form element names.  As an example:
                   2004: get_unprocessed_cgi($ENV{'QUERY_STRING'},['uname','udom']);
                   2005: will result in $ENV{'form.uname'} and $ENV{'form.udom'} being set.
1.17      harris41 2006: 
1.35      matthew  2007: =item cacheheader() 
1.17      harris41 2008: 
1.35      matthew  2009: returns cache-controlling header code
1.17      harris41 2010: 
1.65      matthew  2011: =item no_cache($r) 
1.17      harris41 2012: 
1.35      matthew  2013: specifies header code to not have cache
1.25      albertel 2014: 
1.35      matthew  2015: =item add_to_env($name,$value) 
1.25      albertel 2016: 
1.35      matthew  2017: adds $name to the %ENV hash with value
1.25      albertel 2018: $value, if $name already exists, the entry is converted to an array
                   2019: reference and $value is added to the array.
1.17      harris41 2020: 
                   2021: =back
                   2022: 
                   2023: =cut

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