--- loncom/interface/loncommon.pm 2002/01/30 17:40:39 1.24 +++ loncom/interface/loncommon.pm 2004/11/13 21:06:27 1.231 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # a pile of common routines # -# $Id: loncommon.pm,v 1.24 2002/01/30 17:40:39 albertel Exp $ +# $Id: loncommon.pm,v 1.231 2004/11/13 21:06:27 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -25,241 +25,2148 @@ # # http://www.lon-capa.org/ # -# YEAR=2001 -# 2/13-12/7 Guy Albertelli -# 12/11,12/12,12/17 Scott Harrison -# 12/21 Gerd Kortemeyer -# 12/21 Scott Harrison -# 12/25,12/28 Gerd Kortemeyer -# YEAR=2002 -# 1/4 Gerd Kortemeyer # Makes a table out of the previous attempts # Inputs result_from_symbread, user, domain, course_id # Reads in non-network-related .tab files +# POD header: + +=pod + +=head1 NAME + +Apache::loncommon - pile of common routines + +=head1 SYNOPSIS + +Common routines for manipulating connections, student answers, + domains, common Javascript fragments, etc. + +=head1 OVERVIEW + +A collection of commonly used subroutines that don't have a natural +home anywhere else. This collection helps remove +redundancy from other modules and increase efficiency of memory usage. + +=cut + +# End of POD header package Apache::loncommon; use strict; use Apache::lonnet(); -use POSIX qw(strftime); -use Apache::Constants qw(:common); -use Apache::lonmsg(); +use GDBM_File; +use POSIX qw(strftime mktime); +use Apache::Constants qw(:common :http :methods); +use Apache::lonmenu(); +use Apache::lonlocal; +use HTML::Entities; my $readit; +## +## Global Variables +## + # ----------------------------------------------- Filetypes/Languages/Copyright my %language; +my %supported_language; my %cprtag; +my %scprtag; my %fe; my %fd; -my %fc; +my %category_extensions; -# -------------------------------------------------------------- Thesaurus data -my @therelated; -my @theword; -my @thecount; -my %theindex; -my $thetotalcount; -my $thefuzzy=2; -my $thethreshold=0.1/$thefuzzy; -my $theavecount; +# ---------------------------------------------- Designs -# ----------------------------------------------------------------------- BEGIN -BEGIN { +my %designhash; + +# ---------------------------------------------- Thesaurus variables +# +# %Keywords: +# A hash used by &keyword to determine if a word is considered a keyword. +# $thesaurus_db_file +# Scalar containing the full path to the thesaurus database. + +my %Keywords; +my $thesaurus_db_file; +# +# Initialize values from language.tab, copyright.tab, filetypes.tab, +# thesaurus.tab, and filecategories.tab. +# +BEGIN { + # Variable initialization + $thesaurus_db_file = $Apache::lonnet::perlvar{'lonTabDir'}."/thesaurus.db"; + # unless ($readit) { # ------------------------------------------------------------------- languages { - my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}. - '/language.tab'); - if ($fh) { - while (<$fh>) { - next if /^\#/; - chomp; - my ($key,$val)=(split(/\s+/,$_,2)); - $language{$key}=$val; - } - } + my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}. + '/language.tab'; + if ( open(my $fh,"<$langtabfile") ) { + while (<$fh>) { + next if /^\#/; + chomp; + my ($key,$two,$country,$three,$enc,$val,$sup)=(split(/\t/,$_)); + $language{$key}=$val.' - '.$enc; + if ($sup) { + $supported_language{$key}=$sup; + } + } + close($fh); + } } # ------------------------------------------------------------------ copyrights { - my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonIncludes'}. - '/copyright.tab'); - if ($fh) { - while (<$fh>) { - next if /^\#/; - chomp; - my ($key,$val)=(split(/\s+/,$_,2)); - $cprtag{$key}=$val; - } - } + my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. + '/copyright.tab'; + if ( open (my $fh,"<$copyrightfile") ) { + while (<$fh>) { + next if /^\#/; + chomp; + my ($key,$val)=(split(/\s+/,$_,2)); + $cprtag{$key}=$val; + } + close($fh); + } } -# ------------------------------------------------------------- file categories +# ------------------------------------------------------------------ source copyrights { - my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}. - '/filecategories.tab'); - if ($fh) { - while (<$fh>) { - next if /^\#/; - chomp; - my ($key,$val)=(split(/\s+/,$_,2)); - push @{$fc{$key}},$val; - } - } + my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. + '/source_copyright.tab'; + if ( open (my $fh,"<$sourcecopyrightfile") ) { + while (<$fh>) { + next if /^\#/; + chomp; + my ($key,$val)=(split(/\s+/,$_,2)); + $scprtag{$key}=$val; + } + close($fh); + } } -# ------------------------------------------------------------------ file types + +# -------------------------------------------------------------- domain designs + + my $filename; + my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors'; + opendir(DIR,$designdir); + while ($filename=readdir(DIR)) { + my ($domain)=($filename=~/^(\w+)\./); { - my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}. - '/filetypes.tab'); - if ($fh) { + my $designfile = $designdir.'/'.$filename; + if ( open (my $fh,"<$designfile") ) { while (<$fh>) { - next if (/^\#/); - chomp; - my ($ending,$emb,$descr)=split(/\s+/,$_,3); - if ($descr ne '') { - $fe{$ending}=lc($emb); - $fd{$ending}=$descr; - } - } - } + next if /^\#/; + chomp; + my ($key,$val)=(split(/\=/,$_)); + if ($val) { $designhash{$domain.'.'.$key}=$val; } + } + close($fh); + } + } + } -# -------------------------------------------------------------- Thesaurus data + closedir(DIR); + + +# ------------------------------------------------------------- file categories { - my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}. - '/thesaurus.dat'); - if ($fh) { + my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}. + '/filecategories.tab'; + if ( open (my $fh,"<$categoryfile") ) { while (<$fh>) { - my ($tword,$tindex,$tcount,$trelated)=split(/\@/,$_); - $theindex{$tword}=$tindex; - $theword[$tindex]=$tword; - $thecount[$tindex]=$tcount; - $thetotalcount+=$tcount; - $therelated[$tindex]=$trelated; - } + next if /^\#/; + chomp; + my ($extension,$category)=(split(/\s+/,$_,2)); + push @{$category_extensions{lc($category)}},$extension; + } + close($fh); + } + + } +# ------------------------------------------------------------------ file types + { + my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}. + '/filetypes.tab'; + if ( open (my $fh,"<$typesfile") ) { + while (<$fh>) { + next if (/^\#/); + chomp; + my ($ending,$emb,$descr)=split(/\s+/,$_,3); + if ($descr ne '') { + $fe{$ending}=lc($emb); + $fd{$ending}=$descr; + } + } + close($fh); } - $theavecount=$thetotalcount/$#thecount; } &Apache::lonnet::logthis( - "INFO: Read file types and thesaurus"); + "INFO: Read file types"); $readit=1; + } # end of unless($readit) + } +############################################################### +## HTML and Javascript Helper Functions ## +############################################################### + +=pod + +=head1 HTML and Javascript Functions + +=over 4 + +=item * browser_and_searcher_javascript () + +XXReturns a string +containing javascript with two functions, C and +C. Returned string does not contain EscriptE +tags. + +=item * openbrowser(formname,elementname,only,omit) [javascript] + +inputs: formname, elementname, only, omit + +formname and elementname indicate the name of the html form and name of +the element that the results of the browsing selection are to be placed in. + +Specifying 'only' will restrict the browser to displaying only files +with the given extension. Can be a comma separated list. + +Specifying 'omit' will restrict the browser to NOT displaying files +with the given extension. Can be a comma separated list. + +=item * opensearcher(formname, elementname) [javascript] + +Inputs: formname, elementname + +formname and elementname specify the name of the html form and the name +of the element the selection from the search results will be placed in. + +=cut + +sub browser_and_searcher_javascript { + my ($mode)=@_; + if (!defined($mode)) { $mode='edit'; } + my $resurl=&lastresurl(); + return < +END +} + +sub lastresurl { + if ($ENV{'environment.lastresurl'}) { + return $ENV{'environment.lastresurl'} + } else { + return '/res'; + } } -# ============================================================= END BEGIN BLOCK +sub storeresurl { + my $resurl=&Apache::lonnet::clutter(shift); + unless ($resurl=~/^\/res/) { return 0; } + $resurl=~s/\/$//; + &Apache::lonnet::put('environment',{'lastresurl' => $resurl}); + &Apache::lonnet::appenv('environment.lastresurl' => $resurl); + return 1; +} -# ---------------------------------------------------------- Is this a keyword? +sub studentbrowser_javascript { + unless ( + (($ENV{'request.course.id'}) && + (&Apache::lonnet::allowed('srm',$ENV{'request.course.id'}))) + || ($ENV{'request.role'}=~/^(au|dc|su)/) + ) { return ''; } + return (<<'ENDSTDBRW'); + +ENDSTDBRW +} -sub keyword { - my $newword=shift; - $newword=~s/\W//g; - $newword=~tr/A-Z/a-z/; - my $tindex=$theindex{$newword}; - if ($tindex) { - if ($thecount[$tindex]>$theavecount) { - return 1; - } - } - return 0; -} -# -------------------------------------------------------- Return related words - -sub related { - my $newword=shift; - $newword=~s/\W//g; - $newword=~tr/A-Z/a-z/; - my $tindex=$theindex{$newword}; - if ($tindex) { - my %found=(); - foreach (split(/\,/,$therelated[$tindex])) { -# - Related word found - my ($ridx,$rcount)=split(/\:/,$_); -# - Direct relation index - my $directrel=$rcount/$thecount[$tindex]; - if ($directrel>$thethreshold) { - foreach (split(/\,/,$therelated[$ridx])) { - my ($rridx,$rrcount)=split(/\:/,$_); - if ($rridx==$tindex) { -# - Determine reverse relation index - my $revrel=$rrcount/$thecount[$ridx]; -# - Calculate full index - $found{$ridx}=$directrel*$revrel; - if ($found{$ridx}>$thethreshold) { - foreach (split(/\,/,$therelated[$ridx])) { - my ($rrridx,$rrrcount)=split(/\:/,$_); - unless ($found{$rrridx}) { - my $revrevrel=$rrrcount/$thecount[$ridx]; - if ( - $directrel*$revrel*$revrevrel>$thethreshold - ) { - $found{$rrridx}= - $directrel*$revrel*$revrevrel; - } - } - } - } - } - } +sub selectstudent_link { + my ($form,$unameele,$udomele)=@_; + if ($ENV{'request.course.id'}) { + unless (&Apache::lonnet::allowed('srm',$ENV{'request.course.id'})) { + return ''; + } + return "".&mt('Select User').""; + } + if ($ENV{'request.role'}=~/^(au|dc|su)/) { + return "".&mt('Select User').""; + } + return ''; +} + +sub coursebrowser_javascript { + my ($domainfilter,$roleelement)=@_; + return (< + var extra_element = "$roleelement" + var stdeditbrowser; + function opencrsbrowser(formname,uname,udom,desc) { + var url = '/adm/pickcourse?'; + var filter; + if (filter != null) { + if (filter != '') { + url += 'filter='+filter+'&'; + } + } + var domainfilter='$domainfilter'; + if (domainfilter != null) { + if (domainfilter != '') { + url += 'domainfilter='+domainfilter+'&'; + } + } + url += 'form=' + formname + '&cnumelement='+uname+ + '&cdomelement='+udom+ + '&cnameelement='+desc; + if (extra_element != '') { + url += '&roleelement=$roleelement'; + } + var title = 'Course_Browser'; + var options = 'scrollbars=1,resizable=1,menubar=0'; + options += ',width=700,height=600'; + stdeditbrowser = open(url,title,options,'1'); + stdeditbrowser.focus(); + } + +ENDSTDBRW +} + +sub selectcourse_link { + my ($form,$unameele,$udomele,$desc)=@_; + return "".&mt('Select Course').""; +} + +=pod + +=item * linked_select_forms(...) + +linked_select_forms returns a string containing a block +and html for two menus. The select menus will be linked in that +changing the value of the first menu will result in new values being placed +in the second menu. The values in the select menu will appear in alphabetical +order. + +linked_select_forms takes the following ordered inputs: + +=over 4 + +=item * $formname, the name of the tag + +=item * $middletext, the text which appears between the tags + +=item * $firstdefault, the default value for the first menu + +=item * $firstselectname, the name of the first tag + +=item * $secondselectname, the name of the second tag + +=item * $hashref, a reference to a hash containing the data for the menus. + +=back + +Below is an example of such a hash. Only the 'text', 'default', and +'select2' keys must appear as stated. keys(%menu) are the possible +values for the first select menu. The text that coincides with the +first menu value is given in $menu{$choice1}->{'text'}. The values +and text for the second menu are given in the hash pointed to by +$menu{$choice1}->{'select2'}. + + my %menu = ( A1 => { text =>"Choice A1" , + default => "B3", + select2 => { + B1 => "Choice B1", + B2 => "Choice B2", + B3 => "Choice B3", + B4 => "Choice B4" + } + }, + A2 => { text =>"Choice A2" , + default => "C2", + select2 => { + C1 => "Choice C1", + C2 => "Choice C2", + C3 => "Choice C3" + } + }, + A3 => { text =>"Choice A3" , + default => "D6", + select2 => { + D1 => "Choice D1", + D2 => "Choice D2", + D3 => "Choice D3", + D4 => "Choice D4", + D5 => "Choice D5", + D6 => "Choice D6", + D7 => "Choice D7" + } + } + ); + +=cut + +sub linked_select_forms { + my ($formname, + $middletext, + $firstdefault, + $firstselectname, + $secondselectname, + $hashref + ) = @_; + my $second = "document.$formname.$secondselectname"; + my $first = "document.$formname.$firstselectname"; + # output the javascript to do the changing + my $result = ''; + $result.=" +END + # output the initial values for the selection lists + $result .= "\n"; + foreach my $value (sort(keys(%$hashref))) { + $result.=" ".&mt($hashref->{$value}->{'text'})."\n"; + } + $result .= "\n"; + my %select2 = %{$hashref->{$firstdefault}->{'select2'}}; + $result .= $middletext; + $result .= "\n"; + my $seconddefault = $hashref->{$firstdefault}->{'default'}; + foreach my $value (sort(keys(%select2))) { + $result.=" ".&mt($select2{$value})."\n"; + } + $result .= "\n"; + # return $debug; + return $result; +} # end of sub linked_select_forms { + +=pod + +=item * help_open_topic($topic, $text, $stayOnPage, $width, $height) + +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. + +$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. + +$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.) + +$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. + +=cut + +sub help_open_topic { + my ($topic, $text, $stayOnPage, $width, $height) = @_; + $text = "" if (not defined $text); + $stayOnPage = 0 if (not defined $stayOnPage); + if ($ENV{'browser.interface'} eq 'textual' || + $ENV{'environment.remote'} eq 'off' ) { + $stayOnPage=1; + } + $width = 350 if (not defined $width); + $height = 400 if (not defined $height); + my $filename = $topic; + $filename =~ s/ /_/g; + + my $template = ""; + my $link; + + $topic=~s/\W/\_/g; + + if (!$stayOnPage) + { + $link = "javascript:void(open('/adm/help/${filename}.hlp', 'Help_for_$topic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))"; + } + else + { + $link = "/adm/help/${filename}.hlp"; + } + + # Add the text + if ($text ne "") + { + $template .= + "". + "$text"; + } + + # Add the graphic + my $title = &mt('Online Help'); + my $helpicon=&lonhttpdurl("/adm/help/gif/smallHelp.gif"); + $template .= <<"ENDTEMPLATE"; + +ENDTEMPLATE + if ($text ne '') { $template.='' }; + return $template; + +} + +# This is a quicky function for Latex cheatsheet editing, since it +# appears in at least four places +sub helpLatexCheatsheet { + my $other = shift; + my $addOther = ''; + if ($other) { + $addOther = Apache::loncommon::help_open_topic($other, shift, + undef, undef, 600) . + ''; + } + return ''. + $addOther . + &Apache::loncommon::help_open_topic("Greek_Symbols",'Greek Symbols', + undef,undef,600) + .''. + &Apache::loncommon::help_open_topic("Other_Symbols",'Other Symbols', + undef,undef,600) + .''; +} + +sub help_open_menu { + my ($color,$topic,$component_help,$function,$faq,$bug,$stayOnPage,$width,$height,$text) = @_; + $text = "" if (not defined $text); + $stayOnPage = 0 if (not defined $stayOnPage); + if ($ENV{'browser.interface'} eq 'textual' || + $ENV{'environment.remote'} eq 'off' ) { + $stayOnPage=1; + } + $width = 620 if (not defined $width); + $height = 600 if (not defined $height); + my $link=''; + my $title = &mt('Get help'); + my $origurl = $ENV{'REQUEST_URI'}; + $origurl=~s|^/~|/priv/|; + my $timestamp = time; + foreach (\$color,\$function,\$topic,\$component_help,\$faq,\$bug,\$origurl) { + $$_ = &Apache::lonnet::escape($$_); + } + + if (!$stayOnPage) { + $link = "javascript:helpMenu('open')"; + } else { + $link = "javascript:helpMenu('display')"; + } + my $banner_link = "/adm/helpmenu?page=banner&color=$color&function=$function&topic=$topic&component_help=$component_help&faq=$faq&bug=$bug&origurl=$origurl&stamp=$timestamp&stayonpage=$stayOnPage"; + my $details_link = "/adm/helpmenu?page=body&color=$color&function=$function&topic=$topic&component_help=$component_help&faq=$faq&bug=$bug&origurl=$origurl&stamp=$timestamp"; + my $template; + if ($text ne "") { + $template .= + "". + "$text"; + } + my $helpicon=&lonhttpdurl("/adm/lonIcons/helpgateway.gif"); + $template .= <<"ENDTEMPLATE"; + + +ENDTEMPLATE + if ($component_help) { + if (!$text) { + $template=&help_open_topic($component_help,undef,$stayOnPage, + $width,$height).' '.$template; + } else { + my $help_text; + $help_text=&Apache::lonnet::unescape($topic); + $template=''. + &help_open_topic($component_help,$help_text,$stayOnPage, + $width,$height).''.$template. + ''; + } + } + if ($text ne '') { $template.='' }; + return $template; +} + +sub help_open_bug { + my ($topic, $text, $stayOnPage, $width, $height) = @_; + unless ($ENV{'user.adv'}) { return ''; } + unless ($Apache::lonnet::perlvar{'BugzillaHost'}) { return ''; } + $text = "" if (not defined $text); + $stayOnPage = 0 if (not defined $stayOnPage); + if ($ENV{'browser.interface'} eq 'textual' || + $ENV{'environment.remote'} eq 'off' ) { + $stayOnPage=1; + } + $width = 600 if (not defined $width); + $height = 600 if (not defined $height); + + $topic=~s/\W+/\+/g; + my $link=''; + my $template=''; + my $url=$Apache::lonnet::perlvar{'BugzillaHost'}.'enter_bug.cgi?product=LON-CAPA&bug_file_loc='. + &Apache::lonnet::escape($ENV{'REQUEST_URI'}).'&component='.$topic; + if (!$stayOnPage) + { + $link = "javascript:void(open('$url', 'Bugzilla', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))"; + } + else + { + $link = $url; + } + # Add the text + if ($text ne "") + { + $template .= + "". + "$text"; + } + + # Add the graphic + my $title = &mt('Report a Bug'); + my $bugicon=&lonhttpdurl("/adm/lonMisc/smallBug.gif"); + $template .= <<"ENDTEMPLATE"; + +ENDTEMPLATE + if ($text ne '') { $template.='' }; + return $template; + +} + +sub help_open_faq { + my ($topic, $text, $stayOnPage, $width, $height) = @_; + unless ($ENV{'user.adv'}) { return ''; } + unless ($Apache::lonnet::perlvar{'FAQHost'}) { return ''; } + $text = "" if (not defined $text); + $stayOnPage = 0 if (not defined $stayOnPage); + if ($ENV{'browser.interface'} eq 'textual' || + $ENV{'environment.remote'} eq 'off' ) { + $stayOnPage=1; + } + $width = 350 if (not defined $width); + $height = 400 if (not defined $height); + + $topic=~s/\W+/\+/g; + my $link=''; + my $template=''; + my $url=$Apache::lonnet::perlvar{'FAQHost'}.'/fom/cache/'.$topic.'.html'; + if (!$stayOnPage) + { + $link = "javascript:void(open('$url', 'FAQ-O-Matic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))"; + } + else + { + $link = $url; + } + + # Add the text + if ($text ne "") + { + $template .= + "". + "$text"; + } + + # Add the graphic + my $title = &mt('View the FAQ'); + my $faqicon=&lonhttpdurl("/adm/lonMisc/smallFAQ.gif"); + $template .= <<"ENDTEMPLATE"; + +ENDTEMPLATE + if ($text ne '') { $template.='' }; + return $template; + +} + +############################################################### +############################################################### + +=pod + +=item * csv_translate($text) + +Translate $text to allow it to be output as a 'comma separated values' +format. + +=cut + +############################################################### +############################################################### +sub csv_translate { + my $text = shift; + $text =~ s/\"/\"\"/g; + $text =~ s/\n/ /g; + return $text; +} + + +############################################################### +############################################################### + +=pod + +=item * define_excel_formats + +Define some commonly used Excel cell formats. + +Currently supported formats: + +=over 4 + +=item header + +=item bold + +=item h1 + +=item h2 + +=item h3 + +=item date + +=back + +Inputs: $workbook + +Returns: $format, a hash reference. + +=cut + +############################################################### +############################################################### +sub define_excel_formats { + my ($workbook) = @_; + my $format; + $format->{'header'} = $workbook->add_format(bold => 1, + bottom => 1, + align => 'center'); + $format->{'bold'} = $workbook->add_format(bold=>1); + $format->{'h1'} = $workbook->add_format(bold=>1, size=>18); + $format->{'h2'} = $workbook->add_format(bold=>1, size=>16); + $format->{'h3'} = $workbook->add_format(bold=>1, size=>14); + $format->{'date'} = $workbook->add_format(num_format=> + 'mm/dd/yyyy hh:mm:ss'); + return $format; +} + +############################################################### +############################################################### + +=pod + +=item * change_content_javascript(): + +This and the next function allow you to create small sections of an +otherwise static HTML page that you can update on the fly with +Javascript, even in Netscape 4. + +The Javascript fragment returned by this function (no EscriptE tag) +must be written to the HTML page once. It will prove the Javascript +function "change(name, content)". Calling the change function with the +name of the section +you want to update, matching the name passed to C, and +the new content you want to put in there, will put the content into +that area. + +B: Netscape 4 only reserves enough space for the changable area +to contain room for the original contents. You need to "make space" +for whatever changes you wish to make, and be B to check your +code in Netscape 4. This feature in Netscape 4 is B powerful; +it's adequate for updating a one-line status display, but little more. +This script will set the space to 100% width, so you only need to +worry about height in Netscape 4. + +Modern browsers are much less limiting, and if you can commit to the +user not using Netscape 4, this feature may be used freely with +pretty much any HTML. + +=cut + +sub change_content_javascript { + # If we're on Netscape 4, we need to use Layer-based code + if ($ENV{'browser.type'} eq 'netscape' && + $ENV{'browser.version'} =~ /^4\./) { + return (<. $name is +the name you will use to reference the area later; do not repeat the +same name on a given HTML page more then once. $origContent is what +the area will originally contain, which can be left blank. + +=cut + +sub changable_area { + my ($name, $origContent) = @_; + + if ($ENV{'browser.type'} eq 'netscape' && + $ENV{'browser.version'} =~ /^4\./) { + # If this is netscape 4, we need to use the Layer tag + return "$origContent"; + } else { + return "$origContent"; + } +} + +=pod + +=back + +=cut + +############################################################### +## Home server list generating code ## +############################################################### + +=pod + +=head1 Home Server option list generating code + +=over 4 + +=item * get_domains() + +Returns an array containing each of the domains listed in the hosts.tab +file. + +=cut + +#------------------------------------------- +sub get_domains { + # The code below was stolen from "The Perl Cookbook", p 102, 1st ed. + my @domains; + my %seen; + foreach (sort values(%Apache::lonnet::hostdom)) { + push (@domains,$_) unless $seen{$_}++; + } + return @domains; +} + +# ------------------------------------------ + +sub domain_select { + my ($name,$value,$multiple)=@_; + my %domains=map { + $_ => $_.' '.$Apache::lonnet::domaindescription{$_} + } &get_domains; + if ($multiple) { + $domains{''}=&mt('Any domain'); + return &multiple_select_form($name,$value,4,%domains); + } else { + return &select_form($name,$value,%domains); + } +} + +sub multiple_select_form { + my ($name,$value,$size,%hash)=@_; + my %selected = map { $_ => 1 } ref($value)?@{$value}:($value); + my $output=''; + if (! defined($size)) { + $size = 4; + if (scalar(keys(%hash))<4) { + $size = scalar(keys(%hash)); + } + } + $output.="\n"; + foreach (sort(keys(%hash))) { + $output.=''.$hash{$_}."\n"; + } + $output.="\n"; + return $output; +} + +#------------------------------------------- + +=pod + +=item * select_form($defdom,$name,%hash) + +Returns a string containing a form to +allow a user to select options from a hash option_name => displayed text. +See lonrights.pm for an example invocation and use. + +=cut + +#------------------------------------------- +sub select_form { + my ($def,$name,%hash) = @_; + my $selectform = "\n"; + my @keys; + if (exists($hash{'select_form_order'})) { + @keys=@{$hash{'select_form_order'}}; + } else { + @keys=sort(keys(%hash)); + } + foreach (@keys) { + $selectform.="".&mt($hash{$_})."\n"; + } + $selectform.=""; + return $selectform; +} + +sub gradeleveldescription { + my $gradelevel=shift; + my %gradelevels=(0 => 'Not specified', + 1 => 'Grade 1', + 2 => 'Grade 2', + 3 => 'Grade 3', + 4 => 'Grade 4', + 5 => 'Grade 5', + 6 => 'Grade 6', + 7 => 'Grade 7', + 8 => 'Grade 8', + 9 => 'Grade 9', + 10 => 'Grade 10', + 11 => 'Grade 11', + 12 => 'Grade 12', + 13 => 'Grade 13', + 14 => '100 Level', + 15 => '200 Level', + 16 => '300 Level', + 17 => '400 Level', + 18 => 'Graduate Level'); + return &mt($gradelevels{$gradelevel}); +} + +sub select_level_form { + my ($deflevel,$name)=@_; + unless ($deflevel) { $deflevel=0; } + my $selectform = "\n"; + for (my $i=0; $i<=18; $i++) { + $selectform.="".&gradeleveldescription($i)."\n"; + } + $selectform.=""; + return $selectform; +} + +#------------------------------------------- + +=pod + +=item * select_dom_form($defdom,$name,$includeempty) + +Returns a string containing a form to +allow a user to select the domain to preform an operation in. +See loncreateuser.pm for an example invocation and use. + +If the $includeempty flag is set, it also includes an empty choice ("no domain +selected"); + +=cut + +#------------------------------------------- +sub select_dom_form { + my ($defdom,$name,$includeempty) = @_; + my @domains = get_domains(); + if ($includeempty) { @domains=('',@domains); } + my $selectdomain = "\n"; + foreach (@domains) { + $selectdomain.="$_\n"; + } + $selectdomain.=""; + return $selectdomain; +} + +#------------------------------------------- + +=pod + +=item * get_library_servers($domain) + +Returns a hash which contains keys like '103l3' and values like +'kirk.lite.msu.edu'. All of the keys will be for machines in the +given $domain. + +=cut + +#------------------------------------------- +sub get_library_servers { + my $domain = shift; + my %library_servers; + foreach (keys(%Apache::lonnet::libserv)) { + if ($Apache::lonnet::hostdom{$_} eq $domain) { + $library_servers{$_} = $Apache::lonnet::hostname{$_}; + } + } + return %library_servers; +} + +#------------------------------------------- + +=pod + +=item * home_server_option_list($domain) + +returns a string which contains an list to be used in a + form input. See loncreateuser.pm for an example. + +=cut + +#------------------------------------------- +sub home_server_option_list { + my $domain = shift; + my %servers = &get_library_servers($domain); + my $result = ''; + foreach (sort keys(%servers)) { + $result.= + ''.$_.' '.$servers{$_}."\n"; + } + return $result; +} + +=pod + +=back + +=cut + +############################################################### +## Decoding User Agent ## +############################################################### + +=pod + +=head1 Decoding the User Agent + +=over 4 + +=item * &decode_user_agent() + +Inputs: $r + +Outputs: + +=over 4 + +=item * $httpbrowser + +=item * $clientbrowser + +=item * $clientversion + +=item * $clientmathml + +=item * $clientunicode + +=item * $clientos + +=back + +=back + +=cut + +############################################################### +############################################################### +sub decode_user_agent { + my @browsertype=split(/\&/,$Apache::lonnet::perlvar{"lonBrowsDet"}); + my %mathcap=split(/\&/,$$Apache::lonnet::perlvar{"lonMathML"}); + my $httpbrowser=$ENV{"HTTP_USER_AGENT"}; + my $clientbrowser='unknown'; + my $clientversion='0'; + my $clientmathml=''; + my $clientunicode='0'; + for (my $i=0;$i<=$#browsertype;$i++) { + my ($bname,$match,$notmatch,$vreg,$minv,$univ)=split(/\:/,$browsertype[$i]); + if (($httpbrowser=~/$match/i) && ($httpbrowser!~/$notmatch/i)) { + $clientbrowser=$bname; + $httpbrowser=~/$vreg/i; + $clientversion=$1; + $clientmathml=($clientversion>=$minv); + $clientunicode=($clientversion>=$univ); + } + } + my $clientos='unknown'; + if (($httpbrowser=~/linux/i) || + ($httpbrowser=~/unix/i) || + ($httpbrowser=~/ux/i) || + ($httpbrowser=~/solaris/i)) { $clientos='unix'; } + if (($httpbrowser=~/vax/i) || + ($httpbrowser=~/vms/i)) { $clientos='vms'; } + if ($httpbrowser=~/next/i) { $clientos='next'; } + if (($httpbrowser=~/mac/i) || + ($httpbrowser=~/powerpc/i)) { $clientos='mac'; } + if ($httpbrowser=~/win/i) { $clientos='win'; } + if ($httpbrowser=~/embed/i) { $clientos='pda'; } + return ($httpbrowser,$clientbrowser,$clientversion,$clientmathml, + $clientunicode,$clientos,); +} + +############################################################### +## Authentication changing form generation subroutines ## +############################################################### +## +## All of the authform_xxxxxxx subroutines take their inputs in a +## hash, and have reasonable default values. +## +## formname = the name given in the tag. +#------------------------------------------- + +=pod + +=head1 Authentication Routines + +=over 4 + +=item * authform_xxxxxx + +The authform_xxxxxx subroutines provide javascript and html forms which +handle some of the conveniences required for authentication forms. +This is not an optimal method, but it works. + +See loncreateuser.pm for invocation and use examples. + +=over 4 + +=item * authform_header + +=item * authform_authorwarning + +=item * authform_nochange + +=item * authform_kerberos + +=item * authform_internal + +=item * authform_filesystem + +=back + +=back + +=cut + +#------------------------------------------- +sub authform_header{ + my %in = ( + formname => 'cu', + kerb_def_dom => '', + @_, + ); + $in{'formname'} = 'document.' . $in{'formname'}; + my $result=''; + +#---------------------------------------------- Code for upper case translation + my $Javascript_toUpperCase; + unless ($in{kerb_def_dom}) { + $Javascript_toUpperCase =<<"END"; + switch (choice) { + case 'krb': currentform.elements[choicearg].value = + currentform.elements[choicearg].value.toUpperCase(); + break; + default: + } +END + } else { + $Javascript_toUpperCase = ""; + } + + my $radioval = "'nochange'"; + if (exists($in{'curr_authtype'}) && + defined($in{'curr_authtype'}) && + $in{'curr_authtype'} ne '') { + $radioval = "'$in{'curr_authtype'}arg'"; + } + my $argfield = 'null'; + if ( grep/^mode$/,(keys %in) ) { + if ($in{'mode'} eq 'modifycourse') { + if ( grep/^curr_authtype$/,(keys %in) ) { + $radioval = "'$in{'curr_authtype'}'"; + } + if ( grep/^curr_autharg$/,(keys %in) ) { + unless ($in{'curr_autharg'} eq '') { + $argfield = "'$in{'curr_autharg'}'"; + } + } + } + } + + $result.=<<"END"; +var current = new Object(); +current.radiovalue = $radioval; +current.argfield = $argfield; + +function changed_radio(choice,currentform) { + var choicearg = choice + 'arg'; + // If a radio button in changed, we need to change the argfield + if (current.radiovalue != choice) { + current.radiovalue = choice; + if (current.argfield != null) { + currentform.elements[current.argfield].value = ''; + } + if (choice == 'nochange') { + current.argfield = null; + } else { + current.argfield = choicearg; + switch(choice) { + case 'krb': + currentform.elements[current.argfield].value = + "$in{'kerb_def_dom'}"; + break; + default: + break; + } + } + } + return; +} + +function changed_text(choice,currentform) { + var choicearg = choice + 'arg'; + if (currentform.elements[choicearg].value !='') { + $Javascript_toUpperCase + // clear old field + if ((current.argfield != choicearg) && (current.argfield != null)) { + currentform.elements[current.argfield].value = ''; + } + current.argfield = choicearg; + } + set_auth_radio_buttons(choice,currentform); + return; +} + +function set_auth_radio_buttons(newvalue,currentform) { + var i=0; + while (i < currentform.login.length) { + if (currentform.login[i].value == newvalue) { break; } + i++; + } + if (i == currentform.login.length) { + return; + } + current.radiovalue = newvalue; + currentform.login[i].checked = true; + return; +} +END + return $result; +} + +sub authform_authorwarning{ + my $result=''; + $result=''. + &mt('As a general rule, only authors or co-authors should be '. + 'filesystem authenticated '. + '(which allows access to the server filesystem).')."\n"; + return $result; +} + +sub authform_nochange{ + my %in = ( + formname => 'document.cu', + kerb_def_dom => 'MSU.EDU', + @_, + ); + my $result = &mt('[_1] Do not change login data', + ''); + return $result; +} + +sub authform_kerberos{ + my %in = ( + formname => 'document.cu', + kerb_def_dom => 'MSU.EDU', + kerb_def_auth => 'krb4', + @_, + ); + my ($check4,$check5,$krbarg); + if ($in{'kerb_def_auth'} eq 'krb5') { + $check5 = " checked=\"on\""; + } else { + $check4 = " checked=\"on\""; + } + $krbarg = $in{'kerb_def_dom'}; + + my $krbcheck = ""; + if ( grep/^curr_authtype$/,(keys %in) ) { + if ($in{'curr_authtype'} =~ m/^krb/) { + $krbcheck = " checked=\"on\""; + if ( grep/^curr_autharg$/,(keys %in) ) { + $krbarg = $in{'curr_autharg'}; } } } - return (); + + my $jscall = "javascript:changed_radio('krb',$in{'formname'});"; + my $result .= &mt + ('[_1] Kerberos authenticated with domain [_2] '. + '[_3] Version 4 [_4] Version 5', + '', + '', + '', + ''); + return $result; +} + +sub authform_internal{ + my %args = ( + formname => 'document.cu', + kerb_def_dom => 'MSU.EDU', + @_, + ); + + my $intcheck = ""; + my $intarg = 'value=""'; + if ( grep/^curr_authtype$/,(keys %args) ) { + if ($args{'curr_authtype'} eq 'int') { + $intcheck = " checked=\"on\""; + if ( grep/^curr_autharg$/,(keys %args) ) { + $intarg = "value=\"$args{'curr_autharg'}\""; + } + } + } + + my $jscall = "javascript:changed_radio('int',$args{'formname'});"; + my $result.=&mt + ('[_1] Internally authenticated (with initial password [_2])', + '', + ''); + return $result; +} + +sub authform_local{ + my %in = ( + formname => 'document.cu', + kerb_def_dom => 'MSU.EDU', + @_, + ); + + my $loccheck = ""; + my $locarg = 'value=""'; + if ( grep/^curr_authtype$/,(keys %in) ) { + if ($in{'curr_authtype'} eq 'loc') { + $loccheck = " checked=\"on\""; + if ( grep/^curr_autharg$/,(keys %in) ) { + $locarg = "value=\"$in{'curr_autharg'}\""; + } + } + } + + my $jscall = "javascript:changed_radio('loc',$in{'formname'});"; + my $result.=&mt('[_1] Local Authentication with argument [_2]', + '', + ''); + return $result; +} + +sub authform_filesystem{ + my %in = ( + formname => 'document.cu', + kerb_def_dom => 'MSU.EDU', + @_, + ); + my $jscall = "javascript:changed_radio('fsys',$in{'formname'});"; + my $result.= &mt + ('[_1] Filesystem Authenticated (with initial password [_2])', + '', + ''); + return $result; } -# ---------------------------------------------------------------- Language IDs +############################################################### +## Get Authentication Defaults for Domain ## +############################################################### + +=pod + +=head1 Domains and Authentication + +Returns default authentication type and an associated argument as +listed in file 'domain.tab'. + +=over 4 + +=item * get_auth_defaults + +get_auth_defaults($target_domain) returns the default authentication +type and an associated argument (initial password or a kerberos domain). +These values are stored in lonTabs/domain.tab + +($def_auth, $def_arg) = &get_auth_defaults($target_domain); + +If target_domain is not found in domain.tab, returns nothing (''). + +=cut + +#------------------------------------------- +sub get_auth_defaults { + my $domain=shift; + return ($Apache::lonnet::domain_auth_def{$domain},$Apache::lonnet::domain_auth_arg_def{$domain}); +} +############################################################### +## End Get Authentication Defaults for Domain ## +############################################################### + +############################################################### +## Get Kerberos Defaults for Domain ## +############################################################### +## +## Returns default kerberos version and an associated argument +## as listed in file domain.tab. If not listed, provides +## appropriate default domain and kerberos version. +## +#------------------------------------------- + +=pod + +=item * get_kerberos_defaults + +get_kerberos_defaults($target_domain) returns the default kerberos +version and domain. If not found in domain.tabs, it defaults to +version 4 and the domain of the server. + +($def_version, $def_krb_domain) = &get_kerberos_defaults($target_domain); + +=cut + +#------------------------------------------- +sub get_kerberos_defaults { + my $domain=shift; + my ($krbdef,$krbdefdom) = + &Apache::loncommon::get_auth_defaults($domain); + unless ($krbdef =~/^krb/ && $krbdefdom) { + $ENV{'SERVER_NAME'}=~/(\w+\.\w+)$/; + my $krbdefdom=$1; + $krbdefdom=~tr/a-z/A-Z/; + $krbdef = "krb4"; + } + return ($krbdef,$krbdefdom); +} + +=pod + +=back + +=cut + +############################################################### +## Thesaurus Functions ## +############################################################### + +=pod + +=head1 Thesaurus Functions + +=over 4 + +=item * initialize_keywords + +Initializes the package variable %Keywords if it is empty. Uses the +package variable $thesaurus_db_file. + +=cut + +################################################### + +sub initialize_keywords { + return 1 if (scalar keys(%Keywords)); + # If we are here, %Keywords is empty, so fill it up + # Make sure the file we need exists... + if (! -e $thesaurus_db_file) { + &Apache::lonnet::logthis("Attempt to access $thesaurus_db_file". + " failed because it does not exist"); + return 0; + } + # Set up the hash as a database + my %thesaurus_db; + if (! tie(%thesaurus_db,'GDBM_File', + $thesaurus_db_file,&GDBM_READER(),0640)){ + &Apache::lonnet::logthis("Could not tie \%thesaurus_db to ". + $thesaurus_db_file); + return 0; + } + # Get the average number of appearances of a word. + my $avecount = $thesaurus_db{'average.count'}; + # Put keywords (those that appear > average) into %Keywords + while (my ($word,$data)=each (%thesaurus_db)) { + my ($count,undef) = split /:/,$data; + $Keywords{$word}++ if ($count > $avecount); + } + untie %thesaurus_db; + # Remove special values from %Keywords. + foreach ('total.count','average.count') { + delete($Keywords{$_}) if (exists($Keywords{$_})); + } + return 1; +} + +################################################### + +=pod + +=item * keyword($word) + +Returns true if $word is a keyword. A keyword is a word that appears more +than the average number of times in the thesaurus database. Calls +&initialize_keywords + +=cut + +################################################### + +sub keyword { + return if (!&initialize_keywords()); + my $word=lc(shift()); + $word=~s/\W//g; + return exists($Keywords{$word}); +} + +############################################################### + +=pod + +=item * get_related_words + +Look up a word in the thesaurus. Takes a scalar argument and returns +an array of words. If the keyword is not in the thesaurus, an empty array +will be returned. The order of the words returned is determined by the +database which holds them. + +Uses global $thesaurus_db_file. + +=cut + +############################################################### +sub get_related_words { + my $keyword = shift; + my %thesaurus_db; + if (! -e $thesaurus_db_file) { + &Apache::lonnet::logthis("Attempt to access $thesaurus_db_file ". + "failed because the file does not exist"); + return (); + } + if (! tie(%thesaurus_db,'GDBM_File', + $thesaurus_db_file,&GDBM_READER(),0640)){ + return (); + } + my @Words=(); + if (exists($thesaurus_db{$keyword})) { + $_ = $thesaurus_db{$keyword}; + (undef,@Words) = split/:/; # The first element is the number of times + # the word appears. We do not need it now. + for (my $i=0;$i<=$#Words;$i++) { + ($Words[$i],undef)= split/\,/,$Words[$i]; + } + } + untie %thesaurus_db; + return @Words; +} + +=pod + +=back + +=cut + +# -------------------------------------------------------------- Plaintext name +=pod + +=head1 User Name Functions + +=over 4 + +=item * plainname($uname,$udom,$first) + +Takes a users logon name and returns it as a string in +"first middle last generation" form +if $first is set to 'lastname' then it returns it as +'lastname generation, firstname middlename' if their is a lastname + +=cut + +############################################################### +sub plainname { + my ($uname,$udom,$first)=@_; + my %names=&Apache::lonnet::get('environment', + ['firstname','middlename','lastname','generation'], + $udom,$uname); + my $name=&Apache::lonnet::format_name($names{'firstname'}, + $names{'middlename'}, + $names{'lastname'}, + $names{'generation'},$first); + $name=~s/^\s+//; + $name=~s/\s+$//; + $name=~s/\s+/ /g; + if ($name !~ /\S/) { $name=$uname.'@'.$udom; } + return $name; +} + +# -------------------------------------------------------------------- Nickname +=pod + +=item * nickname($uname,$udom) + +Gets a users name and returns it as a string as + +""nickname"" + +if the user has a nickname or + +"first middle last generation" + +if the user does not + +=cut + +sub nickname { + my ($uname,$udom)=@_; + my %names; + if ($uname eq $ENV{'user.name'} && + $udom eq $ENV{'user.domain'}) { + %names=('nickname' => $ENV{'environment.nickname'} , + 'firstname' => $ENV{'environment.firstname'} , + 'middlename' => $ENV{'environment.middlename'}, + 'lastname' => $ENV{'environment.lastname'} , + 'generation' => $ENV{'environment.generation'}); + } else { + %names=&Apache::lonnet::get('environment', + ['nickname','firstname','middlename', + 'lastname','generation'],$udom,$uname); + } + my $name=$names{'nickname'}; + if ($name) { + $name='"'.$name.'"'; + } else { + $name=$names{'firstname'}.' '.$names{'middlename'}.' '. + $names{'lastname'}.' '.$names{'generation'}; + $name=~s/\s+$//; + $name=~s/\s+/ /g; + } + return $name; +} + + +# ------------------------------------------------------------------ Screenname + +=pod + +=item * screenname($uname,$udom) + +Gets a users screenname and returns it as a string + +=cut + +sub screenname { + my ($uname,$udom)=@_; + if ($uname eq $ENV{'user.name'} && + $udom eq $ENV{'user.domain'}) {return $ENV{'environment.screenname'};} + my %names=&Apache::lonnet::get('environment',['screenname'],$udom,$uname); + return $names{'screenname'}; +} + + +# ------------------------------------------------------------- Message Wrapper + +sub messagewrapper { + my ($link,$username,$domain)=@_; + return + ''.$link.''; +} +# --------------------------------------------------------------- Notes Wrapper + +sub noteswrapper { + my ($link,$un,$do)=@_; + return +"$link"; +} +# ------------------------------------------------------------- Aboutme Wrapper + +sub aboutmewrapper { + my ($link,$username,$domain,$target)=@_; + return ''.$link.''; +} + +# ------------------------------------------------------------ Syllabus Wrapper + + +sub syllabuswrapper { + my ($linktext,$coursedir,$domain,$fontcolor)=@_; + if ($fontcolor) { + $linktext=''.$linktext.''; + } + return qq{$linktext}; +} + +sub track_student_link { + my ($linktext,$sname,$sdom,$target) = @_; + my $link ="/adm/trackstudent"; + my $title = 'View recent activity'; + if (defined($sname) && $sname !~ /^\s*$/ && + defined($sdom) && $sdom !~ /^\s*$/) { + $link .= "?selected_student=$sname:$sdom"; + $title .= ' of this student'; + } + if (defined($target) && $target !~ /^\s*$/) { + $target = qq{target="$target"}; + } else { + $target = ''; + } + return qq{$linktext}; +} + + + +=pod + +=back + +=head1 Access .tab File Data + +=over 4 + +=item * languageids() + +returns list of all language ids + +=cut + sub languageids { return sort(keys(%language)); } -# -------------------------------------------------------- Language Description +=pod + +=item * languagedescription() + +returns description of a specified language id + +=cut + sub languagedescription { - return $language{shift(@_)}; + my $code=shift; + return ($supported_language{$code}?'* ':''). + $language{$code}. + ($supported_language{$code}?' ('.&mt('interface available').')':''); } -# --------------------------------------------------------------- Copyright IDs +sub plainlanguagedescription { + my $code=shift; + return $language{$code}; +} + +sub supportedlanguagecode { + my $code=shift; + return $supported_language{$code}; +} + +=pod + +=item * copyrightids() + +returns list of all copyrights + +=cut + sub copyrightids { return sort(keys(%cprtag)); } -# ------------------------------------------------------- Copyright Description +=pod + +=item * copyrightdescription() + +returns description of a specified copyright id + +=cut + sub copyrightdescription { - return $cprtag{shift(@_)}; + return &mt($cprtag{shift(@_)}); } -# ------------------------------------------------------------- File Categories +=pod + +=item * source_copyrightids() + +returns list of all source copyrights + +=cut + +sub source_copyrightids { + return sort(keys(%scprtag)); +} + +=pod + +=item * source_copyrightdescription() + +returns description of a specified source copyright id + +=cut + +sub source_copyrightdescription { + return &mt($scprtag{shift(@_)}); +} + +=pod + +=item * filecategories() + +returns list of all file categories + +=cut + sub filecategories { - return sort(keys(%fc)); + return sort(keys(%category_extensions)); } -# -------------------------------------- File Types within a specified category +=pod + +=item * filecategorytypes() + +returns list of file types belonging to a given file +category + +=cut + sub filecategorytypes { - return @{$fc{lc(shift(@_))}}; + return @{$category_extensions{lc($_[0])}}; } -# ------------------------------------------------------------------ File Types -sub fileextensions { - return sort(keys(%fe)); -} +=pod + +=item * fileembstyle() + +returns embedding style for a specified file type + +=cut -# ------------------------------------------------------------- Embedding Style sub fileembstyle { return $fe{lc(shift(@_))}; } -# ------------------------------------------------------------ Description Text + +sub filecategoryselect { + my ($name,$value)=@_; + return &select_form($value,$name, + '' => &mt('Any category'), + map { $_,$_ } sort(keys(%category_extensions))); +} + +=pod + +=item * filedescription() + +returns description for a specified file type + +=cut + sub filedescription { - return $fd{lc(shift(@_))}; + my $file_description = $fd{lc(shift())}; + $file_description =~ s:([\[\]]):~$1:g; + return &mt($file_description); } -# ------------------------------------------------------------ Description Text +=pod + +=item * filedescriptionex() + +returns description for a specified file type with +extra formatting + +=cut + sub filedescriptionex { my $ex=shift; - return '.'.$ex.' '.$fd{lc($ex)}; + my $file_description = $fd{lc($ex)}; + $file_description =~ s:([\[\]]):~$1:g; + return '.'.$ex.' '.&mt($file_description); } +# End of .tab access +=pod + +=back + +=cut + +# ------------------------------------------------------------------ File Types +sub fileextensions { + return sort(keys(%fe)); +} + +# ----------------------------------------------------------- Display Languages +# returns a hash with all desired display languages +# + +sub display_languages { + my %languages=(); + foreach (&preferred_languages()) { + $languages{$_}=1; + } + &get_unprocessed_cgi($ENV{'QUERY_STRING'},['displaylanguage']); + if ($ENV{'form.displaylanguage'}) { + foreach (split(/\s*(\,|\;|\:)\s*/,$ENV{'form.displaylanguage'})) { + $languages{$_}=1; + } + } + return %languages; +} + +sub preferred_languages { + my @languages=(); + if ($ENV{'course.'.$ENV{'request.course.id'}.'.languages'}) { + @languages=(@languages,split(/\s*(\,|\;|\:)\s*/, + $ENV{'course.'.$ENV{'request.course.id'}.'.languages'})); + } + if ($ENV{'environment.languages'}) { + @languages=split(/\s*(\,|\;|\:)\s*/,$ENV{'environment.languages'}); + } + my $browser=(split(/\;/,$ENV{'HTTP_ACCEPT_LANGUAGE'}))[0]; + if ($browser) { + @languages=(@languages,split(/\s*(\,|\;|\:)\s*/,$browser)); + } + if ($Apache::lonnet::domain_lang_def{$ENV{'user.domain'}}) { + @languages=(@languages, + $Apache::lonnet::domain_lang_def{$ENV{'user.domain'}}); + } + if ($Apache::lonnet::domain_lang_def{$ENV{'request.role.domain'}}) { + @languages=(@languages, + $Apache::lonnet::domain_lang_def{$ENV{'request.role.domain'}}); + } + if ($Apache::lonnet::domain_lang_def{ + $Apache::lonnet::perlvar{'lonDefDomain'}}) { + @languages=(@languages, + $Apache::lonnet::domain_lang_def{ + $Apache::lonnet::perlvar{'lonDefDomain'}}); + } +# turn "en-ca" into "en-ca,en" + my @genlanguages; + foreach (@languages) { + unless ($_=~/\w/) { next; } + push (@genlanguages,$_); + if ($_=~/(\-|\_)/) { + push (@genlanguages,(split(/(\-|\_)/,$_))[0]); + } + } + return @genlanguages; +} + +############################################################### +## Student Answer Attempts ## +############################################################### + +=pod + +=head1 Alternate Problem Views + +=over 4 + +=item * get_previous_attempt($symb, $username, $domain, $course, + $getattempt, $regexp, $gradesub) + +Return string with previous attempt on problem. Arguments: + +=over 4 + +=item * $symb: Problem, including path + +=item * $username: username of the desired student + +=item * $domain: domain of the desired student + +=item * $course: Course ID + +=item * $getattempt: Leave blank for all attempts, otherwise put + something + +=item * $regexp: if string matches this regexp, the string will be + sent to $gradesub + +=item * $gradesub: routine that processes the string if it matches $regexp + +=back + +The output string is a table containing all desired attempts, if any. + +=cut + sub get_previous_attempt { - my ($symb,$username,$domain,$course)=@_; + my ($symb,$username,$domain,$course,$getattempt,$regexp,$gradesub)=@_; my $prevattempts=''; + no strict 'refs'; if ($symb) { my (%returnhash)= &Apache::lonnet::restore($symb,$course,$domain,$username); @@ -271,23 +2178,37 @@ sub get_previous_attempt { $lasthash{$_}=$returnhash{$version.':'.$_}; } } - $prevattempts='History'; + $prevattempts=''; + $prevattempts.='History'; foreach (sort(keys %lasthash)) { - $prevattempts.=''.$_.''; - } - for ($version=1;$version<=$returnhash{'version'};$version++) { - $prevattempts.='Attempt '.$version.''; - foreach (sort(keys %lasthash)) { - my $value; - if ($_ =~ /timestamp/) { - $value=scalar(localtime($returnhash{$version.':'.$_})); + my ($ign,@parts) = split(/\./,$_); + if ($#parts > 0) { + my $data=$parts[-1]; + pop(@parts); + $prevattempts.='Part '.join('.',@parts).''.$data.' '; + } else { + if ($#parts == 0) { + $prevattempts.=''.$parts[0].''; } else { - $value=$returnhash{$version.':'.$_}; + $prevattempts.=''.$ign.''; } - $prevattempts.=''.$value.''; - } + } + } + if ($getattempt eq '') { + for ($version=1;$version<=$returnhash{'version'};$version++) { + $prevattempts.='Transaction '.$version.''; + foreach (sort(keys %lasthash)) { + my $value; + if ($_ =~ /timestamp/) { + $value=scalar(localtime($returnhash{$version.':'.$_})); + } else { + $value=$returnhash{$version.':'.$_}; + } + $prevattempts.=''.&Apache::lonnet::unescape($value).' '; + } + } } - $prevattempts.='Current'; + $prevattempts.='Current'; foreach (sort(keys %lasthash)) { my $value; if ($_ =~ /timestamp/) { @@ -295,9 +2216,11 @@ sub get_previous_attempt { } else { $value=$lasthash{$_}; } - $prevattempts.=''.$value.''; + $value=&Apache::lonnet::unescape($value); + if ($_ =~/$regexp$/ && (defined &$gradesub)) {$value = &$gradesub($value)} + $prevattempts.=''.$value.' '; } - $prevattempts.=''; + $prevattempts.=''; } else { $prevattempts='Nothing submitted - no attempts.'; } @@ -306,21 +2229,63 @@ sub get_previous_attempt { } } +sub relative_to_absolute { + my ($url,$output)=@_; + my $parser=HTML::TokeParser->new(\$output); + my $token; + my $thisdir=$url; + my @rlinks=(); + while ($token=$parser->get_token) { + if ($token->[0] eq 'S') { + if ($token->[1] eq 'a') { + if ($token->[2]->{'href'}) { + $rlinks[$#rlinks+1]=$token->[2]->{'href'}; + } + } elsif ($token->[1] eq 'img' || $token->[1] eq 'embed' ) { + $rlinks[$#rlinks+1]=$token->[2]->{'src'}; + } elsif ($token->[1] eq 'base') { + $thisdir=$token->[2]->{'href'}; + } + } + } + $thisdir=~s-/[^/]*$--; + foreach (@rlinks) { + unless (($_=~/^http:\/\//i) || + ($_=~/^\//) || + ($_=~/^javascript:/i) || + ($_=~/^mailto:/i) || + ($_=~/^\#/)) { + my $newlocation=&Apache::lonnet::hreflocation($thisdir,$_); + $output=~s/(\"|\'|\=\s*)$_(\"|\'|\s|\>)/$1$newlocation$2/; + } + } +# -------------------------------------------------- Deal with Applet codebases + $output=~s/(\]+)(codebase\=[^\S\>]+)*([^\>]*)\>/$1.($2?$2:' codebase="'.$thisdir.'"').$3.'>'/gei; + return $output; +} + +=pod + +=item * get_student_view + +show a snapshot of what student was looking at + +=cut + sub get_student_view { - my ($symb,$username,$domain,$courseid) = @_; - my ($map,$id,$feedurl) = split(/___/,$symb); - my (%old,%moreenv); + my ($symb,$username,$domain,$courseid,$target,$moreenv) = @_; + my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb); + my (%form); my @elements=('symb','courseid','domain','username'); foreach my $element (@elements) { - $old{$element}=$ENV{'form.grade_'.$element}; - $moreenv{'form.grade_'.$element}=eval '$'.$element #' + $form{'grade_'.$element}=eval '$'.$element #' } - &Apache::lonnet::appenv(%moreenv); - my $userview=&Apache::lonnet::ssi('/res/'.$feedurl); - &Apache::lonnet::delenv('form.grade_'); - foreach my $element (@elements) { - $ENV{'form.grade_'.$element}=$old{$element}; + if (defined($moreenv)) { + %form=(%form,%{$moreenv}); } + if ($target eq 'tex') {$form{'grade_target'} = 'tex';} + $feedurl=&Apache::lonnet::clutter($feedurl); + my $userview=&Apache::lonnet::ssi_body($feedurl,%form); $userview=~s/\]*\>//gi; $userview=~s/\<\/body\>//gi; $userview=~s/\//gi; @@ -328,166 +2293,1524 @@ sub get_student_view { $userview=~s/\//gi; $userview=~s/\<\/head\>//gi; $userview=~s/action\s*\=/would_be_action\=/gi; + $userview=&relative_to_absolute($feedurl,$userview); return $userview; } +=pod + +=item * get_student_answers() + +show a snapshot of how student was answering problem + +=cut + sub get_student_answers { - my ($symb,$username,$domain,$courseid) = @_; - my ($map,$id,$feedurl) = split(/___/,$symb); - my (%old,%moreenv); + my ($symb,$username,$domain,$courseid,%form) = @_; + my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb); + my (%moreenv); my @elements=('symb','courseid','domain','username'); foreach my $element (@elements) { - $old{$element}=$ENV{'form.grade_'.$element}; - $moreenv{'form.grade_'.$element}=eval '$'.$element #' - } - $moreenv{'form.grade_target'}='answer'; - &Apache::lonnet::appenv(%moreenv); - my $userview=&Apache::lonnet::ssi('/res/'.$feedurl); - &Apache::lonnet::delenv('form.grade_'); - foreach my $element (@elements) { - $ENV{'form.grade_'.$element}=$old{$element}; + $moreenv{'grade_'.$element}=eval '$'.$element #' } - $userview=~s/\]*\>//gi; - $userview=~s/\<\/body\>//gi; - $userview=~s/\//gi; - $userview=~s/\<\/html\>//gi; - $userview=~s/\//gi; - $userview=~s/\<\/head\>//gi; - $userview=~s/action\s*\=/would_be_action\=/gi; + $moreenv{'grade_target'}='answer'; + %moreenv=(%form,%moreenv); + my $userview=&Apache::lonnet::ssi('/res/'.$feedurl,%moreenv); return $userview; } +=pod + +=item * &submlink() + +Inputs: $text $uname $udom $symb + +Returns: A link to grades.pm such as to see the SUBM view of a student + +=cut + +############################################### +sub submlink { + my ($text,$uname,$udom,$symb)=@_; + if (!($uname && $udom)) { + (my $cursymb, my $courseid,$udom,$uname)= + &Apache::lonxml::whichuser($symb); + if (!$symb) { $symb=$cursymb; } + } + if (!$symb) { $symb=&symbread(); } + return ''.$text.''; +} +############################################## + +=pod + +=back + +=cut + +############################################### + + +sub timehash { + my @ltime=localtime(shift); + return ( 'seconds' => $ltime[0], + 'minutes' => $ltime[1], + 'hours' => $ltime[2], + 'day' => $ltime[3], + 'month' => $ltime[4]+1, + 'year' => $ltime[5]+1900, + 'weekday' => $ltime[6], + 'dayyear' => $ltime[7]+1, + 'dlsav' => $ltime[8] ); +} + +sub maketime { + my %th=@_; + return POSIX::mktime( + ($th{'seconds'},$th{'minutes'},$th{'hours'}, + $th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,-1)); +} + +######################################### + +sub findallcourses { + my %courses=(); + my $now=time; + foreach (keys %ENV) { + if ($_=~/^user\.role\.\w+\.\/(\w+)\/(\w+)/) { + my ($starttime,$endtime)=$ENV{$_}; + my $active=1; + if ($starttime) { + if ($now<$starttime) { $active=0; } + } + if ($endtime) { + if ($now>$endtime) { $active=0; } + } + if ($active) { $courses{$1.'_'.$2}=1; } + } + } + return keys %courses; +} + +############################################### +############################################### + +=pod + +=head1 Domain Template Functions + +=over 4 + +=item * &determinedomain() + +Inputs: $domain (usually will be undef) + +Returns: Determines which domain should be used for designs + +=cut + +############################################### +sub determinedomain { + my $domain=shift; + if (! $domain) { + # Determine domain if we have not been given one + $domain = $Apache::lonnet::perlvar{'lonDefDomain'}; + if ($ENV{'user.domain'}) { $domain=$ENV{'user.domain'}; } + if ($ENV{'request.role.domain'}) { + $domain=$ENV{'request.role.domain'}; + } + } + return $domain; +} +############################################### +=pod + +=item * &domainlogo() + +Inputs: $domain (usually will be undef) + +Returns: A link to a domain logo, if the domain logo exists. +If the domain logo does not exist, a description of the domain. + +=cut + +############################################### +sub domainlogo { + my $domain = &determinedomain(shift); + # See if there is a logo + if (-e '/home/httpd/html/adm/lonDomLogos/'.$domain.'.gif') { + my $logo=&lonhttpdurl("/adm/lonDomLogos/$domain.gif"); + return ''; + } elsif(exists($Apache::lonnet::domaindescription{$domain})) { + return $Apache::lonnet::domaindescription{$domain}; + } else { + return ''; + } +} +############################################## + +=pod + +=item * &designparm() + +Inputs: $which parameter; $domain (usually will be undef) + +Returns: value of designparamter $which + +=cut + +############################################## +sub designparm { + my ($which,$domain)=@_; + if ($ENV{'browser.blackwhite'} eq 'on') { + if ($which=~/\.(font|alink|vlink|link)$/) { + return '#000000'; + } + if ($which=~/\.(pgbg|sidebg)$/) { + return '#FFFFFF'; + } + if ($which=~/\.tabbg$/) { + return '#CCCCCC'; + } + } + if ($ENV{'environment.color.'.$which}) { + return $ENV{'environment.color.'.$which}; + } + $domain=&determinedomain($domain); + if ($designhash{$domain.'.'.$which}) { + return $designhash{$domain.'.'.$which}; + } else { + return $designhash{'default.'.$which}; + } +} + +############################################### +############################################### + +=pod + +=back + +=head1 HTTP Helpers + +=over 4 + +=item * &bodytag() + +Returns a uniform header for LON-CAPA web pages. + +Inputs: + +=over 4 + +=item * $title, A title to be displayed on the page. + +=item * $function, the current role (can be undef). + +=item * $addentries, extra parameters for the tag. + +=item * $bodyonly, if defined, only return the tag. + +=item * $domain, if defined, force a given domain. + +=item * $forcereg, if page should register as content page (relevant for + text interface only) + +=back + +Returns: A uniform header for LON-CAPA web pages. +If $bodyonly is nonzero, a string containing a tag will be returned. +If $bodyonly is undef or zero, an html string containing a tag and +other decorations will be returned. + +=cut + +sub bodytag { + my ($title,$function,$addentries,$bodyonly,$domain,$forcereg,$customtitle)=@_; + $title=&mt($title); + $function = &get_users_function() if (!$function); + my $img=&designparm($function.'.img',$domain); + my $pgbg=&designparm($function.'.pgbg',$domain); + my $tabbg=&designparm($function.'.tabbg',$domain); + my $font=&designparm($function.'.font',$domain); + my $link=&designparm($function.'.link',$domain); + my $alink=&designparm($function.'.alink',$domain); + my $vlink=&designparm($function.'.vlink',$domain); + my $sidebg=&designparm($function.'.sidebg',$domain); +# Accessibility font enhance + unless ($addentries) { $addentries=''; } + my $addstyle=''; + if ($ENV{'browser.fontenhance'} eq 'on') { + $addstyle=' font-size: x-large;'; + } + # role and realm + my ($role,$realm) + =&Apache::lonnet::plaintext((split(/\./,$ENV{'request.role'}))[0]); +# realm + if ($ENV{'request.course.id'}) { + $realm= + $ENV{'course.'.$ENV{'request.course.id'}.'.description'}; + } + unless ($realm) { $realm=' '; } +# Set messages + my $messages=&domainlogo($domain); +# Port for miniserver + my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'}; + if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; } +# construct main body tag + my $bodytag = < +h1, h2, h3, th { font-family: Arial, Helvetica, sans-serif } +a:focus { color: red; background: yellow } + + +END + my $upperleft=''; + if ($bodyonly) { + return $bodytag; + } elsif ($ENV{'browser.interface'} eq 'textual') { +# Accessibility + + return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web', + $forcereg). + 'LON-CAPA: '.$title.''; + } elsif ($ENV{'environment.remote'} eq 'off') { +# No Remote + my $roleinfo=(< + + $ENV{'environment.firstname'} + $ENV{'environment.middlename'} + $ENV{'environment.lastname'} + $ENV{'environment.generation'} + + +$role + +$realm + +ENDROLE + my $titleinfo = ''.$title.''; + if ($customtitle) { + $titleinfo = $customtitle; + } + if ($ENV{'request.state'} eq 'construct') { + my ($uname,$thisdisfn)= + ($ENV{'request.filename'} =~ m|^/home/([^/]+)/public_html/(.*)|); + my $formaction='/priv/'.$uname.'/'.$thisdisfn; + $formaction=~s/\/+/\//g; + $titleinfo = '' + .&Apache::lonhtmlcommon::crumbs($uname.'/'.$thisdisfn,'_top','/priv','',-1,1)."" + .&Apache::lonhtmlcommon::select_recent('construct','recent','this.form.action=this.form.recent.value;this.form.submit()') + .'' + .&Apache::lonmenu::constspaceform(); + + &Apache::lonhtmlcommon::store_recent('construct',$formaction,$formaction); + if ($thisdisfn!~m|/$|) { $forcereg=1; } + } + + &Apache::lonnet::logthis("hrrm"); + return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web', + $forcereg). + ''.$titleinfo.''.$roleinfo.''; + } + +# +# Top frame rendering, Remote is up +# + my $titleinfo = ' '.$title.''; + if ($customtitle) { + $titleinfo = $customtitle; + } + return(< + +$upperleft +$messages + + + +$titleinfo + + + $ENV{'environment.firstname'} + $ENV{'environment.middlename'} + $ENV{'environment.lastname'} + $ENV{'environment.generation'} + + + + +$role + + +$realm + +ENDBODY +} + +############################################### + +=pod + +=item get_users_function + +Used by &bodytag to determine the current users primary role. +Returns either 'student','coordinator','admin', or 'author'. + +=cut + +############################################### +sub get_users_function { + my $function = 'student'; + if ($ENV{'request.role'}=~/^(cc|in|ta|ep)/) { + $function='coordinator'; + } + if ($ENV{'request.role'}=~/^(su|dc|ad|li)/) { + $function='admin'; + } + if (($ENV{'request.role'}=~/^(au|ca)/) || + ($ENV{'REQUEST_URI'}=~/^(\/priv|\~)/)) { + $function='author'; + } + return $function; +} + +############################################### + +sub get_posted_cgi { + my $r=shift; + + my $buffer; + + $r->read($buffer,$r->header_in('Content-length'),0); + unless ($buffer=~/^(\-+\w+)\s+Content\-Disposition\:\s*form\-data/si) { + my @pairs=split(/&/,$buffer); + my $pair; + foreach $pair (@pairs) { + my ($name,$value) = split(/=/,$pair); + $value =~ tr/+/ /; + $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; + $name =~ tr/+/ /; + $name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; + &add_to_env("form.$name",$value); + } + } else { + my $contentsep=$1; + my @lines = split (/\n/,$buffer); + my $name=''; + my $value=''; + my $fname=''; + my $fmime=''; + my $i; + for ($i=0;$i<=$#lines;$i++) { + if ($lines[$i]=~/^$contentsep/) { + if ($name) { + chomp($value); + if ($fname) { + $ENV{"form.$name.filename"}=$fname; + $ENV{"form.$name.mimetype"}=$fmime; + } else { + $value=~s/\s+$//s; + } + &add_to_env("form.$name",$value); + } + if ($i<$#lines) { + $i++; + $lines[$i]=~ + /Content\-Disposition\:\s*form\-data\;\s*name\=\"([^\"]+)\"/i; + $name=$1; + $value=''; + if ($lines[$i]=~/filename\=\"([^\"]+)\"/i) { + $fname=$1; + if + ($lines[$i+1]=~/Content\-Type\:\s*([\w\-\/]+)/i) { + $fmime=$1; + $i++; + } else { + $fmime=''; + } + } else { + $fname=''; + $fmime=''; + } + $i++; + } + } else { + $value.=$lines[$i]."\n"; + } + } + } + $ENV{'request.method'}=$ENV{'REQUEST_METHOD'}; + $r->method_number(M_GET); + $r->method('GET'); + $r->headers_in->unset('Content-length'); +} + +=pod + +=item * get_unprocessed_cgi($query,$possible_names) + +Modify the %ENV hash to contain unprocessed CGI form parameters held in +$query. The parameters listed in $possible_names (an array reference), +will be set in $ENV{'form.name'} if they do not already exist. + +Typically called with $ENV{'QUERY_STRING'} as the first parameter. +$possible_names is an ref to an array of form element names. As an example: +get_unprocessed_cgi($ENV{'QUERY_STRING'},['uname','udom']); +will result in $ENV{'form.uname'} and $ENV{'form.udom'} being set. + +=cut + sub get_unprocessed_cgi { - my ($query)= @_; + my ($query,$possible_names)= @_; + # $Apache::lonxml::debug=1; foreach (split(/&/,$query)) { my ($name, $value) = split(/=/,$_); - $value =~ tr/+/ /; - $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; - if (!defined($ENV{'form.'.$name})) { $ENV{'form.'.$name}=$value; } + $name = &Apache::lonnet::unescape($name); + if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) { + $value =~ tr/+/ /; + $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; + &Apache::lonxml::debug("Seting :$name: to :$value:"); + unless (defined($ENV{'form.'.$name})) { &add_to_env('form.'.$name,$value) }; + } } } +=pod + +=item * cacheheader() + +returns cache-controlling header code + +=cut + sub cacheheader { - unless ($ENV{'request.method'} eq 'GET') { return ''; } - my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime); - my $output .=' + unless ($ENV{'request.method'} eq 'GET') { return ''; } + my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime); + my $output .=' '; - return $output; + return $output; } +=pod + +=item * no_cache($r) + +specifies header code to not have cache + +=cut + sub no_cache { - my ($r) = @_; - unless ($ENV{'request.method'} eq 'GET') { return ''; } - #my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime); - $r->no_cache(1); - $r->header_out("Pragma" => "no-cache"); - #$r->header_out("Expires" => $date); + my ($r) = @_; + if ($ENV{'REQUEST_METHOD'} ne 'GET' && + $ENV{'request.method'} ne 'GET') { return ''; } + my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime(time)); + $r->no_cache(1); + $r->header_out("Expires" => $date); + $r->header_out("Pragma" => "no-cache"); } -1; -__END__; +sub content_type { + my ($r,$type,$charset) = @_; + unless ($charset) { + $charset=&Apache::lonlocal::current_encoding; + } + if ($charset) { $type.='; charset='.$charset; } + if ($r) { + $r->content_type($type); + } else { + print("Content-type: $type\n\n"); + } +} -=head1 NAME +=pod -Apache::loncommon - pile of common routines +=item * add_to_env($name,$value) -=head1 SYNOPSIS +adds $name to the %ENV hash with value +$value, if $name already exists, the entry is converted to an array +reference and $value is added to the array. -Referenced by other mod_perl Apache modules. +=cut -Invocation: - &Apache::loncommon::SUBROUTINENAME(ARGUMENTS); +sub add_to_env { + my ($name,$value)=@_; + if (defined($ENV{$name})) { + if (ref($ENV{$name})) { + #already have multiple values + push(@{ $ENV{$name} },$value); + } else { + #first time seeing multiple values, convert hash entry to an arrayref + my $first=$ENV{$name}; + undef($ENV{$name}); + push(@{ $ENV{$name} },$first,$value); + } + } else { + $ENV{$name}=$value; + } +} -=head1 INTRODUCTION +=pod -Common collection of used subroutines. This collection helps remove -redundancy from other modules and increase efficiency of memory usage. +=item * get_env_multiple($name) -Current things done: +gets $name from the %ENV hash, it seemlessly handles the cases where multiple +values may be defined and end up as an array ref. - Makes a table out of the previous homework attempts - Inputs result_from_symbread, user, domain, course_id - Reads in non-network-related .tab files +returns an array of values -This is part of the LearningOnline Network with CAPA project -described at http://www.lon-capa.org. +=cut -=head1 HANDLER SUBROUTINE +sub get_env_multiple { + my ($name) = @_; + my @values; + if (defined($ENV{$name})) { + # exists is it an array + if (ref($ENV{$name})) { + @values=@{ $ENV{$name} }; + } else { + $values[0]=$ENV{$name}; + } + } + return(@values); +} + + +=pod -There is no handler subroutine. +=back -=head1 OTHER SUBROUTINES +=head1 CSV Upload/Handling functions =over 4 -=item * +=item * upfile_store($r) -BEGIN() : initialize values from language.tab, copyright.tab, filetypes.tab, -and filecategories.tab. +Store uploaded file, $r should be the HTTP Request object, +needs $ENV{'form.upfile'} +returns $datatoken to be put into hidden field -=item * +=cut -languageids() : returns list of all language ids +sub upfile_store { + my $r=shift; + $ENV{'form.upfile'}=~s/\r/\n/gs; + $ENV{'form.upfile'}=~s/\f/\n/gs; + $ENV{'form.upfile'}=~s/\n+/\n/gs; + $ENV{'form.upfile'}=~s/\n+$//gs; -=item * + my $datatoken=$ENV{'user.name'}.'_'.$ENV{'user.domain'}. + '_enroll_'.$ENV{'request.course.id'}.'_'.time.'_'.$$; + { + my $datafile = $r->dir_config('lonDaemons'). + '/tmp/'.$datatoken.'.tmp'; + if ( open(my $fh,">$datafile") ) { + print $fh $ENV{'form.upfile'}; + close($fh); + } + } + return $datatoken; +} -languagedescription() : returns description of a specified language id +=pod -=item * +=item * load_tmp_file($r) -copyrightids() : returns list of all copyrights +Load uploaded file from tmp, $r should be the HTTP Request object, +needs $ENV{'form.datatoken'}, +sets $ENV{'form.upfile'} to the contents of the file -=item * +=cut -copyrightdescription() : returns description of a specified copyright id +sub load_tmp_file { + my $r=shift; + my @studentdata=(); + { + my $studentfile = $r->dir_config('lonDaemons'). + '/tmp/'.$ENV{'form.datatoken'}.'.tmp'; + if ( open(my $fh,"<$studentfile") ) { + @studentdata=<$fh>; + close($fh); + } + } + $ENV{'form.upfile'}=join('',@studentdata); +} -=item * +=pod -filecategories() : returns list of all file categories +=item * upfile_record_sep() -=item * +Separate uploaded file into records +returns array of records, +needs $ENV{'form.upfile'} and $ENV{'form.upfiletype'} -filecategorytypes() : returns list of file types belonging to a given file -category +=cut -=item * +sub upfile_record_sep { + if ($ENV{'form.upfiletype'} eq 'xml') { + } else { + return split(/\n/,$ENV{'form.upfile'}); + } +} -fileembstyle() : returns embedding style for a specified file type +=pod -=item * +=item * record_sep($record) -filedescription() : returns description for a specified file type +Separate a record into fields $record should be an item from the upfile_record_sep(), needs $ENV{'form.upfiletype'} -=item * +=cut -filedescriptionex() : returns description for a specified file type with -extra formatting +sub record_sep { + my $record=shift; + my %components=(); + if ($ENV{'form.upfiletype'} eq 'xml') { + } elsif ($ENV{'form.upfiletype'} eq 'space') { + my $i=0; + foreach (split(/\s+/,$record)) { + my $field=$_; + $field=~s/^(\"|\')//; + $field=~s/(\"|\')$//; + $components{$i}=$field; + $i++; + } + } elsif ($ENV{'form.upfiletype'} eq 'tab') { + my $i=0; + foreach (split(/\t/,$record)) { + my $field=$_; + $field=~s/^(\"|\')//; + $field=~s/(\"|\')$//; + $components{$i}=$field; + $i++; + } + } else { + my @allfields=split(/\,/,$record); + my $i=0; + my $j; + for ($j=0;$j<=$#allfields;$j++) { + my $field=$allfields[$j]; + if ($field=~/^\s*(\"|\')/) { + my $delimiter=$1; + while (($field!~/$delimiter$/) && ($j<$#allfields)) { + $j++; + $field.=','.$allfields[$j]; + } + $field=~s/^\s*$delimiter//; + $field=~s/$delimiter\s*$//; + } + $components{$i}=$field; + $i++; + } + } + return %components; +} -=item * +###################################################### +###################################################### -get_previous_attempt() : return string with previous attempt on problem +=pod -=item * +=item * upfile_select_html() -get_student_view() : show a snapshot of what student was looking at +Return HTML code to select a file from the users machine and specify +the file type. -=item * +=cut -get_student_answers() : show a snapshot of how student was answering problem +###################################################### +###################################################### +sub upfile_select_html { + my %Types = ( + csv => &mt('CSV (comma separated values, spreadsheet)'), + space => &mt('Space separated'), + tab => &mt('Tabulator separated'), +# xml => &mt('HTML/XML'), + ); + my $Str = ''. + 'Type: '; + foreach my $type (sort(keys(%Types))) { + $Str .= ''.$Types{$type}."\n"; + } + $Str .= "\n"; + return $Str; +} -=item * +###################################################### +###################################################### -get_unprocessed_cgi() : get unparsed CGI parameters +=pod -=item * +=item * csv_print_samples($r,$records) -cacheheader() : returns cache-controlling header code +Prints a table of sample values from each column uploaded $r is an +Apache Request ref, $records is an arrayref from +&Apache::loncommon::upfile_record_sep -=item * +=cut -nocache() : specifies header code to not have cache +###################################################### +###################################################### +sub csv_print_samples { + my ($r,$records) = @_; + my (%sone,%stwo,%sthree); + %sone=&record_sep($$records[0]); + if (defined($$records[1])) {%stwo=&record_sep($$records[1]);} + if (defined($$records[2])) {%sthree=&record_sep($$records[2]);} + # + $r->print(&mt('Samples').''); + foreach (sort({$a <=> $b} keys(%sone))) { + $r->print(''.&mt('Column [_1]',($_+1)).''); } + $r->print(''); + foreach my $hash (\%sone,\%stwo,\%sthree) { + $r->print(''); + foreach (sort({$a <=> $b} keys(%sone))) { + $r->print(''); + if (defined($$hash{$_})) { $r->print($$hash{$_}); } + $r->print(''); + } + $r->print(''); + } + $r->print(''."\n"); +} + +###################################################### +###################################################### + +=pod + +=item * csv_print_select_table($r,$records,$d) + +Prints a table to create associations between values and table columns. + +$r is an Apache Request ref, +$records is an arrayref from &Apache::loncommon::upfile_record_sep, +$d is an array of 2 element arrays (internal name, displayed name,defaultcol) + +=cut + +###################################################### +###################################################### +sub csv_print_select_table { + my ($r,$records,$d) = @_; + my $i=0;my %sone; + %sone=&record_sep($$records[0]); + $r->print(&mt('Associate columns with student attributes.')."\n". + ''. + ''.&mt('Attribute').''. + ''.&mt('Column').''."\n"); + foreach (@$d) { + my ($value,$display,$defaultcol)=@{ $_ }; + $r->print(''.$display.''); + + $r->print(''); + $r->print(''); + foreach (sort({$a <=> $b} keys(%sone))) { + $r->print('Column '.($_+1).''); + } + $r->print(''."\n"); + $i++; + } + $i--; + return $i; +} + +###################################################### +###################################################### + +=pod + +=item * csv_samples_select_table($r,$records,$d) + +Prints a table of sample values from the upload and can make associate samples to internal names. + +$r is an Apache Request ref, +$records is an arrayref from &Apache::loncommon::upfile_record_sep, +$d is an array of 2 element arrays (internal name, displayed name) + +=cut + +###################################################### +###################################################### +sub csv_samples_select_table { + my ($r,$records,$d) = @_; + my %sone; my %stwo; my %sthree; + my $i=0; + # + $r->print(''. + &mt('Field').''.&mt('Samples').''); + %sone=&record_sep($$records[0]); + if (defined($$records[1])) {%stwo=&record_sep($$records[1]);} + if (defined($$records[2])) {%sthree=&record_sep($$records[2]);} + # + foreach (sort keys %sone) { + $r->print(''); + foreach (@$d) { + my ($value,$display,$defaultcol)=@{ $_ }; + $r->print(''. + $display.''); + } + $r->print(''); + if (defined($sone{$_})) { $r->print($sone{$_}."\n"); } + if (defined($stwo{$_})) { $r->print($stwo{$_}."\n"); } + if (defined($sthree{$_})) { $r->print($sthree{$_}."\n"); } + $r->print(''); + $i++; + } + $i--; + return($i); +} + +###################################################### +###################################################### + +=pod + +=item clean_excel_name($name) + +Returns a replacement for $name which does not contain any illegal characters. + +=cut + +###################################################### +###################################################### +sub clean_excel_name { + my ($name) = @_; + $name =~ s/[:\*\?\/\\]//g; + if (length($name) > 31) { + $name = substr($name,0,31); + } + return $name; +} + +=pod + +=item * check_if_partid_hidden($id,$symb,$udom,$uname) + +Returns either 1 or undef + +1 if the part is to be hidden, undef if it is to be shown + +Arguments are: + +$id the id of the part to be checked +$symb, optional the symb of the resource to check +$udom, optional the domain of the user to check for +$uname, optional the username of the user to check for + +=cut + +sub check_if_partid_hidden { + my ($id,$symb,$udom,$uname) = @_; + my $hiddenparts=&Apache::lonnet::EXT('resource.0.hiddenparts', + $symb,$udom,$uname); + my $truth=1; + #if the string starts with !, then the list is the list to show not hide + if ($hiddenparts=~s/^\s*!//) { $truth=undef; } + my @hiddenlist=split(/,/,$hiddenparts); + foreach my $checkid (@hiddenlist) { + if ($checkid =~ /^\s*\Q$id\E\s*$/) { return $truth; } + } + return !$truth; +} + + +############################################################ +############################################################ + +=pod + +=back + +=head1 cgi-bin script and graphing routines + +=over 4 + +=item get_cgi_id + +Inputs: none + +Returns an id which can be used to pass environment variables +to various cgi-bin scripts. These environment variables will +be removed from the users environment after a given time by +the routine &Apache::lonnet::transfer_profile_to_env. + +=cut + +############################################################ +############################################################ +my $uniq=0; +sub get_cgi_id { + $uniq=($uniq+1)%100000; + return (time.'_'.$uniq); +} + +############################################################ +############################################################ + +=pod + +=item DrawBarGraph + +Facilitates the plotting of data in a (stacked) bar graph. +Puts plot definition data into the users environment in order for +graph.png to plot it. Returns an tag for the plot. +The bars on the plot are labeled '1','2',...,'n'. + +Inputs: + +=over 4 + +=item $Title: string, the title of the plot + +=item $xlabel: string, text describing the X-axis of the plot + +=item $ylabel: string, text describing the Y-axis of the plot + +=item $Max: scalar, the maximum Y value to use in the plot +If $Max is < any data point, the graph will not be rendered. + +=item $colors: array ref holding the colors to be used for the data sets when +they are plotted. If undefined, default values will be used. + +=item $labels: array ref holding the labels to use on the x-axis for the bars. + +=item @Values: An array of array references. Each array reference holds data +to be plotted in a stacked bar chart. =back +Returns: + +An tag which references graph.png and the appropriate identifying +information for the plot. + =cut + +############################################################ +############################################################ +sub DrawBarGraph { + my ($Title,$xlabel,$ylabel,$Max,$colors,$labels,@Values)=@_; + # + if (! defined($colors)) { + $colors = ['#33ff00', + '#0033cc', '#990000', '#aaaa66', '#663399', '#ff9933', + '#66ccff', '#ff9999', '#cccc33', '#660000', '#33cc66', + ]; + } + my $extra_settings = {}; + if (ref($Values[-1]) eq 'HASH') { + $extra_settings = pop(@Values); + } + # + my $identifier = &get_cgi_id(); + my $id = 'cgi.'.$identifier; + if (! @Values || ref($Values[0]) ne 'ARRAY') { + return ''; + } + # + my @Labels; + if (defined($labels)) { + @Labels = @$labels; + } else { + for (my $i=0;$i<@{$Values[0]};$i++) { + push (@Labels,$i+1); + } + } + # + my $NumBars = scalar(@{$Values[0]}); + if ($NumBars < scalar(@Labels)) { $NumBars = scalar(@Labels); } + my %ValuesHash; + my $NumSets=1; + foreach my $array (@Values) { + next if (! ref($array)); + $ValuesHash{$id.'.data.'.$NumSets++} = + join(',',@$array); + } + # + my ($height,$width,$xskip,$bar_width) = (200,120,1,15); + if ($NumBars < 3) { + $width = 120+$NumBars*32; + $xskip = 1; + $bar_width = 30; + } elsif ($NumBars < 5) { + $width = 120+$NumBars*20; + $xskip = 1; + $bar_width = 20; + } elsif ($NumBars < 10) { + $width = 120+$NumBars*15; + $xskip = 1; + $bar_width = 15; + } elsif ($NumBars <= 25) { + $width = 120+$NumBars*11; + $xskip = 5; + $bar_width = 8; + } elsif ($NumBars <= 50) { + $width = 120+$NumBars*8; + $xskip = 5; + $bar_width = 4; + } else { + $width = 120+$NumBars*8; + $xskip = 5; + $bar_width = 4; + } + # + $Max = 1 if ($Max < 1); + if ( int($Max) < $Max ) { + $Max++; + $Max = int($Max); + } + $Title = '' if (! defined($Title)); + $xlabel = '' if (! defined($xlabel)); + $ylabel = '' if (! defined($ylabel)); + $ValuesHash{$id.'.title'} = &Apache::lonnet::escape($Title); + $ValuesHash{$id.'.xlabel'} = &Apache::lonnet::escape($xlabel); + $ValuesHash{$id.'.ylabel'} = &Apache::lonnet::escape($ylabel); + $ValuesHash{$id.'.y_max_value'} = $Max; + $ValuesHash{$id.'.NumBars'} = $NumBars; + $ValuesHash{$id.'.NumSets'} = $NumSets; + $ValuesHash{$id.'.PlotType'} = 'bar'; + $ValuesHash{$id.'.Colors'} = join(',',@{$colors}); + $ValuesHash{$id.'.height'} = $height; + $ValuesHash{$id.'.width'} = $width; + $ValuesHash{$id.'.xskip'} = $xskip; + $ValuesHash{$id.'.bar_width'} = $bar_width; + $ValuesHash{$id.'.labels'} = join(',',@Labels); + # + # Deal with other parameters + while (my ($key,$value) = each(%$extra_settings)) { + $ValuesHash{$id.'.'.$key} = $value; + } + # + &Apache::lonnet::appenv(%ValuesHash); + return ''; +} + +############################################################ +############################################################ + +=pod + +=item DrawXYGraph + +Facilitates the plotting of data in an XY graph. +Puts plot definition data into the users environment in order for +graph.png to plot it. Returns an tag for the plot. + +Inputs: + +=over 4 + +=item $Title: string, the title of the plot + +=item $xlabel: string, text describing the X-axis of the plot + +=item $ylabel: string, text describing the Y-axis of the plot + +=item $Max: scalar, the maximum Y value to use in the plot +If $Max is < any data point, the graph will not be rendered. + +=item $colors: Array ref containing the hex color codes for the data to be +plotted in. If undefined, default values will be used. + +=item $Xlabels: Array ref containing the labels to be used for the X-axis. + +=item $Ydata: Array ref containing Array refs. +Each of the contained arrays will be plotted as a separate curve. + +=item %Values: hash indicating or overriding any default values which are +passed to graph.png. +Possible values are: width, xskip, x_ticks, x_tick_offset, among others. + +=back + +Returns: + +An tag which references graph.png and the appropriate identifying +information for the plot. + +=cut + +############################################################ +############################################################ +sub DrawXYGraph { + my ($Title,$xlabel,$ylabel,$Max,$colors,$Xlabels,$Ydata,%Values)=@_; + # + # Create the identifier for the graph + my $identifier = &get_cgi_id(); + my $id = 'cgi.'.$identifier; + # + $Title = '' if (! defined($Title)); + $xlabel = '' if (! defined($xlabel)); + $ylabel = '' if (! defined($ylabel)); + my %ValuesHash = + ( + $id.'.title' => &Apache::lonnet::escape($Title), + $id.'.xlabel' => &Apache::lonnet::escape($xlabel), + $id.'.ylabel' => &Apache::lonnet::escape($ylabel), + $id.'.y_max_value'=> $Max, + $id.'.labels' => join(',',@$Xlabels), + $id.'.PlotType' => 'XY', + ); + # + if (defined($colors) && ref($colors) eq 'ARRAY') { + $ValuesHash{$id.'.Colors'} = join(',',@{$colors}); + } + # + if (! ref($Ydata) || ref($Ydata) ne 'ARRAY') { + return ''; + } + my $NumSets=1; + foreach my $array (@{$Ydata}){ + next if (! ref($array)); + $ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array); + } + $ValuesHash{$id.'.NumSets'} = $NumSets-1; + # + # Deal with other parameters + while (my ($key,$value) = each(%Values)) { + $ValuesHash{$id.'.'.$key} = $value; + } + # + &Apache::lonnet::appenv(%ValuesHash); + return ''; +} + +############################################################ +############################################################ + +=pod + +=item DrawXYYGraph + +Facilitates the plotting of data in an XY graph with two Y axes. +Puts plot definition data into the users environment in order for +graph.png to plot it. Returns an tag for the plot. + +Inputs: + +=over 4 + +=item $Title: string, the title of the plot + +=item $xlabel: string, text describing the X-axis of the plot + +=item $ylabel: string, text describing the Y-axis of the plot + +=item $colors: Array ref containing the hex color codes for the data to be +plotted in. If undefined, default values will be used. + +=item $Xlabels: Array ref containing the labels to be used for the X-axis. + +=item $Ydata1: The first data set + +=item $Min1: The minimum value of the left Y-axis + +=item $Max1: The maximum value of the left Y-axis + +=item $Ydata2: The second data set + +=item $Min2: The minimum value of the right Y-axis + +=item $Max2: The maximum value of the left Y-axis + +=item %Values: hash indicating or overriding any default values which are +passed to graph.png. +Possible values are: width, xskip, x_ticks, x_tick_offset, among others. + +=back + +Returns: + +An tag which references graph.png and the appropriate identifying +information for the plot. + +=cut + +############################################################ +############################################################ +sub DrawXYYGraph { + my ($Title,$xlabel,$ylabel,$colors,$Xlabels,$Ydata1,$Min1,$Max1, + $Ydata2,$Min2,$Max2,%Values)=@_; + # + # Create the identifier for the graph + my $identifier = &get_cgi_id(); + my $id = 'cgi.'.$identifier; + # + $Title = '' if (! defined($Title)); + $xlabel = '' if (! defined($xlabel)); + $ylabel = '' if (! defined($ylabel)); + my %ValuesHash = + ( + $id.'.title' => &Apache::lonnet::escape($Title), + $id.'.xlabel' => &Apache::lonnet::escape($xlabel), + $id.'.ylabel' => &Apache::lonnet::escape($ylabel), + $id.'.labels' => join(',',@$Xlabels), + $id.'.PlotType' => 'XY', + $id.'.NumSets' => 2, + $id.'.two_axes' => 1, + $id.'.y1_max_value' => $Max1, + $id.'.y1_min_value' => $Min1, + $id.'.y2_max_value' => $Max2, + $id.'.y2_min_value' => $Min2, + ); + # + if (defined($colors) && ref($colors) eq 'ARRAY') { + $ValuesHash{$id.'.Colors'} = join(',',@{$colors}); + } + # + if (! ref($Ydata1) || ref($Ydata1) ne 'ARRAY' || + ! ref($Ydata2) || ref($Ydata2) ne 'ARRAY'){ + return ''; + } + my $NumSets=1; + foreach my $array ($Ydata1,$Ydata2){ + next if (! ref($array)); + $ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array); + } + # + # Deal with other parameters + while (my ($key,$value) = each(%Values)) { + $ValuesHash{$id.'.'.$key} = $value; + } + # + &Apache::lonnet::appenv(%ValuesHash); + return ''; +} + +############################################################ +############################################################ + +=pod + +=back + +=head1 Statistics helper routines? + +Bad place for them but what the hell. + +=over 4 + +=item &chartlink + +Returns a link to the chart for a specific student. + +Inputs: + +=over 4 + +=item $linktext: The text of the link + +=item $sname: The students username + +=item $sdomain: The students domain + +=back + +=back + +=cut + +############################################################ +############################################################ +sub chartlink { + my ($linktext, $sname, $sdomain) = @_; + my $link = ''.$linktext.''; +} + +####################################################### +####################################################### + +=pod + +=head1 Course Environment Routines + +=over 4 + +=item &restore_course_settings + +=item &store_course_settings + +Restores/Store indicated form parameters from the course environment. +Will not overwrite existing values of the form parameters. + +Inputs: +a scalar describing the data (e.g. 'chart', 'problem_analysis') + +a hash ref describing the data to be stored. For example: + +%Save_Parameters = ('Status' => 'scalar', + 'chartoutputmode' => 'scalar', + 'chartoutputdata' => 'scalar', + 'Section' => 'array', + 'StudentData' => 'array', + 'Maps' => 'array'); + +Returns: both routines return nothing + +=cut + +####################################################### +####################################################### +sub store_course_settings { + # save to the environment + # appenv the same items, just to be safe + my $courseid = $ENV{'request.course.id'}; + my $coursedom = $ENV{'course.'.$courseid.'.domain'}; + my ($prefix,$Settings) = @_; + my %SaveHash; + my %AppHash; + while (my ($setting,$type) = each(%$Settings)) { + my $basename = 'internal.'.$prefix.'.'.$setting; + my $envname = 'course.'.$courseid.'.'.$basename; + if (exists($ENV{'form.'.$setting})) { + # Save this value away + if ($type eq 'scalar' && + (! exists($ENV{$envname}) || + $ENV{$envname} ne $ENV{'form.'.$setting})) { + $SaveHash{$basename} = $ENV{'form.'.$setting}; + $AppHash{$envname} = $ENV{'form.'.$setting}; + } elsif ($type eq 'array') { + my $stored_form; + if (ref($ENV{'form.'.$setting})) { + $stored_form = join(',', + map { + &Apache::lonnet::escape($_); + } sort(@{$ENV{'form.'.$setting}})); + } else { + $stored_form = + &Apache::lonnet::escape($ENV{'form.'.$setting}); + } + # Determine if the array contents are the same. + if ($stored_form ne $ENV{$envname}) { + $SaveHash{$basename} = $stored_form; + $AppHash{$envname} = $stored_form; + } + } + } + } + my $put_result = &Apache::lonnet::put('environment',\%SaveHash, + $coursedom, + $ENV{'course.'.$courseid.'.num'}); + if ($put_result !~ /^(ok|delayed)/) { + &Apache::lonnet::logthis('unable to save form parameters, '. + 'got error:'.$put_result); + } + # Make sure these settings stick around in this session, too + &Apache::lonnet::appenv(%AppHash); + return; +} + +sub restore_course_settings { + my $courseid = $ENV{'request.course.id'}; + my ($prefix,$Settings) = @_; + while (my ($setting,$type) = each(%$Settings)) { + next if (exists($ENV{'form.'.$setting})); + my $envname = 'course.'.$courseid.'.internal.'.$prefix. + '.'.$setting; + if (exists($ENV{$envname})) { + if ($type eq 'scalar') { + $ENV{'form.'.$setting} = $ENV{$envname}; + } elsif ($type eq 'array') { + $ENV{'form.'.$setting} = [ + map { + &Apache::lonnet::unescape($_); + } split(',',$ENV{$envname}) + ]; + } + } + } +} + +############################################################ +############################################################ + +sub propath { + my ($udom,$uname)=@_; + $udom=~s/\W//g; + $uname=~s/\W//g; + my $subdir=$uname.'__'; + $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; + my $proname="$Apache::lonnet::perlvar{'lonUsersDir'}/$udom/$subdir/$uname"; + return $proname; +} + +sub icon { + my ($file)=@_; + my $curfext = (split(/\./,$file))[-1]; + my $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/unknown.gif'; + my $embstyle = &Apache::loncommon::fileembstyle($curfext); + if (!(!defined($embstyle) || $embstyle eq 'unk' || $embstyle eq 'hdn')) { + if (-e $Apache::lonnet::perlvar{'lonDocRoot'}.'/'. + $Apache::lonnet::perlvar{'lonIconsURL'}.'/'. + $curfext.".gif") { + $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/'. + $curfext.".gif"; + } + } + return $iconname; +} + +sub lonhttpdurl { + my ($url)=@_; + my $lonhttpd_port=$Apache::lonnet::perlvar{'lonhttpdPort'}; + if (!defined($lonhttpd_port)) { $lonhttpd_port='8080'; } + return 'http://'.$ENV{'SERVER_NAME'}.':'.$lonhttpd_port.$url; +} + +sub connection_aborted { + my ($r)=@_; + $r->print(" ");$r->rflush(); + my $c = $r->connection; + return $c->aborted(); +} + +# Escapes strings that may have embedded 's that will be put into +# strings as 'strings'. +sub escape_single { + my ($input) = @_; + $input =~ s/\\/\\\\/g; # Escape the \'s..(must be first)> + $input =~ s/\'/\\\'/g; # Esacpe the 's.... + return $input; +} + +# Same as escape_single, but escape's "'s This +# can be used for "strings" +sub escape_double { + my ($input) = @_; + $input =~ s/\\/\\\\/g; # Escape the /'s..(must be first)> + $input =~ s/\"/\\\"/g; # Esacpe the "s.... + return $input; +} + +# Escapes the last element of a full URL. +sub escape_url { + my ($url) = @_; + my @urlslices = split(/\//, $url); + my $lastitem = &Apache::lonnet::escape(pop(@urlslices)); + return join('/',@urlslices).'/'.$lastitem; +} +=pod + +=back + +=cut + +1; +__END__; +