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.738 and 1.824.2.5

version 1.738, 2006/05/16 18:50:55	version 1.824.2.5, 2007/05/02 22:01:32
Line 38 use vars	Line 38 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 %domainrolehash $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 %domain_primary	%domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary
$tmpdir $_64bit %env);	$tmpdir $_64bit %env);
Line 52 use Storable qw(lock_store lock_nstore l	Line 52 use Storable qw(lock_store lock_nstore l
use Time::HiRes qw( gettimeofday tv_interval );	use Time::HiRes qw( gettimeofday tv_interval );
use Cache::Memcached;	use Cache::Memcached;
use Digest::MD5;	use Digest::MD5;
	use Math::Random;
	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 278 sub critical {	Line 281 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;
	{
	open(my $idf,"$lonidsdir/$handle.id");
	flock($idf,LOCK_SH);
	@profile=<$idf>;
	close($idf);
	}
	my %temp_env;
	foreach my $line (@profile) {
	if ($line !~ m/=/) {
	return 0;
	}
	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)) {	if (!defined($lonidsdir)) {
$lonidsdir = $perlvar{'lonIDsDir'};	$lonidsdir = $perlvar{'lonIDsDir'};
}	}
Line 289 sub transfer_profile_to_env {	Line 333 sub transfer_profile_to_env {
($handle) = ($env{'user.environment'} =~m\|/([^/]+)\.id$\| );	($handle) = ($env{'user.environment'} =~m\|/([^/]+)\.id$\| );
}	}

my @profile;	my $convert;
{	{
open(my $idf,"$lonidsdir/$handle.id");	open(my $idf,"$lonidsdir/$handle.id");
flock($idf,LOCK_SH);	flock($idf,LOCK_SH);
@profile=<$idf>;	if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",
close($idf);	&GDBM_READER(),0640)) {
	@env{keys(%disk_env)} = @disk_env{keys(%disk_env)};
	untie(%disk_env);
	} else {
	$convert = 1;
	}
}	}
my $envi;	if ($convert) {
my %Remove;	if (!&convert_and_load_session_env($lonidsdir,$handle)) {
for ($envi=0;$envi<=$#profile;$envi++) {	&logthis("Failed to load session, or convert session.");
chomp($profile[$envi]);	}
my ($envname,$envvalue)=split(/=/,$profile[$envi],2);	}
$envname=&unescape($envname);
$envvalue=&unescape($envvalue);	my %remove;
$env{$envname} = $envvalue;	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);
}	}
}	}

	sub timed_flock {
	my ($file,$lock_type) = @_;
	my $failed=0;
	eval {
	local $SIG{__DIE__}='DEFAULT';
	local $SIG{ALRM}=sub {
	$failed=1;
	die("failed lock");
	};
	alarm(13);
	flock($file,$lock_type);
	alarm(0);
	};
	if ($failed) {
	return undef;
	} else {
	return 1;
	}
	}

# ---------------------------------------------------------- Append Environment	# ---------------------------------------------------------- Append Environment

sub appenv {	sub appenv {
Line 330 sub appenv {	Line 401 sub appenv {
$env{$key}=$newenv{$key};	$env{$key}=$newenv{$key};
}	}
}	}
	open(my $env_file,$env{'user.environment'});
my $lockfh;	if (&timed_flock($env_file,LOCK_EX)
unless (open($lockfh,"$env{'user.environment'}")) {	&&
return 'error: '.$!;	tie(my %disk_env,'GDBM_File',$env{'user.environment'},
}	(&GDBM_WRITER()\|&GDBM_NOLOCK()),0640)) {
unless (flock($lockfh,LOCK_EX)) {	while (my ($key,$value) = each(%newenv)) {
&logthis("<font color=\"blue\">WARNING: ".	$disk_env{$key} = $value;
'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],2);
$name=&unescape($name);
$value=&unescape($value);
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 &escape($newname).'='.&escape($newenv{$newname})."\n";
}	}
close($fh);	untie(%disk_env);
}	}

close($lockfh);
return 'ok';	return 'ok';
}	}
# ----------------------------------------------------- Delete from Environment	# ----------------------------------------------------- Delete from Environment
Line 386 sub delenv {	Line 422 sub delenv {
"Attempt to delete from environment ".$delthis);	"Attempt to delete from environment ".$delthis);
return 'error';	return 'error';
}	}
my @oldenv;	open(my $env_file,$env{'user.environment'});
{	if (&timed_flock($env_file,LOCK_EX)
my $fh;	&&
unless (open($fh,"$env{'user.environment'}")) {	tie(my %disk_env,'GDBM_File',$env{'user.environment'},
return 'error';	(&GDBM_WRITER()\|&GDBM_NOLOCK()),0640)) {
}	foreach my $key (keys(%disk_env)) {
unless (flock($fh,LOCK_SH)) {	if ($key=~/^$delthis/) {
&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 my $cur_key (@oldenv) {
my $unescaped_cur_key = &unescape($cur_key);
if ($unescaped_cur_key=~/^$delthis/) {
my ($key) = split('=',$cur_key,2);
$key = &unescape($key);
delete($env{$key});	delete($env{$key});
} else {	delete($disk_env{$key});
print $fh $cur_key;
}	}
}	}
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 479 sub overloaderror {	Line 504 sub overloaderror {

sub spareserver {	sub spareserver {
my ($loadpercent,$userloadpercent,$want_server_name) = @_;	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)) {
if ($want_server_name) {
$spareserver=$tryserver;
} else {
$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 569 sub queryauthenticate {	Line 613 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 645 sub idget {	Line 689 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 656 sub idrget {	Line 700 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 808 sub validate_access_key {	Line 899 sub validate_access_key {
# ------------------------------------- Find the section of student in a course	# ------------------------------------- Find the section of student in a course
sub devalidate_getsection_cache {	sub devalidate_getsection_cache {
my ($udom,$unam,$courseid)=@_;	my ($udom,$unam,$courseid)=@_;
$courseid=~s/\_/\//g;
$courseid=~s/^(\w)/\/$1/;
my $hashid="$udom:$unam:$courseid";	my $hashid="$udom:$unam:$courseid";
&devalidate_cache_new('getsection',$hashid);	&devalidate_cache_new('getsection',$hashid);
}	}

	sub courseid_to_courseurl {
	my ($courseid) = @_;
	#already url style courseid
	return $courseid if ($courseid =~ m{^/});

	if (exists($env{'course.'.$courseid.'.num'})) {
	my $cnum = $env{'course.'.$courseid.'.num'};
	my $cdom = $env{'course.'.$courseid.'.domain'};
	return "/$cdom/$cnum";
	}

	my %courseinfo=&Apache::lonnet::coursedescription($courseid);
	if (exists($courseinfo{'num'})) {
	return "/$courseinfo{'domain'}/$courseinfo{'num'}";
	}

	return undef;
	}

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 839 sub getsection {	Line 945 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',	$courseid = &courseid_to_courseurl($courseid);
&homeserver($unam,$udom)))) {	my %roleshash = &dump('roles',$udom,$unam,$courseid);
my ($key,$value)=split(/\=/,$_);	foreach my $key (keys(%roleshash)) {
$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;
if ($key eq $courseid.'_st') { $section=''; }	if ($key eq $courseid.'_st') { $section=''; }
my ($dummy,$end,$start)=split(/\_/,&unescape($value));	my ($dummy,$end,$start)=split(/\_/,&unescape($roleshash{$key}));
my $now=time;	my $now=time;
if (defined($end) && $end && ($now > $end)) {	if (defined($end) && $end && ($now > $end)) {
$Expired{$end}=$section;	$Expired{$end}=$section;
Line 877 sub save_cache {	Line 982 sub save_cache {
&purge_remembered();	&purge_remembered();
#&Apache::loncommon::validate_page();	#&Apache::loncommon::validate_page();
undef(%env);	undef(%env);
	undef($env_loaded);
}	}

my $to_remember=-1;	my $to_remember=-1;
Line 884 my %remembered;	Line 990 my %remembered;
my %accessed;	my %accessed;
my $kicks=0;	my $kicks=0;
my $hits=0;	my $hits=0;
	sub make_key {
	my ($name,$id) = @_;
	if (length($id) > 65
	&& length(&escape($id)) > 200) {
	$id=length($id).':'.&Digest::MD5::md5_hex($id);
	}
	return &escape($name.':'.$id);
	}

sub devalidate_cache_new {	sub devalidate_cache_new {
my ($name,$id,$debug) = @_;	my ($name,$id,$debug) = @_;
if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }	if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }
$id=&escape($name.':'.$id);	$id=&make_key($name,$id);
$memcache->delete($id);	$memcache->delete($id);
delete($remembered{$id});	delete($remembered{$id});
delete($accessed{$id});	delete($accessed{$id});
Line 895 sub devalidate_cache_new {	Line 1010 sub devalidate_cache_new {

sub is_cached_new {	sub is_cached_new {
my ($name,$id,$debug) = @_;	my ($name,$id,$debug) = @_;
$id=&escape($name.':'.$id);	$id=&make_key($name,$id);
if (exists($remembered{$id})) {	if (exists($remembered{$id})) {
if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); }	if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); }
$accessed{$id}=[&gettimeofday()];	$accessed{$id}=[&gettimeofday()];
Line 918 sub is_cached_new {	Line 1033 sub is_cached_new {

sub do_cache_new {	sub do_cache_new {
my ($name,$id,$value,$time,$debug) = @_;	my ($name,$id,$value,$time,$debug) = @_;
$id=&escape($name.':'.$id);	$id=&make_key($name,$id);
my $setvalue=$value;	my $setvalue=$value;
if (!defined($setvalue)) {	if (!defined($setvalue)) {
$setvalue='__undef__';	$setvalue='__undef__';
Line 927 sub do_cache_new {	Line 1042 sub do_cache_new {
$time=600;	$time=600;
}	}
if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }	if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }
$memcache->set($id,$setvalue,$time);	if (!($memcache->set($id,$setvalue,$time))) {
	&logthis("caching of id -> $id failed");
	}
# need to make a copy of $value	# need to make a copy of $value
#&make_room($id,$value,$debug);	#&make_room($id,$value,$debug);
return $value;	return $value;
Line 1162 sub ssi_body {	Line 1279 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 1170 sub ssi_body {	Line 1287 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 1181 sub ssi {	Line 1307 sub ssi {
$form{'no_update_last_known'}=1;	$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 1384 sub userfileupload {	Line 1510 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
Line 1592 sub removeuploadedurl {	Line 1733 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);
	my $url = "/uploaded/$docudom/$docuname/$fname";
	my ($file,$group) = (&parse_portfolio_url($url))[3,4];
	my $sqlresult =
	&update_portfolio_table($docuname,$docudom,$file,
	'portfolio_metadata',$group,
	'delete');
	}
	}
	return $result;
}	}

sub mkdiruserfile {	sub mkdiruserfile {
Line 1604 sub mkdiruserfile {	Line 1758 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);
	my $url = "/uploaded/$docudom/$docuname/$old";
	my ($file,$group) = (&parse_portfolio_url($url))[3,4];
	my $sqlresult =
	&update_portfolio_table($docuname,$docudom,$file,
	'portfolio_metadata',$group,
	'delete');
	}
	}
	return $result;
}	}

# ------------------------------------------------------------------------- Log	# ------------------------------------------------------------------------- Log
Line 1631 sub flushcourselogs {	Line 1800 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 1648 sub flushcourselogs {	Line 1816 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 1669 sub flushcourselogs {	Line 1837 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_name)/(.*)___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 1690 sub flushcourselogs {	Line 1859 sub flushcourselogs {
}	}
}	}
} else {	} else {
my ($dom,$name) = ($entry=~m:___(\w+)/(\w+)/(.*)___(\w+)$:);	my ($dom,$name) = ($entry=~m{___($match_domain)/($match_name)/(.*)___(\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 1701 sub flushcourselogs {	Line 1870 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 1755 sub courselog {	Line 1923 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 1772 sub courseacclog {	Line 1942 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 1836 sub get_course_adv_roles {	Line 2006 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 1875 sub get_my_roles {	Line 2042 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 1901 sub getannounce {	Line 2068 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 1925 sub courseidput {	Line 2092 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 1952 sub courseiddump {	Line 2119 sub courseiddump {
sub dcmailput {	sub dcmailput {
my ($domain,$msgid,$message,$server)=@_;	my ($domain,$msgid,$message,$server)=@_;
my $status = &Apache::lonnet::critical(	my $status = &Apache::lonnet::critical(
'dcmailput:'.$domain.':'.&Apache::lonnet::escape($msgid).'='.	'dcmailput:'.$domain.':'.&escape($msgid).'='.
&Apache::lonnet::escape($message),$server);	&escape($message),$server);
return $status;	return $status;
}	}

Line 1965 sub dcmaildump {	Line 2132 sub dcmaildump {
&escape($enddate).':';	&escape($enddate).':';
my @esc_senders=map { &escape($_)} @$senders;	my @esc_senders=map { &escape($_)} @$senders;
$cmd.=&escape(join('&',@esc_senders));	$cmd.=&escape(join('&',@esc_senders));
foreach (split(/\&/,&reply($cmd,$domain_primary{$dom}))) {	foreach my $line (split(/\&/,&reply($cmd,$domain_primary{$dom}))) {
my ($key,$value) = split(/\=/,$_);	my ($key,$value) = split(/\=/,$line,2);
if (($key) && ($value)) {	if (($key) && ($value)) {
$returnhash{&unescape($key)} = &unescape($value);	$returnhash{&unescape($key)} = &unescape($value);
}	}
Line 1989 sub get_domain_roles {	Line 2156 sub get_domain_roles {
foreach my $tryserver (keys(%libserv)) {	foreach my $tryserver (keys(%libserv)) {
if ($hostdom{$tryserver} eq $dom) {	if ($hostdom{$tryserver} eq $dom) {
%{$personnel{$tryserver}}=();	%{$personnel{$tryserver}}=();
foreach (	foreach my $line (
split(/\&/,&reply('domrolesdump:'.$dom.':'.	split(/\&/,&reply('domrolesdump:'.$dom.':'.
&escape($startdate).':'.&escape($enddate).':'.	&escape($startdate).':'.&escape($enddate).':'.
&escape($rolelist), $tryserver))) {	&escape($rolelist), $tryserver))) {
my($key,$value) = split(/\=/,$_);	my ($key,$value) = split(/\=/,$line,2);
if (($key) && ($value)) {	if (($key) && ($value)) {
$personnel{$tryserver}{&unescape($key)} = &unescape($value);	$personnel{$tryserver}{&unescape($key)} = &unescape($value);
}	}
Line 2007 sub get_domain_roles {	Line 2174 sub get_domain_roles {

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 2021 sub get_first_access {	Line 2188 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 2215 sub hash2str {	Line 2382 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 2515 sub store {	Line 2682 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 2551 sub cstore {	Line 2718 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 2584 sub restore {	Line 2751 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 2631 sub coursedescription {	Line 2798 sub coursedescription {
if (!$args->{'one_time'}) {	if (!$args->{'one_time'}) {
$envhash{'course.'.$normalid.'.last_cache'}=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 2663 sub privileged {	Line 2834 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 2693 sub rolesinit {	Line 2864 sub rolesinit {
my %allroles=();	my %allroles=();
my %allgroups=();	my %allgroups=();
my $now=time;	my $now=time;
my $userroles="user.login.time=$now\n";	my %userroles = ('user.login.time' => $now);
my $group_privs;	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,$group_privs);
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;
Line 2716 sub rolesinit {	Line 2887 sub rolesinit {
} 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 2732 sub rolesinit {	Line 2905 sub rolesinit {
}	}
}	}
}	}
my ($author,$adv) = &set_userprivs(\$userroles,\%allroles,\%allgroups);	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 2781 sub group_roleprivs {	Line 2954 sub group_roleprivs {
if (($tend!=0) && ($tend<$now)) { $access = 0; }	if (($tend!=0) && ($tend<$now)) { $access = 0; }
if (($tstart!=0) && ($tstart>$now)) { $access=0; }	if (($tstart!=0) && ($tstart>$now)) { $access=0; }
if ($access) {	if ($access) {
my ($course,$group) = ($area =~ m\|(/\w+/\w+)/([^/]+)$\|);	my ($course,$group) = ($area =~ m\|(/$match_domain/$match_courseid)/([^/]+)$\|);
$$allgroups{$course}{$group} .=':'.$group_privs;	$$allgroups{$course}{$group} .=':'.$group_privs;
}	}
}	}
Line 2812 sub set_userprivs {	Line 2985 sub set_userprivs {
if (keys(%{$allgroups}) > 0) {	if (keys(%{$allgroups}) > 0) {
foreach my $role (keys %{$allroles}) {	foreach my $role (keys %{$allroles}) {
my ($trole,$area,$sec,$extendedarea);	my ($trole,$area,$sec,$extendedarea);
if ($role =~ m\|^(\w+)\.(/\w+/\w+)(/?\w*)\|) {	if ($role =~ m-^(\w+\|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)-) {
$trole = $1;	$trole = $1;
$area = $2;	$area = $2;
$sec = $3;	$sec = $3;
Line 2827 sub set_userprivs {	Line 3000 sub set_userprivs {
}	}
}	}
}	}
foreach (keys(%grouproles)) {	foreach my $group (keys(%grouproles)) {
$$allroles{$_} = $grouproles{$_};	$$allroles{$group} = $grouproles{$group};
}	}
foreach (keys %{$allroles}) {	foreach my $role (keys(%{$allroles})) {
my %thesepriv=();	my %thesepriv;
if (($_=~/^au/) \|\| ($_=~/^ca/)) { $author=1; }	if (($role=~/^au/) \|\| ($role=~/^ca/)) { $author=1; }
foreach (split(/:/,$$allroles{$_})) {	foreach my $item (split(/:/,$$allroles{$role})) {
if ($_ ne '') {	if ($item ne '') {
my ($privilege,$restrictions)=split(/&/,$_);	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 2845 sub set_userprivs {	Line 3018 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 2856 sub set_userprivs {	Line 3031 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 2871 sub get {	Line 3046 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 2883 sub get {	Line 3058 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 2897 sub del {	Line 3072 sub del {
# -------------------------------------------------------------- dump interface	# -------------------------------------------------------------- dump interface

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

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

	sub dumpstore {
my ($namespace,$udomain,$uname,$regexp,$range)=@_;	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'}; }
Line 2906 sub dump {	Line 3105 sub dump {
} else {	} else {
$regexp='.';	$regexp='.';
}	}
my $rep=reply("dump:$udomain:$uname:$namespace:$regexp:$range",$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(/=/,$_,2);	my ($key,$value)=split(/=/,$item,2);
$returnhash{unescape($key)}=&thaw_unescape($value);	next if ($key =~ /^error: 2 /);
	$returnhash{$key}=&thaw_unescape($value);
}	}
return %returnhash;	return %returnhash;
}	}

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

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

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

sub getkeys {	sub getkeys {
Line 2932 sub getkeys {	Line 3125 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($_));	next if ($key =~ /^error: 2 /);
	push(@keyarray,&unescape($key));
}	}
return @keyarray;	return @keyarray;
}	}
Line 2953 sub currentdump {	Line 3147 sub currentdump {
if ($rep eq "unknown_cmd") {	if ($rep eq "unknown_cmd") {
# an old lond will not know currentdump	# an old lond will not know currentdump
# Do a dump and make it look like a currentdump	# Do a dump and make it look like a currentdump
my @tmp = &dump($courseid,$sdom,$sname,'.');	my @tmp = &dumpstore($courseid,$sdom,$sname,'.');
return if ($tmp[0] =~ /^(error:\|no_such_host)/);	return if ($tmp[0] =~ /^(error:\|no_such_host)/);
my %hash = @tmp;	my %hash = @tmp;
@tmp=();	@tmp=();
%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 2978 sub convert_dump_to_currentdump{	Line 3172 sub convert_dump_to_currentdump{
# we might run in to problems with parameter names =~ /^v\./	# we might run in to problems with parameter names =~ /^v\./
while (my ($key,$value) = each(%hash)) {	while (my ($key,$value) = each(%hash)) {
my ($v,$symb,$param) = split(/:/,$key);	my ($v,$symb,$param) = split(/:/,$key);
	$symb = &unescape($symb);
	$param = &unescape($param);
next if ($v eq 'version' \|\| $symb eq 'keys');	next if ($v eq 'version' \|\| $symb eq 'keys');
next if (exists($returnhash{$symb}) &&	next if (exists($returnhash{$symb}) &&
exists($returnhash{$symb}->{$param}) &&	exists($returnhash{$symb}->{$param}) &&
Line 3039 sub put {	Line 3235 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 3092 sub old_putstore {	Line 3288 sub old_putstore {
if (!$uname) { $uname=$env{'user.name'}; }	if (!$uname) { $uname=$env{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);	my $uhome=&homeserver($uname,$udomain);
my %newstorehash;	my %newstorehash;
foreach (keys %$storehash) {	foreach my $item (keys(%$storehash)) {
my $key = $version.':'.&escape($symb).':'.$_;	my $key = $version.':'.&escape($symb).':'.$item;
$newstorehash{$key} = $storehash->{$_};	$newstorehash{$key} = $storehash->{$item};
}	}
my $items='';	my $items='';
my %allitems = ();	my %allitems = ();
foreach (keys %newstorehash) {	foreach my $item (keys(%newstorehash)) {
if ($_ =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) {	if ($item =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) {
my $key = $1.':keys:'.$2;	my $key = $1.':keys:'.$2;
$allitems{$key} .= $3.':';	$allitems{$key} .= $3.':';
}	}
$items.=$_.'='.&freeze_escape($newstorehash{$_}).'&';	$items.=$item.'='.&freeze_escape($newstorehash{$item}).'&';
}	}
foreach (keys %allitems) {	foreach my $item (keys(%allitems)) {
$allitems{$_} =~ s/\:$//;	$allitems{$item} =~ s/\:$//;
$items.= $_.'='.$allitems{$_}.'&';	$items.= $item.'='.$allitems{$item}.'&';
}	}
$items=~s/\&$//;	$items=~s/\&$//;
return &reply("put:$udomain:$uname:$namespace:$items",$uhome);	return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
Line 3121 sub cput {	Line 3317 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 3133 sub cput {	Line 3329 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 3144 sub eget {	Line 3340 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;
Line 3153 sub eget {	Line 3349 sub eget {

# ------------------------------------------------------------ tmpput interface	# ------------------------------------------------------------ tmpput interface
sub tmpput {	sub tmpput {
my ($storehash,$server)=@_;	my ($storehash,$server,$context)=@_;
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/\&$//;
	if (defined($context)) {
	$items .= ':'.&escape($context);
	}
return &reply("tmpput:$items",$server);	return &reply("tmpput:$items",$server);
}	}

Line 3182 sub tmpdel {	Line 3381 sub tmpdel {
return &reply("tmpdel:$token",$server);	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) {
	my %setters;
	if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
	my ($startblock,$endblock) =
	&Apache::loncommon::blockcheck(\%setters,'port',$unum,$udom);
	if ($startblock && $endblock) {
	return 'B';
	}
	} else {
	my ($startblock,$endblock) =
	&Apache::loncommon::blockcheck(\%setters,'port');
	if ($startblock && $endblock) {
	return 'B';
	}
	}
	}
	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 (ref($access_hash->{$userkey}{'users'}) eq 'ARRAY') {
	foreach my $item (@{$access_hash->{$userkey}{'users'}}) {
	if (ref($item) eq 'HASH') {
	if (($item->{'uname'} eq $env{'user.name'}) &&
	($item->{'udom'} eq $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_courseid)/?([^/]*)$-) {
	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_courseid)/?([^/])$-) {
	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\|editupload)/($match_domain)/($match_username)/portfolio(/.+)$-) {
	$type = 1;
	$udom = $1;
	$unum = $2;
	$file_name = $3;
	} elsif ($url =~ m-^/*(?:uploaded\|editupload)/($match_domain)/($match_courseid)/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\/\w+\/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 (undef,$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 3219 sub customaccess {	Line 3663 sub customaccess {
# ------------------------------------------------- Check for a user privilege	# ------------------------------------------------- Check for a user privilege

sub allowed {	sub allowed {
my ($priv,$uri,$symb)=@_;	my ($priv,$uri,$symb,$role)=@_;
my $ver_orguri=$uri;	my $ver_orguri=$uri;
$uri=&deversion($uri);	$uri=&deversion($uri);
my $orguri=$uri;	my $orguri=$uri;
$uri=&declutter($uri);	$uri=&declutter($uri);

	if ($priv eq 'evb') {
	# Evade communication block restrictions for specified role in a course
	if ($env{'user.priv.'.$role} =~/evb\&([^\:]*)/) {
	return $1;
	} else {
	return;
	}
	}

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';
}	}

Line 3236 sub allowed {	Line 3690 sub allowed {
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[0])) {	($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) {
return 'F';	my %setters;
	my ($startblock,$endblock) =
	&Apache::loncommon::blockcheck(\%setters,'port');
	if ($startblock && $endblock) {
	return 'B';
	} else {
	return 'F';
	}
}	}

# bre access to group if user has rgf priv for this group and course.	# bre access to group portfolio for rgf priv in group, or mdg or vcg in course.
if (($space=~/^(uploaded\|editupload)$/) && ($dir[0] eq 'groups')	if (($space=~/^(uploaded\|editupload)$/) && ($dir[0] eq 'groups')
&& ($dir[2] eq 'portfolio') && ($priv eq 'bre')) {	&& ($dir[2] eq 'portfolio') && ($priv eq 'bre')) {
if (exists($env{'request.course.id'})) {	if (exists($env{'request.course.id'})) {
Line 3251 sub allowed {	Line 3712 sub allowed {
if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid	if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid
.'/'.$dir[1]} =~/rgf\&([^\:]*)/) {	.'/'.$dir[1]} =~/rgf\&([^\:]*)/) {
return $1;	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;
	}
}	}
}	}
}	}
Line 3319 sub allowed {	Line 3788 sub allowed {
$thisallowed.=$1;	$thisallowed.=$1;
}	}

# Group: uri itself is a group
my $groupuri=$uri;
$groupuri=~s/^([^\/])/\/$1/;
if ($env{'user.priv.'.$env{'request.role'}.'.'.$groupuri}
=~/\Q$priv\E\&([^\:]*)/) {
$thisallowed.=$1;
}

# URI is an uploaded document for this course, default permissions don't matter	# 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/\|)) {
Line 3353 sub allowed {	Line 3814 sub allowed {
}	}
}	}

	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 3400 sub allowed {	Line 3868 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 3503 sub allowed {	Line 3971 sub allowed {
#	#

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

#	#
Line 3566 sub allowed {	Line 4040 sub allowed {
}	}
}	}

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

Line 3618 sub get_symb_from_alias {	Line 4097 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 3627 sub definerole {	Line 4106 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 3636 sub definerole {	Line 4115 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 3684 sub log_query {	Line 4163 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; }
return get_query_reply($queryid);	return get_query_reply($queryid);
}	}

	# -------------------------- Update MySQL table for portfolio file

	sub update_portfolio_table {
	my ($uname,$udom,$file_name,$query,$group,$action) = @_;
	my $homeserver = &homeserver($uname,$udom);
	my $queryid=
	&reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group).
	':'.&escape($file_name).':'.$action,$homeserver);
	my $reply = &get_query_reply($queryid);
	return $reply;
	}

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

sub fetch_enrollment_query {	sub fetch_enrollment_query {
Line 3705 sub fetch_enrollment_query {	Line 4196 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 3727 sub fetch_enrollment_query {	Line 4218 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 3812 sub auto_run {	Line 4303 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 3823 sub auto_get_sections {	Line 4314 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 3897 sub auto_photoupdate {	Line 4388 sub auto_photoupdate {
my $host=$hostname{$homeserver};	my $host=$hostname{$homeserver};
my $cmd = '';	my $cmd = '';
my $maxtries = 1;	my $maxtries = 1;
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 3929 sub auto_photoupdate {	Line 4420 sub auto_photoupdate {
}	}

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';
	} 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';	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	# ------------------------------------------------------- Course Group routines

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

sub modify_coursegroup {	sub modify_coursegroup {
Line 3973 sub modify_coursegroup {	Line 4515 sub modify_coursegroup {
return(&put('coursegroups',$groupsettings,$cdom,$cnum));	return(&put('coursegroups',$groupsettings,$cdom,$cnum));
}	}

	sub toggle_coursegroup_status {
	my ($cdom,$cnum,$group,$action) = @_;
	my ($from_namespace,$to_namespace);
	if ($action eq 'delete') {
	$from_namespace = 'coursegroups';
	$to_namespace = 'deleted_groups';
	} else {
	$from_namespace = 'deleted_groups';
	$to_namespace = 'coursegroups';
	}
	my %curr_group = &get_coursegroups($cdom,$cnum,$group,$from_namespace);
	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($to_namespace,\%savedsettings,$cdom,$cnum);
	my $deloutcome;
	if ($result eq 'ok') {
	$deloutcome = &del($from_namespace,[$group],$cdom,$cnum);
	} else {
	return ('write error',$result);
	}
	if ($deloutcome eq 'ok') {
	return 'ok';
	} else {
	return ('delete error',$deloutcome);
	}
	}
	}

sub modify_group_roles {	sub modify_group_roles {
my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs) = @_;	my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs) = @_;
my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;	my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;
Line 3982 sub modify_group_roles {	Line 4555 sub modify_group_roles {
if ($result eq 'ok') {	if ($result eq 'ok') {
&devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);	&devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);
}	}

return $result;	return $result;
}	}

Line 3997 sub get_active_groups {	Line 4569 sub get_active_groups {
my $now = time;	my $now = time;
my %groups = ();	my %groups = ();
foreach my $key (keys(%env)) {	foreach my $key (keys(%env)) {
if ($key =~ m-user\.role\.gr\./([^/]+)/([^/]+)/(\w+)$-) {	if ($key =~ m-user\.role\.gr\./($match_domain)/($match_courseid)/(\w+)$-) {
my ($start,$end) = split(/\./,$env{$key});	my ($start,$end) = split(/\./,$env{$key});
if (($end!=0) && ($end<$now)) { next; }	if (($end!=0) && ($end<$now)) { next; }
if (($start!=0) && ($start>$now)) { next; }	if (($start!=0) && ($start>$now)) { next; }
Line 4018 sub get_users_groups {	Line 4590 sub get_users_groups {
my ($udom,$uname,$courseid) = @_;	my ($udom,$uname,$courseid) = @_;
my @usersgroups;	my @usersgroups;
my $cachetime=1800;	my $cachetime=1800;
$courseid=~s/\_/\//g;
$courseid=~s/^(\w)/\/$1/;

my $hashid="$udom:$uname:$courseid";	my $hashid="$udom:$uname:$courseid";
my ($grouplist,$cached)=&is_cached_new('getgroups',$hashid);	my ($grouplist,$cached)=&is_cached_new('getgroups',$hashid);
Line 4027 sub get_users_groups {	Line 4597 sub get_users_groups {
@usersgroups = split(/:/,$grouplist);	@usersgroups = split(/:/,$grouplist);
} else {	} else {
$grouplist = '';	$grouplist = '';
my %roleshash = &dump('roles',$udom,$uname,$courseid);	my $courseurl = &courseid_to_courseurl($courseid);
my ($tmp) = keys(%roleshash);	my %roleshash = &dump('roles',$udom,$uname,$courseurl);
if ($tmp=~/^error:/) {	my $access_end = $env{'course.'.$courseid.
&logthis('Error retrieving roles: '.$tmp.' for '.$uname.':'.$udom);	'.default_enrollment_end_date'};
} else {	my $now = time;
my $access_end = $env{'course.'.$courseid.	foreach my $key (keys(%roleshash)) {
'.default_enrollment_end_date'};	if ($key =~ /^\Q$courseurl\E\/(\w+)\_gr$/) {
my $now = time;	my $group = $1;
foreach my $key (keys(%roleshash)) {	if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) {
if ($key =~ /^\Q$courseid\E\/(\w+)\_gr$/) {	my $start = $2;
my $group = $1;	my $end = $1;
if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) {	if ($start == -1) { next; } # deleted from group
my $start = $2;	if (($start!=0) && ($start>$now)) { next; }
my $end = $1;	if (($end!=0) && ($end<$now)) {
if ($start == -1) { next; } # deleted from group	if ($access_end && $access_end < $now) {
if (($start!=0) && ($start>$now)) { next; }	if ($access_end - $end < 86400) {
if (($end!=0) && ($end<$now)) {	push(@usersgroups,$group);
if ($access_end && $access_end < $now) {
if ($access_end - $end < 86400) {
push(@usersgroups,$group);
}
}	}
next;
}	}
push(@usersgroups,$group);	next;
}	}
	push(@usersgroups,$group);
}	}
}	}
@usersgroups = &sort_course_groups($courseid,@usersgroups);
$grouplist = join(':',@usersgroups);
&do_cache_new('getgroups',$hashid,$grouplist,$cachetime);
}	}
	@usersgroups = &sort_course_groups($courseid,@usersgroups);
	$grouplist = join(':',@usersgroups);
	&do_cache_new('getgroups',$hashid,$grouplist,$cachetime);
}	}
return @usersgroups;	return @usersgroups;
}	}
Line 4066 sub get_users_groups {	Line 4632 sub get_users_groups {
sub devalidate_getgroups_cache {	sub devalidate_getgroups_cache {
my ($udom,$uname,$cdom,$cnum)=@_;	my ($udom,$uname,$cdom,$cnum)=@_;
my $courseid = $cdom.'_'.$cnum;	my $courseid = $cdom.'_'.$cnum;
$courseid=~s/\_/\//g;
$courseid=~s/^(\w)/\/$1/;
my $hashid="$udom:$uname:$courseid";	my $hashid="$udom:$uname:$courseid";
&devalidate_cache_new('getgroups',$hashid);	&devalidate_cache_new('getgroups',$hashid);
}	}
Line 4075 sub devalidate_getgroups_cache {	Line 4640 sub devalidate_getgroups_cache {
# ------------------------------------------------------------------ Plain Text	# ------------------------------------------------------------------ Plain Text

sub plaintext {	sub plaintext {
my $short=shift;	my ($short,$type,$cid) = @_;
return &Apache::lonlocal::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 4086 sub assignrole {	Line 4671 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_courseid)\/.*/$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 4096 sub assignrole {	Line 4681 sub assignrole {
$mrole='cr';	$mrole='cr';
} elsif ($role =~ /^gr\//) {	} elsif ($role =~ /^gr\//) {
my $cwogrp=$url;	my $cwogrp=$url;
$cwogrp=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;	$cwogrp=~s{^/($match_domain)/($match_courseid)/.*}{$1/$2};
unless (&allowed('mdg',$cwogrp)) {	unless (&allowed('mdg',$cwogrp)) {
&logthis('Refused group assignrole: '.	&logthis('Refused group assignrole: '.
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.	$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
Line 4106 sub assignrole {	Line 4691 sub assignrole {
$mrole='gr';	$mrole='gr';
} else {	} else {
my $cwosec=$url;	my $cwosec=$url;
$cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;	$cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$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 4125 sub assignrole {	Line 4710 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 4142 sub assignrole {	Line 4729 sub assignrole {
# 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($role,$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 4179 sub modifyuser {	Line 4771 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 4329 sub modify_student_enrollment {	Line 4921 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 4388 sub writecoursepref {	Line 4980 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 4398 sub writecoursepref {	Line 4990 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)) {
Line 4435 sub createcourse {	Line 5028 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 4463 ENDINITMAP	Line 5057 ENDINITMAP
return '/'.$udom.'/'.$uname;	return '/'.$udom.'/'.$uname;
}	}

	sub is_course {
	my ($cdom,$cnum) = @_;
	my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,
	undef,'.');
	if (exists($courses{$cdom.'_'.$cnum})) {
	return 1;
	}
	return 0;
	}

# ---------------------------------------------------------- Assign Custom Role	# ---------------------------------------------------------- Assign Custom Role

sub assigncustomrole {	sub assigncustomrole {
Line 4505 sub is_locked {	Line 5109 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 4521 sub mark_as_readonly {	Line 5139 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 4579 sub files_not_in_path {	Line 5198 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_marked_as_readonly {	sub get_portfile_permissions {
my ($domain,$user,$what) = @_;	my ($domain,$user) = @_;
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);
	my ($file,$group);
	if (&is_course($domain,$user)) {
	($group,$file) = split(/\//,$file_name,2);
	} else {
	$file = $file_name;
	}
	my $sqlresult =
	&update_portfolio_table($user,$domain,$file,'portfolio_access',
	$group);
	} 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 4649 sub get_marked_as_readonly_hash {	Line 5428 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 4706 sub dirlist {	Line 5489 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 4736 sub dirlist {	Line 5518 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 4787 sub dirlist {	Line 5565 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 4806 sub GetFileTimestamp {	Line 5584 sub GetFileTimestamp {

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

# we want just the url part without the unneeded accessor url bits
if ($uri =~ m-^/adm/-) {
$uri=~s-^/adm/wrapper/-/-;
$uri=~s-^/adm/coursedocs/showdoc/-/-;
}
my ($udom,$uname,$file,$dir);	my ($udom,$uname,$file,$dir);
if ($uri =~ m-^/(uploaded\|editupload)/-) {	if ($uri =~ m-^/(uploaded\|editupload)/-) {
($udom,$uname,$file) =	($udom,$uname,$file) =
($uri =~ m-/(?:uploaded\|editupload)/?([^/])/?([^/])/?(.*)-);	($uri =~ m-/(?:uploaded\|editupload)/?($match_domain)/?($match_name)/?(.*)-);
$file = 'userfiles/'.$file;	$file = 'userfiles/'.$file;
$dir = &Apache::loncommon::propath($udom,$uname);	$dir = &propath($udom,$uname);
}	}
if ($uri =~ m-^/res/-) {	if ($uri =~ m-^/res/-) {
($udom,$uname) =	($udom,$uname) =
($uri =~ m-/(?:res)/?([^/])/?([^/])/-);	($uri =~ m-/(?:res)/?($match_domain)/?($match_username)/-);
$file = $uri;	$file = $uri;
}	}

Line 4929 sub devalidatecourseresdata {	Line 5702 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 5043 sub EXT {	Line 5817 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 5067 sub EXT {	Line 5840 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 5275 sub EXT {	Line 6054 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 5394 sub metadata {	Line 6176 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 5425 sub metadata {	Line 6207 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 5644 sub metadata_generate_part0 {	Line 6426 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 5678 sub gettitle {	Line 6471 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'};
}	}
Line 5727 sub symblist {	Line 6520 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=~s/^\/adm\/coursedocs\/showdoc\///;
$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 5753 sub symbverify {	Line 6543 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 5902 sub symbread {	Line 6692 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 6012 sub latest_rnd_algorithm_id {	Line 6802 sub latest_rnd_algorithm_id {

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 6038 sub getCODE {	Line 6828 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 6046 sub rndseed {	Line 6836 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 '64bit5') {	if ($which eq '64bit5') {
return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);	return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);
Line 6079 sub rndseed_32bit {	Line 6870 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 6100 sub rndseed_64bit {	Line 6891 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 6124 sub rndseed_64bit2 {	Line 6914 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 6146 sub rndseed_64bit3 {	Line 6937 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 6170 sub rndseed_64bit4 {	Line 6961 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";
Line 6195 sub rndseed_CODE_64bit {	Line 6986 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 6214 sub rndseed_CODE_64bit4 {	Line 7005 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";
Line 6276 sub ireceipt {	Line 7067 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 6300 sub ireceipt {	Line 7090 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 6326 sub repcopy_userfile {	Line 7154 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_name)/+(.*)\|);
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 6357 sub repcopy_userfile {	Line 7185 sub repcopy_userfile {
} else {	} else {
my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);	my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);
if ($lwpresp ne 'ok') {	if ($lwpresp ne 'ok') {
my $ua=new LWP::UserAgent;	return -1;
my $request=new HTTP::Request('GET',&tokenwrapper($uri));
my $response=$ua->request($request);
if ($response->is_success()) {
$info=$response->content;
} else {
return -1;
}
}	}
my @parts = ($cdom,$cnum);	my @parts = ($cdom,$cnum);
if ($filename =~ m\|^(.+)/[^/]+$\|) {	if ($filename =~ m\|^(.+)/[^/]+$\|) {
Line 6427 sub readfile {	Line 7248 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 6443 sub filelocation {	Line 7264 sub filelocation {
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_name)/+(.*)$-);
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 6485 sub hreflocation {	Line 7306 sub hreflocation {
}	}
if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) {	if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) {
$file=~s-^\Q$perlvar{'lonDocRoot'}\E--;	$file=~s-^\Q$perlvar{'lonDocRoot'}\E--;
} elsif ($file=~m-/home/(\w+)/public_html/-) {	} elsif ($file=~m-/home/($match_username)/public_html/-) {
$file=~s-^/home/(\w+)/public_html/-/~$1/-;	$file=~s-^/home/($match_username)/public_html/-/~$1/-;
} elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) {	} elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) {
$file=~s-^/home/httpd/lonUsers/([^/])/./././([^/])/userfiles/	$file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/
-/uploaded/$1/$2/-x;	-/uploaded/$1/$2/-x;
}	}
return $file;	return $file;
Line 6518 sub current_machine_ids {	Line 7339 sub current_machine_ids {
return @ids;	return @ids;
}	}

	sub additional_machine_domains {
	my @domains;
	open(my $fh,"<$perlvar{'lonTabDir'}/expected_domains.tab");
	while( my $line = <$fh>) {
	$line =~ s/\s//g;
	push(@domains,$line);
	}
	return @domains;
	}

	sub default_login_domain {
	my $domain = $perlvar{'lonDefDomain'};
	my $testdomain=(split(/\./,$ENV{'HTTP_HOST'}))[0];
	foreach my $posdom (&current_machine_domains(),
	&additional_machine_domains()) {
	if (lc($posdom) eq lc($testdomain)) {
	$domain=$posdom;
	last;
	}
	}
	return $domain;
	}

# ------------------------------------------------------------- Declutters URLs	# ------------------------------------------------------------- Declutters URLs

sub declutter {	sub declutter {
Line 6566 sub clutter {	Line 7410 sub clutter {
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 6575 sub freeze_escape {	Line 7428 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 6633 BEGIN {	Line 7471 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 6665 BEGIN {	Line 7482 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, $primary) = 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 6737 sub get_iphost {	Line 7554 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 6763 sub get_iphost {	Line 7582 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 6793 sub get_iphost {	Line 7618 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;
Line 6990 B<delenv($regexp)>: removes all items fr	Line 7817 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 7052 passed in @what from the requested user'	Line 7886 passed in @what from the requested user'

=item *	=item *

allowed($priv,$uri) : check for a user privilege; returns codes for allowed	allowed($priv,$uri,$symb,$role) : check for a user privilege; returns codes for allowed actions
actions
F: full access	F: full access
U,I,K: authentication modes (cxx only)	U,I,K: authentication modes (cxx only)
'': 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 7458 cput($namespace,$storehash,$udom,$uname)	Line 8292 cput($namespace,$storehash,$udom,$uname)

=item *	=item *

	newput($namespace,$storehash,$udom,$uname) :

	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 *

eget($namespace,$storearr,$udom,$uname) : returns hash with keys from array	eget($namespace,$storearr,$udom,$uname) : returns hash with keys from array
reference filled in from namesp (encrypts the return communication)	reference filled in from namesp (encrypts the return communication)
($udom and $uname are optional)	($udom and $uname are optional)
Line 7467 reference filled in from namesp (encrypt	Line 8326 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 7692 removeuploadedurl(): convience function	Line 8560 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.738
changed lines
	Added in v.1.824.2.5