|
version 1.523.2.7, 2004/09/24 15:51:11
|
version 1.545.2.2, 2004/10/12 20:26:48
|
|
Line 36 use HTTP::Date;
|
Line 36 use HTTP::Date;
|
| # use Date::Parse; |
# use Date::Parse; |
| use vars |
use vars |
| qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom |
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 |
%courselogs %accesshash %userrolehash $processmarker $dumpcount |
| %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseresdatacache |
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseresdatacache |
| %userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def |
%userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def |
|
Line 51 use Apache::loncoursedata;
|
Line 51 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 qw( gettimeofday tv_interval ); |
| |
use Cache::Memcached; |
| my $readit; |
my $readit; |
| |
|
| =pod |
=pod |
|
Line 115 sub logperm {
|
Line 116 sub logperm {
|
| # -------------------------------------------------- Non-critical communication |
# -------------------------------------------------- Non-critical communication |
| sub subreply { |
sub subreply { |
| my ($cmd,$server)=@_; |
my ($cmd,$server)=@_; |
| |
my $t0_f=[&Time::HiRes::gettimeofday()]; |
| my $peerfile="$perlvar{'lonSockDir'}/$server"; |
my $peerfile="$perlvar{'lonSockDir'}/$server"; |
| my $client=IO::Socket::UNIX->new(Peer =>"$peerfile", |
my $client=IO::Socket::UNIX->new(Peer =>"$peerfile", |
| Type => SOCK_STREAM, |
Type => SOCK_STREAM, |
|
Line 124 sub subreply {
|
Line 126 sub subreply {
|
| my $answer=<$client>; |
my $answer=<$client>; |
| if (!$answer) { $answer="con_lost"; } |
if (!$answer) { $answer="con_lost"; } |
| chomp($answer); |
chomp($answer); |
| |
my $td=&Time::HiRes::tv_interval($t0_f); |
| |
&Apache::lonnet::logthis("\n $td seconds for $cmd"); |
| return $answer; |
return $answer; |
| } |
} |
| |
|
|
Line 1008 EVALBLOCK
|
Line 1012 EVALBLOCK
|
| # &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime)); |
# &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 { |
sub usection { |
| my ($udom,$unam,$courseid)=@_; |
my ($udom,$unam,$courseid)=@_; |
| my $hashid="$udom:$unam:$courseid"; |
my $hashid="$udom:$unam:$courseid"; |
|
Line 1118 sub subscribe {
|
Line 1168 sub subscribe {
|
| sub repcopy { |
sub repcopy { |
| my $filename=shift; |
my $filename=shift; |
| $filename=~s/\/+/\//g; |
$filename=~s/\/+/\//g; |
| if ($filename=~/^\/home\/httpd\/html\/adm\//) { return OK; } |
if ($filename=~m|^/home/httpd/html/adm/|) { return OK; } |
| |
if ($filename=~m|^/home/httpd/html/lonUsers/|) { return OK; } |
| |
if ($filename=~m|^/home/httpd/html/userfiles/| or |
| |
$filename=~m|^/*uploaded/|) { |
| |
return &repcopy_userfile($filename); |
| |
} |
| $filename=~s/[\n\r]//g; |
$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; } |
|
Line 1184 sub ssi_body {
|
Line 1239 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 1320 sub process_coursefile {
|
Line 1375 sub process_coursefile {
|
| # input: name of form element, coursedoc=1 means this is for the course |
# input: name of form element, coursedoc=1 means this is for the course |
| # output: url of file in userspace |
# output: url of file in userspace |
| |
|
| sub userfileupload { |
sub clean_filename { |
| my ($formname,$coursedoc,$subdir)=@_; |
my ($fname)=@_; |
| if (!defined($subdir)) { $subdir='unknown'; } |
|
| my $fname=$ENV{'form.'.$formname.'.filename'}; |
|
| # Replace Windows backslashes by forward slashes |
# Replace Windows backslashes by forward slashes |
| $fname=~s/\\/\//g; |
$fname=~s/\\/\//g; |
| # Get rid of everything but the actual filename |
# Get rid of everything but the actual filename |
|
Line 1332 sub userfileupload {
|
Line 1385 sub userfileupload {
|
| $fname=~s/\s+/\_/g; |
$fname=~s/\s+/\_/g; |
| # Replace all other weird characters by nothing |
# Replace all other weird characters by nothing |
| $fname=~s/[^\w\.\-]//g; |
$fname=~s/[^\w\.\-]//g; |
| |
# Replace all .\d. sequences with _\d. so they no longer look like version |
| |
# numbers |
| |
$fname=~s/\.(\d+)(?=\.)/_$1/g; |
| |
return $fname; |
| |
} |
| |
|
| |
sub userfileupload { |
| |
my ($formname,$coursedoc,$subdir)=@_; |
| |
if (!defined($subdir)) { $subdir='unknown'; } |
| |
my $fname=$ENV{'form.'.$formname.'.filename'}; |
| |
$fname=&clean_filename($fname); |
| # See if there is anything left |
# See if there is anything left |
| unless ($fname) { return 'error: no uploaded file'; } |
unless ($fname) { return 'error: no uploaded file'; } |
| chop($ENV{'form.'.$formname}); |
chop($ENV{'form.'.$formname}); |
|
Line 1425 sub removeuserfile {
|
Line 1489 sub removeuserfile {
|
| return &reply("removeuserfile:$docudom/$docuname/$fname",$home); |
return &reply("removeuserfile:$docudom/$docuname/$fname",$home); |
| } |
} |
| |
|
| |
sub mkdiruserfile { |
| |
my ($docuname,$docudom,$dir)=@_; |
| |
my $home=&homeserver($docuname,$docudom); |
| |
return &reply("mkdiruserfile:".&escape("$docudom/$docuname/$dir"),$home); |
| |
} |
| |
|
| |
sub renameuserfile { |
| |
my ($docuname,$docudom,$old,$new)=@_; |
| |
my $home=&homeserver($docuname,$docudom); |
| |
return &reply("renameuserfile:$docudom:$docuname:".&escape("$old").':'. |
| |
&escape("$new"),$home); |
| |
} |
| |
|
| # ------------------------------------------------------------------------- Log |
# ------------------------------------------------------------------------- Log |
| |
|
| sub log { |
sub log { |
|
Line 2179 sub tmprestore {
|
Line 2256 sub tmprestore {
|
| } |
} |
| |
|
| # ----------------------------------------------------------------------- Store |
# ----------------------------------------------------------------------- Store |
| |
|
| sub store { |
sub store { |
| my ($storehash,$symb,$namespace,$domain,$stuname) = @_; |
my ($storehash,$symb,$namespace,$domain,$stuname) = @_; |
| my $home=''; |
my $home=''; |
|
Line 2193 sub store {
|
Line 2269 sub store {
|
| if (!$stuname) { $stuname=$ENV{'user.name'}; } |
if (!$stuname) { $stuname=$ENV{'user.name'}; } |
| |
|
| &devalidate($symb,$stuname,$domain); |
&devalidate($symb,$stuname,$domain); |
| |
|
| $symb=escape($symb); |
$symb=escape($symb); |
| if (!$namespace) { |
if (!$namespace) { |
| unless ($namespace=$ENV{'request.course.id'}) { |
unless ($namespace=$ENV{'request.course.id'}) { |
|
Line 2229 sub cstore {
|
Line 2304 sub cstore {
|
| if (!$stuname) { $stuname=$ENV{'user.name'}; } |
if (!$stuname) { $stuname=$ENV{'user.name'}; } |
| |
|
| &devalidate($symb,$stuname,$domain); |
&devalidate($symb,$stuname,$domain); |
| |
|
| $symb=escape($symb); |
$symb=escape($symb); |
| if (!$namespace) { |
if (!$namespace) { |
| unless ($namespace=$ENV{'request.course.id'}) { |
unless ($namespace=$ENV{'request.course.id'}) { |
|
Line 2272 sub restore {
|
Line 2346 sub restore {
|
| if (!$domain) { $domain=$ENV{'user.domain'}; } |
if (!$domain) { $domain=$ENV{'user.domain'}; } |
| if (!$stuname) { $stuname=$ENV{'user.name'}; } |
if (!$stuname) { $stuname=$ENV{'user.name'}; } |
| if (!$home) { $home=$ENV{'user.home'}; } |
if (!$home) { $home=$ENV{'user.home'}; } |
| |
|
| my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home"); |
my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home"); |
| |
|
| my %returnhash=(); |
my %returnhash=(); |
|
Line 2644 sub put {
|
Line 2719 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 2723 sub allowed {
|
Line 2822 sub allowed {
|
| $uri=&deversion($uri); |
$uri=&deversion($uri); |
| my $orguri=$uri; |
my $orguri=$uri; |
| $uri=&declutter($uri); |
$uri=&declutter($uri); |
| |
|
| |
|
| |
|
| 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'; |
| } |
} |
| |
|
| # Free bre to public access |
# 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)) { |
| |
return 'F'; |
| |
} |
| |
|
| |
# Free bre to public access |
| if ($priv eq 'bre') { |
if ($priv eq 'bre') { |
| my $copyright=&metadata($uri,'copyright'); |
my $copyright=&metadata($uri,'copyright'); |
| if (($copyright eq 'public') && (!$ENV{'request.course.id'})) { |
if (($copyright eq 'public') && (!$ENV{'request.course.id'})) { |
|
Line 3132 sub log_query {
|
Line 3238 sub log_query {
|
| sub fetch_enrollment_query { |
sub fetch_enrollment_query { |
| my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_; |
my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_; |
| my $homeserver; |
my $homeserver; |
| my $maxtries = 1; |
|
| if ($context eq 'automated') { |
if ($context eq 'automated') { |
| $homeserver = $perlvar{'lonHostID'}; |
$homeserver = $perlvar{'lonHostID'}; |
| $maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout |
|
| } else { |
} else { |
| $homeserver = &homeserver($cnum,$dom); |
$homeserver = &homeserver($cnum,$dom); |
| } |
} |
|
Line 3148 sub fetch_enrollment_query {
|
Line 3252 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\_/) { |
| my $reply = &get_query_reply($queryid); |
&logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum); |
| my $tries = 1; |
return 'error: '.$queryid; |
| while (($reply=~/^timeout/) && ($tries < $maxtries)) { |
|
| $reply = &get_query_reply($queryid); |
|
| $tries++; |
|
| } |
} |
| |
my $reply = &get_query_reply($queryid); |
| if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { |
if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { |
| &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '. |
&logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$ENV{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum); |
| $ENV{'user.name'}.' for '.$queryid.' context: '.$context.' '. |
} else { |
| $cnum.' maxtries: '.$maxtries.' tries: '.$tries); |
|
| } |
|
| unless ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { |
|
| my @responses = split/:/,$reply; |
my @responses = split/:/,$reply; |
| if ($homeserver eq $perlvar{'lonHostID'}) { |
if ($homeserver eq $perlvar{'lonHostID'}) { |
| foreach (@responses) { |
foreach (@responses) { |
|
Line 3177 sub fetch_enrollment_query {
|
Line 3276 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 3690 sub revokecustomrole {
|
Line 3793 sub revokecustomrole {
|
| $deleteflag); |
$deleteflag); |
| } |
} |
| |
|
| |
# ------------------------------------------------------------ Disk usage |
| # ------------------------------------------------------------ Portfolio Director Lister |
sub diskusage { |
| # returns listing of contents of user's /userfiles/portfolio/ directory |
my ($udom,$uname,$directoryRoot)=@_; |
| # |
$directoryRoot =~ s/\/$//; |
| |
my $listing=&reply('du:'.$directoryRoot,homeserver($uname,$udom)); |
| sub portfoliolist { |
|
| my ($currentPath, $currentFile) = @_; |
|
| my ($udom, $uname, $portfolioRoot); |
|
| $uname=$ENV{'user.name'}; |
|
| $udom=$ENV{'user.domain'}; |
|
| # really should interrogate the system for home directory information, but . . . |
|
| $portfolioRoot = '/home/httpd/lonUsers/'.$udom.'/'; |
|
| $uname =~ /^(.?)(.?)(.?)/; |
|
| $portfolioRoot = $portfolioRoot.$1.'/'.$2.'/'.$3.'/'.$uname.'/userfiles/portfolio'; |
|
| my $listing = &reply('ls:'.$portfolioRoot.$currentPath, &homeserver($uname,$udom)); |
|
| return $listing; |
|
| } |
|
| |
|
| sub portfoliomanage { |
|
| |
|
| #FIXME please user the existing remove userfile function instead and |
|
| #add a userfilerename functions. |
|
| #FIXME uhome should never be an argument to any lonnet functions |
|
| |
|
| # handles deleting and renaming files in user's userfiles/portfolio/ directory |
|
| # |
|
| my ($filename, $fileaction, $filenewname) = @_; |
|
| my ($udom, $uname, $uhome); |
|
| $uname=$ENV{'user.name'}; |
|
| $udom=$ENV{'user.domain'}; |
|
| $uhome=$ENV{'user.home'}; |
|
| my $listing = reply('portfoliomanage:'.$uname.':'.$udom.':'.$filename.':'.$fileaction.':'.$filenewname, $uhome); |
|
| return $listing; |
return $listing; |
| } |
} |
| |
|
|
Line 4228 sub add_prefix_and_part {
|
Line 4304 sub add_prefix_and_part {
|
| |
|
| # ---------------------------------------------------------------- Get metadata |
# ---------------------------------------------------------------- Get metadata |
| |
|
| |
my %metaentry; |
| sub metadata { |
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 4245 sub metadata {
|
Line 4324 sub metadata {
|
| # Everything is cached by the main uri, libraries are never directly cached |
# Everything is cached by the main uri, libraries are never directly cached |
| # |
# |
| if (!defined($liburi)) { |
if (!defined($liburi)) { |
| my ($result,$cached)=&is_cached(\%metacache,$uri,'meta'); |
my ($result,$cached)=&is_cached_new($metacache,'meta',$uri); |
| if (defined($cached)) { return $result->{':'.$what}; } |
if (defined($cached)) { return $result->{':'.$what}; } |
| } |
} |
| { |
{ |
| # |
# |
| # Is this a recursive call for a library? |
# Is this a recursive call for a library? |
| # |
# |
| if (! exists($metacache{$uri})) { |
# if (! exists($metacache{$uri})) { |
| $metacache{$uri}={}; |
# $metacache{$uri}={}; |
| } |
# } |
| if ($liburi) { |
if ($liburi) { |
| $liburi=&declutter($liburi); |
$liburi=&declutter($liburi); |
| $filename=$liburi; |
$filename=$liburi; |
| } else { |
} else { |
| &devalidate_cache(\%metacache,$uri,'meta'); |
&devalidate_cache_new($metacache,'meta',$uri); |
| |
undef(%metaentry); |
| } |
} |
| my %metathesekeys=(); |
my %metathesekeys=(); |
| unless ($filename=~/\.meta$/) { $filename.='.meta'; } |
unless ($filename=~/\.meta$/) { $filename.='.meta'; } |
| my $metastring; |
my $metastring; |
| if ($uri !~ m|^uploaded/|) { |
if ($uri !~ m|^uploaded/|) { |
| my $file=&filelocation('',&clutter($filename)); |
my $file=&filelocation('',&clutter($filename)); |
| push(@{$metacache{$uri.'.file'}},$file); |
#push(@{$metaentry{$uri.'.file'}},$file); |
| $metastring=&getfile($file); |
$metastring=&getfile($file); |
| } |
} |
| my $parser=HTML::LCParser->new(\$metastring); |
my $parser=HTML::LCParser->new(\$metastring); |
|
Line 4283 sub metadata {
|
Line 4363 sub metadata {
|
| if (defined($token->[2]->{'id'})) { |
if (defined($token->[2]->{'id'})) { |
| $keyroot.='_'.$token->[2]->{'id'}; |
$keyroot.='_'.$token->[2]->{'id'}; |
| } |
} |
| if ($metacache{$uri}->{':packages'}) { |
if ($metaentry{':packages'}) { |
| $metacache{$uri}->{':packages'}.=','.$package.$keyroot; |
$metaentry{':packages'}.=','.$package.$keyroot; |
| } else { |
} else { |
| $metacache{$uri}->{':packages'}=$package.$keyroot; |
$metaentry{':packages'}=$package.$keyroot; |
| } |
} |
| foreach (keys %packagetab) { |
foreach (keys %packagetab) { |
| my $part=$keyroot; |
my $part=$keyroot; |
|
Line 4308 sub metadata {
|
Line 4388 sub metadata {
|
| if ($subp eq 'display') { |
if ($subp eq 'display') { |
| $value.=' [Part: '.$part.']'; |
$value.=' [Part: '.$part.']'; |
| } |
} |
| $metacache{$uri}->{':'.$unikey.'.part'}=$part; |
$metaentry{':'.$unikey.'.part'}=$part; |
| $metathesekeys{$unikey}=1; |
$metathesekeys{$unikey}=1; |
| unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) { |
unless (defined($metaentry{':'.$unikey.'.'.$subp})) { |
| $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value; |
$metaentry{':'.$unikey.'.'.$subp}=$value; |
| } |
} |
| if (defined($metacache{$uri}->{':'.$unikey.'.default'})) { |
if (defined($metaentry{':'.$unikey.'.default'})) { |
| $metacache{$uri}->{':'.$unikey}= |
$metaentry{':'.$unikey}= |
| $metacache{$uri}->{':'.$unikey.'.default'}; |
$metaentry{':'.$unikey.'.default'}; |
| } |
} |
| } |
} |
| } |
} |
|
Line 4348 sub metadata {
|
Line 4428 sub metadata {
|
| foreach (sort(split(/\,/,&metadata($uri,'keys', |
foreach (sort(split(/\,/,&metadata($uri,'keys', |
| $location,$unikey, |
$location,$unikey, |
| $depthcount+1)))) { |
$depthcount+1)))) { |
| $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_}; |
$metaentry{':'.$_}=$metaentry{':'.$_}; |
| $metathesekeys{$_}=1; |
$metathesekeys{$_}=1; |
| } |
} |
| } |
} |
|
Line 4359 sub metadata {
|
Line 4439 sub metadata {
|
| } |
} |
| $metathesekeys{$unikey}=1; |
$metathesekeys{$unikey}=1; |
| foreach (@{$token->[3]}) { |
foreach (@{$token->[3]}) { |
| $metacache{$uri}->{':'.$unikey.'.'.$_}=$token->[2]->{$_}; |
$metaentry{':'.$unikey.'.'.$_}=$token->[2]->{$_}; |
| } |
} |
| my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry)); |
my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry)); |
| my $default=$metacache{$uri}->{':'.$unikey.'.default'}; |
my $default=$metaentry{':'.$unikey.'.default'}; |
| if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) { |
if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) { |
| # only ws inside the tag, and not in default, so use default |
# only ws inside the tag, and not in default, so use default |
| # as value |
# as value |
| $metacache{$uri}->{':'.$unikey}=$default; |
$metaentry{':'.$unikey}=$default; |
| } else { |
} else { |
| # either something interesting inside the tag or default |
# either something interesting inside the tag or default |
| # uninteresting |
# uninteresting |
| $metacache{$uri}->{':'.$unikey}=$internaltext; |
$metaentry{':'.$unikey}=$internaltext; |
| } |
} |
| # end of not-a-package not-a-library import |
# end of not-a-package not-a-library import |
| } |
} |
|
Line 4387 sub metadata {
|
Line 4467 sub metadata {
|
| &metadata_create_package_def($uri,$key,'extension_'.$extension, |
&metadata_create_package_def($uri,$key,'extension_'.$extension, |
| \%metathesekeys); |
\%metathesekeys); |
| } |
} |
| if (!exists($metacache{$uri}->{':packages'})) { |
if (!exists($metaentry{':packages'})) { |
| foreach my $key (sort(keys(%packagetab))) { |
foreach my $key (sort(keys(%packagetab))) { |
| #no specific packages well let's get default then |
#no specific packages well let's get default then |
| if ($key!~/^default&/) { next; } |
if ($key!~/^default&/) { next; } |
|
Line 4396 sub metadata {
|
Line 4476 sub metadata {
|
| } |
} |
| } |
} |
| # are there custom rights to evaluate |
# are there custom rights to evaluate |
| if ($metacache{$uri}->{':copyright'} eq 'custom') { |
if ($metaentry{':copyright'} eq 'custom') { |
| |
|
| # |
# |
| # Importing a rights file here |
# Importing a rights file here |
| # |
# |
| unless ($depthcount) { |
unless ($depthcount) { |
| my $location=$metacache{$uri}->{':customdistributionfile'}; |
my $location=$metaentry{':customdistributionfile'}; |
| my $dir=$filename; |
my $dir=$filename; |
| $dir=~s|[^/]*$||; |
$dir=~s|[^/]*$||; |
| $location=&filelocation($dir,$location); |
$location=&filelocation($dir,$location); |
| foreach (sort(split(/\,/,&metadata($uri,'keys', |
foreach (sort(split(/\,/,&metadata($uri,'keys', |
| $location,'_rights', |
$location,'_rights', |
| $depthcount+1)))) { |
$depthcount+1)))) { |
| $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_}; |
#$metaentry{':'.$_}=$metacache{$uri}->{':'.$_}; |
| $metathesekeys{$_}=1; |
$metathesekeys{$_}=1; |
| } |
} |
| } |
} |
| } |
} |
| $metacache{$uri}->{':keys'}=join(',',keys %metathesekeys); |
$metaentry{':keys'}=join(',',keys %metathesekeys); |
| &metadata_generate_part0(\%metathesekeys,$metacache{$uri},$uri); |
&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); |
| $metacache{$uri}->{':allpossiblekeys'}=join(',',keys %metathesekeys); |
$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys); |
| &do_cache(\%metacache,$uri,$metacache{$uri},'meta'); |
&do_cache_new($metacache,'meta',$uri,\%metaentry); |
| # this is the end of "was not already recently cached |
# this is the end of "was not already recently cached |
| } |
} |
| return $metacache{$uri}->{':'.$what}; |
return $metaentry{':'.$what}; |
| } |
} |
| |
|
| sub metadata_create_package_def { |
sub metadata_create_package_def { |
|
Line 4428 sub metadata_create_package_def {
|
Line 4508 sub metadata_create_package_def {
|
| my ($pack,$name,$subp)=split(/\&/,$key); |
my ($pack,$name,$subp)=split(/\&/,$key); |
| if ($subp eq 'default') { next; } |
if ($subp eq 'default') { next; } |
| |
|
| if (defined($metacache{$uri}->{':packages'})) { |
if (defined($metaentry{':packages'})) { |
| $metacache{$uri}->{':packages'}.=','.$package; |
$metaentry{':packages'}.=','.$package; |
| } else { |
} else { |
| $metacache{$uri}->{':packages'}=$package; |
$metaentry{':packages'}=$package; |
| } |
} |
| my $value=$packagetab{$key}; |
my $value=$packagetab{$key}; |
| my $unikey; |
my $unikey; |
| $unikey='parameter_0_'.$name; |
$unikey='parameter_0_'.$name; |
| $metacache{$uri}->{':'.$unikey.'.part'}=0; |
$metaentry{':'.$unikey.'.part'}=0; |
| $$metathesekeys{$unikey}=1; |
$$metathesekeys{$unikey}=1; |
| unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) { |
unless (defined($metaentry{':'.$unikey.'.'.$subp})) { |
| $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value; |
$metaentry{':'.$unikey.'.'.$subp}=$value; |
| } |
} |
| if (defined($metacache{$uri}->{':'.$unikey.'.default'})) { |
if (defined($metaentry{':'.$unikey.'.default'})) { |
| $metacache{$uri}->{':'.$unikey}= |
$metaentry{':'.$unikey}= |
| $metacache{$uri}->{':'.$unikey.'.default'}; |
$metaentry{':'.$unikey.'.default'}; |
| } |
} |
| } |
} |
| |
|
|
Line 4480 sub metadata_generate_part0 {
|
Line 4560 sub metadata_generate_part0 {
|
| sub gettitle { |
sub gettitle { |
| my $urlsymb=shift; |
my $urlsymb=shift; |
| my $symb=&symbread($urlsymb); |
my $symb=&symbread($urlsymb); |
| unless ($symb) { |
if ($symb) { |
| unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; } |
my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600); |
| return &metadata($urlsymb,'title'); |
if (defined($cached)) { return $result; } |
| } |
my ($map,$resid,$url)=&decode_symb($symb); |
| my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600); |
my $title=''; |
| if (defined($cached)) { return $result; } |
my %bighash; |
| my ($map,$resid,$url)=&decode_symb($symb); |
if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', |
| my $title=''; |
&GDBM_READER(),0640)) { |
| my %bighash; |
my $mapid=$bighash{'map_pc_'.&clutter($map)}; |
| if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', |
$title=$bighash{'title_'.$mapid.'.'.$resid}; |
| &GDBM_READER(),0640)) { |
untie %bighash; |
| my $mapid=$bighash{'map_pc_'.&clutter($map)}; |
} |
| $title=$bighash{'title_'.$mapid.'.'.$resid}; |
$title=~s/\&colon\;/\:/gs; |
| untie %bighash; |
if ($title) { |
| } |
return &do_cache(\%titlecache,$symb,$title,'title'); |
| $title=~s/\&colon\;/\:/gs; |
} |
| if ($title) { |
$urlsymb=$url; |
| return &do_cache(\%titlecache,$symb,$title,'title'); |
} |
| } else { |
my $title=&metadata($urlsymb,'title'); |
| return &metadata($urlsymb,'title'); |
if (!$title) { $title=(split('/',$urlsymb))[-1]; } |
| } |
return $title; |
| } |
} |
| |
|
| # ------------------------------------------------- Update symbolic store links |
# ------------------------------------------------- Update symbolic store links |
|
Line 4978 sub receipt {
|
Line 5058 sub receipt {
|
| # the local server. |
# the local server. |
| |
|
| sub getfile { |
sub getfile { |
| my ($file,$caller) = @_; |
my ($file) = @_; |
| |
|
| if ($file !~ m|^/*uploaded/(\w+)/(\w+)/(.+)$|) { |
if ($file =~ m|^/*uploaded/|) { $file=&filelocation("",$file); } |
| # normal file from res space |
&repcopy($file); |
| &repcopy($file); |
return &readfile($file); |
| return &readfile($file); |
} |
| } |
|
| |
sub repcopy_userfile { |
| my $info; |
my ($file)=@_; |
| my $cdom = $1; |
|
| my $cnum = $2; |
if ($file =~ m|^/*uploaded/|) { $file=&filelocation("",$file); } |
| my $filename = $3; |
if ($file =~ m|^/home/httpd/html/lonUsers/|) { return OK; } |
| my $path = $Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles'; |
|
| my ($lwpresp,$rtncode); |
my ($cdom,$cnum,$filename) = |
| my $localfile = $path.'/'.$cdom.'/'.$cnum.'/'.$filename; |
($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+([^/]+)/+([^/]+)/+(.*)|); |
| if (-e "$localfile") { |
my ($info,$rtncode); |
| my @fileinfo = stat($localfile); |
my $uri="/uploaded/$cdom/$cnum/$filename"; |
| $lwpresp = &getuploaded('HEAD',$file,$cdom,$cnum,\$info,\$rtncode); |
if (-e "$file") { |
| |
my @fileinfo = stat($file); |
| |
my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode); |
| if ($lwpresp ne 'ok') { |
if ($lwpresp ne 'ok') { |
| if ($rtncode eq '404') { |
if ($rtncode eq '404') { |
| unlink($localfile); |
unlink($file); |
| } |
} |
| #my $ua=new LWP::UserAgent; |
#my $ua=new LWP::UserAgent; |
| #my $request=new HTTP::Request('GET',&tokenwrapper($file)); |
#my $request=new HTTP::Request('GET',&tokenwrapper($uri)); |
| #my $response=$ua->request($request); |
#my $response=$ua->request($request); |
| #if ($response->is_success()) { |
#if ($response->is_success()) { |
| # return $response->content; |
# return $response->content; |
|
Line 5011 sub getfile {
|
Line 5093 sub getfile {
|
| return -1; |
return -1; |
| } |
} |
| if ($info < $fileinfo[9]) { |
if ($info < $fileinfo[9]) { |
| return &readfile($localfile); |
return OK; |
| } |
} |
| $info = ''; |
$info = ''; |
| $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode); |
$lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode); |
| if ($lwpresp ne 'ok') { |
if ($lwpresp ne 'ok') { |
| return -1; |
return -1; |
| } |
} |
| } else { |
} else { |
| $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode); |
my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode); |
| if ($lwpresp ne 'ok') { |
if ($lwpresp ne 'ok') { |
| my $ua=new LWP::UserAgent; |
my $ua=new LWP::UserAgent; |
| my $request=new HTTP::Request('GET',&tokenwrapper($file)); |
my $request=new HTTP::Request('GET',&tokenwrapper($uri)); |
| my $response=$ua->request($request); |
my $response=$ua->request($request); |
| if ($response->is_success()) { |
if ($response->is_success()) { |
| return $response->content; |
$info=$response->content; |
| } else { |
} else { |
| return -1; |
return -1; |
| } |
} |
|
Line 5034 sub getfile {
|
Line 5116 sub getfile {
|
| if ($filename =~ m|^(.+)/[^/]+$|) { |
if ($filename =~ m|^(.+)/[^/]+$|) { |
| push @parts, split(/\//,$1); |
push @parts, split(/\//,$1); |
| } |
} |
| |
my $path = $perlvar{'lonDocRoot'}.'/userfiles'; |
| foreach my $part (@parts) { |
foreach my $part (@parts) { |
| $path .= '/'.$part; |
$path .= '/'.$part; |
| if (!-e $path) { |
if (!-e $path) { |
|
Line 5041 sub getfile {
|
Line 5124 sub getfile {
|
| } |
} |
| } |
} |
| } |
} |
| open (FILE,">$localfile"); |
open(FILE,">$file"); |
| print FILE $info; |
print FILE $info; |
| close(FILE); |
close(FILE); |
| if ($caller eq 'uploadrep') { |
return OK; |
| return 'ok'; |
|
| } |
|
| return $info; |
|
| } |
} |
| |
|
| sub tokenwrapper { |
sub tokenwrapper { |
|
Line 5103 sub filelocation {
|
Line 5183 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; |
my ($udom,$uname,$filename)= |
| |
($file=~m|^/+uploaded/+([^/]+)/+([^/]+)/+(.*)$|); |
| |
my $home=&homeserver($uname,$udom); |
| |
my $is_me=0; |
| |
my @ids=¤t_machine_ids(); |
| |
foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } } |
| |
if ($is_me) { |
| |
$location=&Apache::loncommon::propath($udom,$uname). |
| |
'/userfiles/'.$filename; |
| |
} else { |
| |
$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'. |
| |
$udom.'/'.$uname.'/'.$filename; |
| |
} |
| } else { |
} else { |
| $file=~s/^\Q$perlvar{'lonDocRoot'}\E//; |
$file=~s/^\Q$perlvar{'lonDocRoot'}\E//; |
| $file=~s:^/res/:/:; |
$file=~s:^/res/:/:; |
|
Line 5214 sub goodbye {
|
Line 5306 sub goodbye {
|
| #not converted to using infrastruture and probably shouldn't be |
#not converted to using infrastruture and probably shouldn't be |
| &logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache))); |
&logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache))); |
| #converted |
#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",'%homecache',scalar(%homecache))); |
| &logthis(sprintf("%-20s is %s",'%titlecache',scalar(%titlecache))); |
&logthis(sprintf("%-20s is %s",'%titlecache',scalar(%titlecache))); |
| &logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache))); |
&logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache))); |
|
Line 5299 BEGIN {
|
Line 5391 BEGIN {
|
| $hostip{$id}=$ip; |
$hostip{$id}=$ip; |
| $iphost{$ip}=$id; |
$iphost{$ip}=$id; |
| if ($role eq 'library') { $libserv{$id}=$name; } |
if ($role eq 'library') { $libserv{$id}=$name; } |
| } else { |
|
| if ($configline) { |
|
| &logthis("Skipping hosts.tab line -$configline-"); |
|
| } |
|
| } |
} |
| } |
} |
| close($config); |
close($config); |
|
Line 5371 BEGIN {
|
Line 5459 BEGIN {
|
| |
|
| } |
} |
| |
|
| %metacache=(); |
$metacache=new Cache::Memcached({'servers'=>['127.0.0.1:11211']}); |
| |
|
| $processmarker='_'.time.'_'.$perlvar{'lonHostID'}; |
$processmarker='_'.time.'_'.$perlvar{'lonHostID'}; |
| $dumpcount=0; |
$dumpcount=0; |
|
Line 5994 put($namespace,$storehash,$udom,$uname)
|
Line 6082 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) |
| |
|
![[BACK]](/icons/back.gif){kind=icon}
Return to lonnet.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / lonnet / perl