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.683.2.14 and 1.824.2.3

version 1.683.2.14, 2006/01/31 22:02:03	version 1.824.2.3, 2007/03/17 04:13:06
Line 38 use vars	Line 38 use vars
qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom	qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom
%libserv %pr %prp $memcache %packagetab	%libserv %pr %prp $memcache %packagetab
%courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount	%courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf	%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf
%domaindescription %domain_auth_def %domain_auth_arg_def	%domaindescription %domain_auth_def %domain_auth_arg_def
%domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary	%domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary
$tmpdir $_64bit %env);	$tmpdir $_64bit %env);

use IO::Socket;	use IO::Socket;
use GDBM_File;	use GDBM_File;
use Apache::Constants qw(:common :http);
use HTML::LCParser;	use HTML::LCParser;
use HTML::Parser;	use HTML::Parser;
use Fcntl qw(:flock);	use Fcntl qw(:flock);
Line 53 use Storable qw(lock_store lock_nstore l	Line 52 use Storable qw(lock_store lock_nstore l
use Time::HiRes qw( gettimeofday tv_interval );	use Time::HiRes qw( gettimeofday tv_interval );
use Cache::Memcached;	use Cache::Memcached;
use Digest::MD5;	use Digest::MD5;
	use Math::Random;
	use LONCAPA qw(:DEFAULT :match);
	use LONCAPA::Configuration;

my $readit;	my $readit;
my $max_connection_retries = 10; # Or some such value.	my $max_connection_retries = 10; # Or some such value.
Line 86 delayed.	Line 88 delayed.


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

sub logtouch {	sub logtouch {
my $execdir=$perlvar{'lonDaemons'};	my $execdir=$perlvar{'lonDaemons'};
Line 124 sub logperm {	Line 149 sub logperm {
# -------------------------------------------------- Non-critical communication	# -------------------------------------------------- Non-critical communication
sub subreply {	sub subreply {
my ($cmd,$server)=@_;	my ($cmd,$server)=@_;
my $peerfile="$perlvar{'lonSockDir'}/$server";	my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server};
#	#
# With loncnew process trimming, there's a timing hole between lonc server	# With loncnew process trimming, there's a timing hole between lonc server
# process exit and the master server picking up the listen on the AF_UNIX	# process exit and the master server picking up the listen on the AF_UNIX
Line 152 sub subreply {	Line 177 sub subreply {
}	}
my $answer;	my $answer;
if ($client) {	if ($client) {
print $client "$cmd\n";	print $client "sethost:$server:$cmd\n";
$answer=<$client>;	$answer=<$client>;
if (!$answer) { $answer="con_lost"; }	if (!$answer) { $answer="con_lost"; }
chomp($answer);	chomp($answer);
Line 256 sub critical {	Line 281 sub critical {
return $answer;	return $answer;
}	}

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

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

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

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

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

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

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

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

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

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

sub appenv {	sub appenv {
my %newenv=@_;	my %newenv=@_;
foreach (keys %newenv) {	foreach my $key (keys(%newenv)) {
if (($newenv{$_}=~/^user\.role/) \|\| ($newenv{$_}=~/^user\.priv/)) {	if (($newenv{$key}=~/^user\.role/) \|\| ($newenv{$key}=~/^user\.priv/)) {
&logthis("<font color=\"blue\">WARNING: ".	&logthis("<font color=\"blue\">WARNING: ".
"Attempt to modify environment ".$_." to ".$newenv{$_}	"Attempt to modify environment ".$key." to ".$newenv{$key}
.'</font>');	.'</font>');
delete($newenv{$_});	delete($newenv{$key});
} else {	} else {
$env{$_}=$newenv{$_};	$env{$key}=$newenv{$key};
}
}

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

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

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

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

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

# ------------------------------------------ Find out current server userload	# ------------------------------------------ Find out current server userload
# there is a copy in lond	# there is a copy in lond
sub userload {	sub userload {
Line 445 sub overloaderror {	Line 504 sub overloaderror {

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

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

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

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

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

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

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

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

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

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

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

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

Line 774 sub validate_access_key {	Line 899 sub validate_access_key {
# ------------------------------------- Find the section of student in a course	# ------------------------------------- Find the section of student in a course
sub devalidate_getsection_cache {	sub devalidate_getsection_cache {
my ($udom,$unam,$courseid)=@_;	my ($udom,$unam,$courseid)=@_;
$courseid=~s/\_/\//g;
$courseid=~s/^(\w)/\/$1/;
my $hashid="$udom:$unam:$courseid";	my $hashid="$udom:$unam:$courseid";
&devalidate_cache_new('getsection',$hashid);	&devalidate_cache_new('getsection',$hashid);
}	}

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

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

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

	return undef;
	}

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

my $hashid="$udom:$unam:$courseid";	my $hashid="$udom:$unam:$courseid";
my ($result,$cached)=&is_cached_new('getsection',$hashid);	my ($result,$cached)=&is_cached_new('getsection',$hashid);
Line 805 sub getsection {	Line 945 sub getsection {
# If there is more than one expired role, choose the one which ended last.	# If there is more than one expired role, choose the one which ended last.
# If there is a role which has expired, return it.	# If there is a role which has expired, return it.
#	#
foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',	$courseid = &courseid_to_courseurl($courseid);
&homeserver($unam,$udom)))) {	my %roleshash = &dump('roles',$udom,$unam,$courseid);
my ($key,$value)=split(/\=/,$_);	foreach my $key (keys(%roleshash)) {
$key=&unescape($key);
next if ($key !~/^\Q$courseid\E(?:\/)(\w+)\_st$/);	next if ($key !~/^\Q$courseid\E(?:\/)(\w+)\_st$/);
my $section=$1;	my $section=$1;
if ($key eq $courseid.'_st') { $section=''; }	if ($key eq $courseid.'_st') { $section=''; }
my ($dummy,$end,$start)=split(/\_/,&unescape($value));	my ($dummy,$end,$start)=split(/\_/,&unescape($roleshash{$key}));
my $now=time;	my $now=time;
if (defined($end) && $end && ($now > $end)) {	if (defined($end) && $end && ($now > $end)) {
$Expired{$end}=$section;	$Expired{$end}=$section;
Line 840 sub getsection {	Line 979 sub getsection {
}	}

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

my $to_remember=-1;	my $to_remember=-1;
Line 852 my %remembered;	Line 990 my %remembered;
my %accessed;	my %accessed;
my $kicks=0;	my $kicks=0;
my $hits=0;	my $hits=0;
	sub make_key {
	my ($name,$id) = @_;
	if (length($id) > 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 863 sub devalidate_cache_new {	Line 1007 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 886 sub is_cached_new {	Line 1030 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 947 sub userenvironment {	Line 1091 sub userenvironment {
sub studentphoto {	sub studentphoto {
my ($udom,$unam,$ext) = @_;	my ($udom,$unam,$ext) = @_;
my $home=&Apache::lonnet::homeserver($unam,$udom);	my $home=&Apache::lonnet::homeserver($unam,$udom);
my $ret=&Apache::lonnet::reply("studentphoto:$udom:$unam:$ext",$home);	if (defined($env{'request.course.id'})) {
my $url="/uploaded/$udom/$unam/internal/studentphoto.".$ext;	if ($env{'course.'.$env{'request.course.id'}.'.internal.showphoto'}) {
if ($ret ne 'ok') {	if ($udom eq $env{'course.'.$env{'request.course.id'}.'.domain'}) {
return '/adm/lonKaputt/lonlogo_broken.gif';	return(&retrievestudentphoto($udom,$unam,$ext));
	} else {
	my ($result,$perm_reqd)=
	&Apache::lonnet::auto_photo_permission($unam,$udom);
	if ($result eq 'ok') {
	if (!($perm_reqd eq 'yes')) {
	return(&retrievestudentphoto($udom,$unam,$ext));
	}
	}
	}
	}
	} else {
	my ($result,$perm_reqd) =
	&Apache::lonnet::auto_photo_permission($unam,$udom);
	if ($result eq 'ok') {
	if (!($perm_reqd eq 'yes')) {
	return(&retrievestudentphoto($udom,$unam,$ext));
	}
	}
	}
	return '/adm/lonKaputt/lonlogo_broken.gif';
	}

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

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

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

# ------------------------------------------ Find current version of a resource	# ------------------------------------------ Find current version of a resource
Line 1093 sub ssi_body {	Line 1274 sub ssi_body {
}	}
my $output=($filelink=~/^http\:/?&externalssi($filelink):	my $output=($filelink=~/^http\:/?&externalssi($filelink):
&ssi($filelink,%form));	&ssi($filelink,%form));
$output=~s\|//(\s<!--)? BEGIN LON-CAPA Internal.+// END LON-CAPA Internal\s(-->)?\s\|\|gs;	$output=~s\|//(\s<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s(-->)?\s\|\|gs;
$output=~s/^.?\<body[^\>]\>//si;	$output=~s/^.?\<body[^\>]\>//si;
$output=~s/(.)\<\/body\s\>.*?$/$1/si;	$output=~s/(.)\<\/body\s\>.*?$/$1/si;
return $output;	return $output;
Line 1101 sub ssi_body {	Line 1282 sub ssi_body {

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

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

sub ssi {	sub ssi {

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

my $request;	my $request;

	$form{'no_update_last_known'}=1;

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

$request->header(Cookie => $ENV{'HTTP_COOKIE'});	$request->header(Cookie => $ENV{'HTTP_COOKIE'});
Line 1280 sub clean_filename {	Line 1472 sub clean_filename {
}	}

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


sub userfileupload {	sub userfileupload {
my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase)=@_;	my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname,$destudom)=@_;
if (!defined($subdir)) { $subdir='unknown'; }	if (!defined($subdir)) { $subdir='unknown'; }
my $fname=$env{'form.'.$formname.'.filename'};	my $fname=$env{'form.'.$formname.'.filename'};
$fname=&clean_filename($fname);	$fname=&clean_filename($fname);
Line 1306 sub userfileupload {	Line 1505 sub userfileupload {
open(my $fh,'>'.$fullpath.'/'.$fname);	open(my $fh,'>'.$fullpath.'/'.$fname);
print $fh $env{'form.'.$formname};	print $fh $env{'form.'.$formname};
close($fh);	close($fh);
return $fullpath.'/'.$fname;	return $fullpath.'/'.$fname;
	} elsif (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) { #files uploaded to create course page are handled differently
	my $filepath = 'tmp/addcourse/'.$destudom.'/web/'.$env{'user.name'}.
	'_'.$env{'user.domain'}.'/pending';
	my @parts=split(/\//,$filepath);
	my $fullpath = $perlvar{'lonDaemons'};
	for (my $i=0;$i<@parts;$i++) {
	$fullpath .= '/'.$parts[$i];
	if ((-e $fullpath)!=1) {
	mkdir($fullpath,0777);
	}
	}
	open(my $fh,'>'.$fullpath.'/'.$fname);
	print $fh $env{'form.'.$formname};
	close($fh);
	return $fullpath.'/'.$fname;
}	}

# Create the directory if not present	# Create the directory if not present
$fname="$subdir/$fname";	$fname="$subdir/$fname";
if ($coursedoc) {	if ($coursedoc) {
Line 1323 sub userfileupload {	Line 1538 sub userfileupload {
$fname,$formname,$parser,	$fname,$formname,$parser,
$allfiles,$codebase);	$allfiles,$codebase);
}	}
	} elsif (defined($destuname)) {
	my $docuname=$destuname;
	my $docudom=$destudom;
	return &finishuserfileupload($docuname,$docudom,$formname,
	$fname,$parser,$allfiles,$codebase);

} else {	} else {
my $docuname=$env{'user.name'};	my $docuname=$env{'user.name'};
my $docudom=$env{'user.domain'};	my $docudom=$env{'user.domain'};
	if (exists($env{'form.group'})) {
	$docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
	$docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
	}
return &finishuserfileupload($docuname,$docudom,$formname,	return &finishuserfileupload($docuname,$docudom,$formname,
$fname,$parser,$allfiles,$codebase);	$fname,$parser,$allfiles,$codebase);
}	}
Line 1351 sub finishuserfileupload {	Line 1576 sub finishuserfileupload {
}	}
# Save the file	# Save the file
{	{
open(FH,'>'.$filepath.'/'.$file);	if (!open(FH,'>'.$filepath.'/'.$file)) {
print FH $env{'form.'.$formname};	&logthis('Failed to create '.$filepath.'/'.$file);
	print STDERR ('Failed to create '.$filepath.'/'.$file."\n");
	return '/adm/notfound.html';
	}
	if (!print FH ($env{'form.'.$formname})) {
	&logthis('Failed to write to '.$filepath.'/'.$file);
	print STDERR ('Failed to write to '.$filepath.'/'.$file."\n");
	return '/adm/notfound.html';
	}
close(FH);	close(FH);
}	}
if ($parser eq 'parse') {	if ($parser eq 'parse') {
Line 1495 sub removeuploadedurl {	Line 1728 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 1507 sub mkdiruserfile {	Line 1753 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 1534 sub flushcourselogs {	Line 1795 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 1551 sub flushcourselogs {	Line 1811 sub flushcourselogs {
if ($courseidbuffer{$coursehombuf{$crsid}}) {	if ($courseidbuffer{$coursehombuf{$crsid}}) {
$courseidbuffer{$coursehombuf{$crsid}}.='&'.	$courseidbuffer{$coursehombuf{$crsid}}.='&'.
&escape($crsid).'='.&escape($coursedescrbuf{$crsid}).	&escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid});	':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid});
} else {	} else {
$courseidbuffer{$coursehombuf{$crsid}}=	$courseidbuffer{$coursehombuf{$crsid}}=
&escape($crsid).'='.&escape($coursedescrbuf{$crsid}).	&escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid});	':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid});
}	}
}	}
#	#
# Write course id database (reverse lookup) to homeserver of courses	# Write course id database (reverse lookup) to homeserver of courses
# Is used in pickcourse	# Is used in pickcourse
#	#
foreach (keys %courseidbuffer) {	foreach my $crsid (keys(%courseidbuffer)) {
&courseidput($hostdom{$_},$courseidbuffer{$_},$_);	&courseidput($hostdom{$crsid},$courseidbuffer{$crsid},$crsid);
}	}
#	#
# File accesses	# File accesses
Line 1572 sub flushcourselogs {	Line 1832 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 1593 sub flushcourselogs {	Line 1854 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 1604 sub flushcourselogs {	Line 1865 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 1658 sub courselog {	Line 1918 sub courselog {
$env{'course.'.$env{'request.course.id'}.'.internal.coursecode'};	$env{'course.'.$env{'request.course.id'}.'.internal.coursecode'};
$courseownerbuf{$env{'request.course.id'}}=	$courseownerbuf{$env{'request.course.id'}}=
$env{'course.'.$env{'request.course.id'}.'.internal.courseowner'};	$env{'course.'.$env{'request.course.id'}.'.internal.courseowner'};
	$coursetypebuf{$env{'request.course.id'}}=
	$env{'course.'.$env{'request.course.id'}.'.type'};
if (defined $courselogs{$env{'request.course.id'}}) {	if (defined $courselogs{$env{'request.course.id'}}) {
$courselogs{$env{'request.course.id'}}.='&'.$what;	$courselogs{$env{'request.course.id'}}.='&'.$what;
} else {	} else {
Line 1675 sub courseacclog {	Line 1937 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 1739 sub get_course_adv_roles {	Line 2001 sub get_course_adv_roles {
$cid=$env{'request.course.id'} unless (defined($cid));	$cid=$env{'request.course.id'} unless (defined($cid));
my %coursehash=&coursedescription($cid);	my %coursehash=&coursedescription($cid);
my %nothide=();	my %nothide=();
foreach (split(/\s\,\s/,$coursehash{'nothideprivileged'})) {	foreach my $user (split(/\s\,\s/,$coursehash{'nothideprivileged'})) {
$nothide{join(':',split(/[\@\:]/,$_))}=1;	$nothide{join(':',split(/[\@\:]/,$user))}=1;
}	}
my %returnhash=();	my %returnhash=();
my %dumphash=	my %dumphash=
&dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});	&dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
my $now=time;	my $now=time;
foreach (keys %dumphash) {	foreach my $entry (keys %dumphash) {
my ($tend,$tstart)=split(/\:/,$dumphash{$_});	my ($tend,$tstart)=split(/\:/,$dumphash{$entry});
if (($tstart) && ($tstart<0)) { next; }	if (($tstart) && ($tstart<0)) { next; }
if (($tend) && ($tend<$now)) { next; }	if (($tend) && ($tend<$now)) { next; }
if (($tstart) && ($now<$tstart)) { next; }	if (($tstart) && ($now<$tstart)) { next; }
my ($role,$username,$domain,$section)=split(/\:/,$_);	my ($role,$username,$domain,$section)=split(/\:/,$entry);
if ($username eq '' \|\| $domain eq '') { next; }	if ($username eq '' \|\| $domain eq '') { next; }
if ((&privileged($username,$domain)) &&	if ((&privileged($username,$domain)) &&
(!$nothide{$username.':'.$domain})) { next; }	(!$nothide{$username.':'.$domain})) { next; }
if ($role eq 'cr') { next; }	if ($role eq 'cr') { next; }
my $key=&plaintext($role);	my $key=&plaintext($role);
if ($role =~ /^cr/) {
$key=(split('/',$role))[3];
}
if ($section) { $key.=' (Sec/Grp '.$section.')'; }	if ($section) { $key.=' (Sec/Grp '.$section.')'; }
if ($returnhash{$key}) {	if ($returnhash{$key}) {
$returnhash{$key}.=','.$username.':'.$domain;	$returnhash{$key}.=','.$username.':'.$domain;
Line 1778 sub get_my_roles {	Line 2037 sub get_my_roles {
&dump('nohist_userroles',$udom,$uname);	&dump('nohist_userroles',$udom,$uname);
my %returnhash=();	my %returnhash=();
my $now=time;	my $now=time;
foreach (keys %dumphash) {	foreach my $entry (keys(%dumphash)) {
my ($tend,$tstart)=split(/\:/,$dumphash{$_});	my ($tend,$tstart)=split(/\:/,$dumphash{$entry});
if (($tstart) && ($tstart<0)) { next; }	if (($tstart) && ($tstart<0)) { next; }
if (($tend) && ($tend<$now)) { next; }	if (($tend) && ($tend<$now)) { next; }
if (($tstart) && ($now<$tstart)) { next; }	if (($tstart) && ($now<$tstart)) { next; }
my ($role,$username,$domain,$section)=split(/\:/,$_);	my ($role,$username,$domain,$section)=split(/\:/,$entry);
$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;	$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
}	}
return %returnhash;	return %returnhash;
Line 1804 sub getannounce {	Line 2063 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 1828 sub courseidput {	Line 2087 sub courseidput {
}	}

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

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

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

sub set_first_access {	sub set_first_access {
my ($type)=@_;	my ($type)=@_;
my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();	my ($symb,$courseid,$udom,$uname)=&whichuser();
my ($map,$id,$res)=&decode_symb($symb);	my ($map,$id,$res)=&decode_symb($symb);
if ($type eq 'map') {	if ($type eq 'map') {
$res=&symbread($map);	$res=&symbread($map);
Line 2118 sub hash2str {	Line 2377 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 2418 sub store {	Line 2677 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 2454 sub cstore {	Line 2713 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 2487 sub restore {	Line 2746 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 2503 sub restore {	Line 2762 sub restore {
# ---------------------------------------------------------- Course Description	# ---------------------------------------------------------- Course Description

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

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

	# get the data agin
	if (!$args->{'one_time'}) {
	$envhash{'course.'.$normalid.'.last_cache'}=time;
	}

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

Line 2544 sub privileged {	Line 2829 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 2574 sub rolesinit {	Line 2859 sub rolesinit {
my %allroles=();	my %allroles=();
my %allgroups=();	my %allgroups=();
my $now=time;	my $now=time;
my $userroles="user.login.time=$now\n";	my %userroles = ('user.login.time' => $now);
my $group_privs;	my $group_privs;

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

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

sub custom_roleprivs {	sub custom_roleprivs {
Line 2662 sub group_roleprivs {	Line 2949 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 2693 sub set_userprivs {	Line 2980 sub set_userprivs {
if (keys(%{$allgroups}) > 0) {	if (keys(%{$allgroups}) > 0) {
foreach my $role (keys %{$allroles}) {	foreach my $role (keys %{$allroles}) {
my ($trole,$area,$sec,$extendedarea);	my ($trole,$area,$sec,$extendedarea);
if ($role =~ m\|^(\w+)\.(/\w+/\w+)(/?\w*)\|) {	if ($role =~ m-^(\w+\|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)-) {
$trole = $1;	$trole = $1;
$area = $2;	$area = $2;
$sec = $3;	$sec = $3;
Line 2708 sub set_userprivs {	Line 2995 sub set_userprivs {
}	}
}	}
}	}
foreach (keys(%grouproles)) {	foreach my $group (keys(%grouproles)) {
$$allroles{$_} = $grouproles{$_};	$$allroles{$group} = $grouproles{$group};
}	}
foreach (keys %{$allroles}) {	foreach my $role (keys(%{$allroles})) {
my %thesepriv=();	my %thesepriv;
if (($_=~/^au/) \|\| ($_=~/^ca/)) { $author=1; }	if (($role=~/^au/) \|\| ($role=~/^ca/)) { $author=1; }
foreach (split(/:/,$$allroles{$_})) {	foreach my $item (split(/:/,$$allroles{$role})) {
if ($_ ne '') {	if ($item ne '') {
my ($privilege,$restrictions)=split(/&/,$_);	my ($privilege,$restrictions)=split(/&/,$item);
if ($restrictions eq '') {	if ($restrictions eq '') {
$thesepriv{$privilege}='F';	$thesepriv{$privilege}='F';
} elsif ($thesepriv{$privilege} ne 'F') {	} elsif ($thesepriv{$privilege} ne 'F') {
Line 2726 sub set_userprivs {	Line 3013 sub set_userprivs {
}	}
}	}
my $thesestr='';	my $thesestr='';
foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; }	foreach my $priv (keys(%thesepriv)) {
$$userroles.='user.priv.'.$_.'='.$thesestr."\n";	$thesestr.=':'.$priv.'&'.$thesepriv{$priv};
	}
	$userroles->{'user.priv.'.$role} = $thesestr;
}	}
return ($author,$adv);	return ($author,$adv);
}	}
Line 2737 sub set_userprivs {	Line 3026 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 2752 sub get {	Line 3041 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 2764 sub get {	Line 3053 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 2778 sub del {	Line 3067 sub del {
# -------------------------------------------------------------- dump interface	# -------------------------------------------------------------- dump interface

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

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

	sub dumpstore {
	my ($namespace,$udomain,$uname,$regexp,$range)=@_;
if (!$udomain) { $udomain=$env{'user.domain'}; }	if (!$udomain) { $udomain=$env{'user.domain'}; }
if (!$uname) { $uname=$env{'user.name'}; }	if (!$uname) { $uname=$env{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);	my $uhome=&homeserver($uname,$udomain);
Line 2787 sub dump {	Line 3100 sub dump {
} else {	} else {
$regexp='.';	$regexp='.';
}	}
my $rep=reply("dump:$udomain:$uname:$namespace:$regexp",$uhome);	my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
my @pairs=split(/\&/,$rep);	my @pairs=split(/\&/,$rep);
my %returnhash=();	my %returnhash=();
foreach (@pairs) {	foreach my $item (@pairs) {
my ($key,$value)=split(/=/,$_);	my ($key,$value)=split(/=/,$item,2);
$returnhash{unescape($key)}=&thaw_unescape($value);	next if ($key =~ /^error: 2 /);
	$returnhash{$key}=&thaw_unescape($value);
}	}
return %returnhash;	return %returnhash;
}	}
Line 2806 sub getkeys {	Line 3120 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 2827 sub currentdump {	Line 3142 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 2852 sub convert_dump_to_currentdump{	Line 3167 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 2913 sub put {	Line 3230 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 2938 sub newput {	Line 3255 sub newput {
# --------------------------------------------------------- putstore interface	# --------------------------------------------------------- putstore interface

sub putstore {	sub putstore {
my ($namespace,$storehash,$udomain,$uname)=@_;	my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_;
if (!$udomain) { $udomain=$env{'user.domain'}; }	if (!$udomain) { $udomain=$env{'user.domain'}; }
if (!$uname) { $uname=$env{'user.name'}; }	if (!$uname) { $uname=$env{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);	my $uhome=&homeserver($uname,$udomain);
my $items='';	my $items='';
my %allitems = ();	foreach my $key (keys(%$storehash)) {
foreach (keys %$storehash) {	$items.= &escape($key).'='.&freeze_escape($storehash->{$key}).'&';
if ($_ =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) {
my $key = $1.':keys:'.$2;
$allitems{$key} .= $3.':';
}
$items.=$_.'='.&freeze_escape($$storehash{$_}).'&';
}
foreach (keys %allitems) {
$allitems{$_} =~ s/\:$//;
$items.= $_.'='.$allitems{$_}.'&';
}	}
$items=~s/\&$//;	$items=~s/\&$//;
return &reply("put:$udomain:$uname:$namespace:$items",$uhome);	my $esc_symb=&escape($symb);
	my $esc_v=&escape($version);
	my $reply =
	&reply("putstore:$udomain:$uname:$namespace:$esc_symb:$esc_v:$items",
	$uhome);
	if ($reply eq 'unknown_cmd') {
	# gfall back to way things use to be done
	return &old_putstore($namespace,$symb,$version,$storehash,$udomain,
	$uname);
	}
	return $reply;
	}

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

# ------------------------------------------------------ critical put interface	# ------------------------------------------------------ critical put interface
Line 2967 sub cput {	Line 3312 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 2979 sub cput {	Line 3324 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 2990 sub eget {	Line 3335 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 2999 sub eget {	Line 3344 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 3028 sub tmpdel {	Line 3376 sub tmpdel {
return &reply("tmpdel:$token",$server);	return &reply("tmpdel:$token",$server);
}	}

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

	sub portfolio_access {
	my ($requrl) = @_;
	my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl);
	my $result = &get_portfolio_access($udom,$unum,$file_name,$group);
	if ($result) {
	my %setters;
	if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
	my ($startblock,$endblock) =
	&Apache::loncommon::blockcheck(\%setters,'port',$unum,$udom);
	if ($startblock && $endblock) {
	return 'B';
	}
	} else {
	my ($startblock,$endblock) =
	&Apache::loncommon::blockcheck(\%setters,'port');
	if ($startblock && $endblock) {
	return 'B';
	}
	}
	}
	if ($result eq 'ok') {
	return 'F';
	} elsif ($result =~ /^[^:]+:guest_/) {
	return 'A';
	}
	return '';
	}

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

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

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

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

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

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

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

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

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


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

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

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

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

if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }	if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }
# Free bre access to adm and meta resources	# Free bre access to adm and meta resources
if (((($uri=~/^adm\//) && ($uri !~ m\|/bulletinboard$\|))	if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg\|bulletinboard)$}))
\|\| ($uri=~/\.meta$/)) && ($priv eq 'bre')) {	\|\| (($uri=~/\.meta$/) && ($uri!~m\|^uploaded/\|) ))
	&& ($priv eq 'bre')) {
return 'F';	return 'F';
}	}

# Free bre access to user's own portfolio contents	# Free bre access to user's own portfolio contents
my ($space,$domain,$name,$dir)=split('/',$uri);	my ($space,$domain,$name,@dir)=split('/',$uri);
if (($space=~/^(uploaded\|editupload)$/) && ($env{'user.name'} eq $name) &&	if (($space=~/^(uploaded\|editupload)$/) && ($env{'user.name'} eq $name) &&
($env{'user.domain'} eq $domain) && ('portfolio' eq $dir)) {	($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) {
return 'F';	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.
	if (($space=~/^(uploaded\|editupload)$/) && ($dir[0] eq 'groups')
	&& ($dir[2] eq 'portfolio') && ($priv eq 'bre')) {
	if (exists($env{'request.course.id'})) {
	my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
	my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
	if (($domain eq $cdom) && ($name eq $cnum)) {
	my $courseprivid=$env{'request.course.id'};
	$courseprivid=~s/\_/\//;
	if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid
	.'/'.$dir[1]} =~/rgf\&([^\:]*)/) {
	return $1;
	} else {
	if ($env{'request.course.sec'}) {
	$courseprivid.='/'.$env{'request.course.sec'};
	}
	if ($env{'user.priv.'.$env{'request.role'}.'./'.
	$courseprivid} =~/(mdg\|vcg)\&([^\:]*)/) {
	return $2;
	}
	}
	}
	}
}	}

# Free bre to public access	# Free bre to public access
Line 3148 sub allowed {	Line 3776 sub allowed {
$thisallowed.=$1;	$thisallowed.=$1;
}	}

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

# URI is an uploaded document for this course, default permissions don't matter	# URI is an uploaded document for this course, default permissions don't matter
# not allowing 'edit' access (editupload) to uploaded course docs	# not allowing 'edit' access (editupload) to uploaded course docs
if (($priv eq 'bre') && ($uri=~m\|^uploaded/\|)) {	if (($priv eq 'bre') && ($uri=~m\|^uploaded/\|)) {
Line 3182 sub allowed {	Line 3802 sub allowed {
}	}
}	}

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

# Full access at system, domain or course-wide level? Exit.	# Full access at system, domain or course-wide level? Exit.

if ($thisallowed=~/F/) {	if ($thisallowed=~/F/) {
Line 3229 sub allowed {	Line 3856 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 3299 sub allowed {	Line 3926 sub allowed {
my ($cdom,$cnum,$csec)=split(/\//,$courseid);	my ($cdom,$cnum,$csec)=split(/\//,$courseid);
my $prefix='course.'.$cdom.'_'.$cnum.'.';	my $prefix='course.'.$cdom.'_'.$cnum.'.';
if ((time-$env{$prefix.'last_cache'})>$expiretime) {	if ((time-$env{$prefix.'last_cache'})>$expiretime) {
&coursedescription($courseid);	&coursedescription($courseid,{'freshen_cache' => 1});
}	}
if (($env{$prefix.'res.'.$uri.'.lock.sections'}=~/\,\Q$csec\E\,/)	if (($env{$prefix.'res.'.$uri.'.lock.sections'}=~/\,\Q$csec\E\,/)
\|\| ($env{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {	\|\| ($env{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {
Line 3332 sub allowed {	Line 3959 sub allowed {
#	#

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

#	#
Line 3395 sub allowed {	Line 4028 sub allowed {
}	}
}	}

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

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

sub is_on_map {	sub is_on_map {
my $uri=&deversion(&declutter(shift));	my ($pathname,$filename) = &split_uri_for_cond(shift);
my @uriparts=split(/\//,$uri);
my $filename=$uriparts[$#uriparts];
my $pathname=$uri;
$pathname=~s\|/\Q$filename\E$\|\|;
$pathname=~s/^adm\/wrapper\///;
$pathname=~s/^adm\/coursedocs\/showdoc\///;
#Trying to find the conditional for the file	#Trying to find the conditional for the file
my $match=($env{'acc.res.'.$env{'request.course.id'}.'.'.$pathname}=~	my $match=($env{'acc.res.'.$env{'request.course.id'}.'.'.$pathname}=~
/\&\Q$filename\E\:([\d\\|]+)\&/);	/\&\Q$filename\E\:([\d\\|]+)\&/);
Line 3446 sub get_symb_from_alias {	Line 4085 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 3455 sub definerole {	Line 4094 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 3464 sub definerole {	Line 4103 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 3512 sub log_query {	Line 4151 sub log_query {
my $uhome=&homeserver($uname,$udom);	my $uhome=&homeserver($uname,$udom);
if ($uhome eq 'no_host') { return 'error: no_host'; }	if ($uhome eq 'no_host') { return 'error: no_host'; }
my $uhost=$hostname{$uhome};	my $uhost=$hostname{$uhome};
my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys %filters));	my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys(%filters)));
my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command,	my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command,
$uhome);	$uhome);
unless ($queryid=~/^\Q$uhost\E\_/) { return 'error: '.$queryid; }	unless ($queryid=~/^\Q$uhost\E\_/) { return 'error: '.$queryid; }
return get_query_reply($queryid);	return get_query_reply($queryid);
}	}

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

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

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

sub fetch_enrollment_query {	sub fetch_enrollment_query {
Line 3533 sub fetch_enrollment_query {	Line 4184 sub fetch_enrollment_query {
}	}
my $host=$hostname{$homeserver};	my $host=$hostname{$homeserver};
my $cmd = '';	my $cmd = '';
foreach (keys %{$affiliatesref}) {	foreach my $affiliate (keys %{$affiliatesref}) {
$cmd .= $_.'='.join(",",@{$$affiliatesref{$_}}).'%%';	$cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
}	}
$cmd =~ s/%%$//;	$cmd =~ s/%%$//;
$cmd = &escape($cmd);	$cmd = &escape($cmd);
Line 3555 sub fetch_enrollment_query {	Line 4206 sub fetch_enrollment_query {
} else {	} else {
my @responses = split/:/,$reply;	my @responses = split/:/,$reply;
if ($homeserver eq $perlvar{'lonHostID'}) {	if ($homeserver eq $perlvar{'lonHostID'}) {
foreach (@responses) {	foreach my $line (@responses) {
my ($key,$value) = split/=/,$_;	my ($key,$value) = split(/=/,$line,2);
$$replyref{$key} = $value;	$$replyref{$key} = $value;
}	}
} else {	} else {
my $pathname = $perlvar{'lonDaemons'}.'/tmp';	my $pathname = $perlvar{'lonDaemons'}.'/tmp';
foreach (@responses) {	foreach my $line (@responses) {
my ($key,$value) = split/=/,$_;	my ($key,$value) = split(/=/,$line);
$$replyref{$key} = $value;	$$replyref{$key} = $value;
if ($value > 0) {	if ($value > 0) {
foreach (@{$$affiliatesref{$key}}) {	foreach my $item (@{$$affiliatesref{$key}}) {
my $filename = $dom.'_'.$key.'_'.$_.'_classlist.xml';	my $filename = $dom.'_'.$key.'_'.$item.'_classlist.xml';
my $destname = $pathname.'/'.$filename;	my $destname = $pathname.'/'.$filename;
my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver);	my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver);
if ($xml_classlist =~ /^error/) {	if ($xml_classlist =~ /^error/) {
Line 3640 sub auto_run {	Line 4291 sub auto_run {
my $response = &reply('autorun:'.$cdom,$homeserver);	my $response = &reply('autorun:'.$cdom,$homeserver);
return $response;	return $response;
}	}

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

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

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

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

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

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

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

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

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

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

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

# ------------------------------------------------------- Course Group routines	# ------------------------------------------------------- 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 3725 sub modify_coursegroup {	Line 4503 sub modify_coursegroup {
return(&put('coursegroups',$groupsettings,$cdom,$cnum));	return(&put('coursegroups',$groupsettings,$cdom,$cnum));
}	}

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

sub modify_group_roles {	sub modify_group_roles {
my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs) = @_;	my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs) = @_;
my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;	my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;
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);
	if ($result eq 'ok') {
	&devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);
	}
return $result;	return $result;
}	}

Line 3745 sub get_active_groups {	Line 4557 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 3764 sub get_group_membership {	Line 4576 sub get_group_membership {

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

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 3803 sub devalidate_getgroups_cache {	Line 4628 sub devalidate_getgroups_cache {
# ------------------------------------------------------------------ Plain Text	# ------------------------------------------------------------------ Plain Text

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

# ----------------------------------------------------------------- Assign Role	# ----------------------------------------------------------------- Assign Role
Line 3814 sub assignrole {	Line 4659 sub assignrole {
my $mrole;	my $mrole;
if ($role =~ /^cr\//) {	if ($role =~ /^cr\//) {
my $cwosec=$url;	my $cwosec=$url;
$cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;	$cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
unless (&allowed('ccr',$cwosec)) {	unless (&allowed('ccr',$cwosec)) {
&logthis('Refused custom assignrole: '.	&logthis('Refused custom assignrole: '.
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.	$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
Line 3824 sub assignrole {	Line 4669 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 3834 sub assignrole {	Line 4679 sub assignrole {
$mrole='gr';	$mrole='gr';
} else {	} else {
my $cwosec=$url;	my $cwosec=$url;
$cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;	$cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
unless ((&allowed('c'.$role,$cwosec)) \|\| &allowed('c'.$role,$udom)) {	unless ((&allowed('c'.$role,$cwosec)) \|\| &allowed('c'.$role,$udom)) {
&logthis('Refused assignrole: '.	&logthis('Refused assignrole: '.
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.	$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
Line 3853 sub assignrole {	Line 4698 sub assignrole {
$command.='_0_'.$start;	$command.='_0_'.$start;
}	}
}	}
	my $origstart = $start;
	my $origend = $end;
# actually delete	# actually delete
if ($deleteflag) {	if ($deleteflag) {
if ((&allowed('dro',$udom)) \|\| (&allowed('dro',$url))) {	if ((&allowed('dro',$udom)) \|\| (&allowed('dro',$url))) {
Line 3870 sub assignrole {	Line 4717 sub assignrole {
# log new user role if status is ok	# log new user role if status is ok
if ($answer eq 'ok') {	if ($answer eq 'ok') {
&userrolelog($role,$uname,$udom,$url,$start,$end);	&userrolelog($role,$uname,$udom,$url,$start,$end);
	# for course roles, perform group memberships changes triggered by role change.
	unless ($role =~ /^gr/) {
	&Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,
	$origstart);
	}
}	}
return $answer;	return $answer;
}	}
Line 3907 sub modifyuser {	Line 4759 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 4057 sub modify_student_enrollment {	Line 4909 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 4116 sub writecoursepref {	Line 4968 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 4126 sub writecoursepref {	Line 4978 sub writecoursepref {
# ---------------------------------------------------------- Make/modify course	# ---------------------------------------------------------- Make/modify course

sub createcourse {	sub createcourse {
my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,$course_owner)=@_;	my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,
	$course_owner,$crstype)=@_;
$url=&declutter($url);	$url=&declutter($url);
my $cid='';	my $cid='';
unless (&allowed('ccc',$udom)) {	unless (&allowed('ccc',$udom)) {
Line 4163 sub createcourse {	Line 5016 sub createcourse {
# ----------------------------------------------------------------- Course made	# ----------------------------------------------------------------- Course made
# log existence	# log existence
&courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description).	&courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description).
':'.&escape($inst_code).':'.&escape($course_owner),$uhome);	':'.&escape($inst_code).':'.&escape($course_owner).':'.
	&escape($crstype),$uhome);
&flushcourselogs();	&flushcourselogs();
# set toplevel url	# set toplevel url
my $topurl=$url;	my $topurl=$url;
Line 4191 ENDINITMAP	Line 5045 ENDINITMAP
return '/'.$udom.'/'.$uname;	return '/'.$udom.'/'.$uname;
}	}

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

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

sub assigncustomrole {	sub assigncustomrole {
Line 4233 sub is_locked {	Line 5097 sub is_locked {
$env{'user.domain'},$env{'user.name'});	$env{'user.domain'},$env{'user.name'});
my ($tmp)=keys(%locked);	my ($tmp)=keys(%locked);
if ($tmp=~/^error:/) { undef(%locked); }	if ($tmp=~/^error:/) { undef(%locked); }

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

sub get_courseresdata {	sub get_courseresdata {
Line 4699 sub EXT_cache_set {	Line 5795 sub EXT_cache_set {

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

	my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_;
unless ($varname) { return ''; }	unless ($varname) { return ''; }
#get real user name/domain, courseid and symb	#get real user name/domain, courseid and symb
my $courseid;	my $courseid;
Line 4709 sub EXT {	Line 5805 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 4733 sub EXT {	Line 5828 sub EXT {
if ( (defined($Apache::lonhomework::parsing_a_problem)	if ( (defined($Apache::lonhomework::parsing_a_problem)
\|\| defined($Apache::lonhomework::parsing_a_task))	\|\| defined($Apache::lonhomework::parsing_a_task))
&&	&&
($symbparm eq &symbread()) ) {	($symbparm eq &symbread()) ) {
return $Apache::lonhomework::history{$qualifierrest};	# if we are in the middle of processing the resource the
	# get the value we are planning on committing
	if (defined($Apache::lonhomework::results{$qualifierrest})) {
	return $Apache::lonhomework::results{$qualifierrest};
	} else {
	return $Apache::lonhomework::history{$qualifierrest};
	}
} else {	} else {
my %restored;	my %restored;
if ($publicuser \|\| $env{'request.state'} eq 'construct') {	if ($publicuser \|\| $env{'request.state'} eq 'construct') {
Line 4814 sub EXT {	Line 5915 sub EXT {
return $env{'course.'.$courseid.'.'.$spacequalifierrest};	return $env{'course.'.$courseid.'.'.$spacequalifierrest};
} elsif ($realm eq 'resource') {	} elsif ($realm eq 'resource') {

my $section;
if (defined($courseid) && $courseid eq $env{'request.course.id'}) {	if (defined($courseid) && $courseid eq $env{'request.course.id'}) {
if (!$symbparm) { $symbparm=&symbread(); }	if (!$symbparm) { $symbparm=&symbread(); }
}	}

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

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

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

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

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

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

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

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

my $coursereply=&resdata($env{'course.'.$courseid.'.num'},	$coursereply=&resdata($env{'course.'.$courseid.'.num'},
$env{'course.'.$courseid.'.domain'},	$env{'course.'.$courseid.'.domain'},
'course',	'course',
($seclevelr,$seclevelm,$seclevel,	($seclevelr,$seclevelm,$seclevel,
Line 4922 sub EXT {	Line 6042 sub EXT {
if (($uname eq $env{'user.name'})&&($udom eq $env{'user.domain'})) {	if (($uname eq $env{'user.name'})&&($udom eq $env{'user.domain'})) {
return $env{'environment.'.$spacequalifierrest};	return $env{'environment.'.$spacequalifierrest};
} else {	} else {
	if ($uname eq 'anonymous' && $udom eq '') {
	return '';
	}
my %returnhash=&userenvironment($udom,$uname,	my %returnhash=&userenvironment($udom,$uname,
$spacequalifierrest);	$spacequalifierrest);
return $returnhash{$spacequalifierrest};	return $returnhash{$spacequalifierrest};
Line 4940 sub EXT {	Line 6063 sub EXT {
return '';	return '';
}	}

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

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

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

Line 4984 sub metadata {	Line 6164 sub metadata {
(($uri =~ m\|^/*adm/\|) &&	(($uri =~ m\|^/*adm/\|) &&
($uri !~ m\|^adm/includes\|) && ($uri !~ m\|/bulletinboard$\|)) \|\|	($uri !~ m\|^adm/includes\|) && ($uri !~ m\|/bulletinboard$\|)) \|\|
($uri =~ m\|/$\|) \|\| ($uri =~ m\|/.meta$\|) \|\| ($uri =~ /^~/) \|\|	($uri =~ m\|/$\|) \|\| ($uri =~ m\|/.meta$\|) \|\| ($uri =~ /^~/) \|\|
($uri =~ m\|home/[^/]+/public_html/\|)) {	($uri =~ m\|home/$match_username/public_html/\|)) {
return undef;	return undef;
}	}
my $filename=$uri;	my $filename=$uri;
Line 5015 sub metadata {	Line 6195 sub metadata {
my %metathesekeys=();	my %metathesekeys=();
unless ($filename=~/\.meta$/) { $filename.='.meta'; }	unless ($filename=~/\.meta$/) { $filename.='.meta'; }
my $metastring;	my $metastring;
if ($uri !~ m -^(uploaded\|editupload)/-) {	if ($uri !~ m -^(editupload)/-) {
my $file=&filelocation('',&clutter($filename));	my $file=&filelocation('',&clutter($filename));
#push(@{$metaentry{$uri.'.file'}},$file);	#push(@{$metaentry{$uri.'.file'}},$file);
$metastring=&getfile($file);	$metastring=&getfile($file);
Line 5039 sub metadata {	Line 6219 sub metadata {
} else {	} else {
$metaentry{':packages'}=$package.$keyroot;	$metaentry{':packages'}=$package.$keyroot;
}	}
foreach (sort keys %packagetab) {	foreach my $pack_entry (keys(%packagetab)) {
my $part=$keyroot;	my $part=$keyroot;
$part=~s/^\_//;	$part=~s/^\_//;
if ($_=~/^\Q$package\E\&/ \|\|	if ($pack_entry=~/^\Q$package\E\&/ \|\|
$_=~/^\Q$package\E_0\&/) {	$pack_entry=~/^\Q$package\E_0\&/) {
my ($pack,$name,$subp)=split(/\&/,$_);	my ($pack,$name,$subp)=split(/\&/,$pack_entry);
# ignore package.tab specified default values	# ignore package.tab specified default values
# here &package_tab_default() will fetch those	# here &package_tab_default() will fetch those
if ($subp eq 'default') { next; }	if ($subp eq 'default') { next; }
my $value=$packagetab{$_};	my $value=$packagetab{$pack_entry};
my $unikey;	my $unikey;
if ($pack =~ /_0$/) {	if ($pack =~ /_0$/) {
$unikey='parameter_0_'.$name;	$unikey='parameter_0_'.$name;
Line 5096 sub metadata {	Line 6276 sub metadata {
my $dir=$filename;	my $dir=$filename;
$dir=~s\|[^/]*$\|\|;	$dir=~s\|[^/]*$\|\|;
$location=&filelocation($dir,$location);	$location=&filelocation($dir,$location);
foreach (sort(split(/\,/,&metadata($uri,'keys',	my $metadata =
$location,$unikey,	&metadata($uri,'keys', $location,$unikey,
$depthcount+1)))) {	$depthcount+1);
$metaentry{':'.$_}=$metaentry{':'.$_};	foreach my $meta (split(',',$metadata)) {
$metathesekeys{$_}=1;	$metaentry{':'.$meta}=$metaentry{':'.$meta};
	$metathesekeys{$meta}=1;
}	}
}	}
} else {	} else {
Line 5109 sub metadata {	Line 6290 sub metadata {
$unikey.='_'.$token->[2]->{'name'};	$unikey.='_'.$token->[2]->{'name'};
}	}
$metathesekeys{$unikey}=1;	$metathesekeys{$unikey}=1;
foreach (@{$token->[3]}) {	foreach my $param (@{$token->[3]}) {
$metaentry{':'.$unikey.'.'.$_}=$token->[2]->{$_};	$metaentry{':'.$unikey.'.'.$param} =
	$token->[2]->{$param};
}	}
my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));	my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));
my $default=$metaentry{':'.$unikey.'.default'};	my $default=$metaentry{':'.$unikey.'.default'};
Line 5131 sub metadata {	Line 6313 sub metadata {
}	}
}	}
my ($extension) = ($uri =~ /\.(\w+)$/);	my ($extension) = ($uri =~ /\.(\w+)$/);
foreach my $key (sort(keys(%packagetab))) {	foreach my $key (keys(%packagetab)) {
#no specific packages #how's our extension	#no specific packages #how's our extension
if ($key!~/^extension_\Q$extension\E&/) { next; }	if ($key!~/^extension_\Q$extension\E&/) { next; }
&metadata_create_package_def($uri,$key,'extension_'.$extension,	&metadata_create_package_def($uri,$key,'extension_'.$extension,
\%metathesekeys);	\%metathesekeys);
}	}
if (!exists($metaentry{':packages'})) {	if (!exists($metaentry{':packages'})) {
foreach my $key (sort(keys(%packagetab))) {	foreach my $key (keys(%packagetab)) {
#no specific packages well let's get default then	#no specific packages well let's get default then
if ($key!~/^default&/) { next; }	if ($key!~/^default&/) { next; }
&metadata_create_package_def($uri,$key,'default',	&metadata_create_package_def($uri,$key,'default',
Line 5156 sub metadata {	Line 6338 sub metadata {
my $dir=$filename;	my $dir=$filename;
$dir=~s\|[^/]*$\|\|;	$dir=~s\|[^/]*$\|\|;
$location=&filelocation($dir,$location);	$location=&filelocation($dir,$location);
foreach (sort(split(/\,/,&metadata($uri,'keys',	my $rights_metadata =
$location,'_rights',	&metadata($uri,'keys',$location,'_rights',
$depthcount+1)))) {	$depthcount+1);
#$metaentry{':'.$_}=$metacache{$uri}->{':'.$_};	foreach my $rights (split(',',$rights_metadata)) {
$metathesekeys{$_}=1;	#$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights};
	$metathesekeys{$rights}=1;
}	}
}	}
}	}
$metaentry{':keys'}=join(',',keys %metathesekeys);	# uniqifiy package listing
	my %seen;
	my @uniq_packages =
	grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));
	$metaentry{':packages'} = join(',',@uniq_packages);

	$metaentry{':keys'} = join(',',keys(%metathesekeys));
&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);	&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);	$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
&do_cache_new('meta',$uri,\%metaentry,60*60);	&do_cache_new('meta',$uri,\%metaentry,60*60);
Line 5200 sub metadata_create_package_def {	Line 6389 sub metadata_create_package_def {
sub metadata_generate_part0 {	sub metadata_generate_part0 {
my ($metadata,$metacache,$uri) = @_;	my ($metadata,$metacache,$uri) = @_;
my %allnames;	my %allnames;
foreach my $metakey (sort keys %$metadata) {	foreach my $metakey (keys(%$metadata)) {
if ($metakey=~/^parameter\_(.*)/) {	if ($metakey=~/^parameter\_(.*)/) {
my $part=$$metacache{':'.$metakey.'.part'};	my $part=$$metacache{':'.$metakey.'.part'};
my $name=$$metacache{':'.$metakey.'.name'};	my $name=$$metacache{':'.$metakey.'.name'};
Line 5225 sub metadata_generate_part0 {	Line 6414 sub metadata_generate_part0 {
}	}
}	}

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

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

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

sub gettitle {	sub gettitle {
Line 5259 sub gettitle {	Line 6459 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 5288 sub symblist {	Line 6488 sub symblist {
if (($env{'request.course.fn'}) && (%newhash)) {	if (($env{'request.course.fn'}) && (%newhash)) {
if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',	if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
&GDBM_WRCREAT(),0640)) {	&GDBM_WRCREAT(),0640)) {
foreach (keys %newhash) {	foreach my $url (keys %newhash) {
$hash{declutter($_)}=&encode_symb($mapname,$newhash{$_}->[1],	next if ($url eq 'last_known'
$newhash{$_}->[0]);	&& $env{'form.no_update_last_known'});
	$hash{declutter($url)}=&encode_symb($mapname,
	$newhash{$url}->[1],
	$newhash{$url}->[0]);
}	}
if (untie(%hash)) {	if (untie(%hash)) {
return 'ok';	return 'ok';
Line 5305 sub symblist {	Line 6508 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 5331 sub symbverify {	Line 6531 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 5480 sub symbread {	Line 6680 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 5590 sub latest_rnd_algorithm_id {	Line 6790 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 5616 sub getCODE {	Line 6816 sub getCODE {
sub rndseed {	sub rndseed {
my ($symb,$courseid,$domain,$username)=@_;	my ($symb,$courseid,$domain,$username)=@_;

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

if (defined(&getCODE())) {	if (defined(&getCODE())) {
if ($which eq '64bit5') {	if ($which eq '64bit5') {
return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);	return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);
Line 5657 sub rndseed_32bit {	Line 6858 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 5678 sub rndseed_64bit {	Line 6879 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 5702 sub rndseed_64bit2 {	Line 6902 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 5724 sub rndseed_64bit3 {	Line 6925 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 5748 sub rndseed_64bit4 {	Line 6949 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 5773 sub rndseed_CODE_64bit {	Line 6974 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 5792 sub rndseed_CODE_64bit4 {	Line 6993 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 5854 sub ireceipt {	Line 7055 sub ireceipt {
my $return =&recprefix($fucourseid).'-';	my $return =&recprefix($fucourseid).'-';
if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' \|\|	if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' \|\|
$env{'request.state'} eq 'construct') {	$env{'request.state'} eq 'construct') {
&Apache::lonxml::debug("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname).	#&logthis("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname)." and ".($cpart%$cudom));
" and ".($cpart%$cudom));

$return.= ($cunique%$cuname+	$return.= ($cunique%$cuname+
$cunique%$cudom+	$cunique%$cudom+
Line 5878 sub ireceipt {	Line 7078 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 5904 sub repcopy_userfile {	Line 7142 sub repcopy_userfile {
if ($file =~ m -^/*(uploaded\|editupload)/-) { $file=&filelocation("",$file); }	if ($file =~ m -^/*(uploaded\|editupload)/-) { $file=&filelocation("",$file); }
if ($file =~ m\|^/home/httpd/html/lonUsers/\|) { return 'ok'; }	if ($file =~ m\|^/home/httpd/html/lonUsers/\|) { return 'ok'; }
my ($cdom,$cnum,$filename) =	my ($cdom,$cnum,$filename) =
($file=~m\|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+([^/]+)/+([^/]+)/+(.*)\|);	($file=~m\|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)\|);
my ($info,$rtncode);	my ($info,$rtncode);
my $uri="/uploaded/$cdom/$cnum/$filename";	my $uri="/uploaded/$cdom/$cnum/$filename";
if (-e "$file") {	if (-e "$file") {
Line 5935 sub repcopy_userfile {	Line 7173 sub repcopy_userfile {
} else {	} else {
my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);	my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);
if ($lwpresp ne 'ok') {	if ($lwpresp ne 'ok') {
my $ua=new LWP::UserAgent;	return -1;
my $request=new HTTP::Request('GET',&tokenwrapper($uri));
my $response=$ua->request($request);
if ($response->is_success()) {
$info=$response->content;
} else {
return -1;
}
}	}
my @parts = ($cdom,$cnum);	my @parts = ($cdom,$cnum);
if ($filename =~ m\|^(.+)/[^/]+$\|) {	if ($filename =~ m\|^(.+)/[^/]+$\|) {
Line 6005 sub readfile {	Line 7236 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 6021 sub filelocation {	Line 7252 sub filelocation {
if ($file=~m:^/~:) { # is a contruction space reference	if ($file=~m:^/~:) { # is a contruction space reference
$location = $file;	$location = $file;
$location =~ s:/~(.?)/(.):/home/$1/public_html/$2:;	$location =~ s:/~(.?)/(.):/home/$1/public_html/$2:;
} elsif ($file=~m:^/home/[^/]*/public_html/:) {	} elsif ($file=~m{^/home/$match_username/public_html/}) {
# is a correct contruction space reference	# is a correct contruction space reference
$location = $file;	$location = $file;
} elsif ($file=~/^\/*(uploaded\|editupload)/) { # is an uploaded file	} elsif ($file=~/^\/*(uploaded\|editupload)/) { # is an uploaded file
my ($udom,$uname,$filename)=	my ($udom,$uname,$filename)=
($file=~m -^/+(?:uploaded\|editupload)/+([^/]+)/+([^/]+)/+(.*)$-);	($file=~m -^/+(?:uploaded\|editupload)/+($match_domain)/+($match_name)/+(.*)$-);
my $home=&homeserver($uname,$udom);	my $home=&homeserver($uname,$udom);
my $is_me=0;	my $is_me=0;
my @ids=&current_machine_ids();	my @ids=&current_machine_ids();
foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }	foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
if ($is_me) {	if ($is_me) {
$location=&Apache::loncommon::propath($udom,$uname).	$location=&propath($udom,$uname).
'/userfiles/'.$filename;	'/userfiles/'.$filename;
} else {	} else {
$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.	$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
Line 6063 sub hreflocation {	Line 7294 sub hreflocation {
}	}
if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) {	if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) {
$file=~s-^\Q$perlvar{'lonDocRoot'}\E--;	$file=~s-^\Q$perlvar{'lonDocRoot'}\E--;
} elsif ($file=~m-/home/(\w+)/public_html/-) {	} elsif ($file=~m-/home/($match_username)/public_html/-) {
$file=~s-^/home/(\w+)/public_html/-/~$1/-;	$file=~s-^/home/($match_username)/public_html/-/~$1/-;
} elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) {	} elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) {
$file=~s-^/home/httpd/lonUsers/([^/])/./././([^/])/userfiles/	$file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/
-/uploaded/$1/$2/-x;	-/uploaded/$1/$2/-x;
}	}
return $file;	return $file;
Line 6096 sub current_machine_ids {	Line 7327 sub current_machine_ids {
return @ids;	return @ids;
}	}

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

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

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

sub declutter {	sub declutter {
Line 6137 sub clutter {	Line 7391 sub clutter {
&& $thisfn!~/\.(sequence\|page)$/) {	&& $thisfn!~/\.(sequence\|page)$/) {
$thisfn='/adm/coursedocs/showdoc'.$thisfn;	$thisfn='/adm/coursedocs/showdoc'.$thisfn;
} else {	} else {
#&logthis("Got a blank emb style");	# &logthis("Got a blank emb style");
}	}
}	}
}	}
return $thisfn;	return $thisfn;
}	}

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

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

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

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

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

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

sub thaw_unescape {	sub thaw_unescape {
my ($value)=@_;	my ($value)=@_;
Line 6205 sub goodbye {	Line 7453 sub goodbye {
&logthis(sprintf("%-20s is %s",'hits',$hits));	&logthis(sprintf("%-20s is %s",'hits',$hits));
&flushcourselogs();	&flushcourselogs();
&logthis("Shutting down");	&logthis("Shutting down");
return DONE;
}	}

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

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

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

# ------------------------------------------------------------ Read domain file	# ------------------------------------------------------------ Read domain file
Line 6244 BEGIN {	Line 7470 BEGIN {
%domain_auth_arg_def = ();	%domain_auth_arg_def = ();
my $fh;	my $fh;
if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) {	if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) {
while (<$fh>) {	while (my $line = <$fh>) {
next if (/^(\#\|\s*$)/);	next if ($line =~ /^(\#\|\s*$)/);
# next if /^\#/;	# next if /^\#/;
chomp;	chomp $line;
my ($domain, $domain_description, $def_auth, $def_auth_arg,	my ($domain, $domain_description, $def_auth, $def_auth_arg,
$def_lang, $city, $longi, $lati, $primary) = split(/:/,$_);	$def_lang, $city, $longi, $lati, $primary) = split(/:/,$line,9);
$domain_auth_def{$domain}=$def_auth;	$domain_auth_def{$domain}=$def_auth;
$domain_auth_arg_def{$domain}=$def_auth_arg;	$domain_auth_arg_def{$domain}=$def_auth_arg;
$domaindescription{$domain}=$domain_description;	$domaindescription{$domain}=$domain_description;
Line 6284 BEGIN {	Line 7510 BEGIN {
}	}
close($config);	close($config);
# FIXME: dev server don't want this, production servers _do_ want this	# FIXME: dev server don't want this, production servers _do_ want this
&get_iphost();	#&get_iphost();
}	}

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

}	}

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

$processmarker='_'.time.'_'.$perlvar{'lonHostID'};	$processmarker='_'.time.'_'.$perlvar{'lonHostID'};
$dumpcount=0;	$dumpcount=0;
Line 6569 B<delenv($regexp)>: removes all items fr	Line 7805 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 6631 passed in @what from the requested user'	Line 7874 passed in @what from the requested user'

=item *	=item *

allowed($priv,$uri) : check for a user privilege; returns codes for allowed	allowed($priv,$uri,$symb,$role) : check for a user privilege; returns codes for allowed actions
actions
F: full access	F: full access
U,I,K: authentication modes (cxx only)	U,I,K: authentication modes (cxx only)
'': forbidden	'': forbidden
1: user needs to choose course	1: user needs to choose course
2: browse allowed	2: browse allowed
	A: passphrase authentication needed

=item *	=item *

Line 6958 all args are optional	Line 8201 all args are optional

=item *	=item *

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

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


	=item *

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

	=item *

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

=item *	=item *

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

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

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

=item *	=item *

putstore($namespace,$storehash,$udomain,$uname) : stores hash in namesp	cput($namespace,$storehash,$udom,$uname) : critical put
keys used in storehash include version information (e.g., 1:$symb:message etc.) as	($udom and $uname are optional)
used in records written by &store and retrieved by &restore. This function
was created for use in editing discussion posts, without incrementing the
version number included in the key for a particular post. The colon
separated list of attribute names (e.g., the value associated with the key
1:keys:$symb) is also generated and passed in the ampersand separated
items sent to lonnet::reply().

=item *	=item *

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


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

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


=item *	=item *

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

	=item *

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

	=item *

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

=back	=back

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


	=item *

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

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

=item *	=item *

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

	=item *

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


	=item *

	get_access_controls():

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

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

	Internal notes:

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

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

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

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

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

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

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

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

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

	modify_access_controls():

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

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

=back	=back

=head2 HTTP Helper Routines	=head2 HTTP Helper Routines

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

Removed from v.1.683.2.14
changed lines
	Added in v.1.824.2.3