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.740 and 1.858

version 1.740, 2006/05/30 12:47:18	version 1.858, 2007/04/03 17:51:50
Line 35 use HTTP::Headers;	Line 35 use HTTP::Headers;
use HTTP::Date;	use HTTP::Date;
# use Date::Parse;	# use Date::Parse;
use vars	use vars
qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom	qw(%perlvar %badServerCache %spareid
%libserv %pr %prp $memcache %packagetab	%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
%domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary
$tmpdir $_64bit %env);	$tmpdir $_64bit %env);

use IO::Socket;	use IO::Socket;
Line 52 use Storable qw(lock_store lock_nstore l	Line 50 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 lib '/home/httpd/lib/perl';	use Math::Random;
use LONCAPA;	use LONCAPA qw(:DEFAULT :match);
use LONCAPA::Configuration;	use LONCAPA::Configuration;

my $readit;	my $readit;
Line 146 sub logperm {	Line 144 sub logperm {
return 1;	return 1;
}	}

	sub create_connection {
	my ($hostname,$lonid) = @_;
	my $client=IO::Socket::UNIX->new(Peer => $perlvar{'lonSockCreate'},
	Type => SOCK_STREAM,
	Timeout => 10);
	return 0 if (!$client);
	print $client (join(':',$hostname,$lonid,&machine_ids($lonid))."\n");
	my $result = <$client>;
	chomp($result);
	return 1 if ($result eq 'done');
	return 0;
	}


# -------------------------------------------------- Non-critical communication	# -------------------------------------------------- Non-critical communication
sub subreply {	sub subreply {
my ($cmd,$server)=@_;	my ($cmd,$server)=@_;
my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server};	my $peerfile="$perlvar{'lonSockDir'}/".&hostname($server);
#	#
# With loncnew process trimming, there's a timing hole between lonc server	# With loncnew process trimming, there's a timing hole between lonc server
# process exit and the master server picking up the listen on the AF_UNIX	# process exit and the master server picking up the listen on the AF_UNIX
Line 172 sub subreply {	Line 184 sub subreply {
Timeout => 10);	Timeout => 10);
if($client) {	if($client) {
last; # Connected!	last; # Connected!
	} else {
	&create_connection(&hostname($server),$server);
}	}
sleep(1); # Try again later if failed connection.	sleep(1); # Try again later if failed connection.
}	}
my $answer;	my $answer;
if ($client) {	if ($client) {
Line 189 sub subreply {	Line 203 sub subreply {

sub reply {	sub reply {
my ($cmd,$server)=@_;	my ($cmd,$server)=@_;
unless (defined($hostname{$server})) { return 'no_such_host'; }	unless (defined(&hostname($server))) { return 'no_such_host'; }
my $answer=subreply($cmd,$server);	my $answer=subreply($cmd,$server);
if (($answer=~/^refused/) \|\| ($answer=~/^rejected/)) {	if (($answer=~/^refused/) \|\| ($answer=~/^rejected/)) {
&logthis("<font color=\"blue\">WARNING:".	&logthis("<font color=\"blue\">WARNING:".
Line 201 sub reply {	Line 215 sub reply {
# ----------------------------------------------------------- Send USR1 to lonc	# ----------------------------------------------------------- Send USR1 to lonc

sub reconlonc {	sub reconlonc {
my $peerfile=shift;	&logthis("Trying to reconnect lonc");
&logthis("Trying to reconnect for $peerfile");
my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";	my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
if (open(my $fh,"<$loncfile")) {	if (open(my $fh,"<$loncfile")) {
my $loncpid=<$fh>;	my $loncpid=<$fh>;
Line 211 sub reconlonc {	Line 224 sub reconlonc {
&logthis("lonc at pid $loncpid responding, sending USR1");	&logthis("lonc at pid $loncpid responding, sending USR1");
kill USR1 => $loncpid;	kill USR1 => $loncpid;
sleep 1;	sleep 1;
if (-e "$peerfile") { return; }	} else {
&logthis("$peerfile still not there, give it another try");
sleep 5;
if (-e "$peerfile") { return; }
&logthis(
"<font color=\"blue\">WARNING: $peerfile still not there, giving up</font>");
} else {
&logthis(	&logthis(
"<font color=\"blue\">WARNING:".	"<font color=\"blue\">WARNING:".
" lonc at pid $loncpid not responding, giving up</font>");	" lonc at pid $loncpid not responding, giving up</font>");
}	}
} else {	} else {
&logthis('<font color="blue">WARNING: lonc not running, giving up</font>');	&logthis('<font color="blue">WARNING: lonc not running, giving up</font>');
}	}
}	}

Line 231 sub reconlonc {	Line 238 sub reconlonc {

sub critical {	sub critical {
my ($cmd,$server)=@_;	my ($cmd,$server)=@_;
unless ($hostname{$server}) {	unless (&hostname($server)) {
&logthis("<font color=\"blue\">WARNING:".	&logthis("<font color=\"blue\">WARNING:".
" Critical message to unknown server ($server)</font>");	" Critical message to unknown server ($server)</font>");
return 'no_such_host';	return 'no_such_host';
Line 281 sub critical {	Line 288 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 292 sub transfer_profile_to_env {	Line 340 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 333 sub appenv {	Line 408 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>;	untie(%disk_env);
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);
}

close($lockfh);
return 'ok';	return 'ok';
}	}
# ----------------------------------------------------- Delete from Environment	# ----------------------------------------------------- Delete from Environment
Line 389 sub delenv {	Line 429 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 482 sub overloaderror {	Line 511 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 572 sub queryauthenticate {	Line 620 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,1);
if (!$uhome) {	if ((!$uhome) \|\| ($uhome eq 'no_host')) {
&logthis("User $uname at $udom is unknown in authenticate");	# Maybe the machine was offline and only re-appeared again recently?
	&reconlonc();
	# One more
	my $uhome=&homeserver($uname,$udom,1);
	if ((!$uhome) \|\| ($uhome eq 'no_host')) {
	&logthis("User $uname at $udom is unknown in authenticate");
	}
return 'no_host';	return 'no_host';
}	}
my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome);	my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome);
Line 600 sub homeserver {	Line 654 sub homeserver {
my $index="$uname:$udom";	my $index="$uname:$udom";

if (exists($homecache{$index})) { return $homecache{$index}; }	if (exists($homecache{$index})) { return $homecache{$index}; }
my $tryserver;
foreach $tryserver (keys %libserv) {	my %servers = &get_servers($udom,'library');
	foreach my $tryserver (keys(%servers)) {
next if ($ignoreBadCache ne 'true' &&	next if ($ignoreBadCache ne 'true' &&
exists($badServerCache{$tryserver}));	exists($badServerCache{$tryserver}));
if ($hostdom{$tryserver} eq $udom) {
my $answer=reply("home:$udom:$uname",$tryserver);	my $answer=reply("home:$udom:$uname",$tryserver);
if ($answer eq 'found') {	if ($answer eq 'found') {
return $homecache{$index}=$tryserver;	delete($badServerCache{$tryserver});
} elsif ($answer eq 'no_host') {	return $homecache{$index}=$tryserver;
$badServerCache{$tryserver}=1;	} elsif ($answer eq 'no_host') {
}	$badServerCache{$tryserver}=1;
}	}
}	}
return 'no_host';	return 'no_host';
}	}
Line 622 sub idget {	Line 677 sub idget {
my ($udom,@ids)=@_;	my ($udom,@ids)=@_;
my %returnhash=();	my %returnhash=();

my $tryserver;	my %servers = &get_servers($udom,'library');
foreach $tryserver (keys %libserv) {	foreach my $tryserver (keys(%servers)) {
if ($hostdom{$tryserver} eq $udom) {	my $idlist=join('&',@ids);
my $idlist=join('&',@ids);	$idlist=~tr/A-Z/a-z/;
$idlist=~tr/A-Z/a-z/;	my $reply=&reply("idget:$udom:".$idlist,$tryserver);
my $reply=&reply("idget:$udom:".$idlist,$tryserver);	my @answer=();
my @answer=();	if (($reply ne 'con_lost') && ($reply!~/^error\:/)) {
if (($reply ne 'con_lost') && ($reply!~/^error\:/)) {	@answer=split(/\&/,$reply);
@answer=split(/\&/,$reply);	} ;
} ;	my $i;
my $i;	for ($i=0;$i<=$#ids;$i++) {
for ($i=0;$i<=$#ids;$i++) {	if ($answer[$i]) {
if ($answer[$i]) {	$returnhash{$ids[$i]}=$answer[$i];
$returnhash{$ids[$i]}=$answer[$i];	}
}	}
}	}
}
}
return %returnhash;	return %returnhash;
}	}

Line 648 sub idget {	Line 701 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 659 sub idrget {	Line 712 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 (defined(&domain($udom,'primary'))) {
	my $uhome=&domain($udom,'primary');
	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 (defined(&domain($udom,'primary'))) {
	my $uhome=&domain($udom,'primary');
	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");
	}
	}

	sub retrieve_inst_usertypes {
	my ($udom) = @_;
	my (%returnhash,@order);
	if (defined(&domain($udom,'primary'))) {
	my $uhome=&domain($udom,'primary');
	my $rep=&reply("inst_usertypes:$udom",$uhome);
	my ($hashitems,$orderitems) = split(/:/,$rep);
	my @pairs=split(/\&/,$hashitems);
	foreach my $item (@pairs) {
	my ($key,$value)=split(/=/,$item,2);
	$key = &unescape($key);
	next if ($key =~ /^error: 2 /);
	$returnhash{$key}=&thaw_unescape($value);
	}
	my @esc_order = split(/\&/,$orderitems);
	foreach my $item (@esc_order) {
	push(@order,&unescape($item));
	}
	} else {
	&logthis("get_dom failed - no primary domain server for $udom");
	}
	return (\%returnhash,\@order);
	}

# --------------------------------------------------- Assign a key to a student	# --------------------------------------------------- Assign a key to a student

sub assign_access_key {	sub assign_access_key {
Line 811 sub validate_access_key {	Line 935 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 842 sub getsection {	Line 981 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 880 sub save_cache {	Line 1018 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 887 my %remembered;	Line 1026 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) > 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 898 sub devalidate_cache_new {	Line 1043 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 921 sub is_cached_new {	Line 1066 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 1099 sub repcopy {	Line 1244 sub repcopy {
}	}
$filename=~s/[\n\r]//g;	$filename=~s/[\n\r]//g;
my $transname="$filename.in.transfer";	my $transname="$filename.in.transfer";
	# FIXME: this should flock
if ((-e $filename) \|\| (-e $transname)) { return 'ok'; }	if ((-e $filename) \|\| (-e $transname)) { return 'ok'; }
my $remoteurl=subscribe($filename);	my $remoteurl=subscribe($filename);
if ($remoteurl =~ /^con_lost by/) {	if ($remoteurl =~ /^con_lost by/) {
Line 1165 sub ssi_body {	Line 1311 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 1173 sub ssi_body {	Line 1319 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 1184 sub ssi {	Line 1339 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 1338 sub store_edited_file {	Line 1493 sub store_edited_file {
}	}

sub clean_filename {	sub clean_filename {
my ($fname)=@_;	my ($fname,$args)=@_;
# Replace Windows backslashes by forward slashes	# Replace Windows backslashes by forward slashes
$fname=~s/\\/\//g;	$fname=~s/\\/\//g;
# Get rid of everything but the actual filename	if (!$args->{'keep_path'}) {
$fname=~s/^.*\/([^\/]+)$/$1/;	# Get rid of everything but the actual filename
	$fname=~s/^.*\/([^\/]+)$/$1/;
	}
# Replace spaces by underscores	# Replace spaces by underscores
$fname=~s/\s+/\_/g;	$fname=~s/\s+/\_/g;
# Replace all other weird characters by nothing	# Replace all other weird characters by nothing
$fname=~s/[^\w\.\-]//g;	$fname=~s{[^/\w\.\-]}{}g;
# Replace all .\d. sequences with _\d. so they no longer look like version	# Replace all .\d. sequences with _\d. so they no longer look like version
# numbers	# numbers
$fname=~s/\.(\d+)(?=\.)/_$1/g;	$fname=~s/\.(\d+)(?=\.)/_$1/g;
Line 1359 sub clean_filename {	Line 1516 sub clean_filename {
# $coursedoc - if true up to the current course	# $coursedoc - if true up to the current course
# if false	# if false
# $subdir - directory in userfile to store the file into	# $subdir - directory in userfile to store the file into
# $parser, $allfiles, $codebase - unknown	# $parser - instruction to parse file for objects ($parser = parse)
#	# $allfiles - reference to hash for embedded objects
	# $codebase - reference to hash for codebase of java objects
	# $desuname - username for permanent storage of uploaded file
	# $dsetudom - domain for permanaent storage of uploaded file
	#
# output: url of file in userspace, or error: <message>	# output: url of file in userspace, or error: <message>
# or /adm/notfound.html if failure to upload occurse	# or /adm/notfound.html if failure to upload occurse

Line 1387 sub userfileupload {	Line 1548 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 1463 sub finishuserfileupload {	Line 1639 sub finishuserfileupload {
' for embedded media: '.$parse_result);	' for embedded media: '.$parse_result);
}	}
}	}

# Notify homeserver to grep it	# Notify homeserver to grep it
#	#
my $docuhome=&homeserver($docuname,$docudom);	my $docuhome=&homeserver($docuname,$docudom);
Line 1475 sub finishuserfileupload {	Line 1652 sub finishuserfileupload {
&logthis('Failed to transfer '.$path.$file.' to host '.$docuhome.	&logthis('Failed to transfer '.$path.$file.' to host '.$docuhome.
': '.$fetchresult);	': '.$fetchresult);
return '/adm/notfound.html';	return '/adm/notfound.html';
}	}
}	}

sub extract_embedded_items {	sub extract_embedded_items {
Line 1595 sub removeuploadedurl {	Line 1772 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 1607 sub mkdiruserfile {	Line 1797 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 1634 sub flushcourselogs {	Line 1839 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 1651 sub flushcourselogs {	Line 1855 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 $crs_home (keys(%courseidbuffer)) {
&courseidput($hostdom{$_},$courseidbuffer{$_},$_);	&courseidput(&host_domain($crs_home),$courseidbuffer{$crs_home},
	$crs_home);
}	}
#	#
# File accesses	# File accesses
Line 1672 sub flushcourselogs {	Line 1877 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 1693 sub flushcourselogs {	Line 1899 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 1704 sub flushcourselogs {	Line 1910 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 1730 sub flushcourselogs {	Line 1935 sub flushcourselogs {
delete $domainrolehash{$entry};	delete $domainrolehash{$entry};
}	}
foreach my $dom (keys(%domrolebuffer)) {	foreach my $dom (keys(%domrolebuffer)) {
foreach my $tryserver (keys %libserv) {	my %servers = &get_servers($dom,'library');
if ($hostdom{$tryserver} eq $dom) {	foreach my $tryserver (keys(%servers)) {
unless (&reply('domroleput:'.$dom.':'.	unless (&reply('domroleput:'.$dom.':'.
$domrolebuffer{$dom},$tryserver) eq 'ok') {	$domrolebuffer{$dom},$tryserver) eq 'ok') {
&logthis('Put of domain roles failed for '.$dom.' and '.$tryserver);	&logthis('Put of domain roles failed for '.$dom.' and '.$tryserver);
}	}
}
}	}
}	}
$dumpcount++;	$dumpcount++;
Line 1758 sub courselog {	Line 1962 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 1775 sub courseacclog {	Line 1981 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 1839 sub get_course_adv_roles {	Line 2045 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 1871 sub get_course_adv_roles {	Line 2074 sub get_course_adv_roles {
}	}

sub get_my_roles {	sub get_my_roles {
my ($uname,$udom)=@_;	my ($uname,$udom,$context,$types,$roles,$roledoms)=@_;
unless (defined($uname)) { $uname=$env{'user.name'}; }	unless (defined($uname)) { $uname=$env{'user.name'}; }
unless (defined($udom)) { $udom=$env{'user.domain'}; }	unless (defined($udom)) { $udom=$env{'user.domain'}; }
my %dumphash=	my %dumphash;
	if ($context eq 'userroles') {
	%dumphash = &dump('roles',$udom,$uname);
	} else {
	%dumphash=
&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; }	my $status = 'active';
if (($tstart) && ($now<$tstart)) { next; }	if (($tend) && ($tend<$now)) {
my ($role,$username,$domain,$section)=split(/\:/,$_);	$status = 'previous';
	}
	if (($tstart) && ($now<$tstart)) {
	$status = 'future';
	}
	if (ref($types) eq 'ARRAY') {
	if (!grep(/^\Q$status\E$/,@{$types})) {
	next;
	}
	} else {
	if ($status ne 'active') {
	next;
	}
	}
	my ($role,$username,$domain,$section)=split(/\:/,$entry);
	if (ref($roledoms) eq 'ARRAY') {
	if (!grep(/^\Q$domain\E$/,@{$roledoms})) {
	next;
	}
	}
	if (ref($roles) eq 'ARRAY') {
	if (!grep(/^\Q$role\E$/,@{$roles})) {
	next;
	}
	}
$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;	$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
}	}
return %returnhash;	return %returnhash;
}	}

Line 1895 sub get_my_roles {	Line 2127 sub get_my_roles {

sub postannounce {	sub postannounce {
my ($server,$text)=@_;	my ($server,$text)=@_;
unless (&allowed('psa',$hostdom{$server})) { return 'refused'; }	unless (&allowed('psa',&host_domain($server))) { return 'refused'; }
unless ($text=~/\w/) { $text=''; }	unless ($text=~/\w/) { $text=''; }
return &reply('setannounce:'.&escape($text),$server);	return &reply('setannounce:'.&escape($text),$server);
}	}
Line 1904 sub getannounce {	Line 2136 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 1928 sub courseidput {	Line 2160 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) {	my %libserv = &all_library();
if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) \|\| (!defined($hostidflag)) ) {	foreach my $tryserver (keys(%libserv)) {
if ((!$domfilter) \|\| ($hostdom{$tryserver} eq $domfilter)) {	if ( ( $hostidflag == 1
foreach (	&& grep(/^\Q$tryserver\E$/,@{$hostidref}) )
split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.	\|\| (!defined($hostidflag)) ) {

	if ($domfilter eq ''
	\|\| (&host_domain($tryserver) eq $domfilter)) {
	foreach my $line (
	split(/\&/,&reply('courseiddump:'.&host_domain($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 1963 sub dcmailput {	Line 2200 sub dcmailput {
sub dcmaildump {	sub dcmaildump {
my ($dom,$startdate,$enddate,$senders) = @_;	my ($dom,$startdate,$enddate,$senders) = @_;
my %returnhash=();	my %returnhash=();
if (exists($domain_primary{$dom})) {
	if (defined(&domain($dom,'primary'))) {
my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'.	my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'.
&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($dom,'primary')))) {
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 2227 sub get_domain_roles {
}	}
my $rolelist = join(':',@{$roles});	my $rolelist = join(':',@{$roles});
my %personnel = ();	my %personnel = ();
foreach my $tryserver (keys(%libserv)) {
if ($hostdom{$tryserver} eq $dom) {	my %servers = &get_servers($dom,'library');
%{$personnel{$tryserver}}=();	foreach my $tryserver (keys(%servers)) {
foreach (	%{$personnel{$tryserver}}=();
split(/\&/,&reply('domrolesdump:'.$dom.':'.	foreach my $line (split(/\&/,&reply('domrolesdump:'.$dom.':'.
&escape($startdate).':'.&escape($enddate).':'.	&escape($startdate).':'.
&escape($rolelist), $tryserver))) {	&escape($enddate).':'.
my($key,$value) = split(/\=/,$_);	&escape($rolelist), $tryserver))) {
if (($key) && ($value)) {	my ($key,$value) = split(/\=/,$line,2);
$personnel{$tryserver}{&unescape($key)} = &unescape($value);	if (($key) && ($value)) {
}	$personnel{$tryserver}{&unescape($key)} = &unescape($value);
}	}
}	}
}	}
return %personnel;	return %personnel;
}	}
Line 2010 sub get_domain_roles {	Line 2248 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 2024 sub get_first_access {	Line 2262 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 2091 sub checkin {	Line 2329 sub checkin {
my $now=time;	my $now=time;
my ($ta,$tb,$lonhost)=split(/\*/,$token);	my ($ta,$tb,$lonhost)=split(/\*/,$token);
$lonhost=~tr/A-Z/a-z/;	$lonhost=~tr/A-Z/a-z/;
my $dtoken=$ta.'_'.$hostname{$lonhost}.'_'.$tb;	my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb;
$dtoken=~s/\W/\_/g;	$dtoken=~s/\W/\_/g;
my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=	my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));	split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
Line 2218 sub hash2str {	Line 2456 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 2518 sub store {	Line 2756 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 2554 sub cstore {	Line 2792 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 2587 sub restore {	Line 2825 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 2634 sub coursedescription {	Line 2872 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 2666 sub privileged {	Line 2908 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 2696 sub rolesinit {	Line 2938 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 2719 sub rolesinit {	Line 2961 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 2735 sub rolesinit {	Line 2979 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 {
my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;	my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;
my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);	my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
my $homsvr=homeserver($rauthor,$rdomain);	my $homsvr=homeserver($rauthor,$rdomain);
if ($hostname{$homsvr} ne '') {	if (&hostname($homsvr) ne '') {
my ($rdummy,$roledef)=	my ($rdummy,$roledef)=
&get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);	&get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);
if (($rdummy ne 'con_lost') && ($roledef ne '')) {	if (($rdummy ne 'con_lost') && ($roledef ne '')) {
Line 2784 sub group_roleprivs {	Line 3028 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 2815 sub set_userprivs {	Line 3059 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 2830 sub set_userprivs {	Line 3074 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 2848 sub set_userprivs {	Line 3092 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 2859 sub set_userprivs {	Line 3105 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 2874 sub get {	Line 3120 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 2886 sub get {	Line 3132 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 2900 sub del {	Line 3146 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 2909 sub dump {	Line 3179 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 2935 sub getkeys {	Line 3199 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 2956 sub currentdump {	Line 3221 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 2981 sub convert_dump_to_currentdump{	Line 3246 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 3042 sub put {	Line 3309 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 3095 sub old_putstore {	Line 3362 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 3124 sub cput {	Line 3391 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 3136 sub cput {	Line 3403 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 3147 sub eget {	Line 3414 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 3156 sub eget {	Line 3423 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 3185 sub tmpdel {	Line 3455 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 (exists($access_hash->{$userkey}{'users'}{$env{'user.name'}.':'.$env{'user.domain'}})) {
	return 'ok';
	}
	}
	}
	my %roleshash;
	my @courses_and_groups = @courses;
	push(@courses_and_groups,@groups);
	if (@courses_and_groups > 0) {
	my (%allgroups,%allroles);
	my ($start,$end,$role,$sec,$group);
	foreach my $envkey (%env) {
	if ($envkey =~ m-^user\.role\.(gr\|cc\|in\|ta\|ep\|st)\./($match_domain)/($match_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 3222 sub customaccess {	Line 3730 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 3239 sub allowed {	Line 3757 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 3254 sub allowed {	Line 3779 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 3322 sub allowed {	Line 3855 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 3356 sub allowed {	Line 3881 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 3403 sub allowed {	Line 3935 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 3506 sub allowed {	Line 4038 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 3569 sub allowed {	Line 4107 sub allowed {
}	}
}	}

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

Line 3621 sub get_symb_from_alias {	Line 4164 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 3630 sub definerole {	Line 4173 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 3639 sub definerole {	Line 4182 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 3663 sub definerole {	Line 4206 sub definerole {
sub metadata_query {	sub metadata_query {
my ($query,$custom,$customshow,$server_array)=@_;	my ($query,$custom,$customshow,$server_array)=@_;
my %rhash;	my %rhash;
	my %libserv = &all_library();
my @server_list = (defined($server_array) ? @$server_array	my @server_list = (defined($server_array) ? @$server_array
: keys(%libserv) );	: keys(%libserv) );
for my $server (@server_list) {	for my $server (@server_list) {
Line 3686 sub log_query {	Line 4230 sub log_query {
my ($uname,$udom,$query,%filters)=@_;	my ($uname,$udom,$query,%filters)=@_;
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 3706 sub fetch_enrollment_query {	Line 4262 sub fetch_enrollment_query {
} else {	} else {
$homeserver = &homeserver($cnum,$dom);	$homeserver = &homeserver($cnum,$dom);
}	}
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 3730 sub fetch_enrollment_query {	Line 4286 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 3803 sub courselog_query {	Line 4359 sub courselog_query {
}	}

sub userlog_query {	sub userlog_query {
	#
	# possible filters:
	# action: log check role
	# start: timestamp
	# end: timestamp
	#
my ($uname,$udom,%filters)=@_;	my ($uname,$udom,%filters)=@_;
return &log_query($uname,$udom,'userlog',%filters);	return &log_query($uname,$udom,'userlog',%filters);
}	}
Line 3815 sub auto_run {	Line 4377 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 3826 sub auto_get_sections {	Line 4388 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_photochoice {	Line 4459 sub auto_photochoice {
sub auto_photoupdate {	sub auto_photoupdate {
my ($affiliatesref,$dom,$cnum,$photo) = @_;	my ($affiliatesref,$dom,$cnum,$photo) = @_;
my $homeserver = &homeserver($cnum,$dom);	my $homeserver = &homeserver($cnum,$dom);
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 3932 sub auto_photoupdate {	Line 4494 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) {	my %servers = &get_servers($codedom,'library');
if ($hostdom{$tryserver} eq $codedom) {	foreach my $tryserver (keys(%servers)) {
$homeserver = $tryserver;	if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
last;	push(@homeservers,$tryserver);
}	}
}
if (($env{'user.name'}) && ($env{'user.domain'} eq $codedom)) {
$homeserver = &homeserver($env{'user.name'},$codedom);
}	}
} else {	} else {
$homeserver = &homeserver($caller,$codedom);	push(@homeservers,&homeserver($caller,$codedom));
}	}
foreach (keys %{$instcodes}) {	foreach my $code (keys(%{$instcodes})) {
$courses .= &escape($_).'='.&escape($$instcodes{$_}).'&';	$courses .= &escape($code).'='.&escape($$instcodes{$code}).'&';
}	}
chop($courses);	chop($courses);
my $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$homeserver);	my $ok_response = 0;
unless ($response =~ /(con_lost\|error\|no_such_host\|refused)/) {	my $response;
my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = split/:/,$response;	while (@homeservers > 0 && $ok_response == 0) {
%{$codes} = &str2hash($codes_str);	my $server = shift(@homeservers);
@{$codetitles} = &str2array($codetitles_str);	$response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server);
%{$cat_titles} = &str2hash($cat_titles_str);	if ($response !~ /(con_lost\|error\|no_such_host\|refused)/) {
%{$cat_order} = &str2hash($cat_order_str);	my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) =
	split/:/,$response;
	%{$codes} = (%{$codes},&str2hash($codes_str));
	push(@{$codetitles},&str2array($codetitles_str));
	%{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str));
	%{$cat_order} = (%{$cat_order},&str2hash($cat_order_str));
	$ok_response = 1;
	}
	}
	if ($ok_response) {
return 'ok';	return 'ok';
	} else {
	return $response;
}	}
	}

	sub auto_instcode_defaults {
	my ($domain,$returnhash,$code_order) = @_;
	my @homeservers;

	my %servers = &get_servers($domain,'library');
	foreach my $tryserver (keys(%servers)) {
	if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
	push(@homeservers,$tryserver);
	}
	}

	my $response;
	foreach my $server (@homeservers) {
	$response=&reply('autoinstcodedefaults:'.$domain,$server);
	next 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);
	}
	}
	return 'ok';
	}

	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 3976 sub modify_coursegroup {	Line 4584 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 3999 sub get_active_groups {	Line 4638 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 4020 sub get_users_groups {	Line 4659 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 4029 sub get_users_groups {	Line 4666 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 4068 sub get_users_groups {	Line 4701 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 4077 sub devalidate_getgroups_cache {	Line 4709 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 4088 sub assignrole {	Line 4740 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 4098 sub assignrole {	Line 4750 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 4108 sub assignrole {	Line 4760 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 4188 sub modifyuser {	Line 4840 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 4202 sub modifyuser {	Line 4854 sub modifyuser {
if (($uhome eq 'no_host') &&	if (($uhome eq 'no_host') &&
(($umode && $upass) \|\| ($umode eq 'localauth'))) {	(($umode && $upass) \|\| ($umode eq 'localauth'))) {
my $unhome='';	my $unhome='';
if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) {	if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) {
$unhome = $desiredhome;	$unhome = $desiredhome;
} elsif($env{'course.'.$env{'request.course.id'}.'.domain'} eq $udom) {	} elsif($env{'course.'.$env{'request.course.id'}.'.domain'} eq $udom) {
$unhome=$env{'course.'.$env{'request.course.id'}.'.home'};	$unhome=$env{'course.'.$env{'request.course.id'}.'.home'};
} else { # load balancing routine for determining $unhome	} else { # load balancing routine for determining $unhome
my $tryserver;
my $loadm=10000000;	my $loadm=10000000;
foreach $tryserver (keys %libserv) {	my %servers = &get_servers($udom,'library');
if ($hostdom{$tryserver} eq $udom) {	foreach my $tryserver (keys(%servers)) {
my $answer=reply('load',$tryserver);	my $answer=reply('load',$tryserver);
if (($answer=~/\d+/) && ($answer<$loadm)) {	if (($answer=~/\d+/) && ($answer<$loadm)) {
$loadm=$answer;	$loadm=$answer;
$unhome=$tryserver;	$unhome=$tryserver;
}	}
}
}	}
}	}
if (($unhome eq '') \|\| ($unhome eq 'no_host')) {	if (($unhome eq '') \|\| ($unhome eq 'no_host')) {
Line 4338 sub modify_student_enrollment {	Line 4988 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 4397 sub writecoursepref {	Line 5047 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 4407 sub writecoursepref {	Line 5057 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 4430 sub createcourse {	Line 5081 sub createcourse {
}	}
# ------------------------------------------------ Check supplied server name	# ------------------------------------------------ Check supplied server name
$course_server = $env{'user.homeserver'} if (! defined($course_server));	$course_server = $env{'user.homeserver'} if (! defined($course_server));
if (! exists($libserv{$course_server})) {	if (! &is_library($course_server)) {
return 'error:bad server name '.$course_server;	return 'error:bad server name '.$course_server;
}	}
# ------------------------------------------------------------- Make the course	# ------------------------------------------------------------- Make the course
Line 4444 sub createcourse {	Line 5095 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 4472 ENDINITMAP	Line 5124 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 4514 sub is_locked {	Line 5176 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) = @_;
	$file =~ s{^(/portfolio/\|portfolio/)}{/};
	return $file;
	}

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

sub mark_as_readonly {	sub mark_as_readonly {
Line 4530 sub mark_as_readonly {	Line 5204 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 4588 sub files_not_in_path {	Line 5263 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);
	}

	sub make_public_indefinitely {
	my ($requrl) = @_;
	my $now = time;
	my $action = 'activate';
	my $aclnum = 0;
	if (&is_portfolio_url($requrl)) {
	my (undef,$udom,$unum,$file_name,$group) =
	&parse_portfolio_url($requrl);
	my $current_perms = &get_portfile_permissions($udom,$unum);
	my %access_controls = &get_access_controls($current_perms,
	$group,$file_name);
	foreach my $key (keys(%{$access_controls{$file_name}})) {
	my ($num,$scope,$end,$start) =
	($key =~ /^([^:]+):([a-z]+)_(\d)_?(\d)$/);
	if ($scope eq 'public') {
	if ($start <= $now && $end == 0) {
	$action = 'none';
	} else {
	$action = 'update';
	$aclnum = $num;
	}
	last;
	}
	}
	if ($action eq 'none') {
	return 'ok';
	} else {
	my %changes;
	my $newend = 0;
	my $newstart = $now;
	my $newkey = $aclnum.':public_'.$newend.'_'.$newstart;
	$changes{$action}{$newkey} = {
	type => 'public',
	time => {
	start => $newstart,
	end => $newend,
	},
	};
	my ($outcome,$deloutcome,$new_values,$translation) =
	&modify_access_controls($file_name,\%changes,$udom,$unum);
	return $outcome;
	}
	} else {
	return 'invalid';
	}
	}

	#------------------------------------------------------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 4658 sub get_marked_as_readonly_hash {	Line 5540 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 4715 sub dirlist {	Line 5601 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=();	my %servers = &get_servers($udom,'library');
foreach $tryserver (keys %libserv) {	foreach my $tryserver (keys(%servers)) {
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 =	map { &unescape($_); } split(/:/,$listing);
map { &unescape($_); } split(/:/,$listing);	}
}	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 my $line (@listing_results) {
foreach (@listing_results) {	my ($entry) = split(/&/,$line,2);
my ($entry,@stat)=split(/&/,$_);	$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 @all_domains = sort(&all_domains());
my %alldom=();	foreach my $domain (@all_domains) {
foreach $tryserver (keys %libserv) {	$domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain';
$alldom{$hostdom{$tryserver}}=1;	}
}	return @all_domains;
my $alldomstr='';	} else {
foreach (sort keys %alldom) {	return ('missing domain');
$alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'/&domain:';
}
$alldomstr=~s/:$//;
return split(/:/,$alldomstr);
} else {
my @emptyResults = ();
push(@emptyResults, 'missing domain');
return split(':',@emptyResults);
}	}
}	}

Line 4796 sub dirlist {	Line 5670 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 4815 sub GetFileTimestamp {	Line 5689 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 = &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 4938 sub devalidatecourseresdata {	Line 5807 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 5052 sub EXT {	Line 5922 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 5076 sub EXT {	Line 5945 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 5284 sub EXT {	Line 6159 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 5336 sub packages_tab_default {	Line 6214 sub packages_tab_default {
$do_default=1;	$do_default=1;
} elsif ($pack_type eq 'extension') {	} elsif ($pack_type eq 'extension') {
push(@extension,[$package,$pack_type,$pack_part]);	push(@extension,[$package,$pack_type,$pack_part]);
} else {	} elsif ($pack_part eq $part) {
	# only look at packages defaults for packages that this id is
push(@specifics,[$package,$pack_type,$pack_part]);	push(@specifics,[$package,$pack_type,$pack_part]);
}	}
}	}
Line 5403 sub metadata {	Line 6282 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 5434 sub metadata {	Line 6313 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 5653 sub metadata_generate_part0 {	Line 6532 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 5687 sub gettitle {	Line 6577 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 5736 sub symblist {	Line 6626 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 5762 sub symbverify {	Line 6649 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 5911 sub symbread {	Line 6798 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 6021 sub latest_rnd_algorithm_id {	Line 6908 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 6046 sub getCODE {	Line 6933 sub getCODE {

sub rndseed {	sub rndseed {
my ($symb,$courseid,$domain,$username)=@_;	my ($symb,$courseid,$domain,$username)=@_;
	my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser();
my ($wsymb,$wcourseid,$wdomain,$wusername)=&Apache::lonxml::whichuser();
if (!$symb) {	if (!$symb) {
unless ($symb=$wsymb) { return time; }	unless ($symb=$wsymb) { return time; }
}	}
Line 6055 sub rndseed {	Line 6941 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 6088 sub rndseed_32bit {	Line 6975 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 6109 sub rndseed_64bit {	Line 6996 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 6133 sub rndseed_64bit2 {	Line 7019 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 6155 sub rndseed_64bit3 {	Line 7042 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 6179 sub rndseed_64bit4 {	Line 7066 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 6204 sub rndseed_CODE_64bit {	Line 7091 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 6223 sub rndseed_CODE_64bit4 {	Line 7110 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 6249 sub setup_random_from_rndseed {	Line 7136 sub setup_random_from_rndseed {
}	}

sub latest_receipt_algorithm_id {	sub latest_receipt_algorithm_id {
return 'receipt2';	return 'receipt3';
}	}

sub recunique {	sub recunique {
my $fucourseid=shift;	my $fucourseid=shift;
my $unique;	my $unique;
if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') {	if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' \|\|
	$env{"course.$fucourseid.receiptalg"} eq 'receipt3' ) {
$unique=$env{"course.$fucourseid.internal.encseed"};	$unique=$env{"course.$fucourseid.internal.encseed"};
} else {	} else {
$unique=$perlvar{'lonReceipt'};	$unique=$perlvar{'lonReceipt'};
Line 6266 sub recunique {	Line 7154 sub recunique {
sub recprefix {	sub recprefix {
my $fucourseid=shift;	my $fucourseid=shift;
my $prefix;	my $prefix;
if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') {	if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2'\|\|
	$env{"course.$fucourseid.receiptalg"} eq 'receipt3' ) {
$prefix=$env{"course.$fucourseid.internal.encpref"};	$prefix=$env{"course.$fucourseid.internal.encpref"};
} else {	} else {
$prefix=$perlvar{'lonHostID'};	$prefix=$perlvar{'lonHostID'};
Line 6276 sub recprefix {	Line 7165 sub recprefix {

sub ireceipt {	sub ireceipt {
my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_;	my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_;

	my $return =&recprefix($fucourseid).'-';

	if ($env{"course.$fucourseid.receiptalg"} eq 'receipt3' \|\|
	$env{'request.state'} eq 'construct') {
	$return .= (&digest("$funame,$fudom,$fucourseid,$fusymb,$part")%10000);
	return $return;
	}

my $cuname=unpack("%32C*",$funame);	my $cuname=unpack("%32C*",$funame);
my $cudom=unpack("%32C*",$fudom);	my $cudom=unpack("%32C*",$fudom);
my $cucourseid=unpack("%32C*",$fucourseid);	my $cucourseid=unpack("%32C*",$fucourseid);
my $cusymb=unpack("%32C*",$fusymb);	my $cusymb=unpack("%32C*",$fusymb);
my $cunique=&recunique($fucourseid);	my $cunique=&recunique($fucourseid);
my $cpart=unpack("%32S*",$part);	my $cpart=unpack("%32S*",$part);
my $return =&recprefix($fucourseid).'-';	if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') {
if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' \|\|
$env{'request.state'} eq 'construct') {	#&logthis("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname)." and ".($cpart%$cudom));
&Apache::lonxml::debug("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname).
" and ".($cpart%$cudom));

$return.= ($cunique%$cuname+	$return.= ($cunique%$cuname+
$cunique%$cudom+	$cunique%$cudom+
Line 6309 sub ireceipt {	Line 7205 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 6335 sub repcopy_userfile {	Line 7269 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 $uri="/uploaded/$cdom/$cnum/$filename";	my $uri="/uploaded/$cdom/$cnum/$filename";
if (-e "$file") {	if (-e "$file") {
	# we already have a local copy, check it out
my @fileinfo = stat($file);	my @fileinfo = stat($file);
	my $rtncode;
	my $info;
my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode);	my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode);
if ($lwpresp ne 'ok') {	if ($lwpresp ne 'ok') {
	# there is no such file anymore, even though we had a local copy
if ($rtncode eq '404') {	if ($rtncode eq '404') {
unlink($file);	unlink($file);
}	}
#my $ua=new LWP::UserAgent;
#my $request=new HTTP::Request('GET',&tokenwrapper($uri));
#my $response=$ua->request($request);
#if ($response->is_success()) {
# return $response->content;
# } else {
# return -1;
# }
return -1;	return -1;
}	}
if ($info < $fileinfo[9]) {	if ($info < $fileinfo[9]) {
	# nice, the file we have is up-to-date, just say okay
return 'ok';	return 'ok';
	} else {
	# the file is outdated, get rid of it
	unlink($file);
}	}
$info = '';	}
$lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);	# one way or the other, at this point, we don't have the file
if ($lwpresp ne 'ok') {	# construct the correct path for the file
return -1;	my @parts = ($cdom,$cnum);
}	if ($filename =~ m\|^(.+)/[^/]+$\|) {
} else {	push @parts, split(/\//,$1);
my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);	}
if ($lwpresp ne 'ok') {	my $path = $perlvar{'lonDocRoot'}.'/userfiles';
my $ua=new LWP::UserAgent;	foreach my $part (@parts) {
my $request=new HTTP::Request('GET',&tokenwrapper($uri));	$path .= '/'.$part;
my $response=$ua->request($request);	if (!-e $path) {
if ($response->is_success()) {	mkdir($path,0770);
$info=$response->content;
} else {
return -1;
}
}
my @parts = ($cdom,$cnum);
if ($filename =~ m\|^(.+)/[^/]+$\|) {
push @parts, split(/\//,$1);
}
my $path = $perlvar{'lonDocRoot'}.'/userfiles';
foreach my $part (@parts) {
$path .= '/'.$part;
if (!-e $path) {
mkdir($path,0770);
}
}	}
}	}
open(FILE,">$file");	# now the path exists for sure
print FILE $info;	# get a user agent
close(FILE);	my $ua=new LWP::UserAgent;
	my $transferfile=$file.'.in.transfer';
	# FIXME: this should flock
	if (-e $transferfile) { return 'ok'; }
	my $request;
	$uri=~s/^\///;
	$request=new HTTP::Request('GET','http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri);
	my $response=$ua->request($request,$transferfile);
	# did it work?
	if ($response->is_error()) {
	unlink($transferfile);
	&logthis("Userfile repcopy failed for $uri");
	return -1;
	}
	# worked, rename the transfer file
	rename($transferfile,$file);
return 'ok';	return 'ok';
}	}

Line 6403 sub tokenwrapper {	Line 7336 sub tokenwrapper {
if ($udom && $uname && $file) {	if ($udom && $uname && $file) {
$file=~s\|(\?\.)$\|\|;	$file=~s\|(\?\.)$\|\|;
&appenv("userfile.$udom/$uname/$file" => $env{'request.course.id'});	&appenv("userfile.$udom/$uname/$file" => $env{'request.course.id'});
return 'http://'.$hostname{ &homeserver($uname,$udom)}.'/'.$uri.	return 'http://'.&hostname(&homeserver($uname,$udom)).'/'.$uri.
(($uri=~/\?/)?'&':'?').'token='.$token.	(($uri=~/\?/)?'&':'?').'token='.$token.
'&tokenissued='.$perlvar{'lonHostID'};	'&tokenissued='.$perlvar{'lonHostID'};
} else {	} else {
Line 6411 sub tokenwrapper {	Line 7344 sub tokenwrapper {
}	}
}	}

	# call with reqtype HEAD: get last modification time
	# call with reqtype GET: get the file contents
	# Do not call this with reqtype GET for large files! It loads everything into memory
	#
sub getuploaded {	sub getuploaded {
my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;	my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
$uri=~s/^\///;	$uri=~s/^\///;
$uri = 'http://'.$hostname{ &homeserver($cnum,$cdom)}.'/raw/'.$uri;	$uri = 'http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri;
my $ua=new LWP::UserAgent;	my $ua=new LWP::UserAgent;
my $request=new HTTP::Request($reqtype,$uri);	my $request=new HTTP::Request($reqtype,$uri);
my $response=$ua->request($request);	my $response=$ua->request($request);
Line 6436 sub readfile {	Line 7373 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 6452 sub filelocation {	Line 7389 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();
Line 6494 sub hreflocation {	Line 7431 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;
}	}

sub current_machine_domains {	sub current_machine_domains {
my $hostname=$hostname{$perlvar{'lonHostID'}};	return &machine_domains(&hostname($perlvar{'lonHostID'}));
	}

	sub machine_domains {
	my ($hostname) = @_;
my @domains;	my @domains;
	my %hostname = &all_hostnames();
while( my($id, $name) = each(%hostname)) {	while( my($id, $name) = each(%hostname)) {
# &logthis("-$id-$name-$hostname-");	# &logthis("-$id-$name-$hostname-");
if ($hostname eq $name) {	if ($hostname eq $name) {
push(@domains,$hostdom{$id});	push(@domains,&host_domain($id));
}	}
}	}
return @domains;	return @domains;
}	}

sub current_machine_ids {	sub current_machine_ids {
my $hostname=$hostname{$perlvar{'lonHostID'}};	return &machine_ids(&hostname($perlvar{'lonHostID'}));
	}

	sub machine_ids {
	my ($hostname) = @_;
	$hostname \|\|= &hostname($perlvar{'lonHostID'});
my @ids;	my @ids;
	my %hostname = &all_hostnames();
while( my($id, $name) = each(%hostname)) {	while( my($id, $name) = each(%hostname)) {
# &logthis("-$id-$name-$hostname-");	# &logthis("-$id-$name-$hostname-");
if ($hostname eq $name) {	if ($hostname eq $name) {
Line 6527 sub current_machine_ids {	Line 7475 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 6575 sub clutter {	Line 7546 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 6624 sub goodbye {	Line 7604 sub goodbye {
}	}

BEGIN {	BEGIN {

# ----------------------------------- Read loncapa.conf and loncapa_apache.conf	# ----------------------------------- Read loncapa.conf and loncapa_apache.conf
unless ($readit) {	unless ($readit) {
{	{
# FIXME: Use LONCAPA::Configuration::read_conf here and omit next block	my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf');
open(my $config,"</etc/httpd/conf/loncapa.conf");	%perlvar = (%perlvar,%{$configvars});
	}

while (my $configline=<$config>) {	sub get_dns {
if ($configline=~/\S/ && $configline =~ /^[^\#]*PerlSetVar/) {	my ($url,$func) = @_;
my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);	open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
chomp($varvalue);	foreach my $dns (<$config>) {
$perlvar{$varname}=$varvalue;	next if ($dns !~ /^\^(\S*)/x);
}	$dns = $1;
	my $ua=new LWP::UserAgent;
	my $request=new HTTP::Request('GET',"http://$dns$url");
	my $response=$ua->request($request);
	next if ($response->is_error());
	my @content = split("\n",$response->content);
	&$func(\@content);
}	}
close($config);	close($config);
}	}
	# ------------------------------------------------------------ Read domain file
{	{
open(my $config,"</etc/httpd/conf/loncapa_apache.conf");	my $loaded;
	my %domain;

while (my $configline=<$config>) {	sub parse_domain_tab {
if ($configline =~ /^[^\#]*PerlSetVar/) {	my ($lines) = @_;
my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);	foreach my $line (@$lines) {
chomp($varvalue);	next if ($line =~ /^(\#\|\s*$ )/x);
$perlvar{$varname}=$varvalue;
}	chomp($line);
	my ($name,@elements) = split(/:/,$line,9);
	my %this_domain;
	foreach my $field ('description', 'auth_def', 'auth_arg_def',
	'lang_def', 'city', 'longi', 'lati',
	'primary') {
	$this_domain{$field} = shift(@elements);
	}
	$domain{$name} = \%this_domain;
	&logthis("Domain.tab: $name ".$domain{$name}{'description'} );
	}
	}

	sub load_domain_tab {
	&get_dns('/adm/dns/domain',\&parse_domain_tab);
	my $fh;
	if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) {
	my @lines = <$fh>;
	&parse_domain_tab(\@lines);
	}
	close($fh);
	$loaded = 1;
}	}
close($config);
}

# ------------------------------------------------------------ Read domain file	sub domain {
{	&load_domain_tab() if (!$loaded);
%domaindescription = ();
%domain_auth_def = ();	my ($name,$what) = @_;
%domain_auth_arg_def = ();	return if ( !exists($domain{$name}) );
my $fh;
if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) {
while (<$fh>) {
next if (/^(\#\|\s*$)/);
# next if /^\#/;
chomp;
my ($domain, $domain_description, $def_auth, $def_auth_arg,
$def_lang, $city, $longi, $lati, $primary) = split(/:/,$_);
$domain_auth_def{$domain}=$def_auth;
$domain_auth_arg_def{$domain}=$def_auth_arg;
$domaindescription{$domain}=$domain_description;
$domain_lang_def{$domain}=$def_lang;
$domain_city{$domain}=$city;
$domain_longi{$domain}=$longi;
$domain_lati{$domain}=$lati;
$domain_primary{$domain}=$primary;

# &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");	if (!$what) {
# &logthis("Domain.tab: $domain ".$domaindescription{$domain} );	return $domain{$name}{'description'};
}	}
	return $domain{$name}{$what};
}	}
close ($fh);
}	}


# ------------------------------------------------------------- Read hosts file	# ------------------------------------------------------------- Read hosts file
{	{
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");	my %hostname;
	my %hostdom;
	my %libserv;
	my $loaded;

	sub parse_hosts_tab {
	my ($file) = @_;
	foreach my $configline (@$file) {
	next if ($configline =~ /^(\#\|\s*$ )/x);
	next if ($configline =~ /^\^/);
	chomp($configline);
	my ($id,$domain,$role,$name)=split(/:/,$configline);
	$name=~s/\s//g;
	if ($id && $domain && $role && $name) {
	$hostname{$id}=$name;
	$hostdom{$id}=$domain;
	if ($role eq 'library') { $libserv{$id}=$name; }
	}
	&logthis("Hosts.tab: $name ".$id );
	}
	}

while (my $configline=<$config>) {	sub load_hosts_tab {
next if ($configline =~ /^(\#\|\s*$)/);	&get_dns('/adm/dns/hosts',\&parse_hosts_tab);
chomp($configline);	open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
my ($id,$domain,$role,$name)=split(/:/,$configline);	my @config = <$config>;
$name=~s/\s//g;	&parse_hosts_tab(\@config);
if ($id && $domain && $role && $name) {	close($config);
$hostname{$id}=$name;	$loaded=1;
$hostdom{$id}=$domain;
if ($role eq 'library') { $libserv{$id}=$name; }
}
}	}
close($config);
# FIXME: dev server don't want this, production servers _do_ want this	# FIXME: dev server don't want this, production servers _do_ want this
#&get_iphost();	#&get_iphost();

	sub hostname {
	&load_hosts_tab() if (!$loaded);

	my ($lonid) = @_;
	return $hostname{$lonid};
	}

	sub all_hostnames {
	&load_hosts_tab() if (!$loaded);

	return %hostname;
	}

	sub is_library {
	&load_hosts_tab() if (!$loaded);

	return exists($libserv{$_[0]});
	}

	sub all_library {
	&load_hosts_tab() if (!$loaded);

	return %libserv;
	}

	sub get_servers {
	&load_hosts_tab() if (!$loaded);

	my ($domain,$type) = @_;
	my %possible_hosts = ($type eq 'library') ? %libserv
	: %hostname;
	my %result;
	if (ref($domain) eq 'ARRAY') {
	while ( my ($host,$hostname) = each(%possible_hosts)) {
	if (grep(/^\Q$hostdom{$host}\E$/,@$domain)) {
	$result{$host} = $hostname;
	}
	}
	} else {
	while ( my ($host,$hostname) = each(%possible_hosts)) {
	if ($hostdom{$host} eq $domain) {
	$result{$host} = $hostname;
	}
	}
	}
	return %result;
	}

	sub host_domain {
	&load_hosts_tab() if (!$loaded);

	my ($lonid) = @_;
	return $hostdom{$lonid};
	}

	sub all_domains {
	&load_hosts_tab() if (!$loaded);

	my %seen;
	my @uniq = grep(!$seen{$_}++, values(%hostdom));
	return @uniq;
	}
}	}

sub get_iphost {	{
if (%iphost) { return %iphost; }	my %iphost;
my %name_to_ip;	my %name_to_ip;
foreach my $id (keys(%hostname)) {	my %lonid_to_ip;
my $name=$hostname{$id};	sub get_hosts_from_ip {
my $ip;	my ($ip) = @_;
if (!exists($name_to_ip{$name})) {	my %iphosts = &get_iphost();
$ip = gethostbyname($name);	if (ref($iphosts{$ip})) {
if (!$ip \|\| length($ip) ne 4) {	return @{$iphosts{$ip}};
&logthis("Skipping host $id name $name no IP found\n");	}
next;	return;
	}

	sub get_host_ip {
	my ($lonid) = @_;
	if (exists($lonid_to_ip{$lonid})) {
	return $lonid_to_ip{$lonid};
	}
	my $name=&hostname($lonid);
	my $ip = gethostbyname($name);
	return if (!$ip \|\| length($ip) ne 4);
	$ip=inet_ntoa($ip);
	$name_to_ip{$name} = $ip;
	$lonid_to_ip{$lonid} = $ip;
	return $ip;
	}

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

# ------------------------------------------------------ Read spare server file	# ------------------------------------------------------ Read spare server file
Line 6731 sub get_iphost {	Line 7833 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 6757 sub get_iphost {	Line 7861 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 6787 sub get_iphost {	Line 7897 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 6984 B<delenv($regexp)>: removes all items fr	Line 8096 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 7038 X<userenvironment()>	Line 8157 X<userenvironment()>
B<userenvironment($udom,$uname,@what)>: gets the values of the keys	B<userenvironment($udom,$uname,@what)>: gets the values of the keys
passed in @what from the requested user's environment, returns a hash	passed in @what from the requested user's environment, returns a hash

	=item *
	X<userlog_query()>
	B<userlog_query($uname,$udom,%filters)>: retrieves data from a user's activity.log file. %filters defines filters applied when parsing the log file. These can be start or end timestamps, or the type of action - log to look for Login or Logout events, check for Checkin or Checkout, role for role selection. The response is in the form timestamp1:hostid1:event1&timestamp2:hostid2:event2 where events are escaped strings of the action recorded in the activity.log file.

=back	=back

=head2 User Roles	=head2 User Roles
Line 7046 passed in @what from the requested user'	Line 8169 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 7065 and course level	Line 8188 and course level
plaintext($short) : return value in %prp hash (rolesplain.tab); plain text	plaintext($short) : return value in %prp hash (rolesplain.tab); plain text
explanation of a user role term	explanation of a user role term

	=item *

	get_my_roles($uname,$udom,$context,$types,$roles,$roledoms) :
	All arguments are optional. Returns a hash of a roles, either for
	co-author/assistant author roles for a user's Construction Space
	(default), or if $context is 'user', roles for the user himself,
	In the hash, keys are set to colon-sparated $uname,$udom,and $role,
	and value is set to colon-separated start and end times for the role.
	If no username and domain are specified, will default to current
	user/domain. Types, roles, and roledoms are references to arrays,
	of role statuses (active, future or previous), roles
	(e.g., cc,in, st etc.) and domains of the roles which can be used
	to restrict the list of roles reported. If no array ref is
	provided for types, will default to return only active roles.

=back	=back

=head2 User Modification	=head2 User Modification
Line 7452 cput($namespace,$storehash,$udom,$uname)	Line 8590 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 7461 reference filled in from namesp (encrypt	Line 8624 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 7686 removeuploadedurl(): convience function	Line 8858 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.740
changed lines
	Added in v.1.858