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.651.2.5 and 1.808

version 1.651.2.5, 2005/09/26 22:16:58	version 1.808, 2006/11/27 20:35:10
Line 37 use HTTP::Date;	Line 37 use HTTP::Date;
use vars	use vars
qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom	qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom
%libserv %pr %prp $memcache %packagetab	%libserv %pr %prp $memcache %packagetab
%courselogs %accesshash %userrolehash $processmarker $dumpcount	%courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf	%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf
%domaindescription %domain_auth_def %domain_auth_arg_def	%domaindescription %domain_auth_def %domain_auth_arg_def
%domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit	%domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary
%env);	$tmpdir $_64bit %env);

use IO::Socket;	use IO::Socket;
use GDBM_File;	use GDBM_File;
use Apache::Constants qw(:common :http);
use HTML::LCParser;	use HTML::LCParser;
use HTML::Parser;	use HTML::Parser;
use Fcntl qw(:flock);	use Fcntl qw(:flock);
use Apache::lonlocal;
use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze);	use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze);
use Time::HiRes qw( gettimeofday tv_interval );	use Time::HiRes qw( gettimeofday tv_interval );
use Cache::Memcached;	use Cache::Memcached;
	use Digest::MD5;
	use Math::Random;
	use lib '/home/httpd/lib/perl';
	use LONCAPA qw(:DEFAULT :match);
	use LONCAPA::Configuration;

my $readit;	my $readit;
my $max_connection_retries = 10; # Or some such value.	my $max_connection_retries = 10; # Or some such value.

Line 85 delayed.	Line 89 delayed.


# --------------------------------------------------------------------- Logging	# --------------------------------------------------------------------- Logging
	{
	my $logid;
	sub instructor_log {
	my ($hash_name,$storehash,$delflag,$uname,$udom)=@_;
	$logid++;
	my $id=time().'00000'.$$.'00000'.$logid;
	return &Apache::lonnet::put('nohist_'.$hash_name,
	{ $id => {
	'exe_uname' => $env{'user.name'},
	'exe_udom' => $env{'user.domain'},
	'exe_time' => time(),
	'exe_ip' => $ENV{'REMOTE_ADDR'},
	'delflag' => $delflag,
	'logentry' => $storehash,
	'uname' => $uname,
	'udom' => $udom,
	}
	},
	$env{'course.'.$env{'request.course.id'}.'.domain'},
	$env{'course.'.$env{'request.course.id'}.'.num'}
	);
	}
	}

sub logtouch {	sub logtouch {
my $execdir=$perlvar{'lonDaemons'};	my $execdir=$perlvar{'lonDaemons'};
Line 123 sub logperm {	Line 150 sub logperm {
# -------------------------------------------------- Non-critical communication	# -------------------------------------------------- Non-critical communication
sub subreply {	sub subreply {
my ($cmd,$server)=@_;	my ($cmd,$server)=@_;
my $peerfile="$perlvar{'lonSockDir'}/$server";	my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server};
#	#
# With loncnew process trimming, there's a timing hole between lonc server	# With loncnew process trimming, there's a timing hole between lonc server
# process exit and the master server picking up the listen on the AF_UNIX	# process exit and the master server picking up the listen on the AF_UNIX
Line 151 sub subreply {	Line 178 sub subreply {
}	}
my $answer;	my $answer;
if ($client) {	if ($client) {
print $client "$cmd\n";	print $client "sethost:$server:$cmd\n";
$answer=<$client>;	$answer=<$client>;
if (!$answer) { $answer="con_lost"; }	if (!$answer) { $answer="con_lost"; }
chomp($answer);	chomp($answer);
Line 166 sub reply {	Line 193 sub reply {
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=~/^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>");
}	}
return $answer;	return $answer;
Line 190 sub reconlonc {	Line 217 sub reconlonc {
sleep 5;	sleep 5;
if (-e "$peerfile") { return; }	if (-e "$peerfile") { return; }
&logthis(	&logthis(
"<font color=blue>WARNING: $peerfile still not there, giving up</font>");	"<font color=\"blue\">WARNING: $peerfile still not there, giving up</font>");
} else {	} else {
&logthis(	&logthis(
"<font color=blue>WARNING:".	"<font color=\"blue\">WARNING:".
" lonc at pid $loncpid not responding, giving up</font>");	" lonc at pid $loncpid not responding, giving up</font>");
}	}
} else {	} else {
&logthis('<font color=blue>WARNING: lonc not running, giving up</font>');	&logthis('<font color="blue">WARNING: lonc not running, giving up</font>');
}	}
}	}

Line 206 sub reconlonc {	Line 233 sub reconlonc {
sub critical {	sub critical {
my ($cmd,$server)=@_;	my ($cmd,$server)=@_;
unless ($hostname{$server}) {	unless ($hostname{$server}) {
&logthis("<font color=blue>WARNING:".	&logthis("<font color=\"blue\">WARNING:".
" Critical message to unknown server ($server)</font>");	" Critical message to unknown server ($server)</font>");
return 'no_such_host';	return 'no_such_host';
}	}
Line 240 sub critical {	Line 267 sub critical {
}	}
chomp($wcmd);	chomp($wcmd);
if ($wcmd eq $cmd) {	if ($wcmd eq $cmd) {
&logthis("<font color=blue>WARNING: ".	&logthis("<font color=\"blue\">WARNING: ".
"Connection buffer $dfilename: $cmd</font>");	"Connection buffer $dfilename: $cmd</font>");
&logperm("D:$server:$cmd");	&logperm("D:$server:$cmd");
return 'con_delayed';	return 'con_delayed';
} else {	} else {
&logthis("<font color=red>CRITICAL:"	&logthis("<font color=\"red\">CRITICAL:"
." Critical connection failed: $server $cmd</font>");	." Critical connection failed: $server $cmd</font>");
&logperm("F:$server:$cmd");	&logperm("F:$server:$cmd");
return 'con_failed';	return 'con_failed';
Line 255 sub critical {	Line 282 sub critical {
return $answer;	return $answer;
}	}

# ------------------------------------------- Transfer profile into environment	# ------------------------------------------- check if return value is an error

sub transfer_profile_to_env {	sub error {
	my ($result) = @_;
	if ($result =~ /^(con_lost\|no_such_host\|error: (\d+) (.*))/) {
	if ($2 == 2) { return undef; }
	return $1;
	}
	return undef;
	}

	sub convert_and_load_session_env {
my ($lonidsdir,$handle)=@_;	my ($lonidsdir,$handle)=@_;
my @profile;	my @profile;
{	{
Line 266 sub transfer_profile_to_env {	Line 302 sub transfer_profile_to_env {
@profile=<$idf>;	@profile=<$idf>;
close($idf);	close($idf);
}	}
my $envi;	my %temp_env;
my %Remove;	foreach my $line (@profile) {
for ($envi=0;$envi<=$#profile;$envi++) {	if ($line !~ m/=/) {
chomp($profile[$envi]);	return 0;
my ($envname,$envvalue)=split(/=/,$profile[$envi]);	}
$env{$envname} = $envvalue;	chomp($line);
	my ($envname,$envvalue)=split(/=/,$line,2);
	$temp_env{&unescape($envname)} = &unescape($envvalue);
	}
	unlink("$lonidsdir/$handle.id");
	if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_WRCREAT(),
	0640)) {
	%disk_env = %temp_env;
	@env{keys(%temp_env)} = @disk_env{keys(%temp_env)};
	untie(%disk_env);
	}
	return 1;
	}

	# ------------------------------------------- Transfer profile into environment
	my $env_loaded;
	sub transfer_profile_to_env {
	my ($lonidsdir,$handle,$force_transfer) = @_;
	if (!$force_transfer && $env_loaded) { return; }

	if (!defined($lonidsdir)) {
	$lonidsdir = $perlvar{'lonIDsDir'};
	}
	if (!defined($handle)) {
	($handle) = ($env{'user.environment'} =~m\|/([^/]+)\.id$\| );
	}

	my $convert;
	{
	open(my $idf,"$lonidsdir/$handle.id");
	flock($idf,LOCK_SH);
	if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",
	&GDBM_READER(),0640)) {
	@env{keys(%disk_env)} = @disk_env{keys(%disk_env)};
	untie(%disk_env);
	} else {
	$convert = 1;
	}
	}
	if ($convert) {
	if (!&convert_and_load_session_env($lonidsdir,$handle)) {
	&logthis("Failed to load session, or convert session.");
	}
	}

	my %remove;
	while ( my $envname = each(%env) ) {
if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {	if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
if ($time < time-300) {	if ($time < time-300) {
$Remove{$key}++;	$remove{$key}++;
}	}
}	}
}	}

$env{'user.environment'} = "$lonidsdir/$handle.id";	$env{'user.environment'} = "$lonidsdir/$handle.id";
foreach my $expired_key (keys(%Remove)) {	$env_loaded=1;
	foreach my $expired_key (keys(%remove)) {
&delenv($expired_key);	&delenv($expired_key);
}	}
}	}
Line 288 sub transfer_profile_to_env {	Line 372 sub transfer_profile_to_env {

sub appenv {	sub appenv {
my %newenv=@_;	my %newenv=@_;
foreach (keys %newenv) {	foreach my $key (keys(%newenv)) {
if (($newenv{$_}=~/^user\.role/) \|\| ($newenv{$_}=~/^user\.priv/)) {	if (($newenv{$key}=~/^user\.role/) \|\| ($newenv{$key}=~/^user\.priv/)) {
&logthis("<font color=blue>WARNING: ".	&logthis("<font color=\"blue\">WARNING: ".
"Attempt to modify environment ".$_." to ".$newenv{$_}	"Attempt to modify environment ".$key." to ".$newenv{$key}
.'</font>');	.'</font>');
delete($newenv{$_});	delete($newenv{$key});
} else {	} else {
$env{$_}=$newenv{$_};	$env{$key}=$newenv{$key};
}	}
}	}
	if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(),
my $lockfh;	0640)) {
unless (open($lockfh,"$env{'user.environment'}")) {	while (my ($key,$value) = each(%newenv)) {
return 'error: '.$!;	$disk_env{$key} = $value;
}
unless (flock($lockfh,LOCK_EX)) {
&logthis("<font color=blue>WARNING: ".
'Could not obtain exclusive lock in appenv: '.$!);
close($lockfh);
return 'error: '.$!;
}

my @oldenv;
{
my $fh;
unless (open($fh,"$env{'user.environment'}")) {
return 'error: '.$!;
}
@oldenv=<$fh>;
close($fh);
}
for (my $i=0; $i<=$#oldenv; $i++) {
chomp($oldenv[$i]);
if ($oldenv[$i] ne '') {
my ($name,$value)=split(/=/,$oldenv[$i]);
unless (defined($newenv{$name})) {
$newenv{$name}=$value;
}
}
}
{
my $fh;
unless (open($fh,">$env{'user.environment'}")) {
return 'error';
}
my $newname;
foreach $newname (keys %newenv) {
print $fh "$newname=$newenv{$newname}\n";
}	}
close($fh);	untie(%disk_env);
}	}

close($lockfh);
return 'ok';	return 'ok';
}	}
# ----------------------------------------------------- Delete from Environment	# ----------------------------------------------------- Delete from Environment

sub delenv {	sub delenv {
my $delthis=shift;	my $delthis=shift;
my %newenv=();
if (($delthis=~/user\.role/) \|\| ($delthis=~/user\.priv/)) {	if (($delthis=~/user\.role/) \|\| ($delthis=~/user\.priv/)) {
&logthis("<font color=blue>WARNING: ".	&logthis("<font color=\"blue\">WARNING: ".
"Attempt to delete from environment ".$delthis);	"Attempt to delete from environment ".$delthis);
return 'error';	return 'error';
}	}
my @oldenv;	if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(),
{	0640)) {
my $fh;	foreach my $key (keys(%disk_env)) {
unless (open($fh,"$env{'user.environment'}")) {	if ($key=~/^$delthis/) {
return 'error';
}
unless (flock($fh,LOCK_SH)) {
&logthis("<font color=blue>WARNING: ".
'Could not obtain shared lock in delenv: '.$!);
close($fh);
return 'error: '.$!;
}
@oldenv=<$fh>;
close($fh);
}
{
my $fh;
unless (open($fh,">$env{'user.environment'}")) {
return 'error';
}
unless (flock($fh,LOCK_EX)) {
&logthis("<font color=blue>WARNING: ".
'Could not obtain exclusive lock in delenv: '.$!);
close($fh);
return 'error: '.$!;
}
foreach (@oldenv) {
if ($_=~/^$delthis/) {
my ($key,undef) = split('=',$_);
delete($env{$key});	delete($env{$key});
} else {	delete($disk_env{$key});
print $fh $_;
}	}
}	}
close($fh);	untie(%disk_env);
}	}
return 'ok';	return 'ok';
}	}

	sub get_env_multiple {
	my ($name) = @_;
	my @values;
	if (defined($env{$name})) {
	# exists is it an array
	if (ref($env{$name})) {
	@values=@{ $env{$name} };
	} else {
	$values[0]=$env{$name};
	}
	}
	return(@values);
	}

# ------------------------------------------ Find out current server userload	# ------------------------------------------ Find out current server userload
# there is a copy in lond	# there is a copy in lond
sub userload {	sub userload {
Line 443 sub overloaderror {	Line 478 sub overloaderror {
# ------------------------------ Find server with least workload from spare.tab	# ------------------------------ Find server with least workload from spare.tab

sub spareserver {	sub spareserver {
my ($loadpercent,$userloadpercent) = @_;	my ($loadpercent,$userloadpercent,$want_server_name) = @_;
my $tryserver;	my $spare_server;
my $spareserver='';
if ($userloadpercent !~ /\d/) { $userloadpercent=0; }	if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
my $lowestserver=$loadpercent > $userloadpercent?	my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent
$loadpercent : $userloadpercent;	: $userloadpercent;
foreach $tryserver (keys %spareid) {
my $loadans=reply('load',$tryserver);	foreach my $try_server (@{ $spareid{'primary'} }) {
my $userloadans=reply('userload',$tryserver);	($spare_server, $lowest_load) =
if ($loadans !~ /\d/ && $userloadans !~ /\d/) {	&compare_server_load($try_server, $spare_server, $lowest_load);
next; #didn't get a number from the server	}
}
my $answer;	my $found_server = ($spare_server ne '' && $lowest_load < 100);
if ($loadans =~ /\d/) {
if ($userloadans =~ /\d/) {	if (!$found_server) {
#both are numbers, pick the bigger one	foreach my $try_server (@{ $spareid{'default'} }) {
$answer=$loadans > $userloadans?	($spare_server, $lowest_load) =
$loadans : $userloadans;	&compare_server_load($try_server, $spare_server, $lowest_load);
} else {
$answer = $loadans;
}
} else {
$answer = $userloadans;
}
if (($answer =~ /\d/) && ($answer<$lowestserver)) {
$spareserver="http://$hostname{$tryserver}";
$lowestserver=$answer;
}	}
}	}
return $spareserver;
	if (!$want_server_name) {
	$spare_server="http://$hostname{$spare_server}";
	}
	return $spare_server;
}	}

	sub compare_server_load {
	my ($try_server, $spare_server, $lowest_load) = @_;

	my $loadans = &reply('load', $try_server);
	my $userloadans = &reply('userload',$try_server);

	if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
	next; #didn't get a number from the server
	}

	my $load;
	if ($loadans =~ /\d/) {
	if ($userloadans =~ /\d/) {
	#both are numbers, pick the bigger one
	$load = ($loadans > $userloadans) ? $loadans
	: $userloadans;
	} else {
	$load = $loadans;
	}
	} else {
	$load = $userloadans;
	}

	if (($load =~ /\d/) && ($load < $lowest_load)) {
	$spare_server = $try_server;
	$lowest_load = $load;
	}
	return ($spare_server,$lowest_load);
	}
# --------------------------------------------- Try to change a user's password	# --------------------------------------------- Try to change a user's password

sub changepass {	sub changepass {
my ($uname,$udom,$currentpass,$newpass,$server)=@_;	my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_;
$currentpass = &escape($currentpass);	$currentpass = &escape($currentpass);
$newpass = &escape($newpass);	$newpass = &escape($newpass);
my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass",	my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context",
$server);	$server);
if (! $answer) {	if (! $answer) {
&logthis("No reply on password change request to $server ".	&logthis("No reply on password change request to $server ".
Line 530 sub queryauthenticate {	Line 588 sub queryauthenticate {

sub authenticate {	sub authenticate {
my ($uname,$upass,$udom)=@_;	my ($uname,$upass,$udom)=@_;
$upass=escape($upass);	$upass=&escape($upass);
$uname=~s/\W//g;	$uname= &LONCAPA::clean_username($uname);
my $uhome=&homeserver($uname,$udom);	my $uhome=&homeserver($uname,$udom);
if (!$uhome) {	if (!$uhome) {
&logthis("User $uname at $udom is unknown in authenticate");	&logthis("User $uname at $udom is unknown in authenticate");
Line 606 sub idget {	Line 664 sub idget {
sub idrget {	sub idrget {
my ($udom,@unames)=@_;	my ($udom,@unames)=@_;
my %returnhash=();	my %returnhash=();
foreach (@unames) {	foreach my $uname (@unames) {
$returnhash{$_}=(&userenvironment($udom,$_,'id'))[1];	$returnhash{$uname}=(&userenvironment($udom,$uname,'id'))[1];
}	}
return %returnhash;	return %returnhash;
}	}
Line 617 sub idrget {	Line 675 sub idrget {
sub idput {	sub idput {
my ($udom,%ids)=@_;	my ($udom,%ids)=@_;
my %servers=();	my %servers=();
foreach (keys %ids) {	foreach my $uname (keys(%ids)) {
&cput('environment',{'id'=>$ids{$_}},$udom,$_);	&cput('environment',{'id'=>$ids{$uname}},$udom,$uname);
my $uhom=&homeserver($_,$udom);	my $uhom=&homeserver($uname,$udom);
if ($uhom ne 'no_host') {	if ($uhom ne 'no_host') {
my $id=&escape($ids{$_});	my $id=&escape($ids{$uname});
$id=~tr/A-Z/a-z/;	$id=~tr/A-Z/a-z/;
my $unam=&escape($_);	my $esc_unam=&escape($uname);
if ($servers{$uhom}) {	if ($servers{$uhom}) {
$servers{$uhom}.='&'.$id.'='.$unam;	$servers{$uhom}.='&'.$id.'='.$esc_unam;
} else {	} else {
$servers{$uhom}=$id.'='.$unam;	$servers{$uhom}=$id.'='.$esc_unam;
}	}
}	}
}	}
foreach (keys %servers) {	foreach my $server (keys(%servers)) {
&critical('idput:'.$udom.':'.$servers{$_},$_);	&critical('idput:'.$udom.':'.$servers{$server},$server);
	}
	}

	# ------------------------------------------- get items from domain db files

	sub get_dom {
	my ($namespace,$storearr,$udom)=@_;
	my $items='';
	foreach my $item (@$storearr) {
	$items.=&escape($item).'&';
	}
	$items=~s/\&$//;
	if (!$udom) { $udom=$env{'user.domain'}; }
	if (exists($domain_primary{$udom})) {
	my $uhome=$domain_primary{$udom};
	my $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
	my @pairs=split(/\&/,$rep);
	if ( $#pairs==0 && $pairs[0] =~ /^(con_lost\|error\|no_such_host)/i) {
	return @pairs;
	}
	my %returnhash=();
	my $i=0;
	foreach my $item (@$storearr) {
	$returnhash{$item}=&thaw_unescape($pairs[$i]);
	$i++;
	}
	return %returnhash;
	} else {
	&logthis("get_dom failed - no primary domain server for $udom");
	}
	}

	# -------------------------------------------- put items in domain db files

	sub put_dom {
	my ($namespace,$storehash,$udom)=@_;
	if (!$udom) { $udom=$env{'user.domain'}; }
	if (exists($domain_primary{$udom})) {
	my $uhome=$domain_primary{$udom};
	my $items='';
	foreach my $item (keys(%$storehash)) {
	$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
	}
	$items=~s/\&$//;
	return &reply("putdom:$udom:$namespace:$items",$uhome);
	} else {
	&logthis("put_dom failed - no primary domain server for $udom");
}	}
}	}

Line 767 sub validate_access_key {	Line 872 sub validate_access_key {
}	}

# ------------------------------------- Find the section of student in a course	# ------------------------------------- Find the section of student in a course
	sub devalidate_getsection_cache {
	my ($udom,$unam,$courseid)=@_;
	my $hashid="$udom:$unam:$courseid";
	&devalidate_cache_new('getsection',$hashid);
	}

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

my $hashid="$udom:$unam:$courseid";	my $hashid="$udom:$unam:$courseid";
my ($result,$cached)=&is_cached_new('getsection',$hashid);	my ($result,$cached)=&is_cached_new('getsection',$hashid);
Line 793 sub getsection {	Line 901 sub getsection {
# If there is more than one expired role, choose the one which ended last.	# If there is more than one expired role, choose the one which ended last.
# If there is a role which has expired, return it.	# If there is a role which has expired, return it.
#	#
foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',	foreach my $line (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',
&homeserver($unam,$udom)))) {	&homeserver($unam,$udom)))) {
my ($key,$value)=split(/\=/,$_);	my ($key,$value)=split(/\=/,$line,2);
$key=&unescape($key);	$key=&unescape($key);
next if ($key !~/^\Q$courseid\E(?:\/)(\w+)\_st$/);	next if ($key !~/^\Q$courseid\E(?:\/)(\w+)\_st$/);
my $section=$1;	my $section=$1;
Line 828 sub getsection {	Line 936 sub getsection {
}	}

sub save_cache {	sub save_cache {
my ($r)=@_;
if (! $r->is_initial_req()) { return DECLINED; }
&purge_remembered();	&purge_remembered();
	#&Apache::loncommon::validate_page();
undef(%env);	undef(%env);
return OK;	undef($env_loaded);
}	}

my $to_remember=-1;	my $to_remember=-1;
Line 935 sub userenvironment {	Line 1042 sub userenvironment {
sub studentphoto {	sub studentphoto {
my ($udom,$unam,$ext) = @_;	my ($udom,$unam,$ext) = @_;
my $home=&Apache::lonnet::homeserver($unam,$udom);	my $home=&Apache::lonnet::homeserver($unam,$udom);
my $ret=&Apache::lonnet::reply("studentphoto:$udom:$unam:$ext",$home);	if (defined($env{'request.course.id'})) {
my $url="/uploaded/$udom/$unam/internal/studentphoto.".$ext;	if ($env{'course.'.$env{'request.course.id'}.'.internal.showphoto'}) {
if ($ret ne 'ok') {	if ($udom eq $env{'course.'.$env{'request.course.id'}.'.domain'}) {
return '/adm/lonKaputt/lonlogo_broken.gif';	return(&retrievestudentphoto($udom,$unam,$ext));
	} else {
	my ($result,$perm_reqd)=
	&Apache::lonnet::auto_photo_permission($unam,$udom);
	if ($result eq 'ok') {
	if (!($perm_reqd eq 'yes')) {
	return(&retrievestudentphoto($udom,$unam,$ext));
	}
	}
	}
	}
	} else {
	my ($result,$perm_reqd) =
	&Apache::lonnet::auto_photo_permission($unam,$udom);
	if ($result eq 'ok') {
	if (!($perm_reqd eq 'yes')) {
	return(&retrievestudentphoto($udom,$unam,$ext));
	}
	}
	}
	return '/adm/lonKaputt/lonlogo_broken.gif';
	}

	sub retrievestudentphoto {
	my ($udom,$unam,$ext,$type) = @_;
	my $home=&Apache::lonnet::homeserver($unam,$udom);
	my $ret=&Apache::lonnet::reply("studentphoto:$udom:$unam:$ext:$type",$home);
	if ($ret eq 'ok') {
	my $url="/uploaded/$udom/$unam/internal/studentphoto.$ext";
	if ($type eq 'thumbnail') {
	$url="/uploaded/$udom/$unam/internal/studentphoto_tn.$ext";
	}
	my $tokenurl=&Apache::lonnet::tokenwrapper($url);
	return $tokenurl;
	} else {
	if ($type eq 'thumbnail') {
	return '/adm/lonKaputt/genericstudent_tn.gif';
	} else {
	return '/adm/lonKaputt/lonlogo_broken.gif';
	}
}	}
my $tokenurl=&Apache::lonnet::tokenwrapper($url);
return $tokenurl;
}	}

# -------------------------------------------------------------------- New chat	# -------------------------------------------------------------------- New chat

sub chatsend {	sub chatsend {
my ($newentry,$anon)=@_;	my ($newentry,$anon,$group)=@_;
my $cnum=$env{'course.'.$env{'request.course.id'}.'.num'};	my $cnum=$env{'course.'.$env{'request.course.id'}.'.num'};
my $cdom=$env{'course.'.$env{'request.course.id'}.'.domain'};	my $cdom=$env{'course.'.$env{'request.course.id'}.'.domain'};
my $chome=$env{'course.'.$env{'request.course.id'}.'.home'};	my $chome=$env{'course.'.$env{'request.course.id'}.'.home'};
&reply('chatsend:'.$cdom.':'.$cnum.':'.	&reply('chatsend:'.$cdom.':'.$cnum.':'.
&escape($env{'user.domain'}.':'.$env{'user.name'}.':'.$anon.':'.	&escape($env{'user.domain'}.':'.$env{'user.name'}.':'.$anon.':'.
&escape($newentry)),$chome);	&escape($newentry)).':'.$group,$chome);
}	}

# ------------------------------------------ Find current version of a resource	# ------------------------------------------ Find current version of a resource
Line 1053 sub repcopy {	Line 1197 sub repcopy {
if ($response->is_error()) {	if ($response->is_error()) {
unlink($transname);	unlink($transname);
my $message=$response->status_line;	my $message=$response->status_line;
&logthis("<font color=blue>WARNING:"	&logthis("<font color=\"blue\">WARNING:"
." LWP get: $message: $filename</font>");	." LWP get: $message: $filename</font>");
return 'unavailable';	return 'unavailable';
} else {	} else {
Line 1063 sub repcopy {	Line 1207 sub repcopy {
if ($mresponse->is_error()) {	if ($mresponse->is_error()) {
unlink($filename.'.meta');	unlink($filename.'.meta');
&logthis(	&logthis(
"<font color=yellow>INFO: No metadata: $filename</font>");	"<font color=\"yellow\">INFO: No metadata: $filename</font>");
}	}
}	}
rename($transname,$filename);	rename($transname,$filename);
Line 1081 sub ssi_body {	Line 1225 sub ssi_body {
}	}
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\|//(\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;
return $output;	return $output;
Line 1089 sub ssi_body {	Line 1233 sub ssi_body {

# --------------------------------------------------------- Server Side Include	# --------------------------------------------------------- Server Side Include

	sub absolute_url {
	my ($host_name) = @_;
	my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://');
	if ($host_name eq '') {
	$host_name = $ENV{'SERVER_NAME'};
	}
	return $protocol.$host_name;
	}

sub ssi {	sub ssi {

my ($fn,%form)=@_;	my ($fn,%form)=@_;
Line 1096 sub ssi {	Line 1249 sub ssi {
my $ua=new LWP::UserAgent;	my $ua=new LWP::UserAgent;

my $request;	my $request;

	$form{'no_update_last_known'}=1;

if (%form) {	if (%form) {
$request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn);	$request=new HTTP::Request('POST',&absolute_url().$fn);
$request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));	$request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));
} else {	} else {
$request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn);	$request=new HTTP::Request('GET',&absolute_url().$fn);
}	}

$request->header(Cookie => $ENV{'HTTP_COOKIE'});	$request->header(Cookie => $ENV{'HTTP_COOKIE'});
Line 1169 sub process_coursefile {	Line 1324 sub process_coursefile {
$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,	$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
$home);	$home);
} else {	} else {
my $fetchresult = '';
my $fpath = '';	my $fpath = '';
my $fname = $file;	my $fname = $file;
($fpath,$fname) = ($file =~ m\|^(.*)/([^/]+)$\|);	($fpath,$fname) = ($file =~ m\|^(.*)/([^/]+)$\|);
Line 1269 sub clean_filename {	Line 1423 sub clean_filename {
}	}

# --------------- Take an uploaded file and put it into the userfiles directory	# --------------- Take an uploaded file and put it into the userfiles directory
# input: name of form element, coursedoc=1 means this is for the course	# input: $formname - the contents of the file are in $env{"form.$formname"}
# output: url of file in userspace	# the desired filenam is in $env{"form.$formname.filename"}
	# $coursedoc - if true up to the current course
	# if false
	# $subdir - directory in userfile to store the file into
	# $parser, $allfiles, $codebase - unknown
	#
	# output: url of file in userspace, or error: <message>
	# or /adm/notfound.html if failure to upload occurse


sub userfileupload {	sub userfileupload {
my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase)=@_;	my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname,$destudom)=@_;
if (!defined($subdir)) { $subdir='unknown'; }	if (!defined($subdir)) { $subdir='unknown'; }
my $fname=$env{'form.'.$formname.'.filename'};	my $fname=$env{'form.'.$formname.'.filename'};
$fname=&clean_filename($fname);	$fname=&clean_filename($fname);
Line 1295 sub userfileupload {	Line 1456 sub userfileupload {
open(my $fh,'>'.$fullpath.'/'.$fname);	open(my $fh,'>'.$fullpath.'/'.$fname);
print $fh $env{'form.'.$formname};	print $fh $env{'form.'.$formname};
close($fh);	close($fh);
return $fullpath.'/'.$fname;	return $fullpath.'/'.$fname;
	} elsif (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) { #files uploaded to create course page are handled differently
	my $filepath = 'tmp/addcourse/'.$destudom.'/web/'.$env{'user.name'}.
	'_'.$env{'user.domain'}.'/pending';
	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
$fname="$subdir/$fname";	$fname="$subdir/$fname";
if ($coursedoc) {	if ($coursedoc) {
Line 1312 sub userfileupload {	Line 1489 sub userfileupload {
$fname,$formname,$parser,	$fname,$formname,$parser,
$allfiles,$codebase);	$allfiles,$codebase);
}	}
	} elsif (defined($destuname)) {
	my $docuname=$destuname;
	my $docudom=$destudom;
	return &finishuserfileupload($docuname,$docudom,$formname,
	$fname,$parser,$allfiles,$codebase);

} else {	} else {
my $docuname=$env{'user.name'};	my $docuname=$env{'user.name'};
my $docudom=$env{'user.domain'};	my $docudom=$env{'user.domain'};
	if (exists($env{'form.group'})) {
	$docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
	$docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
	}
return &finishuserfileupload($docuname,$docudom,$formname,	return &finishuserfileupload($docuname,$docudom,$formname,
$fname,$parser,$allfiles,$codebase);	$fname,$parser,$allfiles,$codebase);
}	}
Line 1340 sub finishuserfileupload {	Line 1527 sub finishuserfileupload {
}	}
# Save the file	# Save the file
{	{
open(FH,'>'.$filepath.'/'.$file);	if (!open(FH,'>'.$filepath.'/'.$file)) {
print FH $env{'form.'.$formname};	&logthis('Failed to create '.$filepath.'/'.$file);
	print STDERR ('Failed to create '.$filepath.'/'.$file."\n");
	return '/adm/notfound.html';
	}
	if (!print FH ($env{'form.'.$formname})) {
	&logthis('Failed to write to '.$filepath.'/'.$file);
	print STDERR ('Failed to write to '.$filepath.'/'.$file."\n");
	return '/adm/notfound.html';
	}
close(FH);	close(FH);
}	}
if ($parser eq 'parse') {	if ($parser eq 'parse') {
Line 1484 sub removeuploadedurl {	Line 1679 sub removeuploadedurl {
sub removeuserfile {	sub removeuserfile {
my ($docuname,$docudom,$fname)=@_;	my ($docuname,$docudom,$fname)=@_;
my $home=&homeserver($docuname,$docudom);	my $home=&homeserver($docuname,$docudom);
return &reply("removeuserfile:$docudom/$docuname/$fname",$home);	my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home);
	if ($result eq 'ok') {
	if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {
	my $metafile = $fname.'.meta';
	my $metaresult = &removeuserfile($docuname,$docudom,$metafile);
	}
	}
	return $result;
}	}

sub mkdiruserfile {	sub mkdiruserfile {
Line 1496 sub mkdiruserfile {	Line 1698 sub mkdiruserfile {
sub renameuserfile {	sub renameuserfile {
my ($docuname,$docudom,$old,$new)=@_;	my ($docuname,$docudom,$old,$new)=@_;
my $home=&homeserver($docuname,$docudom);	my $home=&homeserver($docuname,$docudom);
return &reply("renameuserfile:$docudom:$docuname:".&escape("$old").':'.	my $result = &reply("renameuserfile:$docudom:$docuname:".
&escape("$new"),$home);	&escape("$old").':'.&escape("$new"),$home);
	if ($result eq 'ok') {
	if (($old !~ /\.meta$/) && (&is_portfolio_file($old))) {
	my $oldmeta = $old.'.meta';
	my $newmeta = $new.'.meta';
	my $metaresult =
	&renameuserfile($docuname,$docudom,$oldmeta,$newmeta);
	}
	}
	return $result;
}	}

# ------------------------------------------------------------------------- Log	# ------------------------------------------------------------------------- Log
Line 1523 sub flushcourselogs {	Line 1734 sub flushcourselogs {
# times and course titles for all courseids	# times and course titles for all courseids
#	#
my %courseidbuffer=();	my %courseidbuffer=();
foreach (keys %courselogs) {	foreach my $crsid (keys %courselogs) {
my $crsid=$_;
if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'.	if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'.
&escape($courselogs{$crsid}),	&escape($courselogs{$crsid}),
$coursehombuf{$crsid}) eq 'ok') {	$coursehombuf{$crsid}) eq 'ok') {
Line 1532 sub flushcourselogs {	Line 1742 sub flushcourselogs {
} else {	} else {
&logthis('Failed to flush log buffer for '.$crsid);	&logthis('Failed to flush log buffer for '.$crsid);
if (length($courselogs{$crsid})>40000) {	if (length($courselogs{$crsid})>40000) {
&logthis("<font color=blue>WARNING: Buffer for ".$crsid.	&logthis("<font color=\"blue\">WARNING: Buffer for ".$crsid.
" exceeded maximum size, deleting.</font>");	" exceeded maximum size, deleting.</font>");
delete $courselogs{$crsid};	delete $courselogs{$crsid};
}	}
Line 1540 sub flushcourselogs {	Line 1750 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});	':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$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});	':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid});
}	}
}	}
#	#
# Write course id database (reverse lookup) to homeserver of courses	# Write course id database (reverse lookup) to homeserver of courses
# Is used in pickcourse	# Is used in pickcourse
#	#
foreach (keys %courseidbuffer) {	foreach my $crsid (keys(%courseidbuffer)) {
&courseidput($hostdom{$_},$courseidbuffer{$_},$_);	&courseidput($hostdom{$crsid},$courseidbuffer{$crsid},$crsid);
}	}
#	#
# File accesses	# File accesses
Line 1561 sub flushcourselogs {	Line 1771 sub flushcourselogs {
foreach my $entry (keys(%accesshash)) {	foreach my $entry (keys(%accesshash)) {
if ($entry =~ /___count$/) {	if ($entry =~ /___count$/) {
my ($dom,$name);	my ($dom,$name);
($dom,$name,undef)=($entry=~m:___(\w+)/(\w+)/(.*)___count$:);	($dom,$name,undef)=
	($entry=~m{___($match_domain)/($match_username)/(.*)___count$});
if (! defined($dom) \|\| $dom eq '' \|\|	if (! defined($dom) \|\| $dom eq '' \|\|
! defined($name) \|\| $name eq '') {	! defined($name) \|\| $name eq '') {
my $cid = $env{'request.course.id'};	my $cid = $env{'request.course.id'};
Line 1582 sub flushcourselogs {	Line 1793 sub flushcourselogs {
}	}
}	}
} else {	} else {
my ($dom,$name) = ($entry=~m:___(\w+)/(\w+)/(.*)___(\w+)$:);	my ($dom,$name) = ($entry=~m{___($match_domain)/($match_username)/(.*)___(\w+)$});
my %temphash=($entry => $accesshash{$entry});	my %temphash=($entry => $accesshash{$entry});
if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {	if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
delete $accesshash{$entry};	delete $accesshash{$entry};
Line 1593 sub flushcourselogs {	Line 1804 sub flushcourselogs {
# Roles	# Roles
# Reverse lookup of user roles for course faculty/staff and co-authorship	# Reverse lookup of user roles for course faculty/staff and co-authorship
#	#
foreach (keys %userrolehash) {	foreach my $entry (keys(%userrolehash)) {
my $entry=$_;
my ($role,$uname,$udom,$runame,$rudom,$rsec)=	my ($role,$uname,$udom,$runame,$rudom,$rsec)=
split(/\:/,$entry);	split(/\:/,$entry);
if (&Apache::lonnet::put('nohist_userroles',	if (&Apache::lonnet::put('nohist_userroles',
Line 1603 sub flushcourselogs {	Line 1813 sub flushcourselogs {
delete $userrolehash{$entry};	delete $userrolehash{$entry};
}	}
}	}
	#
	# Reverse lookup of domain roles (dc, ad, li, sc, au)
	#
	my %domrolebuffer = ();
	foreach my $entry (keys %domainrolehash) {
	my ($role,$uname,$udom,$runame,$rudom,$rsec)=split/:/,$entry;
	if ($domrolebuffer{$rudom}) {
	$domrolebuffer{$rudom}.='&'.&escape($entry).
	'='.&escape($domainrolehash{$entry});
	} else {
	$domrolebuffer{$rudom}.=&escape($entry).
	'='.&escape($domainrolehash{$entry});
	}
	delete $domainrolehash{$entry};
	}
	foreach my $dom (keys(%domrolebuffer)) {
	foreach my $tryserver (keys %libserv) {
	if ($hostdom{$tryserver} eq $dom) {
	unless (&reply('domroleput:'.$dom.':'.
	$domrolebuffer{$dom},$tryserver) eq 'ok') {
	&logthis('Put of domain roles failed for '.$dom.' and '.$tryserver);
	}
	}
	}
	}
$dumpcount++;	$dumpcount++;
}	}

Line 1622 sub courselog {	Line 1857 sub courselog {
$env{'course.'.$env{'request.course.id'}.'.internal.coursecode'};	$env{'course.'.$env{'request.course.id'}.'.internal.coursecode'};
$courseownerbuf{$env{'request.course.id'}}=	$courseownerbuf{$env{'request.course.id'}}=
$env{'course.'.$env{'request.course.id'}.'.internal.courseowner'};	$env{'course.'.$env{'request.course.id'}.'.internal.courseowner'};
	$coursetypebuf{$env{'request.course.id'}}=
	$env{'course.'.$env{'request.course.id'}.'.type'};
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 1639 sub courseacclog {	Line 1876 sub courseacclog {
if ($fnsymb=~/(problem\|exam\|quiz\|assess\|survey\|form\|task\|page)$/) {	if ($fnsymb=~/(problem\|exam\|quiz\|assess\|survey\|form\|task\|page)$/) {
$what.=':POST';	$what.=':POST';
# FIXME: Probably ought to escape things....	# FIXME: Probably ought to escape things....
foreach (keys %env) {	foreach my $key (keys(%env)) {
if ($_=~/^form\.(.*)/) {	if ($key=~/^form\.(.*)/) {
$what.=':'.$1.'='.$env{$_};	$what.=':'.$1.'='.$env{$key};
}	}
}	}
} elsif ($fnsymb =~ m:^/adm/searchcat:) {	} elsif ($fnsymb =~ m:^/adm/searchcat:) {
Line 1678 sub linklog {	Line 1915 sub linklog {

sub userrolelog {	sub userrolelog {
my ($trole,$username,$domain,$area,$tstart,$tend)=@_;	my ($trole,$username,$domain,$area,$tstart,$tend)=@_;
if (($trole=~/^ca/) \|\| ($trole=~/^in/) \|\|	if (($trole=~/^ca/) \|\| ($trole=~/^aa/) \|\|
($trole=~/^cc/) \|\| ($trole=~/^ep/) \|\|	($trole=~/^in/) \|\| ($trole=~/^cc/) \|\|
($trole=~/^cr/) \|\| ($trole=~/^ta/)) {	($trole=~/^ep/) \|\| ($trole=~/^cr/) \|\|
	($trole=~/^ta/)) {
my (undef,$rudom,$runame,$rsec)=split(/\//,$area);	my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
$userrolehash	$userrolehash
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}	{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
=$tend.':'.$tstart;	=$tend.':'.$tstart;
}	}
	if (($trole=~/^dc/) \|\| ($trole=~/^ad/) \|\|
	($trole=~/^li/) \|\| ($trole=~/^li/) \|\|
	($trole=~/^au/) \|\| ($trole=~/^dg/) \|\|
	($trole=~/^sc/)) {
	my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
	$domainrolehash
	{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
	= $tend.':'.$tstart;
	}
}	}

sub get_course_adv_roles {	sub get_course_adv_roles {
Line 1693 sub get_course_adv_roles {	Line 1940 sub get_course_adv_roles {
$cid=$env{'request.course.id'} unless (defined($cid));	$cid=$env{'request.course.id'} unless (defined($cid));
my %coursehash=&coursedescription($cid);	my %coursehash=&coursedescription($cid);
my %nothide=();	my %nothide=();
foreach (split(/\s\,\s/,$coursehash{'nothideprivileged'})) {	foreach my $user (split(/\s\,\s/,$coursehash{'nothideprivileged'})) {
$nothide{join(':',split(/[\@\:]/,$_))}=1;	$nothide{join(':',split(/[\@\:]/,$user))}=1;
}	}
my %returnhash=();	my %returnhash=();
my %dumphash=	my %dumphash=
&dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});	&dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
my $now=time;	my $now=time;
foreach (keys %dumphash) {	foreach my $entry (keys %dumphash) {
my ($tend,$tstart)=split(/\:/,$dumphash{$_});	my ($tend,$tstart)=split(/\:/,$dumphash{$entry});
if (($tstart) && ($tstart<0)) { next; }	if (($tstart) && ($tstart<0)) { next; }
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(/\:/,$entry);
if ($username eq '' \|\| $domain eq '') { next; }	if ($username eq '' \|\| $domain eq '') { next; }
if ((&privileged($username,$domain)) &&	if ((&privileged($username,$domain)) &&
(!$nothide{$username.':'.$domain})) { next; }	(!$nothide{$username.':'.$domain})) { next; }
if ($role eq 'cr') { next; }	if ($role eq 'cr') { next; }
my $key=&plaintext($role);	my $key=&plaintext($role);
if ($role =~ /^cr/) {
$key=(split('/',$role))[3];
}
if ($section) { $key.=' (Sec/Grp '.$section.')'; }	if ($section) { $key.=' (Sec/Grp '.$section.')'; }
if ($returnhash{$key}) {	if ($returnhash{$key}) {
$returnhash{$key}.=','.$username.':'.$domain;	$returnhash{$key}.=','.$username.':'.$domain;
Line 1732 sub get_my_roles {	Line 1976 sub get_my_roles {
&dump('nohist_userroles',$udom,$uname);	&dump('nohist_userroles',$udom,$uname);
my %returnhash=();	my %returnhash=();
my $now=time;	my $now=time;
foreach (keys %dumphash) {	foreach my $entry (keys(%dumphash)) {
my ($tend,$tstart)=split(/\:/,$dumphash{$_});	my ($tend,$tstart)=split(/\:/,$dumphash{$entry});
if (($tstart) && ($tstart<0)) { next; }	if (($tstart) && ($tstart<0)) { next; }
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(/\:/,$entry);
$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;	$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
}	}
return %returnhash;	return %returnhash;
Line 1758 sub getannounce {	Line 2002 sub getannounce {

if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) {	if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) {
my $announcement='';	my $announcement='';
while (<$fh>) { $announcement .=$_; }	while (my $line = <$fh>) { $announcement .= $line; }
close($fh);	close($fh);
if ($announcement=~/\w/) {	if ($announcement=~/\w/) {
return	return
Line 1782 sub courseidput {	Line 2026 sub courseidput {
}	}

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

#	# ---------------------------------------------------------- DC e-mail

	sub dcmailput {
	my ($domain,$msgid,$message,$server)=@_;
	my $status = &Apache::lonnet::critical(
	'dcmailput:'.$domain.':'.&escape($msgid).'='.
	&escape($message),$server);
	return $status;
	}

	sub dcmaildump {
	my ($dom,$startdate,$enddate,$senders) = @_;
	my %returnhash=();
	if (exists($domain_primary{$dom})) {
	my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'.
	&escape($enddate).':';
	my @esc_senders=map { &escape($_)} @$senders;
	$cmd.=&escape(join('&',@esc_senders));
	foreach my $line (split(/\&/,&reply($cmd,$domain_primary{$dom}))) {
	my ($key,$value) = split(/\=/,$line,2);
	if (($key) && ($value)) {
	$returnhash{&unescape($key)} = &unescape($value);
	}
	}
	}
	return %returnhash;
	}
	# ---------------------------------------------------------- Domain roles

	sub get_domain_roles {
	my ($dom,$roles,$startdate,$enddate)=@_;
	if (undef($startdate) \|\| $startdate eq '') {
	$startdate = '.';
	}
	if (undef($enddate) \|\| $enddate eq '') {
	$enddate = '.';
	}
	my $rolelist = join(':',@{$roles});
	my %personnel = ();
	foreach my $tryserver (keys(%libserv)) {
	if ($hostdom{$tryserver} eq $dom) {
	%{$personnel{$tryserver}}=();
	foreach my $line (
	split(/\&/,&reply('domrolesdump:'.$dom.':'.
	&escape($startdate).':'.&escape($enddate).':'.
	&escape($rolelist), $tryserver))) {
	my ($key,$value) = split(/\=/,$line,2);
	if (($key) && ($value)) {
	$personnel{$tryserver}{&unescape($key)} = &unescape($value);
	}
	}
	}
	}
	return %personnel;
	}

# ----------------------------------------------------------- Check out an item	# ----------------------------------------------------------- Check out an item

sub get_first_access {	sub get_first_access {
my ($type,$argsymb)=@_;	my ($type,$argsymb)=@_;
my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();	my ($symb,$courseid,$udom,$uname)=&whichuser();
if ($argsymb) { $symb=$argsymb; }	if ($argsymb) { $symb=$argsymb; }
my ($map,$id,$res)=&decode_symb($symb);	my ($map,$id,$res)=&decode_symb($symb);
if ($type eq 'map') {	if ($type eq 'map') {
Line 1823 sub get_first_access {	Line 2122 sub get_first_access {

sub set_first_access {	sub set_first_access {
my ($type)=@_;	my ($type)=@_;
my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();	my ($symb,$courseid,$udom,$uname)=&whichuser();
my ($map,$id,$res)=&decode_symb($symb);	my ($map,$id,$res)=&decode_symb($symb);
if ($type eq 'map') {	if ($type eq 'map') {
$res=&symbread($map);	$res=&symbread($map);
Line 1850 sub checkout {	Line 2149 sub checkout {
$now.'&'.$ENV{'REMOTE_ADDR'});	$now.'&'.$ENV{'REMOTE_ADDR'});
my $token=&reply('tmpput:'.$infostr,$lonhost);	my $token=&reply('tmpput:'.$infostr,$lonhost);
if ($token=~/^error\:/) {	if ($token=~/^error\:/) {
&logthis("<font color=blue>WARNING: ".	&logthis("<font color=\"blue\">WARNING: ".
"Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.	"Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
"</font>");	"</font>");
return '';	return '';
Line 1866 sub checkout {	Line 2165 sub checkout {
unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {	unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
return '';	return '';
} else {	} else {
&logthis("<font color=blue>WARNING: ".	&logthis("<font color=\"blue\">WARNING: ".
"Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.	"Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
"</font>");	"</font>");
}	}
Line 1876 sub checkout {	Line 2175 sub checkout {
$token)) ne 'ok') {	$token)) ne 'ok') {
return '';	return '';
} else {	} else {
&logthis("<font color=blue>WARNING: ".	&logthis("<font color=\"blue\">WARNING: ".
"Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.	"Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
"</font>");	"</font>");
}	}
Line 2017 sub hash2str {	Line 2316 sub hash2str {
sub hashref2str {	sub hashref2str {
my ($hashref)=@_;	my ($hashref)=@_;
my $result='__HASH_REF__';	my $result='__HASH_REF__';
foreach (sort(keys(%$hashref))) {	foreach my $key (sort(keys(%$hashref))) {
if (ref($_) eq 'ARRAY') {	if (ref($key) eq 'ARRAY') {
$result.=&arrayref2str($_).'=';	$result.=&arrayref2str($key).'=';
} elsif (ref($_) eq 'HASH') {	} elsif (ref($key) eq 'HASH') {
$result.=&hashref2str($_).'=';	$result.=&hashref2str($key).'=';
} elsif (ref($_)) {	} elsif (ref($key)) {
$result.='=';	$result.='=';
#print("Got a ref of ".(ref($_))." skipping.");	#print("Got a ref of ".(ref($key))." skipping.");
} else {	} else {
if ($_) {$result.=&escape($_).'=';} else { last; }	if ($key) {$result.=&escape($key).'=';} else { last; }
}	}

if(ref($hashref->{$_}) eq 'ARRAY') {	if(ref($hashref->{$key}) eq 'ARRAY') {
$result.=&arrayref2str($hashref->{$_}).'&';	$result.=&arrayref2str($hashref->{$key}).'&';
} elsif(ref($hashref->{$_}) eq 'HASH') {	} elsif(ref($hashref->{$key}) eq 'HASH') {
$result.=&hashref2str($hashref->{$_}).'&';	$result.=&hashref2str($hashref->{$key}).'&';
} elsif(ref($hashref->{$_})) {	} elsif(ref($hashref->{$key})) {
$result.='&';	$result.='&';
#print("Got a ref of ".(ref($hashref->{$_}))." skipping.");	#print("Got a ref of ".(ref($hashref->{$key}))." skipping.");
} else {	} else {
$result.=&escape($hashref->{$_}).'&';	$result.=&escape($hashref->{$key}).'&';
}	}
}	}
$result=~s/\&$//;	$result=~s/\&$//;
Line 2317 sub store {	Line 2616 sub store {
$$storehash{'host'}=$perlvar{'lonHostID'};	$$storehash{'host'}=$perlvar{'lonHostID'};

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

my $namevalue='';	my $namevalue='';
foreach (keys %$storehash) {	foreach my $key (keys(%$storehash)) {
$namevalue.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&';	$namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
}	}
$namevalue=~s/\&$//;	$namevalue=~s/\&$//;
&courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);	&courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);
Line 2386 sub restore {	Line 2685 sub restore {
my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home");	my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home");

my %returnhash=();	my %returnhash=();
foreach (split(/\&/,$answer)) {	foreach my $line (split(/\&/,$answer)) {
my ($name,$value)=split(/\=/,$_);	my ($name,$value)=split(/\=/,$line);
$returnhash{&unescape($name)}=&thaw_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++) {
foreach (split(/\:/,$returnhash{$version.':keys'})) {	foreach my $item (split(/\:/,$returnhash{$version.':keys'})) {
$returnhash{$_}=$returnhash{$version.':'.$_};	$returnhash{$item}=$returnhash{$version.':'.$item};
}	}
}	}
return %returnhash;	return %returnhash;
Line 2402 sub restore {	Line 2701 sub restore {
# ---------------------------------------------------------- Course Description	# ---------------------------------------------------------- Course Description

sub coursedescription {	sub coursedescription {
my $courseid=shift;	my ($courseid,$args)=@_;
$courseid=~s/^\///;	$courseid=~s/^\///;
$courseid=~s/\_/\//g;	$courseid=~s/\_/\//g;
my ($cdomain,$cnum)=split(/\//,$courseid);	my ($cdomain,$cnum)=split(/\//,$courseid);
Line 2412 sub coursedescription {	Line 2711 sub coursedescription {
# trying and trying and trying to get the course description.	# trying and trying and trying to get the course description.
my %envhash=();	my %envhash=();
my %returnhash=();	my %returnhash=();
$envhash{'course.'.$normalid.'.last_cache'}=time;
	my $expiretime=600;
	if ($env{'request.course.id'} eq $normalid) {
	$expiretime=120;
	}

	my $prefix='course.'.$cdomain.'_'.$cnum.'.';
	if (!$args->{'freshen_cache'}
	&& ((time-$env{$prefix.'last_cache'}) < $expiretime) ) {
	foreach my $key (keys(%env)) {
	next if ($key !~ /^\Q$prefix\E(.*)/);
	my ($setting) = $1;
	$returnhash{$setting} = $env{$key};
	}
	return %returnhash;
	}

	# get the data agin
	if (!$args->{'one_time'}) {
	$envhash{'course.'.$normalid.'.last_cache'}=time;
	}
if ($chome ne 'no_host') {	if ($chome ne 'no_host') {
%returnhash=&dump('environment',$cdomain,$cnum);	%returnhash=&dump('environment',$cdomain,$cnum);
if (!exists($returnhash{'con_lost'})) {	if (!exists($returnhash{'con_lost'})) {
$returnhash{'home'}= $chome;	$returnhash{'home'}= $chome;
$returnhash{'domain'} = $cdomain;	$returnhash{'domain'} = $cdomain;
$returnhash{'num'} = $cnum;	$returnhash{'num'} = $cnum;
	if (!defined($returnhash{'type'})) {
	$returnhash{'type'} = 'Course';
	}
while (my ($name,$value) = each %returnhash) {	while (my ($name,$value) = each %returnhash) {
$envhash{'course.'.$normalid.'.'.$name}=$value;	$envhash{'course.'.$normalid.'.'.$name}=$value;
}	}
Line 2430 sub coursedescription {	Line 2752 sub coursedescription {
$envhash{'course.'.$normalid.'.num'}=$cnum;	$envhash{'course.'.$normalid.'.num'}=$cnum;
}	}
}	}
&appenv(%envhash);	if (!$args->{'one_time'}) {
	&appenv(%envhash);
	}
return %returnhash;	return %returnhash;
}	}

Line 2443 sub privileged {	Line 2767 sub privileged {
if (($rolesdump eq 'con_lost') \|\| ($rolesdump eq '')) { return 0; }	if (($rolesdump eq 'con_lost') \|\| ($rolesdump eq '')) { return 0; }
my $now=time;	my $now=time;
if ($rolesdump ne '') {	if ($rolesdump ne '') {
foreach (split(/&/,$rolesdump)) {	foreach my $entry (split(/&/,$rolesdump)) {
if ($_!~/^rolesdef_/) {	if ($entry!~/^rolesdef_/) {
my ($area,$role)=split(/=/,$_);	my ($area,$role)=split(/=/,$entry);
$area=~s/\_\w\w$//;	$area=~s/\_\w\w$//;
my ($trole,$tend,$tstart)=split(/_/,$role);	my ($trole,$tend,$tstart)=split(/_/,$role);
if (($trole eq 'dc') \|\| ($trole eq 'su')) {	if (($trole eq 'dc') \|\| ($trole eq 'su')) {
Line 2471 sub rolesinit {	Line 2795 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 %allgroups=();
my $now=time;	my $now=time;
my $userroles="user.login.time=$now\n";	my %userroles = ('user.login.time' => $now);
	my $group_privs;

if ($rolesdump ne '') {	if ($rolesdump ne '') {
foreach (split(/&/,$rolesdump)) {	foreach my $entry (split(/&/,$rolesdump)) {
if ($_!~/^rolesdef_/) {	if ($entry!~/^rolesdef_/) {
my ($area,$role)=split(/=/,$_);	my ($area,$role)=split(/=/,$entry);
$area=~s/\_\w\w$//;	$area=~s/\_\w\w$//;
	my ($trole,$tend,$tstart,$group_privs);
my ($trole,$tend,$tstart);
if ($role=~/^cr/) {	if ($role=~/^cr/) {
if ($role=~m\|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$\|) {	if ($role=~m\|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$\|) {
($trole,my $trest)=($role=~m\|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$\|);	($trole,my $trest)=($role=~m\|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$\|);
($tend,$tstart)=split('_',$trest);	($tend,$tstart)=split('_',$trest);
} else {	} else {
$trole=$role;	$trole=$role;
}	}
	} elsif ($role =~ m\|^gr/\|) {
	($trole,$tend,$tstart) = split(/_/,$role);
	($trole,$group_privs) = split(/\//,$trole);
	$group_privs = &unescape($group_privs);
} else {	} else {
($trole,$tend,$tstart)=split(/_/,$role);	($trole,$tend,$tstart)=split(/_/,$role);
}	}
$userroles.=&set_arearole($trole,$area,$tstart,$tend,$domain,$username);	my %new_role = &set_arearole($trole,$area,$tstart,$tend,$domain,
	$username);
	@userroles{keys(%new_role)} = @new_role{keys(%new_role)};
if (($tend!=0) && ($tend<$now)) { $trole=''; }	if (($tend!=0) && ($tend<$now)) { $trole=''; }
if (($tstart!=0) && ($tstart>$now)) { $trole=''; }	if (($tstart!=0) && ($tstart>$now)) { $trole=''; }
if (($area ne '') && ($trole ne '')) {	if (($area ne '') && ($trole ne '')) {
Line 2499 sub rolesinit {	Line 2830 sub rolesinit {
my ($tdummy,$tdomain,$trest)=split(/\//,$area);	my ($tdummy,$tdomain,$trest)=split(/\//,$area);
if ($trole =~ /^cr\//) {	if ($trole =~ /^cr\//) {
&custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);	&custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
	} elsif ($trole eq 'gr') {
	&group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart);
} else {	} else {
&standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);	&standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
}	}
}	}
}	}
}	}
my ($author,$adv) = &set_userprivs(\$userroles,\%allroles);	my ($author,$adv) = &set_userprivs(\%userroles,\%allroles,\%allgroups);
$userroles.='user.adv='.$adv."\n".	$userroles{'user.adv'} = $adv;
'user.author='.$author."\n";	$userroles{'user.author'} = $author;
$env{'user.adv'}=$adv;	$env{'user.adv'}=$adv;
}	}
return $userroles;	return \%userroles;
}	}

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

sub custom_roleprivs {	sub custom_roleprivs {
Line 2547 sub custom_roleprivs {	Line 2880 sub custom_roleprivs {
}	}
}	}

	sub group_roleprivs {
	my ($allgroups,$area,$group_privs,$tend,$tstart) = @_;
	my $access = 1;
	my $now = time;
	if (($tend!=0) && ($tend<$now)) { $access = 0; }
	if (($tstart!=0) && ($tstart>$now)) { $access=0; }
	if ($access) {
	my ($course,$group) = ($area =~ m\|(/$match_domain/$match_username)/([^/]+)$\|);
	$$allgroups{$course}{$group} .=':'.$group_privs;
	}
	}

sub standard_roleprivs {	sub standard_roleprivs {
my ($allroles,$trole,$tdomain,$spec,$trest,$area) = @_;	my ($allroles,$trole,$tdomain,$spec,$trest,$area) = @_;
Line 2567 sub standard_roleprivs {	Line 2911 sub standard_roleprivs {
}	}

sub set_userprivs {	sub set_userprivs {
my ($userroles,$allroles) = @_;	my ($userroles,$allroles,$allgroups) = @_;
my $author=0;	my $author=0;
my $adv=0;	my $adv=0;
foreach (keys %{$allroles}) {	my %grouproles = ();
my %thesepriv=();	if (keys(%{$allgroups}) > 0) {
if (($_=~/^au/) \|\| ($_=~/^ca/)) { $author=1; }	foreach my $role (keys %{$allroles}) {
foreach (split(/:/,$$allroles{$_})) {	my ($trole,$area,$sec,$extendedarea);
if ($_ ne '') {	if ($role =~ m-^(\w+\|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_username)(/?\w*)-) {
my ($privilege,$restrictions)=split(/&/,$_);	$trole = $1;
	$area = $2;
	$sec = $3;
	$extendedarea = $area.$sec;
	if (exists($$allgroups{$area})) {
	foreach my $group (keys(%{$$allgroups{$area}})) {
	my $spec = $trole.'.'.$extendedarea;
	$grouproles{$spec.'.'.$area.'/'.$group} =
	$$allgroups{$area}{$group};
	}
	}
	}
	}
	}
	foreach my $group (keys(%grouproles)) {
	$$allroles{$group} = $grouproles{$group};
	}
	foreach my $role (keys(%{$allroles})) {
	my %thesepriv;
	if (($role=~/^au/) \|\| ($role=~/^ca/)) { $author=1; }
	foreach my $item (split(/:/,$$allroles{$role})) {
	if ($item ne '') {
	my ($privilege,$restrictions)=split(/&/,$item);
if ($restrictions eq '') {	if ($restrictions eq '') {
$thesepriv{$privilege}='F';	$thesepriv{$privilege}='F';
} elsif ($thesepriv{$privilege} ne 'F') {	} elsif ($thesepriv{$privilege} ne 'F') {
Line 2585 sub set_userprivs {	Line 2951 sub set_userprivs {
}	}
}	}
my $thesestr='';	my $thesestr='';
foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; }	foreach my $priv (keys(%thesepriv)) {
$$userroles.='user.priv.'.$_.'='.$thesestr."\n";	$thesestr.=':'.$priv.'&'.$thesepriv{$priv};
	}
	$userroles->{'user.priv.'.$role} = $thesestr;
}	}
return ($author,$adv);	return ($author,$adv);
}	}
Line 2596 sub set_userprivs {	Line 2964 sub set_userprivs {
sub get {	sub get {
my ($namespace,$storearr,$udomain,$uname)=@_;	my ($namespace,$storearr,$udomain,$uname)=@_;
my $items='';	my $items='';
foreach (@$storearr) {	foreach my $item (@$storearr) {
$items.=escape($_).'&';	$items.=&escape($item).'&';
}	}
$items=~s/\&$//;	$items=~s/\&$//;
if (!$udomain) { $udomain=$env{'user.domain'}; }	if (!$udomain) { $udomain=$env{'user.domain'}; }
Line 2611 sub get {	Line 2979 sub get {
}	}
my %returnhash=();	my %returnhash=();
my $i=0;	my $i=0;
foreach (@$storearr) {	foreach my $item (@$storearr) {
$returnhash{$_}=&thaw_unescape($pairs[$i]);	$returnhash{$item}=&thaw_unescape($pairs[$i]);
$i++;	$i++;
}	}
return %returnhash;	return %returnhash;
Line 2623 sub get {	Line 2991 sub get {
sub del {	sub del {
my ($namespace,$storearr,$udomain,$uname)=@_;	my ($namespace,$storearr,$udomain,$uname)=@_;
my $items='';	my $items='';
foreach (@$storearr) {	foreach my $item (@$storearr) {
$items.=escape($_).'&';	$items.=&escape($item).'&';
}	}
$items=~s/\&$//;	$items=~s/\&$//;
if (!$udomain) { $udomain=$env{'user.domain'}; }	if (!$udomain) { $udomain=$env{'user.domain'}; }
Line 2637 sub del {	Line 3005 sub del {
# -------------------------------------------------------------- dump interface	# -------------------------------------------------------------- dump interface

sub dump {	sub dump {
my ($namespace,$udomain,$uname,$regexp)=@_;	my ($namespace,$udomain,$uname,$regexp,$range)=@_;
if (!$udomain) { $udomain=$env{'user.domain'}; }	if (!$udomain) { $udomain=$env{'user.domain'}; }
if (!$uname) { $uname=$env{'user.name'}; }	if (!$uname) { $uname=$env{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);	my $uhome=&homeserver($uname,$udomain);
if ($regexp) {	if ($regexp) {
$regexp=&escape($regexp);	$regexp=&escape($regexp);
} else {	} else {
$regexp='.';	$regexp='.';
}	}
my $rep=reply("dump:$udomain:$uname:$namespace:$regexp",$uhome);	my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
my @pairs=split(/\&/,$rep);	my @pairs=split(/\&/,$rep);
my %returnhash=();	my %returnhash=();
foreach (@pairs) {	foreach my $item (@pairs) {
my ($key,$value)=split(/=/,$_);	my ($key,$value)=split(/=/,$item,2);
$returnhash{unescape($key)}=&thaw_unescape($value);	$key = &unescape($key);
}	next if ($key =~ /^error: 2 /);
return %returnhash;	$returnhash{$key}=&thaw_unescape($value);
	}
	return %returnhash;
	}

	# --------------------------------------------------------- dumpstore interface

	sub dumpstore {
	my ($namespace,$udomain,$uname,$regexp,$range)=@_;
	return &dump($namespace,$udomain,$uname,$regexp,$range);
}	}

# -------------------------------------------------------------- keys interface	# -------------------------------------------------------------- keys interface
Line 2665 sub getkeys {	Line 3042 sub getkeys {
my $uhome=&homeserver($uname,$udomain);	my $uhome=&homeserver($uname,$udomain);
my $rep=reply("keys:$udomain:$uname:$namespace",$uhome);	my $rep=reply("keys:$udomain:$uname:$namespace",$uhome);
my @keyarray=();	my @keyarray=();
foreach (split(/\&/,$rep)) {	foreach my $key (split(/\&/,$rep)) {
push (@keyarray,&unescape($_));	push(@keyarray,&unescape($key));
}	}
return @keyarray;	return @keyarray;
}	}
Line 2693 sub currentdump {	Line 3070 sub currentdump {
%returnhash = %{&convert_dump_to_currentdump(\%hash)};	%returnhash = %{&convert_dump_to_currentdump(\%hash)};
} else {	} else {
my @pairs=split(/\&/,$rep);	my @pairs=split(/\&/,$rep);
foreach (@pairs) {	foreach my $pair (@pairs) {
my ($key,$value)=split(/=/,$_);	my ($key,$value)=split(/=/,$pair,2);
my ($symb,$param) = split(/:/,$key);	my ($symb,$param) = split(/:/,$key);
$returnhash{&unescape($symb)}->{&unescape($param)} =	$returnhash{&unescape($symb)}->{&unescape($param)} =
&thaw_unescape($value);	&thaw_unescape($value);
Line 2772 sub put {	Line 3149 sub put {
if (!$uname) { $uname=$env{'user.name'}; }	if (!$uname) { $uname=$env{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);	my $uhome=&homeserver($uname,$udomain);
my $items='';	my $items='';
foreach (keys %$storehash) {	foreach my $item (keys(%$storehash)) {
$items.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&';	$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
}	}
$items=~s/\&$//;	$items=~s/\&$//;
return &reply("put:$udomain:$uname:$namespace:$items",$uhome);	return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
Line 2797 sub newput {	Line 3174 sub newput {
# --------------------------------------------------------- putstore interface	# --------------------------------------------------------- putstore interface

sub putstore {	sub putstore {
my ($namespace,$storehash,$udomain,$uname)=@_;	my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_;
if (!$udomain) { $udomain=$env{'user.domain'}; }	if (!$udomain) { $udomain=$env{'user.domain'}; }
if (!$uname) { $uname=$env{'user.name'}; }	if (!$uname) { $uname=$env{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);	my $uhome=&homeserver($uname,$udomain);
my $items='';	my $items='';
my %allitems = ();	foreach my $key (keys(%$storehash)) {
foreach (keys %$storehash) {	$items.= &escape($key).'='.&freeze_escape($storehash->{$key}).'&';
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);	my $esc_symb=&escape($symb);
	my $esc_v=&escape($version);
	my $reply =
	&reply("putstore:$udomain:$uname:$namespace:$esc_symb:$esc_v:$items",
	$uhome);
	if ($reply eq 'unknown_cmd') {
	# gfall back to way things use to be done
	return &old_putstore($namespace,$symb,$version,$storehash,$udomain,
	$uname);
	}
	return $reply;
	}

	sub old_putstore {
	my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_;
	if (!$udomain) { $udomain=$env{'user.domain'}; }
	if (!$uname) { $uname=$env{'user.name'}; }
	my $uhome=&homeserver($uname,$udomain);
	my %newstorehash;
	foreach my $item (keys(%$storehash)) {
	my $key = $version.':'.&escape($symb).':'.$item;
	$newstorehash{$key} = $storehash->{$item};
	}
	my $items='';
	my %allitems = ();
	foreach my $item (keys(%newstorehash)) {
	if ($item =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) {
	my $key = $1.':keys:'.$2;
	$allitems{$key} .= $3.':';
	}
	$items.=$item.'='.&freeze_escape($newstorehash{$item}).'&';
	}
	foreach my $item (keys(%allitems)) {
	$allitems{$item} =~ s/\:$//;
	$items.= $item.'='.$allitems{$item}.'&';
	}
	$items=~s/\&$//;
	return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
}	}

# ------------------------------------------------------ critical put interface	# ------------------------------------------------------ critical put interface
Line 2826 sub cput {	Line 3231 sub cput {
if (!$uname) { $uname=$env{'user.name'}; }	if (!$uname) { $uname=$env{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);	my $uhome=&homeserver($uname,$udomain);
my $items='';	my $items='';
foreach (keys %$storehash) {	foreach my $item (keys(%$storehash)) {
$items.=escape($_).'='.&freeze_escape($$storehash{$_}).'&';	$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
}	}
$items=~s/\&$//;	$items=~s/\&$//;
return &critical("put:$udomain:$uname:$namespace:$items",$uhome);	return &critical("put:$udomain:$uname:$namespace:$items",$uhome);
Line 2838 sub cput {	Line 3243 sub cput {
sub eget {	sub eget {
my ($namespace,$storearr,$udomain,$uname)=@_;	my ($namespace,$storearr,$udomain,$uname)=@_;
my $items='';	my $items='';
foreach (@$storearr) {	foreach my $item (@$storearr) {
$items.=escape($_).'&';	$items.=&escape($item).'&';
}	}
$items=~s/\&$//;	$items=~s/\&$//;
if (!$udomain) { $udomain=$env{'user.domain'}; }	if (!$udomain) { $udomain=$env{'user.domain'}; }
Line 2849 sub eget {	Line 3254 sub eget {
my @pairs=split(/\&/,$rep);	my @pairs=split(/\&/,$rep);
my %returnhash=();	my %returnhash=();
my $i=0;	my $i=0;
foreach (@$storearr) {	foreach my $item (@$storearr) {
$returnhash{$_}=&thaw_unescape($pairs[$i]);	$returnhash{$item}=&thaw_unescape($pairs[$i]);
$i++;	$i++;
}	}
return %returnhash;	return %returnhash;
}	}

	# ------------------------------------------------------------ tmpput interface
	sub tmpput {
	my ($storehash,$server,$context)=@_;
	my $items='';
	foreach my $item (keys(%$storehash)) {
	$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
	}
	$items=~s/\&$//;
	if (defined($context)) {
	$items .= ':'.&escape($context);
	}
	return &reply("tmpput:$items",$server);
	}

	# ------------------------------------------------------------ tmpget interface
	sub tmpget {
	my ($token,$server)=@_;
	if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
	my $rep=&reply("tmpget:$token",$server);
	my %returnhash;
	foreach my $item (split(/\&/,$rep)) {
	my ($key,$value)=split(/=/,$item);
	$returnhash{&unescape($key)}=&thaw_unescape($value);
	}
	return %returnhash;
	}

	# ------------------------------------------------------------ tmpget interface
	sub tmpdel {
	my ($token,$server)=@_;
	if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
	return &reply("tmpdel:$token",$server);
	}

	# -------------------------------------------------- portfolio access checking

	sub portfolio_access {
	my ($requrl) = @_;
	my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl);
	my $result = &get_portfolio_access($udom,$unum,$file_name,$group);
	if ($result eq 'ok') {
	return 'F';
	} elsif ($result =~ /^[^:]+:guest_/) {
	return 'A';
	}
	return '';
	}

	sub get_portfolio_access {
	my ($udom,$unum,$file_name,$group,$access_hash) = @_;

	if (!ref($access_hash)) {
	my $current_perms = &get_portfile_permissions($udom,$unum);
	my %access_controls = &get_access_controls($current_perms,$group,
	$file_name);
	$access_hash = $access_controls{$file_name};
	}

	my ($public,$guest,@domains,@users,@courses,@groups);
	my $now = time;
	if (ref($access_hash) eq 'HASH') {
	foreach my $key (keys(%{$access_hash})) {
	my ($num,$scope,$end,$start) = ($key =~ /^([^:]+):([a-z]+)_(\d)_?(\d)$/);
	if ($start > $now) {
	next;
	}
	if ($end && $end<$now) {
	next;
	}
	if ($scope eq 'public') {
	$public = $key;
	last;
	} elsif ($scope eq 'guest') {
	$guest = $key;
	} elsif ($scope eq 'domains') {
	push(@domains,$key);
	} elsif ($scope eq 'users') {
	push(@users,$key);
	} elsif ($scope eq 'course') {
	push(@courses,$key);
	} elsif ($scope eq 'group') {
	push(@groups,$key);
	}
	}
	if ($public) {
	return 'ok';
	}
	if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
	if ($guest) {
	return $guest;
	}
	} else {
	if (@domains > 0) {
	foreach my $domkey (@domains) {
	if (ref($access_hash->{$domkey}{'dom'}) eq 'ARRAY') {
	if (grep(/^\Q$env{'user.domain'}\E$/,@{$access_hash->{$domkey}{'dom'}})) {
	return 'ok';
	}
	}
	}
	}
	if (@users > 0) {
	foreach my $userkey (@users) {
	if (exists($access_hash->{$userkey}{'users'}{$env{'user.name'}.':'.$env{'user.domain'}})) {
	return 'ok';
	}
	}
	}
	my %roleshash;
	my @courses_and_groups = @courses;
	push(@courses_and_groups,@groups);
	if (@courses_and_groups > 0) {
	my (%allgroups,%allroles);
	my ($start,$end,$role,$sec,$group);
	foreach my $envkey (%env) {
	if ($envkey =~ m-^user\.role\.(gr\|cc\|in\|ta\|ep\|st)\./($match_domain)/($match_username)/?([^/]*)$-) {
	my $cid = $2.'_'.$3;
	if ($1 eq 'gr') {
	$group = $4;
	$allgroups{$cid}{$group} = $env{$envkey};
	} else {
	if ($4 eq '') {
	$sec = 'none';
	} else {
	$sec = $4;
	}
	$allroles{$cid}{$1}{$sec} = $env{$envkey};
	}
	} elsif ($envkey =~ m-^user\.role\./cr/($match_domain/$match_username/\w)./($match_domain)/($match_username)/?([^/])$-) {
	my $cid = $2.'_'.$3;
	if ($4 eq '') {
	$sec = 'none';
	} else {
	$sec = $4;
	}
	$allroles{$cid}{$1}{$sec} = $env{$envkey};
	}
	}
	if (keys(%allroles) == 0) {
	return;
	}
	foreach my $key (@courses_and_groups) {
	my %content = %{$$access_hash{$key}};
	my $cnum = $content{'number'};
	my $cdom = $content{'domain'};
	my $cid = $cdom.'_'.$cnum;
	if (!exists($allroles{$cid})) {
	next;
	}
	foreach my $role_id (keys(%{$content{'roles'}})) {
	my @sections = @{$content{'roles'}{$role_id}{'section'}};
	my @groups = @{$content{'roles'}{$role_id}{'group'}};
	my @status = @{$content{'roles'}{$role_id}{'access'}};
	my @roles = @{$content{'roles'}{$role_id}{'role'}};
	foreach my $role (keys(%{$allroles{$cid}})) {
	if ((grep/^all$/,@roles) \|\| (grep/^\Q$role\E$/,@roles)) {
	foreach my $sec (keys(%{$allroles{$cid}{$role}})) {
	if (&course_group_datechecker($allroles{$cid}{$role}{$sec},$now,\@status) eq 'ok') {
	if (grep/^all$/,@sections) {
	return 'ok';
	} else {
	if (grep/^$sec$/,@sections) {
	return 'ok';
	}
	}
	}
	}
	if (keys(%{$allgroups{$cid}}) == 0) {
	if (grep/^none$/,@groups) {
	return 'ok';
	}
	} else {
	if (grep/^all$/,@groups) {
	return 'ok';
	}
	foreach my $group (keys(%{$allgroups{$cid}})) {
	if (grep/^$group$/,@groups) {
	return 'ok';
	}
	}
	}
	}
	}
	}
	}
	}
	if ($guest) {
	return $guest;
	}
	}
	}
	return;
	}

	sub course_group_datechecker {
	my ($dates,$now,$status) = @_;
	my ($start,$end) = split(/\./,$dates);
	if (!$start && !$end) {
	return 'ok';
	}
	if (grep/^active$/,@{$status}) {
	if (((!$start) \|\| ($start && $start <= $now)) && ((!$end) \|\| ($end && $end >= $now))) {
	return 'ok';
	}
	}
	if (grep/^previous$/,@{$status}) {
	if ($end > $now ) {
	return 'ok';
	}
	}
	if (grep/^future$/,@{$status}) {
	if ($start > $now) {
	return 'ok';
	}
	}
	return;
	}

	sub parse_portfolio_url {
	my ($url) = @_;

	my ($type,$udom,$unum,$group,$file_name);

	if ($url =~ m-^/*uploaded/($match_domain)/($match_username)/portfolio(/.+)$-) {
	$type = 1;
	$udom = $1;
	$unum = $2;
	$file_name = $3;
	} elsif ($url =~ m-^/*uploaded/($match_domain)/($match_username)/groups/([^/]+)/portfolio/(.+)$-) {
	$type = 2;
	$udom = $1;
	$unum = $2;
	$group = $3;
	$file_name = $3.'/'.$4;
	}
	if (wantarray) {
	return ($type,$udom,$unum,$file_name,$group);
	}
	return $type;
	}

	sub is_portfolio_url {
	my ($url) = @_;
	return scalar(&parse_portfolio_url($url));
	}

	sub is_portfolio_file {
	my ($file) = @_;
	if (($file =~ /^portfolio/) \|\| ($file =~ /^groups\/$match_username\/portfolio/)) {
	return 1;
	}
	return;
	}


# ---------------------------------------------- Custom access rule evaluation	# ---------------------------------------------- Custom access rule evaluation

sub customaccess {	sub customaccess {
my ($priv,$uri)=@_;	my ($priv,$uri)=@_;
my ($urole,$urealm)=split(/\./,$env{'request.role'});	my ($urole,$urealm)=split(/\./,$env{'request.role'},2);
$urealm=~s/^\W//;
my ($udom,$ucrs,$usec)=split(/\//,$urealm);	my ($udom,$ucrs,$usec)=split(/\//,$urealm);
	$udom = &LONCAPA::clean_domain($udom);
	$ucrs = &LONCAPA::clean_username($ucrs);
my $access=0;	my $access=0;
foreach (split(/\s\,\s/,&metadata($uri,'rule_rights'))) {	foreach my $right (split(/\s\,\s/,&metadata($uri,'rule_rights'))) {
my ($effect,$realm,$role)=split(/\:/,$_);	my ($effect,$realm,$role)=split(/\:/,$right);
if ($role) {	if ($role) {
if ($role ne $urole) { next; }	if ($role ne $urole) { next; }
}	}
foreach (split(/\s\,\s/,$realm)) {	foreach my $scope (split(/\s\,\s/,$realm)) {
my ($tdom,$tcrs,$tsec)=split(/\_/,$_);	my ($tdom,$tcrs,$tsec)=split(/\_/,$scope);
if ($tdom) {	if ($tdom) {
if ($tdom ne $udom) { next; }	if ($tdom ne $udom) { next; }
}	}
Line 2894 sub customaccess {	Line 3555 sub customaccess {

sub allowed {	sub allowed {
my ($priv,$uri,$symb)=@_;	my ($priv,$uri,$symb)=@_;
	my $ver_orguri=$uri;
$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 !~ m{/(?:smppg\|bulletinboard)$}))
\|\| ($uri=~/\.meta$/)) && ($priv eq 'bre')) {	\|\| (($uri=~/\.meta$/) && ($uri!~m\|^uploaded/\|) ))
	&& ($priv eq 'bre')) {
return 'F';	return 'F';
}	}

# Free bre access to user's own portfolio contents	# Free bre access to user's own portfolio contents
my ($space,$domain,$name,$dir)=split('/',$uri);	my ($space,$domain,$name,@dir)=split('/',$uri);
if (($space=~/^(uploaded\|editupload)$/) && ($env{'user.name'} eq $name) &&	if (($space=~/^(uploaded\|editupload)$/) && ($env{'user.name'} eq $name) &&
($env{'user.domain'} eq $domain) && ('portfolio' eq $dir)) {	($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) {
return 'F';	return 'F';
}	}

	# bre access to group portfolio for rgf priv in group, or mdg or vcg in course.
	if (($space=~/^(uploaded\|editupload)$/) && ($dir[0] eq 'groups')
	&& ($dir[2] eq 'portfolio') && ($priv eq 'bre')) {
	if (exists($env{'request.course.id'})) {
	my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
	my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
	if (($domain eq $cdom) && ($name eq $cnum)) {
	my $courseprivid=$env{'request.course.id'};
	$courseprivid=~s/\_/\//;
	if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid
	.'/'.$dir[1]} =~/rgf\&([^\:]*)/) {
	return $1;
	} else {
	if ($env{'request.course.sec'}) {
	$courseprivid.='/'.$env{'request.course.sec'};
	}
	if ($env{'user.priv.'.$env{'request.role'}.'./'.
	$courseprivid} =~/(mdg\|vcg)\&([^\:]*)/) {
	return $2;
	}
	}
	}
	}
	}

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

if ($priv eq 'bre') {	if ($priv eq 'bre') {
Line 2946 sub allowed {	Line 3632 sub allowed {
if (($priv eq 'ccc') && ($env{'request.role'} =~ /^dc\./)) {	if (($priv eq 'ccc') && ($env{'request.role'} =~ /^dc\./)) {
# uri is the requested domain in this case.	# uri is the requested domain in this case.
# comparison to 'request.role.domain' shows if the user has selected	# comparison to 'request.role.domain' shows if the user has selected
# a role of dc for the domain in question.	# a role of dc for the domain in question.
return 'F' if ($uri eq $env{'request.role.domain'});	return 'F' if ($uri eq $env{'request.role.domain'});
}	}

Line 2977 sub allowed {	Line 3663 sub allowed {
$thisallowed.=$1;	$thisallowed.=$1;
}	}

# URI is an uploaded document for this course	# URI is an uploaded document for this course, default permissions don't matter
# not allowing 'edit' access (editupload) to uploaded course docs	# not allowing 'edit' access (editupload) to uploaded course docs
if (($priv eq 'bre') && ($uri=~m\|^uploaded/\|)) {	if (($priv eq 'bre') && ($uri=~m\|^uploaded/\|)) {
my $refuri=$env{'httpref.'.$orguri};	$thisallowed='';
if ($refuri) {	my ($match)=&is_on_map($uri);
if ($refuri =~ m\|^/adm/\|) {	if ($match) {
$thisallowed='F';	if ($env{'user.priv.'.$env{'request.role'}.'./'}
}	=~/\Q$priv\E\&([^\:]*)/) {
}	$thisallowed.=$1;
	}
	} else {
	my $refuri = $env{'httpref.'.$orguri} \|\| $env{'httpref.'.$ver_orguri};
	if ($refuri) {
	if ($refuri =~ m\|^/adm/\|) {
	$thisallowed='F';
	} else {
	$refuri=&declutter($refuri);
	my ($match) = &is_on_map($refuri);
	if ($match) {
	$thisallowed='F';
	}
	}
	}
	}
}	}

	if ($priv eq 'bre'
	&& $thisallowed ne 'F'
	&& $thisallowed ne '2'
	&& &is_portfolio_url($uri)) {
	$thisallowed = &portfolio_access($uri);
	}

# 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 3035 sub allowed {	Line 3743 sub allowed {
if ($checkreferer) {	if ($checkreferer) {
my $refuri=$env{'httpref.'.$orguri};	my $refuri=$env{'httpref.'.$orguri};
unless ($refuri) {	unless ($refuri) {
foreach (keys %env) {	foreach my $key (keys(%env)) {
if ($_=~/^httpref\..\/) {	if ($key=~/^httpref\..\/) {
my $pattern=$_;	my $pattern=$key;
$pattern=~s/^httpref\.\/res\///;	$pattern=~s/^httpref\.\/res\///;
$pattern=~s/\*/\[\^\/\]\+/g;	$pattern=~s/\*/\[\^\/\]\+/g;
$pattern=~s/\//\\\//g;	$pattern=~s/\//\\\//g;
if ($orguri=~/$pattern/) {	if ($orguri=~/$pattern/) {
$refuri=$env{$_};	$refuri=$env{$key};
}	}
}	}
}	}
Line 3105 sub allowed {	Line 3813 sub allowed {
my ($cdom,$cnum,$csec)=split(/\//,$courseid);	my ($cdom,$cnum,$csec)=split(/\//,$courseid);
my $prefix='course.'.$cdom.'_'.$cnum.'.';	my $prefix='course.'.$cdom.'_'.$cnum.'.';
if ((time-$env{$prefix.'last_cache'})>$expiretime) {	if ((time-$env{$prefix.'last_cache'})>$expiretime) {
&coursedescription($courseid);	&coursedescription($courseid,{'freshen_cache' => 1});
}	}
if (($env{$prefix.'res.'.$uri.'.lock.sections'}=~/\,\Q$csec\E\,/)	if (($env{$prefix.'res.'.$uri.'.lock.sections'}=~/\,\Q$csec\E\,/)
\|\| ($env{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {	\|\| ($env{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {
Line 3138 sub allowed {	Line 3846 sub allowed {
#	#

unless ($env{'request.course.id'}) {	unless ($env{'request.course.id'}) {
return '1';	if ($thisallowed eq 'A') {
	return 'A';
	} else {
	return '1';
	}
}	}

#	#
Line 3153 sub allowed {	Line 3865 sub allowed {
my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};	my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};
if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}	if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}
=~/\Q$rolecode\E/) {	=~/\Q$rolecode\E/) {
&log($env{'user.domain'},$env{'user.name'},$env{'user.host'},	if ($priv ne 'pch') {
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.	&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
$env{'request.course.id'});	'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
	$env{'request.course.id'});
	}
return '';	return '';
}	}

if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}	if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}
=~/\Q$unamedom\E/) {	=~/\Q$unamedom\E/) {
&log($env{'user.domain'},$env{'user.name'},$env{'user.host'},	if ($priv ne 'pch') {
'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.	&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.
$env{'request.course.id'});	'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
	$env{'request.course.id'});
	}
return '';	return '';
}	}
}	}
Line 3173 sub allowed {	Line 3889 sub allowed {
if ($thisallowed=~/R/) {	if ($thisallowed=~/R/) {
my $rolecode=(split(/\./,$env{'request.role'}))[0];	my $rolecode=(split(/\./,$env{'request.role'}))[0];
if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) {	if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) {
&log($env{'user.domain'},$env{'user.name'},$env{'user.host'},	if ($priv ne 'pch') {
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);	&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
return '';	'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
	}
	return '';
}	}
}	}

Line 3195 sub allowed {	Line 3913 sub allowed {
}	}
}	}

	if ($thisallowed eq 'A') {
	return 'A';
	}
return 'F';	return 'F';
}	}

	sub split_uri_for_cond {
	my $uri=&deversion(&declutter(shift));
	my @uriparts=split(/\//,$uri);
	my $filename=pop(@uriparts);
	my $pathname=join('/',@uriparts);
	return ($pathname,$filename);
	}
# --------------------------------------------------- Is a resource on the map?	# --------------------------------------------------- Is a resource on the map?

sub is_on_map {	sub is_on_map {
my $uri=&declutter(shift);	my ($pathname,$filename) = &split_uri_for_cond(shift);
$uri=~s/\.\d+\.(\w+)$/\.$1/;
my @uriparts=split(/\//,$uri);
my $filename=$uriparts[$#uriparts];
my $pathname=$uri;
$pathname=~s\|/\Q$filename\E$\|\|;
$pathname=~s/^adm\/wrapper\///;
#Trying to find the conditional for the file	#Trying to find the conditional for the file
my $match=($env{'acc.res.'.$env{'request.course.id'}.'.'.$pathname}=~	my $match=($env{'acc.res.'.$env{'request.course.id'}.'.'.$pathname}=~
/\&\Q$filename\E\:([\d\\|]+)\&/);	/\&\Q$filename\E\:([\d\\|]+)\&/);
Line 3246 sub get_symb_from_alias {	Line 3968 sub get_symb_from_alias {
sub definerole {	sub definerole {
if (allowed('mcr','/')) {	if (allowed('mcr','/')) {
my ($rolename,$sysrole,$domrole,$courole)=@_;	my ($rolename,$sysrole,$domrole,$courole)=@_;
foreach (split(':',$sysrole)) {	foreach my $role (split(':',$sysrole)) {
my ($crole,$cqual)=split(/\&/,$_);	my ($crole,$cqual)=split(/\&/,$role);
if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; }	if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; }
if ($pr{'cr:s'}=~/\Q$crole\E\&/) {	if ($pr{'cr:s'}=~/\Q$crole\E\&/) {
if ($pr{'cr:s'}!~/\Q$crole\E\&\w*\Q$cqual\E/) {	if ($pr{'cr:s'}!~/\Q$crole\E\&\w*\Q$cqual\E/) {
Line 3255 sub definerole {	Line 3977 sub definerole {
}	}
}	}
}	}
foreach (split(':',$domrole)) {	foreach my $role (split(':',$domrole)) {
my ($crole,$cqual)=split(/\&/,$_);	my ($crole,$cqual)=split(/\&/,$role);
if ($pr{'cr:d'}!~/\Q$crole\E/) { return "refused:d:$crole"; }	if ($pr{'cr:d'}!~/\Q$crole\E/) { return "refused:d:$crole"; }
if ($pr{'cr:d'}=~/\Q$crole\E\&/) {	if ($pr{'cr:d'}=~/\Q$crole\E\&/) {
if ($pr{'cr:d'}!~/\Q$crole\W\&\w*\Q$cqual\E/) {	if ($pr{'cr:d'}!~/\Q$crole\W\&\w*\Q$cqual\E/) {
Line 3264 sub definerole {	Line 3986 sub definerole {
}	}
}	}
}	}
foreach (split(':',$courole)) {	foreach my $role (split(':',$courole)) {
my ($crole,$cqual)=split(/\&/,$_);	my ($crole,$cqual)=split(/\&/,$role);
if ($pr{'cr:c'}!~/\Q$crole\E/) { return "refused:c:$crole"; }	if ($pr{'cr:c'}!~/\Q$crole\E/) { return "refused:c:$crole"; }
if ($pr{'cr:c'}=~/\Q$crole\E\&/) {	if ($pr{'cr:c'}=~/\Q$crole\E\&/) {
if ($pr{'cr:c'}!~/\Q$crole\E\&\w*\Q$cqual\E/) {	if ($pr{'cr:c'}!~/\Q$crole\E\&\w*\Q$cqual\E/) {
Line 3312 sub log_query {	Line 4034 sub log_query {
my $uhome=&homeserver($uname,$udom);	my $uhome=&homeserver($uname,$udom);
if ($uhome eq 'no_host') { return 'error: no_host'; }	if ($uhome eq 'no_host') { return 'error: no_host'; }
my $uhost=$hostname{$uhome};	my $uhost=$hostname{$uhome};
my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys %filters));	my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys(%filters)));
my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command,	my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command,
$uhome);	$uhome);
unless ($queryid=~/^\Q$uhost\E\_/) { return 'error: '.$queryid; }	unless ($queryid=~/^\Q$uhost\E\_/) { return 'error: '.$queryid; }
Line 3333 sub fetch_enrollment_query {	Line 4055 sub fetch_enrollment_query {
}	}
my $host=$hostname{$homeserver};	my $host=$hostname{$homeserver};
my $cmd = '';	my $cmd = '';
foreach (keys %{$affiliatesref}) {	foreach my $affiliate (keys %{$affiliatesref}) {
$cmd .= $_.'='.join(",",@{$$affiliatesref{$_}}).'%%';	$cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
}	}
$cmd =~ s/%%$//;	$cmd =~ s/%%$//;
$cmd = &escape($cmd);	$cmd = &escape($cmd);
Line 3355 sub fetch_enrollment_query {	Line 4077 sub fetch_enrollment_query {
} else {	} else {
my @responses = split/:/,$reply;	my @responses = split/:/,$reply;
if ($homeserver eq $perlvar{'lonHostID'}) {	if ($homeserver eq $perlvar{'lonHostID'}) {
foreach (@responses) {	foreach my $line (@responses) {
my ($key,$value) = split/=/,$_;	my ($key,$value) = split(/=/,$line,2);
$$replyref{$key} = $value;	$$replyref{$key} = $value;
}	}
} else {	} else {
my $pathname = $perlvar{'lonDaemons'}.'/tmp';	my $pathname = $perlvar{'lonDaemons'}.'/tmp';
foreach (@responses) {	foreach my $line (@responses) {
my ($key,$value) = split/=/,$_;	my ($key,$value) = split(/=/,$line);
$$replyref{$key} = $value;	$$replyref{$key} = $value;
if ($value > 0) {	if ($value > 0) {
foreach (@{$$affiliatesref{$key}}) {	foreach my $item (@{$$affiliatesref{$key}}) {
my $filename = $dom.'_'.$key.'_'.$_.'_classlist.xml';	my $filename = $dom.'_'.$key.'_'.$item.'_classlist.xml';
my $destname = $pathname.'/'.$filename;	my $destname = $pathname.'/'.$filename;
my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver);	my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver);
if ($xml_classlist =~ /^error/) {	if ($xml_classlist =~ /^error/) {
Line 3440 sub auto_run {	Line 4162 sub auto_run {
my $response = &reply('autorun:'.$cdom,$homeserver);	my $response = &reply('autorun:'.$cdom,$homeserver);
return $response;	return $response;
}	}

sub auto_get_sections {	sub auto_get_sections {
my ($cnum,$cdom,$inst_coursecode) = @_;	my ($cnum,$cdom,$inst_coursecode) = @_;
my $homeserver = &homeserver($cnum,$cdom);	my $homeserver = &homeserver($cnum,$cdom);
Line 3451 sub auto_get_sections {	Line 4173 sub auto_get_sections {
}	}
return @secs;	return @secs;
}	}

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

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

sub auto_create_password {	sub auto_create_password {
my ($cnum,$cdom,$authparam) = @_;	my ($cnum,$cdom,$authparam) = @_;
my $homeserver = &homeserver($cnum,$cdom);	my $homeserver = &homeserver($cnum,$cdom);
Line 3480 sub auto_create_password {	Line 4202 sub auto_create_password {
return ($authparam,$create_passwd,$authchk);	return ($authparam,$create_passwd,$authchk);
}	}

	sub auto_photo_permission {
	my ($cnum,$cdom,$students) = @_;
	my $homeserver = &homeserver($cnum,$cdom);
	my ($outcome,$perm_reqd,$conditions) =
	split(/:/,&unescape(&reply('autophotopermission:'.$cdom,$homeserver)),3);
	if ($outcome =~ /^(con_lost\|unknown_cmd\|no_such_host)$/) {
	return (undef,undef);
	}
	return ($outcome,$perm_reqd,$conditions);
	}

	sub auto_checkphotos {
	my ($uname,$udom,$pid) = @_;
	my $homeserver = &homeserver($uname,$udom);
	my ($result,$resulttype);
	my $outcome = &unescape(&reply('autophotocheck:'.&escape($udom).':'.
	&escape($uname).':'.&escape($pid),
	$homeserver));
	if ($outcome =~ /^(con_lost\|unknown_cmd\|no_such_host)$/) {
	return (undef,undef);
	}
	if ($outcome) {
	($result,$resulttype) = split(/:/,$outcome);
	}
	return ($result,$resulttype);
	}

	sub auto_photochoice {
	my ($cnum,$cdom) = @_;
	my $homeserver = &homeserver($cnum,$cdom);
	my ($update,$comment) = split(/:/,&unescape(&reply('autophotochoice:'.
	&escape($cdom),
	$homeserver)));
	if ($update =~ /^(con_lost\|unknown_cmd\|no_such_host)$/) {
	return (undef,undef);
	}
	return ($update,$comment);
	}

	sub auto_photoupdate {
	my ($affiliatesref,$dom,$cnum,$photo) = @_;
	my $homeserver = &homeserver($cnum,$dom);
	my $host=$hostname{$homeserver};
	my $cmd = '';
	my $maxtries = 1;
	foreach my $affiliate (keys(%{$affiliatesref})) {
	$cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
	}
	$cmd =~ s/%%$//;
	$cmd = &escape($cmd);
	my $query = 'institutionalphotos';
	my $queryid=&reply("querysend:".$query.':'.$dom.':'.$cnum.':'.$cmd,$homeserver);
	unless ($queryid=~/^\Q$host\E\_/) {
	&logthis('institutionalphotos: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' and course: '.$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('institutionalphotos error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' course: '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
	} else {
	my @responses = split(/:/,$reply);
	my $outcome = shift(@responses);
	foreach my $item (@responses) {
	my ($key,$value) = split(/=/,$item);
	$$photo{$key} = $value;
	}
	return $outcome;
	}
	return 'error';
	}

sub auto_instcode_format {	sub auto_instcode_format {
my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_;	my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,
	$cat_order) = @_;
my $courses = '';	my $courses = '';
my $homeserver;	my @homeservers;
if ($caller eq 'global') {	if ($caller eq 'global') {
foreach my $tryserver (keys %libserv) {	foreach my $tryserver (keys(%libserv)) {
if ($hostdom{$tryserver} eq $codedom) {	if ($hostdom{$tryserver} eq $codedom) {
$homeserver = $tryserver;	if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
last;	push(@homeservers,$tryserver);
	}
}	}
}	}
if (($env{'user.name'}) && ($env{'user.domain'} eq $codedom)) {
$homeserver = &homeserver($env{'user.name'},$codedom);
}
} else {	} else {
$homeserver = &homeserver($caller,$codedom);	push(@homeservers,&homeserver($caller,$codedom));
}	}
foreach (keys %{$instcodes}) {	foreach my $code (keys(%{$instcodes})) {
$courses .= &escape($_).'='.&escape($$instcodes{$_}).'&';	$courses .= &escape($code).'='.&escape($$instcodes{$code}).'&';
}	}
chop($courses);	chop($courses);
my $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$homeserver);	my $ok_response = 0;
unless ($response =~ /(con_lost\|error\|no_such_host\|refused)/) {	my $response;
my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = split/:/,$response;	while (@homeservers > 0 && $ok_response == 0) {
%{$codes} = &str2hash($codes_str);	my $server = shift(@homeservers);
@{$codetitles} = &str2array($codetitles_str);	$response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server);
%{$cat_titles} = &str2hash($cat_titles_str);	if ($response !~ /(con_lost\|error\|no_such_host\|refused)/) {
%{$cat_order} = &str2hash($cat_order_str);	my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) =
	split/:/,$response;
	%{$codes} = (%{$codes},&str2hash($codes_str));
	push(@{$codetitles},&str2array($codetitles_str));
	%{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str));
	%{$cat_order} = (%{$cat_order},&str2hash($cat_order_str));
	$ok_response = 1;
	}
	}
	if ($ok_response) {
return 'ok';	return 'ok';
	} else {
	return $response;
	}
	}

	sub auto_instcode_defaults {
	my ($domain,$returnhash,$code_order) = @_;
	my @homeservers;
	foreach my $tryserver (keys(%libserv)) {
	if ($hostdom{$tryserver} eq $domain) {
	if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
	push(@homeservers,$tryserver);
	}
	}
}	}
	my $ok_response = 0;
	my $response;
	while (@homeservers > 0 && $ok_response == 0) {
	my $server = shift(@homeservers);
	$response=&reply('autoinstcodedefaults:'.$domain,$server);
	if ($response !~ /(con_lost\|error\|no_such_host\|refused)/) {
	foreach my $pair (split(/\&/,$response)) {
	my ($name,$value)=split(/\=/,$pair);
	if ($name eq 'code_order') {
	@{$code_order} = split(/\&/,&unescape($value));
	} else {
	$returnhash->{&unescape($name)}=&unescape($value);
	}
	}
	$ok_response = 1;
	}
	}
	if ($ok_response) {
	return 'ok';
	} else {
	return $response;
	}
	}

	sub auto_validate_class_sec {
	my ($cdom,$cnum,$owner,$inst_class) = @_;
	my $homeserver = &homeserver($cnum,$cdom);
	my $response=&reply('autovalidateclass_sec:'.$inst_class.':'.
	&escape($owner).':'.$cdom,$homeserver);
return $response;	return $response;
}	}

	# ------------------------------------------------------- Course Group routines

	sub get_coursegroups {
	my ($cdom,$cnum,$group) = @_;
	return(&dump('coursegroups',$cdom,$cnum,$group));
	}

	sub get_deleted_groups {
	my ($cdom,$cnum,$group) = @_;
	return(&dump('deleted_groups',$cdom,$cnum,$group));
	}

	sub modify_coursegroup {
	my ($cdom,$cnum,$groupsettings) = @_;
	return(&put('coursegroups',$groupsettings,$cdom,$cnum));
	}

	sub delete_coursegroup {
	my ($cdom,$cnum,$group) = @_;
	my %curr_group = &get_coursegroups($cdom,$cnum,$group);
	if (my $tmp = &error(%curr_group)) {
	&Apache::lonnet::logthis('Error retrieving group: '.$tmp.' in '.$cnum.':'.$cdom);
	return ('read error',$tmp);
	} else {
	my %savedsettings = %curr_group;
	my $result = &put('deleted_groups',\%savedsettings,$cdom,$cnum);
	my $deloutcome;
	if ($result eq 'ok') {
	$deloutcome = &del('coursegroups',[$group],$cdom,$cnum);
	} else {
	return ('write error',$result);
	}
	if ($deloutcome eq 'ok') {
	return 'ok';
	} else {
	return ('delete error',$deloutcome);
	}
	}
	}

	sub modify_group_roles {
	my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs) = @_;
	my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;
	my $role = 'gr/'.&escape($userprivs);
	my ($uname,$udom) = split(/:/,$user);
	my $result = &assignrole($udom,$uname,$url,$role,$end,$start);
	if ($result eq 'ok') {
	&devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);
	}
	return $result;
	}

	sub modify_coursegroup_membership {
	my ($cdom,$cnum,$membership) = @_;
	my $result = &put('groupmembership',$membership,$cdom,$cnum);
	return $result;
	}

	sub get_active_groups {
	my ($udom,$uname,$cdom,$cnum) = @_;
	my $now = time;
	my %groups = ();
	foreach my $key (keys(%env)) {
	if ($key =~ m-user\.role\.gr\./($match_domain)/($match_username)/(\w+)$-) {
	my ($start,$end) = split(/\./,$env{$key});
	if (($end!=0) && ($end<$now)) { next; }
	if (($start!=0) && ($start>$now)) { next; }
	if ($1 eq $cdom && $2 eq $cnum) {
	$groups{$3} = $env{$key} ;
	}
	}
	}
	return %groups;
	}

	sub get_group_membership {
	my ($cdom,$cnum,$group) = @_;
	return(&dump('groupmembership',$cdom,$cnum,$group));
	}

	sub get_users_groups {
	my ($udom,$uname,$courseid) = @_;
	my @usersgroups;
	my $cachetime=1800;

	my $hashid="$udom:$uname:$courseid";
	my ($grouplist,$cached)=&is_cached_new('getgroups',$hashid);
	if (defined($cached)) {
	@usersgroups = split(/:/,$grouplist);
	} else {
	$grouplist = '';
	my %roleshash = &dump('roles',$udom,$uname,$courseid);
	my ($tmp) = keys(%roleshash);
	if ($tmp=~/^error:/) {
	&logthis('Error retrieving roles: '.$tmp.' for '.$uname.':'.$udom);
	} else {
	my $access_end = $env{'course.'.$courseid.
	'.default_enrollment_end_date'};
	my $now = time;
	foreach my $key (keys(%roleshash)) {
	if ($key =~ /^\Q$courseid\E\/(\w+)\_gr$/) {
	my $group = $1;
	if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) {
	my $start = $2;
	my $end = $1;
	if ($start == -1) { next; } # deleted from group
	if (($start!=0) && ($start>$now)) { next; }
	if (($end!=0) && ($end<$now)) {
	if ($access_end && $access_end < $now) {
	if ($access_end - $end < 86400) {
	push(@usersgroups,$group);
	}
	}
	next;
	}
	push(@usersgroups,$group);
	}
	}
	}
	@usersgroups = &sort_course_groups($courseid,@usersgroups);
	$grouplist = join(':',@usersgroups);
	&do_cache_new('getgroups',$hashid,$grouplist,$cachetime);
	}
	}
	return @usersgroups;
	}

	sub devalidate_getgroups_cache {
	my ($udom,$uname,$cdom,$cnum)=@_;
	my $courseid = $cdom.'_'.$cnum;

	my $hashid="$udom:$uname:$courseid";
	&devalidate_cache_new('getgroups',$hashid);
	}

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

sub plaintext {	sub plaintext {
my $short=shift;	my ($short,$type,$cid) = @_;
return &mt($prp{$short});	if ($short =~ /^cr/) {
	return (split('/',$short))[-1];
	}
	if (!defined($cid)) {
	$cid = $env{'request.course.id'};
	}
	if (defined($cid) && defined($env{'course.'.$cid.'.'.$short.'.plaintext'})) {
	return &Apache::lonlocal::mt($env{'course.'.$cid.'.'.$short.
	'.plaintext'});
	}
	my %rolenames = (
	Course => 'std',
	Group => 'alt1',
	);
	if (defined($type) &&
	defined($rolenames{$type}) &&
	defined($prp{$short}{$rolenames{$type}})) {
	return &Apache::lonlocal::mt($prp{$short}{$rolenames{$type}});
	} else {
	return &Apache::lonlocal::mt($prp{$short}{'std'});
	}
}	}

# ----------------------------------------------------------------- Assign Role	# ----------------------------------------------------------------- Assign Role
Line 3527 sub assignrole {	Line 4531 sub assignrole {
my $mrole;	my $mrole;
if ($role =~ /^cr\//) {	if ($role =~ /^cr\//) {
my $cwosec=$url;	my $cwosec=$url;
$cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;	$cwosec=~s/^\/($match_domain)\/($match_username)\/.*/$1\/$2/;
unless (&allowed('ccr',$cwosec)) {	unless (&allowed('ccr',$cwosec)) {
&logthis('Refused custom assignrole: '.	&logthis('Refused custom assignrole: '.
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.	$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
Line 3535 sub assignrole {	Line 4539 sub assignrole {
return 'refused';	return 'refused';
}	}
$mrole='cr';	$mrole='cr';
	} elsif ($role =~ /^gr\//) {
	my $cwogrp=$url;
	$cwogrp=~s{^/($match_domain)/($match_username)/.*}
	{$1/$2}x;
	unless (&allowed('mdg',$cwogrp)) {
	&logthis('Refused group assignrole: '.
	$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
	$env{'user.name'}.' at '.$env{'user.domain'});
	return 'refused';
	}
	$mrole='gr';
} else {	} else {
my $cwosec=$url;	my $cwosec=$url;
$cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;	$cwosec=~s/^\/($match_domain)\/($match_username)\/.*/$1\/$2/;
unless ((&allowed('c'.$role,$cwosec)) \|\| &allowed('c'.$role,$udom)) {	unless ((&allowed('c'.$role,$cwosec)) \|\| &allowed('c'.$role,$udom)) {
&logthis('Refused assignrole: '.	&logthis('Refused assignrole: '.
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.	$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
Line 3556 sub assignrole {	Line 4571 sub assignrole {
$command.='_0_'.$start;	$command.='_0_'.$start;
}	}
}	}
	my $origstart = $start;
	my $origend = $end;
# actually delete	# actually delete
if ($deleteflag) {	if ($deleteflag) {
if ((&allowed('dro',$udom)) \|\| (&allowed('dro',$url))) {	if ((&allowed('dro',$udom)) \|\| (&allowed('dro',$url))) {
Line 3572 sub assignrole {	Line 4589 sub assignrole {
my $answer=&reply($command,&homeserver($uname,$udom));	my $answer=&reply($command,&homeserver($uname,$udom));
# log new user role if status is ok	# log new user role if status is ok
if ($answer eq 'ok') {	if ($answer eq 'ok') {
&userrolelog($mrole,$uname,$udom,$url,$start,$end);	&userrolelog($role,$uname,$udom,$url,$start,$end);
	# for course roles, perform group memberships changes triggered by role change.
	unless ($role =~ /^gr/) {
	&Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,
	$origstart);
	}
}	}
return $answer;	return $answer;
}	}
Line 3610 sub modifyuser {	Line 4632 sub modifyuser {
$umode, $upass, $first,	$umode, $upass, $first,
$middle, $last, $gene,	$middle, $last, $gene,
$forceid, $desiredhome, $email)=@_;	$forceid, $desiredhome, $email)=@_;
$udom=~s/\W//g;	$udom= &LONCAPA::clean_domain($udom);
$uname=~s/\W//g;	$uname=&LONCAPA::clean_username($uname);
&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.	&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
$umode.', '.$first.', '.$middle.', '.	$umode.', '.$first.', '.$middle.', '.
$last.', '.$gene.'(forceid: '.$forceid.')'.	$last.', '.$gene.'(forceid: '.$forceid.')'.
Line 3695 sub modifyuser {	Line 4717 sub modifyuser {
}	}
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; }
	&devalidate_cache_new('namescache',$uname.':'.$udom);
&logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.	&logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
$umode.', '.$first.', '.$middle.', '.	$umode.', '.$first.', '.$middle.', '.
$last.', '.$gene.' by '.	$last.', '.$gene.' by '.
Line 3759 sub modify_student_enrollment {	Line 4782 sub modify_student_enrollment {
['firstname','middlename','lastname', 'generation','id']	['firstname','middlename','lastname', 'generation','id']
,$udom,$uname);	,$udom,$uname);

#foreach (keys(%tmp)) {	#foreach my $key (keys(%tmp)) {
# &logthis("key $_ = ".$tmp{$_});	# &logthis("key $key = ".$tmp{$key});
#}	#}
$first = $tmp{'firstname'} if (!defined($first) \|\| $first eq '');	$first = $tmp{'firstname'} if (!defined($first) \|\| $first eq '');
$middle = $tmp{'middlename'} if (!defined($middle) \|\| $middle eq '');	$middle = $tmp{'middlename'} if (!defined($middle) \|\| $middle eq '');
Line 3775 sub modify_student_enrollment {	Line 4798 sub modify_student_enrollment {
$cdom,$cnum);	$cdom,$cnum);
unless (($reply eq 'ok') \|\| ($reply eq 'delayed')) {	unless (($reply eq 'ok') \|\| ($reply eq 'delayed')) {
return 'error: '.$reply;	return 'error: '.$reply;
	} else {
	&devalidate_getsection_cache($udom,$uname,$cid);
}	}
# Add student role to user	# Add student role to user
my $uurl='/'.$cid;	my $uurl='/'.$cid;
Line 3816 sub writecoursepref {	Line 4841 sub writecoursepref {
return 'error: no such course';	return 'error: no such course';
}	}
my $cstring='';	my $cstring='';
foreach (keys %prefs) {	foreach my $pref (keys(%prefs)) {
$cstring.=escape($_).'='.escape($prefs{$_}).'&';	$cstring.=&escape($pref).'='.&escape($prefs{$pref}).'&';
}	}
$cstring=~s/\&$//;	$cstring=~s/\&$//;
return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome);	return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome);
Line 3826 sub writecoursepref {	Line 4851 sub writecoursepref {
# ---------------------------------------------------------- Make/modify course	# ---------------------------------------------------------- Make/modify course

sub createcourse {	sub createcourse {
my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,$course_owner)=@_;	my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,
	$course_owner,$crstype)=@_;
$url=&declutter($url);	$url=&declutter($url);
my $cid='';	my $cid='';
unless (&allowed('ccc',$udom)) {	unless (&allowed('ccc',$udom)) {
return 'refused';	return 'refused';
}	}
# ------------------------------------------------------------------- Create ID	# ------------------------------------------------------------------- Create ID
my $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).	my $uname=int(1+rand(9)).
	('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
	substr($$.time,0,5).unpack("H8",pack("I32",time)).
unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};	unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
# ----------------------------------------------- Make sure that does not exist	# ----------------------------------------------- Make sure that does not exist
my $uhome=&homeserver($uname,$udom,'true');	my $uhome=&homeserver($uname,$udom,'true');
Line 3861 sub createcourse {	Line 4889 sub createcourse {
# ----------------------------------------------------------------- Course made	# ----------------------------------------------------------------- Course made
# log existence	# log existence
&courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description).	&courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description).
':'.&escape($inst_code).':'.&escape($course_owner),$uhome);	':'.&escape($inst_code).':'.&escape($course_owner).':'.
	&escape($crstype),$uhome);
&flushcourselogs();	&flushcourselogs();
# set toplevel url	# set toplevel url
my $topurl=$url;	my $topurl=$url;
Line 3931 sub is_locked {	Line 4960 sub is_locked {
$env{'user.domain'},$env{'user.name'});	$env{'user.domain'},$env{'user.name'});
my ($tmp)=keys(%locked);	my ($tmp)=keys(%locked);
if ($tmp=~/^error:/) { undef(%locked); }	if ($tmp=~/^error:/) { undef(%locked); }

if (ref($locked{$file_name}) eq 'ARRAY') {	if (ref($locked{$file_name}) eq 'ARRAY') {
$is_locked = 'true';	$is_locked = 'false';
	foreach my $entry (@{$locked{$file_name}}) {
	if (ref($entry) eq 'ARRAY') {
	$is_locked = 'true';
	last;
	}
	}
} else {	} else {
$is_locked = 'false';	$is_locked = 'false';
}	}
}	}

	sub declutter_portfile {
	my ($file) = @_;
	&logthis("got $file");
	$file =~ s-^(/portfolio/\|portfolio/)-/-;
	&logthis("ret $file");
	return $file;
	}

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

sub mark_as_readonly {	sub mark_as_readonly {
Line 3947 sub mark_as_readonly {	Line 4990 sub mark_as_readonly {
my ($tmp)=keys(%current_permissions);	my ($tmp)=keys(%current_permissions);
if ($tmp=~/^error:/) { undef(%current_permissions); }	if ($tmp=~/^error:/) { undef(%current_permissions); }
foreach my $file (@{$files}) {	foreach my $file (@{$files}) {
	$file = &declutter_portfile($file);
push(@{$current_permissions{$file}},$what);	push(@{$current_permissions{$file}},$what);
}	}
&put('file_permissions',\%current_permissions,$domain,$user);	&put('file_permissions',\%current_permissions,$domain,$user);
Line 4005 sub files_not_in_path {	Line 5049 sub files_not_in_path {
my $filename = $user."savedfiles";	my $filename = $user."savedfiles";
my @return_files;	my @return_files;
my $path_part;	my $path_part;
open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);	open(IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
while (<IN>) {	while (my $line = <IN>) {
#ok, I know it's clunky, but I want it to work	#ok, I know it's clunky, but I want it to work
my @paths_and_file = split m!/!, $_;	my @paths_and_file = split(m\|/\|, $line);
my $file_part = pop (@paths_and_file);	my $file_part = pop(@paths_and_file);
chomp ($file_part);	chomp($file_part);
my $path_part = join ('/', @paths_and_file);	my $path_part = join('/', @paths_and_file);
$path_part .= '/';	$path_part .= '/';
my $path_and_file = $path_part.$file_part;	my $path_and_file = $path_part.$file_part;
if ($path_part ne $path) {	if ($path_part ne $path) {
push (@return_files, ($path_and_file));	push(@return_files, ($path_and_file));
}	}
}	}
close (OUT);	close(OUT);
return (@return_files);	return (@return_files);
}	}

#--------------------------------------------------------------Get Marked as Read Only	#----------------------------------------------Get portfolio file permissions

	sub get_portfile_permissions {
sub get_marked_as_readonly {	my ($domain,$user) = @_;
my ($domain,$user,$what) = @_;
my %current_permissions = &dump('file_permissions',$domain,$user);	my %current_permissions = &dump('file_permissions',$domain,$user);
my ($tmp)=keys(%current_permissions);	my ($tmp)=keys(%current_permissions);
if ($tmp=~/^error:/) { undef(%current_permissions); }	if ($tmp=~/^error:/) { undef(%current_permissions); }
	return \%current_permissions;
	}

	#---------------------------------------------Get portfolio file access controls

	sub get_access_controls {
	my ($current_permissions,$group,$file) = @_;
	my %access;
	my $real_file = $file;
	$file =~ s/\.meta$//;
	if (defined($file)) {
	if (ref($$current_permissions{$file."\0".'accesscontrol'}) eq 'HASH') {
	foreach my $control (keys(%{$$current_permissions{$file."\0".'accesscontrol'}})) {
	$access{$real_file}{$control} = $$current_permissions{$file."\0".$control};
	}
	}
	} else {
	foreach my $key (keys(%{$current_permissions})) {
	if ($key =~ /\0accesscontrol$/) {
	if (defined($group)) {
	if ($key !~ m-^\Q$group\E/-) {
	next;
	}
	}
	my ($fullpath) = split(/\0/,$key);
	if (ref($$current_permissions{$key}) eq 'HASH') {
	foreach my $control (keys(%{$$current_permissions{$key}})) {
	$access{$fullpath}{$control}=$$current_permissions{$fullpath."\0".$control};
	}
	}
	}
	}
	}
	return %access;
	}

	sub modify_access_controls {
	my ($file_name,$changes,$domain,$user)=@_;
	my ($outcome,$deloutcome);
	my %store_permissions;
	my %new_values;
	my %new_control;
	my %translation;
	my @deletions = ();
	my $now = time;
	if (exists($$changes{'activate'})) {
	if (ref($$changes{'activate'}) eq 'HASH') {
	my @newitems = sort(keys(%{$$changes{'activate'}}));
	my $numnew = scalar(@newitems);
	for (my $i=0; $i<$numnew; $i++) {
	my $newkey = $newitems[$i];
	my $newid = &Apache::loncommon::get_cgi_id();
	if ($newkey =~ /^\d+:/) {
	$newkey =~ s/^(\d+)/$newid/;
	$translation{$1} = $newid;
	} elsif ($newkey =~ /^\d+_\d+_\d+:/) {
	$newkey =~ s/^(\d+_\d+_\d+)/$newid/;
	$translation{$1} = $newid;
	}
	$new_values{$file_name."\0".$newkey} =
	$$changes{'activate'}{$newitems[$i]};
	$new_control{$newkey} = $now;
	}
	}
	}
	my %todelete;
	my %changed_items;
	foreach my $action ('delete','update') {
	if (exists($$changes{$action})) {
	if (ref($$changes{$action}) eq 'HASH') {
	foreach my $key (keys(%{$$changes{$action}})) {
	my ($itemnum) = ($key =~ /^([^:]+):/);
	if ($action eq 'delete') {
	$todelete{$itemnum} = 1;
	} else {
	$changed_items{$itemnum} = $key;
	}
	}
	}
	}
	}
	# get lock on access controls for file.
	my $lockhash = {
	$file_name."\0".'locked_access_records' => $env{'user.name'}.
	':'.$env{'user.domain'},
	};
	my $tries = 0;
	my $gotlock = &newput('file_permissions',$lockhash,$domain,$user);

	while (($gotlock ne 'ok') && $tries <3) {
	$tries ++;
	sleep 1;
	$gotlock = &newput('file_permissions',$lockhash,$domain,$user);
	}
	if ($gotlock eq 'ok') {
	my %curr_permissions = &dump('file_permissions',$domain,$user,$file_name);
	my ($tmp)=keys(%curr_permissions);
	if ($tmp=~/^error:/) { undef(%curr_permissions); }
	if (exists($curr_permissions{$file_name."\0".'accesscontrol'})) {
	my $curr_controls = $curr_permissions{$file_name."\0".'accesscontrol'};
	if (ref($curr_controls) eq 'HASH') {
	foreach my $control_item (keys(%{$curr_controls})) {
	my ($itemnum) = ($control_item =~ /^([^:]+):/);
	if (defined($todelete{$itemnum})) {
	push(@deletions,$file_name."\0".$control_item);
	} else {
	if (defined($changed_items{$itemnum})) {
	$new_control{$changed_items{$itemnum}} = $now;
	push(@deletions,$file_name."\0".$control_item);
	$new_values{$file_name."\0".$changed_items{$itemnum}} = $$changes{'update'}{$changed_items{$itemnum}};
	} else {
	$new_control{$control_item} = $$curr_controls{$control_item};
	}
	}
	}
	}
	}
	$deloutcome = &del('file_permissions',\@deletions,$domain,$user);
	$new_values{$file_name."\0".'accesscontrol'} = \%new_control;
	$outcome = &put('file_permissions',\%new_values,$domain,$user);
	# remove lock
	my @del_lock = ($file_name."\0".'locked_access_records');
	my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user);
	} else {
	$outcome = "error: could not obtain lockfile\n";
	}
	return ($outcome,$deloutcome,\%new_values,\%translation);
	}

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

	sub get_marked_as_readonly {
	my ($domain,$user,$what,$group) = @_;
	my $current_permissions = &get_portfile_permissions($domain,$user);
my @readonly_files;	my @readonly_files;
my $cmp1=$what;	my $cmp1=$what;
if (ref($what)) { $cmp1=join('',@{$what}) };	if (ref($what)) { $cmp1=join('',@{$what}) };
while (my ($file_name,$value) = each(%current_permissions)) {	while (my ($file_name,$value) = each(%{$current_permissions})) {
	if (defined($group)) {
	if ($file_name !~ m-^\Q$group\E/-) {
	next;
	}
	}
if (ref($value) eq "ARRAY"){	if (ref($value) eq "ARRAY"){
foreach my $stored_what (@{$value}) {	foreach my $stored_what (@{$value}) {
my $cmp2=$stored_what;	my $cmp2=$stored_what;
if (ref($stored_what)) { $cmp2=join('',@{$stored_what}) };	if (ref($stored_what) eq 'ARRAY') {
	$cmp2=join('',@{$stored_what});
	}
if ($cmp1 eq $cmp2) {	if ($cmp1 eq $cmp2) {
push(@readonly_files, $file_name);	push(@readonly_files, $file_name);
	last;
} elsif (!defined($what)) {	} elsif (!defined($what)) {
push(@readonly_files, $file_name);	push(@readonly_files, $file_name);
	last;
}	}
}	}
}	}
}	}
return @readonly_files;	return @readonly_files;
}	}
#-----------------------------------------------------------Get Marked as Read Only Hash	#-----------------------------------------------------------Get Marked as Read Only Hash

sub get_marked_as_readonly_hash {	sub get_marked_as_readonly_hash {
my ($domain,$user,$what) = @_;	my ($current_permissions,$group,$what) = @_;
my %current_permissions = &dump('file_permissions',$domain,$user);
my ($tmp)=keys(%current_permissions);
if ($tmp=~/^error:/) { undef(%current_permissions); }

my %readonly_files;	my %readonly_files;
while (my ($file_name,$value) = each(%current_permissions)) {	while (my ($file_name,$value) = each(%{$current_permissions})) {
	if (defined($group)) {
	if ($file_name !~ m-^\Q$group\E/-) {
	next;
	}
	}
if (ref($value) eq "ARRAY"){	if (ref($value) eq "ARRAY"){
foreach my $stored_what (@{$value}) {	foreach my $stored_what (@{$value}) {
if ($stored_what eq $what) {	if (ref($stored_what) eq 'ARRAY') {
$readonly_files{$file_name} = 'locked';	foreach my $lock_descriptor(@{$stored_what}) {
} elsif (!defined($what)) {	if ($lock_descriptor eq 'graded') {
$readonly_files{$file_name} = 'locked';	$readonly_files{$file_name} = 'graded';
}	} elsif ($lock_descriptor eq 'handback') {
	$readonly_files{$file_name} = 'handback';
	} else {
	if (!exists($readonly_files{$file_name})) {
	$readonly_files{$file_name} = 'locked';
	}
	}
	}
	}
}	}
}	}
}	}
Line 4075 sub get_marked_as_readonly_hash {	Line 5270 sub get_marked_as_readonly_hash {
sub unmark_as_readonly {	sub unmark_as_readonly {
# unmarks $file_name (if $file_name is defined), or all files locked by $what	# unmarks $file_name (if $file_name is defined), or all files locked by $what
# for portfolio submissions, $what contains [$symb,$crsid]	# for portfolio submissions, $what contains [$symb,$crsid]
my ($domain,$user,$what,$file_name) = @_;	my ($domain,$user,$what,$file_name,$group) = @_;
	$file_name = &declutter_portfile($file_name);
my $symb_crs = $what;	my $symb_crs = $what;
if (ref($what)) { $symb_crs=join('',@$what); }	if (ref($what)) { $symb_crs=join('',@$what); }
my %current_permissions = &dump('file_permissions',$domain,$user);	my %current_permissions = &dump('file_permissions',$domain,$user,$group);
my ($tmp)=keys(%current_permissions);	my ($tmp)=keys(%current_permissions);
if ($tmp=~/^error:/) { undef(%current_permissions); }	if ($tmp=~/^error:/) { undef(%current_permissions); }
my @readonly_files = &get_marked_as_readonly($domain,$user,$what);	my @readonly_files = &get_marked_as_readonly($domain,$user,$what,$group);
foreach my $file (@readonly_files) {	foreach my $file (@readonly_files) {
if (defined($file_name) && ($file_name ne $file)) { next; }	my $clean_file = &declutter_portfile($file);
	if (defined($file_name) && ($file_name ne $clean_file)) { next; }
my $current_locks = $current_permissions{$file};	my $current_locks = $current_permissions{$file};
my @new_locks;	my @new_locks;
my @del_keys;	my @del_keys;
if (ref($current_locks) eq "ARRAY"){	if (ref($current_locks) eq "ARRAY"){
foreach my $locker (@{$current_locks}) {	foreach my $locker (@{$current_locks}) {
my $compare=$locker;	my $compare=$locker;
if (ref($locker)) { $compare=join('',@{$locker}) };	if (ref($locker) eq 'ARRAY') {
if ($compare ne $symb_crs) {	$compare=join('',@{$locker});
push(@new_locks, $locker);	if ($compare ne $symb_crs) {
	push(@new_locks, $locker);
	}
}	}
}	}
if (scalar(@new_locks) > 0) {	if (scalar(@new_locks) > 0) {
Line 4132 sub dirlist {	Line 5331 sub dirlist {

if($udom) {	if($udom) {
if($uname) {	if($uname) {
my $listing=reply('ls2:'.$dirRoot.'/'.$uri,	my $listing = &reply('ls2:'.$dirRoot.'/'.$uri,
homeserver($uname,$udom));	&homeserver($uname,$udom));
my @listing_results;	my @listing_results;
if ($listing eq 'unknown_cmd') {	if ($listing eq 'unknown_cmd') {
$listing=reply('ls:'.$dirRoot.'/'.$uri,	$listing = &reply('ls:'.$dirRoot.'/'.$uri,
homeserver($uname,$udom));	&homeserver($uname,$udom));
@listing_results = split(/:/,$listing);	@listing_results = split(/:/,$listing);
} else {	} else {
@listing_results = map { &unescape($_); } split(/:/,$listing);	@listing_results = map { &unescape($_); } split(/:/,$listing);
}	}
return @listing_results;	return @listing_results;
} elsif(!defined($alternateDirectoryRoot)) {	} elsif(!defined($alternateDirectoryRoot)) {
my $tryserver;	my %allusers;
my %allusers=();	foreach my $tryserver (keys(%libserv)) {
foreach $tryserver (keys %libserv) {
if($hostdom{$tryserver} eq $udom) {	if($hostdom{$tryserver} eq $udom) {
my $listing=reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.	my $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.
$udom, $tryserver);	$udom, $tryserver);
my @listing_results;	my @listing_results;
if ($listing eq 'unknown_cmd') {	if ($listing eq 'unknown_cmd') {
$listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.	$listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.
$udom, $tryserver);	$udom, $tryserver);
@listing_results = split(/:/,$listing);	@listing_results = split(/:/,$listing);
} else {	} else {
@listing_results =	@listing_results =
Line 4162 sub dirlist {	Line 5360 sub dirlist {
if ($listing_results[0] ne 'no_such_dir' &&	if ($listing_results[0] ne 'no_such_dir' &&
$listing_results[0] ne 'empty' &&	$listing_results[0] ne 'empty' &&
$listing_results[0] ne 'con_lost') {	$listing_results[0] ne 'con_lost') {
foreach (@listing_results) {	foreach my $line (@listing_results) {
my ($entry,@stat)=split(/&/,$_);	my ($entry) = split(/&/,$line,2);
$allusers{$entry}=1;	$allusers{$entry} = 1;
}	}
}	}
}	}
}	}
my $alluserstr='';	my $alluserstr='';
foreach (sort keys %allusers) {	foreach my $user (sort(keys(%allusers))) {
$alluserstr.=$_.'&user:';	$alluserstr.=$user.'&user:';
}	}
$alluserstr=~s/:$//;	$alluserstr=~s/:$//;
return split(/:/,$alluserstr);	return split(/:/,$alluserstr);
} else {	} else {
my @emptyResults = ();	return ('missing user name');
push(@emptyResults, 'missing user name');
return split(':',@emptyResults);
}	}
} elsif(!defined($alternateDirectoryRoot)) {	} elsif(!defined($alternateDirectoryRoot)) {
my $tryserver;	my $tryserver;
my %alldom=();	my %alldom=();
foreach $tryserver (keys %libserv) {	foreach $tryserver (keys(%libserv)) {
$alldom{$hostdom{$tryserver}}=1;	$alldom{$hostdom{$tryserver}}=1;
}	}
my $alldomstr='';	my $alldomstr='';
foreach (sort keys %alldom) {	foreach my $domain (sort(keys(%alldom))) {
$alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'/&domain:';	$alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain:';
}	}
$alldomstr=~s/:$//;	$alldomstr=~s/:$//;
return split(/:/,$alldomstr);	return split(/:/,$alldomstr);
} else {	} else {
my @emptyResults = ();	return ('missing domain');
push(@emptyResults, 'missing domain');
return split(':',@emptyResults);
}	}
}	}

Line 4213 sub dirlist {	Line 5407 sub dirlist {
##	##
sub GetFileTimestamp {	sub GetFileTimestamp {
my ($studentDomain,$studentName,$filename,$root)=@_;	my ($studentDomain,$studentName,$filename,$root)=@_;
$studentDomain=~s/\W//g;	$studentDomain = &LONCAPA::clean_domain($studentDomain);
$studentName=~s/\W//g;	$studentName = &LONCAPA::clean_username($studentName);
my $subdir=$studentName.'__';	my $subdir=$studentName.'__';
$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;	$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
my $proname="$studentDomain/$subdir/$studentName";	my $proname="$studentDomain/$subdir/$studentName";
Line 4230 sub GetFileTimestamp {	Line 5424 sub GetFileTimestamp {
}	}
}	}

	sub stat_file {
	my ($uri) = @_;
	$uri = &clutter_with_no_wrapper($uri);

	my ($udom,$uname,$file,$dir);
	if ($uri =~ m-^/(uploaded\|editupload)/-) {
	($udom,$uname,$file) =
	($uri =~ m-/(?:uploaded\|editupload)/?($match_domain)/?($match_username)/?(.*)-);
	$file = 'userfiles/'.$file;
	$dir = &propath($udom,$uname);
	}
	if ($uri =~ m-^/res/-) {
	($udom,$uname) =
	($uri =~ m-/(?:res)/?($match_domain)/?($match_username)/-);
	$file = $uri;
	}

	if (!$udom \|\| !$uname \|\| !$file) {
	# unable to handle the uri
	return ();
	}

	my ($result) = &dirlist($file,$udom,$uname,$dir);
	my @stats = split('&', $result);

	if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
	shift(@stats); #filename is first
	return @stats;
	}
	return ();
	}

# -------------------------------------------------------- Value of a Condition	# -------------------------------------------------------- Value of a Condition

	# gets the value of a specific preevaluated condition
	# stored in the string $env{user.state.<cid>}
	# or looks up a condition reference in the bighash and if if hasn't
	# already been evaluated recurses into docondval to get the value of
	# the condition, then memoizing it to
	# $env{user.state.<cid>.<condition>}
sub directcondval {	sub directcondval {
my $number=shift;	my $number=shift;
if (!defined($env{'user.state.'.$env{'request.course.id'}})) {	if (!defined($env{'user.state.'.$env{'request.course.id'}})) {
&Apache::lonuserstate::evalstate();	&Apache::lonuserstate::evalstate();
}	}
	if (exists($env{'user.state.'.$env{'request.course.id'}.".$number"})) {
	return $env{'user.state.'.$env{'request.course.id'}.".$number"};
	} elsif ($number =~ /^_/) {
	my $sub_condition;
	if (tie(my %bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
	&GDBM_READER(),0640)) {
	$sub_condition=$bighash{'conditions'.$number};
	untie(%bighash);
	}
	my $value = &docondval($sub_condition);
	&appenv('user.state.'.$env{'request.course.id'}.".$number" => $value);
	return $value;
	}
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 4244 sub directcondval {	Line 5489 sub directcondval {
}	}
}	}

	# get the collection of conditions for this resource
sub condval {	sub condval {
my $condidx=shift;	my $condidx=shift;
my $result=0;
my $allpathcond='';	my $allpathcond='';
foreach (split(/\\|/,$condidx)) {	foreach my $cond (split(/\\|/,$condidx)) {
if (defined($env{'acc.cond.'.$env{'request.course.id'}.'.'.$_})) {	if (defined($env{'acc.cond.'.$env{'request.course.id'}.'.'.$cond})) {
$allpathcond.=	$allpathcond.=
'('.$env{'acc.cond.'.$env{'request.course.id'}.'.'.$_}.')\|';	'('.$env{'acc.cond.'.$env{'request.course.id'}.'.'.$cond}.')\|';
}	}
}	}
$allpathcond=~s/\\|$//;	$allpathcond=~s/\\|$//;
if ($env{'request.course.id'}) {	return &docondval($allpathcond);
if ($allpathcond) {	}
my $operand='\|';
my @stack;	#evaluates an expression of conditions
foreach ($allpathcond=~/(\d+\|$\|$\|\&\|\\|)/g) {	sub docondval {
if ($_ eq '(') {	my ($allpathcond) = @_;
push @stack,($operand,$result)	my $result=0;
} elsif ($_ eq ')') {	if ($env{'request.course.id'}
my $before=pop @stack;	&& defined($allpathcond)) {
if (pop @stack eq '&') {	my $operand='\|';
$result=$result>$before?$before:$result;	my @stack;
} else {	foreach my $chunk ($allpathcond=~/(\d+\|_\d+\.\d+\|$\|$\|\&\|\\|)/g) {
$result=$result>$before?$result:$before;	if ($chunk eq '(') {
}	push @stack,($operand,$result);
} elsif (($_ eq '&') \|\| ($_ eq '\|')) {	} elsif ($chunk eq ')') {
$operand=$_;	my $before=pop @stack;
} else {	if (pop @stack eq '&') {
my $new=directcondval($_);	$result=$result>$before?$before:$result;
if ($operand eq '&') {	} else {
$result=$result>$new?$new:$result;	$result=$result>$before?$result:$before;
} else {	}
$result=$result>$new?$result:$new;	} elsif (($chunk eq '&') \|\| ($chunk eq '\|')) {
}	$operand=$chunk;
}	} else {
}	my $new=directcondval($chunk);
}	if ($operand eq '&') {
	$result=$result>$new?$new:$result;
	} else {
	$result=$result>$new?$result:$new;
	}
	}
	}
}	}
return $result;	return $result;
}	}
Line 4293 sub devalidatecourseresdata {	Line 5544 sub devalidatecourseresdata {
&devalidate_cache_new('courseres',$hashid);	&devalidate_cache_new('courseres',$hashid);
}	}


# --------------------------------------------------- Course Resourcedata Query	# --------------------------------------------------- Course Resourcedata Query

sub get_courseresdata {	sub get_courseresdata {
Line 4341 sub get_userresdata {	Line 5593 sub get_userresdata {
}	}
#error 2 occurs when the .db doesn't exist	#error 2 occurs when the .db doesn't exist
if ($tmp!~/error: 2 /) {	if ($tmp!~/error: 2 /) {
&logthis("<font color=blue>WARNING:".	&logthis("<font color=\"blue\">WARNING:".
" Trying to get resource data for ".	" Trying to get resource data for ".
$uname." at ".$udom.": ".	$uname." at ".$udom.": ".
$tmp."</font>");	$tmp."</font>");
Line 4397 sub EXT_cache_set {	Line 5649 sub EXT_cache_set {

# --------------------------------------------------------- Value of a Variable	# --------------------------------------------------------- Value of a Variable
sub EXT {	sub EXT {
my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_;

	my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_;
unless ($varname) { return ''; }	unless ($varname) { return ''; }
#get real user name/domain, courseid and symb	#get real user name/domain, courseid and symb
my $courseid;	my $courseid;
Line 4407 sub EXT {	Line 5659 sub EXT {
$symbparm=&get_symb_from_alias($symbparm);	$symbparm=&get_symb_from_alias($symbparm);
}	}
if (!($uname && $udom)) {	if (!($uname && $udom)) {
(my $cursymb,$courseid,$udom,$uname,$publicuser)=	(my $cursymb,$courseid,$udom,$uname,$publicuser)= &whichuser($symbparm);
&Apache::lonxml::whichuser($symbparm);
if (!$symbparm) { $symbparm=$cursymb; }	if (!$symbparm) { $symbparm=$cursymb; }
} else {	} else {
$courseid=$env{'request.course.id'};	$courseid=$env{'request.course.id'};
Line 4431 sub EXT {	Line 5682 sub EXT {
if ( (defined($Apache::lonhomework::parsing_a_problem)	if ( (defined($Apache::lonhomework::parsing_a_problem)
\|\| defined($Apache::lonhomework::parsing_a_task))	\|\| defined($Apache::lonhomework::parsing_a_task))
&&	&&
($symbparm eq &symbread()) ) {	($symbparm eq &symbread()) ) {
return $Apache::lonhomework::history{$qualifierrest};	# if we are in the middle of processing the resource the
	# get the value we are planning on committing
	if (defined($Apache::lonhomework::results{$qualifierrest})) {
	return $Apache::lonhomework::results{$qualifierrest};
	} else {
	return $Apache::lonhomework::history{$qualifierrest};
	}
} else {	} else {
my %restored;	my %restored;
if ($publicuser \|\| $env{'request.state'} eq 'construct') {	if ($publicuser \|\| $env{'request.state'} eq 'construct') {
Line 4495 sub EXT {	Line 5752 sub EXT {
# ------------------------------------------------------------- request.browser	# ------------------------------------------------------------- request.browser
if ($space eq 'browser') {	if ($space eq 'browser') {
if ($qualifier eq 'textremote') {	if ($qualifier eq 'textremote') {
if (&mt('textual_remote_display') eq 'on') {	if (&Apache::lonlocal::mt('textual_remote_display') eq 'on') {
return 1;	return 1;
} else {	} else {
return 0;	return 0;
Line 4512 sub EXT {	Line 5769 sub EXT {
return $env{'course.'.$courseid.'.'.$spacequalifierrest};	return $env{'course.'.$courseid.'.'.$spacequalifierrest};
} elsif ($realm eq 'resource') {	} elsif ($realm eq 'resource') {

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) { $symbparm=&symbread(); }
}	}

	if ($space eq 'title') {
	if (!$symbparm) { $symbparm = $env{'request.filename'}; }
	return &gettitle($symbparm);
	}

	if ($space eq 'map') {
	my ($map) = &decode_symb($symbparm);
	return &symbread($map);
	}

	my ($section, $group, @groups);
my ($courselevelm,$courselevel);	my ($courselevelm,$courselevel);
if ($symbparm && defined($courseid) &&	if ($symbparm && defined($courseid) &&
$courseid eq $env{'request.course.id'}) {	$courseid eq $env{'request.course.id'}) {
Line 4524 sub EXT {	Line 5792 sub EXT {

# ----------------------------------------------------- Cascading lookup scheme	# ----------------------------------------------------- Cascading lookup scheme
my $symbp=$symbparm;	my $symbp=$symbparm;
my $mapp=(&decode_symb($symbp))[0];	my $mapp=&deversion((&decode_symb($symbp))[0]);

my $symbparm=$symbp.'.'.$spacequalifierrest;	my $symbparm=$symbp.'.'.$spacequalifierrest;
my $mapparm=$mapp.'___(all).'.$spacequalifierrest;	my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
Line 4532 sub EXT {	Line 5800 sub EXT {
if (($env{'user.name'} eq $uname) &&	if (($env{'user.name'} eq $uname) &&
($env{'user.domain'} eq $udom)) {	($env{'user.domain'} eq $udom)) {
$section=$env{'request.course.sec'};	$section=$env{'request.course.sec'};
	@groups = split(/:/,$env{'request.course.groups'});
	@groups=&sort_course_groups($courseid,@groups);
} else {	} else {
if (! defined($usection)) {	if (! defined($usection)) {
$section=&getsection($udom,$uname,$courseid);	$section=&getsection($udom,$uname,$courseid);
} else {	} else {
$section = $usection;	$section = $usection;
}	}
	@groups = &get_users_groups($udom,$uname,$courseid);
}	}

my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;	my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
Line 4553 sub EXT {	Line 5824 sub EXT {
my $userreply=&resdata($uname,$udom,'user',	my $userreply=&resdata($uname,$udom,'user',
($courselevelr,$courselevelm,	($courselevelr,$courselevelm,
$courselevel));	$courselevel));

if (defined($userreply)) { return $userreply; }	if (defined($userreply)) { return $userreply; }

# ------------------------------------------------ second, check some of course	# ------------------------------------------------ second, check some of course
	my $coursereply;
	if (@groups > 0) {
	$coursereply = &check_group_parms($courseid,\@groups,$symbparm,
	$mapparm,$spacequalifierrest);
	if (defined($coursereply)) { return $coursereply; }
	}

my $coursereply=&resdata($env{'course.'.$courseid.'.num'},	$coursereply=&resdata($env{'course.'.$courseid.'.num'},
$env{'course.'.$courseid.'.domain'},	$env{'course.'.$courseid.'.domain'},
'course',	'course',
($seclevelr,$seclevelm,$seclevel,	($seclevelr,$seclevelm,$seclevel,
Line 4620 sub EXT {	Line 5896 sub EXT {
if (($uname eq $env{'user.name'})&&($udom eq $env{'user.domain'})) {	if (($uname eq $env{'user.name'})&&($udom eq $env{'user.domain'})) {
return $env{'environment.'.$spacequalifierrest};	return $env{'environment.'.$spacequalifierrest};
} else {	} else {
	if ($uname eq 'anonymous' && $udom eq '') {
	return '';
	}
my %returnhash=&userenvironment($udom,$uname,	my %returnhash=&userenvironment($udom,$uname,
$spacequalifierrest);	$spacequalifierrest);
return $returnhash{$spacequalifierrest};	return $returnhash{$spacequalifierrest};
Line 4629 sub EXT {	Line 5908 sub EXT {
if ($space eq 'time') {	if ($space eq 'time') {
return time;	return time;
}	}
	} elsif ($realm eq 'server') {
	# ----------------------------------------------------------------- system.time
	if ($space eq 'name') {
	return $ENV{'SERVER_NAME'};
	}
}	}
return '';	return '';
}	}

	sub check_group_parms {
	my ($courseid,$groups,$symbparm,$mapparm,$what) = @_;
	my @groupitems = ();
	my $resultitem;
	my @levels = ($symbparm,$mapparm,$what);
	foreach my $group (@{$groups}) {
	foreach my $level (@levels) {
	my $item = $courseid.'.['.$group.'].'.$level;
	push(@groupitems,$item);
	}
	}
	my $coursereply = &resdata($env{'course.'.$courseid.'.num'},
	$env{'course.'.$courseid.'.domain'},
	'course',@groupitems);
	return $coursereply;
	}

	sub sort_course_groups { # Sort groups based on defined rankings. Default is sort().
	my ($courseid,@groups) = @_;
	@groups = sort(@groups);
	return @groups;
	}

sub packages_tab_default {	sub packages_tab_default {
my ($uri,$varname)=@_;	my ($uri,$varname)=@_;
my (undef,$part,$name)=split(/\./,$varname);	my (undef,$part,$name)=split(/\./,$varname);
my $packages=&metadata($uri,'packages');
foreach my $package (split(/,/,$packages)) {	my (@extension,@specifics,$do_default);
	foreach my $package (split(/,/,&metadata($uri,'packages'))) {
my ($pack_type,$pack_part)=split(/_/,$package,2);	my ($pack_type,$pack_part)=split(/_/,$package,2);
	if ($pack_type eq 'default') {
	$do_default=1;
	} elsif ($pack_type eq 'extension') {
	push(@extension,[$package,$pack_type,$pack_part]);
	} else {
	push(@specifics,[$package,$pack_type,$pack_part]);
	}
	}
	# first look for a package that matches the requested part id
	foreach my $package (@specifics) {
	my (undef,$pack_type,$pack_part)=@{$package};
	next if ($pack_part ne $part);
	if (defined($packagetab{"$pack_type&$name&default"})) {
	return $packagetab{"$pack_type&$name&default"};
	}
	}
	# look for any possible matching non extension_ package
	foreach my $package (@specifics) {
	my (undef,$pack_type,$pack_part)=@{$package};
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"};
}	}
Line 4647 sub packages_tab_default {	Line 5974 sub packages_tab_default {
return $packagetab{$pack_type."_".$pack_part."&$name&default"};	return $packagetab{$pack_type."_".$pack_part."&$name&default"};
}	}
}	}
	# look for any posible extension_ match
	foreach my $package (@extension) {
	my ($package,$pack_type)=@{$package};
	if (defined($packagetab{"$pack_type&$name&default"})) {
	return $packagetab{"$pack_type&$name&default"};
	}
	if (defined($packagetab{$package."&$name&default"})) {
	return $packagetab{$package."&$name&default"};
	}
	}
	# look for a global default setting
	if ($do_default && defined($packagetab{"default&$name&default"})) {
	return $packagetab{"default&$name&default"};
	}
return undef;	return undef;
}	}

Line 4677 sub metadata {	Line 6018 sub metadata {
(($uri =~ m\|^/*adm/\|) &&	(($uri =~ m\|^/*adm/\|) &&
($uri !~ m\|^adm/includes\|) && ($uri !~ m\|/bulletinboard$\|)) \|\|	($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/$match_username/public_html/\|)) {
return undef;	return undef;
}	}
my $filename=$uri;	my $filename=$uri;
Line 4708 sub metadata {	Line 6049 sub metadata {
my %metathesekeys=();	my %metathesekeys=();
unless ($filename=~/\.meta$/) { $filename.='.meta'; }	unless ($filename=~/\.meta$/) { $filename.='.meta'; }
my $metastring;	my $metastring;
if ($uri !~ m -^(uploaded\|editupload)/-) {	if ($uri !~ m -^(editupload)/-) {
my $file=&filelocation('',&clutter($filename));	my $file=&filelocation('',&clutter($filename));
#push(@{$metaentry{$uri.'.file'}},$file);	#push(@{$metaentry{$uri.'.file'}},$file);
$metastring=&getfile($file);	$metastring=&getfile($file);
Line 4732 sub metadata {	Line 6073 sub metadata {
} else {	} else {
$metaentry{':packages'}=$package.$keyroot;	$metaentry{':packages'}=$package.$keyroot;
}	}
foreach (sort keys %packagetab) {	foreach my $pack_entry (keys(%packagetab)) {
my $part=$keyroot;	my $part=$keyroot;
$part=~s/^\_//;	$part=~s/^\_//;
if ($_=~/^\Q$package\E\&/ \|\|	if ($pack_entry=~/^\Q$package\E\&/ \|\|
$_=~/^\Q$package\E_0\&/) {	$pack_entry=~/^\Q$package\E_0\&/) {
my ($pack,$name,$subp)=split(/\&/,$_);	my ($pack,$name,$subp)=split(/\&/,$pack_entry);
# ignore package.tab specified default values	# ignore package.tab specified default values
# here &package_tab_default() will fetch those	# here &package_tab_default() will fetch those
if ($subp eq 'default') { next; }	if ($subp eq 'default') { next; }
my $value=$packagetab{$_};	my $value=$packagetab{$pack_entry};
my $unikey;	my $unikey;
if ($pack =~ /_0$/) {	if ($pack =~ /_0$/) {
$unikey='parameter_0_'.$name;	$unikey='parameter_0_'.$name;
Line 4789 sub metadata {	Line 6130 sub metadata {
my $dir=$filename;	my $dir=$filename;
$dir=~s\|[^/]*$\|\|;	$dir=~s\|[^/]*$\|\|;
$location=&filelocation($dir,$location);	$location=&filelocation($dir,$location);
foreach (sort(split(/\,/,&metadata($uri,'keys',	my $metadata =
$location,$unikey,	&metadata($uri,'keys', $location,$unikey,
$depthcount+1)))) {	$depthcount+1);
$metaentry{':'.$_}=$metaentry{':'.$_};	foreach my $meta (split(',',$metadata)) {
$metathesekeys{$_}=1;	$metaentry{':'.$meta}=$metaentry{':'.$meta};
	$metathesekeys{$meta}=1;
}	}
}	}
} else {	} else {
Line 4802 sub metadata {	Line 6144 sub metadata {
$unikey.='_'.$token->[2]->{'name'};	$unikey.='_'.$token->[2]->{'name'};
}	}
$metathesekeys{$unikey}=1;	$metathesekeys{$unikey}=1;
foreach (@{$token->[3]}) {	foreach my $param (@{$token->[3]}) {
$metaentry{':'.$unikey.'.'.$_}=$token->[2]->{$_};	$metaentry{':'.$unikey.'.'.$param} =
	$token->[2]->{$param};
}	}
my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));	my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));
my $default=$metaentry{':'.$unikey.'.default'};	my $default=$metaentry{':'.$unikey.'.default'};
Line 4824 sub metadata {	Line 6167 sub metadata {
}	}
}	}
my ($extension) = ($uri =~ /\.(\w+)$/);	my ($extension) = ($uri =~ /\.(\w+)$/);
foreach my $key (sort(keys(%packagetab))) {	foreach my $key (keys(%packagetab)) {
#no specific packages #how's our extension	#no specific packages #how's our extension
if ($key!~/^extension_\Q$extension\E&/) { next; }	if ($key!~/^extension_\Q$extension\E&/) { next; }
&metadata_create_package_def($uri,$key,'extension_'.$extension,	&metadata_create_package_def($uri,$key,'extension_'.$extension,
\%metathesekeys);	\%metathesekeys);
}	}
if (!exists($metaentry{':packages'})) {	if (!exists($metaentry{':packages'})) {
foreach my $key (sort(keys(%packagetab))) {	foreach my $key (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; }
&metadata_create_package_def($uri,$key,'default',	&metadata_create_package_def($uri,$key,'default',
Line 4849 sub metadata {	Line 6192 sub metadata {
my $dir=$filename;	my $dir=$filename;
$dir=~s\|[^/]*$\|\|;	$dir=~s\|[^/]*$\|\|;
$location=&filelocation($dir,$location);	$location=&filelocation($dir,$location);
foreach (sort(split(/\,/,&metadata($uri,'keys',	my $rights_metadata =
$location,'_rights',	&metadata($uri,'keys',$location,'_rights',
$depthcount+1)))) {	$depthcount+1);
#$metaentry{':'.$_}=$metacache{$uri}->{':'.$_};	foreach my $rights (split(',',$rights_metadata)) {
$metathesekeys{$_}=1;	#$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights};
	$metathesekeys{$rights}=1;
}	}
}	}
}	}
$metaentry{':keys'}=join(',',keys %metathesekeys);	# uniqifiy package listing
	my %seen;
	my @uniq_packages =
	grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));
	$metaentry{':packages'} = join(',',@uniq_packages);

	$metaentry{':keys'} = join(',',keys(%metathesekeys));
&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);	&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);	$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
&do_cache_new('meta',$uri,\%metaentry,600);	&do_cache_new('meta',$uri,\%metaentry,60*60);
# this is the end of "was not already recently cached	# this is the end of "was not already recently cached
}	}
return $metaentry{':'.$what};	return $metaentry{':'.$what};
Line 4893 sub metadata_create_package_def {	Line 6243 sub metadata_create_package_def {
sub metadata_generate_part0 {	sub metadata_generate_part0 {
my ($metadata,$metacache,$uri) = @_;	my ($metadata,$metacache,$uri) = @_;
my %allnames;	my %allnames;
foreach my $metakey (sort keys %$metadata) {	foreach my $metakey (keys(%$metadata)) {
if ($metakey=~/^parameter\_(.*)/) {	if ($metakey=~/^parameter\_(.*)/) {
my $part=$$metacache{':'.$metakey.'.part'};	my $part=$$metacache{':'.$metakey.'.part'};
my $name=$$metacache{':'.$metakey.'.name'};	my $name=$$metacache{':'.$metakey.'.name'};
Line 4918 sub metadata_generate_part0 {	Line 6268 sub metadata_generate_part0 {
}	}
}	}

	# ------------------------------------------------------ Devalidate title cache

	sub devalidate_title_cache {
	my ($url)=@_;
	if (!$env{'request.course.id'}) { return; }
	my $symb=&symbread($url);
	if (!$symb) { return; }
	my $key=$env{'request.course.id'}."\0".$symb;
	&devalidate_cache_new('title',$key);
	}

# ------------------------------------------------- Get the title of a resource	# ------------------------------------------------- Get the title of a resource

sub gettitle {	sub gettitle {
Line 4952 sub gettitle {	Line 6313 sub gettitle {
sub get_slot {	sub get_slot {
my ($which,$cnum,$cdom)=@_;	my ($which,$cnum,$cdom)=@_;
if (!$cnum \|\| !$cdom) {	if (!$cnum \|\| !$cdom) {
(undef,my $courseid)=&Apache::lonxml::whichuser();	(undef,my $courseid)=&whichuser();
$cdom=$env{'course.'.$courseid.'.domain'};	$cdom=$env{'course.'.$courseid.'.domain'};
$cnum=$env{'course.'.$courseid.'.num'};	$cnum=$env{'course.'.$courseid.'.num'};
}	}
my %slotinfo=&get('slots',[$which],$cdom,$cnum);	my $key=join("\0",'slots',$cdom,$cnum,$which);
&Apache::lonhomework::showhash(%slotinfo);	my %slotinfo;
my ($tmp)=keys(%slotinfo);	if (exists($remembered{$key})) {
if ($tmp=~/^error:/) { return (); }	$slotinfo{$which} = $remembered{$key};
	} else {
	%slotinfo=&get('slots',[$which],$cdom,$cnum);
	&Apache::lonhomework::showhash(%slotinfo);
	my ($tmp)=keys(%slotinfo);
	if ($tmp=~/^error:/) { return (); }
	$remembered{$key} = $slotinfo{$which};
	}
if (ref($slotinfo{$which}) eq 'HASH') {	if (ref($slotinfo{$which}) eq 'HASH') {
return %{$slotinfo{$which}};	return %{$slotinfo{$which}};
}	}
Line 4974 sub symblist {	Line 6342 sub symblist {
if (($env{'request.course.fn'}) && (%newhash)) {	if (($env{'request.course.fn'}) && (%newhash)) {
if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',	if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
&GDBM_WRCREAT(),0640)) {	&GDBM_WRCREAT(),0640)) {
foreach (keys %newhash) {	foreach my $url (keys %newhash) {
$hash{declutter($_)}=&encode_symb($mapname,$newhash{$_}->[1],	next if ($url eq 'last_known'
$newhash{$_}->[0]);	&& $env{'form.no_update_last_known'});
	$hash{declutter($url)}=&encode_symb($mapname,
	$newhash{$url}->[1],
	$newhash{$url}->[0]);
}	}
if (untie(%hash)) {	if (untie(%hash)) {
return 'ok';	return 'ok';
Line 4991 sub symblist {	Line 6362 sub symblist {
sub symbverify {	sub symbverify {
my ($symb,$thisurl)=@_;	my ($symb,$thisurl)=@_;
my $thisfn=$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 5016 sub symbverify {	Line 6385 sub symbverify {
}	}
if ($ids) {	if ($ids) {
# ------------------------------------------------------------------- Has ID(s)	# ------------------------------------------------------------------- Has ID(s)
foreach (split(/\,/,$ids)) {	foreach my $id (split(/\,/,$ids)) {
my ($mapid,$resid)=split(/\./,$_);	my ($mapid,$resid)=split(/\./,$id);
if (	if (
&symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)	&symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
eq $symb) {	eq $symb) {
if (($env{'request.role.adv'}) \|\|	if (($env{'request.role.adv'}) \|\|
$bighash{'encrypted_'.$_} eq $env{'request.enc'}) {	$bighash{'encrypted_'.$id} eq $env{'request.enc'}) {
$okay=1;	$okay=1;
}	}
}	}
Line 5047 sub symbclean {	Line 6416 sub symbclean {
# remove wrapper	# remove wrapper

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

Line 5123 sub symbread {	Line 6493 sub symbread {
if ( ($thisfn =~ m/^(uploaded\|editupload)\//) && ($thisfn !~ m/\.(page\|sequence)$/) ) {	if ( ($thisfn =~ m/^(uploaded\|editupload)\//) && ($thisfn !~ m/\.(page\|sequence)$/) ) {
$targetfn = 'adm/wrapper/'.$thisfn;	$targetfn = 'adm/wrapper/'.$thisfn;
}	}
	if ($targetfn =~ m\|^adm/wrapper/(ext/.*)\|) {
	$targetfn=$1;
	}
if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',	if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
&GDBM_READER(),0640)) {	&GDBM_READER(),0640)) {
$syval=$hash{$targetfn};	$syval=$hash{$targetfn};
Line 5161 sub symbread {	Line 6534 sub symbread {
} elsif (!$donotrecurse) {	} elsif (!$donotrecurse) {
# ------------------------------------------ There is more than one possibility	# ------------------------------------------ There is more than one possibility
my $realpossible=0;	my $realpossible=0;
foreach (@possibilities) {	foreach my $id (@possibilities) {
my $file=$bighash{'src_'.$_};	my $file=$bighash{'src_'.$id};
if (&allowed('bre',$file)) {	if (&allowed('bre',$file)) {
my ($mapid,$resid)=split(/\./,$_);	my ($mapid,$resid)=split(/\./,$id);
if ($bighash{'map_type_'.$mapid} ne 'page') {	if ($bighash{'map_type_'.$mapid} ne 'page') {
$realpossible++;	$realpossible++;
$syval=&encode_symb($bighash{'map_id_'.$mapid},	$syval=&encode_symb($bighash{'map_id_'.$mapid},
Line 5236 sub numval3 {	Line 6609 sub numval3 {
return $total;	return $total;
}	}

	sub digest {
	my ($data)=@_;
	my $digest=&Digest::MD5::md5($data);
	my ($a,$b,$c,$d)=unpack("iiii",$digest);
	my ($e,$f);
	{
	use integer;
	$e=($a+$b);
	$f=($c+$d);
	if ($_64bit) {
	$e=(($e<<32)>>32);
	$f=(($f<<32)>>32);
	}
	}
	if (wantarray) {
	return ($e,$f);
	} else {
	my $g;
	{
	use integer;
	$g=($e+$f);
	if ($_64bit) {
	$g=(($g<<32)>>32);
	}
	}
	return $g;
	}
	}

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

sub get_rand_alg {	sub get_rand_alg {
my ($courseid)=@_;	my ($courseid)=@_;
if (!$courseid) { $courseid=(&Apache::lonxml::whichuser())[1]; }	if (!$courseid) { $courseid=(&whichuser())[1]; }
if ($courseid) {	if ($courseid) {
return $env{"course.$courseid.rndseed"};	return $env{"course.$courseid.rndseed"};
}	}
Line 5268 sub getCODE {	Line 6670 sub getCODE {
sub rndseed {	sub rndseed {
my ($symb,$courseid,$domain,$username)=@_;	my ($symb,$courseid,$domain,$username)=@_;

my ($wsymb,$wcourseid,$wdomain,$wusername)=&Apache::lonxml::whichuser();	my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser();
if (!$symb) {	if (!$symb) {
unless ($symb=$wsymb) { return time; }	unless ($symb=$wsymb) { return time; }
}	}
Line 5276 sub rndseed {	Line 6678 sub rndseed {
if (!$domain) { $domain=$wdomain; }	if (!$domain) { $domain=$wdomain; }
if (!$username) { $username=$wusername }	if (!$username) { $username=$wusername }
my $which=&get_rand_alg();	my $which=&get_rand_alg();

if (defined(&getCODE())) {	if (defined(&getCODE())) {
if ($which eq '64bit4') {	if ($which eq '64bit5') {
	return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);
	} elsif ($which eq '64bit4') {
return &rndseed_CODE_64bit4($symb,$courseid,$domain,$username);	return &rndseed_CODE_64bit4($symb,$courseid,$domain,$username);
} else {	} else {
return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);	return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);
}	}
	} elsif ($which eq '64bit5') {
	return &rndseed_64bit5($symb,$courseid,$domain,$username);
} elsif ($which eq '64bit4') {	} elsif ($which eq '64bit4') {
return &rndseed_64bit4($symb,$courseid,$domain,$username);	return &rndseed_64bit4($symb,$courseid,$domain,$username);
} elsif ($which eq '64bit3') {	} elsif ($which eq '64bit3') {
Line 5305 sub rndseed_32bit {	Line 6712 sub rndseed_32bit {
my $domainseed=unpack("%32C*",$domain) << 7;	my $domainseed=unpack("%32C*",$domain) << 7;
my $courseseed=unpack("%32C*",$courseid);	my $courseseed=unpack("%32C*",$courseid);
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");	#&logthis("$symbseed:$nameseed;$domainseed\|$courseseed;$namechck:$symbchck");
#&Apache::lonxml::debug("rndseed :$num:$symb");	#&logthis("rndseed :$num:$symb");
if ($_64bit) { $num=(($num<<32)>>32); }	if ($_64bit) { $num=(($num<<32)>>32); }
return $num;	return $num;
}	}
Line 5326 sub rndseed_64bit {	Line 6733 sub rndseed_64bit {

my $num1=$symbchck+$symbseed+$namechck;	my $num1=$symbchck+$symbseed+$namechck;
my $num2=$nameseed+$domainseed+$courseseed;	my $num2=$nameseed+$domainseed+$courseseed;
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed\|$courseseed;$namechck:$symbchck");	#&logthis("$symbseed:$nameseed;$domainseed\|$courseseed;$namechck:$symbchck");
#&Apache::lonxml::debug("rndseed :$num:$symb");	#&logthis("rndseed :$num:$symb");
if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
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 5350 sub rndseed_64bit2 {	Line 6756 sub rndseed_64bit2 {

my $num1=$symbchck+$symbseed+$namechck;	my $num1=$symbchck+$symbseed+$namechck;
my $num2=$nameseed+$domainseed+$courseseed;	my $num2=$nameseed+$domainseed+$courseseed;
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed\|$courseseed;$namechck:$symbchck");	#&logthis("$symbseed:$nameseed;$domainseed\|$courseseed;$namechck:$symbchck");
#&Apache::lonxml::debug("rndseed :$num:$symb");	#&logthis("rndseed :$num:$symb");
	if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
return "$num1,$num2";	return "$num1,$num2";
}	}
}	}
Line 5372 sub rndseed_64bit3 {	Line 6779 sub rndseed_64bit3 {

my $num1=$symbchck+$symbseed+$namechck;	my $num1=$symbchck+$symbseed+$namechck;
my $num2=$nameseed+$domainseed+$courseseed;	my $num2=$nameseed+$domainseed+$courseseed;
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed\|$courseseed;$namechck:$symbchck");	#&logthis("$symbseed:$nameseed;$domainseed\|$courseseed;$namechck:$symbchck");
#&Apache::lonxml::debug("rndseed :$num1:$num2:$_64bit");	#&logthis("rndseed :$num1:$num2:$_64bit");
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 5396 sub rndseed_64bit4 {	Line 6803 sub rndseed_64bit4 {

my $num1=$symbchck+$symbseed+$namechck;	my $num1=$symbchck+$symbseed+$namechck;
my $num2=$nameseed+$domainseed+$courseseed;	my $num2=$nameseed+$domainseed+$courseseed;
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed\|$courseseed;$namechck:$symbchck");	#&logthis("$symbseed:$nameseed;$domainseed\|$courseseed;$namechck:$symbchck");
#&Apache::lonxml::debug("rndseed :$num1:$num2:$_64bit");	#&logthis("rndseed :$num1:$num2:$_64bit");
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";
}	}
}	}

	sub rndseed_64bit5 {
	my ($symb,$courseid,$domain,$username)=@_;
	my ($num1,$num2)=&digest("$symb,$courseid,$domain,$username");
	return "$num1:$num2";
	}

sub rndseed_CODE_64bit {	sub rndseed_CODE_64bit {
my ($symb,$courseid,$domain,$username)=@_;	my ($symb,$courseid,$domain,$username)=@_;
{	{
Line 5415 sub rndseed_CODE_64bit {	Line 6828 sub rndseed_CODE_64bit {
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");	#&logthis("$symbseed:$CODEchck\|$CODEseed:$courseseed:$symbchck");
#&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");	#&logthis("rndseed :$num1:$num2:$symb");
if ($_64bit) { $num1=(($num1<<32)>>32); }	if ($_64bit) { $num1=(($num1<<32)>>32); }
if ($_64bit) { $num2=(($num2<<32)>>32); }	if ($_64bit) { $num2=(($num2<<32)>>32); }
return "$num1:$num2";	return "$num1:$num2";
Line 5434 sub rndseed_CODE_64bit4 {	Line 6847 sub rndseed_CODE_64bit4 {
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");	#&logthis("$symbseed:$CODEchck\|$CODEseed:$courseseed:$symbchck");
#&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");	#&logthis("rndseed :$num1:$num2:$symb");
if ($_64bit) { $num1=(($num1<<32)>>32); }	if ($_64bit) { $num1=(($num1<<32)>>32); }
if ($_64bit) { $num2=(($num2<<32)>>32); }	if ($_64bit) { $num2=(($num2<<32)>>32); }
return "$num1:$num2";	return "$num1:$num2";
}	}
}	}

	sub rndseed_CODE_64bit5 {
	my ($symb,$courseid,$domain,$username)=@_;
	my $code = &getCODE();
	my ($num1,$num2)=&digest("$symb,$courseid,$code");
	return "$num1:$num2";
	}

sub setup_random_from_rndseed {	sub setup_random_from_rndseed {
my ($rndseed)=@_;	my ($rndseed)=@_;
if ($rndseed =~/([,:])/) {	if ($rndseed =~/([,:])/) {
Line 5489 sub ireceipt {	Line 6909 sub ireceipt {
my $return =&recprefix($fucourseid).'-';	my $return =&recprefix($fucourseid).'-';
if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' \|\|	if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' \|\|
$env{'request.state'} eq 'construct') {	$env{'request.state'} eq 'construct') {
&Apache::lonxml::debug("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname).	#&logthis("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname)." and ".($cpart%$cudom));
" and ".($cpart%$cudom));

$return.= ($cunique%$cuname+	$return.= ($cunique%$cuname+
$cunique%$cudom+	$cunique%$cudom+
Line 5513 sub ireceipt {	Line 6932 sub ireceipt {

sub receipt {	sub receipt {
my ($part)=@_;	my ($part)=@_;
my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser();	my ($symb,$courseid,$domain,$name) = &whichuser();
return &ireceipt($name,$domain,$courseid,$symb,$part);	return &ireceipt($name,$domain,$courseid,$symb,$part);
}	}

	sub whichuser {
	my ($passedsymb)=@_;
	my ($symb,$courseid,$domain,$name,$publicuser);
	if (defined($env{'form.grade_symb'})) {
	my ($tmp_courseid)=&get_env_multiple('form.grade_courseid');
	my $allowed=&allowed('vgr',$tmp_courseid);
	if (!$allowed &&
	exists($env{'request.course.sec'}) &&
	$env{'request.course.sec'} !~ /^\s*$/) {
	$allowed=&allowed('vgr',$tmp_courseid.
	'/'.$env{'request.course.sec'});
	}
	if ($allowed) {
	($symb)=&get_env_multiple('form.grade_symb');
	$courseid=$tmp_courseid;
	($domain)=&get_env_multiple('form.grade_domain');
	($name)=&get_env_multiple('form.grade_username');
	return ($symb,$courseid,$domain,$name,$publicuser);
	}
	}
	if (!$passedsymb) {
	$symb=&symbread();
	} else {
	$symb=$passedsymb;
	}
	$courseid=$env{'request.course.id'};
	$domain=$env{'user.domain'};
	$name=$env{'user.name'};
	if ($name eq 'public' && $domain eq 'public') {
	if (!defined($env{'form.username'})) {
	$env{'form.username'}.=time.rand(10000000);
	}
	$name.=$env{'form.username'};
	}
	return ($symb,$courseid,$domain,$name,$publicuser);

	}

# ------------------------------------------------------------ Serves up a file	# ------------------------------------------------------------ Serves up a file
# returns either the contents of the file or	# returns either the contents of the file or
# -1 if the file doesn't exist	# -1 if the file doesn't exist
Line 5539 sub repcopy_userfile {	Line 6996 sub repcopy_userfile {
if ($file =~ m -^/*(uploaded\|editupload)/-) { $file=&filelocation("",$file); }	if ($file =~ m -^/*(uploaded\|editupload)/-) { $file=&filelocation("",$file); }
if ($file =~ m\|^/home/httpd/html/lonUsers/\|) { return 'ok'; }	if ($file =~ m\|^/home/httpd/html/lonUsers/\|) { return 'ok'; }
my ($cdom,$cnum,$filename) =	my ($cdom,$cnum,$filename) =
($file=~m\|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+([^/]+)/+([^/]+)/+(.*)\|);	($file=~m\|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_username)/+(.*)\|);
my ($info,$rtncode);	my ($info,$rtncode);
my $uri="/uploaded/$cdom/$cnum/$filename";	my $uri="/uploaded/$cdom/$cnum/$filename";
if (-e "$file") {	if (-e "$file") {
Line 5640 sub readfile {	Line 7097 sub readfile {
my $fh;	my $fh;
open($fh,"<$file");	open($fh,"<$file");
my $a='';	my $a='';
while (<$fh>) { $a .=$_; }	while (my $line = <$fh>) { $a .= $line; }
return $a;	return $a;
}	}

Line 5648 sub filelocation {	Line 7105 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-^/adm/-) {
	$file=~s-^/adm/wrapper/-/-;
	$file=~s-^/adm/coursedocs/showdoc/-/-;
	}
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=~m:^/home/[^/]*/public_html/:) {	} elsif ($file=~m{^/home/$match_username/public_html/}) {
# is a correct contruction space reference	# is a correct contruction space reference
$location = $file;	$location = $file;
} elsif ($file=~/^\/*(uploaded\|editupload)/) { # is an uploaded file	} elsif ($file=~/^\/*(uploaded\|editupload)/) { # is an uploaded file
my ($udom,$uname,$filename)=	my ($udom,$uname,$filename)=
($file=~m -^/+(?:uploaded\|editupload)/+([^/]+)/+([^/]+)/+(.*)$-);	($file=~m -^/+(?:uploaded\|editupload)/+($match_domain)/+($match_username)/+(.*)$-);
my $home=&homeserver($uname,$udom);	my $home=&homeserver($uname,$udom);
my $is_me=0;	my $is_me=0;
my @ids=&current_machine_ids();	my @ids=&current_machine_ids();
foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }	foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
if ($is_me) {	if ($is_me) {
$location=&Apache::loncommon::propath($udom,$uname).	$location=&propath($udom,$uname).
'/userfiles/'.$filename;	'/userfiles/'.$filename;
} else {	} else {
$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.	$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
Line 5686 sub filelocation {	Line 7148 sub filelocation {
sub hreflocation {	sub hreflocation {
my ($dir,$file)=@_;	my ($dir,$file)=@_;
unless (($file=~m-^http://-i) \|\| ($file=~m-^/-)) {	unless (($file=~m-^http://-i) \|\| ($file=~m-^/-)) {
my $finalpath=filelocation($dir,$file);	$file=filelocation($dir,$file);
$finalpath=~s-^/home/httpd/html--;	} elsif ($file=~m-^/adm/-) {
$finalpath=~s-^/home/(\w+)/public_html/-/~$1/-;	$file=~s-^/adm/wrapper/-/-;
return $finalpath;	$file=~s-^/adm/coursedocs/showdoc/-/-;
} elsif ($file=~m-^/home-) {	}
$file=~s-^/home/httpd/html--;	if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) {
$file=~s-^/home/(\w+)/public_html/-/~$1/-;	$file=~s-^\Q$perlvar{'lonDocRoot'}\E--;
return $file;	} elsif ($file=~m-/home/($match_username)/public_html/-) {
	$file=~s-^/home/($match_username)/public_html/-/~$1/-;
	} elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) {
	$file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_username)/userfiles/
	-/uploaded/$1/$2/-x;
}	}
return $file;	return $file;
}	}
Line 5729 sub declutter {	Line 7195 sub declutter {
if ($thisfn=~m\|^/enc/\|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }	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\|^adm/wrapper/\|\|;
	$thisfn=~s\|^adm/coursedocs/showdoc/\|\|;
$thisfn=~s/^res\///;	$thisfn=~s/^res\///;
$thisfn=~s/\?.+$//;	$thisfn=~s/\?.+$//;
return $thisfn;	return $thisfn;
Line 5741 sub clutter {	Line 7209 sub clutter {
unless ($thisfn=~/^\/(uploaded\|editupload\|adm\|userfiles\|ext\|raw\|priv\|public)\//) {	unless ($thisfn=~/^\/(uploaded\|editupload\|adm\|userfiles\|ext\|raw\|priv\|public)\//) {
$thisfn='/res'.$thisfn;	$thisfn='/res'.$thisfn;
}	}
	if ($thisfn !~m\|/adm\|) {
	if ($thisfn =~ m\|/ext/\|) {
	$thisfn='/adm/wrapper'.$thisfn;
	} else {
	my ($ext) = ($thisfn =~ /\.(\w+)$/);
	my $embstyle=&Apache::loncommon::fileembstyle($ext);
	if ($embstyle eq 'ssi'
	\|\| ($embstyle eq 'hdn')
	\|\| ($embstyle eq 'rat')
	\|\| ($embstyle eq 'prv')
	\|\| ($embstyle eq 'ign')) {
	#do nothing with these
	} elsif (($embstyle eq 'img')
	\|\| ($embstyle eq 'emb')
	\|\| ($embstyle eq 'wrp')) {
	$thisfn='/adm/wrapper'.$thisfn;
	} elsif ($embstyle eq 'unk'
	&& $thisfn!~/\.(sequence\|page)$/) {
	$thisfn='/adm/coursedocs/showdoc'.$thisfn;
	} else {
	# &logthis("Got a blank emb style");
	}
	}
	}
return $thisfn;	return $thisfn;
}	}

	sub clutter_with_no_wrapper {
	my $uri = &clutter(shift);
	if ($uri =~ m-^/adm/-) {
	$uri =~ s-^/adm/wrapper/-/-;
	$uri =~ s-^/adm/coursedocs/showdoc/-/-;
	}
	return $uri;
	}

sub freeze_escape {	sub freeze_escape {
my ($value)=@_;	my ($value)=@_;
if (ref($value)) {	if (ref($value)) {
Line 5753 sub freeze_escape {	Line 7254 sub freeze_escape {
return &escape($value);	return &escape($value);
}	}

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

sub escape {
my $str=shift;
$str =~ s/(\W)/"%".unpack('H2',$1)/eg;
return $str;
}

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

sub unescape {
my $str=shift;
$str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
return $str;
}

sub thaw_unescape {	sub thaw_unescape {
my ($value)=@_;	my ($value)=@_;
Line 5779 sub thaw_unescape {	Line 7265 sub thaw_unescape {
return &unescape($value);	return &unescape($value);
}	}

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

sub correct_line_ends {	sub correct_line_ends {
my ($result)=@_;	my ($result)=@_;
$$result =~s/\r\n/\n/mg;	$$result =~s/\r\n/\n/mg;
Line 5812 sub goodbye {	Line 7291 sub goodbye {
&logthis(sprintf("%-20s is %s",'hits',$hits));	&logthis(sprintf("%-20s is %s",'hits',$hits));
&flushcourselogs();	&flushcourselogs();
&logthis("Shutting down");	&logthis("Shutting down");
return DONE;
}	}

BEGIN {	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	my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf');
open(my $config,"</etc/httpd/conf/loncapa.conf");	%perlvar = (%perlvar,%{$configvars});

while (my $configline=<$config>) {
if ($configline=~/\S/ && $configline =~ /^[^\#]*PerlSetVar/) {
my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
chomp($varvalue);
$perlvar{$varname}=$varvalue;
}
}
close($config);
}
{
open(my $config,"</etc/httpd/conf/loncapa_apache.conf");

while (my $configline=<$config>) {
if ($configline =~ /^[^\#]*PerlSetVar/) {
my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
chomp($varvalue);
$perlvar{$varname}=$varvalue;
}
}
close($config);
}	}

# ------------------------------------------------------------ Read domain file	# ------------------------------------------------------------ Read domain file
Line 5851 BEGIN {	Line 7308 BEGIN {
%domain_auth_arg_def = ();	%domain_auth_arg_def = ();
my $fh;	my $fh;
if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) {	if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) {
while (<$fh>) {	while (my $line = <$fh>) {
next if (/^(\#\|\s*$)/);	next if ($line =~ /^(\#\|\s*$)/);
# next if /^\#/;	# next if /^\#/;
chomp;	chomp $line;
my ($domain, $domain_description, $def_auth, $def_auth_arg,	my ($domain, $domain_description, $def_auth, $def_auth_arg,
$def_lang, $city, $longi, $lati) = split(/:/,$_);	$def_lang, $city, $longi, $lati, $primary) = split(/:/,$line,9);
$domain_auth_def{$domain}=$def_auth;	$domain_auth_def{$domain}=$def_auth;
$domain_auth_arg_def{$domain}=$def_auth_arg;	$domain_auth_arg_def{$domain}=$def_auth_arg;
$domaindescription{$domain}=$domain_description;	$domaindescription{$domain}=$domain_description;
Line 5864 BEGIN {	Line 7321 BEGIN {
$domain_city{$domain}=$city;	$domain_city{$domain}=$city;
$domain_longi{$domain}=$longi;	$domain_longi{$domain}=$longi;
$domain_lati{$domain}=$lati;	$domain_lati{$domain}=$lati;
	$domain_primary{$domain}=$primary;

# &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");	# &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");
# &logthis("Domain.tab: $domain ".$domaindescription{$domain} );	# &logthis("Domain.tab: $domain ".$domaindescription{$domain} );
Line 5890 BEGIN {	Line 7348 BEGIN {
}	}
close($config);	close($config);
# FIXME: dev server don't want this, production servers _do_ want this	# FIXME: dev server don't want this, production servers _do_ want this
&get_iphost();	#&get_iphost();
}	}

sub get_iphost {	sub get_iphost {
Line 5922 sub get_iphost {	Line 7380 sub get_iphost {
while (my $configline=<$config>) {	while (my $configline=<$config>) {
chomp($configline);	chomp($configline);
if ($configline) {	if ($configline) {
$spareid{$configline}=1;	my ($host,$type) = split(':',$configline,2);
	if (!defined($type) \|\| $type eq '') { $type = 'default' };
	push(@{ $spareid{$type} }, $host);
}	}
}	}
close($config);	close($config);
Line 5948 sub get_iphost {	Line 7408 sub get_iphost {
while (my $configline=<$config>) {	while (my $configline=<$config>) {
chomp($configline);	chomp($configline);
if ($configline) {	if ($configline) {
my ($short,$plain)=split(/:/,$configline);	my ($short,@plain)=split(/:/,$configline);
if ($plain ne '') { $prp{$short}=$plain; }	%{$prp{$short}} = ();
	if (@plain > 0) {
	$prp{$short}{'std'} = $plain[0];
	for (my $i=1; $i<@plain; $i++) {
	$prp{$short}{'alt'.$i} = $plain[$i];
	}
	}
}	}
}	}
close($config);	close($config);
Line 5978 sub get_iphost {	Line 7444 sub get_iphost {

}	}

$memcache=new Cache::Memcached({'servers'=>['127.0.0.1:11211']});	$memcache=new Cache::Memcached({'servers' => ['127.0.0.1:11211'],
	'compress_threshold'=> 20_000,
	});

$processmarker='_'.time.'_'.$perlvar{'lonHostID'};	$processmarker='_'.time.'_'.$perlvar{'lonHostID'};
$dumpcount=0;	$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;	use integer;
Line 6175 B<delenv($regexp)>: removes all items fr	Line 7643 B<delenv($regexp)>: removes all items fr
environment file that matches the regular expression in $regexp. The	environment file that matches the regular expression in $regexp. The
values are also delted from the current processes %env.	values are also delted from the current processes %env.

	=item * get_env_multiple($name)

	gets $name from the %env hash, it seemlessly handles the cases where multiple
	values may be defined and end up as an array ref.

	returns an array of values

=back	=back

=head2 User Information	=head2 User Information
Line 6244 actions	Line 7719 actions
'': forbidden	'': forbidden
1: user needs to choose course	1: user needs to choose course
2: browse allowed	2: browse allowed
	A: passphrase authentication needed

=item *	=item *

Line 6564 all args are optional	Line 8040 all args are optional

=item *	=item *

	dumpstore($namespace,$udom,$uname,$regexp,$range) :
	dumps the complete (or key matching regexp) namespace into a hash
	($udom, $uname, $regexp, $range are optional) for a namespace that is
	normally &store()ed into

	$range should be either an integer '100' (give me the first 100
	matching records)
	or be two integers sperated by a - with no spaces
	'30-50' (give me the 30th through the 50th matching
	records)


	=item *

	putstore($namespace,$symb,$version,$storehash,$udomain,$uname) :
	replaces a &store() version of data with a replacement set of data
	for a particular resource in a namespace passed in the $storehash hash
	reference

	=item *

tmpstore($storehash,$symb,$namespace,$udom,$uname) : storage that	tmpstore($storehash,$symb,$namespace,$udom,$uname) : storage that
works very similar to store/cstore, but all data is stored in a	works very similar to store/cstore, but all data is stored in a
temporary location and can be reset using tmpreset, $storehash should	temporary location and can be reset using tmpreset, $storehash should
Line 6593 namesp ($udom and $uname are optional)	Line 8090 namesp ($udom and $uname are optional)

=item *	=item *

dump($namespace,$udom,$uname,$regexp) :	dump($namespace,$udom,$uname,$regexp,$range) :
dumps the complete (or key matching regexp) namespace into a hash	dumps the complete (or key matching regexp) namespace into a hash
($udom, $uname and $regexp are optional)	($udom, $uname, $regexp, $range are optional)

	$range should be either an integer '100' (give me the first 100
	matching records)
	or be two integers sperated by a - with no spaces
	'30-50' (give me the 30th through the 50th matching
	records)
=item *	=item *

inc($namespace,$store,$udom,$uname) : increments $store in $namespace.	inc($namespace,$store,$udom,$uname) : increments $store in $namespace.
Line 6612 put($namespace,$storehash,$udom,$uname)	Line 8114 put($namespace,$storehash,$udom,$uname)

=item *	=item *

putstore($namespace,$storehash,$udomain,$uname) : stores hash in namesp	cput($namespace,$storehash,$udom,$uname) : critical put
keys used in storehash include version information (e.g., 1:$symb:message etc.) as	($udom and $uname are optional)
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 *	=item *

cput($namespace,$storehash,$udom,$uname) : critical put	newput($namespace,$storehash,$udom,$uname) :
($udom and $uname are optional)
	Attempts to store the items in the $storehash, but only if they don't
	currently exist, if this succeeds you can be certain that you have
	successfully created a new key value pair in the $namespace db.


	Args:
	$namespace: name of database to store values to
	$storehash: hashref to store to the db
	$udom: (optional) domain of user containing the db
	$uname: (optional) name of user caontaining the db

	Returns:
	'ok' -> succeeded in storing all keys of $storehash
	'key_exists: <key>' -> failed to anything out of $storehash, as at
	least <key> already existed in the db (other
	requested keys may also already exist)
	'error: <msg>' -> unable to tie the DB or other erorr occured
	'con_lost' -> unable to contact request server
	'refused' -> action was not allowed by remote machine


=item *	=item *

Line 6637 reference filled in from namesp (encrypt	Line 8153 reference filled in from namesp (encrypt
log($udom,$name,$home,$message) : write to permanent log for user; use	log($udom,$name,$home,$message) : write to permanent log for user; use
critical subroutine	critical subroutine

	=item *

	get_dom($namespace,$storearr,$udomain) : returns hash with keys from array
	reference filled in from namespace found in domain level on primary domain server ($udomain is optional)

	=item *

	put_dom($namespace,$storehash,$udomain) : stores hash in namespace at domain level on primary domain server ($udomain is optional)

=back	=back

=head2 Network Status Functions	=head2 Network Status Functions
Line 6752 getfile($file,$caller) : two cases - req	Line 8277 getfile($file,$caller) : two cases - req
- returns the entire contents of a file or -1;	- returns the entire contents of a file or -1;
it properly subscribes to and replicates the file if neccessary.	it properly subscribes to and replicates the file if neccessary.


	=item *

	stat_file($url) : $url is expected to be a /res/ or /uploaded/ style file
	reference

	returns either a stat() list of data about the file or an empty list
	if the file doesn't exist or couldn't find out about it (connection
	problems or user unknown)

=item *	=item *

filelocation($dir,$file) : returns file system location of a file	filelocation($dir,$file) : returns file system location of a file
Line 6852 removeuploadedurl(): convience function	Line 8387 removeuploadedurl(): convience function
Args:	Args:
url: a full /uploaded/... url to delete	url: a full /uploaded/... url to delete

	=item *

	get_portfile_permissions():
	Args:
	domain: domain of user or course contain the portfolio files
	user: name of user or num of course contain the portfolio files
	Returns:
	hashref of a dump of the proper file_permissions.db


	=item *

	get_access_controls():

	Args:
	current_permissions: the hash ref returned from get_portfile_permissions()
	group: (optional) the group you want the files associated with
	file: (optional) the file you want access info on

	Returns:
	a hash (keys are file names) of hashes containing
	keys are: path to file/file_name\0uniqueID:scope_end_start (see below)
	values are XML containing access control settings (see below)

	Internal notes:

	access controls are stored in file_permissions.db as key=value pairs.
	key -> path to file/file_name\0uniqueID:scope_end_start
	where scope -> public,guest,course,group,domains or users.
	end -> UNIX time for end of access (0 -> no end date)
	start -> UNIX time for start of access

	value -> XML description of access control
	<scope type=""> (type =1 of: public,guest,course,group,domains,users">
	<start></start>
	<end></end>

	<password></password> for scope type = guest

	<domain></domain> for scope type = course or group
	<number></number>
	<roles id="">
	<role></role>
	<access></access>
	<section></section>
	<group></group>
	</roles>

	<dom></dom> for scope type = domains

	<users> for scope type = users
	<user>
	<uname></uname>
	<udom></udom>
	</user>
	</users>
	</scope>

	Access data is also aggregated for each file in an additional key=value pair:
	key -> path to file/file_name\0accesscontrol
	value -> reference to hash
	hash contains key = value pairs
	where key = uniqueID:scope_end_start
	value = UNIX time record was last updated

	Used to improve speed of look-ups of access controls for each file.

	Locks on files (resulting from submission of portfolio file to a homework problem stored in array of arrays.

	modify_access_controls():

	Modifies access controls for a portfolio file
	Args
	1. file name
	2. reference to hash of required changes,
	3. domain
	4. username
	where domain,username are the domain of the portfolio owner
	(either a user or a course)

	Returns:
	1. result of additions or updates ('ok' or 'error', with error message).
	2. result of deletions ('ok' or 'error', with error message).
	3. reference to hash of any new or updated access controls.
	4. reference to hash used to map incoming IDs to uniqueIDs assigned to control.
	key = integer (inbound ID)
	value = uniqueID

=back	=back

=head2 HTTP Helper Routines	=head2 HTTP Helper Routines

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

Removed from v.1.651.2.5
changed lines
	Added in v.1.808