--- loncom/lonnet/perl/lonnet.pm 2003/09/10 15:53:16 1.410
+++ loncom/lonnet/perl/lonnet.pm 2003/10/06 20:38:25 1.427
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.410 2003/09/10 15:53:16 matthew Exp $
+# $Id: lonnet.pm,v 1.427 2003/10/06 20:38:25 www 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
+ %userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def
%domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir);
use IO::Socket;
@@ -85,7 +85,9 @@ use Apache::Constants qw(:common :http);
use HTML::LCParser;
use Fcntl qw(:flock);
use Apache::loncoursedata;
-
+use Apache::lonlocal;
+use Storable qw(lock_store lock_nstore lock_retrieve);
+use Time::HiRes();
my $readit;
# --------------------------------------------------------------------- Logging
@@ -246,9 +248,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 +442,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;
}
@@ -568,9 +586,9 @@ sub authenticate {
sub homeserver {
my ($uname,$udom,$ignoreBadCache)=@_;
my $index="$uname:$udom";
- if ($homecache{$index}) {
- return "$homecache{$index}";
- }
+
+ my ($result,$cached)=&is_cached(\%homecache,$index,'home',86400);
+ if (defined($cached)) { return $result; }
my $tryserver;
foreach $tryserver (keys %libserv) {
next if ($ignoreBadCache ne 'true' &&
@@ -578,8 +596,7 @@ sub homeserver {
if ($hostdom{$tryserver} eq $udom) {
my $answer=reply("home:$udom:$uname",$tryserver);
if ($answer eq 'found') {
- $homecache{$index}=$tryserver;
- return $tryserver;
+ return &do_cache(\%homecache,$index,$tryserver,'home');
} elsif ($answer eq 'no_host') {
$badServerCache{$tryserver}=1;
}
@@ -831,8 +848,96 @@ sub getsection {
return '-1';
}
+sub devalidate_cache {
+ my ($cache,$id) = @_;
+ delete $$cache{$id.'.time'};
+ delete $$cache{$id};
+}
+
+sub is_cached {
+ my ($cache,$id,$name,$time) = @_;
+ if (!$time) { $time=300; }
+ if (!exists($$cache{$id.'.time'})) {
+ &load_cache($cache,$name);
+ }
+ if (!exists($$cache{$id.'.time'})) {
+# &logthis("Didn't find $id");
+ return (undef,undef);
+ } else {
+ if (time-($$cache{$id.'.time'})>$time) {
+# &logthis("Devailidating $id");
+ &devalidate_cache($cache,$id);
+ return (undef,undef);
+ }
+ }
+ return ($$cache{$id},1);
+}
+
+sub do_cache {
+ my ($cache,$id,$value,$name) = @_;
+ $$cache{$id.'.time'}=time;
+ $$cache{$id}=$value;
+ &save_cache($cache,$name);
+ # do_cache implictly return the set value
+ $$cache{$id};
+}
+
+sub save_cache {
+ my ($cache,$name)=@_;
+# my $starttime=&Time::HiRes::time();
+# &logthis("Saving :$name:");
+ eval lock_store($cache,$perlvar{'lonDaemons'}.'/tmp/'.$name.".storable");
+ if ($@) { &logthis("lock_store threw a die ".$@); }
+# &logthis("save_cache took ".(&Time::HiRes::time()-$starttime));
+}
+
+sub load_cache {
+ my ($cache,$name)=@_;
+# my $starttime=&Time::HiRes::time();
+# &logthis("Before Loading $name size is ".scalar(%$cache));
+ my $tmpcache;
+ eval {
+ $tmpcache=lock_retrieve($perlvar{'lonDaemons'}.'/tmp/'.$name.".storable");
+ };
+ if ($@) { &logthis("lock_retreive threw a die ".$@); return; }
+ if (!%$cache) {
+ my $count;
+ while (my ($key,$value)=each(%$tmpcache)) {
+ $count++;
+ $$cache{$key}=$value;
+ }
+# &logthis("Initial load: $count");
+ } else {
+ my $key;
+ my $count;
+ while ($key=each(%$tmpcache)) {
+ if ($key !~/^(.*)\.time$/) { next; }
+ my $name=$1;
+ if (exists($$cache{$key})) {
+ if ($$tmpcache{$key} >= $$cache{$key}) {
+ $$cache{$key}=$$tmpcache{$key};
+ $$cache{$name}=$$tmpcache{$name};
+ } else {
+# &logthis("Would have overwritten $name with is set to expire at ".$$cache{$key}." with ".$$tmpcache{$key}." Whew!");
+ }
+ } else {
+ $count++;
+ $$cache{$key}=$$tmpcache{$key};
+ $$cache{$name}=$$tmpcache{$name};
+ }
+ }
+# &logthis("Additional load: $count");
+ }
+# &logthis("After Loading $name size is ".scalar(%$cache));
+# &logthis("load_cache took ".(&Time::HiRes::time()-$starttime));
+}
+
sub usection {
my ($udom,$unam,$courseid)=@_;
+ my $hashid="$udom:$unam:$courseid";
+
+ my ($result,$cached)=&is_cached(\%usectioncache,$hashid,'usection');
+ if (defined($cached)) { return $result; }
$courseid=~s/\_/\//g;
$courseid=~s/^(\w)/\/$1/;
foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',
@@ -851,10 +956,12 @@ sub usection {
if ($end) {
if ($now>$end) { $notactive=1; }
}
- unless ($notactive) { return $section; }
+ unless ($notactive) {
+ return &do_cache(\%usectioncache,$hashid,$section,'usection');
+ }
}
}
- return '-1';
+ return &do_cache(\%usectioncache,$hashid,'-1','usection');
}
# ------------------------------------- Read an entry from a user's environment
@@ -2170,27 +2277,7 @@ sub currentdump {
return if ($tmp[0] =~ /^(error:|no_such_host)/);
my %hash = @tmp;
@tmp=();
- # Code ripped from lond, essentially. The only difference
- # here is the unescaping done by lonnet::dump(). Conceivably
- # we might run in to problems with parameter names =~ /^v\./
- while (my ($key,$value) = each(%hash)) {
- my ($v,$symb,$param) = split(/:/,$key);
- next if ($v eq 'version' || $symb eq 'keys');
- next if (exists($returnhash{$symb}) &&
- exists($returnhash{$symb}->{$param}) &&
- $returnhash{$symb}->{'v.'.$param} > $v);
- $returnhash{$symb}->{$param}=$value;
- $returnhash{$symb}->{'v.'.$param}=$v;
- }
- #
- # Remove all of the keys in the hashes which keep track of
- # the version of the parameter.
- while (my ($symb,$param_hash) = each(%returnhash)) {
- # use a foreach because we are going to delete from the hash.
- foreach my $key (keys(%$param_hash)) {
- delete($param_hash->{$key}) if ($key =~ /^v\./);
- }
- }
+ %returnhash = %{&convert_dump_to_currentdump(\%hash)};
} else {
my @pairs=split(/\&/,$rep);
foreach (@pairs) {
@@ -2203,6 +2290,33 @@ sub currentdump {
return %returnhash;
}
+sub convert_dump_to_currentdump{
+ my %hash = %{shift()};
+ my %returnhash;
+ # Code ripped from lond, essentially. The only difference
+ # here is the unescaping done by lonnet::dump(). Conceivably
+ # we might run in to problems with parameter names =~ /^v\./
+ while (my ($key,$value) = each(%hash)) {
+ my ($v,$symb,$param) = split(/:/,$key);
+ next if ($v eq 'version' || $symb eq 'keys');
+ next if (exists($returnhash{$symb}) &&
+ exists($returnhash{$symb}->{$param}) &&
+ $returnhash{$symb}->{'v.'.$param} > $v);
+ $returnhash{$symb}->{$param}=$value;
+ $returnhash{$symb}->{'v.'.$param}=$v;
+ }
+ #
+ # Remove all of the keys in the hashes which keep track of
+ # the version of the parameter.
+ while (my ($symb,$param_hash) = each(%returnhash)) {
+ # use a foreach because we are going to delete from the hash.
+ foreach my $key (keys(%$param_hash)) {
+ delete($param_hash->{$key}) if ($key =~ /^v\./);
+ }
+ }
+ return \%returnhash;
+}
+
# --------------------------------------------------------------- put interface
sub put {
@@ -2590,10 +2704,38 @@ 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);
}
}
+# --------------------------------------------------------- Get symb from alias
+
+sub get_symb_from_alias {
+ my $symb=shift;
+ my ($map,$resid,$url)=&decode_symb($symb);
+# Already is a symb
+ if ($url) { return $symb; }
+# Must be an alias
+ my $aliassymb='';
+ my %bighash;
+ if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
+ &GDBM_READER(),0640)) {
+ my $rid=$bighash{'mapalias_'.$symb};
+ if ($rid) {
+ my ($mapid,$resid)=split(/\./,$rid);
+ $aliassymb=
+ &declutter($bighash{'map_id_'.$mapid}).
+ '___'.$resid.'___'.
+ &declutter($bighash{'src_'.$rid});
+ }
+ untie %bighash;
+ }
+ return $aliassymb;
+}
+
# ----------------------------------------------------------------- Define Role
sub definerole {
@@ -2720,7 +2862,7 @@ sub userlog_query {
sub plaintext {
my $short=shift;
- return $prp{$short};
+ return &mt($prp{$short});
}
# ----------------------------------------------------------------- Assign Role
@@ -3248,7 +3390,7 @@ sub condval {
sub devalidatecourseresdata {
my ($coursenum,$coursedomain)=@_;
my $hashid=$coursenum.':'.$coursedomain;
- delete $courseresdatacache{$hashid.'.time'};
+ &devalidate_cache(\%courseresdatacache,$hashid);
}
# --------------------------------------------------- Course Resourcedata Query
@@ -3257,25 +3399,23 @@ sub courseresdata {
my ($coursenum,$coursedomain,@which)=@_;
my $coursehom=&homeserver($coursenum,$coursedomain);
my $hashid=$coursenum.':'.$coursedomain;
- my $dodump=0;
- if (!defined($courseresdatacache{$hashid.'.time'})) {
- $dodump=1;
- } else {
- if (time-$courseresdatacache{$hashid.'.time'}>300) { $dodump=1; }
- }
- if ($dodump) {
+ my ($result,$cached)=&is_cached(\%courseresdatacache,$hashid,'courseres');
+ unless (defined($cached)) {
my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum);
+ $result=\%dumpreply;
my ($tmp) = keys(%dumpreply);
if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
- $courseresdatacache{$hashid.'.time'}=time;
- $courseresdatacache{$hashid}=\%dumpreply;
+ &do_cache(\%courseresdatacache,$hashid,$result,'courseres');
} elsif ($tmp =~ /^(con_lost|no_such_host)/) {
return $tmp;
+ } elsif ($tmp =~ /^(error)/) {
+ $result=undef;
+ &do_cache(\%courseresdatacache,$hashid,$result,'courseres');
}
}
foreach my $item (@which) {
- if (defined($courseresdatacache{$hashid}->{$item})) {
- return $courseresdatacache{$hashid}->{$item};
+ if (defined($result->{$item})) {
+ return $result->{$item};
}
}
return undef;
@@ -3314,6 +3454,9 @@ sub EXT {
#get real user name/domain, courseid and symb
my $courseid;
my $publicuser;
+ if ($symbparm) {
+ $symbparm=&get_symb_from_alias($symbparm);
+ }
if (!($uname && $udom)) {
(my $cursymb,$courseid,$udom,$uname,$publicuser)=
&Apache::lonxml::whichuser($symbparm);
@@ -3443,19 +3586,25 @@ sub EXT {
# ----------------------------------------------------------- first, check user
#most student don\'t have any data set, check if there is some data
- #every thirty minutes
if (! &EXT_cache_status($udom,$uname)) {
- my %resourcedata=&get('resourcedata',
- [$courselevelr,$courselevelm,$courselevel],
- $udom,$uname);
- my ($tmp)=keys(%resourcedata);
+ my $hashid="$udom:$uname";
+ my ($result,$cached)=&is_cached(\%userresdatacache,$hashid,
+ 'userres');
+ if (!defined($cached)) {
+ my %resourcedata=&get('resourcedata',
+ [$courselevelr,$courselevelm,
+ $courselevel],$udom,$uname);
+ $result=\%resourcedata;
+ &do_cache(\%userresdatacache,$hashid,$result,'userres');
+ }
+ my ($tmp)=keys(%$result);
if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {
- if ($resourcedata{$courselevelr}) {
- return $resourcedata{$courselevelr}; }
- if ($resourcedata{$courselevelm}) {
- return $resourcedata{$courselevelm}; }
- if ($resourcedata{$courselevel}) {
- return $resourcedata{$courselevel}; }
+ if ($$result{$courselevelr}) {
+ return $$result{$courselevelr}; }
+ if ($$result{$courselevelm}) {
+ return $$result{$courselevelm}; }
+ if ($$result{$courselevel}) {
+ return $$result{$courselevel}; }
} else {
if ($tmp!~/No such file/) {
&logthis("<font color=blue>WARNING:".
@@ -3571,11 +3720,11 @@ sub add_prefix_and_part {
sub metadata {
my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
-
$uri=&declutter($uri);
# if it is a non metadata possible uri return quickly
if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|)) ||
- ($uri =~ m|/$|) || ($uri =~ m|/.meta$|)) {
+ ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||
+ ($uri =~ m|home/[^/]+/public_html/|)) {
return '';
}
my $filename=$uri;
@@ -3764,13 +3913,8 @@ sub gettitle {
unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; }
return &metadata($urlsymb,'title');
}
- if ($titlecache{$symb}) {
- if (time < ($titlecache{$symb}[1] + 600)) {
- return $titlecache{$symb}[0];
- } else {
- delete($titlecache{$symb});
- }
- }
+ my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600);
+ if (defined($cached)) { return $result; }
my ($map,$resid,$url)=&decode_symb($symb);
my $title='';
my %bighash;
@@ -3782,8 +3926,7 @@ sub gettitle {
}
$title=~s/\&colon\;/\:/gs;
if ($title) {
- $titlecache{$symb}=[$title,time];
- return $title;
+ return &do_cache(\%titlecache,$symb,$title,'title');
} else {
return &metadata($urlsymb,'title');
}
@@ -3863,7 +4006,18 @@ sub symbclean {
# ---------------------------------------------- Split symb to find map and url
sub decode_symb {
- return split(/\_\_\_/,shift);
+ 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
@@ -4165,10 +4319,26 @@ sub unescape {
return $str;
}
+sub mod_perl_version {
+ if (defined($perlvar{'MODPERL2'})) {
+ return 2;
+ }
+ return 1;
+}
# ================================================================ Main Program
sub goodbye {
&logthis("Starting Shut down");
+#not converted to using infrastruture
+ &logthis(sprintf("%-20s is %s",'%homecache',scalar(%homecache)));
+ &logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache)));
+ &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));
+#converted
+ &logthis(sprintf("%-20s is %s",'%titlecache',scalar(%titlecache)));
+ &logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache)));
+#1.1 only
+ &logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache)));
+ &logthis(sprintf("%-20s is %s",'%usectioncache',scalar(%usectioncache)));
&flushcourselogs();
&logthis("Shutting down");
return DONE;