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.488 and 1.601

version 1.488, 2004/04/23 19:36:46	version 1.601, 2005/03/01 00:22:59
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 %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 %courseresdatacache	%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf
%userresdatacache %usectioncache %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);	%domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit);

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::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 nfreeze);
use Time::HiRes();	use Time::HiRes qw( gettimeofday tv_interval );
	use Cache::Memcached;
my $readit;	my $readit;
	my $max_connection_retries = 10; # Or some such value.

=pod	=pod

Line 116 sub logperm {	Line 117 sub logperm {
sub subreply {	sub subreply {
my ($cmd,$server)=@_;	my ($cmd,$server)=@_;
my $peerfile="$perlvar{'lonSockDir'}/$server";	my $peerfile="$perlvar{'lonSockDir'}/$server";
my $client=IO::Socket::UNIX->new(Peer =>"$peerfile",	#
Type => SOCK_STREAM,	# With loncnew process trimming, there's a timing hole between lonc server
Timeout => 10)	# process exit and the master server picking up the listen on the AF_UNIX
or return "con_lost";	# socket. In that time interval, a lock file will exist:
print $client "$cmd\n";
my $answer=<$client>;	my $lockfile=$peerfile.".lock";
if (!$answer) { $answer="con_lost"; }	while (-e $lockfile) { # Need to wait for the lockfile to disappear.
chomp($answer);	sleep(1);
	}
	# At this point, either a loncnew parent is listening or an old lonc
	# or loncnew child is listening so we can connect or everything's dead.
	#
	# We'll give the connection a few tries before abandoning it. If
	# connection is not possible, we'll con_lost back to the client.
	#
	my $client;
	for (my $retries = 0; $retries < $max_connection_retries; $retries++) {
	$client=IO::Socket::UNIX->new(Peer =>"$peerfile",
	Type => SOCK_STREAM,
	Timeout => 10);
	if($client) {
	last; # Connected!
	}
	sleep(1); # Try again later if failed connection.
	}
	my $answer;
	if ($client) {
	print $client "$cmd\n";
	$answer=<$client>;
	if (!$answer) { $answer="con_lost"; }
	chomp($answer);
	} else {
	$answer = 'con_lost'; # Failed connection.
	}
return $answer;	return $answer;
}	}

Line 131 sub reply {	Line 158 sub reply {
my ($cmd,$server)=@_;	my ($cmd,$server)=@_;
unless (defined($hostname{$server})) { return 'no_such_host'; }	unless (defined($hostname{$server})) { return 'no_such_host'; }
my $answer=subreply($cmd,$server);	my $answer=subreply($cmd,$server);
if ($answer eq 'con_lost') {
#sleep 5;
#$answer=subreply($cmd,$server);
#if ($answer eq 'con_lost') {
# &logthis("Second attempt con_lost on $server");
# my $peerfile="$perlvar{'lonSockDir'}/$server";
# my $client=IO::Socket::UNIX->new(Peer =>"$peerfile",
# Type => SOCK_STREAM,
# Timeout => 10)
# or return "con_lost";
# &logthis("Killing socket");
# print $client "close_connection_exit\n";
#sleep 5;
# $answer=subreply($cmd,$server);
#}
}
if (($answer=~/^refused/) \|\| ($answer=~/^rejected/)) {	if (($answer=~/^refused/) \|\| ($answer=~/^rejected/)) {
&logthis("<font color=blue>WARNING:".	&logthis("<font color=blue>WARNING:".
" $cmd to $server returned $answer</font>");	" $cmd to $server returned $answer</font>");
Line 194 sub critical {	Line 205 sub critical {
}	}
my $answer=reply($cmd,$server);	my $answer=reply($cmd,$server);
if ($answer eq 'con_lost') {	if ($answer eq 'con_lost') {
my $pingreply=reply('ping',$server);
&reconlonc("$perlvar{'lonSockDir'}/$server");	&reconlonc("$perlvar{'lonSockDir'}/$server");
my $pongreply=reply('pong',$server);	my $answer=reply($cmd,$server);
&logthis("Ping/Pong for $server: $pingreply/$pongreply");
$answer=reply($cmd,$server);
if ($answer eq 'con_lost') {	if ($answer eq 'con_lost') {
my $now=time;	my $now=time;
my $middlename=$cmd;	my $middlename=$cmd;
Line 551 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 564 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 642 sub assign_access_key {	Line 650 sub assign_access_key {
# a valid key looks like uname:udom#comments	# a valid key looks like uname:udom#comments
# comments are being appended	# comments are being appended
#	#
my ($ckey,$cdom,$cnum,$udom,$uname,$logentry)=@_;	my ($ckey,$kdom,$knum,$cdom,$cnum,$udom,$uname,$logentry)=@_;
	$kdom=
	$ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($kdom));
	$knum=
	$ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($knum));
$cdom=	$cdom=
$ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));	$ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
$cnum=	$cnum=
$ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));	$ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
$udom=$ENV{'user.name'} unless (defined($udom));	$udom=$ENV{'user.name'} unless (defined($udom));
$uname=$ENV{'user.domain'} unless (defined($uname));	$uname=$ENV{'user.domain'} unless (defined($uname));
my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);	my %existing=&get('accesskeys',[$ckey],$kdom,$knum);
if (($existing{$ckey}=~/^\#(.*)$/) \|\| # - new key	if (($existing{$ckey}=~/^\#(.*)$/) \|\| # - new key
($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#(.*)$/)) {	($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#(.*)$/)) {
# assigned to this person	# assigned to this person
Line 658 sub assign_access_key {	Line 670 sub assign_access_key {
# the first time around	# the first time around
# ready to assign	# ready to assign
$logentry=$1.'; '.$logentry;	$logentry=$1.'; '.$logentry;
if (&put('accesskey',{$ckey=>$uname.':'.$udom.'#'.$logentry},	if (&put('accesskeys',{$ckey=>$uname.':'.$udom.'#'.$logentry},
$cdom,$cnum) eq 'ok') {	$kdom,$knum) eq 'ok') {
# key now belongs to user	# key now belongs to user
my $envkey='key.'.$cdom.'_'.$cnum;	my $envkey='key.'.$cdom.'_'.$cnum;
if (&put('environment',{$envkey => $ckey}) eq 'ok') {	if (&put('environment',{$envkey => $ckey}) eq 'ok') {
Line 755 sub validate_access_key {	Line 767 sub validate_access_key {
$ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));	$ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
$cnum=	$cnum=
$ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));	$ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
$udom=$ENV{'user.name'} unless (defined($udom));	$udom=$ENV{'user.domain'} unless (defined($udom));
$uname=$ENV{'user.domain'} unless (defined($uname));	$uname=$ENV{'user.name'} unless (defined($uname));
my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);	my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
return ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#/);	return ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#/);
}	}
Line 765 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 ($result,$cached)=&is_cached_new('getsection',$hashid);
	if (defined($cached)) { return $result; }

my %Pending;	my %Pending;
my %Expired;	my %Expired;
#	#
Line 791 sub getsection {	Line 809 sub getsection {
if ($key eq $courseid.'_st') { $section=''; }	if ($key eq $courseid.'_st') { $section=''; }
my ($dummy,$end,$start)=split(/\_/,&unescape($value));	my ($dummy,$end,$start)=split(/\_/,&unescape($value));
my $now=time;	my $now=time;
if (defined($end) && ($now > $end)) {	if (defined($end) && $end && ($now > $end)) {
$Expired{$end}=$section;	$Expired{$end}=$section;
next;	next;
}	}
if (defined($start) && ($now < $start)) {	if (defined($start) && $start && ($now < $start)) {
$Pending{$start}=$section;	$Pending{$start}=$section;
next;	next;
}	}
return $section;	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 $Pending{$time};	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 $Expired{$time};	return &do_cache_new('getsection',$hashid,$Expired{$time},$cachetime);
}	}
return '-1';	return &do_cache_new('getsection',$hashid,'-1',$cachetime);
}	}

	sub save_cache {
my $disk_caching_disabled=1;	&purge_remembered();

sub devalidate_cache {
my ($cache,$id,$name) = @_;
delete $$cache{$id.'.time'};
delete $$cache{$id};
if ($disk_caching_disabled) { return; }
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)=@_;
if ($disk_caching_disabled) { return; }
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)=@_;
if ($disk_caching_disabled) { return; }
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 {	my $to_remember=-1;
my ($udom,$unam,$courseid)=@_;	my %remembered;
my $hashid="$udom:$unam:$courseid";	my %accessed;
	my $kicks=0;
my ($result,$cached)=&is_cached(\%usectioncache,$hashid,'usection');	my $hits=0;
if (defined($cached)) { return $result; }	sub devalidate_cache_new {
$courseid=~s/\_/\//g;	my ($name,$id,$debug) = @_;
$courseid=~s/^(\w)/\/$1/;	if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }
foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',	$id=&escape($name.':'.$id);
&homeserver($unam,$udom)))) {	$memcache->delete($id);
my ($key,$value)=split(/\=/,$_);	delete($remembered{$id});
$key=&unescape($key);	delete($accessed{$id});
if ($key=~/^\Q$courseid\E(?:\/)(\w+)\_st$/) {	}
my $section=$1;
if ($key eq $courseid.'_st') { $section=''; }	sub is_cached_new {
my ($dummy,$end,$start)=split(/\_/,&unescape($value));	my ($name,$id,$debug) = @_;
my $now=time;	$id=&escape($name.':'.$id);
my $notactive=0;	if (exists($remembered{$id})) {
if ($start) {	if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); }
if ($now<$start) { $notactive=1; }	$accessed{$id}=[&gettimeofday()];
}	$hits++;
if ($end) {	return ($remembered{$id},1);
if ($now>$end) { $notactive=1; }	}
}	my $value = $memcache->get($id);
unless ($notactive) {	if (!(defined($value))) {
return &do_cache(\%usectioncache,$hashid,$section,'usection');	if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); }
}	return (undef,undef);
}
}	}
return &do_cache(\%usectioncache,$hashid,'-1','usection');	if ($value eq '__undef__') {
	if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); }
	$value=undef;
	}
	&make_room($id,$value,$debug);
	if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); }
	return ($value,1);
	}

	sub do_cache_new {
	my ($name,$id,$value,$time,$debug) = @_;
	$id=&escape($name.':'.$id);
	my $setvalue=$value;
	if (!defined($setvalue)) {
	$setvalue='__undef__';
	}
	if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }
	$memcache->set($id,$setvalue,$time);
	# need to make a copy of $value
	#&make_room($id,$value,$debug);
	return $value;
	}

	sub make_room {
	my ($id,$value,$debug)=@_;
	$remembered{$id}=$value;
	if ($to_remember<0) { return; }
	$accessed{$id}=[&gettimeofday()];
	if (scalar(keys(%remembered)) <= $to_remember) { return; }
	my $to_kick;
	my $max_time=0;
	foreach my $other (keys(%accessed)) {
	if (&tv_interval($accessed{$other}) > $max_time) {
	$to_kick=$other;
	$max_time=&tv_interval($accessed{$other});
	}
	}
	delete($remembered{$to_kick});
	delete($accessed{$to_kick});
	$kicks++;
	if ($debug) { &logthis("kicking $to_kick $max_time $kicks\n"); }
	return;
	}

	sub purge_remembered {
	&logthis("Tossing ".scalar(keys(%remembered)));
	&logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%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 1022 sub getversion {	Line 953 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 1035 sub currentversion {	Line 966 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 1043 sub currentversion {	Line 974 sub currentversion {
sub subscribe {	sub subscribe {
my $fname=shift;	my $fname=shift;
if ($fname=~/\/(aboutme\|syllabus\|bulletinboard\|smppg)$/) { return ''; }	if ($fname=~/\/(aboutme\|syllabus\|bulletinboard\|smppg)$/) { return ''; }
	$fname=~s/[\n\r]//g;
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 1062 sub subscribe {	Line 994 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;
my $transname="$filename.in.transfer";	my $transname="$filename.in.transfer";
if ((-e $filename) \|\| (-e $transname)) { return OK; }	if ((-e $filename) \|\| (-e $transname)) { return OK; }
my $remoteurl=subscribe($filename);	my $remoteurl=subscribe($filename);
Line 1127 sub ssi_body {	Line 1065 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\|//(\s<!--)? BEGIN LON-CAPA Internal.+// END LON-CAPA Internal\s(-->)?\s\|\|gs;
$output=~s/^.?\<body[^\>]\>//si;	$output=~s/^.?\<body[^\>]\>//si;
$output=~s/(.)\<\/body\s\>.*?$/$1/si;	$output=~s/(.)\<\/body\s\>.*?$/$1/si;
$output=~
s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs;
return $output;	return $output;
}	}

Line 1165 sub externalssi {	Line 1102 sub externalssi {
return $response->content;	return $response->content;
}	}

# ------- Add a token to a remote URI's query string to vouch for access rights	# -------------------------------- Allow a /uploaded/ URI to be vouched for

sub tokenwrapper {	sub allowuploaded {
my $uri=shift;	my ($srcurl,$url)=@_;
$uri=~s/^http\:\/\/([^\/]+)//;	$url=&clutter(&declutter($url));
$uri=~s/^\///;	my $dir=$url;
$ENV{'user.environment'}=~/\/([^\/]+)\.id/;	$dir=~s/\/[^\/]+$//;
my $token=$1;	my %httpref=();
# if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.)$/) {	my $httpurl=&hreflocation('',$url);
if ($uri=~m\|^uploaded/([^/]+)/([^/]+)/(.+)(\?\.)$\|) {	$httpref{'httpref.'.$httpurl}=$srcurl;
&appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'});	&Apache::lonnet::appenv(%httpref);
return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri.
(($uri=~/\?/)?'&':'?').'token='.$token.
'&tokenissued='.$perlvar{'lonHostID'};
} else {
return '/adm/notfound.html';
}
}	}

# --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course	# --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course
Line 1269 sub process_coursefile {	Line 1200 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)=@_;	my ($fname)=@_;
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 1280 sub userfileupload {	Line 1210 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});
	if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) { #files uploaded to help request form are handled differently
	my $now = time;
	my $filepath = 'tmp/helprequests/'.$now;
	my @parts=split(/\//,$filepath);
	my $fullpath = $perlvar{'lonDaemons'};
	for (my $i=0;$i<@parts;$i++) {
	$fullpath .= '/'.$parts[$i];
	if ((-e $fullpath)!=1) {
	mkdir($fullpath,0777);
	}
	}
	open(my $fh,'>'.$fullpath.'/'.$fname);
	print $fh $ENV{'form.'.$formname};
	close($fh);
	return $fullpath.'/'.$fname;
	}
# Create the directory if not present	# Create the directory if not present
my $docuname='';	my $docuname='';
my $docudom='';	my $docudom='';
my $docuhome='';	my $docuhome='';
	$fname="$subdir/$fname";
if ($coursedoc) {	if ($coursedoc) {
$docuname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'};	$docuname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'};
$docudom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'};	$docudom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'};
Line 1309 sub finishuserfileupload {	Line 1267 sub finishuserfileupload {
my ($docuname,$docudom,$docuhome,$formname,$fname)=@_;	my ($docuname,$docudom,$docuhome,$formname,$fname)=@_;
my $path=$docudom.'/'.$docuname.'/';	my $path=$docudom.'/'.$docuname.'/';
my $filepath=$perlvar{'lonDocRoot'};	my $filepath=$perlvar{'lonDocRoot'};
	my ($fnamepath,$file);
	$file=$fname;
	if ($fname=~m\|/\|) {
	($fnamepath,$file) = ($fname =~ m\|^(.*)/([^/]+)$\|);
	$path.=$fnamepath.'/';
	}
my @parts=split(/\//,$filepath.'/userfiles/'.$path);	my @parts=split(/\//,$filepath.'/userfiles/'.$path);
my $count;	my $count;
for ($count=4;$count<=$#parts;$count++) {	for ($count=4;$count<=$#parts;$count++) {
Line 1319 sub finishuserfileupload {	Line 1283 sub finishuserfileupload {
}	}
# Save the file	# Save the file
{	{
open(my $fh,'>'.$filepath.'/'.$fname);	open(FH,'>'.$filepath.'/'.$file);
print $fh $ENV{'form.'.$formname};	print FH $ENV{'form.'.$formname};
close($fh);	close(FH);
}	}
# Notify homeserver to grep it	# Notify homeserver to grep it
#	#
my $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,	&Apache::lonnet::logthis("fetching ".$path.$file);
$docuhome);	my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);
if ($fetchresult eq 'ok') {	if ($fetchresult eq 'ok') {
#	#
# Return the URL to it	# Return the URL to it
return '/uploaded/'.$path.$fname;	return '/uploaded/'.$path.$file;
} else {	} else {
&logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$fname.	&logthis('Failed to transfer '.$path.$file.' to host '.$docuhome.
' to host '.$docuhome.': '.$fetchresult);	': '.$fetchresult);
return '/adm/notfound.html';	return '/adm/notfound.html';
}	}
}	}

	sub removeuploadedurl {
	my ($url)=@_;
	my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);
	return &Apache::lonnet::removeuserfile($uname,$udom,$fname);
	}

	sub removeuserfile {
	my ($docuname,$docudom,$fname)=@_;
	my $home=&homeserver($docuname,$docudom);
	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 1377 sub flushcourselogs {	Line 1366 sub flushcourselogs {
}	}
if ($courseidbuffer{$coursehombuf{$crsid}}) {	if ($courseidbuffer{$coursehombuf{$crsid}}) {
$courseidbuffer{$coursehombuf{$crsid}}.='&'.	$courseidbuffer{$coursehombuf{$crsid}}.='&'.
&escape($crsid).'='.&escape($coursedescrbuf{$crsid});	&escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
	':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid});
} else {	} else {
$courseidbuffer{$coursehombuf{$crsid}}=	$courseidbuffer{$coursehombuf{$crsid}}=
&escape($crsid).'='.&escape($coursedescrbuf{$crsid});	&escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
}	':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid});
	}
}	}
#	#
# Write course id database (reverse lookup) to homeserver of courses	# Write course id database (reverse lookup) to homeserver of courses
Line 1454 sub courselog {	Line 1445 sub courselog {
$ENV{'course.'.$ENV{'request.course.id'}.'.home'};	$ENV{'course.'.$ENV{'request.course.id'}.'.home'};
$coursedescrbuf{$ENV{'request.course.id'}}=	$coursedescrbuf{$ENV{'request.course.id'}}=
$ENV{'course.'.$ENV{'request.course.id'}.'.description'};	$ENV{'course.'.$ENV{'request.course.id'}.'.description'};
	$courseinstcodebuf{$ENV{'request.course.id'}}=
	$ENV{'course.'.$ENV{'request.course.id'}.'.internal.coursecode'};
	$courseownerbuf{$ENV{'request.course.id'}}=
	$ENV{'course.'.$ENV{'request.course.id'}.'.internal.courseowner'};
if (defined $courselogs{$ENV{'request.course.id'}}) {	if (defined $courselogs{$ENV{'request.course.id'}}) {
$courselogs{$ENV{'request.course.id'}}.='&'.$what;	$courselogs{$ENV{'request.course.id'}}.='&'.$what;
} else {	} else {
Line 1470 sub courseacclog {	Line 1465 sub courseacclog {
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\|page)$/) {	if ($fnsymb=~/(problem\|exam\|quiz\|assess\|survey\|form\|page)$/) {
$what.=':POST';	$what.=':POST';
	# FIXME: Probably ought to escape things....
foreach (keys %ENV) {	foreach (keys %ENV) {
if ($_=~/^form\.(.*)/) {	if ($_=~/^form\.(.*)/) {
$what.=':'.$1.'='.$ENV{$_};	$what.=':'.$1.'='.$ENV{$_};
}	}
}	}
	} elsif ($fnsymb =~ m:^/adm/searchcat:) {
	# FIXME: We should not be depending on a form parameter that someone
	# editing lonsearchcat.pm might change in the future.
	if ($ENV{'form.phase'} eq 'course_search') {
	$what.= ':POST';
	# FIXME: Probably ought to escape things....
	foreach my $element ('courseexp','crsfulltext','crsrelated',
	'crsdiscuss') {
	$what.=':'.$element.'='.$ENV{'form.'.$element};
	}
	}
}	}
&courselog($what);	&courselog($what);
}	}
Line 1526 sub get_course_adv_roles {	Line 1533 sub get_course_adv_roles {
if (($tend) && ($tend<$now)) { next; }	if (($tend) && ($tend<$now)) { next; }
if (($tstart) && ($now<$tstart)) { next; }	if (($tstart) && ($now<$tstart)) { next; }
my ($role,$username,$domain,$section)=split(/\:/,$_);	my ($role,$username,$domain,$section)=split(/\:/,$_);
	if ($username eq '' \|\| $domain eq '') { next; }
if ((&privileged($username,$domain)) &&	if ((&privileged($username,$domain)) &&
(!$nothide{$username.':'.$domain})) { next; }	(!$nothide{$username.':'.$domain})) { next; }
my $key=&plaintext($role);	my $key=&plaintext($role);
Line 1578 sub getannounce {	Line 1586 sub getannounce {
if ($announcement=~/\w/) {	if ($announcement=~/\w/) {
return	return
'<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'.	'<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'.
'<tr><td bgcolor="#FFFFFF"><pre>'.$announcement.'</pre></td></tr></table>';	'<tr><td bgcolor="#FFFFFF"><tt>'.$announcement.'</tt></td></tr></table>';
} else {	} else {
return '';	return '';
}	}
Line 1597 sub courseidput {	Line 1605 sub courseidput {
}	}

sub courseiddump {	sub courseiddump {
my ($domfilter,$descfilter,$sincefilter)=@_;	my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$hostidflag,$hostidref)=@_;
my %returnhash=();	my %returnhash=();
unless ($domfilter) { $domfilter=''; }	unless ($domfilter) { $domfilter=''; }
foreach my $tryserver (keys %libserv) {	foreach my $tryserver (keys %libserv) {
if ((!$domfilter) \|\| ($hostdom{$tryserver} eq $domfilter)) {	if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) \|\| (!defined($hostidflag)) ) {
foreach (	if ((!$domfilter) \|\| ($hostdom{$tryserver} eq $domfilter)) {
split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.	foreach (
$sincefilter.':'.&escape($descfilter),	split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.
	$sincefilter.':'.&escape($descfilter).':'.
	&escape($instcodefilter).':'.&escape($ownerfilter),
$tryserver))) {	$tryserver))) {
my ($key,$value)=split(/\=/,$_);	my ($key,$value)=split(/\=/,$_);
if (($key) && ($value)) {	if (($key) && ($value)) {
$returnhash{&unescape($key)}=&unescape($value);	$returnhash{&unescape($key)}=$value;
	}
}	}
}	}

}	}
}	}
return %returnhash;	return %returnhash;
Line 1620 sub courseiddump {	Line 1630 sub courseiddump {
#	#
# ----------------------------------------------------------- Check out an item	# ----------------------------------------------------------- Check out an item

	sub get_first_access {
	my ($type,$argsymb)=@_;
	my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();
	if ($argsymb) { $symb=$argsymb; }
	my ($map,$id,$res)=&decode_symb($symb);
	if ($type eq 'map') {
	$res=&symbread($map);
	} else {
	$res=$symb;
	}
	my %times=&get('firstaccesstimes',["$courseid\0$res"],$udom,$uname);
	return $times{"$courseid\0$res"};
	}

	sub set_first_access {
	my ($type)=@_;
	my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();
	my ($map,$id,$res)=&decode_symb($symb);
	if ($type eq 'map') {
	$res=&symbread($map);
	} else {
	$res=$symb;
	}
	my $firstaccess=&get_first_access($type,$symb);
	if (!$firstaccess) {
	return &put('firstaccesstimes',{"$courseid\0$res"=>time},$udom,$uname);
	}
	return 'already_set';
	}

sub checkout {	sub checkout {
my ($symb,$tuname,$tudom,$tcrsid)=@_;	my ($symb,$tuname,$tudom,$tcrsid)=@_;
my $now=time;	my $now=time;
Line 1673 sub checkin {	Line 1713 sub checkin {
my $now=time;	my $now=time;
my ($ta,$tb,$lonhost)=split(/\*/,$token);	my ($ta,$tb,$lonhost)=split(/\*/,$token);
$lonhost=~tr/A-Z/a-z/;	$lonhost=~tr/A-Z/a-z/;
my $dtoken=$ta.'_'.$hostip{$lonhost}.'_'.$tb;	my $dtoken=$ta.'_'.$hostname{$lonhost}.'_'.$tb;
$dtoken=~s/\W/\_/g;	$dtoken=~s/\W/\_/g;
my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=	my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));	split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
Line 1732 sub devalidate {	Line 1772 sub devalidate {
# - the student level sheet of this user in course's homespace	# - the student level sheet of this user in course's homespace
# - the assessment level sheet for this resource	# - the assessment level sheet for this resource
# for this user in user's homespace	# for this user in user's homespace
	# - current conditional state info
my $key=$uname.':'.$udom.':';	my $key=$uname.':'.$udom.':';
my $status=	my $status=
&del('nohist_calculatedsheets',	&del('nohist_calculatedsheets',
Line 1746 sub devalidate {	Line 1787 sub devalidate {
$uname.' at '.$udom.' for '.	$uname.' at '.$udom.' for '.
$symb.': '.$status);	$symb.': '.$status);
}	}
	&delenv('user.state.'.$cid);
}	}
}	}

Line 1798 sub hash2str {	Line 1840 sub hash2str {
sub hashref2str {	sub hashref2str {
my ($hashref)=@_;	my ($hashref)=@_;
my $result='__HASH_REF__';	my $result='__HASH_REF__';
foreach (keys(%$hashref)) {	foreach (sort(keys(%$hashref))) {
if (ref($_) eq 'ARRAY') {	if (ref($_) eq 'ARRAY') {
$result.=&arrayref2str($_).'=';	$result.=&arrayref2str($_).'=';
} elsif (ref($_) eq 'HASH') {	} elsif (ref($_) eq 'HASH') {
Line 1954 sub tmpreset {	Line 1996 sub tmpreset {
$namespace=~s/\//\_/g;	$namespace=~s/\//\_/g;
$namespace=~s/\W//g;	$namespace=~s/\W//g;

#FIXME needs to do something for /pub resources
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 ($domain eq 'public' && $stuname eq 'public') {
	$stuname=$ENV{'REMOTE_ADDR'};
	}
my $path=$perlvar{'lonDaemons'}.'/tmp';	my $path=$perlvar{'lonDaemons'}.'/tmp';
my %hash;	my %hash;
if (tie(%hash,'GDBM_File',	if (tie(%hash,'GDBM_File',
Line 1989 sub tmpstore {	Line 2033 sub tmpstore {
}	}
$namespace=~s/\//\_/g;	$namespace=~s/\//\_/g;
$namespace=~s/\W//g;	$namespace=~s/\W//g;
#FIXME needs to do something for /pub resources
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 ($domain eq 'public' && $stuname eq 'public') {
	$stuname=$ENV{'REMOTE_ADDR'};
	}
my $now=time;	my $now=time;
my %hash;	my %hash;
my $path=$perlvar{'lonDaemons'}.'/tmp';	my $path=$perlvar{'lonDaemons'}.'/tmp';
Line 2003 sub tmpstore {	Line 2049 sub tmpstore {
my $allkeys='';	my $allkeys='';
foreach my $key (keys(%$storehash)) {	foreach my $key (keys(%$storehash)) {
$allkeys.=$key.':';	$allkeys.=$key.':';
$hash{"$version:$symb:$key"}=$$storehash{$key};	$hash{"$version:$symb:$key"}=&freeze_escape($$storehash{$key});
}	}
$hash{"$version:$symb:timestamp"}=$now;	$hash{"$version:$symb:timestamp"}=$now;
$allkeys.='timestamp';	$allkeys.='timestamp';
Line 2030 sub tmprestore {	Line 2076 sub tmprestore {
$symb=escape($symb);	$symb=escape($symb);

if (!$namespace) { $namespace=$ENV{'request.state'}; }	if (!$namespace) { $namespace=$ENV{'request.state'}; }
#FIXME needs to do something for /pub resources
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 ($domain eq 'public' && $stuname eq 'public') {
	$stuname=$ENV{'REMOTE_ADDR'};
	}
my %returnhash;	my %returnhash;
$namespace=~s/\//\_/g;	$namespace=~s/\//\_/g;
$namespace=~s/\W//g;	$namespace=~s/\W//g;
Line 2051 sub tmprestore {	Line 2099 sub tmprestore {
my $key;	my $key;
$returnhash{"$scope:keys"}=$vkeys;	$returnhash{"$scope:keys"}=$vkeys;
foreach $key (@keys) {	foreach $key (@keys) {
$returnhash{"$scope:$key"}=$hash{"$scope:$symb:$key"};	$returnhash{"$scope:$key"}=&thaw_unescape($hash{"$scope:$symb:$key"});
$returnhash{"$key"}=$hash{"$scope:$symb:$key"};	$returnhash{"$key"}=&thaw_unescape($hash{"$scope:$symb:$key"});
}	}
}	}
if (!(untie(%hash))) {	if (!(untie(%hash))) {
Line 2093 sub store {	Line 2141 sub store {

my $namevalue='';	my $namevalue='';
foreach (keys %$storehash) {	foreach (keys %$storehash) {
$namevalue.=escape($_).'='.escape($$storehash{$_}).'&';	$namevalue.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&';
}	}
$namevalue=~s/\&$//;	$namevalue=~s/\&$//;
&courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);	&courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);
Line 2129 sub cstore {	Line 2177 sub cstore {

my $namevalue='';	my $namevalue='';
foreach (keys %$storehash) {	foreach (keys %$storehash) {
$namevalue.=escape($_).'='.escape($$storehash{$_}).'&';	$namevalue.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&';
}	}
$namevalue=~s/\&$//;	$namevalue=~s/\&$//;
&courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);	&courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);
Line 2163 sub restore {	Line 2211 sub restore {
my %returnhash=();	my %returnhash=();
foreach (split(/\&/,$answer)) {	foreach (split(/\&/,$answer)) {
my ($name,$value)=split(/\=/,$_);	my ($name,$value)=split(/\=/,$_);
$returnhash{&unescape($name)}=&unescape($value);	$returnhash{&unescape($name)}=&thaw_unescape($value);
}	}
my $version;	my $version;
for ($version=1;$version<=$returnhash{'version'};$version++) {	for ($version=1;$version<=$returnhash{'version'};$version++) {
Line 2219 sub privileged {	Line 2267 sub privileged {
my $now=time;	my $now=time;
if ($rolesdump ne '') {	if ($rolesdump ne '') {
foreach (split(/&/,$rolesdump)) {	foreach (split(/&/,$rolesdump)) {
if ($_!~/^rolesdef\&/) {	if ($_!~/^rolesdef_/) {
my ($area,$role)=split(/=/,$_);	my ($area,$role)=split(/=/,$_);
$area=~s/\_\w\w$//;	$area=~s/\_\w\w$//;
my ($trole,$tend,$tstart)=split(/_/,$role);	my ($trole,$tend,$tstart)=split(/_/,$role);
Line 2246 sub rolesinit {	Line 2294 sub rolesinit {
my $rolesdump=reply("dump:$domain:$username:roles",$authhost);	my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
if (($rolesdump eq 'con_lost') \|\| ($rolesdump eq '')) { return ''; }	if (($rolesdump eq 'con_lost') \|\| ($rolesdump eq '')) { return ''; }
my %allroles=();	my %allroles=();
my %thesepriv=();
my $now=time;	my $now=time;
my $userroles="user.login.time=$now\n";	my $userroles="user.login.time=$now\n";
my $thesestr;

if ($rolesdump ne '') {	if ($rolesdump ne '') {
foreach (split(/&/,$rolesdump)) {	foreach (split(/&/,$rolesdump)) {
if ($_!~/^rolesdef\&/) {	if ($_!~/^rolesdef_/) {
my ($area,$role)=split(/=/,$_);	my ($area,$role)=split(/=/,$_);
$area=~s/\_\w\w$//;	$area=~s/\_\w\w$//;
my ($trole,$tend,$tstart)=split(/_/,$role);
$userroles.='user.role.'.$trole.'.'.$area.'='.	my ($trole,$tend,$tstart);
$tstart.'.'.$tend."\n";	if ($role=~/^cr/) {
# log the associated role with the area	($trole,my $trest)=($role=~m\|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$\|);
&userrolelog($trole,$username,$domain,$area,$tstart,$tend);	($tend,$tstart)=split('_',$trest);
if ($tend!=0) {	} else {
if ($tend<$now) {	($trole,$tend,$tstart)=split(/_/,$role);
$trole='';	}
}	$userroles.=&set_arearole($trole,$area,$tstart,$tend,$domain,$username);
}	if (($tend!=0) && ($tend<$now)) { $trole=''; }
if ($tstart!=0) {	if (($tstart!=0) && ($tstart>$now)) { $trole=''; }
if ($tstart>$now) {
$trole='';
}
}
if (($area ne '') && ($trole ne '')) {	if (($area ne '') && ($trole ne '')) {
my $spec=$trole.'.'.$area;	my $spec=$trole.'.'.$area;
my ($tdummy,$tdomain,$trest)=split(/\//,$area);	my ($tdummy,$tdomain,$trest)=split(/\//,$area);
if ($trole =~ /^cr\//) {	if ($trole =~ /^cr\//) {
my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);	&custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
my $homsvr=homeserver($rauthor,$rdomain);
if ($hostname{$homsvr} ne '') {
my ($rdummy,$roledef)=
&get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);

if (($rdummy ne 'con_lost') && ($roledef ne '')) {
my ($syspriv,$dompriv,$coursepriv)=
split(/\_/,$roledef);
if (defined($syspriv)) {
$allroles{'cm./'}.=':'.$syspriv;
$allroles{$spec.'./'}.=':'.$syspriv;
}
if ($tdomain ne '') {
if (defined($dompriv)) {
$allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv;
$allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;
}
if ($trest ne '') {
if (defined($coursepriv)) {
$allroles{'cm.'.$area}.=':'.$coursepriv;
$allroles{$spec.'.'.$area}.=':'.$coursepriv;
}
}
}
}
}
} else {	} else {
if (defined($pr{$trole.':s'})) {	&standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
$allroles{'cm./'}.=':'.$pr{$trole.':s'};
$allroles{$spec.'./'}.=':'.$pr{$trole.':s'};
}
if ($tdomain ne '') {
if (defined($pr{$trole.':d'})) {
$allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
$allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
}
if ($trest ne '') {
if (defined($pr{$trole.':c'})) {
$allroles{'cm.'.$area}.=':'.$pr{$trole.':c'};
$allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'};
}
}
}
}	}
}	}
}	}
}	}
my $adv=0;	my ($author,$adv) = &set_userprivs(\$userroles,\%allroles);
my $author=0;
foreach (keys %allroles) {
%thesepriv=();
if (($_!~/^st/) && ($_!~/^ta/) && ($_!~/^cm/)) { $adv=1; }
if (($_=~/^au/) \|\| ($_=~/^ca/)) { $author=1; }
foreach (split(/:/,$allroles{$_})) {
if ($_ ne '') {
my ($privilege,$restrictions)=split(/&/,$_);
if ($restrictions eq '') {
$thesepriv{$privilege}='F';
} else {
if ($thesepriv{$privilege} ne 'F') {
$thesepriv{$privilege}.=$restrictions;
}
}
}
}
$thesestr='';
foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; }
$userroles.='user.priv.'.$_.'='.$thesestr."\n";
}
$userroles.='user.adv='.$adv."\n".	$userroles.='user.adv='.$adv."\n".
'user.author='.$author."\n";	'user.author='.$author."\n";
$ENV{'user.adv'}=$adv;	$ENV{'user.adv'}=$adv;
Line 2352 sub rolesinit {	Line 2332 sub rolesinit {
return $userroles;	return $userroles;
}	}

	sub set_arearole {
	my ($trole,$area,$tstart,$tend,$domain,$username) = @_;
	# log the associated role with the area
	&userrolelog($trole,$username,$domain,$area,$tstart,$tend);
	return 'user.role.'.$trole.'.'.$area.'='.$tstart.'.'.$tend."\n";
	}

	sub custom_roleprivs {
	my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;
	my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
	my $homsvr=homeserver($rauthor,$rdomain);
	if ($hostname{$homsvr} ne '') {
	my ($rdummy,$roledef)=
	&get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);
	if (($rdummy ne 'con_lost') && ($roledef ne '')) {
	my ($syspriv,$dompriv,$coursepriv)=split(/\_/,$roledef);
	if (defined($syspriv)) {
	$$allroles{'cm./'}.=':'.$syspriv;
	$$allroles{$spec.'./'}.=':'.$syspriv;
	}
	if ($tdomain ne '') {
	if (defined($dompriv)) {
	$$allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv;
	$$allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;
	}
	if (($trest ne '') && (defined($coursepriv))) {
	$$allroles{'cm.'.$area}.=':'.$coursepriv;
	$$allroles{$spec.'.'.$area}.=':'.$coursepriv;
	}
	}
	}
	}
	}


	sub standard_roleprivs {
	my ($allroles,$trole,$tdomain,$spec,$trest,$area) = @_;
	if (defined($pr{$trole.':s'})) {
	$$allroles{'cm./'}.=':'.$pr{$trole.':s'};
	$$allroles{$spec.'./'}.=':'.$pr{$trole.':s'};
	}
	if ($tdomain ne '') {
	if (defined($pr{$trole.':d'})) {
	$$allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
	$$allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
	}
	if (($trest ne '') && (defined($pr{$trole.':c'}))) {
	$$allroles{'cm.'.$area}.=':'.$pr{$trole.':c'};
	$$allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'};
	}
	}
	}

	sub set_userprivs {
	my ($userroles,$allroles) = @_;
	my $author=0;
	my $adv=0;
	foreach (keys %{$allroles}) {
	my %thesepriv=();
	if (($_=~/^au/) \|\| ($_=~/^ca/)) { $author=1; }
	foreach (split(/:/,$$allroles{$_})) {
	if ($_ ne '') {
	my ($privilege,$restrictions)=split(/&/,$_);
	if ($restrictions eq '') {
	$thesepriv{$privilege}='F';
	} elsif ($thesepriv{$privilege} ne 'F') {
	$thesepriv{$privilege}.=$restrictions;
	}
	if ($thesepriv{'adv'} eq 'F') { $adv=1; }
	}
	}
	my $thesestr='';
	foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; }
	$$userroles.='user.priv.'.$_.'='.$thesestr."\n";
	}
	return ($author,$adv);
	}

# --------------------------------------------------------------- get interface	# --------------------------------------------------------------- get interface

sub get {	sub get {
Line 2373 sub get {	Line 2431 sub get {
my %returnhash=();	my %returnhash=();
my $i=0;	my $i=0;
foreach (@$storearr) {	foreach (@$storearr) {
$returnhash{$_}=unescape($pairs[$i]);	$returnhash{$_}=&thaw_unescape($pairs[$i]);
$i++;	$i++;
}	}
return %returnhash;	return %returnhash;
Line 2412 sub dump {	Line 2470 sub dump {
my %returnhash=();	my %returnhash=();
foreach (@pairs) {	foreach (@pairs) {
my ($key,$value)=split(/=/,$_);	my ($key,$value)=split(/=/,$_);
$returnhash{unescape($key)}=unescape($value);	$returnhash{unescape($key)}=&thaw_unescape($value);
}	}
return %returnhash;	return %returnhash;
}	}
Line 2458 sub currentdump {	Line 2516 sub currentdump {
my ($key,$value)=split(/=/,$_);	my ($key,$value)=split(/=/,$_);
my ($symb,$param) = split(/:/,$key);	my ($symb,$param) = split(/:/,$key);
$returnhash{&unescape($symb)}->{&unescape($param)} =	$returnhash{&unescape($symb)}->{&unescape($param)} =
&unescape($value);	&thaw_unescape($value);
}	}
}	}
return %returnhash;	return %returnhash;
Line 2524 sub put {	Line 2582 sub put {
my $uhome=&homeserver($uname,$udomain);	my $uhome=&homeserver($uname,$udomain);
my $items='';	my $items='';
foreach (keys %$storehash) {	foreach (keys %$storehash) {
$items.=&escape($_).'='.&escape($$storehash{$_}).'&';	$items.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&';
	}
	$items=~s/\&$//;
	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.=$_.'='.&freeze_escape($$storehash{$_}).'&';
	}
	foreach (keys %allitems) {
	$allitems{$_} =~ s/\:$//;
	$items.= $_.'='.$allitems{$_}.'&';
}	}
$items=~s/\&$//;	$items=~s/\&$//;
return &reply("put:$udomain:$uname:$namespace:$items",$uhome);	return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
Line 2539 sub cput {	Line 2621 sub cput {
my $uhome=&homeserver($uname,$udomain);	my $uhome=&homeserver($uname,$udomain);
my $items='';	my $items='';
foreach (keys %$storehash) {	foreach (keys %$storehash) {
$items.=escape($_).'='.escape($$storehash{$_}).'&';	$items.=escape($_).'='.&freeze_escape($$storehash{$_}).'&';
}	}
$items=~s/\&$//;	$items=~s/\&$//;
return &critical("put:$udomain:$uname:$namespace:$items",$uhome);	return &critical("put:$udomain:$uname:$namespace:$items",$uhome);
Line 2562 sub eget {	Line 2644 sub eget {
my %returnhash=();	my %returnhash=();
my $i=0;	my $i=0;
foreach (@$storearr) {	foreach (@$storearr) {
$returnhash{$_}=unescape($pairs[$i]);	$returnhash{$_}=&thaw_unescape($pairs[$i]);
$i++;	$i++;
}	}
return %returnhash;	return %returnhash;
Line 2605 sub customaccess {	Line 2687 sub customaccess {
# ------------------------------------------------- Check for a user privilege	# ------------------------------------------------- Check for a user privilege

sub allowed {	sub allowed {
my ($priv,$uri)=@_;	my ($priv,$uri,$symb)=@_;
$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 access to user's own portfolio contents
	my ($space,$domain,$name,$dir)=split('/',$uri);
	if (('uploaded' eq $space) && ($ENV{'user.name'} eq $name) &&
	($ENV{'user.domain'} eq $domain) && ('portfolio' eq $dir)) {
	return 'F';
	}

# Free bre to public access	# Free bre to public access

if ($priv eq 'bre') {	if ($priv eq 'bre') {
Line 2682 sub allowed {	Line 2773 sub allowed {

# URI is an uploaded document for this course	# URI is an uploaded document for this course

if (($priv eq 'bre') &&	if (($priv eq 'bre') && ($uri=~m\|^uploaded/\|)) {
($uri=~/^uploaded\/$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}\/$ENV{'course.'.$ENV{'request.course.id'}.'.num'}/)) {	my $refuri=$ENV{'httpref.'.$orguri};
return 'F';	if ($refuri) {
	if ($refuri =~ m\|^/adm/\|) {
	$thisallowed='F';
	}
	}
}	}

# Full access at system, domain or course-wide level? Exit.	# Full access at system, domain or course-wide level? Exit.

if ($thisallowed=~/F/) {	if ($thisallowed=~/F/) {
Line 2872 sub allowed {	Line 2968 sub allowed {

if ($thisallowed=~/X/) {	if ($thisallowed=~/X/) {
if ($ENV{'acc.randomout'}) {	if ($ENV{'acc.randomout'}) {
my $symb=&symbread($uri,1);	if (!$symb) { $symb=&symbread($uri,1); }
if (($symb) && ($ENV{'acc.randomout'}=~/\&\Q$symb\E\&/)) {	if (($symb) && ($ENV{'acc.randomout'}=~/\&\Q$symb\E\&/)) {
return '';	return '';
}	}
Line 3008 sub log_query {	Line 3104 sub log_query {
return get_query_reply($queryid);	return get_query_reply($queryid);
}	}

	# ------- Request retrieval of institutional classlists for course(s)

	sub fetch_enrollment_query {
	my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_;
	my $homeserver;
	my $maxtries = 1;
	if ($context eq 'automated') {
	$homeserver = $perlvar{'lonHostID'};
	$maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout
	} else {
	$homeserver = &homeserver($cnum,$dom);
	}
	my $host=$hostname{$homeserver};
	my $cmd = '';
	foreach (keys %{$affiliatesref}) {
	$cmd .= $_.'='.join(",",@{$$affiliatesref{$_}}).'%%';
	}
	$cmd =~ s/%%$//;
	$cmd = &escape($cmd);
	my $query = 'fetchenrollment';
	my $queryid=&reply("querysend:".$query.':'.$dom.':'.$ENV{'user.name'}.':'.$cmd,$homeserver);
	unless ($queryid=~/^\Q$host\E\_/) {
	&logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum);
	return 'error: '.$queryid;
	}
	my $reply = &get_query_reply($queryid);
	my $tries = 1;
	while (($reply=~/^timeout/) && ($tries < $maxtries)) {
	$reply = &get_query_reply($queryid);
	$tries ++;
	}
	if ( ($reply =~/^timeout/) \|\| ($reply =~/^error/) ) {
	&logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$ENV{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
	} else {
	my @responses = split/:/,$reply;
	if ($homeserver eq $perlvar{'lonHostID'}) {
	foreach (@responses) {
	my ($key,$value) = split/=/,$_;
	$$replyref{$key} = $value;
	}
	} else {
	my $pathname = $perlvar{'lonDaemons'}.'/tmp';
	foreach (@responses) {
	my ($key,$value) = split/=/,$_;
	$$replyref{$key} = $value;
	if ($value > 0) {
	foreach (@{$$affiliatesref{$key}}) {
	my $filename = $dom.'_'.$key.'_'.$_.'_classlist.xml';
	my $destname = $pathname.'/'.$filename;
	my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver);
	if ($xml_classlist =~ /^error/) {
	&logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum);
	} else {
	if ( open(FILE,">$destname") ) {
	print FILE &unescape($xml_classlist);
	close(FILE);
	} else {
	&logthis('fetch_enrollment_query - error opening classlist file '.$destname.' '.$context.' '.$cnum);
	}
	}
	}
	}
	}
	}
	return 'ok';
	}
	return 'error';
	}

sub get_query_reply {	sub get_query_reply {
my $queryid=shift;	my $queryid=shift;
my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid;	my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid;
Line 3052 sub userlog_query {	Line 3217 sub userlog_query {
return &log_query($uname,$udom,'userlog',%filters);	return &log_query($uname,$udom,'userlog',%filters);
}	}

	#--------- Call auto-enrollment subs in localenroll.pm for homeserver for course

	sub auto_run {
	my ($cnum,$cdom) = @_;
	my $homeserver = &homeserver($cnum,$cdom);
	my $response = &reply('autorun:'.$cdom,$homeserver);
	return $response;
	}

	sub auto_get_sections {
	my ($cnum,$cdom,$inst_coursecode) = @_;
	my $homeserver = &homeserver($cnum,$cdom);
	my @secs = ();
	my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));
	unless ($response eq 'refused') {
	@secs = split/:/,$response;
	}
	return @secs;
	}

	sub auto_new_course {
	my ($cnum,$cdom,$inst_course_id,$owner) = @_;
	my $homeserver = &homeserver($cnum,$cdom);
	my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver));
	return $response;
	}

	sub auto_validate_courseID {
	my ($cnum,$cdom,$inst_course_id) = @_;
	my $homeserver = &homeserver($cnum,$cdom);
	my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver));
	return $response;
	}

	sub auto_create_password {
	my ($cnum,$cdom,$authparam) = @_;
	my $homeserver = &homeserver($cnum,$cdom);
	my $create_passwd = 0;
	my $authchk = '';
	my $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver));
	if ($response eq 'refused') {
	$authchk = 'refused';
	} else {
	($authparam,$create_passwd,$authchk) = split/:/,$response;
	}
	return ($authparam,$create_passwd,$authchk);
	}

	sub auto_instcode_format {
	my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_;
	my $courses = '';
	my $homeserver;
	if ($caller eq 'global') {
	foreach my $tryserver (keys %libserv) {
	if ($hostdom{$tryserver} eq $codedom) {
	$homeserver = $tryserver;
	last;
	}
	}
	if (($ENV{'user.name'}) && ($ENV{'user.domain'} eq $codedom)) {
	$homeserver = &homeserver($ENV{'user.name'},$codedom);
	}
	} else {
	$homeserver = &homeserver($caller,$codedom);
	}
	foreach (keys %{$instcodes}) {
	$courses .= &escape($_).'='.&escape($$instcodes{$_}).'&';
	}
	chop($courses);
	my $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$homeserver);
	unless ($response =~ /(con_lost\|error\|no_such_host\|refused)/) {
	my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = split/:/,$response;
	%{$codes} = &str2hash($codes_str);
	@{$codetitles} = &str2array($codetitles_str);
	%{$cat_titles} = &str2hash($cat_titles_str);
	%{$cat_order} = &str2hash($cat_order_str);
	return 'ok';
	}
	return $response;
	}

# ------------------------------------------------------------------ Plain Text	# ------------------------------------------------------------------ Plain Text

sub plaintext {	sub plaintext {
Line 3226 sub modifyuser {	Line 3472 sub modifyuser {
if (defined($middle)) { $names{'middlename'} = $middle; }	if (defined($middle)) { $names{'middlename'} = $middle; }
if ($last) { $names{'lastname'} = $last; }	if ($last) { $names{'lastname'} = $last; }
if (defined($gene)) { $names{'generation'} = $gene; }	if (defined($gene)) { $names{'generation'} = $gene; }
if ($email) { $names{'notification'} = $email;	if ($email) {
$names{'critnotification'} = $email; }	$email=~s/[^\w\@\.\-\,]//gs;
	if ($email=~/\@/) { $names{'notification'} = $email;
	$names{'critnotification'} = $email;
	$names{'permanentemail'} = $email; }
	}
my $reply = &put('environment', \%names, $udom,$uname);	my $reply = &put('environment', \%names, $udom,$uname);
if ($reply ne 'ok') { return 'error: '.$reply; }	if ($reply ne 'ok') { return 'error: '.$reply; }
&logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.	&logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
Line 3242 sub modifyuser {	Line 3491 sub modifyuser {

sub modifystudent {	sub modifystudent {
my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,	my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
$end,$start,$forceid,$desiredhome,$email,$type,$cid)=@_;	$end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid)=@_;
if (!$cid) {	if (!$cid) {
unless ($cid=$ENV{'request.course.id'}) {	unless ($cid=$ENV{'request.course.id'}) {
return 'not_in_class';	return 'not_in_class';
Line 3257 sub modifystudent {	Line 3506 sub modifystudent {
# students environment	# students environment
$uid = undef if (!$forceid);	$uid = undef if (!$forceid);
$reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,	$reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
$gene,$usec,$end,$start,$type,$cid);	$gene,$usec,$end,$start,$type,$locktype,$cid);
return $reply;	return $reply;
}	}

sub modify_student_enrollment {	sub modify_student_enrollment {
my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,	my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid) = @_;
$cid) = @_;
my ($cdom,$cnum,$chome);	my ($cdom,$cnum,$chome);
if (!$cid) {	if (!$cid) {
unless ($cid=$ENV{'request.course.id'}) {	unless ($cid=$ENV{'request.course.id'}) {
Line 3305 sub modify_student_enrollment {	Line 3553 sub modify_student_enrollment {
$gene = $tmp{'generation'} if (!defined($gene) \|\| $gene eq '');	$gene = $tmp{'generation'} if (!defined($gene) \|\| $gene eq '');
$uid = $tmp{'id'} if (!defined($uid) \|\| $uid eq '');	$uid = $tmp{'id'} if (!defined($uid) \|\| $uid eq '');
}	}
my $fullname = &Apache::loncoursedata::ProcessFullName($last,$gene,	my $fullname = &format_name($first,$middle,$last,$gene,'lastname');
$first,$middle);
my $reply=cput('classlist',	my $reply=cput('classlist',
{"$uname:$udom" =>	{"$uname:$udom" =>
join(':',$end,$start,$uid,$usec,$fullname,$type) },	join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) },
$cdom,$cnum);	$cdom,$cnum);
unless (($reply eq 'ok') \|\| ($reply eq 'delayed')) {	unless (($reply eq 'ok') \|\| ($reply eq 'delayed')) {
return 'error: '.$reply;	return 'error: '.$reply;
Line 3323 sub modify_student_enrollment {	Line 3570 sub modify_student_enrollment {
return &assignrole($udom,$uname,$uurl,'st',$end,$start);	return &assignrole($udom,$uname,$uurl,'st',$end,$start);
}	}

	sub format_name {
	my ($firstname,$middlename,$lastname,$generation,$first)=@_;
	my $name;
	if ($first ne 'lastname') {
	$name=$firstname.' '.$middlename.' '.$lastname.' '.$generation;
	} else {
	if ($lastname=~/\S/) {
	$name.= $lastname.' '.$generation.', '.$firstname.' '.$middlename;
	$name=~s/\s+,/,/;
	} else {
	$name.= $firstname.' '.$middlename.' '.$generation;
	}
	}
	$name=~s/^\s+//;
	$name=~s/\s+$//;
	$name=~s/\s+/ /g;
	return $name;
	}

# ------------------------------------------------- Write to course preferences	# ------------------------------------------------- Write to course preferences

sub writecoursepref {	sub writecoursepref {
Line 3345 sub writecoursepref {	Line 3611 sub writecoursepref {
# ---------------------------------------------------------- Make/modify course	# ---------------------------------------------------------- Make/modify course

sub createcourse {	sub createcourse {
my ($udom,$description,$url,$course_server,$nonstandard)=@_;	my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,$course_owner)=@_;
$url=&declutter($url);	$url=&declutter($url);
my $cid='';	my $cid='';
unless (&allowed('ccc',$udom)) {	unless (&allowed('ccc',$udom)) {
Line 3378 sub createcourse {	Line 3644 sub createcourse {
return 'error: no such course';	return 'error: no such course';
}	}
# ----------------------------------------------------------------- Course made	# ----------------------------------------------------------------- Course made
# log existance	# log existence
&courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description),	&courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description).
$uhome);	':'.&escape($inst_code).':'.&escape($course_owner),$uhome);
&flushcourselogs();	&flushcourselogs();
# set toplevel url	# set toplevel url
my $topurl=$url;	my $topurl=$url;
Line 3433 sub revokecustomrole {	Line 3699 sub revokecustomrole {
$deleteflag);	$deleteflag);
}	}

	# ------------------------------------------------------------ Disk usage
	sub diskusage {
	my ($udom,$uname,$directoryRoot)=@_;
	$directoryRoot =~ s/\/$//;
	my $listing=&reply('du:'.$directoryRoot,homeserver($uname,$udom));
	return $listing;
	}

	sub is_locked {
	my ($file_name, $domain, $user) = @_;
	my @check;
	my $is_locked;
	push @check, $file_name;
	my %locked = &Apache::lonnet::get('file_permissions',\@check,
	$ENV{'user.domain'},$ENV{'user.name'});
	if (ref($locked{$file_name}) eq 'ARRAY') {
	$is_locked = 'true';
	} else {
	$is_locked = 'false';
	}
	}

	# ------------------------------------------------------------- Mark as Read Only

	sub mark_as_readonly {
	my ($domain,$user,$files,$what) = @_;
	my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user);
	foreach my $file (@{$files}) {
	push(@{$current_permissions{$file}},$what);
	}
	&Apache::lonnet::put('file_permissions',\%current_permissions,$domain,$user);
	return;
	}

	# ------------------------------------------------------------Save Selected Files

	sub save_selected_files {
	my ($user, $path, @files) = @_;
	my $filename = $user."savedfiles";
	my @other_files = &files_not_in_path($user, $path);
	open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
	foreach my $file (@files) {
	print (OUT $ENV{'form.currentpath'}.$file."\n");
	}
	foreach my $file (@other_files) {
	print (OUT $file."\n");
	}
	close (OUT);
	return 'ok';
	}

	sub clear_selected_files {
	my ($user) = @_;
	my $filename = $user."savedfiles";
	open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
	print (OUT undef);
	close (OUT);
	return ("ok");
	}

	sub files_in_path {
	my ($user, $path) = @_;
	my $filename = $user."savedfiles";
	my %return_files;
	open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
	while (my $line_in = <IN>) {
	chomp ($line_in);
	my @paths_and_file = split (m!/!, $line_in);
	my $file_part = pop (@paths_and_file);
	my $path_part = join ('/', @paths_and_file);
	$path_part.='/';
	my $path_and_file = $path_part.$file_part;
	if ($path_part eq $path) {
	$return_files{$file_part}= 'selected';
	}
	}
	close (IN);
	return (\%return_files);
	}

	# called in portfolio select mode, to show files selected NOT in current directory
	sub files_not_in_path {
	my ($user, $path) = @_;
	my $filename = $user."savedfiles";
	my @return_files;
	my $path_part;
	open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
	while (<IN>) {
	#ok, I know it's clunky, but I want it to work
	my @paths_and_file = split m!/!, $_;
	my $file_part = pop (@paths_and_file);
	chomp ($file_part);
	my $path_part = join ('/', @paths_and_file);
	$path_part .= '/';
	my $path_and_file = $path_part.$file_part;
	if ($path_part ne $path) {
	push (@return_files, ($path_and_file));
	}
	}
	close (OUT);
	return (@return_files);
	}

	#--------------------------------------------------------------Get Marked as Read Only

	sub get_marked_as_readonly {
	my ($domain,$user,$what) = @_;
	my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user);
	my @readonly_files;
	while (my ($file_name,$value) = each(%current_permissions)) {
	if (ref($value) eq "ARRAY"){
	foreach my $stored_what (@{$value}) {
	if ($stored_what eq $what) {
	push(@readonly_files, $file_name);
	} elsif (!defined($what)) {
	push(@readonly_files, $file_name);
	}
	}
	}
	}
	return @readonly_files;
	}
	#-----------------------------------------------------------Get Marked as Read Only Hash

	sub get_marked_as_readonly_hash {
	my ($domain,$user,$what) = @_;
	my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user);
	my %readonly_files;
	while (my ($file_name,$value) = each(%current_permissions)) {
	if (ref($value) eq "ARRAY"){
	foreach my $stored_what (@{$value}) {
	if ($stored_what eq $what) {
	$readonly_files{$file_name} = 'locked';
	} elsif (!defined($what)) {
	$readonly_files{$file_name} = 'locked';
	}
	}
	}
	}
	return %readonly_files;
	}
	# ------------------------------------------------------------ Unmark as Read Only

	sub unmark_as_readonly {
	# unmarks all files locked by $what
	# for portfolio submissions, $what contains $crsid and $symb
	my ($domain,$user,$what) = @_;
	my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user);
	my @readonly_files = &Apache::lonnet::get_marked_as_readonly($domain,$user,$what);
	foreach my $file(@readonly_files){
	my $current_locks = $current_permissions{$file};
	my @new_locks;
	my @del_keys;
	if (ref($current_locks) eq "ARRAY"){
	foreach my $locker (@{$current_locks}) {
	unless ($locker eq $what) {
	push(@new_locks, $what);
	}
	}
	if (@new_locks > 0) {
	$current_permissions{$file} = \@new_locks;
	} else {
	push(@del_keys, $file);
	&Apache::lonnet::del('file_permissions',\@del_keys, $domain, $user);
	delete $current_permissions{$file};
	}
	}
	}
	&Apache::lonnet::put('file_permissions',\%current_permissions,$domain,$user);
	return;
	}

# ------------------------------------------------------------ Directory lister	# ------------------------------------------------------------ Directory lister

sub dirlist {	sub dirlist {
Line 3541 sub GetFileTimestamp {	Line 3979 sub GetFileTimestamp {

sub directcondval {	sub directcondval {
my $number=shift;	my $number=shift;
	if (!defined($ENV{'user.state.'.$ENV{'request.course.id'}})) {
	&Apache::lonuserstate::evalstate();
	}
if ($ENV{'user.state.'.$ENV{'request.course.id'}}) {	if ($ENV{'user.state.'.$ENV{'request.course.id'}}) {
return substr($ENV{'user.state.'.$ENV{'request.course.id'}},$number,1);	return substr($ENV{'user.state.'.$ENV{'request.course.id'}},$number,1);
} else {	} else {
Line 3594 sub condval {	Line 4035 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 3603 sub courseresdata {	Line 4044 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 3766 sub EXT {	Line 4207 sub EXT {

my $section;	my $section;
if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) {	if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) {
	if (!$symbparm) { $symbparm=&symbread(); }
	}
	my ($courselevelm,$courselevel);
	if ($symbparm && defined($courseid) &&
	$courseid eq $ENV{'request.course.id'}) {

#print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;	#print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;

# ----------------------------------------------------- Cascading lookup scheme	# ----------------------------------------------------- Cascading lookup scheme
if (!$symbparm) { $symbparm=&symbread(); }
my $symbp=$symbparm;	my $symbp=$symbparm;
my $mapp=(&decode_symb($symbp))[0];	my $mapp=(&decode_symb($symbp))[0];

Line 3781 sub EXT {	Line 4226 sub EXT {
($ENV{'user.domain'} eq $udom)) {	($ENV{'user.domain'} eq $udom)) {
$section=$ENV{'request.course.sec'};	$section=$ENV{'request.course.sec'};
} else {	} else {
if (! defined($usection)) {	if (! defined($usection)) {
$section=&usection($udom,$uname,$courseid);	$section=&getsection($udom,$uname,$courseid);
} else {	} else {
$section = $usection;	$section = $usection;
}	}
}	}

my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;	my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
my $seclevelr=$courseid.'.['.$section.'].'.$symbparm;	my $seclevelr=$courseid.'.['.$section.'].'.$symbparm;
my $seclevelm=$courseid.'.['.$section.'].'.$mapparm;	my $seclevelm=$courseid.'.['.$section.'].'.$mapparm;

my $courselevel=$courseid.'.'.$spacequalifierrest;	$courselevel=$courseid.'.'.$spacequalifierrest;
my $courselevelr=$courseid.'.'.$symbparm;	my $courselevelr=$courseid.'.'.$symbparm;
my $courselevelm=$courseid.'.'.$mapparm;	$courselevelm=$courseid.'.'.$mapparm;

# ----------------------------------------------------------- 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
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 3823 sub EXT {	Line 4267 sub EXT {
$uname." at ".$udom.": ".	$uname." at ".$udom.": ".
$tmp."</font>");	$tmp."</font>");
} elsif ($tmp=~/error: 2 /) {	} elsif ($tmp=~/error: 2 /) {
&EXT_cache_set($udom,$uname);	&EXT_cache_set($udom,$uname);
} elsif ($tmp =~ /^(con_lost\|no_such_host)/) {	} elsif ($tmp =~ /^(con_lost\|no_such_host)/) {
return $tmp;	return $tmp;
}	}
}	}
}	}

# -------------------------------------------------------- second, check course	# ------------------------------------------------ second, check some of course

my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'},	my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'},
$ENV{'course.'.$courseid.'.domain'},	$ENV{'course.'.$courseid.'.domain'},
($seclevelr,$seclevelm,$seclevel,	($seclevelr,$seclevelm,$seclevel,
$courselevelr,$courselevelm,	$courselevelr));
$courselevel));
if (defined($coursereply)) { return $coursereply; }	if (defined($coursereply)) { return $coursereply; }

# ------------------------------------------------------ third, check map parms	# ------------------------------------------------------ third, check map parms
Line 3850 sub EXT {	Line 4293 sub EXT {
}	}
if ($thisparm) { return $thisparm; }	if ($thisparm) { return $thisparm; }
}	}
# --------------------------------------------- last, look in resource metadata	# ------------------------------------------ fourth, look in resource metadata

$spacequalifierrest=~s/\./\_/;	$spacequalifierrest=~s/\./\_/;
my $filename;	my $filename;
Line 3865 sub EXT {	Line 4308 sub EXT {
$metadata=&metadata($filename,'parameter_'.$spacequalifierrest);	$metadata=&metadata($filename,'parameter_'.$spacequalifierrest);
if (defined($metadata)) { return $metadata; }	if (defined($metadata)) { return $metadata; }

	# ---------------------------------------------- fourth, look in rest pf course
	if ($symbparm && defined($courseid) &&
	$courseid eq $ENV{'request.course.id'}) {
	my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'},
	$ENV{'course.'.$courseid.'.domain'},
	($courselevelm,$courselevel));
	if (defined($coursereply)) { return $coursereply; }
	}
# ------------------------------------------------------------------ Cascade up	# ------------------------------------------------------------------ Cascade up
unless ($space eq '0') {	unless ($space eq '0') {
my @parts=split(/_/,$space);	my @parts=split(/_/,$space);
Line 3907 sub packages_tab_default {	Line 4358 sub packages_tab_default {
if (defined($packagetab{"$pack_type&$name&default"})) {	if (defined($packagetab{"$pack_type&$name&default"})) {
return $packagetab{"$pack_type&$name&default"};	return $packagetab{"$pack_type&$name&default"};
}	}
	if ($pack_type eq 'part') { $pack_part='0'; }
if (defined($packagetab{$pack_type."_".$pack_part."&$name&default"})) {	if (defined($packagetab{$pack_type."_".$pack_part."&$name&default"})) {
return $packagetab{$pack_type."_".$pack_part."&$name&default"};	return $packagetab{$pack_type."_".$pack_part."&$name&default"};
}	}
Line 3932 sub add_prefix_and_part {	Line 4384 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\|^uploaded/\|)) {	($uri =~ m\|home/[^/]+/public_html/\|)) {
return undef;	return undef;
}	}
my $filename=$uri;	my $filename=$uri;
Line 3949 sub metadata {	Line 4404 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('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('meta',$uri);
	undef(%metaentry);
}	}
my %metathesekeys=();	my %metathesekeys=();
unless ($filename=~/\.meta$/) { $filename.='.meta'; }	unless ($filename=~/\.meta$/) { $filename.='.meta'; }
my $metastring=&getfile(&filelocation('',&clutter($filename)));	my $metastring;
	if ($uri !~ m\|^uploaded/\|) {
	my $file=&filelocation('',&clutter($filename));
	#push(@{$metaentry{$uri.'.file'}},$file);
	$metastring=&getfile($file);
	}
my $parser=HTML::LCParser->new(\$metastring);	my $parser=HTML::LCParser->new(\$metastring);
my $token;	my $token;
undef %metathesekeys;	undef %metathesekeys;
Line 3982 sub metadata {	Line 4443 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 4007 sub metadata {	Line 4468 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 4047 sub metadata {	Line 4508 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 4058 sub metadata {	Line 4519 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 4086 sub metadata {	Line 4547 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 4095 sub metadata {	Line 4556 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('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 4127 sub metadata_create_package_def {	Line 4588 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 4179 sub metadata_generate_part0 {	Line 4640 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 $key=$ENV{'request.course.id'}."\0".$symb;
return &metadata($urlsymb,'title');	my ($result,$cached)=&is_cached_new('title',$key);
}	if (defined($cached)) {
my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600);	return $result;
if (defined($cached)) { return $result; }	}
my ($map,$resid,$url)=&decode_symb($symb);	my ($map,$resid,$url)=&decode_symb($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',
&GDBM_READER(),0640)) {	&GDBM_READER(),0640)) {
my $mapid=$bighash{'map_pc_'.&clutter($map)};	my $mapid=$bighash{'map_pc_'.&clutter($map)};
$title=$bighash{'title_'.$mapid.'.'.$resid};	$title=$bighash{'title_'.$mapid.'.'.$resid};
untie %bighash;	untie %bighash;
}	}
$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);
} else {	}
return &metadata($urlsymb,'title');	$urlsymb=$url;
}	}
	my $title=&metadata($urlsymb,'title');
	if (!$title) { $title=(split('/',$urlsymb))[-1]; }
	return $title;
}	}

# ------------------------------------------------- Update symbolic store links	# ------------------------------------------------- Update symbolic store links
Line 4212 sub symblist {	Line 4676 sub symblist {
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.'___'.&deversion($newhash{$_});	$hash{declutter($_)}=&encode_symb($mapname,$newhash{$_}->[1],
	$newhash{$_}->[0]);
}	}
if (untie(%hash)) {	if (untie(%hash)) {
return 'ok';	return 'ok';
Line 4225 sub symblist {	Line 4690 sub symblist {
# --------------------------------------------------------------- Verify a symb	# --------------------------------------------------------------- Verify a symb

sub symbverify {	sub symbverify {
my ($symb,$thisfn)=@_;	my ($symb,$thisurl)=@_;
	my $thisfn=$thisurl;
	# wrapper not part of symbs
	$thisfn=~s/^\/adm\/wrapper//;
$thisfn=&declutter($thisfn);	$thisfn=&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; }
Line 4235 sub symbverify {	Line 4703 sub symbverify {
unless ($url eq $thisfn) { return 0; }	unless ($url eq $thisfn) { return 0; }

$symb=&symbclean($symb);	$symb=&symbclean($symb);
	$thisurl=&deversion($thisurl);
$thisfn=&deversion($thisfn);	$thisfn=&deversion($thisfn);

my %bighash;	my %bighash;
Line 4242 sub symbverify {	Line 4711 sub symbverify {

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($thisurl)};
unless ($ids) {	unless ($ids) {
$ids=$bighash{'ids_/'.$thisfn};	$ids=$bighash{'ids_/'.$thisurl};
}	}
if ($ids) {	if ($ids) {
# ------------------------------------------------------------------- Has ID(s)	# ------------------------------------------------------------------- Has ID(s)
Line 4253 sub symbverify {	Line 4722 sub symbverify {
if (	if (
&symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)	&symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
eq $symb) {	eq $symb) {
$okay=1;	if (($ENV{'request.role.adv'}) \|\|
}	$bighash{'encrypted_'.$_} eq $ENV{'request.enc'}) {
	$okay=1;
	}
	}
}	}
}	}
untie(%bighash);	untie(%bighash);
Line 4266 sub symbverify {	Line 4738 sub symbverify {

sub symbclean {	sub symbclean {
my $symb=shift;	my $symb=shift;
	if ($symb=~m\|^/enc/\|) { $symb=&Apache::lonenc::unencrypted($symb); }
# remove version from map	# remove version from map
$symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/;	$symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/;

# remove version from URL	# remove version from URL
$symb=~s/\.(\d+)\.(\w+)$/\.$2/;	$symb=~s/\.(\d+)\.(\w+)$/\.$2/;

	# remove wrapper

	$symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\/(res\/)*/$1/;
return $symb;	return $symb;
}	}

Line 4284 sub encode_symb {	Line 4759 sub encode_symb {
}	}

sub decode_symb {	sub decode_symb {
my ($map,$resid,$url)=split(/\_\_\_/,shift);	my $symb=shift;
	if ($symb=~m\|^/enc/\|) { $symb=&Apache::lonenc::unencrypted($symb); }
	my ($map,$resid,$url)=split(/___/,$symb);
return (&fixversion($map),$resid,&fixversion($url));	return (&fixversion($map),$resid,&fixversion($url));
}	}

Line 4295 sub fixversion {	Line 4772 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 4310 sub fixversion {	Line 4786 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 4324 sub deversion {	Line 4799 sub deversion {

sub symbread {	sub symbread {
my ($thisfn,$donotrecurse)=@_;	my ($thisfn,$donotrecurse)=@_;
	my $cache_str='request.symbread.cached.'.$thisfn;
	if (defined($ENV{$cache_str})) { return $ENV{$cache_str}; }
# no filename provided? try from environment	# no filename provided? try from environment
unless ($thisfn) {	unless ($thisfn) {
if ($ENV{'request.symb'}) { return &symbclean($ENV{'request.symb'}); }	if ($ENV{'request.symb'}) {
	return $ENV{$cache_str}=&symbclean($ENV{'request.symb'});
	}
$thisfn=$ENV{'request.filename'};	$thisfn=$ENV{'request.filename'};
}	}
	if ($thisfn=~m\|^/enc/\|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
# is that filename actually a symb? Verify, clean, and return	# is that filename actually a symb? Verify, clean, and return
if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) {	if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) {
if (&symbverify($thisfn,$1)) { return &symbclean($thisfn); }	if (&symbverify($thisfn,$1)) {
	return $ENV{$cache_str}=&symbclean($thisfn);
	}
}	}
$thisfn=declutter($thisfn);	$thisfn=declutter($thisfn);
my %hash;	my %hash;
Line 4349 sub symbread {	Line 4831 sub symbread {
}	}
# ---------------------------------------------------------- There was an entry	# ---------------------------------------------------------- There was an entry
if ($syval) {	if ($syval) {
unless ($syval=~/\_\d+$/) {	#unless ($syval=~/\_\d+$/) {
unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) {	#unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) {
&appenv('request.ambiguous' => $thisfn);	#&appenv('request.ambiguous' => $thisfn);
return '';	#return $ENV{$cache_str}='';
}	#}
$syval.=$1;	#$syval.=$1;
}	#}
} else {	} else {
# ------------------------------------------------------- Was not in symb table	# ------------------------------------------------------- Was not in symb table
if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',	if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
Line 4399 sub symbread {	Line 4881 sub symbread {
}	}
}	}
if ($syval) {	if ($syval) {
return &symbclean($syval.'___'.$thisfn);	return $ENV{$cache_str}=$syval;
	#return $ENV{$cache_str}=&symbclean($syval.'___'.$thisfn);
}	}
}	}
&appenv('request.ambiguous' => $thisfn);	&appenv('request.ambiguous' => $thisfn);
return '';	return $ENV{$cache_str}='';
}	}

# ---------------------------------------------------------- Return random seed	# ---------------------------------------------------------- Return random seed
Line 4417 sub numval {	Line 4900 sub numval {
$txt=~tr/U-Z/0-5/;	$txt=~tr/U-Z/0-5/;
$txt=~tr/u-z/0-5/;	$txt=~tr/u-z/0-5/;
$txt=~s/\D//g;	$txt=~s/\D//g;
	if ($_64bit) { if ($txt > 2**32) { return -1; } }
return int($txt);	return int($txt);
}	}

Line 4432 sub numval2 {	Line 4916 sub numval2 {
my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt);	my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt);
my $total;	my $total;
foreach my $val (@txts) { $total+=$val; }	foreach my $val (@txts) { $total+=$val; }
	if ($_64bit) { if ($total > 2**32) { return -1; } }
return int($total);	return int($total);
}	}

	sub numval3 {
	use integer;
	my $txt=shift;
	$txt=~tr/A-J/0-9/;
	$txt=~tr/a-j/0-9/;
	$txt=~tr/K-T/0-9/;
	$txt=~tr/k-t/0-9/;
	$txt=~tr/U-Z/0-5/;
	$txt=~tr/u-z/0-5/;
	$txt=~s/\D//g;
	my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt);
	my $total;
	foreach my $val (@txts) { $total+=$val; }
	if ($_64bit) { $total=(($total<<32)>>32); }
	return $total;
	}

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

	sub get_rand_alg {
	my ($courseid)=@_;
	if (!$courseid) { $courseid=(&Apache::lonxml::whichuser())[1]; }
	if ($courseid) {
	return $ENV{"course.$courseid.rndseed"};
	}
	return &latest_rnd_algorithm_id();
	}

	sub validCODE {
	my ($CODE)=@_;
	if (defined($CODE) && $CODE ne '' && $CODE =~ /^\w+$/) { return 1; }
	return 0;
	}

	sub getCODE {
	if (&validCODE($ENV{'form.CODE'})) { return $ENV{'form.CODE'}; }
	if (defined($Apache::lonhomework::parsing_a_problem) &&
	&validCODE($Apache::lonhomework::history{'resource.CODE'})) {
	return $Apache::lonhomework::history{'resource.CODE'};
	}
	return undef;
}	}

sub rndseed {	sub rndseed {
Line 4449 sub rndseed {	Line 4975 sub rndseed {
if (!$courseid) { $courseid=$wcourseid; }	if (!$courseid) { $courseid=$wcourseid; }
if (!$domain) { $domain=$wdomain; }	if (!$domain) { $domain=$wdomain; }
if (!$username) { $username=$wusername }	if (!$username) { $username=$wusername }
my $which=$ENV{"course.$courseid.rndseed"};	my $which=&get_rand_alg();
my $CODE=$ENV{'form.CODE'};	if (defined(&getCODE())) {
if (defined($CODE)) {	if ($which eq '64bit4') {
return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);	return &rndseed_CODE_64bit4($symb,$courseid,$domain,$username);
	} else {
	return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);
	}
	} elsif ($which eq '64bit4') {
	return &rndseed_64bit4($symb,$courseid,$domain,$username);
	} elsif ($which eq '64bit3') {
	return &rndseed_64bit3($symb,$courseid,$domain,$username);
} elsif ($which eq '64bit2') {	} elsif ($which eq '64bit2') {
return &rndseed_64bit2($symb,$courseid,$domain,$username);	return &rndseed_64bit2($symb,$courseid,$domain,$username);
} elsif ($which eq '64bit') {	} elsif ($which eq '64bit') {
Line 4474 sub rndseed_32bit {	Line 5007 sub rndseed_32bit {
my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;	my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed\|$courseseed;$namechck:$symbchck");	#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed\|$courseseed;$namechck:$symbchck");
#&Apache::lonxml::debug("rndseed :$num:$symb");	#&Apache::lonxml::debug("rndseed :$num:$symb");
	if ($_64bit) { $num=(($num<<32)>>32); }
return $num;	return $num;
}	}
}	}
Line 4494 sub rndseed_64bit {	Line 5028 sub rndseed_64bit {
my $num2=$nameseed+$domainseed+$courseseed;	my $num2=$nameseed+$domainseed+$courseseed;
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed\|$courseseed;$namechck:$symbchck");	#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed\|$courseseed;$namechck:$symbchck");
#&Apache::lonxml::debug("rndseed :$num:$symb");	#&Apache::lonxml::debug("rndseed :$num:$symb");
	if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
	if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
return "$num1,$num2";	return "$num1,$num2";
}	}
}	}
Line 4520 sub rndseed_64bit2 {	Line 5056 sub rndseed_64bit2 {
}	}
}	}

	sub rndseed_64bit3 {
	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=numval2($symb) << 10;
	my $namechck=unpack("%32S*",$username.' ');

	my $nameseed=numval2($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 :$num1:$num2:$_64bit");
	if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }

	return "$num1:$num2";
	}
	}

	sub rndseed_64bit4 {
	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=numval3($symb) << 10;
	my $namechck=unpack("%32S*",$username.' ');

	my $nameseed=numval3($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 :$num1:$num2:$_64bit");
	if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }

	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=numval2($symb);	my $symbseed=numval2($symb);
my $CODEchck=unpack("%32S*",$ENV{'form.CODE'}.' ') << 16;	my $CODEchck=unpack("%32S*",&getCODE().' ') << 16;
my $CODEseed=numval($ENV{'form.CODE'});	my $CODEseed=numval(&getCODE());
my $courseseed=unpack("%32S*",$courseid.' ');	my $courseseed=unpack("%32S*",$courseid.' ');
my $num1=$symbseed+$CODEchck;	my $num1=$symbseed+$CODEchck;
my $num2=$CODEseed+$courseseed+$symbchck;	my $num2=$CODEseed+$courseseed+$symbchck;
#&Apache::lonxml::debug("$symbseed:$CODEchck\|$CODEseed:$courseseed:$symbchck");	#&Apache::lonxml::debug("$symbseed:$CODEchck\|$CODEseed:$courseseed:$symbchck");
#&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");	#&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");
return "$num1,$num2";	if ($_64bit) { $num1=(($num1<<32)>>32); }
	if ($_64bit) { $num2=(($num2<<32)>>32); }
	return "$num1:$num2";
	}
	}

	sub rndseed_CODE_64bit4 {
	my ($symb,$courseid,$domain,$username)=@_;
	{
	use integer;
	my $symbchck=unpack("%32S*",$symb.' ') << 16;
	my $symbseed=numval3($symb);
	my $CODEchck=unpack("%32S*",&getCODE().' ') << 16;
	my $CODEseed=numval3(&getCODE());
	my $courseseed=unpack("%32S*",$courseid.' ');
	my $num1=$symbseed+$CODEchck;
	my $num2=$CODEseed+$courseseed+$symbchck;
	#&Apache::lonxml::debug("$symbseed:$CODEchck\|$CODEseed:$courseseed:$symbchck");
	#&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");
	if ($_64bit) { $num1=(($num1<<32)>>32); }
	if ($_64bit) { $num2=(($num2<<32)>>32); }
	return "$num1:$num2";
}	}
}	}

sub setup_random_from_rndseed {	sub setup_random_from_rndseed {
my ($rndseed)=@_;	my ($rndseed)=@_;
if ($rndseed =~/,/) {	if ($rndseed =~/([,:])/) {
my ($num1,$num2)=split(/,/,$rndseed);	my ($num1,$num2)=split(/[,:]/,$rndseed);
&Math::Random::random_set_seed(abs($num1),abs($num2));	&Math::Random::random_set_seed(abs($num1),abs($num2));
} else {	} else {
&Math::Random::random_set_seed_from_phrase($rndseed);	&Math::Random::random_set_seed_from_phrase($rndseed);
Line 4623 sub receipt {	Line 5228 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 $request=new HTTP::Request('GET',&tokenwrapper($uri));
	#my $response=$ua->request($request);
	#if ($response->is_success()) {
	# return $response->content;
	# } else {
	# return -1;
	# }
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') {
return -1;	my $ua=new LWP::UserAgent;
	my $request=new HTTP::Request('GET',&tokenwrapper($uri));
	my $response=$ua->request($request);
	if ($response->is_success()) {
	$info=$response->content;
	} else {
	return -1;
	}
}	}
my @parts = ($cdom,$cnum);	my @parts = ($cdom,$cnum);
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 4671 sub getfile {	Line 5294 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';	}

	sub tokenwrapper {
	my $uri=shift;
	$uri=~s\|^http\://([^/]+)\|\|;
	$uri=~s\|^/\|\|;
	$ENV{'user.environment'}=~/\/([^\/]+)\.id/;
	my $token=$1;
	my (undef,$udom,$uname,$file)=split('/',$uri,4);
	if ($udom && $uname && $file) {
	$file=~s\|(\?\.)$\|\|;
	&appenv("userfile.$udom/$uname/$file" => $ENV{'request.course.id'});
	return 'http://'.$hostname{ &homeserver($uname,$udom)}.'/'.$uri.
	(($uri=~/\?/)?'&':'?').'token='.$token.
	'&tokenissued='.$perlvar{'lonHostID'};
	} else {
	return '/adm/notfound.html';
}	}
return $info;
}	}

sub getuploaded {	sub getuploaded {
Line 4710 sub readfile {	Line 5348 sub readfile {
}	}

sub filelocation {	sub filelocation {
my ($dir,$file) = @_;	my ($dir,$file) = @_;
my $location;	my $location;
$file=~ s/^\s(\S+)\s$/$1/; ## strip off leading and trailing spaces	$file=~ s/^\s(\S+)\s$/$1/; ## strip off leading and trailing spaces
if ($file=~m:^/~:) { # is a contruction space reference	if ($file=~m:^/~:) { # is a contruction space reference
$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)=
} else {	($file=~m\|^/+uploaded/+([^/]+)/+([^/]+)/+(.*)$\|);
$file=~s/^\Q$perlvar{'lonDocRoot'}\E//;	my $home=&homeserver($uname,$udom);
$file=~s:^/res/:/:;	my $is_me=0;
if ( !( $file =~ m:^/:) ) {	my @ids=&current_machine_ids();
$location = $dir. '/'.$file;	foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
} else {	if ($is_me) {
$location = '/home/httpd/html/res'.$file;	$location=&Apache::loncommon::propath($udom,$uname).
	'/userfiles/'.$filename;
	} else {
	$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
	$udom.'/'.$uname.'/'.$filename;
	}
	} elsif ($file =~ /^\/adm\/portfolio\//) {
	$file =~ s:^/adm/portfolio/::;
	$location = $location=&Apache::loncommon::propath($ENV{'user.domain'},$ENV{'user.name'}).'/userfiles/portfolio/'.$file;
	} else {
	$file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
	$file=~s:^/res/:/:;
	if ( !( $file =~ m:^/:) ) {
	$location = $dir. '/'.$file;
	} else {
	$location = '/home/httpd/html/res'.$file;
	}
}	}
}	$location=~s://+:/:g; # remove duplicate /
$location=~s://+:/:g; # remove duplicate /	while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..
while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..	while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./
while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./	return $location;
return $location;
}	}

sub hreflocation {	sub hreflocation {
Line 4776 sub current_machine_ids {	Line 5429 sub current_machine_ids {

sub declutter {	sub declutter {
my $thisfn=shift;	my $thisfn=shift;
	if ($thisfn=~m\|^/enc/\|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
$thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;	$thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;
$thisfn=~s/^\///;	$thisfn=~s/^\///;
$thisfn=~s/^res\///;	$thisfn=~s/^res\///;
Line 4787 sub declutter {	Line 5441 sub declutter {

sub clutter {	sub clutter {
my $thisfn='/'.&declutter(shift);	my $thisfn='/'.&declutter(shift);
unless ($thisfn=~/^\/(uploaded\|adm\|userfiles\|ext\|raw\|priv)\//) {	unless ($thisfn=~/^\/(uploaded\|adm\|userfiles\|ext\|raw\|priv\|public)\//) {
$thisfn='/res'.$thisfn;	$thisfn='/res'.$thisfn;
}	}
return $thisfn;	return $thisfn;
}	}

	sub freeze_escape {
	my ($value)=@_;
	if (ref($value)) {
	$value=&nfreeze($value);
	return '__FROZEN__'.&escape($value);
	}
	return &escape($value);
	}

# -------------------------------------------------------- Escape Special Chars	# -------------------------------------------------------- Escape Special Chars

sub escape {	sub escape {
Line 4809 sub unescape {	Line 5472 sub unescape {
return $str;	return $str;
}	}

	sub thaw_unescape {
	my ($value)=@_;
	if ($value =~ /^__FROZEN__/) {
	substr($value,0,10,undef);
	$value=&unescape($value);
	return &thaw($value);
	}
	return &unescape($value);
	}

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

sub correct_line_ends {	sub correct_line_ends {
Line 4826 sub correct_line_ends {	Line 5499 sub correct_line_ends {
sub goodbye {	sub goodbye {
&logthis("Starting Shut down");	&logthis("Starting Shut down");
#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',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',scalar(%homecache)));	&logthis(sprintf("%-20s is %s",'%homecache',length(&freeze(\%homecache))));
&logthis(sprintf("%-20s is %s",'%titlecache',scalar(%titlecache)));	# &logthis(sprintf("%-20s is %s",'%titlecache',length(&freeze(\%titlecache))));
&logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache)));	# &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&freeze(\%courseresdatacache))));
#1.1 only	#1.1 only
&logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache)));	# &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&freeze(\%userresdatacache))));
&logthis(sprintf("%-20s is %s",'%usectioncache',scalar(%usectioncache)));	# &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&freeze(\%getsectioncache))));
&logthis(sprintf("%-20s is %s",'%courseresversioncache',scalar(%courseresversioncache)));	# &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&freeze(\%courseresversioncache))));
&logthis(sprintf("%-20s is %s",'%resversioncache',scalar(%resversioncache)));	# &logthis(sprintf("%-20s is %s",'%resversioncache',length(&freeze(\%resversioncache))));
	&logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered))));
	&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 4846 BEGIN {	Line 5522 BEGIN {
# ----------------------------------- Read loncapa.conf and loncapa_apache.conf	# ----------------------------------- Read loncapa.conf and loncapa_apache.conf
unless ($readit) {	unless ($readit) {
{	{
	# FIXME: Use LONCAPA::Configuration::read_conf here and omit next block
open(my $config,"</etc/httpd/conf/loncapa.conf");	open(my $config,"</etc/httpd/conf/loncapa.conf");

while (my $configline=<$config>) {	while (my $configline=<$config>) {
Line 4906 BEGIN {	Line 5583 BEGIN {
while (my $configline=<$config>) {	while (my $configline=<$config>) {
next if ($configline =~ /^(\#\|\s*$)/);	next if ($configline =~ /^(\#\|\s*$)/);
chomp($configline);	chomp($configline);
my ($id,$domain,$role,$name,$ip,$domdescr)=split(/:/,$configline);	my ($id,$domain,$role,$name)=split(/:/,$configline);
if ($id && $domain && $role && $name && $ip) {	$name=~s/\s//g;
	if ($id && $domain && $role && $name) {
$hostname{$id}=$name;	$hostname{$id}=$name;
$hostdom{$id}=$domain;	$hostdom{$id}=$domain;
$hostip{$id}=$ip;
$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);
}	}

	sub get_iphost {
	if (%iphost) { return %iphost; }
	foreach my $id (keys(%hostname)) {
	my $name=$hostname{$id};
	my $ip = gethostbyname($name);
	if (!$ip \|\| length($ip) ne 4) {
	&logthis("Skipping host $id name $name no IP found\n");
	next;
	}
	$ip=inet_ntoa($ip);
	push(@{$iphost{$ip}},$id);
	}
	return %iphost;
	}

# ------------------------------------------------------ Read spare server file	# ------------------------------------------------------ Read spare server file
{	{
open(my $config,"<$perlvar{'lonTabDir'}/spare.tab");	open(my $config,"<$perlvar{'lonTabDir'}/spare.tab");
Line 4985 BEGIN {	Line 5672 BEGIN {

}	}

%metacache=();	$memcache=new Cache::Memcached({'servers'=>['127.0.0.1:11211']});

$processmarker='_'.time.'_'.$perlvar{'lonHostID'};	$processmarker='_'.time.'_'.$perlvar{'lonHostID'};
$dumpcount=0;	$dumpcount=0;
Line 4993 $dumpcount=0;	Line 5680 $dumpcount=0;
&logtouch();	&logtouch();
&logthis('<font color=yellow>INFO: Read configuration</font>');	&logthis('<font color=yellow>INFO: Read configuration</font>');
$readit=1;	$readit=1;
	{
	use integer;
	my $test=(2**32)+1;
	if ($test != 0) { $_64bit=1; } else { $_64bit=0; }
	&logthis(" Detected 64bit platform ($_64bit)");
	}
}	}
}	}

Line 5220 X<rolesinit()>	Line 5913 X<rolesinit()>
B<rolesinit($udom,$username,$authhost)>: get user privileges	B<rolesinit($udom,$username,$authhost)>: get user privileges

=item *	=item *
X<usection()>	X<getsection()>
B<usection($udom,$uname,$cname)>: finds the section of student in the	B<getsection($udom,$uname,$cname)>: finds the section of student in the
course $cname, return section name/number or '' for "not in course"	course $cname, return section name/number or '' for "not in course"
and '-1' for "no section"	and '-1' for "no section"

Line 5479 returns the data handle	Line 6172 returns the data handle
=item *	=item *

symbverify($symb,$thisfn) : verifies that $symb actually exists and is	symbverify($symb,$thisfn) : verifies that $symb actually exists and is
a possible symb for the URL in $thisfn, returns a 1 on success, 0 on	a possible symb for the URL in $thisfn, and if is an encryypted
failure, user must be in a course, as it assumes the existance of the	resource that the user accessed using /enc/ returns a 1 on success, 0
course initi hash, and uses $ENV('request.course.id'}	on failure, user must be in a course, as it assumes the existance of
	the course initial hash, and uses $ENV('request.course.id'}


=item *	=item *
Line 5608 put($namespace,$storehash,$udom,$uname)	Line 6302 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)

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

Removed from v.1.488
changed lines
	Added in v.1.601