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.395 and 1.444

version 1.395, 2003/07/29 05:22:56	version 1.444, 2003/11/10 21:50:21
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 73 use LWP::UserAgent();	Line 35 use LWP::UserAgent();
use HTTP::Headers;	use HTTP::Headers;
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	%libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache
%courselogs %accesshash %userrolehash $processmarker $dumpcount	%courselogs %accesshash %userrolehash $processmarker $dumpcount
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache	%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache
%domaindescription %domain_auth_def %domain_auth_arg_def $tmpdir);	%userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def
	%domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir);

use IO::Socket;	use IO::Socket;
use GDBM_File;	use GDBM_File;
use Apache::Constants qw(:common :http);	use Apache::Constants qw(:common :http);
use HTML::LCParser;	use HTML::LCParser;
use Fcntl qw(:flock);	use Fcntl qw(:flock);
use Apache::loncoursedata;	use Apache::loncoursedata;
	use Apache::lonlocal;
	use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw);
	use Time::HiRes();
my $readit;	my $readit;

# --------------------------------------------------------------------- Logging	# --------------------------------------------------------------------- Logging
Line 243 sub critical {	Line 209 sub critical {
}	}
return $answer;	return $answer;
}	}

	#
	# -------------- Remove all key from the env that start witha lowercase letter
	# (Which is always a lon-capa value)

	sub cleanenv {
	# unless (defined(&Apache::exists_config_define("MODPERL2"))) { return; }
	# unless (&Apache::exists_config_define("MODPERL2")) { return; }
	foreach my $key (keys(%ENV)) {
	if ($key =~ /^[a-z]/) {
	delete($ENV{$key});
	}
	}
	}

# ------------------------------------------- Transfer profile into environment	# ------------------------------------------- Transfer profile into environment

Line 256 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 377 sub userload {	Line 366 sub userload {
my $curtime=time;	my $curtime=time;
while ($filename=readdir(LONIDS)) {	while ($filename=readdir(LONIDS)) {
if ($filename eq '.' \|\| $filename eq '..') {next;}	if ($filename eq '.' \|\| $filename eq '..') {next;}
my ($atime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[8];	my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
if ($curtime-$atime < 3600) { $numusers++; }	if ($curtime-$mtime < 1800) { $numusers++; }
}	}
closedir(LONIDS);	closedir(LONIDS);
}	}
Line 424 sub spareserver {	Line 413 sub spareserver {
my $lowestserver=$loadpercent > $userloadpercent?	my $lowestserver=$loadpercent > $userloadpercent?
$loadpercent : $userloadpercent;	$loadpercent : $userloadpercent;
foreach $tryserver (keys %spareid) {	foreach $tryserver (keys %spareid) {
my $loadans=reply('load',$tryserver);	my $loadans=reply('load',$tryserver);
my $userloadans=reply('userload',$tryserver);	my $userloadans=reply('userload',$tryserver);
if ($userloadans !~ /\d/) { $userloadans=0; }	if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
my $answer=$loadans > $userloadans?	next; #didn't get a number from the server
$loadans : $userloadans;	}
if (($answer =~ /\d/) && ($answer<$lowestserver)) {	my $answer;
$spareserver="http://$hostname{$tryserver}";	if ($loadans =~ /\d/) {
$lowestserver=$answer;	if ($userloadans =~ /\d/) {
}	#both are numbers, pick the bigger one
	$answer=$loadans > $userloadans?
	$loadans : $userloadans;
	} else {
	$answer = $loadans;
	}
	} else {
	$answer = $userloadans;
	}
	if (($answer =~ /\d/) && ($answer<$lowestserver)) {
	$spareserver="http://$hostname{$tryserver}";
	$lowestserver=$answer;
	}
}	}
return $spareserver;	return $spareserver;
}	}
Line 556 sub authenticate {	Line 557 sub authenticate {
sub homeserver {	sub homeserver {
my ($uname,$udom,$ignoreBadCache)=@_;	my ($uname,$udom,$ignoreBadCache)=@_;
my $index="$uname:$udom";	my $index="$uname:$udom";
if ($homecache{$index}) {
return "$homecache{$index}";	my ($result,$cached)=&is_cached(\%homecache,$index,'home',86400);
}	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 566 sub homeserver {	Line 567 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') {
$homecache{$index}=$tryserver;	return &do_cache(\%homecache,$index,$tryserver,'home');
return $tryserver;
} elsif ($answer eq 'no_host') {	} elsif ($answer eq 'no_host') {
$badServerCache{$tryserver}=1;	$badServerCache{$tryserver}=1;
}	}
Line 819 sub getsection {	Line 819 sub getsection {
return '-1';	return '-1';
}	}

	sub devalidate_cache {
	my ($cache,$id,$name) = @_;
	delete $$cache{$id.'.time'};
	delete $$cache{$id};
	my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
	open(DB,"$filename.lock");
	flock(DB,LOCK_EX);
	my %hash;
	if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {
	eval <<'EVALBLOCK';
	delete($hash{$id});
	delete($hash{$id.'.time'});
	EVALBLOCK
	if ($@) {
	&logthis("<font color='red'>devalidate_cache blew up :$@:$name</font>");
	unlink($filename);
	}
	} else {
	if (-e $filename) {
	&logthis("Unable to tie hash (devalidate cache): $name");
	unlink($filename);
	}
	}
	untie(%hash);
	flock(DB,LOCK_UN);
	close(DB);
	}

	sub is_cached {
	my ($cache,$id,$name,$time) = @_;
	if (!$time) { $time=300; }
	if (!exists($$cache{$id.'.time'})) {
	&load_cache_item($cache,$name,$id);
	}
	if (!exists($$cache{$id.'.time'})) {
	# &logthis("Didn't find $id");
	return (undef,undef);
	} else {
	if (time-($$cache{$id.'.time'})>$time) {
	# &logthis("Devalidating $id - ".time-($$cache{$id.'.time'}));
	&devalidate_cache($cache,$id,$name);
	return (undef,undef);
	}
	}
	return ($$cache{$id},1);
	}

	sub do_cache {
	my ($cache,$id,$value,$name) = @_;
	$$cache{$id.'.time'}=time;
	$$cache{$id}=$value;
	# &logthis("Caching $id as :$value:");
	&save_cache_item($cache,$name,$id);
	# do_cache implictly return the set value
	$$cache{$id};
	}

	sub save_cache_item {
	my ($cache,$name,$id)=@_;
	my $starttime=&Time::HiRes::time();
	# &logthis("Saving :$name:$id");
	my %hash;
	my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
	open(DB,"$filename.lock");
	flock(DB,LOCK_EX);
	if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {
	eval <<'EVALBLOCK';
	$hash{$id.'.time'}=$$cache{$id.'.time'};
	$hash{$id}=freeze({'item'=>$$cache{$id}});
	EVALBLOCK
	if ($@) {
	&logthis("<font color='red'>save_cache blew up :$@:$name</font>");
	unlink($filename);
	}
	} else {
	if (-e $filename) {
	&logthis("Unable to tie hash (save cache item): $name");
	unlink($filename);
	}
	}
	untie(%hash);
	flock(DB,LOCK_UN);
	close(DB);
	# &logthis("save_cache_item $name took ".(&Time::HiRes::time()-$starttime));
	}

	sub load_cache_item {
	my ($cache,$name,$id)=@_;
	my $starttime=&Time::HiRes::time();
	# &logthis("Before Loading $name for $id size is ".scalar(%$cache));
	my %hash;
	my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
	open(DB,"$filename.lock");
	flock(DB,LOCK_SH);
	if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) {
	eval <<'EVALBLOCK';
	if (!%$cache) {
	my $count;
	while (my ($key,$value)=each(%hash)) {
	$count++;
	if ($key =~ /\.time$/) {
	$$cache{$key}=$value;
	} else {
	my $hashref=thaw($value);
	$$cache{$key}=$hashref->{'item'};
	}
	}
	# &logthis("Initial load: $count");
	} else {
	my $hashref=thaw($hash{$id});
	$$cache{$id}=$hashref->{'item'};
	$$cache{$id.'.time'}=$hash{$id.'.time'};
	}
	EVALBLOCK
	if ($@) {
	&logthis("<font color='red'>load_cache blew up :$@:$name</font>");
	unlink($filename);
	}
	} else {
	if (-e $filename) {
	&logthis("Unable to tie hash (load cache item): $name");
	unlink($filename);
	}
	}
	untie(%hash);
	flock(DB,LOCK_UN);
	close(DB);
	# &logthis("After Loading $name size is ".scalar(%$cache));
	# &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime));
	}

sub usection {	sub usection {
my ($udom,$unam,$courseid)=@_;	my ($udom,$unam,$courseid)=@_;
	my $hashid="$udom:$unam:$courseid";

	my ($result,$cached)=&is_cached(\%usectioncache,$hashid,'usection');
	if (defined($cached)) { return $result; }
$courseid=~s/\_/\//g;	$courseid=~s/\_/\//g;
$courseid=~s/^(\w)/\/$1/;	$courseid=~s/^(\w)/\/$1/;
foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',	foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',
Line 839 sub usection {	Line 974 sub usection {
if ($end) {	if ($end) {
if ($now>$end) { $notactive=1; }	if ($now>$end) { $notactive=1; }
}	}
unless ($notactive) { return $section; }	unless ($notactive) {
	return &do_cache(\%usectioncache,$hashid,$section,'usection');
	}
}	}
}	}
return '-1';	return &do_cache(\%usectioncache,$hashid,'-1','usection');
}	}

# ------------------------------------- Read an entry from a user's environment	# ------------------------------------- Read an entry from a user's environment
Line 882 sub getversion {	Line 1019 sub getversion {

sub currentversion {	sub currentversion {
my $fname=shift;	my $fname=shift;
	my ($result,$cached)=&is_cached(\%resversioncache,$fname,'resversion',600);
	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/;
my ($udom,$uname)=split(/\//,$author);	my ($udom,$uname)=split(/\//,$author);
Line 893 sub currentversion {	Line 1032 sub currentversion {
if (($answer eq 'con_lost') \|\| ($answer eq 'rejected')) {	if (($answer eq 'con_lost') \|\| ($answer eq 'rejected')) {
return -1;	return -1;
}	}
return $answer;	return &do_cache(\%resversioncache,$fname,$answer,'resversion');
}	}

# ----------------------------- Subscribe to a resource, return URL if possible	# ----------------------------- Subscribe to a resource, return URL if possible
Line 928 sub repcopy {	Line 1067 sub repcopy {
&logthis("Subscribe returned $remoteurl: $filename");	&logthis("Subscribe returned $remoteurl: $filename");
return HTTP_SERVICE_UNAVAILABLE;	return HTTP_SERVICE_UNAVAILABLE;
} elsif ($remoteurl eq 'not_found') {	} elsif ($remoteurl eq 'not_found') {
&logthis("Subscribe returned not_found: $filename");	#&logthis("Subscribe returned not_found: $filename");
return HTTP_NOT_FOUND;	return HTTP_NOT_FOUND;
} elsif ($remoteurl =~ /^rejected by/) {	} elsif ($remoteurl =~ /^rejected by/) {
&logthis("Subscribe returned $remoteurl: $filename");	&logthis("Subscribe returned $remoteurl: $filename");
Line 1216 sub courseacclog {	Line 1355 sub courseacclog {
my $fnsymb=shift;	my $fnsymb=shift;
unless ($ENV{'request.course.id'}) { return ''; }	unless ($ENV{'request.course.id'}) { return ''; }
my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'};	my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'};
if ($fnsymb=~/(problem\|exam\|quiz\|assess\|survey\|form)$/) {	if ($fnsymb=~/(problem\|exam\|quiz\|assess\|survey\|form\|page)$/) {
$what.=':POST';	$what.=':POST';
foreach (keys %ENV) {	foreach (keys %ENV) {
if ($_=~/^form\.(.*)/) {	if ($_=~/^form\.(.*)/) {
Line 1284 sub get_course_adv_roles {	Line 1423 sub get_course_adv_roles {
return %returnhash;	return %returnhash;
}	}

	sub get_my_roles {
	my ($uname,$udom)=@_;
	unless (defined($uname)) { $uname=$ENV{'user.name'}; }
	unless (defined($udom)) { $udom=$ENV{'user.domain'}; }
	my %dumphash=
	&dump('nohist_userroles',$udom,$uname);
	my %returnhash=();
	my $now=time;
	foreach (keys %dumphash) {
	my ($tend,$tstart)=split(/\:/,$dumphash{$_});
	if (($tstart) && ($tstart<0)) { next; }
	if (($tend) && ($tend<$now)) { next; }
	if (($tstart) && ($now<$tstart)) { next; }
	my ($role,$username,$domain,$section)=split(/\:/,$_);
	$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
	}
	return %returnhash;
	}

	# ----------------------------------------------------- Frontpage Announcements
	#
	#

	sub postannounce {
	my ($server,$text)=@_;
	unless (&allowed('psa',$hostdom{$server})) { return 'refused'; }
	unless ($text=~/\w/) { $text=''; }
	return &reply('setannounce:'.&escape($text),$server);
	}

	sub getannounce {
	if (my $fh=Apache::File->new($perlvar{'lonDocRoot'}.'/announcement.txt')) {
	my $announcement='';
	while (<$fh>) { $announcement .=$_; }
	$fh->close();
	if ($announcement=~/\w/) {
	return
	'<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'.
	'<tr><td bgcolor="#FFFFFF"><pre>'.$announcement.'</pre></td></tr></table>';
	} else {
	return '';
	}
	} else {
	return '';
	}
	}

# ---------------------------------------------------------- Course ID routines	# ---------------------------------------------------------- Course ID routines
# Deal with domain's nohist_courseid.db files	# Deal with domain's nohist_courseid.db files
#	#
Line 2077 sub dump {	Line 2263 sub dump {
return %returnhash;	return %returnhash;
}	}

	# -------------------------------------------------------------- keys interface

	sub getkeys {
	my ($namespace,$udomain,$uname)=@_;
	if (!$udomain) { $udomain=$ENV{'user.domain'}; }
	if (!$uname) { $uname=$ENV{'user.name'}; }
	my $uhome=&homeserver($uname,$udomain);
	my $rep=reply("keys:$udomain:$uname:$namespace",$uhome);
	my @keyarray=();
	foreach (split(/\&/,$rep)) {
	push (@keyarray,&unescape($_));
	}
	return @keyarray;
	}

# --------------------------------------------------------------- currentdump	# --------------------------------------------------------------- currentdump
sub currentdump {	sub currentdump {
my ($courseid,$sdom,$sname)=@_;	my ($courseid,$sdom,$sname)=@_;
Line 2096 sub currentdump {	Line 2297 sub currentdump {
return if ($tmp[0] =~ /^(error:\|no_such_host)/);	return if ($tmp[0] =~ /^(error:\|no_such_host)/);
my %hash = @tmp;	my %hash = @tmp;
@tmp=();	@tmp=();
# Code ripped from lond, essentially. The only difference	%returnhash = %{&convert_dump_to_currentdump(\%hash)};
# here is the unescaping done by lonnet::dump(). Conceivably
# we might run in to problems with parameter names =~ /^v\./
while (my ($key,$value) = each(%hash)) {
my ($v,$symb,$param) = split(/:/,$key);
next if ($v eq 'version' \|\| $symb eq 'keys');
next if (exists($returnhash{$symb}) &&
exists($returnhash{$symb}->{$param}) &&
$returnhash{$symb}->{'v.'.$param} > $v);
$returnhash{$symb}->{$param}=$value;
$returnhash{$symb}->{'v.'.$param}=$v;
}
#
# Remove all of the keys in the hashes which keep track of
# the version of the parameter.
while (my ($symb,$param_hash) = each(%returnhash)) {
# use a foreach because we are going to delete from the hash.
foreach my $key (keys(%$param_hash)) {
delete($param_hash->{$key}) if ($key =~ /^v\./);
}
}
} else {	} else {
my @pairs=split(/\&/,$rep);	my @pairs=split(/\&/,$rep);
foreach (@pairs) {	foreach (@pairs) {
Line 2129 sub currentdump {	Line 2310 sub currentdump {
return %returnhash;	return %returnhash;
}	}

	sub convert_dump_to_currentdump{
	my %hash = %{shift()};
	my %returnhash;
	# Code ripped from lond, essentially. The only difference
	# here is the unescaping done by lonnet::dump(). Conceivably
	# we might run in to problems with parameter names =~ /^v\./
	while (my ($key,$value) = each(%hash)) {
	my ($v,$symb,$param) = split(/:/,$key);
	next if ($v eq 'version' \|\| $symb eq 'keys');
	next if (exists($returnhash{$symb}) &&
	exists($returnhash{$symb}->{$param}) &&
	$returnhash{$symb}->{'v.'.$param} > $v);
	$returnhash{$symb}->{$param}=$value;
	$returnhash{$symb}->{'v.'.$param}=$v;
	}
	#
	# Remove all of the keys in the hashes which keep track of
	# the version of the parameter.
	while (my ($symb,$param_hash) = each(%returnhash)) {
	# use a foreach because we are going to delete from the hash.
	foreach my $key (keys(%$param_hash)) {
	delete($param_hash->{$key}) if ($key =~ /^v\./);
	}
	}
	return \%returnhash;
	}

# --------------------------------------------------------------- put interface	# --------------------------------------------------------------- put interface

sub put {	sub put {
Line 2209 sub customaccess {	Line 2417 sub customaccess {
$access=($effect eq 'allow');	$access=($effect eq 'allow');
last;	last;
}	}
	if ($realm eq '' && $role eq '') {
	$access=($effect eq 'allow');
	}
}	}
return $access;	return $access;
}	}
Line 2217 sub customaccess {	Line 2428 sub customaccess {

sub allowed {	sub allowed {
my ($priv,$uri)=@_;	my ($priv,$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}; }
# Free bre access to adm and meta resources	# Free bre access to adm and meta resources

if ((($uri=~/^adm\//) \|\| ($uri=~/\.meta$/)) && ($priv eq 'bre')) {	if ((($uri=~/^adm\//) \|\| ($uri=~/\.meta$/)) && ($priv eq 'bre')) {
Line 2501 sub allowed {	Line 2713 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 2516 sub is_on_map {	Line 2729 sub is_on_map {
}	}
}	}

	# --------------------------------------------------------- Get symb from alias

	sub get_symb_from_alias {
	my $symb=shift;
	my ($map,$resid,$url)=&decode_symb($symb);
	# Already is a symb
	if ($url) { return $symb; }
	# Must be an alias
	my $aliassymb='';
	my %bighash;
	if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
	&GDBM_READER(),0640)) {
	my $rid=$bighash{'mapalias_'.$symb};
	if ($rid) {
	my ($mapid,$resid)=split(/\./,$rid);
	$aliassymb=&encode_symb($bighash{'map_id_'.$mapid},
	$resid,$bighash{'src_'.$rid});
	}
	untie %bighash;
	}
	return $aliassymb;
	}

# ----------------------------------------------------------------- Define Role	# ----------------------------------------------------------------- Define Role

sub definerole {	sub definerole {
Line 2642 sub userlog_query {	Line 2878 sub userlog_query {

sub plaintext {	sub plaintext {
my $short=shift;	my $short=shift;
return $prp{$short};	return &mt($prp{$short});
}	}

# ----------------------------------------------------------------- Assign Role	# ----------------------------------------------------------------- Assign Role
Line 2746 sub modifyuser {	Line 2982 sub modifyuser {
' in domain '.$ENV{'request.role.domain'});	' in domain '.$ENV{'request.role.domain'});
my $uhome=&homeserver($uname,$udom,'true');	my $uhome=&homeserver($uname,$udom,'true');
# ----------------------------------------------------------------- Create User	# ----------------------------------------------------------------- Create User
if (($uhome eq 'no_host') && ($umode) && ($upass)) {	if (($uhome eq 'no_host') &&
	(($umode && $upass) \|\| ($umode eq 'localauth'))) {
my $unhome='';	my $unhome='';
if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) {	if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) {
$unhome = $desiredhome;	$unhome = $desiredhome;
Line 3070 sub dirlist {	Line 3307 sub dirlist {
}	}
my $alldomstr='';	my $alldomstr='';
foreach (sort keys %alldom) {	foreach (sort keys %alldom) {
$alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:';	$alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'/&domain:';
}	}
$alldomstr=~s/:$//;	$alldomstr=~s/:$//;
return split(/:/,$alldomstr);	return split(/:/,$alldomstr);
Line 3086 sub dirlist {	Line 3323 sub dirlist {
# when it was last modified. It will also return an error of -1	# when it was last modified. It will also return an error of -1
# if an error occurs	# if an error occurs

	##
	## FIXME: This subroutine assumes its caller knows something about the
	## directory structure of the home server for the student ($root).
	## Not a good assumption to make. Since this is for looking up files
	## in user directories, the full path should be constructed by lond, not
	## whatever machine we request data from.
	##
sub GetFileTimestamp {	sub GetFileTimestamp {
my ($studentDomain,$studentName,$filename,$root)=@_;	my ($studentDomain,$studentName,$filename,$root)=@_;
$studentDomain=~s/\W//g;	$studentDomain=~s/\W//g;
Line 3162 sub condval {	Line 3406 sub condval {
sub devalidatecourseresdata {	sub devalidatecourseresdata {
my ($coursenum,$coursedomain)=@_;	my ($coursenum,$coursedomain)=@_;
my $hashid=$coursenum.':'.$coursedomain;	my $hashid=$coursenum.':'.$coursedomain;
delete $courseresdatacache{$hashid.'.time'};	&devalidate_cache(\%courseresdatacache,$hashid,'courseres');
}	}

# --------------------------------------------------- Course Resourcedata Query	# --------------------------------------------------- Course Resourcedata Query
Line 3171 sub courseresdata {	Line 3415 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 $dodump=0;	my ($result,$cached)=&is_cached(\%courseresdatacache,$hashid,'courseres');
if (!defined($courseresdatacache{$hashid.'.time'})) {	unless (defined($cached)) {
$dodump=1;
} else {
if (time-$courseresdatacache{$hashid.'.time'}>300) { $dodump=1; }
}
if ($dodump) {
my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum);	my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum);
	$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) {
$courseresdatacache{$hashid.'.time'}=time;	&do_cache(\%courseresdatacache,$hashid,$result,'courseres');
$courseresdatacache{$hashid}=\%dumpreply;
} elsif ($tmp =~ /^(con_lost\|no_such_host)/) {	} elsif ($tmp =~ /^(con_lost\|no_such_host)/) {
return $tmp;	return $tmp;
	} elsif ($tmp =~ /^(error)/) {
	$result=undef;
	&do_cache(\%courseresdatacache,$hashid,$result,'courseres');
}	}
}	}
foreach my $item (@which) {	foreach my $item (@which) {
if (defined($courseresdatacache{$hashid}->{$item})) {	if (defined($result->{$item})) {
return $courseresdatacache{$hashid}->{$item};	return $result->{$item};
}	}
}	}
return undef;	return undef;
Line 3228 sub EXT {	Line 3470 sub EXT {
#get real user name/domain, courseid and symb	#get real user name/domain, courseid and symb
my $courseid;	my $courseid;
my $publicuser;	my $publicuser;
	if ($symbparm) {
	$symbparm=&get_symb_from_alias($symbparm);
	}
if (!($uname && $udom)) {	if (!($uname && $udom)) {
(my $cursymb,$courseid,$udom,$uname,$publicuser)=	(my $cursymb,$courseid,$udom,$uname,$publicuser)=
&Apache::lonxml::whichuser($symbparm);	&Apache::lonxml::whichuser($symbparm);
Line 3313 sub EXT {	Line 3558 sub EXT {
} elsif ($realm eq 'request') {	} elsif ($realm eq 'request') {
# ------------------------------------------------------------- request.browser	# ------------------------------------------------------------- request.browser
if ($space eq 'browser') {	if ($space eq 'browser') {
return $ENV{'browser.'.$qualifier};	if ($qualifier eq 'textremote') {
	if (&mt('textual_remote_display') eq 'on') {
	return 1;
	} else {
	return 0;
	}
	} else {
	return $ENV{'browser.'.$qualifier};
	}
# ------------------------------------------------------------ request.filename	# ------------------------------------------------------------ request.filename
} else {	} else {
return $ENV{'request.'.$spacequalifierrest};	return $ENV{'request.'.$spacequalifierrest};
Line 3331 sub EXT {	Line 3584 sub EXT {
# ----------------------------------------------------- Cascading lookup scheme	# ----------------------------------------------------- Cascading lookup scheme
if (!$symbparm) { $symbparm=&symbread(); }	if (!$symbparm) { $symbparm=&symbread(); }
my $symbp=$symbparm;	my $symbp=$symbparm;
my $mapp=(split(/\_\_\_/,$symbp))[0];	my $mapp=(&decode_symb($symbp))[0];

my $symbparm=$symbp.'.'.$spacequalifierrest;	my $symbparm=$symbp.'.'.$spacequalifierrest;
my $mapparm=$mapp.'___(all).'.$spacequalifierrest;	my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
Line 3357 sub EXT {	Line 3610 sub EXT {

# ----------------------------------------------------------- first, check user	# ----------------------------------------------------------- first, check user
#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
#every thirty minutes
if (! &EXT_cache_status($udom,$uname)) {	if (! &EXT_cache_status($udom,$uname)) {
my %resourcedata=&get('resourcedata',	my $hashid="$udom:$uname";
[$courselevelr,$courselevelm,$courselevel],	my ($result,$cached)=&is_cached(\%userresdatacache,$hashid,
$udom,$uname);	'userres');
my ($tmp)=keys(%resourcedata);	if (!defined($cached)) {
	my %resourcedata=&get('resourcedata',
	[$courselevelr,$courselevelm,
	$courselevel],$udom,$uname);
	$result=\%resourcedata;
	&do_cache(\%userresdatacache,$hashid,$result,'userres');
	}
	my ($tmp)=keys(%$result);
if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {	if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {
if ($resourcedata{$courselevelr}) {	if ($$result{$courselevelr}) {
return $resourcedata{$courselevelr}; }	return $$result{$courselevelr}; }
if ($resourcedata{$courselevelm}) {	if ($$result{$courselevelm}) {
return $resourcedata{$courselevelm}; }	return $$result{$courselevelm}; }
if ($resourcedata{$courselevel}) {	if ($$result{$courselevel}) {
return $resourcedata{$courselevel}; }	return $$result{$courselevel}; }
} else {	} else {
if ($tmp!~/No such file/) {	if ($tmp!~/No such file/) {
&logthis("<font color=blue>WARNING:".	&logthis("<font color=blue>WARNING:".
Line 3410 sub EXT {	Line 3669 sub EXT {
my $filename;	my $filename;
if (!$symbparm) { $symbparm=&symbread(); }	if (!$symbparm) { $symbparm=&symbread(); }
if ($symbparm) {	if ($symbparm) {
$filename=(split(/\_\_\_/,$symbparm))[2];	$filename=(&decode_symb($symbparm))[2];
} else {	} else {
$filename=$ENV{'request.filename'};	$filename=$ENV{'request.filename'};
}	}
Line 3454 sub EXT {	Line 3713 sub EXT {

sub packages_tab_default {	sub packages_tab_default {
my ($uri,$varname)=@_;	my ($uri,$varname)=@_;
&logthis(" $varname");
my (undef,$part,$name)=split(/\./,$varname);	my (undef,$part,$name)=split(/\./,$varname);
my $packages=&metadata($uri,'packages');	my $packages=&metadata($uri,'packages');
foreach my $package (split(/,/,$packages)) {	foreach my $package (split(/,/,$packages)) {
Line 3486 sub add_prefix_and_part {	Line 3744 sub add_prefix_and_part {

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\|/$\|) \|\| ($uri =~ m\|/.meta$\|)) {	($uri =~ m\|/$\|) \|\| ($uri =~ m\|/.meta$\|) \|\| ($uri =~ /^~/) \|\|
	($uri =~ m\|home/[^/]+/public_html/\|)) {
return '';	return '';
}	}
my $filename=$uri;	my $filename=$uri;
Line 3500 sub metadata {	Line 3758 sub metadata {
# Look at timestamp of caching	# Look at timestamp of caching
# Everything is cached by the main uri, libraries are never directly cached	# Everything is cached by the main uri, libraries are never directly cached
#	#
unless (abs($metacache{$uri.':cachedtimestamp'}-time)<600 && !defined($liburi)) {	if (!defined($liburi)) {
	my ($result,$cached)=&is_cached(\%metacache,$uri,'meta');
	if (defined($cached)) { return $result->{':'.$what}; }
	}
	{
#	#
# Is this a recursive call for a library?	# Is this a recursive call for a library?
#	#
	my %lcmetacache;
if ($liburi) {	if ($liburi) {
$liburi=&declutter($liburi);	$liburi=&declutter($liburi);
$filename=$liburi;	$filename=$liburi;
}	} else {
	&devalidate_cache(\%metacache,$uri,'meta');
	}
my %metathesekeys=();	my %metathesekeys=();
unless ($filename=~/\.meta$/) { $filename.='.meta'; }	unless ($filename=~/\.meta$/) { $filename.='.meta'; }
my $metastring=&getfile(&filelocation('',&clutter($filename)));	my $metastring=&getfile(&filelocation('',&clutter($filename)));
my $parser=HTML::LCParser->new(\$metastring);	my $parser=HTML::LCParser->new(\$metastring);
my $token;	my $token;
undef %metathesekeys;	undef %metathesekeys;
delete($metacache{$uri.':packages'});
while ($token=$parser->get_token) {	while ($token=$parser->get_token) {
if ($token->[0] eq 'S') {	if ($token->[0] eq 'S') {
if (defined($token->[2]->{'package'})) {	if (defined($token->[2]->{'package'})) {
Line 3526 sub metadata {	Line 3790 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 ($lcmetacache{':packages'}) {
$metacache{$uri.':packages'}.=','.$package.$keyroot;	$lcmetacache{':packages'}.=','.$package.$keyroot;
} else {	} else {
$metacache{$uri.':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;
$metacache{$uri.':'.$unikey.'.part'}=$part;
$metathesekeys{$unikey}=1;	$metathesekeys{$unikey}=1;
unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) {	unless (defined($lcmetacache{':'.$unikey.'.'.$subp})) {
$metacache{$uri.':'.$unikey.'.'.$subp}=$value;	$lcmetacache{':'.$unikey.'.'.$subp}=$value;
}	}
if (defined($metacache{$uri.':'.$unikey.'.default'})) {	if (defined($lcmetacache{':'.$unikey.'.default'})) {
$metacache{$uri.':'.$unikey}=	$lcmetacache{':'.$unikey}=
$metacache{$uri.':'.$unikey.'.default'};	$lcmetacache{':'.$unikey.'.default'};
}	}
}	}
}	}
Line 3594 sub metadata {	Line 3865 sub metadata {
}	}
$metathesekeys{$unikey}=1;	$metathesekeys{$unikey}=1;
foreach (@{$token->[3]}) {	foreach (@{$token->[3]}) {
$metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};	$lcmetacache{':'.$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=$lcmetacache{':'.$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;	$lcmetacache{':'.$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;	$lcmetacache{':'.$unikey}=$internaltext;
}	}
# end of not-a-package not-a-library import	# end of not-a-package not-a-library import
}	}
Line 3615 sub metadata {	Line 3886 sub metadata {
}	}
}	}
# are there custom rights to evaluate	# are there custom rights to evaluate
if ($metacache{$uri.':copyright'} eq 'custom') {	if ($lcmetacache{':copyright'} eq 'custom') {

#	#
# Importing a rights file here	# Importing a rights file here
#	#
unless ($depthcount) {	unless ($depthcount) {
my $location=$metacache{$uri.':customdistributionfile'};	my $location=$lcmetacache{':customdistributionfile'};
my $dir=$filename;	my $dir=$filename;
$dir=~s\|[^/]*$\|\|;	$dir=~s\|[^/]*$\|\|;
$location=&filelocation($dir,$location);	$location=&filelocation($dir,$location);
Line 3632 sub metadata {	Line 3903 sub metadata {
}	}
}	}
}	}
$metacache{$uri.':keys'}=join(',',keys %metathesekeys);	$lcmetacache{':keys'}=join(',',keys %metathesekeys);
&metadata_generate_part0(\%metathesekeys,\%metacache,$uri);	&metadata_generate_part0(\%metathesekeys,\%lcmetacache,$uri);
$metacache{$uri.':allpossiblekeys'}=join(',',keys %metathesekeys);	$lcmetacache{':allpossiblekeys'}=join(',',keys %metathesekeys);
$metacache{$uri.':cachedtimestamp'}=time;	&do_cache(\%metacache,$uri,\%lcmetacache,'meta');
# 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 $metacache{$uri}->{':'.$what};
}	}

sub metadata_generate_part0 {	sub metadata_generate_part0 {
Line 3646 sub metadata_generate_part0 {	Line 3917 sub metadata_generate_part0 {
my %allnames;	my %allnames;
foreach my $metakey (sort keys %$metadata) {	foreach my $metakey (sort keys %$metadata) {
if ($metakey=~/^parameter\_(.*)/) {	if ($metakey=~/^parameter\_(.*)/) {
my $part=$$metacache{$uri.':'.$metakey.'.part'};	my $part=$$metacache{':'.$metakey.'.part'};
my $name=$$metacache{$uri.':'.$metakey.'.name'};	my $name=$$metacache{':'.$metakey.'.name'};
if (! exists($$metadata{'parameter_0_'.$name.'.name'})) {	if (! exists($$metadata{'parameter_0_'.$name.'.name'})) {
$allnames{$name}=$part;	$allnames{$name}=$part;
}	}
Line 3655 sub metadata_generate_part0 {	Line 3926 sub metadata_generate_part0 {
}	}
foreach my $name (keys(%allnames)) {	foreach my $name (keys(%allnames)) {
$$metadata{"parameter_0_$name"}=1;	$$metadata{"parameter_0_$name"}=1;
my $key="$uri:parameter_0_$name";	my $key=":parameter_0_$name";
$$metacache{"$key.part"}='0';	$$metacache{"$key.part"}='0';
$$metacache{"$key.name"}=$name;	$$metacache{"$key.name"}=$name;
$$metacache{"$key.type"}=$$metacache{$uri.':parameter_'.	$$metacache{"$key.type"}=$$metacache{':parameter_'.
$allnames{$name}.'_'.$name.	$allnames{$name}.'_'.$name.
'.type'};	'.type'};
my $olddis=$$metacache{$uri.':parameter_'.$allnames{$name}.'_'.$name.	my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name.
'.display'};	'.display'};
my $expr='\\[Part: '.$allnames{$name}.'\\]';	my $expr='\\[Part: '.$allnames{$name}.'\\]';
$olddis=~s/$expr/\[Part: 0\]/;	$olddis=~s/$expr/\[Part: 0\]/;
Line 3678 sub gettitle {	Line 3949 sub gettitle {
unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; }	unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; }
return &metadata($urlsymb,'title');	return &metadata($urlsymb,'title');
}	}
if ($titlecache{$symb}) {	my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600);
if (time < ($titlecache{$symb}[1] + 600)) {	if (defined($cached)) { return $result; }
return $titlecache{$symb}[0];	my ($map,$resid,$url)=&decode_symb($symb);
} else {
delete($titlecache{$symb});
}
}
my ($map,$resid,$url)=split(/\_\_\_/,$symb);
my $title='';	my $title='';
my %bighash;	my %bighash;
if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',	if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
Line 3696 sub gettitle {	Line 3962 sub gettitle {
}	}
$title=~s/\&colon\;/\:/gs;	$title=~s/\&colon\;/\:/gs;
if ($title) {	if ($title) {
$titlecache{$symb}=[$title,time];	return &do_cache(\%titlecache,$symb,$title,'title');
return $title;
} else {	} else {
return &metadata($urlsymb,'title');	return &metadata($urlsymb,'title');
}	}
Line 3707 sub gettitle {	Line 3972 sub gettitle {

sub symblist {	sub symblist {
my ($mapname,%newhash)=@_;	my ($mapname,%newhash)=@_;
$mapname=declutter($mapname);	$mapname=&deversion(&declutter($mapname));
my %hash;	my %hash;
if (($ENV{'request.course.fn'}) && (%newhash)) {	if (($ENV{'request.course.fn'}) && (%newhash)) {
if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',	if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
&GDBM_WRCREAT(),0640)) {	&GDBM_WRCREAT(),0640)) {
foreach (keys %newhash) {	foreach (keys %newhash) {
$hash{declutter($_)}=$mapname.'___'.$newhash{$_};	$hash{declutter($_)}=$mapname.'___'.&deversion($newhash{$_});
}	}
if (untie(%hash)) {	if (untie(%hash)) {
return 'ok';	return 'ok';
Line 3731 sub symbverify {	Line 3996 sub symbverify {
# 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)=split(/\_\_\_/,$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);
	$thisfn=&deversion($thisfn);

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 3774 sub symbclean {	Line 4042 sub symbclean {
return $symb;	return $symb;
}	}

	# ---------------------------------------------- Split symb to find map and url

	sub encode_symb {
	my ($map,$resid,$url)=@_;
	return &symbclean(&declutter($map).'___'.$resid.'___'.&declutter($url));
	}

	sub decode_symb {
	my ($map,$resid,$url)=split(/\_\_\_/,shift);
	return (&fixversion($map),$resid,&fixversion($url));
	}

	sub fixversion {
	my $fn=shift;
	if ($fn=~/^(adm\|uploaded\|public)/) { return $fn; }
	my %bighash;
	my $uri=&clutter($fn);
	my $key=$ENV{'request.course.id'}.'_'.$uri;
	# is this cached?
	my ($result,$cached)=&is_cached(\%courseresversioncache,$key,
	'courseresversion',600);
	if (defined($cached)) { return $result; }
	# unfortunately not cached, or expired
	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') \|\|
	($version==&getversion($uri))) {
	$uri=~s/\.(\w+)$/\.$version\.$1/;
	}
	}
	untie %bighash;
	}
	return &do_cache
	(\%courseresversioncache,$key,&declutter($uri),'courseresversion');
	}

	sub deversion {
	my $url=shift;
	$url=~s/\.\d+\.(\w+)$/\.$1/;
	return $url;
	}

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

sub symbread {	sub symbread {
Line 3871 sub numval {	Line 4183 sub numval {
}	}

sub latest_rnd_algorithm_id {	sub latest_rnd_algorithm_id {
return '64bit';	return '64bit2';
}	}

sub rndseed {	sub rndseed {
Line 3888 sub rndseed {	Line 4200 sub rndseed {
my $CODE=$ENV{'scantron.CODE'};	my $CODE=$ENV{'scantron.CODE'};
if (defined($CODE)) {	if (defined($CODE)) {
&rndseed_CODE_64bit($symb,$courseid,$domain,$username);	&rndseed_CODE_64bit($symb,$courseid,$domain,$username);
	} elsif ($which eq '64bit2') {
	return &rndseed_64bit2($symb,$courseid,$domain,$username);
} elsif ($which eq '64bit') {	} elsif ($which eq '64bit') {
return &rndseed_64bit($symb,$courseid,$domain,$username);	return &rndseed_64bit($symb,$courseid,$domain,$username);
}	}
Line 3931 sub rndseed_64bit {	Line 4245 sub rndseed_64bit {
}	}
}	}

	sub rndseed_64bit2 {
	my ($symb,$courseid,$domain,$username)=@_;
	{
	use integer;
	# strings need to be an even # of cahracters long, it it is odd the
	# last characters gets thrown away
	my $symbchck=unpack("%32S*",$symb.' ') << 21;
	my $symbseed=numval($symb) << 10;
	my $namechck=unpack("%32S*",$username.' ');

	my $nameseed=numval($username) << 21;
	my $domainseed=unpack("%32S*",$domain.' ') << 10;
	my $courseseed=unpack("%32S*",$courseid.' ');

	my $num1=$symbchck+$symbseed+$namechck;
	my $num2=$nameseed+$domainseed+$courseseed;
	#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed\|$courseseed;$namechck:$symbchck");
	#&Apache::lonxml::debug("rndseed :$num:$symb");
	return "$num1,$num2";
	}
	}

sub rndseed_CODE_64bit {	sub rndseed_CODE_64bit {
my ($symb,$courseid,$domain,$username)=@_;	my ($symb,$courseid,$domain,$username)=@_;
{	{
use integer;	use integer;
my $symbchck=unpack("%32S*",$symb) << 16;	my $symbchck=unpack("%32S*",$symb.' ') << 16;
my $symbseed=numval($symb);	my $symbseed=numval($symb);
my $CODEseed=numval($ENV{'scantron.CODE'}) << 16;	my $CODEseed=numval($ENV{'scantron.CODE'}) << 16;
my $courseseed=unpack("%32S*",$courseid);	my $courseseed=unpack("%32S*",$courseid.' ');
my $num1=$symbseed+$CODEseed;	my $num1=$symbseed+$CODEseed;
my $num2=$courseseed+$symbchck;	my $num2=$courseseed+$symbchck;
#&Apache::lonxml::debug("$symbseed:$CODEseed\|$courseseed:$symbchck");	#&Apache::lonxml::debug("$symbseed:$CODEseed\|$courseseed:$symbchck");
Line 4073 sub unescape {	Line 4409 sub unescape {
return $str;	return $str;
}	}

	sub mod_perl_version {
	if (defined($perlvar{'MODPERL2'})) {
	return 2;
	}
	return 1;
	}

	sub correct_line_ends {
	my ($result)=@_;
	$$result =~s/\r\n/\n/mg;
	$$result =~s/\r/\n/mg;
	}
# ================================================================ Main Program	# ================================================================ Main Program

sub goodbye {	sub goodbye {
&logthis("Starting Shut down");	&logthis("Starting Shut down");
	#not converted to using infrastruture and probably shouldn't be
	&logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache)));
	#converted
	&logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));
	&logthis(sprintf("%-20s is %s",'%homecache',scalar(%homecache)));
	&logthis(sprintf("%-20s is %s",'%titlecache',scalar(%titlecache)));
	&logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache)));
	#1.1 only
	&logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache)));
	&logthis(sprintf("%-20s is %s",'%usectioncache',scalar(%usectioncache)));
	&logthis(sprintf("%-20s is %s",'%courseresversioncache',scalar(%courseresversioncache)));
	&logthis(sprintf("%-20s is %s",'%resversioncache',scalar(%resversioncache)));
&flushcourselogs();	&flushcourselogs();
&logthis("Shutting down");	&logthis("Shutting down");
return DONE;	return DONE;
Line 4120 BEGIN {	Line 4480 BEGIN {
next if (/^(\#\|\s*$)/);	next if (/^(\#\|\s*$)/);
# next if /^\#/;	# next if /^\#/;
chomp;	chomp;
my ($domain, $domain_description, $def_auth, $def_auth_arg)	my ($domain, $domain_description, $def_auth, $def_auth_arg,
= split(/:/,$_,4);	$def_lang, $city, $longi, $lati) = split(/:/,$_);
$domain_auth_def{$domain}=$def_auth;	$domain_auth_def{$domain}=$def_auth;
$domain_auth_arg_def{$domain}=$def_auth_arg;	$domain_auth_arg_def{$domain}=$def_auth_arg;
$domaindescription{$domain}=$domain_description;	$domaindescription{$domain}=$domain_description;
	$domain_lang_def{$domain}=$def_lang;
	$domain_city{$domain}=$city;
	$domain_longi{$domain}=$longi;
	$domain_lati{$domain}=$lati;

# &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");	# &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");
# &logthis("Domain.tab: $domain ".$domaindescription{$domain} );	# &logthis("Domain.tab: $domain ".$domaindescription{$domain} );
}	}

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

Removed from v.1.395
changed lines
	Added in v.1.444