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.782.2.4 and 1.957

version 1.782.2.4, 2006/10/20 20:39:44	version 1.957, 2008/04/30 22:42:59
Line 31 package Apache::lonnet;	Line 31 package Apache::lonnet;

use strict;	use strict;
use LWP::UserAgent();	use LWP::UserAgent();
use HTTP::Headers;
use HTTP::Date;	use HTTP::Date;
# use Date::Parse;	# use Date::Parse;
use vars	use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom	$_64bit %env);
%libserv %pr %prp $memcache %packagetab
%courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount	my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf	%userrolehash, $processmarker, $dumpcount, %coursedombuf,
%domaindescription %domain_auth_def %domain_auth_arg_def	%coursenumbuf, %coursehombuf, %coursedescrbuf, %courseinstcodebuf,
%domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary	%courseownerbuf, %coursetypebuf);
$tmpdir $_64bit %env);

use IO::Socket;	use IO::Socket;
use GDBM_File;	use GDBM_File;
use HTML::LCParser;	use HTML::LCParser;
use HTML::Parser;
use Fcntl qw(:flock);	use Fcntl qw(:flock);
use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze);	use Storable qw(thaw nfreeze);
use Time::HiRes qw( gettimeofday tv_interval );	use Time::HiRes qw( gettimeofday tv_interval );
use Cache::Memcached;	use Cache::Memcached;
use Digest::MD5;	use 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 91 delayed.	Line 88 delayed.
{	{
my $logid;	my $logid;
sub instructor_log {	sub instructor_log {
my ($hash_name,$storehash,$delflag,$uname,$udom)=@_;	my ($hash_name,$storehash,$delflag,$uname,$udom,$cnum,$cdom)=@_;
	if (($cnum eq '') \|\| ($cdom eq '')) {
	$cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
	$cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
	}
$logid++;	$logid++;
my $id=time().'00000'.$$.'00000'.$logid;	my $now = time();
	my $id=$now.'00000'.$$.'00000'.$logid;
return &Apache::lonnet::put('nohist_'.$hash_name,	return &Apache::lonnet::put('nohist_'.$hash_name,
{ $id => {	{ $id => {
'exe_uname' => $env{'user.name'},	'exe_uname' => $env{'user.name'},
'exe_udom' => $env{'user.domain'},	'exe_udom' => $env{'user.domain'},
'exe_time' => time(),	'exe_time' => $now,
'exe_ip' => $ENV{'REMOTE_ADDR'},	'exe_ip' => $ENV{'REMOTE_ADDR'},
'delflag' => $delflag,	'delflag' => $delflag,
'logentry' => $storehash,	'logentry' => $storehash,
'uname' => $uname,	'uname' => $uname,
'udom' => $udom,	'udom' => $udom,
}	}
},	},$cdom,$cnum);
$env{'course.'.$env{'request.course.id'}.'.domain'},
$env{'course.'.$env{'request.course.id'}.'.num'}
);
}	}
}	}

Line 146 sub logperm {	Line 145 sub logperm {
return 1;	return 1;
}	}

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


# -------------------------------------------------- Non-critical communication	# -------------------------------------------------- Non-critical communication
sub subreply {	sub subreply {
my ($cmd,$server)=@_;	my ($cmd,$server)=@_;
my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server};	my $peerfile="$perlvar{'lonSockDir'}/".&hostname($server);
#	#
# With loncnew process trimming, there's a timing hole between lonc server	# With loncnew process trimming, there's a timing hole between lonc server
# process exit and the master server picking up the listen on the AF_UNIX	# process exit and the master server picking up the listen on the AF_UNIX
Line 170 sub subreply {	Line 183 sub subreply {
$client=IO::Socket::UNIX->new(Peer =>"$peerfile",	$client=IO::Socket::UNIX->new(Peer =>"$peerfile",
Type => SOCK_STREAM,	Type => SOCK_STREAM,
Timeout => 10);	Timeout => 10);
if($client) {	if ($client) {
last; # Connected!	last; # Connected!
	} else {
	&create_connection(&hostname($server),$server);
}	}
sleep(1); # Try again later if failed connection.	sleep(1); # Try again later if failed connection.
}	}
my $answer;	my $answer;
if ($client) {	if ($client) {
Line 189 sub subreply {	Line 204 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 216 sub reply {
# ----------------------------------------------------------- Send USR1 to lonc	# ----------------------------------------------------------- Send USR1 to lonc

sub reconlonc {	sub reconlonc {
my $peerfile=shift;	my ($lonid) = @_;
&logthis("Trying to reconnect for $peerfile");	my $hostname = &hostname($lonid);
	if ($lonid) {
	my $peerfile="$perlvar{'lonSockDir'}/$hostname";
	if ($hostname && -e $peerfile) {
	&logthis("Trying to reconnect lonc for $lonid ($hostname)");
	my $client=IO::Socket::UNIX->new(Peer => $peerfile,
	Type => SOCK_STREAM,
	Timeout => 10);
	if ($client) {
	print $client ("reset_retries\n");
	my $answer=<$client>;
	#reset just this one.
	}
	}
	return;
	}

	&logthis("Trying to reconnect lonc");
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 243 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 257 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 292 sub error {	Line 318 sub error {
return undef;	return undef;
}	}

	sub convert_and_load_session_env {
	my ($lonidsdir,$handle)=@_;
	my @profile;
	{
	my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
	if (!$opened) {
	return 0;
	}
	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	# ------------------------------------------- Transfer profile into environment
my $env_loaded;	my $env_loaded;
sub transfer_profile_to_env {	sub transfer_profile_to_env {
Line 305 sub transfer_profile_to_env {	Line 362 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");	my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
	if (!$opened) {
	return;
	}
flock($idf,LOCK_SH);	flock($idf,LOCK_SH);
@profile=<$idf>;	if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",
close($idf);	&GDBM_READER(),0640)) {
	@env{keys(%disk_env)} = @disk_env{keys(%disk_env)};
	untie(%disk_env);
	} else {
	$convert = 1;
	}
}	}
my $envi;	if ($convert) {
my %Remove;	if (!&convert_and_load_session_env($lonidsdir,$handle)) {
for ($envi=0;$envi<=$#profile;$envi++) {	&logthis("Failed to load session, or convert session.");
chomp($profile[$envi]);	}
my ($envname,$envvalue)=split(/=/,$profile[$envi],2);	}
$envname=&unescape($envname);
$envvalue=&unescape($envvalue);	my %remove;
$env{$envname} = $envvalue;	while ( my $envname = each(%env) ) {
if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {	if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
if ($time < time-300) {	if ($time < time-300) {
$Remove{$key}++;	$remove{$key}++;
}	}
}	}
}	}

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

# ---------------------------------------------------------- Append Environment	# ---------------------------------------------------- Check for valid session
	sub check_for_valid_session {
sub appenv {	my ($r) = @_;
my %newenv=@_;	my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
foreach my $key (keys(%newenv)) {	my $lonid=$cookies{'lonID'};
if (($newenv{$key}=~/^user\.role/) \|\| ($newenv{$key}=~/^user\.priv/)) {	return undef if (!$lonid);
&logthis("<font color=\"blue\">WARNING: ".
"Attempt to modify environment ".$key." to ".$newenv{$key}	my $handle=&LONCAPA::clean_handle($lonid->value);
.'</font>');	my $lonidsdir=$r->dir_config('lonIDsDir');
delete($newenv{$key});	return undef if (!-e "$lonidsdir/$handle.id");
} else {
$env{$key}=$newenv{$key};	my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
}	return undef if (!$opened);
}
foreach my $key (keys(%newenv)) {	flock($idf,LOCK_SH);
my $value = &escape($newenv{$key});	my %disk_env;
delete($newenv{$key});	if (!tie(%disk_env,'GDBM_File',"$lonidsdir/$handle.id",
$newenv{&escape($key)}=$value;	&GDBM_READER(),0640)) {
	return undef;
}	}

my $lockfh;	if (!defined($disk_env{'user.name'})
unless (open($lockfh,"$env{'user.environment'}")) {	\|\| !defined($disk_env{'user.domain'})) {
return 'error: '.$!;	return undef;
}
unless (flock($lockfh,LOCK_EX)) {
&logthis("<font color=\"blue\">WARNING: ".
'Could not obtain exclusive lock in appenv: '.$!);
close($lockfh);
return 'error: '.$!;
}	}
	return $handle;
	}

my @oldenv;	sub timed_flock {
{	my ($file,$lock_type) = @_;
my $fh;	my $failed=0;
unless (open($fh,"$env{'user.environment'}")) {	eval {
return 'error: '.$!;	local $SIG{__DIE__}='DEFAULT';
}	local $SIG{ALRM}=sub {
@oldenv=<$fh>;	$failed=1;
close($fh);	die("failed lock");
	};
	alarm(13);
	flock($file,$lock_type);
	alarm(0);
	};
	if ($failed) {
	return undef;
	} else {
	return 1;
}	}
for (my $i=0; $i<=$#oldenv; $i++) {	}
chomp($oldenv[$i]);
if ($oldenv[$i] ne '') {	# ---------------------------------------------------------- Append Environment
my ($name,$value)=split(/=/,$oldenv[$i],2);
unless (defined($newenv{$name})) {	sub appenv {
$newenv{$name}=$value;	my ($newenv,$roles) = @_;
	if (ref($newenv) eq 'HASH') {
	foreach my $key (keys(%{$newenv})) {
	my $refused = 0;
	if (($key =~ /^user\.role/) \|\| ($key =~ /^user\.priv/)) {
	$refused = 1;
	if (ref($roles) eq 'ARRAY') {
	my ($type,$role) = ($key =~ /^user\.(role\|priv)\.([^.]+)\./);
	if (grep(/^\Q$role\E$/,@{$roles})) {
	$refused = 0;
	}
	}
	}
	if ($refused) {
	&logthis("<font color=\"blue\">WARNING: ".
	"Attempt to modify environment ".$key." to ".$newenv->{$key}
	.'</font>');
	delete($newenv->{$key});
	} else {
	$env{$key}=$newenv->{$key};
	}
	}
	my $opened = open(my $env_file,'+<',$env{'user.environment'});
	if ($opened
	&& &timed_flock($env_file,LOCK_EX)
	&&
	tie(my %disk_env,'GDBM_File',$env{'user.environment'},
	(&GDBM_WRITER()\|&GDBM_NOLOCK()),0640)) {
	while (my ($key,$value) = each(%{$newenv})) {
	$disk_env{$key} = $value;
}	}
	untie(%disk_env);
}	}
}	}
{
my $fh;
unless (open($fh,">$env{'user.environment'}")) {
return 'error';
}
my $newname;
foreach $newname (keys %newenv) {
print $fh $newname.'='.$newenv{$newname}."\n";
}
close($fh);
}

close($lockfh);
return 'ok';	return 'ok';
}	}
# ----------------------------------------------------- Delete from Environment	# ----------------------------------------------------- Delete from Environment
Line 406 sub delenv {	Line 495 sub delenv {
"Attempt to delete from environment ".$delthis);	"Attempt to delete from environment ".$delthis);
return 'error';	return 'error';
}	}
my @oldenv;	my $opened = open(my $env_file,'+<',$env{'user.environment'});
{	if ($opened
my $fh;	&& &timed_flock($env_file,LOCK_EX)
unless (open($fh,"$env{'user.environment'}")) {	&&
return 'error';	tie(my %disk_env,'GDBM_File',$env{'user.environment'},
}	(&GDBM_WRITER()\|&GDBM_NOLOCK()),0640)) {
unless (flock($fh,LOCK_SH)) {	foreach my $key (keys(%disk_env)) {
&logthis("<font color=\"blue\">WARNING: ".	if ($key=~/^$delthis/) {
'Could not obtain shared lock in delenv: '.$!);	delete($env{$key});
close($fh);	delete($disk_env{$key});
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});
} else {
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
sub userload {	sub userload {
my $numusers=0;	my $numusers=0;
{	{
Line 456 sub userload {	Line 534 sub userload {
my $filename;	my $filename;
my $curtime=time;	my $curtime=time;
while ($filename=readdir(LONIDS)) {	while ($filename=readdir(LONIDS)) {
if ($filename eq '.' \|\| $filename eq '..') {next;}	next if ($filename eq '.' \|\| $filename eq '..');
	next if ($filename =~ /publicuser_\d+\.id/);
my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];	my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
if ($curtime-$mtime < 1800) { $numusers++; }	if ($curtime-$mtime < 1800) { $numusers++; }
}	}
Line 519 sub spareserver {	Line 598 sub spareserver {
}	}

if (!$want_server_name) {	if (!$want_server_name) {
$spare_server="http://$hostname{$spare_server}";	$spare_server="http://".&hostname($spare_server);
}	}
return $spare_server;	return $spare_server;
}	}
Line 553 sub compare_server_load {	Line 632 sub compare_server_load {
}	}
return ($spare_server,$lowest_load);	return ($spare_server,$lowest_load);
}	}

	# --------------------------- ask offload servers if user already has a session
	sub find_existing_session {
	my ($udom,$uname) = @_;
	foreach my $try_server (@{ $spareid{'primary'} },
	@{ $spareid{'default'} }) {
	return $try_server if (&has_user_session($try_server, $udom, $uname));
	}
	return;
	}

	# -------------------------------- ask if server already has a session for user
	sub has_user_session {
	my ($lonid,$udom,$uname) = @_;
	my $result = &reply(join(':','userhassession',
	map {&escape($_)} ($udom,$uname)),$lonid);
	return 1 if ($result eq 'ok');

	return 0;
	}

# --------------------------------------------- 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 607 sub queryauthenticate {	Line 707 sub queryauthenticate {
# --------- Try to authenticate user from domain's lib servers (first this one)	# --------- Try to authenticate user from domain's lib servers (first this one)

sub authenticate {	sub authenticate {
my ($uname,$upass,$udom)=@_;	my ($uname,$upass,$udom,$checkdefauth)=@_;
$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) {	my $newhome;
&logthis("User $uname at $udom is unknown in authenticate");	if ((!$uhome) \|\| ($uhome eq 'no_host')) {
return 'no_host';	# Maybe the machine was offline and only re-appeared again recently?
	&reconlonc();
	# One more
	$uhome=&homeserver($uname,$udom,1);
	if (($uhome eq 'no_host') && $checkdefauth) {
	if (defined(&domain($udom,'primary'))) {
	$newhome=&domain($udom,'primary');
	}
	if ($newhome ne '') {
	$uhome = $newhome;
	}
	}
	if ((!$uhome) \|\| ($uhome eq 'no_host')) {
	&logthis("User $uname at $udom is unknown in authenticate");
	return 'no_host';
	}
}	}
my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome);	my $answer=reply("encrypt:auth:$udom:$uname:$upass:$checkdefauth",$uhome);
if ($answer eq 'authorized') {	if ($answer eq 'authorized') {
&logthis("User $uname at $udom authorized by $uhome");	if ($newhome) {
return $uhome;	&logthis("User $uname at $udom authorized by $uhome, but needs account");
	return 'no_account_on_host';
	} else {
	&logthis("User $uname at $udom authorized by $uhome");
	return $uhome;
	}
}	}
if ($answer eq 'non_authorized') {	if ($answer eq 'non_authorized') {
&logthis("User $uname at $udom rejected by $uhome");	&logthis("User $uname at $udom rejected by $uhome");
Line 636 sub homeserver {	Line 756 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 658 sub idget {	Line 779 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 684 sub idget {	Line 803 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 695 sub idrget {	Line 814 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 {
	$servers{$uhom}=$id.'='.$esc_unam;
	}
	}
	}
	foreach my $server (keys(%servers)) {
	&critical('idput:'.$udom.':'.$servers{$server},$server);
	}
	}

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

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

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

	sub put_dom {
	my ($namespace,$storehash,$udom,$uhome)=@_;
	if (!$udom) {
	$udom=$env{'user.domain'};
	if (defined(&domain($udom,'primary'))) {
	$uhome=&domain($udom,'primary');
	} else {
	undef($uhome);
	}
	} else {
	if (!$uhome) {
	if (defined(&domain($udom,'primary'))) {
	$uhome=&domain($udom,'primary');
	}
	}
	}
	if ($udom && $uhome && ($uhome ne 'no_host')) {
	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 homeserver and/or domain");
	}
	}

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

	sub is_domainimage {
	my ($url) = @_;
	if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img\|logo\|domlogo)/+-) {
	if (&domain($1) ne '') {
	return '1';
	}
	}
	return;
	}

	sub inst_directory_query {
	my ($srch) = @_;
	my $udom = $srch->{'srchdomain'};
	my %results;
	my $homeserver = &domain($udom,'primary');
	my $outcome;
	if ($homeserver ne '') {
	my $queryid=&reply("querysend:instdirsearch:".
	&escape($srch->{'srchby'}).':'.
	&escape($srch->{'srchterm'}).':'.
	&escape($srch->{'srchtype'}),$homeserver);
	my $host=&hostname($homeserver);
	if ($queryid !~/^\Q$host\E\_/) {
	&logthis('instituional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom);
	return;
	}
	my $response = &get_query_reply($queryid);
	my $maxtries = 5;
	my $tries = 1;
	while (($response=~/^timeout/) && ($tries < $maxtries)) {
	$response = &get_query_reply($queryid);
	$tries ++;
	}

	if (!&error($response) && $response ne 'refused') {
	if ($response eq 'unavailable') {
	$outcome = $response;
	} else {
	$outcome = 'ok';
	my @matches = split(/\n/,$response);
	foreach my $match (@matches) {
	my ($key,$value) = split(/=/,$match);
	$results{&unescape($key).':'.$udom} = &thaw_unescape($value);
	}
	}
	}
	}
	return ($outcome,%results);
	}

	sub usersearch {
	my ($srch) = @_;
	my $dom = $srch->{'srchdomain'};
	my %results;
	my %libserv = &all_library();
	my $query = 'usersearch';
	foreach my $tryserver (keys(%libserv)) {
	if (&host_domain($tryserver) eq $dom) {
	my $host=&hostname($tryserver);
	my $queryid=
	&reply("querysend:".&escape($query).':'.
	&escape($srch->{'srchby'}).':'.
	&escape($srch->{'srchtype'}).':'.
	&escape($srch->{'srchterm'}),$tryserver);
	if ($queryid !~/^\Q$host\E\_/) {
	&logthis('usersearch: invalid queryid: '.$queryid.' for host: '.$host.'in domain '.$dom.' and server: '.$tryserver);
	next;
	}
	my $reply = &get_query_reply($queryid);
	my $maxtries = 1;
	my $tries = 1;
	while (($reply=~/^timeout/) && ($tries < $maxtries)) {
	$reply = &get_query_reply($queryid);
	$tries ++;
	}
	if ( ($reply =~/^timeout/) \|\| ($reply =~/^error/) ) {
	&logthis('usersrch error: '.$reply.' for '.$dom.' - searching for : '.$srch->{'srchterm'}.' by '.$srch->{'srchby'}.' ('.$srch->{'srchtype'}.') - maxtries: '.$maxtries.' tries: '.$tries);
	} else {
	my @matches;
	if ($reply =~ /\n/) {
	@matches = split(/\n/,$reply);
	} else {
	@matches = split(/\&/,$reply);
	}
	foreach my $match (@matches) {
	my ($uname,$udom,%userhash);
	foreach my $entry (split(/:/,$match)) {
	my ($key,$value) =
	map {&unescape($_);} split(/=/,$entry);
	$userhash{$key} = $value;
	if ($key eq 'username') {
	$uname = $value;
	} elsif ($key eq 'domain') {
	$udom = $value;
	}
	}
	$results{$uname.':'.$udom} = \%userhash;
	}
	}
	}
	}
	return %results;
	}

	sub get_instuser {
	my ($udom,$uname,$id) = @_;
	my $homeserver = &domain($udom,'primary');
	my ($outcome,%results);
	if ($homeserver ne '') {
	my $queryid=&reply("querysend:getinstuser:".&escape($uname).':'.
	&escape($id).':'.&escape($udom),$homeserver);
	my $host=&hostname($homeserver);
	if ($queryid !~/^\Q$host\E\_/) {
	&logthis('get_instuser invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom);
	return;
	}
	my $response = &get_query_reply($queryid);
	my $maxtries = 5;
	my $tries = 1;
	while (($response=~/^timeout/) && ($tries < $maxtries)) {
	$response = &get_query_reply($queryid);
	$tries ++;
	}
	if (!&error($response) && $response ne 'refused') {
	if ($response eq 'unavailable') {
	$outcome = $response;
	} else {
	$outcome = 'ok';
	my @matches = split(/\n/,$response);
	foreach my $match (@matches) {
	my ($key,$value) = split(/=/,$match);
	$results{&unescape($key)} = &thaw_unescape($value);
	}
	}
	}
	}
	my %userinfo;
	if (ref($results{$uname}) eq 'HASH') {
	%userinfo = %{$results{$uname}};
	}
	return ($outcome,%userinfo);
	}

	sub inst_rulecheck {
	my ($udom,$uname,$id,$item,$rules) = @_;
	my %returnhash;
	if ($udom ne '') {
	if (ref($rules) eq 'ARRAY') {
	@{$rules} = map {&escape($_);} (@{$rules});
	my $rulestr = join(':',@{$rules});
	my $homeserver=&domain($udom,'primary');
	if (($homeserver ne '') && ($homeserver ne 'no_host')) {
	my $response;
	if ($item eq 'username') {
	$response=&unescape(&reply('instrulecheck:'.&escape($udom).
	':'.&escape($uname).':'.$rulestr,
	$homeserver));
	} elsif ($item eq 'id') {
	$response=&unescape(&reply('instidrulecheck:'.&escape($udom).
	':'.&escape($id).':'.$rulestr,
	$homeserver));
	} elsif ($item eq 'selfcreate') {
	$response=&unescape(&reply('instselfcreatecheck:'.
	&escape($udom).':'.&escape($uname).
	':'.$rulestr,$homeserver));
	}
	if ($response ne 'refused') {
	my @pairs=split(/\&/,$response);
	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;
	}

	sub inst_userrules {
	my ($udom,$check) = @_;
	my (%ruleshash,@ruleorder);
	if ($udom ne '') {
	my $homeserver=&domain($udom,'primary');
	if (($homeserver ne '') && ($homeserver ne 'no_host')) {
	my $response;
	if ($check eq 'id') {
	$response=&reply('instidrules:'.&escape($udom),
	$homeserver);
	} elsif ($check eq 'email') {
	$response=&reply('instemailrules:'.&escape($udom),
	$homeserver);
} else {	} else {
$servers{$uhom}=$id.'='.$unam;	$response=&reply('instuserrules:'.&escape($udom),
	$homeserver);
	}
	if (($response ne 'refused') && ($response ne 'error') &&
	($response ne 'unknown_cmd') &&
	($response ne 'no_such_host')) {
	my ($hashitems,$orderitems) = split(/:/,$response);
	my @pairs=split(/\&/,$hashitems);
	foreach my $item (@pairs) {
	my ($key,$value)=split(/=/,$item,2);
	$key = &unescape($key);
	next if ($key =~ /^error: 2 /);
	$ruleshash{$key}=&thaw_unescape($value);
	}
	my @esc_order = split(/\&/,$orderitems);
	foreach my $item (@esc_order) {
	push(@ruleorder,&unescape($item));
	}
}	}
}	}
}	}
foreach (keys %servers) {	return (\%ruleshash,\@ruleorder);
&critical('idput:'.$udom.':'.$servers{$_},$_);	}

	# ------------------------- Get Authentication and Language Defaults for Domain

	sub get_domain_defaults {
	my ($domain) = @_;
	my $cachetime = 606024;
	my ($defauthtype,$defautharg,$deflang);
	my ($result,$cached)=&is_cached_new('domdefaults',$domain);
	if (defined($cached)) {
	if (ref($result) eq 'HASH') {
	return %{$result};
	}
}	}
	my %domdefaults;
	my %domconfig =
	&Apache::lonnet::get_dom('configuration',['defaults'],$domain);
	if (ref($domconfig{'defaults'}) eq 'HASH') {
	$domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};
	$domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};
	$domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'};
	} else {
	$domdefaults{'lang_def'} = &domain($domain,'lang_def');
	$domdefaults{'auth_def'} = &domain($domain,'auth_def');
	$domdefaults{'auth_arg_def'} = &domain($domain,'auth_arg_def');
	}
	&Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults,
	$cachetime);
	return %domdefaults;
}	}

# --------------------------------------------------- Assign a key to a student	# --------------------------------------------------- Assign a key to a student
Line 746 sub assign_access_key {	Line 1211 sub assign_access_key {
# key now belongs to user	# key now belongs to user
my $envkey='key.'.$cdom.'_'.$cnum;	my $envkey='key.'.$cdom.'_'.$cnum;
if (&put('environment',{$envkey => $ckey}) eq 'ok') {	if (&put('environment',{$envkey => $ckey}) eq 'ok') {
&appenv('environment.'.$envkey => $ckey);	&appenv({'environment.'.$envkey => $ckey});
return 'ok';	return 'ok';
} else {	} else {
return	return
Line 847 sub validate_access_key {	Line 1312 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 878 sub getsection {	Line 1358 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 924 my %remembered;	Line 1403 my %remembered;
my %accessed;	my %accessed;
my $kicks=0;	my $kicks=0;
my $hits=0;	my $hits=0;
	sub make_key {
	my ($name,$id) = @_;
	if (length($id) > 65
	&& length(&escape($id)) > 200) {
	$id=length($id).':'.&Digest::MD5::md5_hex($id);
	}
	return &escape($name.':'.$id);
	}

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

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

sub do_cache_new {	sub do_cache_new {
my ($name,$id,$value,$time,$debug) = @_;	my ($name,$id,$value,$time,$debug) = @_;
$id=&escape($name.':'.$id);	$id=&make_key($name,$id);
my $setvalue=$value;	my $setvalue=$value;
if (!defined($setvalue)) {	if (!defined($setvalue)) {
$setvalue='__undef__';	$setvalue='__undef__';
Line 967 sub do_cache_new {	Line 1455 sub do_cache_new {
$time=600;	$time=600;
}	}
if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }	if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }
$memcache->set($id,$setvalue,$time);	my $result = $memcache->set($id,$setvalue,$time);
	if (! $result) {
	&logthis("caching of id -> $id failed");
	$memcache->disconnect_all();
	}
# need to make a copy of $value	# need to make a copy of $value
#&make_room($id,$value,$debug);	&make_room($id,$value,$debug);
return $value;	return $value;
}	}

sub make_room {	sub make_room {
my ($id,$value,$debug)=@_;	my ($id,$value,$debug)=@_;
$remembered{$id}=$value;
	$remembered{$id}= (ref($value)) ? &Storable::dclone($value)
	: $value;
if ($to_remember<0) { return; }	if ($to_remember<0) { return; }
$accessed{$id}=[&gettimeofday()];	$accessed{$id}=[&gettimeofday()];
if (scalar(keys(%remembered)) <= $to_remember) { return; }	if (scalar(keys(%remembered)) <= $to_remember) { return; }
Line 1136 sub repcopy {	Line 1630 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 1200 sub ssi_body {	Line 1695 sub ssi_body {
if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) {	if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) {
$form{'LONCAPA_INTERNAL_no_discussion'}='true';	$form{'LONCAPA_INTERNAL_no_discussion'}='true';
}	}
my $output=($filelink=~/^http\:/?&externalssi($filelink):	my $output='';
&ssi($filelink,%form));	my $response;
	if ($filelink=~/^http\:/) {
	($output,$response)=&externalssi($filelink);
	} else {
	($output,$response)=&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\>.?$//si;
return $output;	if (wantarray) {
	return ($output, $response);
	} else {
	return $output;
	}
}	}

# --------------------------------------------------------- Server Side Include	# --------------------------------------------------------- Server Side Include
Line 1219 sub absolute_url {	Line 1723 sub absolute_url {
return $protocol.$host_name;	return $protocol.$host_name;
}	}

	#
	# Server side include.
	# Parameters:
	# fn Possibly encrypted resource name/id.
	# form Hash that describes how the rendering should be done
	# and other things.
	# Returns:
	# Scalar context: The content of the response.
	# Array context: 2 element list of the content and the full response object.
	#
sub ssi {	sub ssi {

my ($fn,%form)=@_;	my ($fn,%form)=@_;

my $ua=new LWP::UserAgent;	my $ua=new LWP::UserAgent;

my $request;	my $request;

$form{'no_update_last_known'}=1;	$form{'no_update_last_known'}=1;
	&Apache::lonenc::check_encrypt(\$fn);
if (%form) {	if (%form) {
$request=new HTTP::Request('POST',&absolute_url().$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));
Line 1239 sub ssi {	Line 1751 sub ssi {
$request->header(Cookie => $ENV{'HTTP_COOKIE'});	$request->header(Cookie => $ENV{'HTTP_COOKIE'});
my $response=$ua->request($request);	my $response=$ua->request($request);

return $response->content;	if (wantarray) {
	return ($response->content, $response);
	} else {
	return $response->content;
	}
}	}

sub externalssi {	sub externalssi {
Line 1247 sub externalssi {	Line 1763 sub externalssi {
my $ua=new LWP::UserAgent;	my $ua=new LWP::UserAgent;
my $request=new HTTP::Request('GET',$url);	my $request=new HTTP::Request('GET',$url);
my $response=$ua->request($request);	my $response=$ua->request($request);
return $response->content;	if (wantarray) {
	return ($response->content, $response);
	} else {
	return $response->content;
	}
}	}

# -------------------------------- Allow a /uploaded/ URI to be vouched for	# -------------------------------- Allow a /uploaded/ URI to be vouched for
Line 1260 sub allowuploaded {	Line 1780 sub allowuploaded {
my %httpref=();	my %httpref=();
my $httpurl=&hreflocation('',$url);	my $httpurl=&hreflocation('',$url);
$httpref{'httpref.'.$httpurl}=$srcurl;	$httpref{'httpref.'.$httpurl}=$srcurl;
&Apache::lonnet::appenv(%httpref);	&Apache::lonnet::appenv(\%httpref);
}	}

# --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course	# --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course
Line 1384 sub store_edited_file {	Line 1904 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 1405 sub clean_filename {	Line 1927 sub clean_filename {
# $coursedoc - if true up to the current course	# $coursedoc - if true up to the current course
# if false	# if false
# $subdir - directory in userfile to store the file into	# $subdir - directory in userfile to store the file into
# $parser, $allfiles, $codebase - unknown	# $parser - instruction to parse file for objects ($parser = parse)
#	# $allfiles - reference to hash for embedded objects
	# $codebase - reference to hash for codebase of java objects
	# $desuname - username for permanent storage of uploaded file
	# $dsetudom - domain for permanaent storage of uploaded file
	# $thumbwidth - width (pixels) of thumbnail to make for uploaded image
	# $thumbheight - height (pixels) of thumbnail to make for uploaded image
	#
# output: url of file in userspace, or error: <message>	# output: url of file in userspace, or error: <message>
# or /adm/notfound.html if failure to upload occurse	# or /adm/notfound.html if failure to upload occurse


sub userfileupload {	sub userfileupload {
my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname,$destudom)=@_;	my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname,
	$destudom,$thumbwidth,$thumbheight)=@_;
if (!defined($subdir)) { $subdir='unknown'; }	if (!defined($subdir)) { $subdir='unknown'; }
my $fname=$env{'form.'.$formname.'.filename'};	my $fname=$env{'form.'.$formname.'.filename'};
$fname=&clean_filename($fname);	$fname=&clean_filename($fname);
Line 1459 sub userfileupload {	Line 1988 sub userfileupload {
if ($env{'form.folder'} =~ m/^(default\|supplemental)/) {	if ($env{'form.folder'} =~ m/^(default\|supplemental)/) {
return &finishuserfileupload($docuname,$docudom,	return &finishuserfileupload($docuname,$docudom,
$formname,$fname,$parser,$allfiles,	$formname,$fname,$parser,$allfiles,
$codebase);	$codebase,$thumbwidth,$thumbheight);
} else {	} else {
$fname=$env{'form.folder'}.'/'.$fname;	$fname=$env{'form.folder'}.'/'.$fname;
return &process_coursefile('uploaddoc',$docuname,$docudom,	return &process_coursefile('uploaddoc',$docuname,$docudom,
Line 1469 sub userfileupload {	Line 1998 sub userfileupload {
} elsif (defined($destuname)) {	} elsif (defined($destuname)) {
my $docuname=$destuname;	my $docuname=$destuname;
my $docudom=$destudom;	my $docudom=$destudom;
return &finishuserfileupload($docuname,$docudom,$formname,	return &finishuserfileupload($docuname,$docudom,$formname,$fname,
$fname,$parser,$allfiles,$codebase);	$parser,$allfiles,$codebase,
	$thumbwidth,$thumbheight);

} else {	} else {
my $docuname=$env{'user.name'};	my $docuname=$env{'user.name'};
Line 1479 sub userfileupload {	Line 2009 sub userfileupload {
$docuname=$env{'course.'.$env{'request.course.id'}.'.num'};	$docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
$docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};	$docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
}	}
return &finishuserfileupload($docuname,$docudom,$formname,	return &finishuserfileupload($docuname,$docudom,$formname,$fname,
$fname,$parser,$allfiles,$codebase);	$parser,$allfiles,$codebase,
	$thumbwidth,$thumbheight);
}	}
}	}

sub finishuserfileupload {	sub finishuserfileupload {
my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase) = @_;	my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase,
	$thumbwidth,$thumbheight) = @_;
my $path=$docudom.'/'.$docuname.'/';	my $path=$docudom.'/'.$docuname.'/';
my $filepath=$perlvar{'lonDocRoot'};	my $filepath=$perlvar{'lonDocRoot'};
my ($fnamepath,$file);	my ($fnamepath,$file,$fetchthumb);
$file=$fname;	$file=$fname;
if ($fname=~m\|/\|) {	if ($fname=~m\|/\|) {
($fnamepath,$file) = ($fname =~ m\|^(.*)/([^/]+)$\|);	($fnamepath,$file) = ($fname =~ m\|^(.*)/([^/]+)$\|);
Line 1524 sub finishuserfileupload {	Line 2056 sub finishuserfileupload {
' for embedded media: '.$parse_result);	' for embedded media: '.$parse_result);
}	}
}	}
	if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {
	my $input = $filepath.'/'.$file;
	my $output = $filepath.'/'.'tn-'.$file;
	my $thumbsize = $thumbwidth.'x'.$thumbheight;
	system("convert -sample $thumbsize $input $output");
	if (-e $filepath.'/'.'tn-'.$file) {
	$fetchthumb = 1;
	}
	}

# Notify homeserver to grep it	# Notify homeserver to grep it
#	#
my $docuhome=&homeserver($docuname,$docudom);	my $docuhome=&homeserver($docuname,$docudom);
my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);	my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);
if ($fetchresult eq 'ok') {	if ($fetchresult eq 'ok') {
	if ($fetchthumb) {
	my $thumbresult= &reply('fetchuserfile:'.$path.'tn-'.$file,$docuhome);
	if ($thumbresult ne 'ok') {
	&logthis('Failed to transfer '.$path.'tn-'.$file.' to host '.
	$docuhome.': '.$thumbresult);
	}
	}
#	#
# Return the URL to it	# Return the URL to it
return '/uploaded/'.$path.$file;	return '/uploaded/'.$path.$file;
Line 1536 sub finishuserfileupload {	Line 2085 sub finishuserfileupload {
&logthis('Failed to transfer '.$path.$file.' to host '.$docuhome.	&logthis('Failed to transfer '.$path.$file.' to host '.$docuhome.
': '.$fetchresult);	': '.$fetchresult);
return '/adm/notfound.html';	return '/adm/notfound.html';
}	}
}	}

sub extract_embedded_items {	sub extract_embedded_items {
Line 1560 sub extract_embedded_items {	Line 2109 sub extract_embedded_items {
while (my $t=$p->get_token()) {	while (my $t=$p->get_token()) {
if ($t->[0] eq 'S') {	if ($t->[0] eq 'S') {
my ($tagname, $attr) = ($t->[1],$t->[2]);	my ($tagname, $attr) = ($t->[1],$t->[2]);
push (@state, $tagname);	push(@state, $tagname);
if (lc($tagname) eq 'allow') {	if (lc($tagname) eq 'allow') {
&add_filetype($allfiles,$attr->{'src'},'src');	&add_filetype($allfiles,$attr->{'src'},'src');
}	}
if (lc($tagname) eq 'img') {	if (lc($tagname) eq 'img') {
&add_filetype($allfiles,$attr->{'src'},'src');	&add_filetype($allfiles,$attr->{'src'},'src');
}	}
	if (lc($tagname) eq 'a') {
	&add_filetype($allfiles,$attr->{'href'},'href');
	}
if (lc($tagname) eq 'script') {	if (lc($tagname) eq 'script') {
if ($attr->{'archive'} =~ /\.jar$/i) {	if ($attr->{'archive'} =~ /\.jar$/i) {
&add_filetype($allfiles,$attr->{'archive'},'archive');	&add_filetype($allfiles,$attr->{'archive'},'archive');
Line 1656 sub removeuploadedurl {	Line 2208 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 1668 sub mkdiruserfile {	Line 2233 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 1695 sub flushcourselogs {	Line 2275 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 1709 sub flushcourselogs {	Line 2288 sub flushcourselogs {
delete $courselogs{$crsid};	delete $courselogs{$crsid};
}	}
}	}
if ($courseidbuffer{$coursehombuf{$crsid}}) {	$courseidbuffer{$coursehombuf{$crsid}}{$crsid} = {
$courseidbuffer{$coursehombuf{$crsid}}.='&'.	'description' => $coursedescrbuf{$crsid},
&escape($crsid).'='.&escape($coursedescrbuf{$crsid}).	'inst_code' => $courseinstcodebuf{$crsid},
':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid});	'type' => $coursetypebuf{$crsid},
} else {	'owner' => $courseownerbuf{$crsid},
$courseidbuffer{$coursehombuf{$crsid}}=	};
&escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid});
}
}	}
#	#
# Write course id database (reverse lookup) to homeserver of courses	# Write course id database (reverse lookup) to homeserver of courses
# Is used in pickcourse	# Is used in pickcourse
#	#
foreach (keys %courseidbuffer) {	foreach my $crs_home (keys(%courseidbuffer)) {
&courseidput($hostdom{$_},$courseidbuffer{$_},$_);	my $response = &courseidput(&host_domain($crs_home),
	$courseidbuffer{$crs_home},
	$crs_home,'timeonly');
}	}
#	#
# File accesses	# File accesses
Line 1733 sub flushcourselogs {	Line 2311 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 1754 sub flushcourselogs {	Line 2333 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 1765 sub flushcourselogs {	Line 2344 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 1780 sub flushcourselogs {	Line 2358 sub flushcourselogs {
#	#
my %domrolebuffer = ();	my %domrolebuffer = ();
foreach my $entry (keys %domainrolehash) {	foreach my $entry (keys %domainrolehash) {
my ($role,$uname,$udom,$runame,$rudom,$rsec)=split/:/,$entry;	my ($role,$uname,$udom,$runame,$rudom,$rsec)=split(/:/,$entry);
if ($domrolebuffer{$rudom}) {	if ($domrolebuffer{$rudom}) {
$domrolebuffer{$rudom}.='&'.&escape($entry).	$domrolebuffer{$rudom}.='&'.&escape($entry).
'='.&escape($domainrolehash{$entry});	'='.&escape($domainrolehash{$entry});
Line 1791 sub flushcourselogs {	Line 2369 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 1838 sub courseacclog {	Line 2415 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 1886 sub userrolelog {	Line 2463 sub userrolelog {
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}	{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
=$tend.':'.$tstart;	=$tend.':'.$tstart;
}	}
	if (($env{'request.role'} =~ /dc\./) &&
	(($trole=~/^au/) \|\| ($trole=~/^in/) \|\|
	($trole=~/^cc/) \|\| ($trole=~/^ep/) \|\|
	($trole=~/^cr/) \|\| ($trole=~/^ta/))) {
	$userrolehash
	{$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'}
	=$tend.':'.$tstart;
	}
if (($trole=~/^dc/) \|\| ($trole=~/^ad/) \|\|	if (($trole=~/^dc/) \|\| ($trole=~/^ad/) \|\|
($trole=~/^li/) \|\| ($trole=~/^li/) \|\|	($trole=~/^li/) \|\| ($trole=~/^li/) \|\|
($trole=~/^au/) \|\| ($trole=~/^dg/) \|\|	($trole=~/^au/) \|\| ($trole=~/^dg/) \|\|
Line 1897 sub userrolelog {	Line 2482 sub userrolelog {
}	}
}	}

	sub courserolelog {
	my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,$context)=@_;
	if (($trole eq 'cc') \|\| ($trole eq 'in') \|\|
	($trole eq 'ep') \|\| ($trole eq 'ad') \|\|
	($trole eq 'ta') \|\| ($trole eq 'st') \|\|
	($trole=~/^cr/) \|\| ($trole eq 'gr')) {
	if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) {
	my $cdom = $1;
	my $cnum = $2;
	my $sec = $3;
	my $namespace = 'rolelog';
	my %storehash = (
	role => $trole,
	start => $tstart,
	end => $tend,
	selfenroll => $selfenroll,
	context => $context,
	);
	if ($trole eq 'gr') {
	$namespace = 'groupslog';
	$storehash{'group'} = $sec;
	} else {
	$storehash{'section'} = $sec;
	}
	&instructor_log($namespace,\%storehash,$delflag,$username,$domain,$cnum,$cdom);
	}
	}
	return;
	}

sub get_course_adv_roles {	sub get_course_adv_roles {
my $cid=shift;	my ($cid,$codes) = @_;
$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;	if ($user !~ /:/) {
	$nothide{join(':',split(/[\@]/,$user))}=1;
	} else {
	$nothide{$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);	if ($codes) {
if ($section) { $key.=' (Sec/Grp '.$section.')'; }	if ($section) { $role .= ':'.$section; }
if ($returnhash{$key}) {	if ($returnhash{$role}) {
$returnhash{$key}.=','.$username.':'.$domain;	$returnhash{$role}.=','.$username.':'.$domain;
	} else {
	$returnhash{$role}=$username.':'.$domain;
	}
} else {	} else {
$returnhash{$key}=$username.':'.$domain;	my $key=&plaintext($role);
	if ($section) { $key.=' (Section '.$section.')'; }
	if ($returnhash{$key}) {
	$returnhash{$key}.=','.$username.':'.$domain;
	} else {
	$returnhash{$key}=$username.':'.$domain;
	}
}	}
}	}
return %returnhash;	return %returnhash;
}	}

sub get_my_roles {	sub get_my_roles {
my ($uname,$udom)=@_;	my ($uname,$udom,$context,$types,$roles,$roledoms,$withsec,$hidepriv)=@_;
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,%nothide);
	if ($context eq 'userroles') {
	%dumphash = &dump('roles',$udom,$uname);
	} else {
	%dumphash=
&dump('nohist_userroles',$udom,$uname);	&dump('nohist_userroles',$udom,$uname);
	if ($hidepriv) {
	my %coursehash=&coursedescription($udom.'_'.$uname);
	foreach my $user (split(/\s\,\s/,$coursehash{'nothideprivileged'})) {
	if ($user !~ /:/) {
	$nothide{join(':',split(/[\@]/,$user))} = 1;
	} else {
	$nothide{$user} = 1;
	}
	}
	}
	}
my %returnhash=();	my %returnhash=();
my $now=time;	my $now=time;
foreach (keys %dumphash) {	foreach my $entry (keys(%dumphash)) {
my ($tend,$tstart)=split(/\:/,$dumphash{$_});	my ($role,$tend,$tstart);
	if ($context eq 'userroles') {
	($role,$tend,$tstart)=split(/_/,$dumphash{$entry});
	} else {
	($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';
$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;	}
}	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 ($rolecode,$username,$domain,$section,$area);
	if ($context eq 'userroles') {
	($area,$rolecode) = split(/_/,$entry);
	(undef,$domain,$username,$section) = split(/\//,$area);
	} else {
	($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})) {
	if ($role =~ /^cr\//) {
	if (!grep(/^cr$/,@{$roles})) {
	next;
	}
	} else {
	next;
	}
	}
	}
	if ($hidepriv) {
	if ((&privileged($username,$domain)) &&
	(!$nothide{$username.':'.$domain})) {
	next;
	}
	}
	if ($withsec) {
	$returnhash{$username.':'.$domain.':'.$role.':'.$section} =
	$tstart.':'.$tend;
	} else {
	$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
	}
	}
return %returnhash;	return %returnhash;
}	}

Line 1955 sub get_my_roles {	Line 2650 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 1964 sub getannounce {	Line 2659 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 1983 sub getannounce {	Line 2678 sub getannounce {
#	#

sub courseidput {	sub courseidput {
my ($domain,$what,$coursehome)=@_;	my ($domain,$storehash,$coursehome,$caller) = @_;
return &reply('courseidput:'.$domain.':'.$what,$coursehome);	my $outcome;
	if ($caller eq 'timeonly') {
	my $cids = '';
	foreach my $item (keys(%$storehash)) {
	$cids.=&escape($item).'&';
	}
	$cids=~s/\&$//;
	$outcome = &reply('courseidputhash:'.$domain.':'.$caller.':'.$cids,
	$coursehome);
	} else {
	my $items = '';
	foreach my $item (keys(%$storehash)) {
	$items.= &escape($item).'='.
	&freeze_escape($$storehash{$item}).'&';
	}
	$items=~s/\&$//;
	$outcome = &reply('courseidputhash:'.$domain.':'.$caller.':'.$items,
	$coursehome);
	}
	if ($outcome eq 'unknown_cmd') {
	my $what;
	foreach my $cid (keys(%$storehash)) {
	$what .= &escape($cid).'=';
	foreach my $item ('description','inst_code','owner','type') {
	$what .= &escape($storehash->{$cid}{$item}).':';
	}
	$what =~ s/\:$/&/;
	}
	$what =~ s/\&$//;
	return &reply('courseidput:'.$domain.':'.$what,$coursehome);
	} else {
	return $outcome;
	}
}	}

sub courseiddump {	sub courseiddump {
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter)=@_;	my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
my %returnhash=();	$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
unless ($domfilter) { $domfilter=''; }	$selfenrollonly)=@_;
foreach my $tryserver (keys %libserv) {	my $as_hash = 1;
if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) \|\| (!defined($hostidflag)) ) {	my %returnhash;
if ((!$domfilter) \|\| ($hostdom{$tryserver} eq $domfilter)) {	if (!$domfilter) { $domfilter=''; }
foreach (	my %libserv = &all_library();
split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.	foreach my $tryserver (keys(%libserv)) {
$sincefilter.':'.&escape($descfilter).':'.	if ( ( $hostidflag == 1
&escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter),	&& grep(/^\Q$tryserver\E$/,@{$hostidref}) )
$tryserver))) {	\|\| (!defined($hostidflag)) ) {
my ($key,$value)=split(/\=/,$_);
if (($key) && ($value)) {	if (($domfilter eq '') \|\|
$returnhash{&unescape($key)}=$value;	(&host_domain($tryserver) eq $domfilter)) {
}	my $rep =
	&reply('courseiddump:'.&host_domain($tryserver).':'.
	$sincefilter.':'.&escape($descfilter).':'.
	&escape($instcodefilter).':'.&escape($ownerfilter).
	':'.&escape($coursefilter).':'.&escape($typefilter).
	':'.&escape($regexp_ok).':'.$as_hash.':'.
	&escape($selfenrollonly),$tryserver);
	my @pairs=split(/\&/,$rep);
	foreach my $item (@pairs) {
	my ($key,$value)=split(/\=/,$item,2);
	$key = &unescape($key);
	next if ($key =~ /^error: 2 /);
	my $result = &thaw_unescape($value);
	if (ref($result) eq 'HASH') {
	$returnhash{$key}=$result;
	} else {
	my @responses = split(/:/,$value);
	my @items = ('description','inst_code','owner','type');
	for (my $i=0; $i<@responses; $i++) {
	$returnhash{$key}{$items[$i]} = &unescape($responses[$i]);
	}
	}
}	}
}	}
}	}
Line 2023 sub dcmailput {	Line 2771 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 2047 sub get_domain_roles {	Line 2796 sub get_domain_roles {
if (undef($enddate) \|\| $enddate eq '') {	if (undef($enddate) \|\| $enddate eq '') {
$enddate = '.';	$enddate = '.';
}	}
my $rolelist = join(':',@{$roles});	my $rolelist;
	if (ref($roles) eq 'ARRAY') {
	$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 2070 sub get_domain_roles {	Line 2822 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 'course') {
	$res='course';
	} elsif ($type eq 'map') {
$res=&symbread($map);	$res=&symbread($map);
} else {	} else {
$res=$symb;	$res=$symb;
Line 2084 sub get_first_access {	Line 2838 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 'course') {
	$res='course';
	} elsif ($type eq 'map') {
$res=&symbread($map);	$res=&symbread($map);
} else {	} else {
$res=$symb;	$res=$symb;
Line 2151 sub checkin {	Line 2907 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 2278 sub hash2str {	Line 3034 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 2578 sub store {	Line 3334 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 2614 sub cstore {	Line 3370 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 2647 sub restore {	Line 3403 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 2694 sub coursedescription {	Line 3450 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 2715 sub coursedescription {	Line 3472 sub coursedescription {
}	}
}	}
if (!$args->{'one_time'}) {	if (!$args->{'one_time'}) {
&appenv(%envhash);	&appenv(\%envhash);
}	}
return %returnhash;	return %returnhash;
}	}
Line 2729 sub privileged {	Line 3486 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 2763 sub rolesinit {	Line 3520 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 2819 sub custom_roleprivs {	Line 3576 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 2849 sub group_roleprivs {	Line 3606 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 2880 sub set_userprivs {	Line 3637 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+\|cr/\w+/\w+/\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 2895 sub set_userprivs {	Line 3652 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/) \|\| ($role=~/^aa/)) { $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 2913 sub set_userprivs {	Line 3670 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 2924 sub set_userprivs {	Line 3683 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 2939 sub get {	Line 3698 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 2951 sub get {	Line 3710 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 2990 sub dump {	Line 3749 sub dump {

sub dumpstore {	sub dumpstore {
my ($namespace,$udomain,$uname,$regexp,$range)=@_;	my ($namespace,$udomain,$uname,$regexp,$range)=@_;
return &dump($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);
	next if ($key =~ /^error: 2 /);
	$returnhash{$key}=&thaw_unescape($value);
	}
	return %returnhash;
}	}

# -------------------------------------------------------------- keys interface	# -------------------------------------------------------------- keys interface
Line 3002 sub getkeys {	Line 3777 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 3023 sub currentdump {	Line 3799 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 3048 sub convert_dump_to_currentdump{	Line 3824 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 3109 sub put {	Line 3887 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 3162 sub old_putstore {	Line 3940 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 3191 sub cput {	Line 3969 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 3203 sub cput {	Line 3981 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 3214 sub eget {	Line 3992 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 3223 sub eget {	Line 4001 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 3240 sub tmpget {	Line 4021 sub tmpget {
my %returnhash;	my %returnhash;
foreach my $item (split(/\&/,$rep)) {	foreach my $item (split(/\&/,$rep)) {
my ($key,$value)=split(/=/,$item);	my ($key,$value)=split(/=/,$item);
	next if ($key =~ /^error: 2 /);
$returnhash{&unescape($key)}=&thaw_unescape($value);	$returnhash{&unescape($key)}=&thaw_unescape($value);
}	}
return %returnhash;	return %returnhash;
Line 3258 sub portfolio_access {	Line 4040 sub portfolio_access {
my ($requrl) = @_;	my ($requrl) = @_;
my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl);	my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl);
my $result = &get_portfolio_access($udom,$unum,$file_name,$group);	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') {	if ($result eq 'ok') {
return 'F';	return 'F';
} elsif ($result =~ /^[^:]+:guest_/) {	} elsif ($result =~ /^[^:]+:guest_/) {
Line 3321 sub get_portfolio_access {	Line 4119 sub get_portfolio_access {
}	}
if (@users > 0) {	if (@users > 0) {
foreach my $userkey (@users) {	foreach my $userkey (@users) {
if (exists($access_hash->{$userkey}{'users'}{$env{'user.name'}.':'.$env{'user.domain'}})) {	if (ref($access_hash->{$userkey}{'users'}) eq 'ARRAY') {
return 'ok';	foreach my $item (@{$access_hash->{$userkey}{'users'}}) {
}	if (ref($item) eq 'HASH') {
	if (($item->{'uname'} eq $env{'user.name'}) &&
	($item->{'udom'} eq $env{'user.domain'})) {
	return 'ok';
	}
	}
	}
	}
}	}
}	}
my %roleshash;	my %roleshash;
Line 3333 sub get_portfolio_access {	Line 4138 sub get_portfolio_access {
my (%allgroups,%allroles);	my (%allgroups,%allroles);
my ($start,$end,$role,$sec,$group);	my ($start,$end,$role,$sec,$group);
foreach my $envkey (%env) {	foreach my $envkey (%env) {
if ($envkey =~ m-^user\.role\.(gr\|cc\|in\|ta\|ep\|st)\./([^/]+)/([^/]+)/?([^/]*)$-) {	if ($envkey =~ m-^user\.role\.(gr\|cc\|in\|ta\|ep\|st)\./($match_domain)/($match_courseid)/?([^/]*)$-) {
my $cid = $2.'_'.$3;	my $cid = $2.'_'.$3;
if ($1 eq 'gr') {	if ($1 eq 'gr') {
$group = $4;	$group = $4;
Line 3346 sub get_portfolio_access {	Line 4151 sub get_portfolio_access {
}	}
$allroles{$cid}{$1}{$sec} = $env{$envkey};	$allroles{$cid}{$1}{$sec} = $env{$envkey};
}	}
} elsif ($envkey =~ m-^user\.role\./cr/(\w+/\w+/\w)./([^/]+)/([^/]+)/?([^/])$-) {	} elsif ($envkey =~ m-^user\.role\./cr/($match_domain/$match_username/\w)./($match_domain)/($match_courseid)/?([^/])$-) {
my $cid = $2.'_'.$3;	my $cid = $2.'_'.$3;
if ($4 eq '') {	if ($4 eq '') {
$sec = 'none';	$sec = 'none';
Line 3441 sub parse_portfolio_url {	Line 4246 sub parse_portfolio_url {

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

if ($url =~ m-^/*uploaded/([^/]+)/([^/]+)/portfolio(/.+)$-) {	if ($url =~ m-^/*(?:uploaded\|editupload)/($match_domain)/($match_username)/portfolio(/.+)$-) {
$type = 1;	$type = 1;
$udom = $1;	$udom = $1;
$unum = $2;	$unum = $2;
$file_name = $3;	$file_name = $3;
} elsif ($url =~ m-^/*uploaded/([^/]+)/([^/]+)/groups/([^/]+)/portfolio/(.+)$-) {	} elsif ($url =~ m-^/*(?:uploaded\|editupload)/($match_domain)/($match_courseid)/groups/([^/]+)/portfolio/(.+)$-) {
$type = 2;	$type = 2;
$udom = $1;	$udom = $1;
$unum = $2;	$unum = $2;
Line 3464 sub is_portfolio_url {	Line 4269 sub is_portfolio_url {
return scalar(&parse_portfolio_url($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,$type)=split(/\:/,$right);
if ($role) {	if ($type eq 'user') {
if ($role ne $urole) { next; }	foreach my $scope (split(/\s\,\s/,$realm)) {
}	my ($tdom,$tuname)=split(m{/},$scope);
foreach (split(/\s\,\s/,$realm)) {	if ($tdom) {
my ($tdom,$tcrs,$tsec)=split(/\_/,$_);	if ($tdom ne $env{'user.domain'}) { next; }
if ($tdom) {	}
if ($tdom ne $udom) { next; }	if ($tuname) {
}	if ($tuname ne $env{'user.name'}) { next; }
if ($tcrs) {	}
if ($tcrs ne $ucrs) { next; }	$access=($effect eq 'allow');
}	last;
if ($tsec) {	}
if ($tsec ne $usec) { next; }	} else {
}	if ($role) {
$access=($effect eq 'allow');	if ($role ne $urole) { next; }
last;	}
}	foreach my $scope (split(/\s\,\s/,$realm)) {
if ($realm eq '' && $role eq '') {	my ($tdom,$tcrs,$tsec)=split(/\_/,$scope);
$access=($effect eq 'allow');	if ($tdom) {
	if ($tdom ne $udom) { next; }
	}
	if ($tcrs) {
	if ($tcrs ne $ucrs) { next; }
	}
	if ($tsec) {
	if ($tsec ne $usec) { next; }
	}
	$access=($effect eq 'allow');
	last;
	}
	if ($realm eq '' && $role eq '') {
	$access=($effect eq 'allow');
	}
}	}
}	}
return $access;	return $access;
Line 3501 sub customaccess {	Line 4330 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{/(?:smppg\|bulletinboard)$}))	if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg\|bulletinboard)$}))
Line 3519 sub allowed {	Line 4357 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 portfolio for rgf priv in group, or mdg or vcg in course.	# bre access to group portfolio for rgf priv in group, or mdg or vcg in course.
Line 3690 sub allowed {	Line 4535 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 3795 sub allowed {	Line 4640 sub allowed {
unless ($env{'request.course.id'}) {	unless ($env{'request.course.id'}) {
if ($thisallowed eq 'A') {	if ($thisallowed eq 'A') {
return 'A';	return 'A';
	} elsif ($thisallowed eq 'B') {
	return 'B';
} else {	} else {
return '1';	return '1';
}	}
Line 3862 sub allowed {	Line 4709 sub allowed {

if ($thisallowed eq 'A') {	if ($thisallowed eq 'A') {
return 'A';	return 'A';
	} elsif ($thisallowed eq 'B') {
	return 'B';
}	}
return 'F';	return 'F';
}	}
Line 3915 sub get_symb_from_alias {	Line 4764 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 3924 sub definerole {	Line 4773 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 3933 sub definerole {	Line 4782 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 3957 sub definerole {	Line 4806 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 3980 sub log_query {	Line 4830 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;
	}

	# -------------------------- Update MySQL allusers table

	sub update_allusers_table {
	my ($uname,$udom,$names) = @_;
	my $homeserver = &homeserver($uname,$udom);
	my $queryid=
	&reply('querysend:allusers:'.&escape($uname).':'.&escape($udom).':'.
	'lastname='.&escape($names->{'lastname'}).'%%'.
	'firstname='.&escape($names->{'firstname'}).'%%'.
	'middlename='.&escape($names->{'middlename'}).'%%'.
	'generation='.&escape($names->{'generation'}).'%%'.
	'permanentemail='.&escape($names->{'permanentemail'}).'%%'.
	'id='.&escape($names->{'id'}),$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 4000 sub fetch_enrollment_query {	Line 4879 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 4022 sub fetch_enrollment_query {	Line 4901 sub fetch_enrollment_query {
if ( ($reply =~/^timeout/) \|\| ($reply =~/^error/) ) {	if ( ($reply =~/^timeout/) \|\| ($reply =~/^error/) ) {
&logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);	&logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
} 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 4065 sub get_query_reply {	Line 4944 sub get_query_reply {
sleep 2;	sleep 2;
if (-e $replyfile.'.end') {	if (-e $replyfile.'.end') {
if (open(my $fh,$replyfile)) {	if (open(my $fh,$replyfile)) {
$reply.=<$fh>;	$reply = join('',<$fh>);
close($fh);	close($fh);
} else { return 'error: reply_file_error'; }	} else { return 'error: reply_file_error'; }
return &unescape($reply);	return &unescape($reply);
}	}
Line 4097 sub courselog_query {	Line 4976 sub courselog_query {
}	}

sub userlog_query {	sub userlog_query {
	#
	# possible filters:
	# action: log check role
	# start: timestamp
	# end: timestamp
	#
my ($uname,$udom,%filters)=@_;	my ($uname,$udom,%filters)=@_;
return &log_query($uname,$udom,'userlog',%filters);	return &log_query($uname,$udom,'userlog',%filters);
}	}
Line 4105 sub userlog_query {	Line 4990 sub userlog_query {

sub auto_run {	sub auto_run {
my ($cnum,$cdom) = @_;	my ($cnum,$cdom) = @_;
my $homeserver = &homeserver($cnum,$cdom);	my $response = 0;
my $response = &reply('autorun:'.$cdom,$homeserver);	my $settings;
	my %domconfig = &get_dom('configuration',['autoenroll'],$cdom);
	if (ref($domconfig{'autoenroll'}) eq 'HASH') {
	$settings = $domconfig{'autoenroll'};
	if ($settings->{'run'} eq '1') {
	$response = 1;
	}
	} else {
	my $homeserver;
	if (&is_course($cdom,$cnum)) {
	$homeserver = &homeserver($cnum,$cdom);
	} else {
	$homeserver = &domain($cdom,'primary');
	}
	if ($homeserver ne 'no_host') {
	$response = &reply('autorun:'.$cdom,$homeserver);
	}
	}
return $response;	return $response;
}	}

Line 4116 sub auto_get_sections {	Line 5018 sub auto_get_sections {
my @secs = ();	my @secs = ();
my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));	my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));
unless ($response eq 'refused') {	unless ($response eq 'refused') {
@secs = split/:/,$response;	@secs = split(/:/,$response);
}	}
return @secs;	return @secs;
}	}
Line 4136 sub auto_validate_courseID {	Line 5038 sub auto_validate_courseID {
}	}

sub auto_create_password {	sub auto_create_password {
my ($cnum,$cdom,$authparam) = @_;	my ($cnum,$cdom,$authparam,$udom) = @_;
my $homeserver = &homeserver($cnum,$cdom);	my ($homeserver,$response);
my $create_passwd = 0;	my $create_passwd = 0;
my $authchk = '';	my $authchk = '';
my $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver));	if ($udom =~ /^$match_domain$/) {
if ($response eq 'refused') {	$homeserver = &domain($udom,'primary');
$authchk = 'refused';	}
	if ($homeserver eq '') {
	if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) {
	$homeserver = &homeserver($cnum,$cdom);
	}
	}
	if ($homeserver eq '') {
	$authchk = 'nodomain';
} else {	} else {
($authparam,$create_passwd,$authchk) = split/:/,$response;	$response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver));
	if ($response eq 'refused') {
	$authchk = 'refused';
	} else {
	($authparam,$create_passwd,$authchk) = split(/:/,$response);
	}
}	}
return ($authparam,$create_passwd,$authchk);	return ($authparam,$create_passwd,$authchk);
}	}
Line 4191 sub auto_photochoice {	Line 5105 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 4226 sub auto_photoupdate {	Line 5140 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 @homeservers;	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)) {
if (!grep/^\Q$tryserver\E$/,@homeservers) {	if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
push(@homeservers,$tryserver);	push(@homeservers,$tryserver);
}	}
}
}	}
} else {	} else {
push(@homeservers,&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 $ok_response = 0;	my $ok_response = 0;
Line 4251 sub auto_instcode_format {	Line 5165 sub auto_instcode_format {
$response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server);	$response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server);
if ($response !~ /(con_lost\|error\|no_such_host\|refused)/) {	if ($response !~ /(con_lost\|error\|no_such_host\|refused)/) {
my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) =	my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) =
split/:/,$response;	split(/:/,$response);
%{$codes} = (%{$codes},&str2hash($codes_str));	%{$codes} = (%{$codes},&str2hash($codes_str));
push(@{$codetitles},&str2array($codetitles_str));	push(@{$codetitles},&str2array($codetitles_str));
%{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str));	%{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str));
Line 4266 sub auto_instcode_format {	Line 5180 sub auto_instcode_format {
}	}
}	}

	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 {	sub auto_validate_class_sec {
my ($cdom,$cnum,$owner,$inst_class) = @_;	my ($cdom,$cnum,$owners,$inst_class) = @_;
my $homeserver = &homeserver($cnum,$cdom);	my $homeserver = &homeserver($cnum,$cdom);
	my $ownerlist;
	if (ref($owners) eq 'ARRAY') {
	$ownerlist = join(',',@{$owners});
	} else {
	$ownerlist = $owners;
	}
my $response=&reply('autovalidateclass_sec:'.$inst_class.':'.	my $response=&reply('autovalidateclass_sec:'.$inst_class.':'.
&escape($owner).':'.$cdom,$homeserver);	&escape($ownerlist).':'.$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 4286 sub modify_coursegroup {	Line 5236 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,$selfenroll,$context) = @_;
my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;	my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;
my $role = 'gr/'.&escape($userprivs);	my $role = 'gr/'.&escape($userprivs);
my ($uname,$udom) = split(/:/,$user);	my ($uname,$udom) = split(/:/,$user);
my $result = &assignrole($udom,$uname,$url,$role,$end,$start);	my $result = &assignrole($udom,$uname,$url,$role,$end,$start,'',$selfenroll,$context);
if ($result eq 'ok') {	if ($result eq 'ok') {
&devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);	&devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);
}	}
Line 4309 sub get_active_groups {	Line 5290 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 4330 sub get_users_groups {	Line 5311 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 4339 sub get_users_groups {	Line 5318 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 4378 sub get_users_groups {	Line 5353 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 4414 sub plaintext {	Line 5388 sub plaintext {
# ----------------------------------------------------------------- Assign Role	# ----------------------------------------------------------------- Assign Role

sub assignrole {	sub assignrole {
my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_;	my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll,
	$context)=@_;
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 4428 sub assignrole {	Line 5403 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 4438 sub assignrole {	Line 5413 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)) {	if (!(&allowed('c'.$role,$cwosec)) && !(&allowed('c'.$role,$udom))) {
&logthis('Refused assignrole: '.	my $refused;
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.	if (($env{'request.course.sec'} ne '') && ($role eq 'st')) {
$env{'user.name'}.' at '.$env{'user.domain'});	if (!(&allowed('c'.$role,$url))) {
return 'refused';	$refused = 1;
	}
	} else {
	$refused = 1;
	}
	if ($refused) {
	if (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
	$refused = '';
	} else {
	&logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.
	' '.$role.' '.$end.' '.$start.' by '.
	$env{'user.name'}.' at '.$env{'user.domain'});
	return 'refused';
	}
	}
}	}
$mrole=$role;	$mrole=$role;
}	}
Line 4459 sub assignrole {	Line 5448 sub assignrole {
}	}
my $origstart = $start;	my $origstart = $start;
my $origend = $end;	my $origend = $end;
	my $delflag;
# actually delete	# actually delete
if ($deleteflag) {	if ($deleteflag) {
if ((&allowed('dro',$udom)) \|\| (&allowed('dro',$url))) {	if ((&allowed('dro',$udom)) \|\| (&allowed('dro',$url))) {
Line 4469 sub assignrole {	Line 5459 sub assignrole {
# set start and finish to negative values for userrolelog	# set start and finish to negative values for userrolelog
$start=-1;	$start=-1;
$end=-1;	$end=-1;
	$delflag = 1;
}	}
}	}
# send command	# send command
Line 4477 sub assignrole {	Line 5468 sub assignrole {
if ($answer eq 'ok') {	if ($answer eq 'ok') {
&userrolelog($role,$uname,$udom,$url,$start,$end);	&userrolelog($role,$uname,$udom,$url,$start,$end);
# for course roles, perform group memberships changes triggered by role change.	# for course roles, perform group memberships changes triggered by role change.
	&courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,$selfenroll,$context);
unless ($role =~ /^gr/) {	unless ($role =~ /^gr/) {
&Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,	&Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,
$origstart);	$origstart,$selfenroll,$context);
}	}
}	}
return $answer;	return $answer;
Line 4518 sub modifyuser {	Line 5510 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 4532 sub modifyuser {	Line 5524 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 4579 sub modifyuser {	Line 5569 sub modifyuser {
}	}
# -------------------------------------------------------------- Add names, etc	# -------------------------------------------------------------- Add names, etc
my @tmp=&get('environment',	my @tmp=&get('environment',
['firstname','middlename','lastname','generation'],	['firstname','middlename','lastname','generation','id',
	'permanentemail'],
$udom,$uname);	$udom,$uname);
my %names;	my %names;
if ($tmp[0] =~ m/^error:.*/) {	if ($tmp[0] =~ m/^error:.*/) {
Line 4601 sub modifyuser {	Line 5592 sub modifyuser {
$names{'critnotification'} = $email;	$names{'critnotification'} = $email;
$names{'permanentemail'} = $email; }	$names{'permanentemail'} = $email; }
}	}
	if ($uid) { $names{'id'} = $uid; }
my $reply = &put('environment', \%names, $udom,$uname);	my $reply = &put('environment', \%names, $udom,$uname);
if ($reply ne 'ok') { return 'error: '.$reply; }	if ($reply ne 'ok') { return 'error: '.$reply; }
	my $sqlresult = &update_allusers_table($uname,$udom,\%names);
&devalidate_cache_new('namescache',$uname.':'.$udom);	&devalidate_cache_new('namescache',$uname.':'.$udom);
&logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.	&logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
$umode.', '.$first.', '.$middle.', '.	$umode.', '.$first.', '.$middle.', '.
Line 4615 sub modifyuser {	Line 5608 sub modifyuser {

sub modifystudent {	sub modifystudent {
my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,	my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
$end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid)=@_;	$end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid,
	$selfenroll,$context)=@_;
if (!$cid) {	if (!$cid) {
unless ($cid=$env{'request.course.id'}) {	unless ($cid=$env{'request.course.id'}) {
return 'not_in_class';	return 'not_in_class';
Line 4630 sub modifystudent {	Line 5624 sub modifystudent {
# students environment	# students environment
$uid = undef if (!$forceid);	$uid = undef if (!$forceid);
$reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,	$reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
$gene,$usec,$end,$start,$type,$locktype,$cid);	$gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll,$context);
return $reply;	return $reply;
}	}

sub modify_student_enrollment {	sub modify_student_enrollment {
my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid) = @_;	my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll,$context) = @_;
my ($cdom,$cnum,$chome);	my ($cdom,$cnum,$chome);
if (!$cid) {	if (!$cid) {
unless ($cid=$env{'request.course.id'}) {	unless ($cid=$env{'request.course.id'}) {
Line 4668 sub modify_student_enrollment {	Line 5662 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 4693 sub modify_student_enrollment {	Line 5687 sub modify_student_enrollment {
if ($usec) {	if ($usec) {
$uurl.='/'.$usec;	$uurl.='/'.$usec;
}	}
return &assignrole($udom,$uname,$uurl,'st',$end,$start);	return &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,$selfenroll,$context);
}	}

sub format_name {	sub format_name {
Line 4727 sub writecoursepref {	Line 5721 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 4761 sub createcourse {	Line 5755 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 4774 sub createcourse {	Line 5768 sub createcourse {
}	}
# ----------------------------------------------------------------- Course made	# ----------------------------------------------------------------- Course made
# log existence	# log existence
&courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description).	my $newcourse = {
':'.&escape($inst_code).':'.&escape($course_owner).':'.	$udom.'_'.$uname => {
&escape($crstype),$uhome);	description => $description,
&flushcourselogs();	inst_code => $inst_code,
	owner => $course_owner,
	type => $crstype,
	},
	};
	&courseidput($udom,$newcourse,$uhome,'notime');
# set toplevel url	# set toplevel url
my $topurl=$url;	my $topurl=$url;
unless ($nonstandard) {	unless ($nonstandard) {
Line 4804 ENDINITMAP	Line 5803 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 {
my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag)=@_;	my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag,$selfenroll,$context)=@_;
return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,	return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,
$end,$start,$deleteflag);	$end,$start,$deleteflag,$selfenroll,$context);
}	}

# ----------------------------------------------------------------- Revoke Role	# ----------------------------------------------------------------- Revoke Role

sub revokerole {	sub revokerole {
my ($udom,$uname,$url,$role,$deleteflag)=@_;	my ($udom,$uname,$url,$role,$deleteflag,$selfenroll,$context)=@_;
my $now=time;	my $now=time;
return &assignrole($udom,$uname,$url,$role,$now,$deleteflag);	return &assignrole($udom,$uname,$url,$role,$now,$deleteflag,$selfenroll,$context);
}	}

# ---------------------------------------------------------- Revoke Custom Role	# ---------------------------------------------------------- Revoke Custom Role

sub revokecustomrole {	sub revokecustomrole {
my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag)=@_;	my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag,$selfenroll,$context)=@_;
my $now=time;	my $now=time;
return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now,	return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now,
$deleteflag);	$deleteflag,$selfenroll,$context);
}	}

# ------------------------------------------------------------ Disk usage	# ------------------------------------------------------------ Disk usage
sub diskusage {	sub diskusage {
my ($udom,$uname,$directoryRoot)=@_;	my ($udom,$uname,$directorypath,$getpropath)=@_;
$directoryRoot =~ s/\/$//;	$directorypath =~ s/\/$//;
my $listing=&reply('du:'.$directoryRoot,homeserver($uname,$udom));	my $listing=&reply('du2:'.&escape($directorypath).':'
	.&escape($getpropath).':'.&escape($uname).':'
	.&escape($udom),homeserver($uname,$udom));
	if ($listing eq 'unknown_cmd') {
	if ($getpropath) {
	$directorypath = &propath($udom,$uname).'/'.$directorypath;
	}
	$listing = &reply('du:'.$directorypath,homeserver($uname,$udom));
	}
return $listing;	return $listing;
}	}

Line 4862 sub is_locked {	Line 5879 sub is_locked {

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

Line 4889 sub save_selected_files {	Line 5904 sub save_selected_files {
my ($user, $path, @files) = @_;	my ($user, $path, @files) = @_;
my $filename = $user."savedfiles";	my $filename = $user."savedfiles";
my @other_files = &files_not_in_path($user, $path);	my @other_files = &files_not_in_path($user, $path);
open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);	open (OUT, '>'.$tmpdir.$filename);
foreach my $file (@files) {	foreach my $file (@files) {
print (OUT $env{'form.currentpath'}.$file."\n");	print (OUT $env{'form.currentpath'}.$file."\n");
}	}
Line 4935 sub files_not_in_path {	Line 5950 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 5011 sub modify_access_controls {	Line 6026 sub modify_access_controls {
for (my $i=0; $i<$numnew; $i++) {	for (my $i=0; $i<$numnew; $i++) {
my $newkey = $newitems[$i];	my $newkey = $newitems[$i];
my $newid = &Apache::loncommon::get_cgi_id();	my $newid = &Apache::loncommon::get_cgi_id();
$newkey =~ s/^(\d+)/$newid/;	if ($newkey =~ /^\d+:/) {
$translation{$1} = $newid;	$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} =	$new_values{$file_name."\0".$newkey} =
$$changes{'activate'}{$newitems[$i]};	$$changes{'activate'}{$newitems[$i]};
$new_control{$newkey} = $now;	$new_control{$newkey} = $now;
Line 5077 sub modify_access_controls {	Line 6097 sub modify_access_controls {
# remove lock	# remove lock
my @del_lock = ($file_name."\0".'locked_access_records');	my @del_lock = ($file_name."\0".'locked_access_records');
my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user);	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 {	} else {
$outcome = "error: could not obtain lockfile\n";	$outcome = "error: could not obtain lockfile\n";
}	}
return ($outcome,$deloutcome,\%new_values,\%translation);	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

sub get_marked_as_readonly {	sub get_marked_as_readonly {
Line 5191 sub unmark_as_readonly {	Line 6267 sub unmark_as_readonly {
# ------------------------------------------------------------ Directory lister	# ------------------------------------------------------------ Directory lister

sub dirlist {	sub dirlist {
my ($uri,$userdomain,$username,$alternateDirectoryRoot)=@_;	my ($uri,$userdomain,$username,$getpropath,$getuserdir,$alternateRoot)=@_;

$uri=~s/^\///;	$uri=~s/^\///;
$uri=~s/\/$//;	$uri=~s/\/$//;
my ($udom, $uname);	my ($udom, $uname);
(undef,$udom,$uname)=split(/\//,$uri);	if ($getuserdir) {
if(defined($userdomain)) {
$udom = $userdomain;	$udom = $userdomain;
}
if(defined($username)) {
$uname = $username;	$uname = $username;
	} else {
	(undef,$udom,$uname)=split(/\//,$uri);
	if(defined($userdomain)) {
	$udom = $userdomain;
	}
	if(defined($username)) {
	$uname = $username;
	}
}	}
	my ($dirRoot,$listing,@listing_results);

my $dirRoot = $perlvar{'lonDocRoot'};	$dirRoot = $perlvar{'lonDocRoot'};
if(defined($alternateDirectoryRoot)) {	if (defined($getpropath)) {
$dirRoot = $alternateDirectoryRoot;	$dirRoot = &propath($udom,$uname);
$dirRoot =~ s/\/$//;	$dirRoot =~ s/\/$//;
	} elsif (defined($getuserdir)) {
	my $subdir=$uname.'__';
	$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
	$dirRoot = $Apache::lonnet::perlvar{'lonUsersDir'}
	."/$udom/$subdir/$uname";
	} elsif (defined($alternateRoot)) {
	$dirRoot = $alternateRoot;
}	}

if($udom) {	if($udom) {
if($uname) {	if($uname) {
my $listing=reply('ls2:'.$dirRoot.'/'.$uri,	$listing = &reply('ls3:'.&escape('/'.$uri).':'.$getpropath.':'
homeserver($uname,$udom));	.$getuserdir.':'.&escape($dirRoot)
my @listing_results;	.':'.&escape($uname).':'.&escape($udom),
	&homeserver($uname,$udom));
if ($listing eq 'unknown_cmd') {	if ($listing eq 'unknown_cmd') {
$listing=reply('ls:'.$dirRoot.'/'.$uri,	$listing = &reply('ls2:'.$dirRoot.'/'.$uri,
homeserver($uname,$udom));	&homeserver($uname,$udom));
	} else {
	@listing_results = map { &unescape($_); } split(/:/,$listing);
	}
	if ($listing eq 'unknown_cmd') {
	$listing = &reply('ls:'.$dirRoot.'/'.$uri,
	&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(!$alternateRoot) {
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) {	$listing = &reply('ls3:'.&escape("/res/$udom").':::::'.
my $listing=reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.	&escape($udom),$tryserver);
$udom, $tryserver);	if ($listing eq 'unknown_cmd') {
my @listing_results;	$listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.
if ($listing eq 'unknown_cmd') {	$udom, $tryserver);
$listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.	} else {
$udom, $tryserver);	@listing_results = map { &unescape($_); } split(/:/,$listing);
@listing_results = split(/:/,$listing);
} else {
@listing_results =
map { &unescape($_); } split(/:/,$listing);
}
if ($listing_results[0] ne 'no_such_dir' &&
$listing_results[0] ne 'empty' &&
$listing_results[0] ne 'con_lost') {
foreach (@listing_results) {
my ($entry,@stat)=split(/&/,$_);
$allusers{$entry}=1;
}
}
}	}
	if ($listing eq 'unknown_cmd') {
	$listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.
	$udom, $tryserver);
	@listing_results = split(/:/,$listing);
	} else {
	@listing_results =
	map { &unescape($_); } split(/:/,$listing);
	}
	if ($listing_results[0] ne 'no_such_dir' &&
	$listing_results[0] ne 'empty' &&
	$listing_results[0] ne 'con_lost') {
	foreach my $line (@listing_results) {
	my ($entry) = split(/&/,$line,2);
	$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($getpropath)) {
}	my @all_domains = sort(&all_domains());
} elsif(!defined($alternateDirectoryRoot)) {	foreach my $domain (@all_domains) {
my $tryserver;	$domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain';
my %alldom=();	}
foreach $tryserver (keys %libserv) {	return @all_domains;
$alldom{$hostdom{$tryserver}}=1;	} else {
}	return ('missing domain');
my $alldomstr='';
foreach (sort keys %alldom) {
$alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'/&domain:';
}
$alldomstr=~s/:$//;
return split(/:/,$alldomstr);
} else {
my @emptyResults = ();
push(@emptyResults, 'missing domain');
return split(':',@emptyResults);
}	}
}	}

Line 5284 sub dirlist {	Line 6372 sub dirlist {
# when it was last modified. It will also return an error of -1	# when it was last modified. It will also return an error of -1
# if an error occurs	# if an error occurs

##
## FIXME: This subroutine assumes its caller knows something about the
## directory structure of the home server for the student ($root).
## Not a good assumption to make. Since this is for looking up files
## in user directories, the full path should be constructed by lond, not
## whatever machine we request data from.
##
sub GetFileTimestamp {	sub GetFileTimestamp {
my ($studentDomain,$studentName,$filename,$root)=@_;	my ($studentDomain,$studentName,$filename,$getuserdir)=@_;
$studentDomain=~s/\W//g;	$studentDomain = &LONCAPA::clean_domain($studentDomain);
$studentName=~s/\W//g;	$studentName = &LONCAPA::clean_username($studentName);
my $subdir=$studentName.'__';	my ($fileStat) =
$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;	&Apache::lonnet::dirlist($filename,$studentDomain,$studentName,
my $proname="$studentDomain/$subdir/$studentName";	undef,$getuserdir);
$proname .= '/'.$filename;
my ($fileStat) = &Apache::lonnet::dirlist($proname, $studentDomain,
$studentName, $root);
my @stats = split('&', $fileStat);	my @stats = split('&', $fileStat);
if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {	if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
# @stats contains first the filename, then the stat output	# @stats contains first the filename, then the stat output
Line 5312 sub GetFileTimestamp {	Line 6390 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	my ($udom,$uname,$file);
if ($uri =~ m-^/adm/-) {
$uri=~s-^/adm/wrapper/-/-;
$uri=~s-^/adm/coursedocs/showdoc/-/-;
}
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);
}	}
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 5336 sub stat_file {	Line 6408 sub stat_file {
# unable to handle the uri	# unable to handle the uri
return ();	return ();
}	}
	my $getpropath;
my ($result) = &dirlist($file,$udom,$uname,$dir);	if ($file =~ /^userfiles\//) {
	$getpropath = 1;
	}
	my ($result) = &dirlist($file,$udom,$uname,$getpropath);
my @stats = split('&', $result);	my @stats = split('&', $result);

if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {	if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
Line 5370 sub directcondval {	Line 6445 sub directcondval {
untie(%bighash);	untie(%bighash);
}	}
my $value = &docondval($sub_condition);	my $value = &docondval($sub_condition);
&appenv('user.state.'.$env{'request.course.id'}.".$number" => $value);	&appenv({'user.state.'.$env{'request.course.id'}.".$number" => $value});
return $value;	return $value;
}	}
if ($env{'user.state.'.$env{'request.course.id'}}) {	if ($env{'user.state.'.$env{'request.course.id'}}) {
Line 5437 sub devalidatecourseresdata {	Line 6512 sub devalidatecourseresdata {


# --------------------------------------------------- Course Resourcedata Query	# --------------------------------------------------- Course Resourcedata Query
	#
	# Parameters:
	# $coursenum - Number of the course.
	# $coursedomain - Domain at which the course was created.
	# Returns:
	# A hash of the course parameters along (I think) with timestamps
	# and version info.

sub get_courseresdata {	sub get_courseresdata {
my ($coursenum,$coursedomain)=@_;	my ($coursenum,$coursedomain)=@_;
Line 5495 sub get_userresdata {	Line 6577 sub get_userresdata {
}	}
return $tmp;	return $tmp;
}	}
	#----------------------------------------------- resdata - return resource data
	# Purpose:
	# Return resource data for either users or for a course.
	# Parameters:
	# $name - Course/user name.
	# $domain - Name of the domain the user/course is registered on.
	# $type - Type of thing $name is (must be 'course' or 'user'
	# @which - Array of names of resources desired.
	# Returns:
	# The value of the first reasource in @which that is found in the
	# resource hash.
	# Exceptional Conditions:
	# If the $type passed in is not valid (not the string 'course' or
	# 'user', an undefined reference is returned.
	# If none of the resources are found, an undef is returned
sub resdata {	sub resdata {
my ($name,$domain,$type,@which)=@_;	my ($name,$domain,$type,@which)=@_;
my $result;	my $result;
Line 5506 sub resdata {	Line 6602 sub resdata {
}	}
if (!ref($result)) { return $result; }	if (!ref($result)) { return $result; }
foreach my $item (@which) {	foreach my $item (@which) {
if (defined($result->{$item})) {	if (defined($result->{$item->[0]})) {
return $result->{$item};	return [$result->{$item->[0]},$item->[1]];
}	}
}	}
return undef;	return undef;
Line 5535 sub EXT_cache_status {	Line 6631 sub EXT_cache_status {
sub EXT_cache_set {	sub EXT_cache_set {
my ($target_domain,$target_user) = @_;	my ($target_domain,$target_user) = @_;
my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;	my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;
#&appenv($cachename => time);	#&appenv({$cachename => time});
}	}

# --------------------------------------------------------- Value of a Variable	# --------------------------------------------------------- Value of a Variable
Line 5550 sub EXT {	Line 6646 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 5674 sub EXT {	Line 6769 sub EXT {
my ($map) = &decode_symb($symbparm);	my ($map) = &decode_symb($symbparm);
return &symbread($map);	return &symbread($map);
}	}
	if ($space eq 'filename') {
	if ($symbparm) {
	return &clutter((&decode_symb($symbparm))[2]);
	}
	return &hreflocation('',$env{'request.filename'});
	}

my ($section, $group, @groups);	my ($section, $group, @groups);
my ($courselevelm,$courselevel);	my ($courselevelm,$courselevel);
Line 5714 sub EXT {	Line 6815 sub EXT {
# ----------------------------------------------------------- first, check user	# ----------------------------------------------------------- first, check user

my $userreply=&resdata($uname,$udom,'user',	my $userreply=&resdata($uname,$udom,'user',
($courselevelr,$courselevelm,	([$courselevelr,'resource'],
$courselevel));	[$courselevelm,'map' ],
if (defined($userreply)) { return $userreply; }	[$courselevel, 'course' ]));
	if (defined($userreply)) { return &get_reply($userreply); }

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

$coursereply=&resdata($env{'course.'.$courseid.'.num'},	$coursereply=&resdata($env{'course.'.$courseid.'.num'},
$env{'course.'.$courseid.'.domain'},	$env{'course.'.$courseid.'.domain'},
'course',	'course',
($seclevelr,$seclevelm,$seclevel,	([$seclevelr, 'resource'],
$courselevelr));	[$seclevelm, 'map' ],
if (defined($coursereply)) { return $coursereply; }	[$seclevel, 'course' ],
	[$courselevelr,'resource']));
	if (defined($coursereply)) { return &get_reply($coursereply); }

# ------------------------------------------------------ third, check map parms	# ------------------------------------------------------ third, check map parms
my %parmhash=();	my %parmhash=();
Line 5742 sub EXT {	Line 6846 sub EXT {
$thisparm=$parmhash{$symbparm};	$thisparm=$parmhash{$symbparm};
untie(%parmhash);	untie(%parmhash);
}	}
if ($thisparm) { return $thisparm; }	if ($thisparm) { return &get_reply([$thisparm,'resource']); }
}	}
# ------------------------------------------ fourth, look in resource metadata	# ------------------------------------------ fourth, look in resource metadata

Line 5755 sub EXT {	Line 6859 sub EXT {
$filename=$env{'request.filename'};	$filename=$env{'request.filename'};
}	}
my $metadata=&metadata($filename,$spacequalifierrest);	my $metadata=&metadata($filename,$spacequalifierrest);
if (defined($metadata)) { return $metadata; }	if (defined($metadata)) { return &get_reply([$metadata,'resource']); }
$metadata=&metadata($filename,'parameter_'.$spacequalifierrest);	$metadata=&metadata($filename,'parameter_'.$spacequalifierrest);
if (defined($metadata)) { return $metadata; }	if (defined($metadata)) { return &get_reply([$metadata,'resource']); }

# ---------------------------------------------- fourth, look in rest pf course	# ---------------------------------------------- fourth, look in rest of course
if ($symbparm && defined($courseid) &&	if ($symbparm && defined($courseid) &&
$courseid eq $env{'request.course.id'}) {	$courseid eq $env{'request.course.id'}) {
my $coursereply=&resdata($env{'course.'.$courseid.'.num'},	my $coursereply=&resdata($env{'course.'.$courseid.'.num'},
$env{'course.'.$courseid.'.domain'},	$env{'course.'.$courseid.'.domain'},
'course',	'course',
($courselevelm,$courselevel));	([$courselevelm,'map' ],
if (defined($coursereply)) { return $coursereply; }	[$courselevel, 'course']));
	if (defined($coursereply)) { return &get_reply($coursereply); }
}	}
# ------------------------------------------------------------------ Cascade up	# ------------------------------------------------------------------ Cascade up
unless ($space eq '0') {	unless ($space eq '0') {
Line 5774 sub EXT {	Line 6879 sub EXT {
my $id=pop(@parts);	my $id=pop(@parts);
my $part=join('_',@parts);	my $part=join('_',@parts);
if ($part eq '') { $part='0'; }	if ($part eq '') { $part='0'; }
my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,	my @partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
$symbparm,$udom,$uname,$section,1);	$symbparm,$udom,$uname,$section,1);
if (defined($partgeneral)) { return $partgeneral; }	if (defined($partgeneral[0])) { return &get_reply(\@partgeneral); }
}	}
if ($recurse) { return undef; }	if ($recurse) { return undef; }
my $pack_def=&packages_tab_default($filename,$varname);	my $pack_def=&packages_tab_default($filename,$varname);
if (defined($pack_def)) { return $pack_def; }	if (defined($pack_def)) { return &get_reply([$pack_def,'resource']); }

# ---------------------------------------------------- Any other user namespace	# ---------------------------------------------------- Any other user namespace
} elsif ($realm eq 'environment') {	} elsif ($realm eq 'environment') {
# ----------------------------------------------------------------- environment	# ----------------------------------------------------------------- environment
Line 5809 sub EXT {	Line 6913 sub EXT {
return '';	return '';
}	}

	sub get_reply {
	my ($reply_value) = @_;
	if (ref($reply_value) eq 'ARRAY') {
	if (wantarray) {
	return @$reply_value;
	}
	return $reply_value->[0];
	} else {
	return $reply_value;
	}
	}

sub check_group_parms {	sub check_group_parms {
my ($courseid,$groups,$symbparm,$mapparm,$what) = @_;	my ($courseid,$groups,$symbparm,$mapparm,$what) = @_;
my @groupitems = ();	my @groupitems = ();
my $resultitem;	my $resultitem;
my @levels = ($symbparm,$mapparm,$what);	my @levels = ([$symbparm,'resource'],[$mapparm,'map'],[$what,'course']);
foreach my $group (@{$groups}) {	foreach my $group (@{$groups}) {
foreach my $level (@levels) {	foreach my $level (@levels) {
my $item = $courseid.'.['.$group.'].'.$level;	my $item = $courseid.'.['.$group.'].'.$level->[0];
push(@groupitems,$item);	push(@groupitems,[$item,$level->[1]]);
}	}
}	}
my $coursereply = &resdata($env{'course.'.$courseid.'.num'},	my $coursereply = &resdata($env{'course.'.$courseid.'.num'},
Line 5843 sub packages_tab_default {	Line 6959 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 \|\| $pack_type 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 5909 sub metadata {	Line 7026 sub metadata {
if (($uri eq '') \|\|	if (($uri eq '') \|\|
(($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 =~ m\|home/[^/]+/public_html/\|)) {	return undef;
	}
	if (($uri =~ /^~/ \|\| $uri =~ m{home/$match_username/public_html/})
	&& &Apache::lonxml::get_state('target') =~ /^(\|meta)$/) {
return undef;	return undef;
}	}
my $filename=$uri;	my $filename=$uri;
Line 5931 sub metadata {	Line 7051 sub metadata {
# if (! exists($metacache{$uri})) {	# if (! exists($metacache{$uri})) {
# $metacache{$uri}={};	# $metacache{$uri}={};
# }	# }
	my $cachetime = 60*60;
if ($liburi) {	if ($liburi) {
$liburi=&declutter($liburi);	$liburi=&declutter($liburi);
$filename=$liburi;	$filename=$liburi;
Line 5941 sub metadata {	Line 7062 sub metadata {
my %metathesekeys=();	my %metathesekeys=();
unless ($filename=~/\.meta$/) { $filename.='.meta'; }	unless ($filename=~/\.meta$/) { $filename.='.meta'; }
my $metastring;	my $metastring;
if ($uri !~ m -^(editupload)/-) {	if ($uri =~ /^~/ \|\| $uri =~ m{home/$match_username/public_html/}) {
	my $which = &hreflocation('','/'.($liburi \|\| $uri));
	$metastring =
	&Apache::lonnet::ssi_body($which,
	('grade_target' => 'meta'));
	$cachetime = 1; # only want this cached in the child not long term
	} elsif ($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 6046 sub metadata {	Line 7173 sub metadata {
# only ws inside the tag, and not in default, so use default	# only ws inside the tag, and not in default, so use default
# as value	# as value
$metaentry{':'.$unikey}=$default;	$metaentry{':'.$unikey}=$default;
} else {	} elsif ( $internaltext =~ /\S/ ) {
# either something interesting inside the tag or default	# something interesting inside the tag
# uninteresting
$metaentry{':'.$unikey}=$internaltext;	$metaentry{':'.$unikey}=$internaltext;
	} else {
	# no interesting values, don't set a default
}	}
# end of not-a-package not-a-library import	# end of not-a-package not-a-library import
}	}
Line 6059 sub metadata {	Line 7187 sub metadata {
}	}
}	}
my ($extension) = ($uri =~ /\.(\w+)$/);	my ($extension) = ($uri =~ /\.(\w+)$/);
	$extension = lc($extension);
	if ($extension eq 'htm') { $extension='html'; }

foreach my $key (keys(%packagetab)) {	foreach my $key (keys(%packagetab)) {
#no specific packages #how's our extension	#no specific packages #how's our extension
if ($key!~/^extension_\Q$extension\E&/) { next; }	if ($key!~/^extension_\Q$extension\E&/) { next; }
&metadata_create_package_def($uri,$key,'extension_'.$extension,	&metadata_create_package_def($uri,$key,'extension_'.$extension,
\%metathesekeys);	\%metathesekeys);
}	}
if (!exists($metaentry{':packages'})) {
	if (!exists($metaentry{':packages'})
	\|\| $packagetab{"import_defaults&extension_$extension"}) {
foreach my $key (keys(%packagetab)) {	foreach my $key (keys(%packagetab)) {
#no specific packages well let's get default then	#no specific packages well let's get default then
if ($key!~/^default&/) { next; }	if ($key!~/^default&/) { next; }
Line 6102 sub metadata {	Line 7235 sub metadata {
$metaentry{':keys'} = join(',',keys(%metathesekeys));	$metaentry{':keys'} = join(',',keys(%metathesekeys));
&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);	&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);	$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
&do_cache_new('meta',$uri,\%metaentry,60*60);	&do_cache_new('meta',$uri,\%metaentry,$cachetime);
# this is the end of "was not already recently cached	# this is the end of "was not already recently cached
}	}
return $metaentry{':'.$what};	return $metaentry{':'.$what};
Line 6184 sub gettitle {	Line 7317 sub gettitle {
}	}
my ($map,$resid,$url)=&decode_symb($symb);	my ($map,$resid,$url)=&decode_symb($symb);
my $title='';	my $title='';
my %bighash;	if (!$map && $resid == 0 && $url =~/default\.sequence$/) {
if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',	$title = $env{'course.'.$env{'request.course.id'}.'.description'};
&GDBM_READER(),0640)) {	} else {
my $mapid=$bighash{'map_pc_'.&clutter($map)};	if (tie(my %bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
$title=$bighash{'title_'.$mapid.'.'.$resid};	&GDBM_READER(),0640)) {
untie %bighash;	my $mapid=$bighash{'map_pc_'.&clutter($map)};
	$title=$bighash{'title_'.$mapid.'.'.$resid};
	untie(%bighash);
	}
}	}
$title=~s/\&colon\;/\:/gs;	$title=~s/\&colon\;/\:/gs;
if ($title) {	if ($title) {
Line 6205 sub gettitle {	Line 7341 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 6254 sub symblist {	Line 7390 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 6280 sub symbverify {	Line 7413 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 6400 sub symbread {	Line 7533 sub symbread {
if ($syval) {	if ($syval) {
#unless ($syval=~/\_\d+$/) {	#unless ($syval=~/\_\d+$/) {
#unless ($env{'form.request.prefix'}=~/\.(\d+)\_$/) {	#unless ($env{'form.request.prefix'}=~/\.(\d+)\_$/) {
#&appenv('request.ambiguous' => $thisfn);	#&appenv({'request.ambiguous' => $thisfn});
#return $env{$cache_str}='';	#return $env{$cache_str}='';
#}	#}
#$syval.=$1;	#$syval.=$1;
Line 6429 sub symbread {	Line 7562 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 6452 sub symbread {	Line 7585 sub symbread {
return $env{$cache_str}=$syval;	return $env{$cache_str}=$syval;
}	}
}	}
&appenv('request.ambiguous' => $thisfn);	&appenv({'request.ambiguous' => $thisfn});
return $env{$cache_str}='';	return $env{$cache_str}='';
}	}

Line 6539 sub latest_rnd_algorithm_id {	Line 7672 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 6564 sub getCODE {	Line 7697 sub getCODE {

sub rndseed {	sub rndseed {
my ($symb,$courseid,$domain,$username)=@_;	my ($symb,$courseid,$domain,$username)=@_;
	my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser();
my ($wsymb,$wcourseid,$wdomain,$wusername)=&Apache::lonxml::whichuser();	if (!defined($symb)) {
if (!$symb) {
unless ($symb=$wsymb) { return time; }	unless ($symb=$wsymb) { return time; }
}	}
if (!$courseid) { $courseid=$wcourseid; }	if (!$courseid) { $courseid=$wcourseid; }
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 6606 sub rndseed_32bit {	Line 7739 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 6627 sub rndseed_64bit {	Line 7760 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 6651 sub rndseed_64bit2 {	Line 7783 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 6673 sub rndseed_64bit3 {	Line 7806 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 6697 sub rndseed_64bit4 {	Line 7830 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 6722 sub rndseed_CODE_64bit {	Line 7855 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 6741 sub rndseed_CODE_64bit4 {	Line 7874 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 6767 sub setup_random_from_rndseed {	Line 7900 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 6784 sub recunique {	Line 7918 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 6794 sub recprefix {	Line 7929 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 6827 sub ireceipt {	Line 7969 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 6853 sub repcopy_userfile {	Line 8033 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 6920 sub tokenwrapper {	Line 8099 sub tokenwrapper {
my (undef,$udom,$uname,$file)=split('/',$uri,4);	my (undef,$udom,$uname,$file)=split('/',$uri,4);
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 6929 sub tokenwrapper {	Line 8108 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 6954 sub readfile {	Line 8137 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 6967 sub filelocation {	Line 8150 sub filelocation {
$file=~s-^/adm/wrapper/-/-;	$file=~s-^/adm/wrapper/-/-;
$file=~s-^/adm/coursedocs/showdoc/-/-;	$file=~s-^/adm/coursedocs/showdoc/-/-;
}	}

if ($file=~m:^/~:) { # is a contruction space reference	if ($file=~m:^/~:) { # is a contruction space reference
$location = $file;	$location = $file;
$location =~ s:/~(.?)/(.):/home/$1/public_html/$2:;	$location =~ s:/~(.?)/(.):/home/$1/public_html/$2:;
} elsif ($file=~m:^/home/[^/]*/public_html/:) {	} elsif ($file=~m{^/home/$match_username/public_html/}) {
# is a correct contruction space reference	# is a correct contruction space reference
$location = $file;	$location = $file;
	} elsif ($file =~ m-^\Q$Apache::lonnet::perlvar{'lonTabDir'}\E/-) {
	$location = $file;
} elsif ($file=~/^\/*(uploaded\|editupload)/) { # is an uploaded file	} elsif ($file=~/^\/*(uploaded\|editupload)/) { # is an uploaded file
my ($udom,$uname,$filename)=	my ($udom,$uname,$filename)=
($file=~m -^/+(?:uploaded\|editupload)/+([^/]+)/+([^/]+)/+(.*)$-);	($file=~m -^/+(?:uploaded\|editupload)/+($match_domain)/+($match_name)/+(.*)$-);
my $home=&homeserver($uname,$udom);	my $home=&homeserver($uname,$udom);
my $is_me=0;	my $is_me=0;
my @ids=&current_machine_ids();	my @ids=&current_machine_ids();
foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }	foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
if ($is_me) {	if ($is_me) {
$location=&propath($udom,$uname).	$location=&propath($udom,$uname).'/userfiles/'.$filename;
'/userfiles/'.$filename;
} else {	} else {
$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.	$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
$udom.'/'.$uname.'/'.$filename;	$udom.'/'.$uname.'/'.$filename;
}	}
	} elsif ($file =~ m-^/adm/-) {
	$location = $perlvar{'lonDocRoot'}.'/'.$file;
} else {	} else {
$file=~s/^\Q$perlvar{'lonDocRoot'}\E//;	$file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
$file=~s:^/res/:/:;	$file=~s:^/res/:/:;
Line 6997 sub filelocation {	Line 8184 sub filelocation {
}	}
}	}
$location=~s://+:/:g; # remove duplicate /	$location=~s://+:/:g; # remove duplicate /
while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..	while ($location=~m{/\.\./}) {
	if ($location =~ m{/[^/]+/\.\./}) {
	$location=~ s{/[^/]+/\.\./}{/}g;
	} else {
	$location=~ s{/\.\./}{/}g;
	}
	} #remove dir/..
while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./	while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./
return $location;	return $location;
}	}
Line 7012 sub hreflocation {	Line 8205 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;
}	}
	if ($file=~ m{^/userfiles/}) {
	$file =~ s{^/userfiles/}{/uploaded/};
	}
return $file;	return $file;
}	}

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

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

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

	sub machine_ids {
	my ($hostname) = @_;
	$hostname \|\|= &hostname($perlvar{'lonHostID'});
my @ids;	my @ids;
while( my($id, $name) = each(%hostname)) {	my %name_to_host = &all_names();
# &logthis("-$id-$name-$hostname-");	if (ref($name_to_host{$hostname}) eq 'ARRAY') {
if ($hostname eq $name) {	return @{ $name_to_host{$hostname} };
push(@ids,$id);	}
}	return;
	}

	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 @ids;	return $domain;
}	}

# ------------------------------------------------------------- Declutters URLs	# ------------------------------------------------------------- Declutters URLs
Line 7063 sub declutter {	Line 8290 sub declutter {

sub clutter {	sub clutter {
my $thisfn='/'.&declutter(shift);	my $thisfn='/'.&declutter(shift);
unless ($thisfn=~/^\/(uploaded\|editupload\|adm\|userfiles\|ext\|raw\|priv\|public)\//) {	if ($thisfn !~ m{^/(uploaded\|editupload\|adm\|userfiles\|ext\|raw\|priv\|public)/}
	\|\| $thisfn =~ m{^/adm/(includes\|pages)} ) {
$thisfn='/res'.$thisfn;	$thisfn='/res'.$thisfn;
}	}
if ($thisfn !~m\|/adm\|) {	if ($thisfn !~m\|/adm\|) {
Line 7093 sub clutter {	Line 8321 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 7123 sub correct_line_ends {	Line 8360 sub correct_line_ends {
sub goodbye {	sub goodbye {
&logthis("Starting Shut down");	&logthis("Starting Shut down");
#not converted to using infrastruture and probably shouldn't be	#not converted to using infrastruture and probably shouldn't be
&logthis(sprintf("%-20s is %s",'%badServerCache',length(&freeze(\%badServerCache))));	&logthis(sprintf("%-20s is %s",'%badServerCache',length(&nfreeze(\%badServerCache))));
#converted	#converted
# &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));	# &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));
&logthis(sprintf("%-20s is %s",'%homecache',length(&freeze(\%homecache))));	&logthis(sprintf("%-20s is %s",'%homecache',length(&nfreeze(\%homecache))));
# &logthis(sprintf("%-20s is %s",'%titlecache',length(&freeze(\%titlecache))));	# &logthis(sprintf("%-20s is %s",'%titlecache',length(&nfreeze(\%titlecache))));
# &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&freeze(\%courseresdatacache))));	# &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&nfreeze(\%courseresdatacache))));
#1.1 only	#1.1 only
# &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&freeze(\%userresdatacache))));	# &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&nfreeze(\%userresdatacache))));
# &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&freeze(\%getsectioncache))));	# &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&nfreeze(\%getsectioncache))));
# &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&freeze(\%courseresversioncache))));	# &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&nfreeze(\%courseresversioncache))));
# &logthis(sprintf("%-20s is %s",'%resversioncache',length(&freeze(\%resversioncache))));	# &logthis(sprintf("%-20s is %s",'%resversioncache',length(&nfreeze(\%resversioncache))));
&logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered))));	&logthis(sprintf("%-20s is %s",'%remembered',length(&nfreeze(\%remembered))));
&logthis(sprintf("%-20s is %s",'kicks',$kicks));	&logthis(sprintf("%-20s is %s",'kicks',$kicks));
&logthis(sprintf("%-20s is %s",'hits',$hits));	&logthis(sprintf("%-20s is %s",'hits',$hits));
&flushcourselogs();	&flushcourselogs();
&logthis("Shutting down");	&logthis("Shutting down");
}	}

BEGIN {	sub get_dns {
# ----------------------------------- Read loncapa.conf and loncapa_apache.conf	my ($url,$func,$ignore_cache) = @_;
unless ($readit) {	if (!$ignore_cache) {
{	my ($content,$cached)=
my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf');	&Apache::lonnet::is_cached_new('dns',$url);
%perlvar = (%perlvar,%{$configvars});	if ($cached) {
}	&$func($content);
	return;
	}
	}

	my %alldns;
	open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
	foreach my $dns (<$config>) {
	next if ($dns !~ /^\^(\S*)/x);
	$alldns{$1} = 1;
	}
	while (%alldns) {
	my ($dns) = keys(%alldns);
	delete($alldns{$dns});
	my $ua=new LWP::UserAgent;
	my $request=new HTTP::Request('GET',"http://$dns$url");
	my $response=$ua->request($request);
	next if ($response->is_error());
	my @content = split("\n",$response->content);
	&Apache::lonnet::do_cache_new('dns',$url,\@content,302460*60);
	&$func(\@content);
	return;
	}
	close($config);
	my $which = (split('/',$url))[3];
	&logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n");
	open($config,"<$perlvar{'lonTabDir'}/dns_$which.tab");
	my @content = <$config>;
	&$func(\@content);
	return;
	}
# ------------------------------------------------------------ Read domain file	# ------------------------------------------------------------ Read domain file
{	{
%domaindescription = ();	my $loaded;
%domain_auth_def = ();	my %domain;
%domain_auth_arg_def = ();
my $fh;
if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) {
while (<$fh>) {
next if (/^(\#\|\s*$)/);
# next if /^\#/;
chomp;
my ($domain, $domain_description, $def_auth, $def_auth_arg,
$def_lang, $city, $longi, $lati, $primary) = split(/:/,$_);
$domain_auth_def{$domain}=$def_auth;
$domain_auth_arg_def{$domain}=$def_auth_arg;
$domaindescription{$domain}=$domain_description;
$domain_lang_def{$domain}=$def_lang;
$domain_city{$domain}=$city;
$domain_longi{$domain}=$longi;
$domain_lati{$domain}=$lati;
$domain_primary{$domain}=$primary;

# &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");	sub parse_domain_tab {
# &logthis("Domain.tab: $domain ".$domaindescription{$domain} );	my ($lines) = @_;
	foreach my $line (@$lines) {
	next if ($line =~ /^(\#\|\s*$ )/x);

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

	sub reset_domain_info {
	undef($loaded);
	undef(%domain);
	}

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

	sub domain {
	&load_domain_tab() if (!$loaded);

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

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


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

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

	sub reset_hosts_info {
	&purge_remembered();
	&reset_domain_info();
	&reset_hosts_ip_info();
	undef(%name_to_host);
	undef(%hostname);
	undef(%hostdom);
	undef(%libserv);
	undef($loaded);
	}

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

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

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

	return %hostname;
	}

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

	return %name_to_host;
	}

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

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

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

	return %libserv;
	}

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

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

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

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

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

	my %seen;
	my @uniq = grep(!$seen{$_}++, values(%hostdom));
	return @uniq;
}	}
close($config);
# FIXME: dev server don't want this, production servers _do_ want this
#&get_iphost();
}	}

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

	sub reset_hosts_ip_info {
	undef(%iphost);
	undef(%name_to_ip);
	undef(%lonid_to_ip);
	}

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

	sub get_iphost {
	my ($ignore_cache) = @_;

	if (!$ignore_cache) {
	if (%iphost) {
	return %iphost;
}	}
$ip=inet_ntoa($ip);	my ($ip_info,$cached)=
$name_to_ip{$name} = $ip;	&Apache::lonnet::is_cached_new('iphost','iphost');
} else {	if ($cached) {
$ip = $name_to_ip{$name};	%iphost = %{$ip_info->[0]};
	%name_to_ip = %{$ip_info->[1]};
	%lonid_to_ip = %{$ip_info->[2]};
	return %iphost;
	}
	}

	# get yesterday's info for fallback
	my %old_name_to_ip;
	my ($ip_info,$cached)=
	&Apache::lonnet::is_cached_new('iphost','iphost');
	if ($cached) {
	%old_name_to_ip = %{$ip_info->[1]};
	}

	my %name_to_host = &all_names();
	foreach my $name (keys(%name_to_host)) {
	my $ip;
	if (!exists($name_to_ip{$name})) {
	$ip = gethostbyname($name);
	if (!$ip \|\| length($ip) ne 4) {
	if (defined($old_name_to_ip{$name})) {
	$ip = $old_name_to_ip{$name};
	&logthis("Can't find $name defaulting to old $ip");
	} else {
	&logthis("Name $name no IP found");
	next;
	}
	} else {
	$ip=inet_ntoa($ip);
	}
	$name_to_ip{$name} = $ip;
	} else {
	$ip = $name_to_ip{$name};
	}
	foreach my $id (@{ $name_to_host{$name} }) {
	$lonid_to_ip{$id} = $ip;
	}
	push(@{$iphost{$ip}},@{$name_to_host{$name}});
}	}
push(@{$iphost{$ip}},$id);	&Apache::lonnet::do_cache_new('iphost','iphost',
	[\%iphost,\%name_to_ip,\%lonid_to_ip],
	486060);

	return %iphost;
}	}
return %iphost;
}	}

	BEGIN {

	# ----------------------------------- Read loncapa.conf and loncapa_apache.conf
	unless ($readit) {
	{
	my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf');
	%perlvar = (%perlvar,%{$configvars});
	}


# ------------------------------------------------------ Read spare server file	# ------------------------------------------------------ Read spare server file
{	{
open(my $config,"<$perlvar{'lonTabDir'}/spare.tab");	open(my $config,"<$perlvar{'lonTabDir'}/spare.tab");
Line 7480 that was requested	Line 8945 that was requested

=item *	=item *
X<appenv()>	X<appenv()>
B<appenv(%hash)>: the value of %hash is written to	B<appenv($hashref,$rolesarrayref)>: the value of %{$hashref} is written to
the user envirnoment file, and will be restored for each access this	the user envirnoment file, and will be restored for each access this
user makes during this session, also modifies the %env for the current	user makes during this session, also modifies the %env for the current
process	process. Optional rolesarrayref - if defined contains a reference to an array
	of roles which are exempt from the restriction on modifying user.role entries
	in the user's environment.db and in %env.

=item *	=item *
X<delenv()>	X<delenv()>
Line 7491 B<delenv($regexp)>: removes all items fr	Line 8958 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 7545 X<userenvironment()>	Line 9019 X<userenvironment()>
B<userenvironment($udom,$uname,@what)>: gets the values of the keys	B<userenvironment($udom,$uname,@what)>: gets the values of the keys
passed in @what from the requested user's environment, returns a hash	passed in @what from the requested user's environment, returns a hash

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

=back	=back

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

	=item *

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

=back	=back

=head2 User Modification	=head2 User Modification
Line 7581 explanation of a user role term	Line 9080 explanation of a user role term

=item *	=item *

assignrole($udom,$uname,$url,$role,$end,$start) : assign role; give a role to a	assignrole($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll,$context) : assign role; give a role to a
user for the level given by URL. Optional start and end dates (leave empty	user for the level given by URL. Optional start and end dates (leave empty
string or zero for "no date")	string or zero for "no date")

Line 7605 modify user	Line 9104 modify user

modifystudent	modifystudent

modify a students enrollment and identification information.	modify a student's enrollment and identification information.
The course id is resolved based on the current users environment.	The course id is resolved based on the current users environment.
This means the envoking user must be a course coordinator or otherwise	This means the envoking user must be a course coordinator or otherwise
associated with a course.	associated with a course.
Line 7617 Inputs:	Line 9116 Inputs:

=over 4	=over 4

=item B<$udom> Students loncapa domain	=item B<$udom> Student's loncapa domain

=item B<$uname> Students loncapa login name	=item B<$uname> Student's loncapa login name

=item B<$uid> Students id/student number	=item B<$uid> Student's id/student number

=item B<$umode> Students authentication mode	=item B<$umode> Student's authentication mode

=item B<$upass> Students password	=item B<$upass> Student's password

=item B<$first> Students first name	=item B<$first> Student's first name

=item B<$middle> Students middle name	=item B<$middle> Student's middle name

=item B<$last> Students last name	=item B<$last> Student's last name

=item B<$gene> Students generation	=item B<$gene> Student's generation

=item B<$usec> Students section in course	=item B<$usec> Student's section in course

=item B<$end> Unix time of the roles expiration	=item B<$end> Unix time of the roles expiration

Line 7645 Inputs:	Line 9144 Inputs:

=item B<$desiredhome> server to use as home server for student	=item B<$desiredhome> server to use as home server for student

	=item B<$email> Student's permanent e-mail address

	=item B<$type> Type of enrollment (auto or manual)

	=item B<$locktype>

	=item B<$cid>

	=item B<$selfenroll>

	=item B<$context>

=back	=back

=item *	=item *
Line 7678 Inputs:	Line 9189 Inputs:

=item $start	=item $start

	=item $type

	=item $locktype

	=item $cid

	=item $selfenroll

	=item $context

=back	=back


Line 7715 setting for a specific $type, where $typ	Line 9236 setting for a specific $type, where $typ
@what should be a list of parameters to ask about. This routine caches	@what should be a list of parameters to ask about. This routine caches
answers for 5 minutes.	answers for 5 minutes.

	=item *

	get_courseresdata($courseid, $domain) : dump the entire course resource
	data base, returning a hash that is keyed by the resource name and has
	values that are the resource value. I believe that the timestamps and
	versions are also returned.


=back	=back

=head2 Course Modification	=head2 Course Modification
Line 7994 reference filled in from namesp (encrypt	Line 9523 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,$udom,$uhome) : returns hash with keys from
	array reference filled in from namespace found in domain level on either
	specified domain server ($uhome) or primary domain server ($udom and $uhome are optional).

	=item *

	put_dom($namespace,$storehash,$udom,$uhome) : stores hash in namespace at
	domain level either on specified domain server ($uhome) or primary domain
	server ($udom and $uhome are optional)

	=item *

	get_domain_defaults($target_domain) : returns hash with defaults for
	authentication and language in the domain. Keys are: auth_def, auth_arg_def,
	lang_def; corresponsing values are authentication type (internal, krb4, krb5,
	or localauth), initial password or a kerberos realm, language (e.g., en-us).
	Values are retrieved from cache (if current), or from domain's configuration.db
	(if available), or lastly from values in lonTabs/dns_domain,tab,
	or lonTabs/domain.tab.

	%domdefaults = &get_auth_defaults($target_domain);

=back	=back

=head2 Network Status Functions	=head2 Network Status Functions
Line 8385 symblist($mapname,%newhash) : update sym	Line 9938 symblist($mapname,%newhash) : update sym
=back	=back

=cut	=cut

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

Removed from v.1.782.2.4
changed lines
	Added in v.1.957