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.745 and 1.848

version 1.745, 2006/06/07 18:41:57	version 1.848, 2007/03/14 23:36:10
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 %coursetypebuf	%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 149 sub logperm {	Line 147 sub logperm {
# -------------------------------------------------- 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 189 sub subreply {	Line 187 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 199 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 208 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 222 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 272 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 324 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;
	}
	}
	if ($convert) {
	if (!&convert_and_load_session_env($lonidsdir,$handle)) {
	&logthis("Failed to load session, or convert session.");
	}
}	}
my $envi;
my %Remove;	my %remove;
for ($envi=0;$envi<=$#profile;$envi++) {	while ( my $envname = each(%env) ) {
chomp($profile[$envi]);
my ($envname,$envvalue)=split(/=/,$profile[$envi],2);
$envname=&unescape($envname);
$envvalue=&unescape($envvalue);
$env{$envname} = $envvalue;
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 392 sub appenv {
$env{$key}=$newenv{$key};	$env{$key}=$newenv{$key};
}	}
}	}
	open(my $env_file,$env{'user.environment'});
my $lockfh;	if (&timed_flock($env_file,LOCK_EX)
unless (open($lockfh,"$env{'user.environment'}")) {	&&
return 'error: '.$!;	tie(my %disk_env,'GDBM_File',$env{'user.environment'},
}	(&GDBM_WRITER()\|&GDBM_NOLOCK()),0640)) {
unless (flock($lockfh,LOCK_EX)) {	while (my ($key,$value) = each(%newenv)) {
&logthis("<font color=\"blue\">WARNING: ".	$disk_env{$key} = $value;
'Could not obtain exclusive lock in appenv: '.$!);
close($lockfh);
return 'error: '.$!;
}

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

close($lockfh);
return 'ok';	return 'ok';
}	}
# ----------------------------------------------------- Delete from Environment	# ----------------------------------------------------- Delete from Environment
Line 389 sub delenv {	Line 413 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 495 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 604 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 638 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 661 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 685 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 696 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 919 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 965 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 1002 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 1099 sub repcopy {	Line 1222 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 1289 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 1297 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 1317 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 1471 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 1610 sub removeuploadedurl {	Line 1745 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 1622 sub mkdiruserfile {	Line 1770 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 1649 sub flushcourselogs {	Line 1812 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 1677 sub flushcourselogs {	Line 1839 sub flushcourselogs {
# 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 1687 sub flushcourselogs {	Line 1850 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 1708 sub flushcourselogs {	Line 1872 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 1719 sub flushcourselogs {	Line 1883 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 1745 sub flushcourselogs {	Line 1908 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 1792 sub courseacclog {	Line 1954 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 1856 sub get_course_adv_roles {	Line 2018 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 1888 sub get_course_adv_roles {	Line 2047 sub get_course_adv_roles {
}	}

sub get_my_roles {	sub get_my_roles {
my ($uname,$udom)=@_;	my ($uname,$udom,$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=
&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 1912 sub get_my_roles {	Line 2095 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 1921 sub getannounce {	Line 2104 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 1945 sub courseidput {	Line 2128 sub courseidput {
}	}

sub courseiddump {	sub courseiddump {
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter)=@_;	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($typefilter),	&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 1980 sub dcmailput {	Line 2168 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 2006 sub get_domain_roles {	Line 2195 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 2027 sub get_domain_roles {	Line 2216 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 2041 sub get_first_access {	Line 2230 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 2108 sub checkin {	Line 2297 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 2235 sub hash2str {	Line 2424 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 2535 sub store {	Line 2724 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 2571 sub cstore {	Line 2760 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 2604 sub restore {	Line 2793 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 2651 sub coursedescription {	Line 2840 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'})) {
Line 2686 sub privileged {	Line 2876 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 2720 sub rolesinit {	Line 2910 sub rolesinit {
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 2776 sub custom_roleprivs {	Line 2966 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 2806 sub group_roleprivs {	Line 2996 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 2837 sub set_userprivs {	Line 3027 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 2852 sub set_userprivs {	Line 3042 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 2870 sub set_userprivs {	Line 3060 sub set_userprivs {
}	}
}	}
my $thesestr='';	my $thesestr='';
foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; }	foreach my $priv (keys(%thesepriv)) {
$userroles->{'user.priv.'.$_} = $thesestr;	$thesestr.=':'.$priv.'&'.$thesepriv{$priv};
	}
	$userroles->{'user.priv.'.$role} = $thesestr;
}	}
return ($author,$adv);	return ($author,$adv);
}	}
Line 2881 sub set_userprivs {	Line 3073 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 2896 sub get {	Line 3088 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 2908 sub get {	Line 3100 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 2922 sub del {	Line 3114 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 2931 sub dump {	Line 3147 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 2957 sub getkeys {	Line 3167 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 2978 sub currentdump {	Line 3189 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 3003 sub convert_dump_to_currentdump{	Line 3214 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 3064 sub put {	Line 3277 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 3117 sub old_putstore {	Line 3330 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 3146 sub cput {	Line 3359 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 3158 sub cput {	Line 3371 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 3169 sub eget {	Line 3382 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 3178 sub eget {	Line 3391 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 3207 sub tmpdel {	Line 3423 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 3244 sub customaccess {	Line 3698 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 3261 sub allowed {	Line 3725 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 3276 sub allowed {	Line 3747 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 3344 sub allowed {	Line 3823 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 3378 sub allowed {	Line 3849 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 3425 sub allowed {	Line 3903 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 3528 sub allowed {	Line 4006 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 3591 sub allowed {	Line 4075 sub allowed {
}	}
}	}

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

Line 3643 sub get_symb_from_alias {	Line 4132 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 3652 sub definerole {	Line 4141 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 3661 sub definerole {	Line 4150 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 3685 sub definerole {	Line 4174 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 3708 sub log_query {	Line 4198 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 3728 sub fetch_enrollment_query {	Line 4230 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 3752 sub fetch_enrollment_query {	Line 4254 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 3837 sub auto_run {	Line 4339 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 3848 sub auto_get_sections {	Line 4350 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 3919 sub auto_photochoice {	Line 4421 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 3954 sub auto_photoupdate {	Line 4456 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 3998 sub modify_coursegroup {	Line 4546 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 4021 sub get_active_groups {	Line 4600 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 4042 sub get_users_groups {	Line 4621 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 4051 sub get_users_groups {	Line 4628 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 4090 sub get_users_groups {	Line 4663 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 4100 sub devalidate_getgroups_cache {	Line 4672 sub devalidate_getgroups_cache {

sub plaintext {	sub plaintext {
my ($short,$type,$cid) = @_;	my ($short,$type,$cid) = @_;
	if ($short =~ /^cr/) {
	return (split('/',$short))[-1];
	}
if (!defined($cid)) {	if (!defined($cid)) {
$cid = $env{'request.course.id'};	$cid = $env{'request.course.id'};
}	}
Line 4127 sub assignrole {	Line 4702 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 4137 sub assignrole {	Line 4712 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 4147 sub assignrole {	Line 4722 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 4227 sub modifyuser {	Line 4802 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 4241 sub modifyuser {	Line 4816 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 4377 sub modify_student_enrollment {	Line 4950 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 4436 sub writecoursepref {	Line 5009 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 4470 sub createcourse {	Line 5043 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 4513 ENDINITMAP	Line 5086 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 4555 sub is_locked {	Line 5138 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 = 'false';	$is_locked = 'false';
foreach my $entry (@{$locked{$file_name}}) {	foreach my $entry (@{$locked{$file_name}}) {
if (ref($entry) eq 'ARRAY') {	if (ref($entry) eq 'ARRAY') {
if ($$entry[0] eq 'access' \|\| $$entry[0] eq 'accesscount') {	$is_locked = 'true';
next;	last;
} else {
$is_locked = 'true';
last;
}
}	}
}	}
} else {	} else {
Line 4574 sub is_locked {	Line 5152 sub is_locked {
}	}
}	}

	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 4582 sub mark_as_readonly {	Line 5166 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 4640 sub files_not_in_path {	Line 5225 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);
}	}

Line 4669 sub get_portfile_permissions {	Line 5254 sub get_portfile_permissions {

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

sub get_access_controls {	sub get_access_controls {
my ($current_permissions,$group,$file) = @_;	my ($current_permissions,$group,$file) = @_;
my @access_checks = ();	my %access;
my %access;	my $real_file = $file;
	$file =~ s/\.meta$//;
if (defined($file)) {	if (defined($file)) {
@access_checks = ($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 {	} else {
@access_checks = keys(%{$current_permissions});	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};
	}
	}
	}
	}
}	}
foreach my $file_name (@access_checks) {	return %access;
my $value = $$current_permissions{$file_name};	}
if (defined($group)) {
if ($file_name !~ m-^\Q$group\E/-) {	sub modify_access_controls {
next;	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;
}	}
}	}
if (ref($value) eq "ARRAY") {	}
foreach my $stored_what (@{$value}) {	my %todelete;
if (ref($stored_what) eq 'ARRAY') {	my %changed_items;
if ($$stored_what[0] eq 'access') {	foreach my $action ('delete','update') {
if (!defined($access{$file_name})) {	if (exists($$changes{$action})) {
%{$access{$file_name}} = ();	if (ref($$changes{$action}) eq 'HASH') {
}	foreach my $key (keys(%{$$changes{$action}})) {
$access{$file_name}{$$stored_what[1]}=$$stored_what[2];	my ($itemnum) = ($key =~ /^([^:]+):/);
	if ($action eq 'delete') {
	$todelete{$itemnum} = 1;
} else {	} else {
next;	$changed_items{$itemnum} = $key;
}	}
}	}
}	}
}	}
}	}
return %access;	# 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	#------------------------------------------------------Get Marked as Read Only
Line 4720 sub get_marked_as_readonly {	Line 5451 sub get_marked_as_readonly {
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)) {	if (ref($stored_what) eq 'ARRAY') {
if ($$stored_what[0] eq 'access' \|\|	$cmp2=join('',@{$stored_what});
$$stored_what[0] eq 'accesscount') {
next;
} else {
$cmp2=join('',@{$stored_what});
}
}	}
if ($cmp1 eq $cmp2) {	if ($cmp1 eq $cmp2) {
push(@readonly_files, $file_name);	push(@readonly_files, $file_name);
Line 4754 sub get_marked_as_readonly_hash {	Line 5480 sub get_marked_as_readonly_hash {
if (ref($value) eq "ARRAY"){	if (ref($value) eq "ARRAY"){
foreach my $stored_what (@{$value}) {	foreach my $stored_what (@{$value}) {
if (ref($stored_what) eq 'ARRAY') {	if (ref($stored_what) eq 'ARRAY') {
if ($$stored_what[0] eq 'access' \|\|	foreach my $lock_descriptor(@{$stored_what}) {
$$stored_what[0] eq 'accesscount') {	if ($lock_descriptor eq 'graded') {
next;	$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';
	}
	}
}	}
}	}
if ($stored_what eq $what) {
$readonly_files{$file_name} = 'locked';
} elsif (!defined($what)) {
$readonly_files{$file_name} = 'locked';
}
}	}
}	}
}	}
Line 4775 sub unmark_as_readonly {	Line 5503 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,$group) = @_;	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,$group);	my %current_permissions = &dump('file_permissions',$domain,$user,$group);
Line 4782 sub unmark_as_readonly {	Line 5511 sub unmark_as_readonly {
if ($tmp=~/^error:/) { undef(%current_permissions); }	if ($tmp=~/^error:/) { undef(%current_permissions); }
my @readonly_files = &get_marked_as_readonly($domain,$user,$what,$group);	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;
Line 4790 sub unmark_as_readonly {	Line 5520 sub unmark_as_readonly {
foreach my $locker (@{$current_locks}) {	foreach my $locker (@{$current_locks}) {
my $compare=$locker;	my $compare=$locker;
if (ref($locker) eq 'ARRAY') {	if (ref($locker) eq 'ARRAY') {
if ($$locker[0] eq 'access' \|\|
$$locker[0] eq 'accesscount') {
push(@new_locks,$locker);
next;
}
$compare=join('',@{$locker});	$compare=join('',@{$locker});
}	if ($compare ne $symb_crs) {
if ($compare ne $symb_crs) {	push(@new_locks, $locker);
push(@new_locks, $locker);	}
}	}
}	}
if (scalar(@new_locks) > 0) {	if (scalar(@new_locks) > 0) {
Line 4838 sub dirlist {	Line 5563 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 4919 sub dirlist {	Line 5632 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 4938 sub GetFileTimestamp {	Line 5651 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 5061 sub devalidatecourseresdata {	Line 5769 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 5175 sub EXT {	Line 5884 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 5413 sub EXT {	Line 6121 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 5465 sub packages_tab_default {	Line 6176 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 5532 sub metadata {	Line 6244 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 5563 sub metadata {	Line 6275 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 5782 sub metadata_generate_part0 {	Line 6494 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 5816 sub gettitle {	Line 6539 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 5865 sub symblist {	Line 6588 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 5891 sub symbverify {	Line 6611 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 6040 sub symbread {	Line 6760 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 6150 sub latest_rnd_algorithm_id {	Line 6870 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 6176 sub getCODE {	Line 6896 sub getCODE {
sub rndseed {	sub rndseed {
my ($symb,$courseid,$domain,$username)=@_;	my ($symb,$courseid,$domain,$username)=@_;

my ($wsymb,$wcourseid,$wdomain,$wusername)=&Apache::lonxml::whichuser();	my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser();
if (!$symb) {	if (!$symb) {
unless ($symb=$wsymb) { return time; }	unless ($symb=$wsymb) { return time; }
}	}
Line 6184 sub rndseed {	Line 6904 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 6217 sub rndseed_32bit {	Line 6938 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 6238 sub rndseed_64bit {	Line 6959 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 6262 sub rndseed_64bit2 {	Line 6982 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 6284 sub rndseed_64bit3 {	Line 7005 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 6308 sub rndseed_64bit4 {	Line 7029 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 6333 sub rndseed_CODE_64bit {	Line 7054 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 6352 sub rndseed_CODE_64bit4 {	Line 7073 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 6378 sub setup_random_from_rndseed {	Line 7099 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 6395 sub recunique {	Line 7117 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 6405 sub recprefix {	Line 7128 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 6438 sub ireceipt {	Line 7168 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 6464 sub repcopy_userfile {	Line 7232 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 6532 sub tokenwrapper {	Line 7299 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 6540 sub tokenwrapper {	Line 7307 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 6565 sub readfile {	Line 7336 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 6581 sub filelocation {	Line 7352 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 6623 sub hreflocation {	Line 7394 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'}};	my $hostname=&hostname($perlvar{'lonHostID'});
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'}};	my $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 6656 sub current_machine_ids {	Line 7429 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 6704 sub clutter {	Line 7500 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 6756 BEGIN {	Line 7561 BEGIN {
# ----------------------------------- Read loncapa.conf and loncapa_apache.conf	# ----------------------------------- Read loncapa.conf and loncapa_apache.conf
unless ($readit) {	unless ($readit) {
{	{
# FIXME: Use LONCAPA::Configuration::read_conf here and omit next block	my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf');
open(my $config,"</etc/httpd/conf/loncapa.conf");	%perlvar = (%perlvar,%{$configvars});

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

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

# ------------------------------------------------------------ Read domain file	# ------------------------------------------------------------ Read domain file
{	{
%domaindescription = ();	my %domain;
%domain_auth_def = ();
%domain_auth_arg_def = ();
my $fh;	my $fh;
if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) {	if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) {
while (<$fh>) {	while (my $line = <$fh>) {
next if (/^(\#\|\s*$)/);	next if ($line =~ /^(\#\|\s*$ )/);
# next if /^\#/;
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}");	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: $domain ".$domaindescription{$domain} );	# &logthis("Domain.tab: $domain ".$domaindescription{$domain} );
}	}
}	}
close ($fh);	close ($fh);

	sub domain {
	my ($name,$what) = @_;
	return if ( !exists($domain{$name}) );

	if (!$what) {
	return $domain{$name}{'description'};
	}
	return $domain{$name}{$what};
	}
}	}


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

while (my $configline=<$config>) {	while (my $configline=<$config>) {
Line 6829 BEGIN {	Line 7621 BEGIN {
close($config);	close($config);
# FIXME: dev server don't want this, production servers _do_ want this	# FIXME: dev server don't want this, production servers _do_ want this
#&get_iphost();	#&get_iphost();
}

sub get_iphost {	sub hostname {
if (%iphost) { return %iphost; }	my ($lonid) = @_;
my %name_to_ip;	return $hostname{$lonid};
foreach my $id (keys(%hostname)) {	}
my $name=$hostname{$id};
my $ip;	sub all_hostnames {
if (!exists($name_to_ip{$name})) {	return %hostname;
$ip = gethostbyname($name);	}
if (!$ip \|\| length($ip) ne 4) {
&logthis("Skipping host $id name $name no IP found\n");	sub is_library {
next;	return exists($libserv{$_[0]});
	}

	sub all_library {
	return %libserv;
	}

	sub get_servers {
	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;
	}
}	}
$ip=inet_ntoa($ip);
$name_to_ip{$name} = $ip;
} else {	} else {
$ip = $name_to_ip{$name};	while ( my ($host,$hostname) = each(%possible_hosts)) {
	if ($hostdom{$host} eq $domain) {
	$result{$host} = $hostname;
	}
	}
}	}
push(@{$iphost{$ip}},$id);	return %result;
	}

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

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

	{
	my %iphost;
	sub get_hosts_from_ip {
	my ($ip) = @_;
	my %iphosts = &get_iphost();
	if (ref($iphosts{$ip})) {
	return @{$iphosts{$ip}};
	}
	return;
	}

	sub get_iphost {
	if (%iphost) { return %iphost; }
	my %name_to_ip;
	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};
	}
	push(@{$iphost{$ip}},$id);
	}
	return %iphost;
}	}
return %iphost;
}	}

# ------------------------------------------------------ Read spare server file	# ------------------------------------------------------ Read spare server file
Line 6860 sub get_iphost {	Line 7714 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 6922 sub get_iphost {	Line 7778 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 7119 B<delenv($regexp)>: removes all items fr	Line 7977 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 7181 passed in @what from the requested user'	Line 8046 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 7200 and course level	Line 8065 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,$types,$roles,$roledoms) : All arguments are
	optional. Returns a hash of a user's roles, with keys set to
	colon-sparated $uname,$udom,and $role, and value 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 if 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 7587 cput($namespace,$storehash,$udom,$uname)	Line 8465 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 7596 reference filled in from namesp (encrypt	Line 8499 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 7821 removeuploadedurl(): convience function	Line 8733 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.745
changed lines
	Added in v.1.848