|
version 1.587.2.3.2.1, 2005/02/10 08:16:31
|
version 1.587.2.3.2.10, 2005/02/14 04:26:29
|
|
Line 35 use HTTP::Headers;
|
Line 35 use HTTP::Headers;
|
| use HTTP::Date; |
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 %badServerCache %hostip %iphost %spareid %hostdom |
| %libserv %pr %prp $metacache %packagetab %titlecache %courseresversioncache %resversioncache |
%libserv %pr %prp $memcache %packagetab |
| %courselogs %accesshash %userrolehash $processmarker $dumpcount |
%courselogs %accesshash %userrolehash $processmarker $dumpcount |
| %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %courseresdatacache |
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf |
| %userresdatacache %getsectioncache %domaindescription %domain_auth_def %domain_auth_arg_def |
%getsectioncache %domaindescription %domain_auth_def %domain_auth_arg_def |
| %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit); |
%domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit); |
| |
|
| use IO::Socket; |
use IO::Socket; |
|
Line 563 sub homeserver {
|
Line 563 sub homeserver {
|
| my ($uname,$udom,$ignoreBadCache)=@_; |
my ($uname,$udom,$ignoreBadCache)=@_; |
| my $index="$uname:$udom"; |
my $index="$uname:$udom"; |
| |
|
| my ($result,$cached)=&is_cached(\%homecache,$index,'home',86400); |
my ($result,$cached)=&is_cached_new('home',$index); |
| if (defined($cached)) { return $result; } |
if (defined($cached)) { return $result; } |
| my $tryserver; |
my $tryserver; |
| foreach $tryserver (keys %libserv) { |
foreach $tryserver (keys %libserv) { |
|
Line 572 sub homeserver {
|
Line 572 sub homeserver {
|
| if ($hostdom{$tryserver} eq $udom) { |
if ($hostdom{$tryserver} eq $udom) { |
| my $answer=reply("home:$udom:$uname",$tryserver); |
my $answer=reply("home:$udom:$uname",$tryserver); |
| if ($answer eq 'found') { |
if ($answer eq 'found') { |
| return &do_cache(\%homecache,$index,$tryserver,'home'); |
return &do_cache_new('home',$index,$tryserver,86400); |
| } elsif ($answer eq 'no_host') { |
} elsif ($answer eq 'no_host') { |
| $badServerCache{$tryserver}=1; |
$badServerCache{$tryserver}=1; |
| } |
} |
|
Line 924 sub save_cache_item {
|
Line 924 sub save_cache_item {
|
| } |
} |
| |
|
| sub save_cache { |
sub save_cache { |
| |
&purge_remembered(); |
| if ($disk_caching_disabled) { return; } |
if ($disk_caching_disabled) { return; } |
| my ($cache,$name,$id); |
my ($cache,$name,$id); |
| foreach $name (keys(%do_save)) { |
foreach $name (keys(%do_save)) { |
|
Line 1021 EVALBLOCK
|
Line 1022 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 (1) { &Apache::lonnet::logthis("deleting $name:$id"); } |
|
| $cache->delete(&escape($name.':'.$id)); |
|
| } |
|
| |
|
| my $to_remember=10; |
my $to_remember=10; |
| my %remembered; |
my %remembered; |
| my %accessed; |
my %accessed; |
| |
my $kicks=0; |
| |
my $hits=0; |
| |
sub devalidate_cache_new { |
| |
my ($name,$id,$debug) = @_; |
| |
if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); } |
| |
$id=&escape($name.':'.$id); |
| |
$memcache->delete($id); |
| |
delete($remembered{$id}); |
| |
delete($accessed{$id}); |
| |
} |
| |
|
| sub is_cached_new { |
sub is_cached_new { |
| my ($cache,$name,$id,$debug) = @_; |
my ($name,$id,$debug) = @_; |
| $debug=0; |
|
| $id=&escape($name.':'.$id); |
$id=&escape($name.':'.$id); |
| if (exists($remembered{$id})) { |
if (exists($remembered{$id})) { |
| if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); } |
if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); } |
| $accessed{$id}=[&gettimeofday()]; |
$accessed{$id}=[&gettimeofday()]; |
| |
$hits++; |
| return ($remembered{$id},1); |
return ($remembered{$id},1); |
| } |
} |
| my $value = $cache->get($id); |
my $value = $memcache->get($id); |
| if (!(defined($value))) { |
if (!(defined($value))) { |
| if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); } |
if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); } |
| return (undef,undef); |
return (undef,undef); |
| } |
} |
| &make_room($id,$value); |
&make_room($id,$value,$debug); |
| if ($value eq '__undef__') { |
if ($value eq '__undef__') { |
| if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); } |
if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); } |
| return (undef,1); |
return (undef,1); |
|
Line 1054 sub is_cached_new {
|
Line 1060 sub is_cached_new {
|
| } |
} |
| |
|
| sub do_cache_new { |
sub do_cache_new { |
| my ($cache,$name,$id,$value,$time,$debug) = @_; |
my ($name,$id,$value,$time,$debug) = @_; |
| $debug=0; |
|
| $id=&escape($name.':'.$id); |
$id=&escape($name.':'.$id); |
| my $setvalue=$value; |
my $setvalue=$value; |
| if (!defined($setvalue)) { |
if (!defined($setvalue)) { |
| $setvalue='__undef__'; |
$setvalue='__undef__'; |
| } |
} |
| if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); } |
if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); } |
| $cache->set($id,$setvalue,300); |
$memcache->set($id,$setvalue,300); |
| |
&make_room($id,$value,$debug); |
| return $value; |
return $value; |
| } |
} |
| |
|
| my $kicks=0; |
|
| sub make_room { |
sub make_room { |
| my ($id,$value)=@_; |
my ($id,$value,$debug)=@_; |
| my $debug=0; |
|
| $remembered{$id}=$value; |
$remembered{$id}=$value; |
| $accessed{$id}=[&gettimeofday()]; |
$accessed{$id}=[&gettimeofday()]; |
| if (scalar(keys(%remembered)) <= $to_remember) { return; } |
if (scalar(keys(%remembered)) <= $to_remember) { return; } |
|
Line 1088 sub make_room {
|
Line 1092 sub make_room {
|
| return; |
return; |
| } |
} |
| |
|
| |
sub purge_remembered { |
| |
&logthis("Tossing ".scalar(keys(%remembered))); |
| |
undef(%remembered); |
| |
undef(%accessed); |
| |
} |
| # ------------------------------------- Read an entry from a user's environment |
# ------------------------------------- Read an entry from a user's environment |
| |
|
| sub userenvironment { |
sub userenvironment { |
|
Line 1125 sub getversion {
|
Line 1134 sub getversion {
|
| |
|
| sub currentversion { |
sub currentversion { |
| my $fname=shift; |
my $fname=shift; |
| my ($result,$cached)=&is_cached(\%resversioncache,$fname,'resversion',600); |
my ($result,$cached)=&is_cached_new('resversion',$fname); |
| if (defined($cached)) { return $result; } |
if (defined($cached)) { return $result; } |
| my $author=$fname; |
my $author=$fname; |
| $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; |
$author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; |
|
Line 1138 sub currentversion {
|
Line 1147 sub currentversion {
|
| if (($answer eq 'con_lost') || ($answer eq 'rejected')) { |
if (($answer eq 'con_lost') || ($answer eq 'rejected')) { |
| return -1; |
return -1; |
| } |
} |
| return &do_cache(\%resversioncache,$fname,$answer,'resversion'); |
return &do_cache_new('resversion',$fname,$answer,600); |
| } |
} |
| |
|
| # ----------------------------- Subscribe to a resource, return URL if possible |
# ----------------------------- Subscribe to a resource, return URL if possible |
|
Line 4190 sub condval {
|
Line 4199 sub condval {
|
| sub devalidatecourseresdata { |
sub devalidatecourseresdata { |
| my ($coursenum,$coursedomain)=@_; |
my ($coursenum,$coursedomain)=@_; |
| my $hashid=$coursenum.':'.$coursedomain; |
my $hashid=$coursenum.':'.$coursedomain; |
| &devalidate_cache(\%courseresdatacache,$hashid,'courseres'); |
&devalidate_cache_new('courseres',$hashid); |
| } |
} |
| |
|
| # --------------------------------------------------- Course Resourcedata Query |
# --------------------------------------------------- Course Resourcedata Query |
|
Line 4199 sub courseresdata {
|
Line 4208 sub courseresdata {
|
| my ($coursenum,$coursedomain,@which)=@_; |
my ($coursenum,$coursedomain,@which)=@_; |
| my $coursehom=&homeserver($coursenum,$coursedomain); |
my $coursehom=&homeserver($coursenum,$coursedomain); |
| my $hashid=$coursenum.':'.$coursedomain; |
my $hashid=$coursenum.':'.$coursedomain; |
| my ($result,$cached)=&is_cached(\%courseresdatacache,$hashid,'courseres'); |
my ($result,$cached)=&is_cached_new('courseres',$hashid); |
| unless (defined($cached)) { |
unless (defined($cached)) { |
| my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum); |
my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum); |
| $result=\%dumpreply; |
$result=\%dumpreply; |
| my ($tmp) = keys(%dumpreply); |
my ($tmp) = keys(%dumpreply); |
| if ($tmp !~ /^(con_lost|error|no_such_host)/i) { |
if ($tmp !~ /^(con_lost|error|no_such_host)/i) { |
| &do_cache(\%courseresdatacache,$hashid,$result,'courseres'); |
&do_cache_new('courseres',$hashid,$result,600); |
| } elsif ($tmp =~ /^(con_lost|no_such_host)/) { |
} elsif ($tmp =~ /^(con_lost|no_such_host)/) { |
| return $tmp; |
return $tmp; |
| } elsif ($tmp =~ /^(error)/) { |
} elsif ($tmp =~ /^(error)/) { |
| $result=undef; |
$result=undef; |
| &do_cache(\%courseresdatacache,$hashid,$result,'courseres'); |
&do_cache_new('courseres',$hashid,$result,600); |
| } |
} |
| } |
} |
| foreach my $item (@which) { |
foreach my $item (@which) { |
|
Line 4399 sub EXT {
|
Line 4408 sub EXT {
|
| #most student don\'t have any data set, check if there is some data |
#most student don\'t have any data set, check if there is some data |
| if (! &EXT_cache_status($udom,$uname)) { |
if (! &EXT_cache_status($udom,$uname)) { |
| my $hashid="$udom:$uname"; |
my $hashid="$udom:$uname"; |
| my ($result,$cached)=&is_cached(\%userresdatacache,$hashid, |
my ($result,$cached)=&is_cached_new('userres',$hashid); |
| 'userres'); |
|
| if (!defined($cached)) { |
if (!defined($cached)) { |
| my %resourcedata=&dump('resourcedata',$udom,$uname); |
my %resourcedata=&dump('resourcedata',$udom,$uname); |
| $result=\%resourcedata; |
$result=\%resourcedata; |
| &do_cache(\%userresdatacache,$hashid,$result,'userres'); |
&do_cache_new('userres',$hashid,$result); |
| } |
} |
| my ($tmp)=keys(%$result); |
my ($tmp)=keys(%$result); |
| if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) { |
if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) { |
|
Line 4552 sub metadata {
|
Line 4560 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_new($metacache,'meta',$uri); |
my ($result,$cached)=&is_cached_new('meta',$uri); |
| if (defined($cached)) { return $result->{':'.$what}; } |
if (defined($cached)) { return $result->{':'.$what}; } |
| } |
} |
| { |
{ |
|
Line 4566 sub metadata {
|
Line 4574 sub metadata {
|
| $liburi=&declutter($liburi); |
$liburi=&declutter($liburi); |
| $filename=$liburi; |
$filename=$liburi; |
| } else { |
} else { |
| &devalidate_cache_new($metacache,'meta',$uri); |
&devalidate_cache_new('meta',$uri); |
| undef(%metaentry); |
undef(%metaentry); |
| } |
} |
| my %metathesekeys=(); |
my %metathesekeys=(); |
|
Line 4725 sub metadata {
|
Line 4733 sub metadata {
|
| $metaentry{':keys'}=join(',',keys %metathesekeys); |
$metaentry{':keys'}=join(',',keys %metathesekeys); |
| &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); |
&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); |
| $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys); |
$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys); |
| &do_cache_new($metacache,'meta',$uri,\%metaentry); |
&do_cache_new('meta',$uri,\%metaentry); |
| # this is the end of "was not already recently cached |
# this is the end of "was not already recently cached |
| } |
} |
| return $metaentry{':'.$what}; |
return $metaentry{':'.$what}; |
|
Line 4789 sub gettitle {
|
Line 4797 sub gettitle {
|
| my $urlsymb=shift; |
my $urlsymb=shift; |
| my $symb=&symbread($urlsymb); |
my $symb=&symbread($urlsymb); |
| if ($symb) { |
if ($symb) { |
| my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600); |
my $key=$ENV{'request.course.id'}."\0".$symb; |
| |
my ($result,$cached)=&is_cached_new('title',$key); |
| if (defined($cached)) { |
if (defined($cached)) { |
| return $result; |
return $result; |
| } |
} |
|
Line 4804 sub gettitle {
|
Line 4813 sub gettitle {
|
| } |
} |
| $title=~s/\&colon\;/\:/gs; |
$title=~s/\&colon\;/\:/gs; |
| if ($title) { |
if ($title) { |
| return &do_cache(\%titlecache,$symb,$title,'title'); |
return &do_cache_new('title',$key,$title,600); |
| } |
} |
| $urlsymb=$url; |
$urlsymb=$url; |
| } |
} |
|
Line 4918 sub fixversion {
|
Line 4927 sub fixversion {
|
| my $uri=&clutter($fn); |
my $uri=&clutter($fn); |
| my $key=$ENV{'request.course.id'}.'_'.$uri; |
my $key=$ENV{'request.course.id'}.'_'.$uri; |
| # is this cached? |
# is this cached? |
| my ($result,$cached)=&is_cached(\%courseresversioncache,$key, |
my ($result,$cached)=&is_cached_new('courseresversion',$key); |
| 'courseresversion',600); |
|
| if (defined($cached)) { return $result; } |
if (defined($cached)) { return $result; } |
| # unfortunately not cached, or expired |
# unfortunately not cached, or expired |
| if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', |
if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', |
|
Line 4933 sub fixversion {
|
Line 4941 sub fixversion {
|
| } |
} |
| untie %bighash; |
untie %bighash; |
| } |
} |
| return &do_cache |
return &do_cache_new('courseresversion',$key,&declutter($uri),600); |
| (\%courseresversioncache,$key,&declutter($uri),'courseresversion'); |
|
| } |
} |
| |
|
| sub deversion { |
sub deversion { |
|
Line 5646 sub goodbye {
|
Line 5653 sub goodbye {
|
| &logthis(sprintf("%-20s is %s",'%badServerCache',length(&freeze(\%badServerCache)))); |
&logthis(sprintf("%-20s is %s",'%badServerCache',length(&freeze(\%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',length(&freeze(\%homecache)))); |
# &logthis(sprintf("%-20s is %s",'%homecache',length(&freeze(\%homecache)))); |
| &logthis(sprintf("%-20s is %s",'%titlecache',length(&freeze(\%titlecache)))); |
# &logthis(sprintf("%-20s is %s",'%titlecache',length(&freeze(\%titlecache)))); |
| &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&freeze(\%courseresdatacache)))); |
# &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&freeze(\%courseresdatacache)))); |
| #1.1 only |
#1.1 only |
| &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&freeze(\%userresdatacache)))); |
# &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&freeze(\%userresdatacache)))); |
| &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&freeze(\%getsectioncache)))); |
&logthis(sprintf("%-20s is %s",'%getsectioncache',length(&freeze(\%getsectioncache)))); |
| &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&freeze(\%courseresversioncache)))); |
# &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&freeze(\%courseresversioncache)))); |
| &logthis(sprintf("%-20s is %s",'%resversioncache',length(&freeze(\%resversioncache)))); |
# &logthis(sprintf("%-20s is %s",'%resversioncache',length(&freeze(\%resversioncache)))); |
| &logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered)))); |
&logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered)))); |
| &logthis(sprintf("%-20s is %s",'kicks',$kicks)); |
&logthis(sprintf("%-20s is %s",'kicks',$kicks)); |
| |
&logthis(sprintf("%-20s is %s",'hits',$hits)); |
| &flushcourselogs(); |
&flushcourselogs(); |
| &logthis("Shutting down"); |
&logthis("Shutting down"); |
| return DONE; |
return DONE; |
|
Line 5801 BEGIN {
|
Line 5809 BEGIN {
|
| |
|
| } |
} |
| |
|
| $metacache=new Cache::Memcached({'servers'=>['127.0.0.1:11211']}); |
$memcache=new Cache::Memcached({'servers'=>['127.0.0.1:11211']}); |
| |
|
| $processmarker='_'.time.'_'.$perlvar{'lonHostID'}; |
$processmarker='_'.time.'_'.$perlvar{'lonHostID'}; |
| $dumpcount=0; |
$dumpcount=0; |
![[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