version 1.523.2.2, 2004/09/15 20:41:07
|
version 1.529, 2004/08/23 19:34:01
|
Line 50 use Fcntl qw(:flock);
|
Line 50 use Fcntl qw(:flock);
|
use Apache::loncoursedata; |
use Apache::loncoursedata; |
use Apache::lonlocal; |
use Apache::lonlocal; |
use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw); |
use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw); |
use Time::HiRes qw( gettimeofday tv_interval ); |
use Time::HiRes(); |
my $readit; |
my $readit; |
|
|
=pod |
=pod |
Line 1047 sub currentversion {
|
Line 1047 sub currentversion {
|
sub subscribe { |
sub subscribe { |
my $fname=shift; |
my $fname=shift; |
if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; } |
if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; } |
$fname=~s/[\n\r]//g; |
|
my $author=$fname; |
my $author=$fname; |
$author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; |
$author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; |
my ($udom,$uname)=split(/\//,$author); |
my ($udom,$uname)=split(/\//,$author); |
Line 1068 sub repcopy {
|
Line 1067 sub repcopy {
|
my $filename=shift; |
my $filename=shift; |
$filename=~s/\/+/\//g; |
$filename=~s/\/+/\//g; |
if ($filename=~/^\/home\/httpd\/html\/adm\//) { return OK; } |
if ($filename=~/^\/home\/httpd\/html\/adm\//) { return OK; } |
$filename=~s/[\n\r]//g; |
|
my $transname="$filename.in.transfer"; |
my $transname="$filename.in.transfer"; |
if ((-e $filename) || (-e $transname)) { return OK; } |
if ((-e $filename) || (-e $transname)) { return OK; } |
my $remoteurl=subscribe($filename); |
my $remoteurl=subscribe($filename); |
Line 1133 sub ssi_body {
|
Line 1131 sub ssi_body {
|
my ($filelink,%form)=@_; |
my ($filelink,%form)=@_; |
my $output=($filelink=~/^http\:/?&externalssi($filelink): |
my $output=($filelink=~/^http\:/?&externalssi($filelink): |
&ssi($filelink,%form)); |
&ssi($filelink,%form)); |
$output=~s/^.*?\<body[^\>]*\>//si; |
|
$output=~s/(.*)\<\/body\s*\>.*?$/$1/si; |
|
$output=~ |
$output=~ |
s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs; |
s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs; |
|
$output=~s/^.*?\<body[^\>]*\>//si; |
|
$output=~s/(.*)\<\/body\s*\>.*?$/$1/si; |
return $output; |
return $output; |
} |
} |
|
|
Line 2593 sub put {
|
Line 2591 sub put {
|
return &reply("put:$udomain:$uname:$namespace:$items",$uhome); |
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 |
# ------------------------------------------------------ critical put interface |
|
|
sub cput { |
sub cput { |
Line 2675 sub allowed {
|
Line 2697 sub allowed {
|
|
|
if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; } |
if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; } |
# Free bre access to adm and meta resources |
# Free bre access to adm and meta resources |
|
if (((($uri=~/^adm\//) && ($uri !~ m|/bulletinboard$|)) |
if ((($uri=~/^adm\//) || ($uri=~/\.meta$/)) && ($priv eq 'bre')) { |
|| ($uri=~/\.meta$/)) && ($priv eq 'bre')) { |
return 'F'; |
return 'F'; |
} |
} |
|
|
Line 3095 sub fetch_enrollment_query {
|
Line 3117 sub fetch_enrollment_query {
|
$cmd = &escape($cmd); |
$cmd = &escape($cmd); |
my $query = 'fetchenrollment'; |
my $query = 'fetchenrollment'; |
my $queryid=&reply("querysend:".$query.':'.$dom.':'.$ENV{'user.name'}.':'.$cmd,$homeserver); |
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); |
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; |
my @responses = split/:/,$reply; |
if ($homeserver eq $perlvar{'lonHostID'}) { |
if ($homeserver eq $perlvar{'lonHostID'}) { |
foreach (@responses) { |
foreach (@responses) { |
Line 3114 sub fetch_enrollment_query {
|
Line 3141 sub fetch_enrollment_query {
|
my $filename = $dom.'_'.$key.'_'.$_.'_classlist.xml'; |
my $filename = $dom.'_'.$key.'_'.$_.'_classlist.xml'; |
my $destname = $pathname.'/'.$filename; |
my $destname = $pathname.'/'.$filename; |
my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver); |
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") ) { |
if ( open(FILE,">$destname") ) { |
print FILE &unescape($xml_classlist); |
print FILE &unescape($xml_classlist); |
close(FILE); |
close(FILE); |
|
} else { |
|
&logthis('fetch_enrollment_query - error opening classlist file '.$destname.' '.$context.' '.$cnum); |
} |
} |
} |
} |
} |
} |
Line 3996 sub EXT {
|
Line 4027 sub EXT {
|
|
|
my $section; |
my $section; |
if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) { |
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; |
#print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest; |
|
|
# ----------------------------------------------------- Cascading lookup scheme |
# ----------------------------------------------------- Cascading lookup scheme |
|
if (!$symbparm) { $symbparm=&symbread(); } |
my $symbp=$symbparm; |
my $symbp=$symbparm; |
my $mapp=(&decode_symb($symbp))[0]; |
my $mapp=(&decode_symb($symbp))[0]; |
|
|
Line 4014 sub EXT {
|
Line 4042 sub EXT {
|
($ENV{'user.domain'} eq $udom)) { |
($ENV{'user.domain'} eq $udom)) { |
$section=$ENV{'request.course.sec'}; |
$section=$ENV{'request.course.sec'}; |
} else { |
} else { |
if (! defined($usection)) { |
if (! defined($usection)) { |
$section=&usection($udom,$uname,$courseid); |
$section=&usection($udom,$uname,$courseid); |
} else { |
} else { |
$section = $usection; |
$section = $usection; |
} |
} |
} |
} |
|
|
my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest; |
my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest; |
Line 4056 sub EXT {
|
Line 4084 sub EXT {
|
$uname." at ".$udom.": ". |
$uname." at ".$udom.": ". |
$tmp."</font>"); |
$tmp."</font>"); |
} elsif ($tmp=~/error: 2 /) { |
} elsif ($tmp=~/error: 2 /) { |
&EXT_cache_set($udom,$uname); |
&EXT_cache_set($udom,$uname); |
} elsif ($tmp =~ /^(con_lost|no_such_host)/) { |
} elsif ($tmp =~ /^(con_lost|no_such_host)/) { |
return $tmp; |
return $tmp; |
} |
} |
Line 4066 sub EXT {
|
Line 4094 sub EXT {
|
# -------------------------------------------------------- second, check course |
# -------------------------------------------------------- second, check course |
|
|
my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'}, |
my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'}, |
$ENV{'course.'.$courseid.'.domain'}, |
$ENV{'course.'.$courseid.'.domain'}, |
($seclevelr,$seclevelm,$seclevel, |
($seclevelr,$seclevelm,$seclevel, |
$courselevelr,$courselevelm, |
$courselevelr,$courselevelm, |
$courselevel)); |
$courselevel)); |
if (defined($coursereply)) { return $coursereply; } |
if (defined($coursereply)) { return $coursereply; } |
|
|
# ------------------------------------------------------ third, check map parms |
# ------------------------------------------------------ third, check map parms |
Line 4169 sub metadata {
|
Line 4197 sub metadata {
|
my ($uri,$what,$liburi,$prefix,$depthcount)=@_; |
my ($uri,$what,$liburi,$prefix,$depthcount)=@_; |
$uri=&declutter($uri); |
$uri=&declutter($uri); |
# if it is a non metadata possible uri return quickly |
# 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|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) || |
($uri =~ m|home/[^/]+/public_html/|)) { |
($uri =~ m|home/[^/]+/public_html/|)) { |
return undef; |
return undef; |
Line 4567 sub deversion {
|
Line 4597 sub deversion {
|
|
|
sub symbread { |
sub symbread { |
my ($thisfn,$donotrecurse)=@_; |
my ($thisfn,$donotrecurse)=@_; |
if (defined($ENV{'request.symbread.cached'})) { |
|
return $ENV{'request.symbread.cached'}; |
|
} |
|
# no filename provided? try from environment |
# no filename provided? try from environment |
unless ($thisfn) { |
unless ($thisfn) { |
if ($ENV{'request.symb'}) { |
if ($ENV{'request.symb'}) { return &symbclean($ENV{'request.symb'}); } |
$ENV{'request.symbread.cached'}=&symbclean($ENV{'request.symb'}); |
|
return $ENV{'request.symbread.cached'}; |
|
} |
|
$thisfn=$ENV{'request.filename'}; |
$thisfn=$ENV{'request.filename'}; |
} |
} |
# is that filename actually a symb? Verify, clean, and return |
# is that filename actually a symb? Verify, clean, and return |
if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) { |
if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) { |
if (&symbverify($thisfn,$1)) { |
if (&symbverify($thisfn,$1)) { return &symbclean($thisfn); } |
$ENV{'request.symbread.cached'}=&symbclean($thisfn); |
|
return $ENV{'request.symbread.cached'}; |
|
} |
|
} |
} |
$thisfn=declutter($thisfn); |
$thisfn=declutter($thisfn); |
my %hash; |
my %hash; |
Line 4604 sub symbread {
|
Line 4625 sub symbread {
|
unless ($syval=~/\_\d+$/) { |
unless ($syval=~/\_\d+$/) { |
unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) { |
unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) { |
&appenv('request.ambiguous' => $thisfn); |
&appenv('request.ambiguous' => $thisfn); |
$ENV{'request.symbread.cached'}=''; |
|
return ''; |
return ''; |
} |
} |
$syval.=$1; |
$syval.=$1; |
Line 4652 sub symbread {
|
Line 4672 sub symbread {
|
} |
} |
} |
} |
if ($syval) { |
if ($syval) { |
$ENV{'request.symbread.cached'}=&symbclean($syval.'___'.$thisfn); |
return &symbclean($syval.'___'.$thisfn); |
return $ENV{'request.symbread.cached'}; |
|
} |
} |
} |
} |
&appenv('request.ambiguous' => $thisfn); |
&appenv('request.ambiguous' => $thisfn); |
$ENV{'request.symbread.cached'}=''; |
|
return ''; |
return ''; |
} |
} |
|
|
Line 5044 sub filelocation {
|
Line 5062 sub filelocation {
|
$location = $file; |
$location = $file; |
$location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; |
$location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; |
} elsif ($file=~/^\/*uploaded/) { # is an uploaded file |
} 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 { |
} else { |
$file=~s/^\Q$perlvar{'lonDocRoot'}\E//; |
$file=~s/^\Q$perlvar{'lonDocRoot'}\E//; |
$file=~s:^/res/:/:; |
$file=~s:^/res/:/:; |
Line 5935 put($namespace,$storehash,$udom,$uname)
|
Line 5967 put($namespace,$storehash,$udom,$uname)
|
|
|
=item * |
=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 |
cput($namespace,$storehash,$udom,$uname) : critical put |
($udom and $uname are optional) |
($udom and $uname are optional) |
|
|