--- loncom/lonnet/perl/lonnet.pm 2004/10/12 20:37:04 1.545.2.3
+++ loncom/lonnet/perl/lonnet.pm 2004/10/26 15:15:18 1.553
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.545.2.3 2004/10/12 20:37:04 albertel Exp $
+# $Id: lonnet.pm,v 1.553 2004/10/26 15:15:18 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -36,10 +36,10 @@ use HTTP::Date;
# use Date::Parse;
use vars
qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom
- %libserv %pr %prp $metacache %packagetab %titlecache %courseresversioncache %resversioncache
+ %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache
%courselogs %accesshash %userrolehash $processmarker $dumpcount
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseresdatacache
- %userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def
+ %userresdatacache %getsectioncache %domaindescription %domain_auth_def %domain_auth_arg_def
%domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir);
use IO::Socket;
@@ -51,8 +51,8 @@ use Apache::loncoursedata;
use Apache::lonlocal;
use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw);
use Time::HiRes qw( gettimeofday tv_interval );
-use Cache::Memcached;
my $readit;
+my $max_connection_retries = 10; # Or some such value.
=pod
@@ -117,14 +117,40 @@ sub logperm {
sub subreply {
my ($cmd,$server)=@_;
my $peerfile="$perlvar{'lonSockDir'}/$server";
- my $client=IO::Socket::UNIX->new(Peer =>"$peerfile",
- Type => SOCK_STREAM,
- Timeout => 10)
- or return "con_lost";
- print $client "$cmd\n";
- my $answer=<$client>;
- if (!$answer) { $answer="con_lost"; }
- chomp($answer);
+ #
+ # With loncnew process trimming, there's a timing hole between lonc server
+ # process exit and the master server picking up the listen on the AF_UNIX
+ # socket. In that time interval, a lock file will exist:
+
+ my $lockfile=$peerfile.".lock";
+ while (-e $lockfile) { # Need to wait for the lockfile to disappear.
+ sleep(1);
+ }
+ # At this point, either a loncnew parent is listening or an old lonc
+ # or loncnew child is listening so we can connect or everything's dead.
+ #
+ # We'll give the connection a few tries before abandoning it. If
+ # connection is not possible, we'll con_lost back to the client.
+ #
+ my $client;
+ for (my $retries = 0; $retries < $max_connection_retries; $retries++) {
+ $client=IO::Socket::UNIX->new(Peer =>"$peerfile",
+ Type => SOCK_STREAM,
+ Timeout => 10);
+ if($client) {
+ last; # Connected!
+ }
+ sleep(1); # Try again later if failed connection.
+ }
+ my $answer;
+ if ($client) {
+ print $client "$cmd\n";
+ $answer=<$client>;
+ if (!$answer) { $answer="con_lost"; }
+ chomp($answer);
+ } else {
+ $answer = 'con_lost'; # Failed connection.
+ }
return $answer;
}
@@ -772,6 +798,11 @@ sub getsection {
my ($udom,$unam,$courseid)=@_;
$courseid=~s/\_/\//g;
$courseid=~s/^(\w)/\/$1/;
+
+ my $hashid="$udom:$unam:$courseid";
+ my ($result,$cached)=&is_cached(\%getsectioncache,$hashid,'getsection');
+ if (defined($cached)) { return $result; }
+
my %Pending;
my %Expired;
#
@@ -796,29 +827,29 @@ sub getsection {
if ($key eq $courseid.'_st') { $section=''; }
my ($dummy,$end,$start)=split(/\_/,&unescape($value));
my $now=time;
- if (defined($end) && ($now > $end)) {
+ if (defined($end) && $end && ($now > $end)) {
$Expired{$end}=$section;
next;
}
- if (defined($start) && ($now < $start)) {
+ if (defined($start) && $start && ($now < $start)) {
$Pending{$start}=$section;
next;
}
- return $section;
+ return &do_cache(\%getsectioncache,$hashid,$section,'getsection');
}
#
# Presumedly there will be few matching roles from the above
# loop and the sorting time will be negligible.
if (scalar(keys(%Pending))) {
my ($time) = sort {$a <=> $b} keys(%Pending);
- return $Pending{$time};
+ return &do_cache(\%getsectioncache,$hashid,$Pending{$time},'getsection');
}
if (scalar(keys(%Expired))) {
my @sorted = sort {$a <=> $b} keys(%Expired);
my $time = pop(@sorted);
- return $Expired{$time};
+ return &do_cache(\%getsectioncache,$hashid,$Expired{$time},'getsection');
}
- return '-1';
+ return &do_cache(\%getsectioncache,$hashid,'-1','getsection');
}
@@ -874,7 +905,7 @@ sub is_cached {
# &logthis("Upping $mtime - ".$$cache{$id.'.time'}.
# "$id because of $filename");
} else {
-# &logthis("Devalidating $filename $id - ".(time-($$cache{$id.'.time'})));
+ &logthis("Devalidating $filename $id - ".(time-($$cache{$id.'.time'})));
&devalidate_cache($cache,$id,$name);
return (undef,undef);
}
@@ -1009,84 +1040,6 @@ EVALBLOCK
# &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime));
}
-sub devalidate_cache_new {
- my ($cache,$name,$id) = @_;
- if (0) { &Apache::lonnet::logthis("deleting $name:$id"); }
- $cache->delete(&escape($name.':'.$id));
-}
-
-my $lastone;
-my $lastname;
-sub is_cached_new {
- my ($cache,$name,$id,$debug) = @_;
- $debug=0;
- $id=&escape($name.':'.$id);
- if ($lastname eq $id) {
- if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $lastone <= $lastname "); }
- return ($lastone,1);
- }
- undef($lastone);
- undef($lastname);
- my $value = $cache->get($id);
- if (!(defined($value))) {
- if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); }
- return (undef,undef);
- }
- $lastname=$id;
- if ($value eq '__undef__') {
- if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); }
- return (undef,1);
- }
- if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); }
- $lastone=$value;
- return ($value,1);
-}
-
-sub do_cache_new {
- my ($cache,$name,$id,$value,$time,$debug) = @_;
- $debug=0;
- $id=&escape($name.':'.$id);
- my $setvalue=$value;
- if (!defined($setvalue)) {
- $setvalue='__undef__';
- }
- if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }
- $cache->set($id,$setvalue,300);
- return $value;
-}
-
-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',
- &homeserver($unam,$udom)))) {
- my ($key,$value)=split(/\=/,$_);
- $key=&unescape($key);
- if ($key=~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/) {
- my $section=$1;
- if ($key eq $courseid.'_st') { $section=''; }
- my ($dummy,$end,$start)=split(/\_/,&unescape($value));
- my $now=time;
- my $notactive=0;
- if ($start) {
- if ($now<$start) { $notactive=1; }
- }
- if ($end) {
- if ($now>$end) { $notactive=1; }
- }
- unless ($notactive) {
- return &do_cache(\%usectioncache,$hashid,$section,'usection');
- }
- }
- }
- return &do_cache(\%usectioncache,$hashid,'-1','usection');
-}
-
# ------------------------------------- Read an entry from a user's environment
sub userenvironment {
@@ -1920,6 +1873,7 @@ sub devalidate {
# - the student level sheet of this user in course's homespace
# - the assessment level sheet for this resource
# for this user in user's homespace
+ # - current conditional state info
my $key=$uname.':'.$udom.':';
my $status=
&del('nohist_calculatedsheets',
@@ -1934,6 +1888,7 @@ sub devalidate {
$uname.' at '.$udom.' for '.
$symb.': '.$status);
}
+ &delenv('user.state.'.$cid);
}
}
@@ -2253,6 +2208,7 @@ sub tmprestore {
}
# ----------------------------------------------------------------------- Store
+
sub store {
my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
my $home='';
@@ -2266,6 +2222,7 @@ sub store {
if (!$stuname) { $stuname=$ENV{'user.name'}; }
&devalidate($symb,$stuname,$domain);
+
$symb=escape($symb);
if (!$namespace) {
unless ($namespace=$ENV{'request.course.id'}) {
@@ -2301,6 +2258,7 @@ sub cstore {
if (!$stuname) { $stuname=$ENV{'user.name'}; }
&devalidate($symb,$stuname,$domain);
+
$symb=escape($symb);
if (!$namespace) {
unless ($namespace=$ENV{'request.course.id'}) {
@@ -2343,7 +2301,6 @@ sub restore {
if (!$domain) { $domain=$ENV{'user.domain'}; }
if (!$stuname) { $stuname=$ENV{'user.name'}; }
if (!$home) { $home=$ENV{'user.home'}; }
-
my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home");
my %returnhash=();
@@ -2830,12 +2787,14 @@ sub allowed {
}
# Free bre access to user's own portfolio contents
- $uri=~m:([^/]+)/([^/]+)/([^/]+)/([^/]+)/:;
- if (('uploaded' eq $1)&&($ENV{'user.name'} eq $3) && ($ENV{'user.domain'} eq $2) && ('portfolio' eq $4)) {
+ my ($space,$domain,$name,$dir)=split('/',$uri);
+ if (('uploaded' eq $space) && ($ENV{'user.name'} eq $name) &&
+ ($ENV{'user.domain'} eq $domain) && ('portfolio' eq $dir)) {
return 'F';
}
# Free bre to public access
+
if ($priv eq 'bre') {
my $copyright=&metadata($uri,'copyright');
if (($copyright eq 'public') && (!$ENV{'request.course.id'})) {
@@ -3099,6 +3058,9 @@ sub allowed {
return '';
}
}
+ if (!defined($ENV{'user.state.'.$ENV{'request.course.id'}})) {
+ &Apache::lonuserstate::evalstate();
+ }
if (&condval($statecond)) {
return '2';
} else {
@@ -3235,8 +3197,10 @@ sub log_query {
sub fetch_enrollment_query {
my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_;
my $homeserver;
+ my $maxtries = 1;
if ($context eq 'automated') {
$homeserver = $perlvar{'lonHostID'};
+ $maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout
} else {
$homeserver = &homeserver($cnum,$dom);
}
@@ -3254,8 +3218,13 @@ sub fetch_enrollment_query {
return 'error: '.$queryid;
}
my $reply = &get_query_reply($queryid);
+ my $tries = 1;
+ while (($reply=~/^timeout/) && ($tries < $maxtries)) {
+ $reply = &get_query_reply($queryid);
+ $tries ++;
+ }
if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
- &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$ENV{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum);
+ &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$ENV{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
} else {
my @responses = split/:/,$reply;
if ($homeserver eq $perlvar{'lonHostID'}) {
@@ -4151,7 +4120,7 @@ sub EXT {
$section=$ENV{'request.course.sec'};
} else {
if (! defined($usection)) {
- $section=&usection($udom,$uname,$courseid);
+ $section=&getsection($udom,$uname,$courseid);
} else {
$section = $usection;
}
@@ -4301,7 +4270,6 @@ sub add_prefix_and_part {
# ---------------------------------------------------------------- Get metadata
-my %metaentry;
sub metadata {
my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
$uri=&declutter($uri);
@@ -4321,29 +4289,28 @@ sub metadata {
# Everything is cached by the main uri, libraries are never directly cached
#
if (!defined($liburi)) {
- my ($result,$cached)=&is_cached_new($metacache,'meta',$uri);
+ my ($result,$cached)=&is_cached(\%metacache,$uri,'meta');
if (defined($cached)) { return $result->{':'.$what}; }
}
{
#
# Is this a recursive call for a library?
#
-# if (! exists($metacache{$uri})) {
-# $metacache{$uri}={};
-# }
+ if (! exists($metacache{$uri})) {
+ $metacache{$uri}={};
+ }
if ($liburi) {
$liburi=&declutter($liburi);
$filename=$liburi;
} else {
- &devalidate_cache_new($metacache,'meta',$uri);
- undef(%metaentry);
+ &devalidate_cache(\%metacache,$uri,'meta');
}
my %metathesekeys=();
unless ($filename=~/\.meta$/) { $filename.='.meta'; }
my $metastring;
if ($uri !~ m|^uploaded/|) {
my $file=&filelocation('',&clutter($filename));
- #push(@{$metaentry{$uri.'.file'}},$file);
+ push(@{$metacache{$uri.'.file'}},$file);
$metastring=&getfile($file);
}
my $parser=HTML::LCParser->new(\$metastring);
@@ -4360,10 +4327,10 @@ sub metadata {
if (defined($token->[2]->{'id'})) {
$keyroot.='_'.$token->[2]->{'id'};
}
- if ($metaentry{':packages'}) {
- $metaentry{':packages'}.=','.$package.$keyroot;
+ if ($metacache{$uri}->{':packages'}) {
+ $metacache{$uri}->{':packages'}.=','.$package.$keyroot;
} else {
- $metaentry{':packages'}=$package.$keyroot;
+ $metacache{$uri}->{':packages'}=$package.$keyroot;
}
foreach (keys %packagetab) {
my $part=$keyroot;
@@ -4385,14 +4352,14 @@ sub metadata {
if ($subp eq 'display') {
$value.=' [Part: '.$part.']';
}
- $metaentry{':'.$unikey.'.part'}=$part;
+ $metacache{$uri}->{':'.$unikey.'.part'}=$part;
$metathesekeys{$unikey}=1;
- unless (defined($metaentry{':'.$unikey.'.'.$subp})) {
- $metaentry{':'.$unikey.'.'.$subp}=$value;
+ unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) {
+ $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value;
}
- if (defined($metaentry{':'.$unikey.'.default'})) {
- $metaentry{':'.$unikey}=
- $metaentry{':'.$unikey.'.default'};
+ if (defined($metacache{$uri}->{':'.$unikey.'.default'})) {
+ $metacache{$uri}->{':'.$unikey}=
+ $metacache{$uri}->{':'.$unikey.'.default'};
}
}
}
@@ -4425,7 +4392,7 @@ sub metadata {
foreach (sort(split(/\,/,&metadata($uri,'keys',
$location,$unikey,
$depthcount+1)))) {
- $metaentry{':'.$_}=$metaentry{':'.$_};
+ $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_};
$metathesekeys{$_}=1;
}
}
@@ -4436,18 +4403,18 @@ sub metadata {
}
$metathesekeys{$unikey}=1;
foreach (@{$token->[3]}) {
- $metaentry{':'.$unikey.'.'.$_}=$token->[2]->{$_};
+ $metacache{$uri}->{':'.$unikey.'.'.$_}=$token->[2]->{$_};
}
my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));
- my $default=$metaentry{':'.$unikey.'.default'};
+ my $default=$metacache{$uri}->{':'.$unikey.'.default'};
if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) {
# only ws inside the tag, and not in default, so use default
# as value
- $metaentry{':'.$unikey}=$default;
+ $metacache{$uri}->{':'.$unikey}=$default;
} else {
# either something interesting inside the tag or default
# uninteresting
- $metaentry{':'.$unikey}=$internaltext;
+ $metacache{$uri}->{':'.$unikey}=$internaltext;
}
# end of not-a-package not-a-library import
}
@@ -4464,7 +4431,7 @@ sub metadata {
&metadata_create_package_def($uri,$key,'extension_'.$extension,
\%metathesekeys);
}
- if (!exists($metaentry{':packages'})) {
+ if (!exists($metacache{$uri}->{':packages'})) {
foreach my $key (sort(keys(%packagetab))) {
#no specific packages well let's get default then
if ($key!~/^default&/) { next; }
@@ -4473,31 +4440,31 @@ sub metadata {
}
}
# are there custom rights to evaluate
- if ($metaentry{':copyright'} eq 'custom') {
+ if ($metacache{$uri}->{':copyright'} eq 'custom') {
#
# Importing a rights file here
#
unless ($depthcount) {
- my $location=$metaentry{':customdistributionfile'};
+ my $location=$metacache{$uri}->{':customdistributionfile'};
my $dir=$filename;
$dir=~s|[^/]*$||;
$location=&filelocation($dir,$location);
foreach (sort(split(/\,/,&metadata($uri,'keys',
$location,'_rights',
$depthcount+1)))) {
- #$metaentry{':'.$_}=$metacache{$uri}->{':'.$_};
+ $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_};
$metathesekeys{$_}=1;
}
}
}
- $metaentry{':keys'}=join(',',keys %metathesekeys);
- &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
- $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
- &do_cache_new($metacache,'meta',$uri,\%metaentry);
+ $metacache{$uri}->{':keys'}=join(',',keys %metathesekeys);
+ &metadata_generate_part0(\%metathesekeys,$metacache{$uri},$uri);
+ $metacache{$uri}->{':allpossiblekeys'}=join(',',keys %metathesekeys);
+ &do_cache(\%metacache,$uri,$metacache{$uri},'meta');
# this is the end of "was not already recently cached
}
- return $metaentry{':'.$what};
+ return $metacache{$uri}->{':'.$what};
}
sub metadata_create_package_def {
@@ -4505,22 +4472,22 @@ sub metadata_create_package_def {
my ($pack,$name,$subp)=split(/\&/,$key);
if ($subp eq 'default') { next; }
- if (defined($metaentry{':packages'})) {
- $metaentry{':packages'}.=','.$package;
+ if (defined($metacache{$uri}->{':packages'})) {
+ $metacache{$uri}->{':packages'}.=','.$package;
} else {
- $metaentry{':packages'}=$package;
+ $metacache{$uri}->{':packages'}=$package;
}
my $value=$packagetab{$key};
my $unikey;
$unikey='parameter_0_'.$name;
- $metaentry{':'.$unikey.'.part'}=0;
+ $metacache{$uri}->{':'.$unikey.'.part'}=0;
$$metathesekeys{$unikey}=1;
- unless (defined($metaentry{':'.$unikey.'.'.$subp})) {
- $metaentry{':'.$unikey.'.'.$subp}=$value;
+ unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) {
+ $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value;
}
- if (defined($metaentry{':'.$unikey.'.default'})) {
- $metaentry{':'.$unikey}=
- $metaentry{':'.$unikey.'.default'};
+ if (defined($metacache{$uri}->{':'.$unikey.'.default'})) {
+ $metacache{$uri}->{':'.$unikey}=
+ $metacache{$uri}->{':'.$unikey.'.default'};
}
}
@@ -5129,13 +5096,15 @@ sub repcopy_userfile {
sub tokenwrapper {
my $uri=shift;
- $uri=~s/^http\:\/\/([^\/]+)//;
- $uri=~s/^\///;
+ $uri=~s|^http\://([^/]+)||;
+ $uri=~s|^/||;
$ENV{'user.environment'}=~/\/([^\/]+)\.id/;
my $token=$1;
- if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) {
- &appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'});
- return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri.
+ my (undef,$udom,$uname,$file)=split('/',$uri,4);
+ if ($udom && $uname && $file) {
+ $file=~s|(\?\.*)*$||;
+ &appenv("userfile.$udom/$uname/$file" => $ENV{'request.course.id'});
+ return 'http://'.$hostname{ &homeserver($uname,$udom)}.'/'.$uri.
(($uri=~/\?/)?'&':'?').'token='.$token.
'&tokenissued='.$perlvar{'lonHostID'};
} else {
@@ -5303,13 +5272,13 @@ sub goodbye {
#not converted to using infrastruture and probably shouldn't be
&logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache)));
#converted
-# &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));
+ &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));
&logthis(sprintf("%-20s is %s",'%homecache',scalar(%homecache)));
&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)));
+ &logthis(sprintf("%-20s is %s",'%getsectioncache',scalar(%getsectioncache)));
&logthis(sprintf("%-20s is %s",'%courseresversioncache',scalar(%courseresversioncache)));
&logthis(sprintf("%-20s is %s",'%resversioncache',scalar(%resversioncache)));
&flushcourselogs();
@@ -5456,7 +5425,7 @@ BEGIN {
}
-$metacache=new Cache::Memcached({'servers'=>['127.0.0.1:11211']});
+%metacache=();
$processmarker='_'.time.'_'.$perlvar{'lonHostID'};
$dumpcount=0;
@@ -5691,8 +5660,8 @@ X<rolesinit()>
B<rolesinit($udom,$username,$authhost)>: get user privileges
=item *
-X<usection()>
-B<usection($udom,$uname,$cname)>: finds the section of student in the
+X<getsection()>
+B<getsection($udom,$uname,$cname)>: finds the section of student in the
course $cname, return section name/number or '' for "not in course"
and '-1' for "no section"