--- loncom/lonnet/perl/lonnet.pm 2004/09/17 02:41:21 1.523.2.4
+++ loncom/lonnet/perl/lonnet.pm 2004/08/23 19:34:01 1.529
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.523.2.4 2004/09/17 02:41:21 albertel Exp $
+# $Id: lonnet.pm,v 1.529 2004/08/23 19:34:01 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -50,7 +50,7 @@ use Fcntl qw(:flock);
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 Time::HiRes();
my $readit;
=pod
@@ -827,10 +827,9 @@ sub devalidate_cache {
my ($cache,$id,$name) = @_;
delete $$cache{$id.'.time'};
delete $$cache{$id};
- if (1 || $disk_caching_disabled) { return; }
+ if ($disk_caching_disabled) { return; }
my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
- if (!-e $filename) { return; }
- open(DB,">$filename.lock");
+ open(DB,"$filename.lock");
flock(DB,LOCK_EX);
my %hash;
if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {
@@ -857,7 +856,7 @@ sub is_cached {
my ($cache,$id,$name,$time) = @_;
if (!$time) { $time=300; }
if (!exists($$cache{$id.'.time'})) {
- &load_cache_item($cache,$name,$id,$time);
+ &load_cache_item($cache,$name,$id);
}
if (!exists($$cache{$id.'.time'})) {
# &logthis("Didn't find $id");
@@ -882,66 +881,44 @@ sub do_cache {
$$cache{$id};
}
-my %do_save_item;
-my %do_save;
sub save_cache_item {
my ($cache,$name,$id)=@_;
if ($disk_caching_disabled) { return; }
- $do_save{$name}=$cache;
- if (!exists($do_save_item{$name})) { $do_save_item{$name}={} }
- $do_save_item{$name}->{$id}=1;
- return;
-}
-
-sub save_cache {
- if ($disk_caching_disabled) { return; }
- my ($cache,$name,$id);
- foreach $name (keys(%do_save)) {
- $cache=$do_save{$name};
-
- my $starttime=&Time::HiRes::time();
- &logthis("Saving :$name:");
- my %hash;
- my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
- open(DB,">$filename.lock");
- flock(DB,LOCK_EX);
- if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {
- foreach $id (keys(%{ $do_save_item{$name} })) {
- eval <<'EVALBLOCK';
- $hash{$id.'.time'}=$$cache{$id.'.time'};
- $hash{$id}=freeze({'item'=>$$cache{$id}});
+ my $starttime=&Time::HiRes::time();
+# &logthis("Saving :$name:$id");
+ my %hash;
+ my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
+ open(DB,"$filename.lock");
+ flock(DB,LOCK_EX);
+ if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {
+ eval <<'EVALBLOCK';
+ $hash{$id.'.time'}=$$cache{$id.'.time'};
+ $hash{$id}=freeze({'item'=>$$cache{$id}});
EVALBLOCK
- if ($@) {
- &logthis("<font color='red'>save_cache blew up :$@:$name</font>");
- unlink($filename);
- last;
- }
- }
- } else {
- if (-e $filename) {
- &logthis("Unable to tie hash (save cache): $name ($!)");
- unlink($filename);
- }
+ if ($@) {
+ &logthis("<font color='red'>save_cache blew up :$@:$name</font>");
+ unlink($filename);
+ }
+ } else {
+ if (-e $filename) {
+ &logthis("Unable to tie hash (save cache item): $name ($!)");
+ unlink($filename);
}
- untie(%hash);
- flock(DB,LOCK_UN);
- close(DB);
- &logthis("save_cache $name took ".(&Time::HiRes::time()-$starttime));
}
- undef(%do_save);
- undef(%do_save_item);
-
+ untie(%hash);
+ flock(DB,LOCK_UN);
+ close(DB);
+# &logthis("save_cache_item $name took ".(&Time::HiRes::time()-$starttime));
}
sub load_cache_item {
- my ($cache,$name,$id,$time)=@_;
+ my ($cache,$name,$id)=@_;
if ($disk_caching_disabled) { return; }
my $starttime=&Time::HiRes::time();
# &logthis("Before Loading $name for $id size is ".scalar(%$cache));
my %hash;
my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
- if (!-e $filename) { return; }
- open(DB,">$filename.lock");
+ open(DB,"$filename.lock");
flock(DB,LOCK_SH);
if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) {
eval <<'EVALBLOCK';
@@ -958,11 +935,9 @@ sub load_cache_item {
}
# &logthis("Initial load: $count");
} else {
- if (($$cache{$id.'.time'}+$time) < time) {
- $$cache{$id.'.time'}=$hash{$id.'.time'};
- my $hashref=thaw($hash{$id});
- $$cache{$id}=$hashref->{'item'};
- }
+ my $hashref=thaw($hash{$id});
+ $$cache{$id}=$hashref->{'item'};
+ $$cache{$id.'.time'}=$hash{$id.'.time'};
}
EVALBLOCK
if ($@) {
@@ -1072,7 +1047,6 @@ sub currentversion {
sub subscribe {
my $fname=shift;
if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; }
- $fname=~s/[\n\r]//g;
my $author=$fname;
$author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
my ($udom,$uname)=split(/\//,$author);
@@ -1093,7 +1067,6 @@ sub repcopy {
my $filename=shift;
$filename=~s/\/+/\//g;
if ($filename=~/^\/home\/httpd\/html\/adm\//) { return OK; }
- $filename=~s/[\n\r]//g;
my $transname="$filename.in.transfer";
if ((-e $filename) || (-e $transname)) { return OK; }
my $remoteurl=subscribe($filename);
@@ -1158,10 +1131,10 @@ sub ssi_body {
my ($filelink,%form)=@_;
my $output=($filelink=~/^http\:/?&externalssi($filelink):
&ssi($filelink,%form));
- $output=~s/^.*?\<body[^\>]*\>//si;
- $output=~s/(.*)\<\/body\s*\>.*?$/$1/si;
$output=~
s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs;
+ $output=~s/^.*?\<body[^\>]*\>//si;
+ $output=~s/(.*)\<\/body\s*\>.*?$/$1/si;
return $output;
}
@@ -2618,6 +2591,30 @@ sub put {
return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
}
+# ---------------------------------------------------------- putstore interface
+
+sub putstore {
+ my ($namespace,$storehash,$udomain,$uname)=@_;
+ if (!$udomain) { $udomain=$ENV{'user.domain'}; }
+ if (!$uname) { $uname=$ENV{'user.name'}; }
+ my $uhome=&homeserver($uname,$udomain);
+ my $items='';
+ my %allitems = ();
+ foreach (keys %$storehash) {
+ if ($_ =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) {
+ my $key = $1.':keys:'.$2;
+ $allitems{$key} .= $3.':';
+ }
+ $items.=$_.'='.&escape($$storehash{$_}).'&';
+ }
+ foreach (keys %allitems) {
+ $allitems{$_} =~ s/\:$//;
+ $items.= $_.'='.$allitems{$_}.'&';
+ }
+ $items=~s/\&$//;
+ return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
+}
+
# ------------------------------------------------------ critical put interface
sub cput {
@@ -2700,8 +2697,8 @@ sub allowed {
if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; }
# Free bre access to adm and meta resources
-
- if ((($uri=~/^adm\//) || ($uri=~/\.meta$/)) && ($priv eq 'bre')) {
+ if (((($uri=~/^adm\//) && ($uri !~ m|/bulletinboard$|))
+ || ($uri=~/\.meta$/)) && ($priv eq 'bre')) {
return 'F';
}
@@ -3120,9 +3117,14 @@ sub fetch_enrollment_query {
$cmd = &escape($cmd);
my $query = 'fetchenrollment';
my $queryid=&reply("querysend:".$query.':'.$dom.':'.$ENV{'user.name'}.':'.$cmd,$homeserver);
- unless ($queryid=~/^\Q$host\E\_/) { return 'error: '.$queryid; }
+ unless ($queryid=~/^\Q$host\E\_/) {
+ &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum);
+ return 'error: '.$queryid;
+ }
my $reply = &get_query_reply($queryid);
- unless ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
+ if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
+ &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$ENV{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum);
+ } else {
my @responses = split/:/,$reply;
if ($homeserver eq $perlvar{'lonHostID'}) {
foreach (@responses) {
@@ -3139,10 +3141,14 @@ sub fetch_enrollment_query {
my $filename = $dom.'_'.$key.'_'.$_.'_classlist.xml';
my $destname = $pathname.'/'.$filename;
my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver);
- unless ($xml_classlist =~ /^error/) {
+ if ($xml_classlist =~ /^error/) {
+ &logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum);
+ } else {
if ( open(FILE,">$destname") ) {
print FILE &unescape($xml_classlist);
close(FILE);
+ } else {
+ &logthis('fetch_enrollment_query - error opening classlist file '.$destname.' '.$context.' '.$cnum);
}
}
}
@@ -4021,14 +4027,11 @@ sub EXT {
my $section;
if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) {
- if (!$symbparm) { $symbparm=&symbread(); }
- }
- if ($symbparm && defined($courseid) &&
- $courseid eq $ENV{'request.course.id'}) {
#print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
# ----------------------------------------------------- Cascading lookup scheme
+ if (!$symbparm) { $symbparm=&symbread(); }
my $symbp=$symbparm;
my $mapp=(&decode_symb($symbp))[0];
@@ -4039,11 +4042,11 @@ sub EXT {
($ENV{'user.domain'} eq $udom)) {
$section=$ENV{'request.course.sec'};
} else {
- if (! defined($usection)) {
- $section=&usection($udom,$uname,$courseid);
- } else {
- $section = $usection;
- }
+ if (! defined($usection)) {
+ $section=&usection($udom,$uname,$courseid);
+ } else {
+ $section = $usection;
+ }
}
my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
@@ -4081,7 +4084,7 @@ sub EXT {
$uname." at ".$udom.": ".
$tmp."</font>");
} elsif ($tmp=~/error: 2 /) {
- &EXT_cache_set($udom,$uname);
+ &EXT_cache_set($udom,$uname);
} elsif ($tmp =~ /^(con_lost|no_such_host)/) {
return $tmp;
}
@@ -4091,10 +4094,10 @@ sub EXT {
# -------------------------------------------------------- second, check course
my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'},
- $ENV{'course.'.$courseid.'.domain'},
- ($seclevelr,$seclevelm,$seclevel,
- $courselevelr,$courselevelm,
- $courselevel));
+ $ENV{'course.'.$courseid.'.domain'},
+ ($seclevelr,$seclevelm,$seclevel,
+ $courselevelr,$courselevelm,
+ $courselevel));
if (defined($coursereply)) { return $coursereply; }
# ------------------------------------------------------ third, check map parms
@@ -4194,7 +4197,9 @@ 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|)) ||
+ if (($uri eq '') ||
+ (($uri =~ m|^/*adm/|) &&
+ ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||
($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||
($uri =~ m|home/[^/]+/public_html/|)) {
return undef;
@@ -4592,20 +4597,14 @@ sub deversion {
sub symbread {
my ($thisfn,$donotrecurse)=@_;
- my $cache_str='request.symbread.cached.'.$thisfn;
- if (defined($ENV{$cache_str})) { return $ENV{$cache_str}; }
# no filename provided? try from environment
unless ($thisfn) {
- if ($ENV{'request.symb'}) {
- return $ENV{$cache_str}=&symbclean($ENV{'request.symb'});
- }
+ if ($ENV{'request.symb'}) { return &symbclean($ENV{'request.symb'}); }
$thisfn=$ENV{'request.filename'};
}
# is that filename actually a symb? Verify, clean, and return
if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) {
- if (&symbverify($thisfn,$1)) {
- return $ENV{$cache_str}=&symbclean($thisfn);
- }
+ if (&symbverify($thisfn,$1)) { return &symbclean($thisfn); }
}
$thisfn=declutter($thisfn);
my %hash;
@@ -4626,7 +4625,7 @@ sub symbread {
unless ($syval=~/\_\d+$/) {
unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) {
&appenv('request.ambiguous' => $thisfn);
- return $ENV{$cache_str}='';
+ return '';
}
$syval.=$1;
}
@@ -4673,11 +4672,11 @@ sub symbread {
}
}
if ($syval) {
- return $ENV{$cache_str}=&symbclean($syval.'___'.$thisfn);
+ return &symbclean($syval.'___'.$thisfn);
}
}
&appenv('request.ambiguous' => $thisfn);
- return $ENV{$cache_str}='';
+ return '';
}
# ---------------------------------------------------------- Return random seed
@@ -5063,7 +5062,21 @@ sub filelocation {
$location = $file;
$location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
} elsif ($file=~/^\/*uploaded/) { # is an uploaded file
- $location=$file;
+ if ($file=~/^\/uploaded\/([^\/]+)\/([^\/]+)\/(\/)?simplepage\/([^\/]+)$/) {
+ $location=&Apache::loncommon::propath($1,$2).'/userfiles/simplepage/'.$4;
+ if (not -e $location) {
+ $file=~/^\/uploaded\/(.*)$/;
+ $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.$1;
+ }
+ } elsif ($file=~/^\/uploaded\/([^\/]+)\/([^\/]+)\/aboutme\/([^\/]+)$/) {
+ $location=&Apache::loncommon::propath($1,$2).'/userfiles/aboutme/'.$3;
+ if (not -e $location) {
+ $file=~/^\/uploaded\/(.*)$/;
+ $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.$1;
+ }
+ } else {
+ $location=$file;
+ }
} else {
$file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
$file=~s:^/res/:/:;
@@ -5954,6 +5967,17 @@ put($namespace,$storehash,$udom,$uname)
=item *
+putstore($namespace,$storehash,$udomain,$uname) : stores hash in namesp
+keys used in storehash include version information (e.g., 1:$symb:message etc.) as
+used in records written by &store and retrieved by &restore. This function
+was created for use in editing discussion posts, without incrementing the
+version number included in the key for a particular post. The colon
+separated list of attribute names (e.g., the value associated with the key
+1:keys:$symb) is also generated and passed in the ampersand separated
+items sent to lonnet::reply().
+
+=item *
+
cput($namespace,$storehash,$udom,$uname) : critical put
($udom and $uname are optional)