--- loncom/interface/loncommon.pm 2002/04/23 21:00:01 1.34 +++ loncom/interface/loncommon.pm 2003/03/20 19:20:31 1.89 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # a pile of common routines # -# $Id: loncommon.pm,v 1.34 2002/04/23 21:00:01 matthew Exp $ +# $Id: loncommon.pm,v 1.89 2003/03/20 19:20:31 www Exp $ # # Copyright Michigan State University Board of Trustees # @@ -27,46 +27,121 @@ # # 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 +# 6/24,7/2 H. K. Ng # 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 + +Referenced by other mod_perl Apache modules. + +Invocation: + &Apache::loncommon::SUBROUTINENAME(ARGUMENTS); + +=head1 INTRODUCTION + +Common collection of used subroutines. This collection helps remove +redundancy from other modules and increase efficiency of memory usage. + +Current things done: + + Makes a table out of the previous homework attempts + Inputs result_from_symbread, user, domain, course_id + Reads in non-network-related .tab files + +This is part of the LearningOnline Network with CAPA project +described at http://www.lon-capa.org. + +=head2 General Subroutines + +=over 4 + +=cut + +# End of POD header package Apache::loncommon; use strict; use Apache::lonnet(); -use POSIX qw(strftime); +use GDBM_File; +use POSIX qw(strftime mktime); use Apache::Constants qw(:common); use Apache::lonmsg(); - +use Apache::lonmenu(); my $readit; +=pod + +=item Global Variables + +=over 4 + +=cut # ----------------------------------------------- Filetypes/Languages/Copyright my %language; my %cprtag; my %fe; my %fd; -my %fc; +my %category_extensions; + +# ---------------------------------------------- Designs + +my %designhash; + +# ---------------------------------------------- Thesaurus variables + +=pod + +=item %Keywords + +A hash used by &keyword to determine if a word is considered a keyword. + +=item $thesaurus_db_file + +Scalar containing the full path to the thesaurus database. + +=cut + +my %Keywords; +my $thesaurus_db_file; + -# -------------------------------------------------------------- Thesaurus data -my @therelated; -my @theword; -my @thecount; -my %theindex; -my $thetotalcount; -my $thefuzzy=2; -my $thethreshold=0.1/$thefuzzy; -my $theavecount; +=pod + +=back + +=cut # ----------------------------------------------------------------------- BEGIN -BEGIN { +=pod + +=item BEGIN() + +Initialize values from language.tab, copyright.tab, filetypes.tab, +thesaurus.tab, and filecategories.tab. + +=cut + +# ----------------------------------------------------------------------- BEGIN + +BEGIN { + # Variable initialization + $thesaurus_db_file = $Apache::lonnet::perlvar{'lonTabDir'}."/thesaurus.db"; + # unless ($readit) { # ------------------------------------------------------------------- languages { @@ -94,6 +169,30 @@ BEGIN { } } } + +# -------------------------------------------------------------- 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($designdir.'/'.$filename); + if ($fh) { + while (<$fh>) { + next if /^\#/; + chomp; + my ($key,$val)=(split(/\=/,$_)); + if ($val) { $designhash{$domain.'.'.$key}=$val; } + } + } + } + + } + closedir(DIR); + + # ------------------------------------------------------------- file categories { my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}. @@ -102,8 +201,8 @@ BEGIN { while (<$fh>) { next if /^\#/; chomp; - my ($key,$val)=(split(/\s+/,$_,2)); - push @{$fc{$key}},$val; + my ($extension,$category)=(split(/\s+/,$_,2)); + push @{$category_extensions{lc($category)}},$extension; } } } @@ -123,32 +222,371 @@ BEGIN { } } } -# -------------------------------------------------------------- Thesaurus data - { - my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}. - '/thesaurus.dat'); - if ($fh) { - while (<$fh>) { - my ($tword,$tindex,$tcount,$trelated)=split(/\@/,$_); - $theindex{$tword}=$tindex; - $theword[$tindex]=$tword; - $thecount[$tindex]=$tcount; - $thetotalcount+=$tcount; - $therelated[$tindex]=$trelated; - } - } - $theavecount=$thetotalcount/$#thecount; - } &Apache::lonnet::logthis( - "INFO: Read file types and thesaurus"); + "INFO: Read file types"); $readit=1; -} + } # end of unless($readit) } # ============================================================= END BEGIN BLOCK ############################################################### +## HTML and Javascript Helper Functions ## +############################################################### + +=pod + +=item browser_and_searcher_javascript + +Returns scalar containing javascript to open a browser window +or a searcher window. Also creates + +=over 4 + +=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 seperated list. + +Specifying 'omit' will restrict the browser to NOT displaying files +with the given extension. Can be a comma seperated 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. + +=back + +=cut + +############################################################### +sub browser_and_searcher_javascript { + return < + var stdeditbrowser; + function openstdbrowser(formname,uname,udom) { + var url = '/adm/pickstudent?'; + var filter; + eval('filter=document.'+formname+'.'+uname+'.value;'); + if (filter != null) { + if (filter != '') { + url += 'filter='+filter+'&'; + } + } + url += 'form=' + formname + '&unameelement='+uname+ + '&udomelement='+udom; + var title = 'Student Browser'; + var options = 'scrollbars=1,resizable=1,menubar=0'; + options += ',width=700,height=600'; + stdeditbrowser = open(url,title,options,'1'); + stdeditbrowser.focus(); + } + +ENDSTDBRW +} + +sub selectstudent_link { + my ($form,$unameele,$udomele)=@_; + unless ($ENV{'request.course.id'}) { return ''; } + unless (&Apache::lonnet::allowed('srm',$ENV{'request.course.id'})) { + return ''; + } + return "Select"; +} + +############################################################### + +=pod + +=item linked_select_forms(...) + +linked_select_forms returns a string containing a block +and html for two tags + +=item $firstdefault, the default value for the first menu + +=item $firstselectname, the name of the first 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"; + my $seconddefault = $hashref->{$firstdefault}->{'default'}; + foreach my $value (sort(keys(%select2))) { + $result.=" \n"; + } + $selectform.=""; + return $selectform; +} + + +#------------------------------------------- + +=pod + +=item select_dom_form($defdom,$name) + +Returns a string containing a form input. See loncreateuser.pm for an example. + +=cut + +#------------------------------------------- sub home_server_option_list { my $domain = shift; - my %servers = &get_home_servers($domain); + my %servers = &get_library_servers($domain); my $result = ''; foreach (sort keys(%servers)) { $result.= @@ -198,6 +700,75 @@ sub home_server_option_list { ############################################################### ############################################################### +############################################################### + +=pod + +=item &decode_user_agent() + +Inputs: $r + +Outputs: + +=over 4 + +=item $httpbrowser + +=item $clientbrowser + +=item $clientversion + +=item $clientmathml + +=item $clientunicode + +=item $clientos + +=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 ## ############################################################### ## @@ -205,14 +776,61 @@ sub home_server_option_list { ## hash, and have reasonable default values. ## ## formname = the name given in the
tag. +#------------------------------------------- + +=pod + +=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 + +=cut + +#------------------------------------------- sub authform_header{ my %in = ( formname => 'cu', - kerb_def_dom => 'MSU.EDU', + 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 = ""; + } + $result.=<<"END"; var current = new Object(); current.radiovalue = 'nochange'; @@ -246,12 +864,7 @@ function changed_radio(choice,currentfor function changed_text(choice,currentform) { var choicearg = choice + 'arg'; if (currentform.elements[choicearg].value !='') { - switch (choice) { - case 'krb': currentform.elements[choicearg].value = - currentform.elements[choicearg].value.toUpperCase(); - break; - default: - } + $Javascript_toUpperCase // clear old field if ((current.argfield != choicearg) && (current.argfield != null)) { currentform.elements[current.argfield].value = ''; @@ -297,7 +910,7 @@ sub authform_nochange{ my $result=''; $result.=<<"END"; + onclick="javascript:changed_radio('nochange',$in{'formname'});" /> Do not change login data END return $result; @@ -307,16 +920,26 @@ sub authform_kerberos{ my %in = ( formname => 'document.cu', kerb_def_dom => 'MSU.EDU', + kerb_def_auth => 'krb4', @_, ); my $result=''; + my $check4; + my $check5; + if ($in{'kerb_def_auth'} eq 'krb5') { + $check5 = " checked=\"on\""; + } else { + $check4 = " checked=\"on\""; + } $result.=<<"END"; + onchange="javascript:changed_radio('krb',$in{'formname'});" /> Kerberos authenticated with domain - + +Version 4 +Version 5 END return $result; } @@ -331,10 +954,10 @@ sub authform_internal{ $result.=<<"END"; + onclick="javascript:changed_radio('int',$args{'formname'});" /> Internally authenticated (with initial password + onchange="javascript:changed_text('int',$args{'formname'});" />) END return $result; } @@ -349,10 +972,10 @@ sub authform_local{ $result.=<<"END"; + onclick="javascript:changed_radio('loc',$in{'formname'});" /> Local Authentication with argument + onchange="javascript:changed_text('loc',$in{'formname'});" /> END return $result; } @@ -367,10 +990,10 @@ sub authform_filesystem{ $result.=<<"END"; + onclick="javascript:changed_radio('fsys',$in{'formname'});" /> Filesystem authenticated (with initial password + onchange="javascript:changed_text('fsys',$in{'formname'});">) END return $result; } @@ -379,64 +1002,305 @@ END ## End Authentication changing form generation functions ## ############################################################### +############################################################### +## Get Authentication Defaults for Domain ## +############################################################### +## +## Returns default authentication type and an associated argument +## as listed in file domain.tab +## +#------------------------------------------- + +=pod + +=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 (''). + +=over 4 + +=item get_auth_defaults + +=back + +=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); + +=over 4 + +=item get_kerberos_defaults + +=back + +=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); +} +############################################################### +## End Get Kerberos Defaults for Domain ## +############################################################### + +############################################################### +## Thesaurus Functions ## +############################################################### + +=pod +=item initialize_keywords -# ---------------------------------------------------------- Is this a keyword? +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 { - 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; - } - } - } - } - } - } - } + 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 arguement 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]; } } - return (); + untie %thesaurus_db; + return @Words; +} + +############################################################### +## End Thesaurus Functions ## +############################################################### + +# -------------------------------------------------------------- Plaintext name +=pod + +=item plainname($uname,$udom) + +Gets a users name and returns it as a string in +"first middle last generation" +form + +=cut + +############################################################### +sub plainname { + my ($uname,$udom)=@_; + my %names=&Apache::lonnet::get('environment', + ['firstname','middlename','lastname','generation'], + $udom,$uname); + my $name=$names{'firstname'}.' '.$names{'middlename'}.' '. + $names{'lastname'}.' '.$names{'generation'}; + $name=~s/\s+$//; + $name=~s/\s+/ /g; + 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=&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)=@_; + my %names= + &Apache::lonnet::get('environment',['screenname'],$udom,$uname); + return $names{'screenname'}; +} + +# ------------------------------------------------------------- Message Wrapper + +sub messagewrapper { + my ($link,$un,$do)=@_; + return +"$link"; +} +# --------------------------------------------------------------- Notes Wrapper + +sub noteswrapper { + my ($link,$un,$do)=@_; + return +"$link"; +} +# ------------------------------------------------------------- Aboutme Wrapper + +sub aboutmewrapper { + my ($link,$username,$domain)=@_; + return "$link"; +} + +# ------------------------------------------------------------ Syllabus Wrapper + + +sub syllabuswrapper { + my ($link,$un,$do,$tf)=@_; + if ($tf) { $link=''.$link.''; } + return "$link"; } # ---------------------------------------------------------------- Language IDs @@ -461,12 +1325,12 @@ sub copyrightdescription { # ------------------------------------------------------------- File Categories sub filecategories { - return sort(keys(%fc)); + return sort(keys(%category_extensions)); } # -------------------------------------- File Types within a specified category sub filecategorytypes { - return @{$fc{lc(shift(@_))}}; + return @{$category_extensions{lc($_[0])}}; } # ------------------------------------------------------------------ File Types @@ -490,9 +1354,22 @@ sub filedescriptionex { return '.'.$ex.' '.$fd{lc($ex)}; } +# ---- Retrieve attempts by students +# input +# $symb - problem including path +# $username,$domain - that of the student +# $course - course name +# $getattempt - leave blank if want all attempts, else put something. +# $regexp - regular expression. If string matches regexp send to +# $gradesub - routine that process the string if it matches regexp +# +# output +# formatted as a table all the attempts, if any. +# 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); @@ -504,30 +1381,37 @@ sub get_previous_attempt { $lasthash{$_}=$returnhash{$version.':'.$_}; } } - $prevattempts=''; + $prevattempts='
History
'; + $prevattempts.=''; foreach (sort(keys %lasthash)) { my ($ign,@parts) = split(/\./,$_); - if (@parts) { + if ($#parts > 0) { my $data=$parts[-1]; pop(@parts); - $prevattempts.=''; + $prevattempts.=''; } else { - $prevattempts.=''; - } - } - for ($version=1;$version<=$returnhash{'version'};$version++) { - $prevattempts.=''; - foreach (sort(keys %lasthash)) { - my $value; - if ($_ =~ /timestamp/) { - $value=scalar(localtime($returnhash{$version.':'.$_})); + if ($#parts == 0) { + $prevattempts.=''; } else { - $value=$returnhash{$version.':'.$_}; + $prevattempts.=''; } - $prevattempts.=''; - } + } + } + if ($getattempt eq '') { + for ($version=1;$version<=$returnhash{'version'};$version++) { + $prevattempts.=''; + foreach (sort(keys %lasthash)) { + my $value; + if ($_ =~ /timestamp/) { + $value=scalar(localtime($returnhash{$version.':'.$_})); + } else { + $value=$returnhash{$version.':'.$_}; + } + $prevattempts.=''; + } + } } - $prevattempts.=''; + $prevattempts.=''; foreach (sort(keys %lasthash)) { my $value; if ($_ =~ /timestamp/) { @@ -535,9 +1419,10 @@ sub get_previous_attempt { } else { $value=$lasthash{$_}; } - $prevattempts.=''; + if ($_ =~/$regexp$/ && (defined &$gradesub)) {$value = &$gradesub($value)} + $prevattempts.=''; } - $prevattempts.='
HistoryPart '.join('.',@parts).'
'.$data.'		Part '.join('.',@parts).'
'.$data.' 		'.$ign.'
Attempt '.$version.''.$parts[0].''.$ign.''.$value.'
Transaction '.$version.''.$value.' 
Current
Current'.$value.''.$value.' 
'; + $prevattempts.='
'; } else { $prevattempts='Nothing submitted - no attempts.'; } @@ -547,7 +1432,7 @@ sub get_previous_attempt { } sub get_student_view { - my ($symb,$username,$domain,$courseid) = @_; + my ($symb,$username,$domain,$courseid,$target) = @_; my ($map,$id,$feedurl) = split(/___/,$symb); my (%old,%moreenv); my @elements=('symb','courseid','domain','username'); @@ -555,6 +1440,7 @@ sub get_student_view { $old{$element}=$ENV{'form.grade_'.$element}; $moreenv{'form.grade_'.$element}=eval '$'.$element #' } + if ($target eq 'tex') {$moreenv{'form.grade_target'} = 'tex';} &Apache::lonnet::appenv(%moreenv); my $userview=&Apache::lonnet::ssi('/res/'.$feedurl); &Apache::lonnet::delenv('form.grade_'); @@ -587,16 +1473,251 @@ sub get_student_answers { foreach my $element (@elements) { $ENV{'form.grade_'.$element}=$old{$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; return $userview; } +############################################### + + +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,$th{'dlsav'})); +} + + +######################################### +# +# Retro-fixing of un-backward-compatible time format + +sub unsqltime { + my $timestamp=shift; + if ($timestamp=~/^(\d+)\-(\d+)\-(\d+)\s+(\d+)\:(\d+)\:(\d+)$/) { + $timestamp=&maketime( + 'year'=>$1,'month'=>$2,'day'=>$3, + 'hours'=>$4,'minutes'=>$5,'seconds'=>$6); + } + return $timestamp; +} + +######################################### + +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 + +=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 $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'}; + if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; } + 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)=@_; + $domain=&determinedomain($domain); + if ($designhash{$domain.'.'.$which}) { + return $designhash{$domain.'.'.$which}; + } else { + return $designhash{'default.'.$which}; + } +} + +############################################### +############################################### + +=pod + +=item &bodytag() + +Returns a uniform header for LON-CAPA web pages. + +Inputs: + + $title, A title to be displayed on the page. + $function, the current role (can be undef). + $addentries, extra parameters for the tag. + $bodyonly, if defined, only return the tag. + $domain, if defined, force a given domain. + $forcereg, if page should register as content page (relevant for + text interface only) + +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)=@_; + unless ($function) { + $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'; + } + } + 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); + + # 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); +# Output + my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'}; + if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; } + my $bodytag = < +END + if ($bodyonly) { + return $bodytag; + } elsif ($ENV{'browser.interface'} eq 'textual') { + return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web', + $forcereg). + '

LON-CAPA: '.$title.'

'; + } else { + return(< + + +$messages + + + + $title + + + $ENV{'environment.firstname'} + $ENV{'environment.middlename'} + $ENV{'environment.lastname'} + $ENV{'environment.generation'} +   + + + +$role  + + +$realm  +
+ENDBODY + } +} +############################################### + sub get_unprocessed_cgi { my ($query,$possible_names)= @_; # $Apache::lonxml::debug=1; @@ -647,11 +1768,21 @@ sub add_to_env { } } -#---CSV Upload/Handling functions +=pod + +=back + +=head2 CSV Upload/Handling functions + +=over 4 + +=item upfile_store($r) -# ========================================================= Store uploaded file -# needs $ENV{'form.upfile'} -# return $datatoken to be put into hidden field +Store uploaded file, $r should be the HTTP Request object, +needs $ENV{'form.upfile'} +returns $datatoken to be put into hidden field + +=cut sub upfile_store { my $r=shift; @@ -670,9 +1801,15 @@ sub upfile_store { return $datatoken; } -# ================================================= Load uploaded file from tmp -# needs $ENV{'form.datatoken'} -# sets $ENV{'form.upfile'} to the contents of the file +=pod + +=item load_tmp_file($r) + +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 + +=cut sub load_tmp_file { my $r=shift; @@ -687,10 +1824,15 @@ sub load_tmp_file { $ENV{'form.upfile'}=join('',@studentdata); } -# ========================================= Separate uploaded file into records -# returns array of records -# needs $ENV{'form.upfile'} -# needs $ENV{'form.upfiletype'} +=pod + +=item upfile_record_sep() + +Separate uploaded file into records +returns array of records, +needs $ENV{'form.upfile'} and $ENV{'form.upfiletype'} + +=cut sub upfile_record_sep { if ($ENV{'form.upfiletype'} eq 'xml') { @@ -699,9 +1841,14 @@ sub upfile_record_sep { } } -# =============================================== Separate a record into fields -# needs $ENV{'form.upfiletype'} -# takes $record as arg +=pod + +=item record_sep($record) + +Separate a record into fields $record should be an item from the upfile_record_sep(), needs $ENV{'form.upfiletype'} + +=cut + sub record_sep { my $record=shift; my %components=(); @@ -746,10 +1893,17 @@ sub record_sep { return %components; } -# =============================== HTML code to select file and specify its type +=pod + +=item upfile_select_html() + +return HTML code to select file and specify its type + +=cut + sub upfile_select_html { return (<<'ENDUPFORM'); - +
Type: