--- loncom/lonnet/perl/lonnet.pm 2003/08/26 04:56:30 1.406
+++ loncom/lonnet/perl/lonnet.pm 2003/09/19 16:29:09 1.416
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.406 2003/08/26 04:56:30 albertel Exp $
+# $Id: lonnet.pm,v 1.416 2003/09/19 16:29:09 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -76,7 +76,7 @@ qw(%perlvar %hostname %homecache %badSer
%libserv %pr %prp %metacache %packagetab %titlecache
%courselogs %accesshash %userrolehash $processmarker $dumpcount
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache
- %domaindescription %domain_auth_def %domain_auth_arg_def
+ %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def
%domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir);
use IO::Socket;
@@ -85,6 +85,7 @@ use Apache::Constants qw(:common :http);
use HTML::LCParser;
use Fcntl qw(:flock);
use Apache::loncoursedata;
+use Apache::lonlocal;
my $readit;
@@ -246,9 +247,13 @@ sub critical {
return $answer;
}
+#
# -------------- Remove all key from the env that start witha lowercase letter
-# (Which is alweways a lon-capa value)
+# (Which is always a lon-capa value)
+
sub cleanenv {
+# unless (defined(&Apache::exists_config_define("MODPERL2"))) { return; }
+# unless (&Apache::exists_config_define("MODPERL2")) { return; }
foreach my $key (keys(%ENV)) {
if ($key =~ /^[a-z]/) {
delete($ENV{$key});
@@ -436,15 +441,27 @@ sub spareserver {
my $lowestserver=$loadpercent > $userloadpercent?
$loadpercent : $userloadpercent;
foreach $tryserver (keys %spareid) {
- my $loadans=reply('load',$tryserver);
- my $userloadans=reply('userload',$tryserver);
- if ($userloadans !~ /\d/) { $userloadans=0; }
- my $answer=$loadans > $userloadans?
- $loadans : $userloadans;
- if (($answer =~ /\d/) && ($answer<$lowestserver)) {
- $spareserver="http://$hostname{$tryserver}";
- $lowestserver=$answer;
- }
+ my $loadans=reply('load',$tryserver);
+ my $userloadans=reply('userload',$tryserver);
+ if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
+ next; #didn't get a number from the server
+ }
+ my $answer;
+ if ($loadans =~ /\d/) {
+ if ($userloadans =~ /\d/) {
+ #both are numbers, pick the bigger one
+ $answer=$loadans > $userloadans?
+ $loadans : $userloadans;
+ } else {
+ $answer = $loadans;
+ }
+ } else {
+ $answer = $userloadans;
+ }
+ if (($answer =~ /\d/) && ($answer<$lowestserver)) {
+ $spareserver="http://$hostname{$tryserver}";
+ $lowestserver=$answer;
+ }
}
return $spareserver;
}
@@ -831,8 +848,38 @@ sub getsection {
return '-1';
}
+sub devalidate_cache {
+ my ($cache,$id) = @_;
+ delete $courseresdatacache{$id.'.time'};
+ delete $courseresdatacache{$id};
+}
+
+sub is_cached {
+ my ($cache,$id,$time) = @_;
+ if (!exists($$cache{$id.'.time'})) {
+ return undef;
+ } else {
+ if (time-$$cache{$id.'.time'}>300) {
+ &devaidate_cache($cache,$id);
+ return undef;
+ }
+ }
+ return $$cache{$id};
+}
+
+sub do_cache {
+ my ($cache,$id,$value) = @_;
+ $$cache{$id.'.time'}=time;
+ # do_cache implictly return the set value
+ $$cache{$id}=$value;
+}
+
sub usection {
my ($udom,$unam,$courseid)=@_;
+ my $hashid="$udom:$unam:$courseid";
+
+ my $result;
+ if ($result=&is_cached(\%usectioncache,$hashid,300)) { return $result; }
$courseid=~s/\_/\//g;
$courseid=~s/^(\w)/\/$1/;
foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',
@@ -851,10 +898,12 @@ sub usection {
if ($end) {
if ($now>$end) { $notactive=1; }
}
- unless ($notactive) { return $section; }
+ unless ($notactive) {
+ return &do_cache(\%usectioncache,$hashid,$section);
+ }
}
}
- return '-1';
+ return &do_cache(\%usectioncache,$hashid,'-1');
}
# ------------------------------------- Read an entry from a user's environment
@@ -1228,7 +1277,7 @@ sub courseacclog {
my $fnsymb=shift;
unless ($ENV{'request.course.id'}) { return ''; }
my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'};
- if ($fnsymb=~/(problem|exam|quiz|assess|survey|form)$/) {
+ if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|page)$/) {
$what.=':POST';
foreach (keys %ENV) {
if ($_=~/^form\.(.*)/) {
@@ -2136,6 +2185,21 @@ sub dump {
return %returnhash;
}
+# -------------------------------------------------------------- keys interface
+
+sub getkeys {
+ my ($namespace,$udomain,$uname)=@_;
+ if (!$udomain) { $udomain=$ENV{'user.domain'}; }
+ if (!$uname) { $uname=$ENV{'user.name'}; }
+ my $uhome=&homeserver($uname,$udomain);
+ my $rep=reply("keys:$udomain:$uname:$namespace",$uhome);
+ my @keyarray=();
+ foreach (split(/\&/,$rep)) {
+ push (@keyarray,&unescape($_));
+ }
+ return @keyarray;
+}
+
# --------------------------------------------------------------- currentdump
sub currentdump {
my ($courseid,$sdom,$sname)=@_;
@@ -2575,7 +2639,10 @@ sub is_on_map {
if ($match) {
return (1,$1);
} else {
- return (0,0);
+ my ($name,$ext)=($filename=~/^(.+)\.(\w+)$/);
+ $ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
+ /\&(\Q$name\E\.\d+\.$ext)\:([\d\|]+)\&/;
+ return (0,$2,$pathname.'/'.$1);
}
}
@@ -2705,7 +2772,7 @@ sub userlog_query {
sub plaintext {
my $short=shift;
- return $prp{$short};
+ return &mt($prp{$short});
}
# ----------------------------------------------------------------- Assign Role
@@ -3150,6 +3217,13 @@ sub dirlist {
# when it was last modified. It will also return an error of -1
# if an error occurs
+##
+## FIXME: This subroutine assumes its caller knows something about the
+## directory structure of the home server for the student ($root).
+## Not a good assumption to make. Since this is for looking up files
+## in user directories, the full path should be constructed by lond, not
+## whatever machine we request data from.
+##
sub GetFileTimestamp {
my ($studentDomain,$studentName,$filename,$root)=@_;
$studentDomain=~s/\W//g;
@@ -3249,6 +3323,8 @@ sub courseresdata {
$courseresdatacache{$hashid}=\%dumpreply;
} elsif ($tmp =~ /^(con_lost|no_such_host)/) {
return $tmp;
+ } elsif ($tmp =~ /^(error)/) {
+ $courseresdatacache{$hashid.'.time'}=time;
}
}
foreach my $item (@which) {
@@ -3395,7 +3471,7 @@ sub EXT {
# ----------------------------------------------------- Cascading lookup scheme
if (!$symbparm) { $symbparm=&symbread(); }
my $symbp=$symbparm;
- my $mapp=(split(/\_\_\_/,$symbp))[0];
+ my $mapp=(&decode_symb($symbp))[0];
my $symbparm=$symbp.'.'.$spacequalifierrest;
my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
@@ -3474,7 +3550,7 @@ sub EXT {
my $filename;
if (!$symbparm) { $symbparm=&symbread(); }
if ($symbparm) {
- $filename=(split(/\_\_\_/,$symbparm))[2];
+ $filename=(&decode_symb($symbparm))[2];
} else {
$filename=$ENV{'request.filename'};
}
@@ -3749,7 +3825,7 @@ sub gettitle {
delete($titlecache{$symb});
}
}
- my ($map,$resid,$url)=split(/\_\_\_/,$symb);
+ my ($map,$resid,$url)=&decode_symb($symb);
my $title='';
my %bighash;
if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
@@ -3795,7 +3871,7 @@ sub symbverify {
# direct jump to resource in page or to a sequence - will construct own symbs
if ($thisfn=~/\.(page|sequence)$/) { return 1; }
# check URL part
- my ($map,$resid,$url)=split(/\_\_\_/,$symb);
+ my ($map,$resid,$url)=&decode_symb($symb);
unless (&symbclean($url) eq &symbclean($thisfn)) { return 0; }
$symb=&symbclean($symb);
@@ -3838,6 +3914,23 @@ sub symbclean {
return $symb;
}
+# ---------------------------------------------- Split symb to find map and url
+
+sub decode_symb {
+ my ($map,$resid,$url)=split(/\_\_\_/,shift);
+ return (&fixversion($map),$resid,&fixversion($url));
+}
+
+sub fixversion {
+ my $fn=shift;
+ if ($fn=~/^(adm|uploaded|public)/) { return $fn; }
+ my ($match,$cond,$versioned)=&is_on_map($fn);
+ unless ($match) {
+ $fn=$versioned;
+ }
+ return $fn;
+}
+
# ------------------------------------------------------ Return symb list entry
sub symbread {
@@ -4137,6 +4230,12 @@ sub unescape {
return $str;
}
+sub mod_perl_version {
+ if (defined($perlvar{'MODPERL2'})) {
+ return 2;
+ }
+ return 1;
+}
# ================================================================ Main Program
sub goodbye {