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.430 and 1.435

version 1.430, 2003/10/12 22:02:44	version 1.435, 2003/10/30 00:26:25
Line 25	Line 25
#	#
# http://www.lon-capa.org/	# http://www.lon-capa.org/
#	#
# 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30,
# 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19,
# 11/8,11/16,11/18,11/22,11/23,12/22,
# 01/06,01/13,02/24,02/28,02/29,
# 03/01,03/02,03/06,03/07,03/13,
# 04/05,05/29,05/31,06/01,
# 06/05,06/26 Gerd Kortemeyer
# 06/26 Ben Tyszka
# 06/30,07/15,07/17,07/18,07/20,07/21,07/22,07/25 Gerd Kortemeyer
# 08/14 Ben Tyszka
# 08/22,08/28,08/31,09/01,09/02,09/04,09/05,09/25,09/28,09/30 Gerd Kortemeyer
# 10/04 Gerd Kortemeyer
# 10/04 Guy Albertelli
# 10/06,10/09,10/10,10/11,10/14,10/20,10/23,10/25,10/26,10/27,10/28,10/29,
# 10/30,10/31,
# 11/2,11/14,11/15,11/16,11/20,11/21,11/22,11/25,11/27,
# 12/02,12/12,12/13,12/14,12/28,12/29 Gerd Kortemeyer
# 05/01/01 Guy Albertelli
# 05/01,06/01,09/01 Gerd Kortemeyer
# 09/01 Guy Albertelli
# 09/01,10/01,11/01 Gerd Kortemeyer
# YEAR=2001
# 3/2 Gerd Kortemeyer
# 3/19,3/20 Gerd Kortemeyer
# 5/26,5/28 Gerd Kortemeyer
# 5/30 H. K. Ng
# 6/1 Gerd Kortemeyer
# July Guy Albertelli
# 8/4,8/7,8/8,8/9,8/11,8/16,8/17,8/18,8/20,8/23,9/20,9/21,9/26,
# 10/2 Gerd Kortemeyer
# 11/17,11/20,11/22,11/29 Gerd Kortemeyer
# 12/5 Matthew Hall
# 12/5 Guy Albertelli
# 12/6,12/7,12/12 Gerd Kortemeyer
# 12/21,12/22,12/27,12/28 Gerd Kortemeyer
# YEAR=2002
# 1/4,2/4,2/7 Gerd Kortemeyer
#
###	###

package Apache::lonnet;	package Apache::lonnet;
Line 274 sub transfer_profile_to_env {	Line 236 sub transfer_profile_to_env {
$idf->close();	$idf->close();
}	}
my $envi;	my $envi;
	my %Remove;
for ($envi=0;$envi<=$#profile;$envi++) {	for ($envi=0;$envi<=$#profile;$envi++) {
chomp($profile[$envi]);	chomp($profile[$envi]);
my ($envname,$envvalue)=split(/=/,$profile[$envi]);	my ($envname,$envvalue)=split(/=/,$profile[$envi]);
$ENV{$envname} = $envvalue;	$ENV{$envname} = $envvalue;
	if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
	if ($time < time-300) {
	$Remove{$key}++;
	}
	}
	}
	foreach my $expired_key (keys(%Remove)) {
	&delenv($expired_key);
}	}
$ENV{'user.environment'} = "$lonidsdir/$handle.id";	$ENV{'user.environment'} = "$lonidsdir/$handle.id";
}	}
Line 860 sub devalidate_cache {	Line 831 sub devalidate_cache {
delete($hash{$id});	delete($hash{$id});
delete($hash{$id.'.time'});	delete($hash{$id.'.time'});
} else {	} else {
&logthis("Unable to tie hash");	&logthis("Unable to tie hash (devalidate cache): $name");
}	}
untie(%hash);	untie(%hash);
flock(DB,LOCK_UN);	flock(DB,LOCK_UN);
Line 878 sub is_cached {	Line 849 sub is_cached {
return (undef,undef);	return (undef,undef);
} else {	} else {
if (time-($$cache{$id.'.time'})>$time) {	if (time-($$cache{$id.'.time'})>$time) {
# &logthis("Devailidating $id - ".time-($$cache{$id.'.time'}));	# &logthis("Devalidating $id - ".time-($$cache{$id.'.time'}));
&devalidate_cache($cache,$id,$name);	&devalidate_cache($cache,$id,$name);
return (undef,undef);	return (undef,undef);
}	}
Line 958 sub save_cache_item {	Line 929 sub save_cache_item {
$hash{$id.'.time'}=$$cache{$id.'.time'};	$hash{$id.'.time'}=$$cache{$id.'.time'};
$hash{$id}=freeze({'item'=>$$cache{$id}});	$hash{$id}=freeze({'item'=>$$cache{$id}});
} else {	} else {
&logthis("Unable to tie hash");	&logthis("Unable to tie hash (save cache item): $name");
}	}
untie(%hash);	untie(%hash);
flock(DB,LOCK_UN);	flock(DB,LOCK_UN);
Line 993 sub load_cache_item {	Line 964 sub load_cache_item {
$$cache{$id.'.time'}=$hash{$id.'.time'};	$$cache{$id.'.time'}=$hash{$id.'.time'};
}	}
} else {	} else {
&logthis("Unable to tie hash");	&logthis("Unable to tie hash (load cache item): $name");
}	}
untie(%hash);	untie(%hash);
flock(DB,LOCK_UN);	flock(DB,LOCK_UN);
Line 2763 sub allowed {	Line 2734 sub allowed {

sub is_on_map {	sub is_on_map {
my $uri=&declutter(shift);	my $uri=&declutter(shift);
	$uri=~s/\.\d+\.(\w+)$/\.$1/;
my @uriparts=split(/\//,$uri);	my @uriparts=split(/\//,$uri);
my $filename=$uriparts[$#uriparts];	my $filename=$uriparts[$#uriparts];
my $pathname=$uri;	my $pathname=$uri;
Line 2774 sub is_on_map {	Line 2746 sub is_on_map {
if ($match) {	if ($match) {
return (1,$1);	return (1,$1);
} else {	} else {
my ($name,$ext)=($filename=~/^(.+)\.(\w+)$/);	return (0,0);
$ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
/\&(\Q$name\E\.\d+\.$ext)\:([\d\\|]+)\&/;
return (0,$2,$pathname.'/'.$1);
}	}
}	}

Line 3848 sub metadata {	Line 3817 sub metadata {
$lcmetacache{':packages'}=$package.$keyroot;	$lcmetacache{':packages'}=$package.$keyroot;
}	}
foreach (keys %packagetab) {	foreach (keys %packagetab) {
if ($_=~/^$package\&/) {	my $part=$keyroot;
	$part=~s/^\_//;
	if ($_=~/^\Q$package\E\&/ \|\|
	$_=~/^\Q$package\E_0\&/) {
my ($pack,$name,$subp)=split(/\&/,$_);	my ($pack,$name,$subp)=split(/\&/,$_);
# ignore package.tab specified default values	# ignore package.tab specified default values
# here &package_tab_default() will fetch those	# here &package_tab_default() will fetch those
if ($subp eq 'default') { next; }	if ($subp eq 'default') { next; }
my $value=$packagetab{$_};	my $value=$packagetab{$_};
my $part=$keyroot;	my $unikey;
$part=~s/^\_//;	if ($pack =~ /_0$/) {
	$unikey='parameter_0_'.$name;
	$part=0;
	} else {
	$unikey='parameter'.$keyroot.'_'.$name;
	}
if ($subp eq 'display') {	if ($subp eq 'display') {
$value.=' [Part: '.$part.']';	$value.=' [Part: '.$part.']';
}	}
my $unikey='parameter'.$keyroot.'_'.$name;
$lcmetacache{':'.$unikey.'.part'}=$part;	$lcmetacache{':'.$unikey.'.part'}=$part;
$metathesekeys{$unikey}=1;	$metathesekeys{$unikey}=1;
unless (defined($lcmetacache{':'.$unikey.'.'.$subp})) {	unless (defined($lcmetacache{':'.$unikey.'.'.$subp})) {
Line 4037 sub symblist {	Line 4013 sub symblist {

sub symbverify {	sub symbverify {
my ($symb,$thisfn)=@_;	my ($symb,$thisfn)=@_;
$thisfn=&declutter($thisfn);	$thisfn=&symbclean(&declutter($thisfn));
# direct jump to resource in page or to a sequence - will construct own symbs	# direct jump to resource in page or to a sequence - will construct own symbs
if ($thisfn=~/\.(page\|sequence)$/) { return 1; }	if ($thisfn=~/\.(page\|sequence)$/) { return 1; }
# check URL part	# check URL part
my ($map,$resid,$url)=&decode_symb($symb);	my ($map,$resid,$url)=&decode_symb($symb);
unless (&symbclean($url) eq &symbclean($thisfn)) { return 0; }	unless ($url eq $thisfn) { return 0; }

$symb=&symbclean($symb);	$symb=&symbclean($symb);

my %bighash;	my %bighash;
my $okay=0;	my $okay=0;

if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',	if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
&GDBM_READER(),0640)) {	&GDBM_READER(),0640)) {
my $ids=$bighash{'ids_'.&clutter($thisfn)};	my $ids=$bighash{'ids_'.&clutter($thisfn)};
Line 4099 sub decode_symb {	Line 4076 sub decode_symb {
sub fixversion {	sub fixversion {
my $fn=shift;	my $fn=shift;
if ($fn=~/^(adm\|uploaded\|public)/) { return $fn; }	if ($fn=~/^(adm\|uploaded\|public)/) { return $fn; }
my ($match,$cond,$versioned)=&is_on_map($fn);	my %bighash;
unless ($match) {	my $uri=&clutter($fn);
$fn=$versioned;	if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
	&GDBM_READER(),0640)) {
	if ($bighash{'version_'.$uri}) {
	my $version=$bighash{'version_'.$uri};
	unless ($version eq 'mostrecent') {
	$uri=~s/\.(\w+)$/\.$version\.$1/;
	}
	}
	untie %bighash;
}	}
return $fn;	return &declutter($uri);
}	}

# ------------------------------------------------------ Return symb list entry	# ------------------------------------------------------ Return symb list entry

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

Removed from v.1.430
changed lines
	Added in v.1.435