loncom/lonnet/perl/lonnet.pm - diff

Return to lonnet.pm CVS log

Up to [LON-CAPA] / loncom / lonnet / perl

Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.587.2.3.2.3 and 1.587.2.3.2.16

version 1.587.2.3.2.3, 2005/02/13 23:09:03	version 1.587.2.3.2.16, 2005/04/15 20:48:18
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 $memcache %packagetab %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	%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 559 sub authenticate {	Line 559 sub authenticate {

# ---------------------- Find the homebase for a user from domain's lib servers	# ---------------------- Find the homebase for a user from domain's lib servers

	my %homecache;
sub homeserver {	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);	if (exists($homecache{$index})) { return $homecache{$index}; }
if (defined($cached)) { return $result; }
my $tryserver;	my $tryserver;
foreach $tryserver (keys %libserv) {	foreach $tryserver (keys %libserv) {
next if ($ignoreBadCache ne 'true' &&	next if ($ignoreBadCache ne 'true' &&
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 $homecache{$index}=$tryserver;
} elsif ($answer eq 'no_host') {	} elsif ($answer eq 'no_host') {
$badServerCache{$tryserver}=1;	$badServerCache{$tryserver}=1;
}	}
Line 777 sub validate_access_key {	Line 777 sub validate_access_key {

sub getsection {	sub getsection {
my ($udom,$unam,$courseid)=@_;	my ($udom,$unam,$courseid)=@_;
	my $cachetime=1800;
$courseid=~s/\_/\//g;	$courseid=~s/\_/\//g;
$courseid=~s/^(\w)/\/$1/;	$courseid=~s/^(\w)/\/$1/;

my $hashid="$udom:$unam:$courseid";	my $hashid="$udom:$unam:$courseid";
my ($result,$cached)=&is_cached(\%getsectioncache,$hashid,'getsection');	my ($result,$cached)=&is_cached_new('getsection',$hashid);
if (defined($cached)) { return $result; }	if (defined($cached)) { return $result; }

my %Pending;	my %Pending;
Line 816 sub getsection {	Line 817 sub getsection {
$Pending{$start}=$section;	$Pending{$start}=$section;
next;	next;
}	}
return &do_cache(\%getsectioncache,$hashid,$section,'getsection');	return &do_cache_new('getsection',$hashid,$section,$cachetime);
}	}
#	#
# Presumedly there will be few matching roles from the above	# Presumedly there will be few matching roles from the above
# loop and the sorting time will be negligible.	# loop and the sorting time will be negligible.
if (scalar(keys(%Pending))) {	if (scalar(keys(%Pending))) {
my ($time) = sort {$a <=> $b} keys(%Pending);	my ($time) = sort {$a <=> $b} keys(%Pending);
return &do_cache(\%getsectioncache,$hashid,$Pending{$time},'getsection');	return &do_cache_new('getsection',$hashid,$Pending{$time},$cachetime);
}	}
if (scalar(keys(%Expired))) {	if (scalar(keys(%Expired))) {
my @sorted = sort {$a <=> $b} keys(%Expired);	my @sorted = sort {$a <=> $b} keys(%Expired);
my $time = pop(@sorted);	my $time = pop(@sorted);
return &do_cache(\%getsectioncache,$hashid,$Expired{$time},'getsection');	return &do_cache_new('getsection',$hashid,$Expired{$time},$cachetime);
}	}
return &do_cache(\%getsectioncache,$hashid,'-1','getsection');	return &do_cache_new('getsection',$hashid,'-1',$cachetime);
}	}


Line 1022 EVALBLOCK	Line 1023 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 $to_remember=-1;
my ($name,$id) = @_;
if (1) { &Apache::lonnet::logthis("deleting $name:$id"); }
$memcache->delete(&escape($name.':'.$id));
}

my $to_remember=10;
my %remembered;	my %remembered;
my %accessed;	my %accessed;
my $kicks=0;	my $kicks=0;
my $hits=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 ($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} "); }
Line 1048 sub is_cached_new {	Line 1051 sub is_cached_new {
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);
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);	$value=undef;
}	}
	&make_room($id,$value,$debug);
if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); }	if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); }
return ($value,1);	return ($value,1);
}	}

sub do_cache_new {	sub do_cache_new {
my ($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 (!defined($time)) {
	$time=600;
	}
if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }	if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }
$memcache->set($id,$setvalue,300);	$memcache->set($id,$setvalue,$time);
	#&make_room($id,$value,$debug);
return $value;	return $value;
}	}

sub make_room {	sub make_room {
my ($id,$value)=@_;	my ($id,$value,$debug)=@_;
my $debug=0;
$remembered{$id}=$value;	$remembered{$id}=$value;
	if ($to_remember<0) { return; }
$accessed{$id}=[&gettimeofday()];	$accessed{$id}=[&gettimeofday()];
if (scalar(keys(%remembered)) <= $to_remember) { return; }	if (scalar(keys(%remembered)) <= $to_remember) { return; }
my $to_kick;	my $to_kick;
Line 1093 sub make_room {	Line 1099 sub make_room {

sub purge_remembered {	sub purge_remembered {
&logthis("Tossing ".scalar(keys(%remembered)));	&logthis("Tossing ".scalar(keys(%remembered)));
	&logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered))));
undef(%remembered);	undef(%remembered);
undef(%accessed);	undef(%accessed);
}	}
Line 1133 sub getversion {	Line 1140 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 1146 sub currentversion {	Line 1153 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 4198 sub condval {	Line 4205 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 4207 sub courseresdata {	Line 4214 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 4407 sub EXT {	Line 4414 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,600);
}	}
my ($tmp)=keys(%$result);	my ($tmp)=keys(%$result);
if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {	if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {
Line 4733 sub metadata {	Line 4739 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('meta',$uri,\%metaentry);	&do_cache_new('meta',$uri,\%metaentry,6000);
# 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 4797 sub gettitle {	Line 4803 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_new('title',$symb);	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 4812 sub gettitle {	Line 4819 sub gettitle {
}	}
$title=~s/\&colon\;/\:/gs;	$title=~s/\&colon\;/\:/gs;
if ($title) {	if ($title) {
return &do_cache_new('title',$symb,$title,600);	return &do_cache_new('title',$key,$title,600);
}	}
$urlsymb=$url;	$urlsymb=$url;
}	}
Line 4926 sub fixversion {	Line 4933 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 4941 sub fixversion {	Line 4947 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 5654 sub goodbye {	Line 5659 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));	&logthis(sprintf("%-20s is %s",'hits',$hits));

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>

Removed from v.1.587.2.3.2.3
changed lines
	Added in v.1.587.2.3.2.16