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.515 and 1.562

version 1.515, 2004/06/29 04:30:00	version 1.562, 2004/11/06 01:11:38
Line 38 use vars	Line 38 use vars
qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom	qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom
%libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache	%libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache
%courselogs %accesshash %userrolehash $processmarker $dumpcount	%courselogs %accesshash %userrolehash $processmarker $dumpcount
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache	%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseresdatacache
%userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def	%userresdatacache %getsectioncache %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);

use IO::Socket;	use IO::Socket;
Line 47 use GDBM_File;	Line 47 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 );
my $readit;	my $readit;
	my $max_connection_retries = 10; # Or some such value.

=pod	=pod

Line 116 sub logperm {	Line 116 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 434 sub overloaderror {	Line 460 sub overloaderror {
if ($overload>0) {	if ($overload>0) {
$r->err_headers_out->{'Retry-After'}=$overload;	$r->err_headers_out->{'Retry-After'}=$overload;
$r->log_error('Overload of '.$overload.' on '.$checkserver);	$r->log_error('Overload of '.$overload.' on '.$checkserver);
return 409;	return 413;
}	}
return '';	return '';
}	}
Line 771 sub getsection {	Line 797 sub getsection {
my ($udom,$unam,$courseid)=@_;	my ($udom,$unam,$courseid)=@_;
$courseid=~s/\_/\//g;	$courseid=~s/\_/\//g;
$courseid=~s/^(\w)/\/$1/;	$courseid=~s/^(\w)/\/$1/;

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

my %Pending;	my %Pending;
my %Expired;	my %Expired;
#	#
Line 795 sub getsection {	Line 826 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(\%getsectioncache,$hashid,$section,'getsection');
}	}
#	#
# 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(\%getsectioncache,$hashid,$Pending{$time},'getsection');
}	}
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(\%getsectioncache,$hashid,$Expired{$time},'getsection');
}	}
return '-1';	return &do_cache(\%getsectioncache,$hashid,'-1','getsection');
}	}


Line 826 my $disk_caching_disabled=1;	Line 857 my $disk_caching_disabled=1;
sub devalidate_cache {	sub devalidate_cache {
my ($cache,$id,$name) = @_;	my ($cache,$id,$name) = @_;
delete $$cache{$id.'.time'};	delete $$cache{$id.'.time'};
	delete $$cache{$id.'.file'};
delete $$cache{$id};	delete $$cache{$id};
if ($disk_caching_disabled) { return; }	if (1 \|\| $disk_caching_disabled) { return; }
my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";	my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
open(DB,"$filename.lock");	if (!-e $filename) { return; }
	open(DB,">$filename.lock");
flock(DB,LOCK_EX);	flock(DB,LOCK_EX);
my %hash;	my %hash;
if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {	if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {
Line 856 sub is_cached {	Line 889 sub is_cached {
my ($cache,$id,$name,$time) = @_;	my ($cache,$id,$name,$time) = @_;
if (!$time) { $time=300; }	if (!$time) { $time=300; }
if (!exists($$cache{$id.'.time'})) {	if (!exists($$cache{$id.'.time'})) {
&load_cache_item($cache,$name,$id);	&load_cache_item($cache,$name,$id,$time);
}	}
if (!exists($$cache{$id.'.time'})) {	if (!exists($$cache{$id.'.time'})) {
# &logthis("Didn't find $id");	# &logthis("Didn't find $id");
return (undef,undef);	return (undef,undef);
} else {	} else {
if (time-($$cache{$id.'.time'})>$time) {	if (time-($$cache{$id.'.time'})>$time) {
# &logthis("Devalidating $id - ".time-($$cache{$id.'.time'}));	if (exists($$cache{$id.'.file'})) {
&devalidate_cache($cache,$id,$name);	foreach my $filename (@{ $$cache{$id.'.file'} }) {
return (undef,undef);	my $mtime=(stat($filename))[9];
	#+1 is to take care of edge effects
	if ($mtime && (($mtime+1) < ($$cache{$id.'.time'}))) {
	# &logthis("Upping $mtime - ".$$cache{$id.'.time'}.
	# "$id because of $filename");
	} else {
	&logthis("Devalidating $filename $id - ".(time-($$cache{$id.'.time'})));
	&devalidate_cache($cache,$id,$name);
	return (undef,undef);
	}
	}
	$$cache{$id.'.time'}=time;
	} else {
	# &logthis("Devalidating $id - ".time-($$cache{$id.'.time'}));
	&devalidate_cache($cache,$id,$name);
	return (undef,undef);
	}
}	}
}	}
return ($$cache{$id},1);	return ($$cache{$id},1);
Line 881 sub do_cache {	Line 930 sub do_cache {
$$cache{$id};	$$cache{$id};
}	}

	my %do_save_item;
	my %do_save;
sub save_cache_item {	sub save_cache_item {
my ($cache,$name,$id)=@_;	my ($cache,$name,$id)=@_;
if ($disk_caching_disabled) { return; }	if ($disk_caching_disabled) { return; }
my $starttime=&Time::HiRes::time();	$do_save{$name}=$cache;
# &logthis("Saving :$name:$id");	if (!exists($do_save_item{$name})) { $do_save_item{$name}={} }
my %hash;	$do_save_item{$name}->{$id}=1;
my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";	return;
open(DB,"$filename.lock");	}
flock(DB,LOCK_EX);
if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {	sub save_cache {
eval <<'EVALBLOCK';	if ($disk_caching_disabled) { return; }
$hash{$id.'.time'}=$$cache{$id.'.time'};	my ($cache,$name,$id);
$hash{$id}=freeze({'item'=>$$cache{$id}});	foreach $name (keys(%do_save)) {
	$cache=$do_save{$name};

	my $starttime=&Time::HiRes::time();
	&logthis("Saving :$name:");
	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)) {
	foreach $id (keys(%{ $do_save_item{$name} })) {
	eval <<'EVALBLOCK';
	$hash{$id.'.time'}=$$cache{$id.'.time'};
	$hash{$id}=freeze({'item'=>$$cache{$id}});
	if (exists($$cache{$id.'.file'})) {
	$hash{$id.'.file'}=freeze({'item'=>$$cache{$id.'.file'}});
	}
EVALBLOCK	EVALBLOCK
if ($@) {	if ($@) {
&logthis("<font color='red'>save_cache blew up :$@:$name</font>");	&logthis("<font color='red'>save_cache blew up :$@:$name</font>");
unlink($filename);	unlink($filename);
}	last;
} else {	}
if (-e $filename) {	}
&logthis("Unable to tie hash (save cache item): $name ($!)");	} else {
unlink($filename);	if (-e $filename) {
	&logthis("Unable to tie hash (save cache): $name ($!)");
	unlink($filename);
	}
}	}
	untie(%hash);
	flock(DB,LOCK_UN);
	close(DB);
	&logthis("save_cache $name took ".(&Time::HiRes::time()-$starttime));
}	}
untie(%hash);	undef(%do_save);
flock(DB,LOCK_UN);	undef(%do_save_item);
close(DB);
# &logthis("save_cache_item $name took ".(&Time::HiRes::time()-$starttime));
}	}

sub load_cache_item {	sub load_cache_item {
my ($cache,$name,$id)=@_;	my ($cache,$name,$id,$time)=@_;
if ($disk_caching_disabled) { return; }	if ($disk_caching_disabled) { return; }
my $starttime=&Time::HiRes::time();	my $starttime=&Time::HiRes::time();
# &logthis("Before Loading $name for $id size is ".scalar(%$cache));	# &logthis("Before Loading $name for $id size is ".scalar(%$cache));
my %hash;	my %hash;
my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";	my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
open(DB,"$filename.lock");	if (!-e $filename) { return; }
	open(DB,">$filename.lock");
flock(DB,LOCK_SH);	flock(DB,LOCK_SH);
if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) {	if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) {
eval <<'EVALBLOCK';	eval <<'EVALBLOCK';
Line 935 sub load_cache_item {	Line 1009 sub load_cache_item {
}	}
# &logthis("Initial load: $count");	# &logthis("Initial load: $count");
} else {	} else {
my $hashref=thaw($hash{$id});	if (($$cache{$id.'.time'}+$time) < time) {
$$cache{$id}=$hashref->{'item'};	$$cache{$id.'.time'}=$hash{$id.'.time'};
$$cache{$id.'.time'}=$hash{$id.'.time'};	{
	my $hashref=thaw($hash{$id});
	$$cache{$id}=$hashref->{'item'};
	}
	if (exists($hash{$id.'.file'})) {
	my $hashref=thaw($hash{$id.'.file'});
	$$cache{$id.'.file'}=$hashref->{'item'};
	}
	}
}	}
EVALBLOCK	EVALBLOCK
if ($@) {	if ($@) {
Line 957 EVALBLOCK	Line 1039 EVALBLOCK
# &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime));	# &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime));
}	}

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

my ($result,$cached)=&is_cached(\%usectioncache,$hashid,'usection');
if (defined($cached)) { return $result; }
$courseid=~s/\_/\//g;
$courseid=~s/^(\w)/\/$1/;
foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',
&homeserver($unam,$udom)))) {
my ($key,$value)=split(/\=/,$_);
$key=&unescape($key);
if ($key=~/^\Q$courseid\E(?:\/)(\w+)\_st$/) {
my $section=$1;
if ($key eq $courseid.'_st') { $section=''; }
my ($dummy,$end,$start)=split(/\_/,&unescape($value));
my $now=time;
my $notactive=0;
if ($start) {
if ($now<$start) { $notactive=1; }
}
if ($end) {
if ($now>$end) { $notactive=1; }
}
unless ($notactive) {
return &do_cache(\%usectioncache,$hashid,$section,'usection');
}
}
}
return &do_cache(\%usectioncache,$hashid,'-1','usection');
}

# ------------------------------------- Read an entry from a user's environment	# ------------------------------------- Read an entry from a user's environment

sub userenvironment {	sub userenvironment {
Line 1047 sub currentversion {	Line 1097 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 1066 sub subscribe {	Line 1117 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 1131 sub ssi_body {	Line 1188 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/^.?\<body[^\>]\>//si;
$output=~s/(.)\<\/body\s\>.*?$/$1/si;
$output=~	$output=~
s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs;	s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs;
	$output=~s/^.?\<body[^\>]\>//si;
	$output=~s/(.)\<\/body\s\>.*?$/$1/si;
return $output;	return $output;
}	}

Line 1267 sub process_coursefile {	Line 1324 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,$subdir)=@_;	my ($fname)=@_;
if (!defined($subdir)) { $subdir='unknown'; }
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 1279 sub userfileupload {	Line 1334 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='';
Line 1356 sub removeuserfile {	Line 1438 sub removeuserfile {
return &reply("removeuserfile:$docudom/$docuname/$fname",$home);	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 1395 sub flushcourselogs {	Line 1490 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});
} else {	} else {
$courseidbuffer{$coursehombuf{$crsid}}=	$courseidbuffer{$coursehombuf{$crsid}}=
&escape($crsid).'='.&escape($coursedescrbuf{$crsid});	&escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
	'='.&escape($courseinstcodebuf{$crsid});
}	}
}	}
#	#
Line 1472 sub courselog {	Line 1569 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'};
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 1596 sub getannounce {	Line 1695 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 1627 sub courseiddump {	Line 1726 sub courseiddump {
$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;
}	}
}	}
}	}
Line 1773 sub devalidate {	Line 1872 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 1787 sub devalidate {	Line 1887 sub devalidate {
$uname.' at '.$udom.' for '.	$uname.' at '.$udom.' for '.
$symb.': '.$status);	$symb.': '.$status);
}	}
	&delenv('user.state.'.$cid);
}	}
}	}

Line 2368 sub rolesinit {	Line 2469 sub rolesinit {
my $author=0;	my $author=0;
foreach (keys %allroles) {	foreach (keys %allroles) {
%thesepriv=();	%thesepriv=();
if (($_!~/^st/) && ($_!~/^ta/) && ($_!~/^cm/)) { $adv=1; }
if (($_=~/^au/) \|\| ($_=~/^ca/)) { $author=1; }	if (($_=~/^au/) \|\| ($_=~/^ca/)) { $author=1; }
foreach (split(/:/,$allroles{$_})) {	foreach (split(/:/,$allroles{$_})) {
if ($_ ne '') {	if ($_ ne '') {
Line 2380 sub rolesinit {	Line 2480 sub rolesinit {
$thesepriv{$privilege}.=$restrictions;	$thesepriv{$privilege}.=$restrictions;
}	}
}	}
	if ($thesepriv{'adv'} eq 'F') { $adv=1; }
}	}
}	}
$thesestr='';	$thesestr='';
Line 2414 sub get {	Line 2515 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 2453 sub dump {	Line 2554 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 2499 sub currentdump {	Line 2600 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 2565 sub put {	Line 2666 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.=$_.'='.&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 2580 sub cput {	Line 2705 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 2603 sub eget {	Line 2728 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 2650 sub allowed {	Line 2775 sub allowed {
$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 3059 sub log_query {	Line 3193 sub log_query {
sub fetch_enrollment_query {	sub fetch_enrollment_query {
my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_;	my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_;
my $homeserver;	my $homeserver;
	my $maxtries = 1;
if ($context eq 'automated') {	if ($context eq 'automated') {
$homeserver = $perlvar{'lonHostID'};	$homeserver = $perlvar{'lonHostID'};
	$maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout
} else {	} else {
$homeserver = &homeserver($cnum,$dom);	$homeserver = &homeserver($cnum,$dom);
}	}
Line 3073 sub fetch_enrollment_query {	Line 3209 sub fetch_enrollment_query {
$cmd = &escape($cmd);	$cmd = &escape($cmd);
my $query = 'fetchenrollment';	my $query = 'fetchenrollment';
my $queryid=&reply("querysend:".$query.':'.$dom.':'.$ENV{'user.name'}.':'.$cmd,$homeserver);	my $queryid=&reply("querysend:".$query.':'.$dom.':'.$ENV{'user.name'}.':'.$cmd,$homeserver);
unless ($queryid=~/^\Q$host\E\_/) { return 'error: '.$queryid; }	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 $reply = &get_query_reply($queryid);
unless ( ($reply =~/^timeout/) \|\| ($reply =~/^error/) ) {	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;	my @responses = split/:/,$reply;
if ($homeserver eq $perlvar{'lonHostID'}) {	if ($homeserver eq $perlvar{'lonHostID'}) {
foreach (@responses) {	foreach (@responses) {
Line 3092 sub fetch_enrollment_query {	Line 3238 sub fetch_enrollment_query {
my $filename = $dom.'_'.$key.'_'.$_.'_classlist.xml';	my $filename = $dom.'_'.$key.'_'.$_.'_classlist.xml';
my $destname = $pathname.'/'.$filename;	my $destname = $pathname.'/'.$filename;
my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver);	my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver);
unless ($xml_classlist =~ /^error/) {	if ($xml_classlist =~ /^error/) {
	&logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum);
	} else {
if ( open(FILE,">$destname") ) {	if ( open(FILE,">$destname") ) {
print FILE &unescape($xml_classlist);	print FILE &unescape($xml_classlist);
close(FILE);	close(FILE);
	} else {
	&logthis('fetch_enrollment_query - error opening classlist file '.$destname.' '.$context.' '.$cnum);
}	}
}	}
}	}
Line 3199 sub auto_create_password {	Line 3349 sub auto_create_password {
return ($authparam,$create_passwd,$authchk);	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') {
	$homeserver = $perlvar{'lonHostID'};
	} else {
	$homeserver = &homeserver($caller,$codedom);
	}
	my $host=$hostname{$homeserver};
	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 3451 sub modify_student_enrollment {	Line 3627 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,$locktype) },	join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) },
Line 3469 sub modify_student_enrollment {	Line 3644 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 3491 sub writecoursepref {	Line 3685 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)=@_;
$url=&declutter($url);	$url=&declutter($url);
my $cid='';	my $cid='';
unless (&allowed('ccc',$udom)) {	unless (&allowed('ccc',$udom)) {
Line 3524 sub createcourse {	Line 3718 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),$uhome);
&flushcourselogs();	&flushcourselogs();
# set toplevel url	# set toplevel url
my $topurl=$url;	my $topurl=$url;
Line 3579 sub revokecustomrole {	Line 3773 sub revokecustomrole {
$deleteflag);	$deleteflag);
}	}

	# ------------------------------------------------------------ Disk usage
# ------------------------------------------------------------ Portfolio Director Lister	sub diskusage {
sub portfoliolist {	my ($udom,$uname,$directoryRoot)=@_;
#FIXME us the ls: command instead please	$directoryRoot =~ s/\/$//;
#FIXME uhome should never be an argument to any lonnet functions	my $listing=&reply('du:'.$directoryRoot,homeserver($uname,$udom));
# returns listing of contents of user's /userfiles/portfolio/ directory
#
my ($udom,$uname,$uhome);
$uname=$ENV{'user.name'};
$udom=$ENV{'user.domain'};
$uhome=$ENV{'user.home'};
my $listing = &reply('portls:'.$uname.':'.$udom, $uhome);
return $listing;	return $listing;
}	}

sub portfoliomanage {	# ------------------------------------------------------------- Mark as Read Only

#FIXME please user the existing remove userfile function instead and	sub mark_as_readonly {
#add a userfilerename functions.	my ($domain,$user,$files,$what) = @_;
#FIXME uhome should never be an argument to any lonnet functions	my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user);
	foreach my $file (@{$files}) {
# handles deleting and renaming files in user's userfiles/portfolio/ directory	push(@{$current_permissions{$file}},$what);
#	}
my ($filename, $fileaction, $filenewname) = @_;	&Apache::lonnet::put('file_permissions',\%current_permissions,$domain,$user);
my ($udom, $uname, $uhome);	return;
$uname=$ENV{'user.name'};	}
$udom=$ENV{'user.domain'};
$uhome=$ENV{'user.home'};	#--------------------------------------------------------------Get Marked as Read Only
my $listing = reply('portfoliomanage:'.$uname.':'.$udom.':'.$filename.':'.$fileaction.':'.$filenewname, $uhome);
return $listing;	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, my $value) = each %current_permissions) {
	if (ref($value) eq "ARRAY"){
	foreach my $stored_what (@{$value}) {
	if ($stored_what eq $what) {
	push(@readonly_files, $file_name);
	}
	}
	}
	}
	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){

	}
	&Apache::lonnet::put('file_permissions',\%current_permissions,$domain,$user);
	return;
	}

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

Line 3720 sub GetFileTimestamp {	Line 3934 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 3945 sub EXT {	Line 4162 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(); }
	}
	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 3960 sub EXT {	Line 4180 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;
Line 4002 sub EXT {	Line 4222 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;
}	}
Line 4012 sub EXT {	Line 4232 sub EXT {
# -------------------------------------------------------- second, check course	# -------------------------------------------------------- second, check 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,$courselevelm,
$courselevel));	$courselevel));
if (defined($coursereply)) { return $coursereply; }	if (defined($coursereply)) { return $coursereply; }

# ------------------------------------------------------ third, check map parms	# ------------------------------------------------------ third, check map parms
Line 4115 sub metadata {	Line 4335 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\|home/[^/]+/public_html/\|)) {
return undef;	return undef;
Line 4148 sub metadata {	Line 4370 sub metadata {
unless ($filename=~/\.meta$/) { $filename.='.meta'; }	unless ($filename=~/\.meta$/) { $filename.='.meta'; }
my $metastring;	my $metastring;
if ($uri !~ m\|^uploaded/\|) {	if ($uri !~ m\|^uploaded/\|) {
$metastring=&getfile(&filelocation('',&clutter($filename)));	my $file=&filelocation('',&clutter($filename));
	push(@{$metacache{$uri.'.file'}},$file);
	$metastring=&getfile($file);
}	}
my $parser=HTML::LCParser->new(\$metastring);	my $parser=HTML::LCParser->new(\$metastring);
my $token;	my $token;
Line 4361 sub metadata_generate_part0 {	Line 4585 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 ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600);
return &metadata($urlsymb,'title');	if (defined($cached)) { return $result; }
}	my ($map,$resid,$url)=&decode_symb($symb);
my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600);	my $title='';
if (defined($cached)) { return $result; }	my %bighash;
my ($map,$resid,$url)=&decode_symb($symb);	if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
my $title='';	&GDBM_READER(),0640)) {
my %bighash;	my $mapid=$bighash{'map_pc_'.&clutter($map)};
if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',	$title=$bighash{'title_'.$mapid.'.'.$resid};
&GDBM_READER(),0640)) {	untie %bighash;
my $mapid=$bighash{'map_pc_'.&clutter($map)};	}
$title=$bighash{'title_'.$mapid.'.'.$resid};	$title=~s/\&colon\;/\:/gs;
untie %bighash;	if ($title) {
}	return &do_cache(\%titlecache,$symb,$title,'title');
$title=~s/\&colon\;/\:/gs;	}
if ($title) {	$urlsymb=$url;
return &do_cache(\%titlecache,$symb,$title,'title');	}
} else {	my $title=&metadata($urlsymb,'title');
return &metadata($urlsymb,'title');	if (!$title) { $title=(split('/',$urlsymb))[-1]; }
}	return $title;
}	}

# ------------------------------------------------- Update symbolic store links	# ------------------------------------------------- Update symbolic store links
Line 4513 sub deversion {	Line 4737 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'};
}	}
# 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 4541 sub symbread {	Line 4771 sub symbread {
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;
}	}
Line 4588 sub symbread {	Line 4818 sub symbread {
}	}
}	}
if ($syval) {	if ($syval) {
return &symbclean($syval.'___'.$thisfn);	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 4637 sub get_rand_alg {	Line 4867 sub get_rand_alg {
return &latest_rnd_algorithm_id();	return &latest_rnd_algorithm_id();
}	}

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

sub getCODE {	sub getCODE {
if (defined($ENV{'form.CODE'})) { return $ENV{'form.CODE'}; }	if (&validCODE($ENV{'form.CODE'})) { return $ENV{'form.CODE'}; }
if (defined($Apache::lonhomework::parsing_a_problem) &&	if (defined($Apache::lonhomework::parsing_a_problem) &&
defined($Apache::lonhomework::history{'resource.CODE'})) {	&validCODE($Apache::lonhomework::history{'resource.CODE'})) {
return $Apache::lonhomework::history{'resource.CODE'};	return $Apache::lonhomework::history{'resource.CODE'};
}	}
return undef;	return undef;
Line 4853 sub receipt {	Line 5089 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 4901 sub getfile {	Line 5155 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 4947 sub filelocation {	Line 5216 sub filelocation {
$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)=
	($file=~m\|^/+uploaded/+([^/]+)/+([^/]+)/+(.*)$\|);
	my $home=&homeserver($uname,$udom);
	my $is_me=0;
	my @ids=&current_machine_ids();
	foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
	if ($is_me) {
	$location=&Apache::loncommon::propath($udom,$uname).
	'/userfiles/'.$filename;
	} else {
	$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
	$udom.'/'.$uname.'/'.$filename;
	}
} else {	} else {
$file=~s/^\Q$perlvar{'lonDocRoot'}\E//;	$file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
$file=~s:^/res/:/:;	$file=~s:^/res/:/:;
Line 5023 sub clutter {	Line 5304 sub clutter {
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 5039 sub unescape {	Line 5329 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 {
if (defined($perlvar{'MODPERL2'})) {	if (defined($perlvar{'MODPERL2'})) {
return 2;	return 2;
Line 5064 sub goodbye {	Line 5364 sub goodbye {
&logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache)));	&logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache)));
#1.1 only	#1.1 only
&logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache)));	&logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache)));
&logthis(sprintf("%-20s is %s",'%usectioncache',scalar(%usectioncache)));	&logthis(sprintf("%-20s is %s",'%getsectioncache',scalar(%getsectioncache)));
&logthis(sprintf("%-20s is %s",'%courseresversioncache',scalar(%courseresversioncache)));	&logthis(sprintf("%-20s is %s",'%courseresversioncache',scalar(%courseresversioncache)));
&logthis(sprintf("%-20s is %s",'%resversioncache',scalar(%resversioncache)));	&logthis(sprintf("%-20s is %s",'%resversioncache',scalar(%resversioncache)));
&flushcourselogs();	&flushcourselogs();
Line 5143 BEGIN {	Line 5443 BEGIN {
$hostip{$id}=$ip;	$hostip{$id}=$ip;
$iphost{$ip}=$id;	$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);
Line 5450 X<rolesinit()>	Line 5746 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 5838 put($namespace,$storehash,$udom,$uname)	Line 6134 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.515
changed lines
	Added in v.1.562