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.1172.2.146.2.14 and 1.1526

version 1.1172.2.146.2.14, 2023/09/04 18:59:17	version 1.1526, 2024/05/01 12:06:25
Line 71 delayed.	Line 71 delayed.
package Apache::lonnet;	package Apache::lonnet;

use strict;	use strict;
use LWP::UserAgent();
use HTTP::Date;	use HTTP::Date;
use Image::Magick;	use Image::Magick;
use CGI::Cookie;	use CGI::Cookie;

	use Encode;

use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $deftex	use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $deftex
$_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease	$_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease
%managerstab $passwdmin);	%managerstab $passwdmin);
Line 101 use LONCAPA qw(:DEFAULT :match);	Line 102 use LONCAPA qw(:DEFAULT :match);
use LONCAPA::Configuration;	use LONCAPA::Configuration;
use LONCAPA::lonmetadata;	use LONCAPA::lonmetadata;
use LONCAPA::Lond;	use LONCAPA::Lond;
	use LONCAPA::LWPReq;
use LONCAPA::transliterate;	use LONCAPA::transliterate;

use File::Copy;	use File::Copy;
Line 113 require Exporter;	Line 115 require Exporter;
our @ISA = qw (Exporter);	our @ISA = qw (Exporter);
our @EXPORT = qw(%env);	our @EXPORT = qw(%env);


# ------------------------------------ Logging (parameters, docs, slots, roles)	# ------------------------------------ Logging (parameters, docs, slots, roles)
{	{
my $logid;	my $logid;
Line 128 our @EXPORT = qw(%env);	Line 131 our @EXPORT = qw(%env);
my $now = time();	my $now = time();
my $id=$now.'00000'.$$.'00000'.$logid;	my $id=$now.'00000'.$$.'00000'.$logid;
my $ip = &get_requestor_ip();	my $ip = &get_requestor_ip();
my $logentry = {	my $logentry = {
$id => {	$id => {
'exe_uname' => $env{'user.name'},	'exe_uname' => $env{'user.name'},
'exe_udom' => $env{'user.domain'},	'exe_udom' => $env{'user.domain'},
'exe_time' => $now,	'exe_time' => $now,
'exe_ip' => $ip,	'exe_ip' => $ip,
'delflag' => $delflag,	'delflag' => $delflag,
'logentry' => $storehash,	'logentry' => $storehash,
'uname' => $uname,	'uname' => $uname,
'udom' => $udom,	'udom' => $udom,
}	}
};	};
return &put('nohist_'.$hash_name,$logentry,$cdom,$cnum);	return &put('nohist_'.$hash_name,$logentry,$cdom,$cnum);
}	}
}	}

Line 185 sub create_connection {	Line 188 sub create_connection {
Type => SOCK_STREAM,	Type => SOCK_STREAM,
Timeout => 10);	Timeout => 10);
return 0 if (!$client);	return 0 if (!$client);
print $client (join(':',$hostname,$lonid,&machine_ids($hostname))."\n");	print $client (join(':',$hostname,$lonid,&machine_ids($hostname),$loncaparevs{$lonid})."\n");
my $result = <$client>;	my $result = <$client>;
chomp($result);	chomp($result);
return 1 if ($result eq 'done');	return 1 if ($result eq 'done');
Line 230 sub get_server_distarch {	Line 233 sub get_server_distarch {
return;	return;
}	}

	sub get_servercerts_info {
	my ($lonhost,$hostname,$context) = @_;
	return if ($lonhost eq '');
	if ($hostname eq '') {
	$hostname = &hostname($lonhost);
	}
	return if ($hostname eq '');
	my ($rep,$uselocal);
	if ($context eq 'install') {
	$uselocal = 1;
	} elsif (grep { $_ eq $lonhost } &current_machine_ids()) {
	$uselocal = 1;
	}
	if (($context ne 'cgi') && ($context ne 'install') && ($uselocal)) {
	my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0];
	if ($distro eq '') {
	$uselocal = 0;
	} elsif ($distro =~ /^(?:centos\|redhat\|scientific)(\d+)$/) {
	if ($1 < 6) {
	$uselocal = 0;
	}
	} elsif ($distro =~ /^(?:sles)(\d+)$/) {
	if ($1 < 12) {
	$uselocal = 0;
	}
	}
	}
	if ($uselocal) {
	$rep = LONCAPA::Lond::server_certs(\%perlvar,$lonhost,$hostname);
	} else {
	$rep=&reply('servercerts',$lonhost);
	}
	my ($result,%returnhash);
	if (($rep=~/^(refused\|rejected\|error)/) \|\| ($rep eq 'con_lost') \|\|
	($rep eq 'unknown_cmd')) {
	$result = $rep;
	} else {
	$result = 'ok';
	my @pairs=split(/\&/,$rep);
	foreach my $item (@pairs) {
	my ($key,$value)=split(/=/,$item,2);
	my $what = &unescape($key);
	$returnhash{$what}=&thaw_unescape($value);
	}
	}
	return ($result,\%returnhash);
	}

sub get_server_loncaparev {	sub get_server_loncaparev {
my ($dom,$lonhost,$ignore_cache,$caller) = @_;	my ($dom,$lonhost,$ignore_cache,$caller) = @_;
if (defined($lonhost)) {	if (defined($lonhost)) {
Line 264 sub get_server_loncaparev {	Line 315 sub get_server_loncaparev {
$answer = &reply('serverloncaparev',$lonhost);	$answer = &reply('serverloncaparev',$lonhost);
if (($answer eq 'unknown_cmd') \|\| ($answer eq 'con_lost')) {	if (($answer eq 'unknown_cmd') \|\| ($answer eq 'con_lost')) {
if ($caller eq 'loncron') {	if ($caller eq 'loncron') {
my $ua=new LWP::UserAgent;
$ua->timeout(4);
my $hostname = &hostname($lonhost);	my $hostname = &hostname($lonhost);
my $protocol = $protocol{$lonhost};	my $protocol = $protocol{$lonhost};
$protocol = 'http' if ($protocol ne 'https');	$protocol = 'http' if ($protocol ne 'https');
my $url = $protocol.'://'.$hostname.'/adm/about.html';	my $url = $protocol.'://'.$hostname.'/adm/about.html';
my $request=new HTTP::Request('GET',$url);	my $request=new HTTP::Request('GET',$url);
my $response=$ua->request($request);	my $response=&LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,4,1);
unless ($response->is_error()) {	unless ($response->is_error()) {
my $content = $response->content;	my $content = $response->content;
if ($content =~ /<p>VERSION\:\s*([\w.\-]+)<\/p>/) {	if ($content =~ /<p>VERSION\:\s*([\w.\-]+)<\/p>/) {
Line 362 sub remote_devalidate_cache {	Line 411 sub remote_devalidate_cache {
my $items;	my $items;
return unless (ref($cachekeys) eq 'ARRAY');	return unless (ref($cachekeys) eq 'ARRAY');
my $cachestr = join('&',@{$cachekeys});	my $cachestr = join('&',@{$cachekeys});
return &reply('devalidatecache:'.&escape($cachestr),$lonhost);	my $response = &reply('devalidatecache:'.&escape($cachestr),$lonhost);
	return $response;
}	}

sub sign_lti {	sub sign_lti {
Line 451 sub subreply {	Line 501 sub subreply {
} else {	} else {
&create_connection(&hostname($server),$server);	&create_connection(&hostname($server),$server);
}	}
sleep(0.1); # Try again later if failed connection.	sleep(0.1); # Try again later if failed connection.
}	}
my $answer;	my $answer;
if ($client) {	if ($client) {
Line 525 sub reconlonc {	Line 575 sub reconlonc {
&logthis("lonc at pid $loncpid responding, sending USR1");	&logthis("lonc at pid $loncpid responding, sending USR1");
kill USR1 => $loncpid;	kill USR1 => $loncpid;
sleep 1;	sleep 1;
} else {	} else {
&logthis(	&logthis(
"<font color=\"blue\">WARNING:".	"<font color=\"blue\">WARNING:".
" lonc at pid $loncpid not responding, giving up</font>");	" lonc at pid $loncpid not responding, giving up</font>");
Line 720 sub check_for_valid_session {	Line 770 sub check_for_valid_session {
}	}
}	}
if (!-e "$lonidsdir/$handle.id") {	if (!-e "$lonidsdir/$handle.id") {
if ((ref($domref)) && ($name eq 'lonID') &&	if ((ref($domref)) && ($name eq 'lonID') &&
($handle =~ /^($match_username)\_\d+\_($match_domain)\_(.+)$/)) {	($handle =~ /^($match_username)\_\d+\_($match_domain)\_(.+)$/)) {
my ($possuname,$possudom,$possuhome) = ($1,$2,$3);	my ($possuname,$possudom,$possuhome) = ($1,$2,$3);
if ((&domain($possudom) ne '') && (&homeserver($possuname,$possudom) eq $possuhome)) {	if ((&domain($possudom) ne '') && (&homeserver($possuname,$possudom) eq $possuhome)) {
Line 992 sub spareserver {	Line 1042 sub spareserver {
: $userloadpercent;	: $userloadpercent;
my ($uint_dom,$remotesessions);	my ($uint_dom,$remotesessions);
if (($udom ne '') && (&domain($udom) ne '')) {	if (($udom ne '') && (&domain($udom) ne '')) {
my $uprimary_id = &Apache::lonnet::domain($udom,'primary');	my $uprimary_id = &domain($udom,'primary');
$uint_dom = &Apache::lonnet::internet_dom($uprimary_id);	$uint_dom = &internet_dom($uprimary_id);
my %udomdefaults = &Apache::lonnet::get_domain_defaults($udom);	my %udomdefaults = &get_domain_defaults($udom);
$remotesessions = $udomdefaults{'remotesessions'};	$remotesessions = $udomdefaults{'remotesessions'};
}	}
my $spareshash = &this_host_spares($udom);	my $spareshash = &this_host_spares($udom);
Line 1030 sub spareserver {	Line 1080 sub spareserver {
if ($protocol{$spare_server} eq 'https') {	if ($protocol{$spare_server} eq 'https') {
$protocol = $protocol{$spare_server};	$protocol = $protocol{$spare_server};
}	}
my $alias = &Apache::lonnet::use_proxy_alias($r,$spare_server);	my $alias = &use_proxy_alias($r,$spare_server);
$hostname = $alias if ($alias ne '');	$hostname = $alias if ($alias ne '');
$spare_server = $protocol.'://'.$hostname;	$spare_server = $protocol.'://'.$hostname;
}	}
Line 1111 sub delusersession {	Line 1161 sub delusersession {
return;	return;
}	}


# check if user's browser sent load balancer cookie and server still has session	# check if user's browser sent load balancer cookie and server still has session
# and is not overloaded.	# and is not overloaded.
sub check_for_balancer_cookie {	sub check_for_balancer_cookie {
Line 1219 sub choose_server {	Line 1268 sub choose_server {
unless (defined($cached)) {	unless (defined($cached)) {
my $cachetime = 606024;	my $cachetime = 606024;
my %domconfig =	my %domconfig =
&Apache::lonnet::get_dom('configuration',['loadbalancing'],$udom);	&get_dom('configuration',['loadbalancing'],$udom);
if (ref($domconfig{'loadbalancing'}) eq 'HASH') {	if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
$balancers = &do_cache_new('loadbalancing',$udom,$domconfig{'loadbalancing'},	$balancers = &do_cache_new('loadbalancing',$udom,$domconfig{'loadbalancing'},
$cachetime);	$cachetime);
Line 1227 sub choose_server {	Line 1276 sub choose_server {
}	}
}	}
foreach my $lonhost (keys(%servers)) {	foreach my $lonhost (keys(%servers)) {
my $loginvia;
if ($skiploadbal) {	if ($skiploadbal) {
if (ref($balancers) eq 'HASH') {	if (ref($balancers) eq 'HASH') {
next if (exists($balancers->{$lonhost}));	next if (exists($balancers->{$lonhost}));
}	}
}	}
	my $loginvia;
if ($checkloginvia) {	if ($checkloginvia) {
$loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};	$loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};
if ($loginvia) {	if ($loginvia) {
Line 1412 sub can_switchserver {	Line 1461 sub can_switchserver {
sub can_host_session {	sub can_host_session {
my ($udom,$lonhost,$remoterev,$remotesessions,$hostedsessions) = @_;	my ($udom,$lonhost,$remoterev,$remotesessions,$hostedsessions) = @_;
my $canhost = 1;	my $canhost = 1;
my $host_idn = &Apache::lonnet::internet_dom($lonhost);	my $host_idn = &internet_dom($lonhost);
if (ref($remotesessions) eq 'HASH') {	if (ref($remotesessions) eq 'HASH') {
if (ref($remotesessions->{'excludedomain'}) eq 'ARRAY') {	if (ref($remotesessions->{'excludedomain'}) eq 'ARRAY') {
if (grep(/^\Q$host_idn\E$/,@{$remotesessions->{'excludedomain'}})) {	if (grep(/^\Q$host_idn\E$/,@{$remotesessions->{'excludedomain'}})) {
Line 1448 sub can_host_session {	Line 1497 sub can_host_session {
}	}
if ($canhost) {	if ($canhost) {
if (ref($hostedsessions) eq 'HASH') {	if (ref($hostedsessions) eq 'HASH') {
my $uprimary_id = &Apache::lonnet::domain($udom,'primary');	my $uprimary_id = &domain($udom,'primary');
my $uint_dom = &Apache::lonnet::internet_dom($uprimary_id);	my $uint_dom = &internet_dom($uprimary_id);
if (ref($hostedsessions->{'excludedomain'}) eq 'ARRAY') {	if (ref($hostedsessions->{'excludedomain'}) eq 'ARRAY') {
if (($uint_dom ne '') &&	if (($uint_dom ne '') &&
(grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'excludedomain'}}))) {	(grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'excludedomain'}}))) {
Line 1541 sub spares_for_offload {	Line 1590 sub spares_for_offload {
} else {	} else {
my $cachetime = 606024;	my $cachetime = 606024;
my %domconfig =	my %domconfig =
&Apache::lonnet::get_dom('configuration',['usersessions'],$dom_in_use);	&get_dom('configuration',['usersessions'],$dom_in_use);
if (ref($domconfig{'usersessions'}) eq 'HASH') {	if (ref($domconfig{'usersessions'}) eq 'HASH') {
if (ref($domconfig{'usersessions'}{'spares'}) eq 'HASH') {	if (ref($domconfig{'usersessions'}{'spares'}) eq 'HASH') {
if (ref($domconfig{'usersessions'}{'spares'}{$lonhost_in_use}) eq 'HASH') {	if (ref($domconfig{'usersessions'}{'spares'}{$lonhost_in_use}) eq 'HASH') {
Line 1590 sub get_lonbalancer_config {	Line 1639 sub get_lonbalancer_config {
sub check_loadbalancing {	sub check_loadbalancing {
my ($uname,$udom,$caller) = @_;	my ($uname,$udom,$caller) = @_;
my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom,	my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom,
$rule_in_effect,$offloadto,$otherserver,$setcookie);	$rule_in_effect,$offloadto,$otherserver,$setcookie,$dom_balancers);
my $lonhost = $perlvar{'lonHostID'};	my $lonhost = $perlvar{'lonHostID'};
my @hosts = &current_machine_ids();	my @hosts = &current_machine_ids();
my $uprimary_id = &Apache::lonnet::domain($udom,'primary');	my $uprimary_id = &domain($udom,'primary');
my $uintdom = &Apache::lonnet::internet_dom($uprimary_id);	my $uintdom = &internet_dom($uprimary_id);
my $intdom = &Apache::lonnet::internet_dom($lonhost);	my $intdom = &internet_dom($lonhost);
my $serverhomedom = &host_domain($lonhost);	my $serverhomedom = &host_domain($lonhost);
my $domneedscache;	my $domneedscache;
my $cachetime = 606024;	my $cachetime = 606024;

if (($uintdom ne '') && ($uintdom eq $intdom)) {	if (($uintdom ne '') && ($uintdom eq $intdom)) {
Line 1609 sub check_loadbalancing {	Line 1658 sub check_loadbalancing {
my ($result,$cached)=&is_cached_new('loadbalancing',$dom_in_use);	my ($result,$cached)=&is_cached_new('loadbalancing',$dom_in_use);
unless (defined($cached)) {	unless (defined($cached)) {
my %domconfig =	my %domconfig =
&Apache::lonnet::get_dom('configuration',['loadbalancing'],$dom_in_use);	&get_dom('configuration',['loadbalancing'],$dom_in_use);
if (ref($domconfig{'loadbalancing'}) eq 'HASH') {	if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
$result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime);	$result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime);
} else {	} else {
Line 1617 sub check_loadbalancing {	Line 1666 sub check_loadbalancing {
}	}
}	}
if (ref($result) eq 'HASH') {	if (ref($result) eq 'HASH') {
($is_balancer,$currtargets,$currrules,$setcookie) =	($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers) =
&check_balancer_result($result,@hosts);	&check_balancer_result($result,@hosts);
if ($is_balancer) {	if ($is_balancer) {
if (ref($currrules) eq 'HASH') {	if (ref($currrules) eq 'HASH') {
Line 1670 sub check_loadbalancing {	Line 1719 sub check_loadbalancing {
($result,$cached)=&is_cached_new('loadbalancing',$serverhomedom);	($result,$cached)=&is_cached_new('loadbalancing',$serverhomedom);
unless (defined($cached)) {	unless (defined($cached)) {
my %domconfig =	my %domconfig =
&Apache::lonnet::get_dom('configuration',['loadbalancing'],$serverhomedom);	&get_dom('configuration',['loadbalancing'],$serverhomedom);
if (ref($domconfig{'loadbalancing'}) eq 'HASH') {	if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
$result = &do_cache_new('loadbalancing',$serverhomedom,$domconfig{'loadbalancing'},$cachetime);	$result = &do_cache_new('loadbalancing',$serverhomedom,$domconfig{'loadbalancing'},$cachetime);
} else {	} else {
Line 1678 sub check_loadbalancing {	Line 1727 sub check_loadbalancing {
}	}
}	}
if (ref($result) eq 'HASH') {	if (ref($result) eq 'HASH') {
($is_balancer,$currtargets,$currrules,$setcookie) =	($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers) =
&check_balancer_result($result,@hosts);	&check_balancer_result($result,@hosts);
if ($is_balancer) {	if ($is_balancer) {
if (ref($currrules) eq 'HASH') {	if (ref($currrules) eq 'HASH') {
Line 1754 sub check_loadbalancing {	Line 1803 sub check_loadbalancing {
if (($is_balancer) && (!$homeintdom)) {	if (($is_balancer) && (!$homeintdom)) {
undef($setcookie);	undef($setcookie);
}	}
return ($is_balancer,$otherserver,$setcookie);	return ($is_balancer,$otherserver,$setcookie,$offloadto,$dom_balancers);
}	}

sub check_balancer_result {	sub check_balancer_result {
my ($result,@hosts) = @_;	my ($result,@hosts) = @_;
my ($is_balancer,$currtargets,$currrules,$setcookie);	my ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers);
if (ref($result) eq 'HASH') {	if (ref($result) eq 'HASH') {
if ($result->{'lonhost'} ne '') {	if ($result->{'lonhost'} ne '') {
my $currbalancer = $result->{'lonhost'};	my $currbalancer = $result->{'lonhost'};
Line 1768 sub check_balancer_result {	Line 1817 sub check_balancer_result {
$currtargets = $result->{'targets'};	$currtargets = $result->{'targets'};
$currrules = $result->{'rules'};	$currrules = $result->{'rules'};
}	}
	$dom_balancers = $currbalancer;
} else {	} else {
foreach my $key (keys(%{$result})) {	if (keys(%{$result})) {
if (($key ne '') && (grep(/^\Q$key\E$/,@hosts)) &&	foreach my $key (keys(%{$result})) {
(ref($result->{$key}) eq 'HASH')) {	if (($key ne '') && (grep(/^\Q$key\E$/,@hosts)) &&
$is_balancer = 1;	(ref($result->{$key}) eq 'HASH')) {
$currrules = $result->{$key}{'rules'};	$is_balancer = 1;
$currtargets = $result->{$key}{'targets'};	$currrules = $result->{$key}{'rules'};
$setcookie = $result->{$key}{'cookie'};	$currtargets = $result->{$key}{'targets'};
last;	$setcookie = $result->{$key}{'cookie'};
	last;
	}
}	}
	$dom_balancers = join(',',sort(keys(%{$result})));
}	}
}	}
}	}
return ($is_balancer,$currtargets,$currrules,$setcookie);	return ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers);
}	}

sub get_loadbalancer_targets {	sub get_loadbalancer_targets {
Line 1799 sub get_loadbalancer_targets {	Line 1852 sub get_loadbalancer_targets {
}	}
} elsif ($rule_in_effect eq 'externalbalancer') {	} elsif ($rule_in_effect eq 'externalbalancer') {
my %domconfig =	my %domconfig =
&Apache::lonnet::get_dom('configuration',['loadbalancing'],$udom);	&get_dom('configuration',['loadbalancing'],$udom);
if (ref($domconfig{'loadbalancing'}) eq 'HASH') {	if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
if ($domconfig{'loadbalancing'}{'lonhost'} ne '') {	if ($domconfig{'loadbalancing'}{'lonhost'} ne '') {
if (&hostname($domconfig{'loadbalancing'}{'lonhost'}) ne '') {	if (&hostname($domconfig{'loadbalancing'}{'lonhost'}) ne '') {
Line 1853 sub internet_dom_servers {	Line 1906 sub internet_dom_servers {
return %uniqservers;	return %uniqservers;
}	}

	sub trusted_domains {
	my ($cmdtype,$calldom) = @_;
	my ($trusted,$untrusted);
	if (&domain($calldom) eq '') {
	return ($trusted,$untrusted);
	}
	unless ($cmdtype =~ /^(content\|shared\|enroll\|coaurem\|othcoau\|domroles\|catalog\|reqcrs\|msg)$/) {
	return ($trusted,$untrusted);
	}
	my $callprimary = &domain($calldom,'primary');
	my $intcalldom = &internet_dom($callprimary);
	if ($intcalldom eq '') {
	return ($trusted,$untrusted);
	}

	my ($trustconfig,$cached)=&is_cached_new('trust',$calldom);
	unless (defined($cached)) {
	my %domconfig = &get_dom('configuration',['trust'],$calldom);
	&do_cache_new('trust',$calldom,$domconfig{'trust'},3600);
	$trustconfig = $domconfig{'trust'};
	}
	if (ref($trustconfig)) {
	my (%possexc,%possinc,@allexc,@allinc);
	if (ref($trustconfig->{$cmdtype}) eq 'HASH') {
	if (ref($trustconfig->{$cmdtype}->{'exc'}) eq 'ARRAY') {
	map { $possexc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'exc'}};
	}
	if (ref($trustconfig->{$cmdtype}->{'inc'}) eq 'ARRAY') {
	$possinc{$intcalldom} = 1;
	map { $possinc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'inc'}};
	}
	}
	if (keys(%possexc)) {
	if (keys(%possinc)) {
	foreach my $key (sort(keys(%possexc))) {
	next if ($key eq $intcalldom);
	unless ($possinc{$key}) {
	push(@allexc,$key);
	}
	}
	} else {
	@allexc = sort(keys(%possexc));
	}
	}
	if (keys(%possinc)) {
	$possinc{$intcalldom} = 1;
	@allinc = sort(keys(%possinc));
	}
	if ((@allexc > 0) \|\| (@allinc > 0)) {
	my %doms_by_intdom;
	my %allintdoms = &all_host_intdom();
	my %alldoms = &all_host_domain();
	foreach my $key (%allintdoms) {
	if (ref($doms_by_intdom{$allintdoms{$key}}) eq 'ARRAY') {
	unless (grep(/^\Q$alldoms{$key}\E$/,@{$doms_by_intdom{$allintdoms{$key}}})) {
	push(@{$doms_by_intdom{$allintdoms{$key}}},$alldoms{$key});
	}
	} else {
	$doms_by_intdom{$allintdoms{$key}} = [$alldoms{$key}];
	}
	}
	foreach my $exc (@allexc) {
	if (ref($doms_by_intdom{$exc}) eq 'ARRAY') {
	push(@{$untrusted},@{$doms_by_intdom{$exc}});
	}
	}
	foreach my $inc (@allinc) {
	if (ref($doms_by_intdom{$inc}) eq 'ARRAY') {
	push(@{$trusted},@{$doms_by_intdom{$inc}});
	}
	}
	}
	}
	return ($trusted,$untrusted);
	}

	sub will_trust {
	my ($cmdtype,$domain,$possdom) = @_;
	return 1 if ($domain eq $possdom);
	my ($trustedref,$untrustedref) = &trusted_domains($cmdtype,$possdom);
	my $willtrust;
	if ((ref($trustedref) eq 'ARRAY') && (@{$trustedref} > 0)) {
	if (grep(/^\Q$domain\E$/,@{$trustedref})) {
	$willtrust = 1;
	}
	} elsif ((ref($untrustedref) eq 'ARRAY') && (@{$untrustedref} > 0)) {
	unless (grep(/^\Q$domain\E$/,@{$untrustedref})) {
	$willtrust = 1;
	}
	} else {
	$willtrust = 1;
	}
	return $willtrust;
	}

# ---------------------- Find the homebase for a user from domain's lib servers	# ---------------------- Find the homebase for a user from domain's lib servers

my %homecache;	my %homecache;
Line 1878 sub homeserver {	Line 2026 sub homeserver {
return 'no_host';	return 'no_host';
}	}

# ------------------------------------- Find the usernames behind a list of IDs	# ----- Find the usernames behind a list of student/employee IDs or clicker IDs

sub idget {	sub idget {
my ($udom,@ids)=@_;	my ($udom,$idsref,$namespace)=@_;
my %returnhash=();	my %returnhash=();
	my @ids=();
	if (ref($idsref) eq 'ARRAY') {
	@ids = @{$idsref};
	} else {
	return %returnhash;
	}
	if ($namespace eq '') {
	$namespace = 'ids';
	}

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

Line 1914 sub idrget {	Line 2078 sub idrget {
return %returnhash;	return %returnhash;
}	}

# ------------------------------- Store away a list of names and associated IDs	# Store away a list of names and associated student/employee IDs or clicker IDs

sub idput {	sub idput {
my ($udom,%ids)=@_;	my ($udom,$idsref,$uhom,$namespace)=@_;
my %servers=();	my %servers=();
	my %ids=();
	my %byid = ();
	if (ref($idsref) eq 'HASH') {
	%ids=%{$idsref};
	}
	if ($namespace eq '') {
	$namespace = 'ids';
	}
foreach my $uname (keys(%ids)) {	foreach my $uname (keys(%ids)) {
&cput('environment',{'id'=>$ids{$uname}},$udom,$uname);	&cput('environment',{'id'=>$ids{$uname}},$udom,$uname);
my $uhom=&homeserver($uname,$udom);	if ($uhom eq '') {
	$uhom=&homeserver($uname,$udom);
	}
if ($uhom ne 'no_host') {	if ($uhom ne 'no_host') {
my $id=&escape($ids{$uname});
$id=~tr/A-Z/a-z/;
my $esc_unam=&escape($uname);	my $esc_unam=&escape($uname);
if ($servers{$uhom}) {	if ($namespace eq 'ids') {
$servers{$uhom}.='&'.$id.'='.$esc_unam;	my $id=&escape($ids{$uname});
	$id=~tr/A-Z/a-z/;
	my $esc_unam=&escape($uname);
	$servers{$uhom}.=$id.'='.$esc_unam.'&';
} else {	} else {
$servers{$uhom}=$id.'='.$esc_unam;	my @currids = split(/,/,$ids{$uname});
	foreach my $id (@currids) {
	$byid{$uhom}{$id} .= $uname.',';
	}
	}
	}
	}
	if ($namespace eq 'clickers') {
	foreach my $server (keys(%byid)) {
	if (ref($byid{$server}) eq 'HASH') {
	foreach my $id (keys(%{$byid{$server}})) {
	$byid{$server} =~ s/,$//;
	$servers{$uhom}.=&escape($id).'='.&escape($byid{$server}).'&';
	}
}	}
}	}
}	}
foreach my $server (keys(%servers)) {	foreach my $server (keys(%servers)) {
&critical('idput:'.$udom.':'.$servers{$server},$server);	$servers{$server} =~ s/\&$//;
	if ($namespace eq 'ids') {
	&critical('idput:'.$udom.':'.$servers{$server},$server);
	} else {
	&critical('updateclickers:'.$udom.':add:'.$servers{$server},$server);
	}
}	}
}	}

# ---------------------------------------- Delete unwanted IDs from ids.db file	# ------------- Delete unwanted student/employee IDs or clicker IDs from domain

sub iddel {	sub iddel {
my ($udom,$idshashref,$uhome)=@_;	my ($udom,$idshashref,$uhome,$namespace)=@_;
my %result=();	my %result=();
unless (ref($idshashref) eq 'HASH') {	my %ids=();
	my %byid = ();
	if (ref($idshashref) eq 'HASH') {
	%ids=%{$idshashref};
	} else {
return %result;	return %result;
}	}
	if ($namespace eq '') {
	$namespace = 'ids';
	}
my %servers=();	my %servers=();
while (my ($id,$uname) = each(%{$idshashref})) {	while (my ($id,$unamestr) = each(%ids)) {
my $uhom;	if ($namespace eq 'ids') {
if ($uhome) {	my $uhom = $uhome;
$uhom = $uhome;	if ($uhom eq '') {
} else {	$uhom=&homeserver($unamestr,$udom);
$uhom=&homeserver($uname,$udom);	}
}	if ($uhom ne 'no_host') {
if ($uhom ne 'no_host') {
if ($servers{$uhom}) {
$servers{$uhom}.='&'.&escape($id);	$servers{$uhom}.='&'.&escape($id);
} else {	}
$servers{$uhom}=&escape($id);	} else {
	my @curritems = split(/,/,$ids{$id});
	foreach my $uname (@curritems) {
	my $uhom = $uhome;
	if ($uhom eq '') {
	$uhom=&homeserver($uname,$udom);
	}
	if ($uhom ne 'no_host') {
	$byid{$uhom}{$id} .= $uname.',';
	}
	}
	}
	}
	if ($namespace eq 'clickers') {
	foreach my $server (keys(%byid)) {
	if (ref($byid{$server}) eq 'HASH') {
	foreach my $id (keys(%{$byid{$server}})) {
	$byid{$server}{$id} =~ s/,$//;
	$servers{$server}.=&escape($id).'='.&escape($byid{$server}{$id}).'&';
	}
}	}
}	}
}	}
foreach my $server (keys(%servers)) {	foreach my $server (keys(%servers)) {
$result{$server} = &critical('iddel:'.$udom.':'.$servers{$server},$uhome);	$servers{$server} =~ s/\&$//;
	if ($namespace eq 'ids') {
	$result{$server} = &critical('iddel:'.$udom.':'.$servers{$server},$uhome);
	} elsif ($namespace eq 'clickers') {
	$result{$server} = &critical('updateclickers:'.$udom.':del:'.$servers{$server},$server);
	}
}	}
return %result;	return %result;
}	}

	# ----- Update clicker ID-to-username look-ups in clickers.db on library server

	sub updateclickers {
	my ($udom,$action,$idshashref,$uhome,$critical) = @_;
	my %clickers;
	if (ref($idshashref) eq 'HASH') {
	%clickers=%{$idshashref};
	} else {
	return;
	}
	my $items='';
	foreach my $item (keys(%clickers)) {
	$items.=&escape($item).'='.&escape($clickers{$item}).'&';
	}
	$items=~s/\&$//;
	my $request = "updateclickers:$udom:$action:$items";
	if ($critical) {
	return &critical($request,$uhome);
	} else {
	return &reply($request,$uhome);
	}
	}

# ------------------------------dump from db file owned by domainconfig user	# ------------------------------dump from db file owned by domainconfig user
sub dump_dom {	sub dump_dom {
my ($namespace, $udom, $regexp) = @_;	my ($namespace, $udom, $regexp) = @_;
Line 2132 sub restore_dom {	Line 2377 sub restore_dom {
}	}
}	}
my %returnhash=();	my %returnhash=();
unless (($answer eq '') \|\| ($answer eq 'con_lost') \|\| ($answer eq 'refused') \|\|	unless (($answer eq '') \|\| ($answer eq 'con_lost') \|\| ($answer eq 'refused') \|\|
($answer eq 'unknown_cmd') \|\| ($answer eq 'rejected')) {	($answer eq 'unknown_cmd') \|\| ($answer eq 'rejected')) {
foreach my $line (split(/\&/,$answer)) {	foreach my $line (split(/\&/,$answer)) {
my ($name,$value)=split(/\=/,$line);	my ($name,$value)=split(/\=/,$line);
Line 2157 sub get_domainconfiguser {	Line 2402 sub get_domainconfiguser {
sub retrieve_inst_usertypes {	sub retrieve_inst_usertypes {
my ($udom) = @_;	my ($udom) = @_;
my (%returnhash,@order);	my (%returnhash,@order);
my %domdefs = &Apache::lonnet::get_domain_defaults($udom);	my %domdefs = &get_domain_defaults($udom);
if ((ref($domdefs{'inststatustypes'}) eq 'HASH') &&	if ((ref($domdefs{'inststatustypes'}) eq 'HASH') &&
(ref($domdefs{'inststatusorder'}) eq 'ARRAY')) {	(ref($domdefs{'inststatusorder'}) eq 'ARRAY')) {
return ($domdefs{'inststatustypes'},$domdefs{'inststatusorder'});	return ($domdefs{'inststatustypes'},$domdefs{'inststatusorder'});
Line 2208 sub inst_directory_query {	Line 2453 sub inst_directory_query {
unless ($homeserver eq $perlvar{'lonHostID'}) {	unless ($homeserver eq $perlvar{'lonHostID'}) {
if ($srch->{'srchby'} eq 'email') {	if ($srch->{'srchby'} eq 'email') {
my $lcrev = &get_server_loncaparev($udom,$homeserver);	my $lcrev = &get_server_loncaparev($udom,$homeserver);
my ($major,$minor,$subver) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.(\d+)[\w.\-]+\'?$/);	my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);
if (($major eq '' && $minor eq '') \|\| ($major < 2) \|\|	if (($major eq '' && $minor eq '') \|\| ($major < 2) \|\|
(($major == 2) && ($minor < 11)) \|\|	(($major == 2) && ($minor < 12))) {
(($major == 2) && ($minor == 11) && ($subver < 3))) {
return;	return;
}	}
}	}
Line 2260 sub usersearch {	Line 2504 sub usersearch {
unless ($tryserver eq $perlvar{'lonHostID'}) {	unless ($tryserver eq $perlvar{'lonHostID'}) {
if ($srch->{'srchby'} eq 'email') {	if ($srch->{'srchby'} eq 'email') {
my $lcrev = &get_server_loncaparev($dom,$tryserver);	my $lcrev = &get_server_loncaparev($dom,$tryserver);
my ($major,$minor,$subver) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.(\d+)[\w.\-]+\'?$/);	my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);
next if (($major eq '' && $minor eq '') \|\| ($major < 2) \|\|	next if (($major eq '' && $minor eq '') \|\| ($major < 2) \|\|
(($major == 2) && ($minor < 11)) \|\|	(($major == 2) && ($minor < 12)));
(($major == 2) && ($minor == 11) && ($subver < 3)));
}	}
}	}
my $host=&hostname($tryserver);	my $host=&hostname($tryserver);
Line 2355 sub get_multiple_instusers {	Line 2598 sub get_multiple_instusers {
my ($udom,$users,$caller) = @_;	my ($udom,$users,$caller) = @_;
my ($outcome,$results);	my ($outcome,$results);
if (ref($users) eq 'HASH') {	if (ref($users) eq 'HASH') {
my $count = keys(%{$users});	my $count = keys(%{$users});
my $requested = &freeze_escape($users);	my $requested = &freeze_escape($users);
my $homeserver = &domain($udom,'primary');	my $homeserver = &domain($udom,'primary');
if ($homeserver ne '') {	if ($homeserver ne '') {
Line 2399 sub get_multiple_instusers {	Line 2642 sub get_multiple_instusers {
} else {	} else {
($outcome,my $userdata) = split(/=/,$response,2);	($outcome,my $userdata) = split(/=/,$response,2);
if ($outcome eq 'ok') {	if ($outcome eq 'ok') {
$results = &thaw_unescape($userdata);	$results = &thaw_unescape($userdata);
}	}
}	}
}	}
Line 2426 sub inst_rulecheck {	Line 2669 sub inst_rulecheck {
$response=&unescape(&reply('instidrulecheck:'.&escape($udom).	$response=&unescape(&reply('instidrulecheck:'.&escape($udom).
':'.&escape($id).':'.$rulestr,	':'.&escape($id).':'.$rulestr,
$homeserver));	$homeserver));
} elsif ($item eq 'unamemap') {
$response=&unescape(&reply('instunamemapcheck:'.
&escape($udom).':'.&escape($uname).
':'.$rulestr,$homeserver));
} elsif ($item eq 'selfcreate') {	} elsif ($item eq 'selfcreate') {
$response=&unescape(&reply('instselfcreatecheck:'.	$response=&unescape(&reply('instselfcreatecheck:'.
&escape($udom).':'.&escape($uname).	&escape($udom).':'.&escape($uname).
':'.$rulestr,$homeserver));	':'.$rulestr,$homeserver));
	} elsif ($item eq 'unamemap') {
	$response=&unescape(&reply('instunamemapcheck:'.
	&escape($udom).':'.&escape($uname).
	':'.$rulestr,$homeserver));
}	}
if ($response ne 'refused') {	if ($response ne 'refused') {
my @pairs=split(/\&/,$response);	my @pairs=split(/\&/,$response);
Line 2465 sub inst_userrules {	Line 2708 sub inst_userrules {
$homeserver);	$homeserver);
} elsif ($check eq 'unamemap') {	} elsif ($check eq 'unamemap') {
$response=&reply('unamemaprules:'.&escape($udom),	$response=&reply('unamemaprules:'.&escape($udom),
$homeserver);	$homeserver);
} else {	} else {
$response=&reply('instuserrules:'.&escape($udom),	$response=&reply('instuserrules:'.&escape($udom),
$homeserver);	$homeserver);
Line 2507 sub get_domain_defaults {	Line 2750 sub get_domain_defaults {
}	}
my %domdefaults;	my %domdefaults;
my %domconfig =	my %domconfig =
&Apache::lonnet::get_dom('configuration',['defaults','quotas',	&get_dom('configuration',['defaults','quotas',
'requestcourses','inststatus',	'requestcourses','inststatus',
'coursedefaults','usersessions',	'coursedefaults','usersessions',
'requestauthor','selfenrollment',	'requestauthor','authordefaults',
'coursecategories','autoenroll',	'selfenrollment','coursecategories',
'helpsettings','wafproxy','ltisec',	'ssl','autoenroll','trust',
'toolsec','domexttool','exttool'],	'helpsettings','wafproxy',
$domain);	'ltisec','toolsec','privacy'],$domain);
my @coursetypes = ('official','unofficial','community','textbook');	my @coursetypes = ('official','unofficial','community','textbook','placement');
if (ref($domconfig{'defaults'}) eq 'HASH') {	if (ref($domconfig{'defaults'}) eq 'HASH') {
$domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};	$domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};
$domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};	$domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};
Line 2540 sub get_domain_defaults {	Line 2783 sub get_domain_defaults {
} else {	} else {
$domdefaults{'defaultquota'} = $domconfig{'quotas'};	$domdefaults{'defaultquota'} = $domconfig{'quotas'};
}	}
my @usertools = ('aboutme','blog','webdav','portfolio');	my @usertools = ('aboutme','blog','webdav','portfolio','portaccess');
foreach my $item (@usertools) {	foreach my $item (@usertools) {
if (ref($domconfig{'quotas'}{$item}) eq 'HASH') {	if (ref($domconfig{'quotas'}{$item}) eq 'HASH') {
$domdefaults{$item} = $domconfig{'quotas'}{$item};	$domdefaults{$item} = $domconfig{'quotas'}{$item};
Line 2551 sub get_domain_defaults {	Line 2794 sub get_domain_defaults {
}	}
}	}
if (ref($domconfig{'requestcourses'}) eq 'HASH') {	if (ref($domconfig{'requestcourses'}) eq 'HASH') {
foreach my $item ('official','unofficial','community','textbook') {	foreach my $item ('official','unofficial','community','textbook','placement') {
$domdefaults{$item} = $domconfig{'requestcourses'}{$item};	$domdefaults{$item} = $domconfig{'requestcourses'}{$item};
}	}
}	}
if (ref($domconfig{'requestauthor'}) eq 'HASH') {	if (ref($domconfig{'requestauthor'}) eq 'HASH') {
$domdefaults{'requestauthor'} = $domconfig{'requestauthor'};	$domdefaults{'requestauthor'} = $domconfig{'requestauthor'};
}	}
	if (ref($domconfig{'authordefaults'}) eq 'HASH') {
	foreach my $item ('nocodemirror','copyright','sourceavail','domcoordacc','editors') {
	if ($item eq 'editors') {
	if (ref($domconfig{'authordefaults'}{'editors'}) eq 'ARRAY') {
	$domdefaults{$item} = join(',',@{$domconfig{'authordefaults'}{'editors'}});
	}
	} else {
	$domdefaults{$item} = $domconfig{'authordefaults'}{$item};
	}
	}
	}
if (ref($domconfig{'inststatus'}) eq 'HASH') {	if (ref($domconfig{'inststatus'}) eq 'HASH') {
foreach my $item ('inststatustypes','inststatusorder','inststatusguest') {	foreach my $item ('inststatustypes','inststatusorder','inststatusguest') {
$domdefaults{$item} = $domconfig{'inststatus'}{$item};	$domdefaults{$item} = $domconfig{'inststatus'}{$item};
}	}
}	}
if (ref($domconfig{'coursedefaults'}) eq 'HASH') {	if (ref($domconfig{'coursedefaults'}) eq 'HASH') {
	$domdefaults{'canuse_pdfforms'} = $domconfig{'coursedefaults'}{'canuse_pdfforms'};
$domdefaults{'usejsme'} = $domconfig{'coursedefaults'}{'usejsme'};	$domdefaults{'usejsme'} = $domconfig{'coursedefaults'}{'usejsme'};
$domdefaults{'inline_chem'} = $domconfig{'coursedefaults'}{'inline_chem'};	$domdefaults{'inline_chem'} = $domconfig{'coursedefaults'}{'inline_chem'};
$domdefaults{'uselcmath'} = $domconfig{'coursedefaults'}{'uselcmath'};	$domdefaults{'uselcmath'} = $domconfig{'coursedefaults'}{'uselcmath'};
Line 2584 sub get_domain_defaults {	Line 2839 sub get_domain_defaults {
}	}
if ($domdefaults{'postsubmit'} eq 'on') {	if ($domdefaults{'postsubmit'} eq 'on') {
if (ref($domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}) eq 'HASH') {	if (ref($domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}) eq 'HASH') {
$domdefaults{$type.'postsubtimeout'} =	$domdefaults{$type.'postsubtimeout'} =
$domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}{$type};	$domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}{$type};
}	}
}	}
if (ref($domconfig{'coursedefaults'}{'domexttool'}) eq 'HASH') {	if (ref($domconfig{'coursedefaults'}{'domexttool'}) eq 'HASH') {
Line 2598 sub get_domain_defaults {	Line 2853 sub get_domain_defaults {
} else {	} else {
$domdefaults{$type.'exttool'} = 0;	$domdefaults{$type.'exttool'} = 0;
}	}
	if (ref($domconfig{'coursedefaults'}{'crsauthor'}) eq 'HASH') {
	$domdefaults{$type.'crsauthor'} = $domconfig{'coursedefaults'}{'crsauthor'}{$type};
	} else {
	$domdefaults{$type.'crsauthor'} = 1;
	}
	if (ref($domconfig{'coursedefaults'}{'crseditors'}) eq 'ARRAY') {
	$domdefaults{'crseditors'}=join(',',@{$domconfig{'coursedefaults'}{'crseditors'}});
	}
}	}
if (ref($domconfig{'coursedefaults'}{'canclone'}) eq 'HASH') {	if (ref($domconfig{'coursedefaults'}{'canclone'}) eq 'HASH') {
if (ref($domconfig{'coursedefaults'}{'canclone'}{'instcode'}) eq 'ARRAY') {	if (ref($domconfig{'coursedefaults'}{'canclone'}{'instcode'}) eq 'ARRAY') {
Line 2668 sub get_domain_defaults {	Line 2931 sub get_domain_defaults {
$domdefaults{'catunauth'} = $domconfig{'coursecategories'}{'unauth'};	$domdefaults{'catunauth'} = $domconfig{'coursecategories'}{'unauth'};
}	}
}	}
	if (ref($domconfig{'ssl'}) eq 'HASH') {
	if (ref($domconfig{'ssl'}{'replication'}) eq 'HASH') {
	$domdefaults{'replication'} = $domconfig{'ssl'}{'replication'};
	}
	if (ref($domconfig{'ssl'}{'connto'}) eq 'HASH') {
	$domdefaults{'connect'} = $domconfig{'ssl'}{'connto'};
	}
	if (ref($domconfig{'ssl'}{'connfrom'}) eq 'HASH') {
	$domdefaults{'connect'} = $domconfig{'ssl'}{'connfrom'};
	}
	}
	if (ref($domconfig{'trust'}) eq 'HASH') {
	my @prefixes = qw(content shared enroll othcoau coaurem domroles catalog reqcrs msg);
	foreach my $prefix (@prefixes) {
	if (ref($domconfig{'trust'}{$prefix}) eq 'HASH') {
	$domdefaults{'trust'.$prefix} = $domconfig{'trust'}{$prefix};
	}
	}
	}
if (ref($domconfig{'autoenroll'}) eq 'HASH') {	if (ref($domconfig{'autoenroll'}) eq 'HASH') {
$domdefaults{'autofailsafe'} = $domconfig{'autoenroll'}{'autofailsafe'};	$domdefaults{'autofailsafe'} = $domconfig{'autoenroll'}{'autofailsafe'};
$domdefaults{'failsafe'} = $domconfig{'autoenroll'}{'failsafe'};	$domdefaults{'failsafe'} = $domconfig{'autoenroll'}{'failsafe'};
Line 2696 sub get_domain_defaults {	Line 2978 sub get_domain_defaults {
$domdefaults{'ltiprivhosts'} = $domconfig{'ltisec'}{'private'}{'keys'};	$domdefaults{'ltiprivhosts'} = $domconfig{'ltisec'}{'private'}{'keys'};
}	}
}	}
	if (ref($domconfig{'ltisec'}{'suggested'}) eq 'HASH') {
	my %suggestions = %{$domconfig{'ltisec'}{'suggested'}};
	foreach my $item (keys(%{$domconfig{'ltisec'}{'suggested'}})) {
	unless (ref($domconfig{'ltisec'}{'suggested'}{$item}) eq 'HASH') {
	delete($suggestions{$item});
	}
	}
	if (keys(%suggestions)) {
	$domdefaults{'linkprotsuggested'} = \%suggestions;
	}
	}
}	}
if (ref($domconfig{'toolsec'}) eq 'HASH') {	if (ref($domconfig{'toolsec'}) eq 'HASH') {
if (ref($domconfig{'toolsec'}{'encrypt'}) eq 'HASH') {	if (ref($domconfig{'toolsec'}{'encrypt'}) eq 'HASH') {
Line 2708 sub get_domain_defaults {	Line 3001 sub get_domain_defaults {
}	}
}	}
}	}
	if (ref($domconfig{'privacy'}) eq 'HASH') {
	if (ref($domconfig{'privacy'}{'approval'}) eq 'HASH') {
	foreach my $domtype ('instdom','extdom') {
	if (ref($domconfig{'privacy'}{'approval'}{$domtype}) eq 'HASH') {
	foreach my $roletype ('domain','author','course','community') {
	if ($domconfig{'privacy'}{'approval'}{$domtype}{$roletype} eq 'user') {
	$domdefaults{'userapprovals'} = 1;
	last;
	}
	}
	}
	last if ($domdefaults{'userapprovals'});
	}
	}
	}
&do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);	&do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);
return %domdefaults;	return %domdefaults;
}	}
Line 2727 sub get_dom_cats {	Line 3035 sub get_dom_cats {
} else {	} else {
$cats = {};	$cats = {};
}	}
&Apache::lonnet::do_cache_new('cats',$dom,$cats,3600);	&do_cache_new('cats',$dom,$cats,3600);
}	}
return $cats;	return $cats;
}	}
Line 2772 sub retrieve_instcodes {	Line 3080 sub retrieve_instcodes {
return $totcodes;	return $totcodes;
}	}

# --------------------------------------------- Get domain config for passwords

sub get_passwdconf {
my ($dom) = @_;
my (%passwdconf,$gotconf,$lookup);
my ($result,$cached)=&is_cached_new('passwdconf',$dom);
if (defined($cached)) {
if (ref($result) eq 'HASH') {
%passwdconf = %{$result};
$gotconf = 1;
}
}
unless ($gotconf) {
my %domconfig = &get_dom('configuration',['passwords'],$dom);
if (ref($domconfig{'passwords'}) eq 'HASH') {
%passwdconf = %{$domconfig{'passwords'}};
}
my $cachetime = 246060;
&do_cache_new('passwdconf',$dom,\%passwdconf,$cachetime);
}
return %passwdconf;
}

sub course_portal_url {	sub course_portal_url {
my ($cnum,$cdom,$r) = @_;	my ($cnum,$cdom,$r) = @_;
my $chome = &homeserver($cnum,$cdom);	my $chome = &homeserver($cnum,$cdom);
Line 2806 sub course_portal_url {	Line 3091 sub course_portal_url {
if ($domdefaults{'portal_def'}) {	if ($domdefaults{'portal_def'}) {
$firsturl = $domdefaults{'portal_def'};	$firsturl = $domdefaults{'portal_def'};
} else {	} else {
my $alias = &Apache::lonnet::use_proxy_alias($r,$chome);	my $alias = &use_proxy_alias($r,$chome);
$hostname = $alias if ($alias ne '');	$hostname = $alias if ($alias ne '');
$firsturl = $protocol.'://'.$hostname;	$firsturl = $protocol.'://'.$hostname;
}	}
Line 2833 sub url_prefix {	Line 3118 sub url_prefix {
return $prefix;	return $prefix;
}	}

	# --------------------------------------------- Get domain config for passwords

	sub get_passwdconf {
	my ($dom) = @_;
	my (%passwdconf,$gotconf,$lookup);
	my ($result,$cached)=&is_cached_new('passwdconf',$dom);
	if (defined($cached)) {
	if (ref($result) eq 'HASH') {
	%passwdconf = %{$result};
	$gotconf = 1;
	}
	}
	unless ($gotconf) {
	my %domconfig = &get_dom('configuration',['passwords'],$dom);
	if (ref($domconfig{'passwords'}) eq 'HASH') {
	%passwdconf = %{$domconfig{'passwords'}};
	}
	my $cachetime = 246060;
	&do_cache_new('passwdconf',$dom,\%passwdconf,$cachetime);
	}
	return %passwdconf;
	}

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

sub assign_access_key {	sub assign_access_key {
Line 2981 sub courseid_to_courseurl {	Line 3289 sub courseid_to_courseurl {
return "/$cdom/$cnum";	return "/$cdom/$cnum";
}	}

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

sub is_cached_new {	sub is_cached_new {
my ($name,$id,$debug) = @_;	my ($name,$id,$debug) = @_;
my $remembered_id=$name.':'.$id; # this is to avoid make_key (which is slow) for	my $remembered_id=$name.':'.$id; # this is to avoid make_key (which is slow) whenever possible
# keys in %remembered hash, which persists for
# duration of request (no restriction on key length).
if (exists($remembered{$remembered_id})) {	if (exists($remembered{$remembered_id})) {
if ($debug) { &Apache::lonnet::logthis("Early return $remembered_id of $remembered{$remembered_id} "); }	if ($debug) { &Apache::lonnet::logthis("Early return $remembered_id of $remembered{$remembered_id} "); }
$accessed{$remembered_id}=[&gettimeofday()];	$accessed{$remembered_id}=[&gettimeofday()];
Line 3181 sub userenvironment {	Line 3487 sub userenvironment {
# ---------------------------------------------------------- Get a studentphoto	# ---------------------------------------------------------- Get a studentphoto
sub studentphoto {	sub studentphoto {
my ($udom,$unam,$ext) = @_;	my ($udom,$unam,$ext) = @_;
my $home=&Apache::lonnet::homeserver($unam,$udom);	my $home=&homeserver($unam,$udom);
if (defined($env{'request.course.id'})) {	if (defined($env{'request.course.id'})) {
if ($env{'course.'.$env{'request.course.id'}.'.internal.showphoto'}) {	if ($env{'course.'.$env{'request.course.id'}.'.internal.showphoto'}) {
if ($udom eq $env{'course.'.$env{'request.course.id'}.'.domain'}) {	if ($udom eq $env{'course.'.$env{'request.course.id'}.'.domain'}) {
return(&retrievestudentphoto($udom,$unam,$ext));	return(&retrievestudentphoto($udom,$unam,$ext));
} else {	} else {
my ($result,$perm_reqd)=	my ($result,$perm_reqd)=
&Apache::lonnet::auto_photo_permission($unam,$udom);	&auto_photo_permission($unam,$udom);
if ($result eq 'ok') {	if ($result eq 'ok') {
if (!($perm_reqd eq 'yes')) {	if (!($perm_reqd eq 'yes')) {
return(&retrievestudentphoto($udom,$unam,$ext));	return(&retrievestudentphoto($udom,$unam,$ext));
Line 3198 sub studentphoto {	Line 3504 sub studentphoto {
}	}
} else {	} else {
my ($result,$perm_reqd) =	my ($result,$perm_reqd) =
&Apache::lonnet::auto_photo_permission($unam,$udom);	&auto_photo_permission($unam,$udom);
if ($result eq 'ok') {	if ($result eq 'ok') {
if (!($perm_reqd eq 'yes')) {	if (!($perm_reqd eq 'yes')) {
return(&retrievestudentphoto($udom,$unam,$ext));	return(&retrievestudentphoto($udom,$unam,$ext));
Line 3210 sub studentphoto {	Line 3516 sub studentphoto {

sub retrievestudentphoto {	sub retrievestudentphoto {
my ($udom,$unam,$ext,$type) = @_;	my ($udom,$unam,$ext,$type) = @_;
my $home=&Apache::lonnet::homeserver($unam,$udom);	my $home=&homeserver($unam,$udom);
my $ret=&Apache::lonnet::reply("studentphoto:$udom:$unam:$ext:$type",$home);	my $ret=&reply("studentphoto:$udom:$unam:$ext:$type",$home);
if ($ret eq 'ok') {	if ($ret eq 'ok') {
my $url="/uploaded/$udom/$unam/internal/studentphoto.$ext";	my $url="/uploaded/$udom/$unam/internal/studentphoto.$ext";
if ($type eq 'thumbnail') {	if ($type eq 'thumbnail') {
$url="/uploaded/$udom/$unam/internal/studentphoto_tn.$ext";	$url="/uploaded/$udom/$unam/internal/studentphoto_tn.$ext";
}	}
my $tokenurl=&Apache::lonnet::tokenwrapper($url);	my $tokenurl=&tokenwrapper($url);
return $tokenurl;	return $tokenurl;
} else {	} else {
if ($type eq 'thumbnail') {	if ($type eq 'thumbnail') {
Line 3342 sub repcopy {	Line 3648 sub repcopy {
mkdir($path,0777);	mkdir($path,0777);
}	}
}	}
my $ua=new LWP::UserAgent;
my $request=new HTTP::Request('GET',"$remoteurl");	my $request=new HTTP::Request('GET',"$remoteurl");
my $response=$ua->request($request,$transname);	my $response;
	if ($remoteurl =~ m{/raw/}) {
	$response=&LONCAPA::LWPReq::makerequest($home,$request,$transname,\%perlvar,'',0,1);
	} else {
	$response=&LONCAPA::LWPReq::makerequest($home,$request,$transname,\%perlvar,'',1);
	}
if ($response->is_error()) {	if ($response->is_error()) {
unlink($transname);	unlink($transname);
my $message=$response->status_line;	my $message=$response->status_line;
Line 3354 sub repcopy {	Line 3664 sub repcopy {
} else {	} else {
if ($remoteurl!~/\.meta$/) {	if ($remoteurl!~/\.meta$/) {
my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');	my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');
my $mresponse=$ua->request($mrequest,$filename.'.meta');	my $mresponse;
	if ($remoteurl =~ m{/raw/}) {
	$mresponse = &LONCAPA::LWPReq::makerequest($home,$mrequest,$filename.'.meta',\%perlvar,'',0,1);
	} else {
	$mresponse = &LONCAPA::LWPReq::makerequest($home,$mrequest,$filename.'.meta',\%perlvar,'',1);
	}
if ($mresponse->is_error()) {	if ($mresponse->is_error()) {
unlink($filename.'.meta');	unlink($filename.'.meta');
&logthis(	&logthis(
Line 3384 sub unsubscribe {	Line 3699 sub unsubscribe {
} elsif (grep { $_ eq $home } &current_machine_ids()) {	} elsif (grep { $_ eq $home } &current_machine_ids()) {
$answer = 'home';	$answer = 'home';
} else {	} else {
$answer = reply("unsub:$fname",$home);	my $defdom = $perlvar{'lonDefDomain'};
	if (&will_trust('content',$defdom,$udom)) {
	$answer = reply("unsub:$fname",$home);
	} else {
	$answer = 'untrusted';
	}
}	}
return $answer;	return $answer;
}	}
Line 3427 sub absolute_url {	Line 3747 sub absolute_url {
if ($alias eq $host_name) {	if ($alias eq $host_name) {
my $lonhost = $perlvar{'lonHostID'};	my $lonhost = $perlvar{'lonHostID'};
my $hostname = &hostname($lonhost);	my $hostname = &hostname($lonhost);
my $lcproto;	my $lcproto;
if (($keep_proto) \|\| ($hostname eq '')) {	if (($keep_proto) \|\| ($hostname eq '')) {
$lcproto = $protocol;	$lcproto = $protocol;
} else {	} else {
Line 3439 sub absolute_url {	Line 3759 sub absolute_url {
return $lcproto.$hostname;	return $lcproto.$hostname;
}	}
}	}
}	}
return $protocol.$host_name;	return $protocol.$host_name;
}	}

Line 3463 sub ssi {	Line 3783 sub ssi {
&Apache::lonenc::check_encrypt(\$fn);	&Apache::lonenc::check_encrypt(\$fn);
if (%form) {	if (%form) {
$request=new HTTP::Request('POST',$host.$fn);	$request=new HTTP::Request('POST',$host.$fn);
$request->content(join('&',map {	$request->content(join('&',map {
my $name = escape($_);	my $name = escape($_);
"$name=" . ( ref($form{$_}) eq 'ARRAY'	"$name=" . ( ref($form{$_}) eq 'ARRAY'
? join("&$name=", map {escape($_) } @{$form{$_}})	? join("&$name=", map {escape($_) } @{$form{$_}})
: &escape($form{$_}) );	: &escape($form{$_}) );
} keys(%form)));	} keys(%form)));
} else {	} else {
$request=new HTTP::Request('GET',$host.$fn);	$request=new HTTP::Request('GET',$host.$fn);
}	}

$request->header(Cookie => $ENV{'HTTP_COOKIE'});	$request->header(Cookie => $ENV{'HTTP_COOKIE'});
	my $lonhost = $perlvar{'lonHostID'};
	my $islocal;
if (($env{'request.course.id'}) &&	if (($env{'request.course.id'}) &&
($form{'grade_courseid'} eq $env{'request.course.id'}) &&	($form{'grade_courseid'} eq $env{'request.course.id'}) &&
($form{'grade_username'} ne '') && ($form{'grade_domain'} ne '') &&	($form{'grade_username'} ne '') && ($form{'grade_domain'} ne '') &&
($form{'grade_symb'} ne '') &&	($form{'grade_symb'} ne '') &&
(&Apache::lonnet::allowed('mgr',$env{'request.course.id'}.	(&allowed('mgr',$env{'request.course.id'}.
($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:'')))) {	($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:'')))) {
if (LWP::UserAgent->VERSION >= 5.834) {	$islocal = 1;
my $ua=new LWP::UserAgent;
$ua->local_address('127.0.0.1');
$response = $ua->request($request);
} else {
{
require LWP::Protocol::http;
local @LWP::Protocol::http::EXTRA_SOCK_OPTS = (LocalAddr => '127.0.0.1');
my $ua=new LWP::UserAgent;
$response = $ua->request($request);
@LWP::Protocol::http::EXTRA_SOCK_OPTS = ();
}
}
} else {
my $ua=new LWP::UserAgent;
$response = $ua->request($request);
}	}
	$response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,
	'','','',$islocal);

if (wantarray) {	if (wantarray) {
return ($response->content, $response);	return ($response->content, $response);
} else {	} else {
Line 3507 sub ssi {	Line 3816 sub ssi {

sub externalssi {	sub externalssi {
my ($url)=@_;	my ($url)=@_;
my $ua=new LWP::UserAgent;
my $request=new HTTP::Request('GET',$url);	my $request=new HTTP::Request('GET',$url);
my $response=$ua->request($request);	my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar);
if (wantarray) {	if (wantarray) {
return ($response->content, $response);	return ($response->content, $response);
} else {	} else {
Line 3517 sub externalssi {	Line 3825 sub externalssi {
}	}
}	}

# If the local copy of a replicated resource is outdated, trigger a
# connection from the homeserver to flush the delayed queue. If no update	# If the local copy of a replicated resource is outdated, trigger a
	# connection from the homeserver to flush the delayed queue. If no update
# happens, remove local copies of outdated resource (and corresponding	# happens, remove local copies of outdated resource (and corresponding
# metadata file).	# metadata file).

Line 3538 sub remove_stale_resfile {	Line 3847 sub remove_stale_resfile {
if ($hostname) {	if ($hostname) {
my $protocol = $protocol{$homeserver};	my $protocol = $protocol{$homeserver};
$protocol = 'http' if ($protocol ne 'https');	$protocol = 'http' if ($protocol ne 'https');
my $uri = $protocol.'://'.$hostname.'/raw/'.&declutter($url);	my $uri = &declutter($url);
my $ua=new LWP::UserAgent;	my $request=new HTTP::Request('HEAD',$protocol.'://'.$hostname.'/raw/'.$uri);
$ua->timeout(5);	my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,5,0,1);
my $request=new HTTP::Request('HEAD',$uri);
my $response=$ua->request($request);
if ($response->is_success()) {	if ($response->is_success()) {
my $remmodtime = &HTTP::Date::str2time( $response->header('Last-modified') );	my $remmodtime = &HTTP::Date::str2time( $response->header('Last-modified') );
my $locmodtime = (stat($fname))[9];	my $locmodtime = (stat($fname))[9];
Line 3605 sub allowuploaded {	Line 3912 sub allowuploaded {
#	#
# Determine if the current user should be able to edit a particular resource,	# Determine if the current user should be able to edit a particular resource,
# when viewing in course context.	# when viewing in course context.
# (a) When viewing resource used to determine if "Edit" item is included in	# (a) When viewing resource used to determine if "Edit" item is included in
# Functions.	# Functions.
# (b) When displaying folder contents in course editor, used to determine if	# (b) When displaying folder contents in course editor, used to determine if
# "Edit" link will be displayed alongside resource.	# "Edit" link will be displayed alongside resource.
Line 3613 sub allowuploaded {	Line 3920 sub allowuploaded {
# input: six args -- filename (decluttered), course number, course domain,	# input: six args -- filename (decluttered), course number, course domain,
# url, symb (if registered) and group (if this is a group	# url, symb (if registered) and group (if this is a group
# item -- e.g., bulletin board, group page etc.).	# item -- e.g., bulletin board, group page etc.).
# output: array of five scalars --	# output: array of five scalars --
# $cfile -- url for file editing if editable on current server	# $cfile -- url for file editing if editable on current server
# $home -- homeserver of resource (i.e., for author if published,	# $home -- homeserver of resource (i.e., for author if published,
# or course if uploaded.).	# or course if uploaded.).
# $switchserver -- 1 if server switch will be needed.	# $switchserver -- 1 if server switch will be needed.
# $forceedit -- 1 if icon/link should be to go to edit mode	# $forceedit -- 1 if icon/link should be to go to edit mode
# $forceview -- 1 if icon/link should be to go to view mode	# $forceview -- 1 if icon/link should be to go to view mode
#	#

Line 3644 sub can_edit_resource {	Line 3951 sub can_edit_resource {
}	}
}	}

	#
	# For /adm/viewcoauthors can only edit if author or co-author who is manager.
	#

	if (($resurl eq '/adm/viewcoauthors') && ($cnum ne '') && ($cdom ne '')) {
	if (((&allowed('cca',"$cdom/$cnum")) \|\|
	(&allowed('caa',"$cdom/$cnum"))) \|\|
	((&allowed('vca',"$cdom/$cnum") \|\|
	&allowed('vaa',"$cdom/$cnum")) &&
	($env{"environment.internal.manager./$cdom/$cnum"}))) {
	$home = $env{'user.home'};
	$cfile = $resurl;
	if ($env{'form.forceedit'}) {
	$forceview = 1;
	} else {
	$forceedit = 1;
	}
	return ($cfile,$home,$switchserver,$forceedit,$forceview);
	} else {
	return;
	}
	}

if ($env{'request.course.id'}) {	if ($env{'request.course.id'}) {
my $crsedit = &Apache::lonnet::allowed('mdc',$env{'request.course.id'});	my $crsedit = &allowed('mdc',$env{'request.course.id'});
if ($group ne '') {	if ($group ne '') {
# if this is a group homepage or group bulletin board, check group privs	# if this is a group homepage or group bulletin board, check group privs
my $allowed = 0;	my $allowed = 0;
Line 3674 sub can_edit_resource {	Line 4004 sub can_edit_resource {
}	}
} else {	} else {
if ($resurl =~ m{^/?adm/viewclasslist$}) {	if ($resurl =~ m{^/?adm/viewclasslist$}) {
unless (&Apache::lonnet::allowed('opa',$env{'request.course.id'})) {	unless (&allowed('opa',$env{'request.course.id'})) {
return;	return;
}	}
} elsif (!$crsedit) {	} elsif (!$crsedit) {
	if ($env{'request.role'} =~ m{^st\./$cdom/$cnum}) {
#	#
# No edit allowed where CC has switched to student role.	# No edit allowed where CC has switched to student role.
#	#
return;	return;
	} elsif (($resurl !~ m{^/res/$match_domain/$match_username/}) \|\|
	($resurl =~ m{^/res/lib/templates/})) {
	return;
	}
}	}
}	}
}	}
Line 3758 sub can_edit_resource {	Line 4093 sub can_edit_resource {
}	}
} elsif ($resurl eq '/res/lib/templates/simpleproblem.problem/smpedit') {	} elsif ($resurl eq '/res/lib/templates/simpleproblem.problem/smpedit') {
my $template = '/res/lib/templates/simpleproblem.problem';	my $template = '/res/lib/templates/simpleproblem.problem';
if (&is_on_map($template)) {	if (&is_on_map($template)) {
$incourse = 1;	$incourse = 1;
$forceview = 1;	$forceview = 1;
$cfile = $template;	$cfile = $template;
Line 3818 sub can_edit_resource {	Line 4153 sub can_edit_resource {
$cfile=$file;	$cfile=$file;
}	}
}	}
if (($cfile ne '') && (!$incourse \|\| $uploaded) &&	if (($cfile ne '') && (!$incourse \|\| $uploaded) &&
(($home ne '') && ($home ne 'no_host'))) {	(($home ne '') && ($home ne 'no_host'))) {
my @ids=&current_machine_ids();	my @ids=&current_machine_ids();
unless (grep(/^\Q$home\E$/,@ids)) {	unless (grep(/^\Q$home\E$/,@ids)) {
Line 3845 sub in_course {	Line 4180 sub in_course {
if ($hideprivileged) {	if ($hideprivileged) {
my $skipuser;	my $skipuser;
my %coursehash = &coursedescription($cdom.'_'.$cnum);	my %coursehash = &coursedescription($cdom.'_'.$cnum);
my @possdoms = ($cdom);	my @possdoms = ($cdom);
if ($coursehash{'checkforpriv'}) {	if ($coursehash{'checkforpriv'}) {
push(@possdoms,split(/,/,$coursehash{'checkforpriv'}));	push(@possdoms,split(/,/,$coursehash{'checkforpriv'}));
}	}
if (&privileged($uname,$udom,\@possdoms)) {	if (&privileged($uname,$udom,\@possdoms)) {
$skipuser = 1;	$skipuser = 1;
Line 4041 sub clean_filename {	Line 4376 sub clean_filename {
# Replace all .\d. sequences with _\d. so they no longer look like version	# Replace all .\d. sequences with _\d. so they no longer look like version
# numbers	# numbers
$fname=~s/\.(\d+)(?=\.)/_$1/g;	$fname=~s/\.(\d+)(?=\.)/_$1/g;
# Replace three or more adjacent underscores with one for consistency	# Replace three or more adjacent underscores with one for consistency
# with loncfile::filename_check() so complete url can be extracted by	# with loncfile::filename_check() so complete url can be extracted by
# lonnet::decode_symb()	# lonnet::decode_symb()
$fname=~s/_{3,}/_/g;	$fname=~s/_{3,}/_/g;
Line 4090 sub resizeImage {	Line 4425 sub resizeImage {
# input: $formname - the contents of the file are in $env{"form.$formname"}	# input: $formname - the contents of the file are in $env{"form.$formname"}
# the desired filename is in $env{"form.$formname.filename"}	# the desired filename is in $env{"form.$formname.filename"}
# $context - possible values: coursedoc, existingfile, overwrite,	# $context - possible values: coursedoc, existingfile, overwrite,
# canceloverwrite, scantron, toollogo or ''.	# canceloverwrite, scantron, toollogo or ''.
# if 'coursedoc': upload to the current course	# if 'coursedoc': upload to the current course
# if 'existingfile': write file to tmp/overwrites directory	# if 'existingfile': write file to tmp/overwrites directory
# if 'canceloverwrite': delete file written to tmp/overwrites directory	# if 'canceloverwrite': delete file written to tmp/overwrites directory
Line 4098 sub resizeImage {	Line 4433 sub resizeImage {
# $subdir - directory in userfile to store the file into	# $subdir - directory in userfile to store the file into
# $parser - instruction to parse file for objects ($parser = parse) or	# $parser - instruction to parse file for objects ($parser = parse) or
# if context is 'scantron', $parser is hashref of csv column mapping	# if context is 'scantron', $parser is hashref of csv column mapping
# (e.g.,{ PaperID => 0, LastName => 1, FirstName => 2, ID => 3,	# (e.g.,{ PaperID => 0, LastName => 1, FirstName => 2, ID => 3,
# Section => 4, CODE => 5, FirstQuestion => 9 }).	# Section => 4, CODE => 5, FirstQuestion => 9 }).
# $allfiles - reference to hash for embedded objects	# $allfiles - reference to hash for embedded objects
# $codebase - reference to hash for codebase of java objects	# $codebase - reference to hash for codebase of java objects
Line 4148 sub userfileupload {	Line 4483 sub userfileupload {
} else {	} else {
$docudom = $env{'user.domain'};	$docudom = $env{'user.domain'};
}	}
if ($destuname =~ /^$match_username$/) {	if ($destuname =~ /^$match_username$/) {
$docuname = $destuname;	$docuname = $destuname;
} else {	} else {
$docuname = $env{'user.name'};	$docuname = $env{'user.name'};
Line 4313 sub finishuserfileupload {	Line 4648 sub finishuserfileupload {
if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {	if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {
my $input = $filepath.'/'.$file;	my $input = $filepath.'/'.$file;
my $output = $filepath.'/'.'tn-'.$file;	my $output = $filepath.'/'.'tn-'.$file;
my $makethumb;	my $makethumb;
my $thumbsize = $thumbwidth.'x'.$thumbheight;	my $thumbsize = $thumbwidth.'x'.$thumbheight;
if ($context eq 'toollogo') {	if ($context eq 'toollogo') {
my ($fullwidth,$fullheight) = &check_dimensions($input);	my ($fullwidth,$fullheight) = &check_dimensions($input);
Line 4329 sub finishuserfileupload {	Line 4664 sub finishuserfileupload {
my @args = ('convert','-sample',$thumbsize,$input,$output);	my @args = ('convert','-sample',$thumbsize,$input,$output);
system({$args[0]} @args);	system({$args[0]} @args);
if (-e $filepath.'/'.'tn-'.$file) {	if (-e $filepath.'/'.'tn-'.$file) {
$fetchthumb = 1;	$fetchthumb = 1;
}	}
}	}
}	}
Line 4387 sub extract_embedded_items {	Line 4722 sub extract_embedded_items {
}	}
if (lc($tagname) eq 'a') {	if (lc($tagname) eq 'a') {
unless (($attr->{'href'} =~ /^#/) \|\| ($attr->{'href'} eq '')) {	unless (($attr->{'href'} =~ /^#/) \|\| ($attr->{'href'} eq '')) {
&add_filetype($allfiles,$attr->{'href'},'href');	&add_filetype($allfiles,$attr->{'href'},'href');
}	}
}	}
if (lc($tagname) eq 'script') {	if (lc($tagname) eq 'script') {
Line 4592 sub bubblesheet_converter {	Line 4927 sub bubblesheet_converter {
($fullpath =~ m{^\Q$perlvar{'lonDocRoot'}/userfiles/$cdom/\E$match_courseid/scantron_orig}) &&	($fullpath =~ m{^\Q$perlvar{'lonDocRoot'}/userfiles/$cdom/\E$match_courseid/scantron_orig}) &&
(-e $fullpath) && (ref($config) eq 'HASH') && ($format ne '')) {	(-e $fullpath) && (ref($config) eq 'HASH') && ($format ne '')) {
my (%csvcols,%csvoptions);	my (%csvcols,%csvoptions);
if (ref($config->{'fields'}) eq 'HASH') {	if (ref($config->{'fields'}) eq 'HASH') {
%csvcols = %{$config->{'fields'}};	%csvcols = %{$config->{'fields'}};
}	}
if (ref($config->{'options'}) eq 'HASH') {	if (ref($config->{'options'}) eq 'HASH') {
Line 4956 sub flushcourselogs {	Line 5291 sub flushcourselogs {
# That said there is a lot of noise in the data being stored.	# That said there is a lot of noise in the data being stored.
# So counts for prtspool/ and adm/ etc. are recorded.	# So counts for prtspool/ and adm/ etc. are recorded.
#	#
# A review of which items ending '___count' are written to %accesshash should likely be	# A review of which items ending '___count' are written to %accesshash should likely be
# made before deciding whether to set these to 'course.' instead of 'request.'	# made before deciding whether to set these to 'course.' instead of 'request.'
#	#
# Under the current scheme each user receives a nohist_accesscount.db file listing	# Under the current scheme each user receives a nohist_accesscount.db file listing
# accesses for things which are not published resources, regardless of course, and	# accesses for things which are not published resources, regardless of course, and
# there is not a nohist_accesscount.db file in a course, which might log accesses from	# there is not a nohist_accesscount.db file in a course, which might log accesses from
# anyone in the course for things which are not published resources.	# anyone in the course for things which are not published resources.
Line 4993 sub flushcourselogs {	Line 5328 sub flushcourselogs {
foreach my $entry (keys(%userrolehash)) {	foreach my $entry (keys(%userrolehash)) {
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 (&put('nohist_userroles',
{ $role.':'.$uname.':'.$udom.':'.$rsec => $userrolehash{$entry} },	{ $role.':'.$uname.':'.$udom.':'.$rsec => $userrolehash{$entry} },
$rudom,$runame) eq 'ok') {	$rudom,$runame) eq 'ok') {
delete $userrolehash{$entry};	delete $userrolehash{$entry};
Line 5015 sub flushcourselogs {	Line 5350 sub flushcourselogs {
delete $domainrolehash{$entry};	delete $domainrolehash{$entry};
}	}
foreach my $dom (keys(%domrolebuffer)) {	foreach my $dom (keys(%domrolebuffer)) {
my %servers;	my %servers;
if (defined(&domain($dom,'primary'))) {	if (defined(&domain($dom,'primary'))) {
my $primary=&domain($dom,'primary');	my $primary=&domain($dom,'primary');
my $hostname=&hostname($primary);	my $hostname=&hostname($primary);
$servers{$primary} = $hostname;	$servers{$primary} = $hostname;
} else {	} else {
%servers = &get_servers($dom,'library');	%servers = &get_servers($dom,'library');
}	}
foreach my $tryserver (keys(%servers)) {	foreach my $tryserver (keys(%servers)) {
if (&reply('domroleput:'.$dom.':'.	if (&reply('domroleput:'.$dom.':'.
$domrolebuffer{$dom},$tryserver) eq 'ok') {	$domrolebuffer{$dom},$tryserver) eq 'ok') {
last;	last;
} else {	} else {
&logthis('Put of domain roles failed for '.$dom.' and '.$tryserver);	&logthis('Put of domain roles failed for '.$dom.' and '.$tryserver);
}	}
}	}
Line 5160 sub userrolelog {	Line 5495 sub userrolelog {
}	}

sub courserolelog {	sub courserolelog {
my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,$context)=@_;	my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,
	$context,$othdomby,$requester)=@_;
if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) {	if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) {
my $cdom = $1;	my $cdom = $1;
my $cnum = $2;	my $cnum = $2;
Line 5173 sub courserolelog {	Line 5509 sub courserolelog {
selfenroll => $selfenroll,	selfenroll => $selfenroll,
context => $context,	context => $context,
);	);
	if ($othdomby) {
	if ($othdomby eq 'othdombydc') {
	$storehash{'approval'} = 'domain';
	} elsif ($othdomby eq 'othdombyuser') {
	$storehash{'approval'} = 'user';
	}
	if ($requester ne '') {
	$storehash{'requester'} = $requester;
	}
	}
if ($trole eq 'gr') {	if ($trole eq 'gr') {
$namespace = 'groupslog';	$namespace = 'groupslog';
$storehash{'group'} = $sec;	$storehash{'group'} = $sec;
} else {	} else {
$storehash{'section'} = $sec;	$storehash{'section'} = $sec;
	my ($curruserdomstr,$newuserdomstr);
	if (exists($env{'course.'.$cdom.'_'.$cnum.'.internal.userdomains'})) {
	$curruserdomstr = $env{'course.'.$env{'request.course.id'}.'.internal.userdomains'};
	} else {
	my %courseinfo = &coursedescription($cdom.'/'.$cnum);
	$curruserdomstr = $courseinfo{'internal.userdomains'};
	}
	if ($curruserdomstr ne '') {
	my @udoms = split(/,/,$curruserdomstr);
	unless (grep(/^\Q$domain\E/,@udoms)) {
	push(@udoms,$domain);
	$newuserdomstr = join(',',sort(@udoms));
	}
	} else {
	$newuserdomstr = $domain;
	}
	if ($newuserdomstr ne '') {
	my $putresult = &put('environment',{ 'internal.userdomains' => $newuserdomstr },
	$cdom,$cnum);
	if ($putresult eq 'ok') {
	unless (($selfenroll) \|\| ($context eq 'selfenroll')) {
	if (($context eq 'createcourse') \|\| ($context eq 'requestcourses') \|\|
	($context eq 'automated') \|\| ($context eq 'domain')) {
	$env{'course.'.$cdom.'_'.$cnum.'.internal.userdomains'} = $newuserdomstr;
	} elsif ($env{'request.course.id'} eq $cdom.'_'.$cnum) {
	&appenv({'course.'.$cdom.'_'.$cnum.'.internal.userdomains' => $newuserdomstr});
	}
	}
	}
	}
}	}
&write_log('course',$namespace,\%storehash,$delflag,$username,	&write_log('course',$namespace,\%storehash,$delflag,$username,
$domain,$cnum,$cdom);	$domain,$cnum,$cdom);
Line 5189 sub courserolelog {	Line 5565 sub courserolelog {
}	}

sub domainrolelog {	sub domainrolelog {
my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_;	my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,
	$context,$othdomby,$requester)=@_;
if ($area =~ m{^/($match_domain)/$}) {	if ($area =~ m{^/($match_domain)/$}) {
my $cdom = $1;	my $cdom = $1;
my $domconfiguser = &Apache::lonnet::get_domainconfiguser($cdom);	my $domconfiguser = &get_domainconfiguser($cdom);
my $namespace = 'rolelog';	my $namespace = 'rolelog';
my %storehash = (	my %storehash = (
role => $trole,	role => $trole,
Line 5200 sub domainrolelog {	Line 5577 sub domainrolelog {
end => $tend,	end => $tend,
context => $context,	context => $context,
);	);
	if ($othdomby) {
	if ($othdomby eq 'othdombydc') {
	$storehash{'approval'} = 'domain';
	} elsif ($othdomby eq 'othdombyuser') {
	$storehash{'approval'} = 'user';
	}
	if ($requester ne '') {
	$storehash{'requester'} = $requester;
	}
	}
&write_log('domain',$namespace,\%storehash,$delflag,$username,	&write_log('domain',$namespace,\%storehash,$delflag,$username,
$domain,$domconfiguser,$cdom);	$domain,$domconfiguser,$cdom);
}	}
Line 5208 sub domainrolelog {	Line 5595 sub domainrolelog {
}	}

sub coauthorrolelog {	sub coauthorrolelog {
my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_;	my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,
	$context,$othdomby,$requester)=@_;
if ($area =~ m{^/($match_domain)/($match_username)$}) {	if ($area =~ m{^/($match_domain)/($match_username)$}) {
my $audom = $1;	my $audom = $1;
my $auname = $2;	my $auname = $2;
Line 5219 sub coauthorrolelog {	Line 5607 sub coauthorrolelog {
end => $tend,	end => $tend,
context => $context,	context => $context,
);	);
	if ($othdomby) {
	if ($othdomby eq 'othdombydc') {
	$storehash{'approval'} = 'domain';
	} elsif ($othdomby eq 'othdombyuser') {
	$storehash{'approval'} = 'user';
	}
	if ($requester ne '') {
	$storehash{'requester'} = $requester;
	}
	}
&write_log('author',$namespace,\%storehash,$delflag,$username,	&write_log('author',$namespace,\%storehash,$delflag,$username,
$domain,$auname,$audom);	$domain,$auname,$audom);
}	}
Line 5359 sub get_my_roles {	Line 5757 sub get_my_roles {
} else {	} else {
my $possdoms = [$domain];	my $possdoms = [$domain];
if (ref($roledoms) eq 'ARRAY') {	if (ref($roledoms) eq 'ARRAY') {
push(@{$possdoms},@{$roledoms});	push(@{$possdoms},@{$roledoms});
}	}
if (&privileged($username,$domain,$possdoms,\@privroles)) {	if (&privileged($username,$domain,$possdoms,\@privroles)) {
if (!$nothide{$username.':'.$domain}) {	if (!$nothide{$username.':'.$domain}) {
Line 5423 sub get_my_adhocroles {	Line 5821 sub get_my_adhocroles {
} elsif ($cid =~ /^($match_domain)_($match_courseid)$/) {	} elsif ($cid =~ /^($match_domain)_($match_courseid)$/) {
$cdom = $1;	$cdom = $1;
$cnum = $2;	$cnum = $2;
%info = &Apache::lonnet::get('environment',['internal.coursecode'],	%info = &get('environment',['internal.coursecode'],
$cdom,$cnum);	$cdom,$cnum);
}	}
if (($info{'internal.coursecode'} ne '') && ($checkreg)) {	if (($info{'internal.coursecode'} ne '') && ($checkreg)) {
my $user = $env{'user.name'}.':'.$env{'user.domain'};	my $user = $env{'user.name'}.':'.$env{'user.domain'};
Line 5656 sub courseiddump {	Line 6054 sub courseiddump {
if (($domfilter eq '') \|\|	if (($domfilter eq '') \|\|
(&host_domain($tryserver) eq $domfilter)) {	(&host_domain($tryserver) eq $domfilter)) {
my $rep;	my $rep;
if (grep { $_ eq $tryserver } &current_machine_ids()) {	if (grep { $_ eq $tryserver } current_machine_ids()) {
$rep = &LONCAPA::Lond::dump_course_id_handler(	$rep = LONCAPA::Lond::dump_course_id_handler(
join(":", (&host_domain($tryserver), $sincefilter,	join(":", (&host_domain($tryserver), $sincefilter,
&escape($descfilter), &escape($instcodefilter),	&escape($descfilter), &escape($instcodefilter),
&escape($ownerfilter), &escape($coursefilter),	&escape($ownerfilter), &escape($coursefilter),
&escape($typefilter), &escape($regexp_ok),	&escape($typefilter), &escape($regexp_ok),
$as_hash, &escape($selfenrollonly),	$as_hash, &escape($selfenrollonly),
&escape($catfilter), $showhidden, $caller,	&escape($catfilter), $showhidden, $caller,
&escape($cloner), &escape($cc_clone), $cloneonly,	&escape($cloner), &escape($cc_clone), $cloneonly,
&escape($createdbefore), &escape($createdafter),	&escape($createdbefore), &escape($createdafter),
&escape($creationcontext),$domcloner,$hasuniquecode,	&escape($creationcontext),$domcloner,$hasuniquecode,
$reqcrsdom,&escape($reqinstcode))));	$reqcrsdom,&escape($reqinstcode))));
} else {	} else {
Line 5681 sub courseiddump {	Line 6079 sub courseiddump {
&escape($creationcontext).':'.$domcloner.':'.$hasuniquecode.	&escape($creationcontext).':'.$domcloner.':'.$hasuniquecode.
':'.$reqcrsdom.':'.&escape($reqinstcode),$tryserver);	':'.$reqcrsdom.':'.&escape($reqinstcode),$tryserver);
}	}

my @pairs=split(/\&/,$rep);	my @pairs=split(/\&/,$rep);
foreach my $item (@pairs) {	foreach my $item (@pairs) {
my ($key,$value)=split(/\=/,$item,2);	my ($key,$value)=split(/\=/,$item,2);
Line 5751 sub extract_lastaccess {	Line 6149 sub extract_lastaccess {

sub dcmailput {	sub dcmailput {
my ($domain,$msgid,$message,$server)=@_;	my ($domain,$msgid,$message,$server)=@_;
my $status = &Apache::lonnet::critical(	my $status = &critical(
'dcmailput:'.$domain.':'.&escape($msgid).'='.	'dcmailput:'.$domain.':'.&escape($msgid).'='.
&escape($message),$server);	&escape($message),$server);
return $status;	return $status;
Line 5908 sub set_first_access {	Line 6306 sub set_first_access {
}	}
}	}

sub checkout {
my ($symb,$tuname,$tudom,$tcrsid)=@_;
my $now=time;
my $lonhost=$perlvar{'lonHostID'};
my $ip = &get_requestor_ip();
my $infostr=&escape(
'CHECKOUTTOKEN&'.
$tuname.'&'.
$tudom.'&'.
$tcrsid.'&'.
$symb.'&'.
$now.'&'.$ip);
my $token=&reply('tmpput:'.$infostr,$lonhost);
if ($token=~/^error\:/) {
&logthis("<font color=\"blue\">WARNING: ".
"Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
"</font>");
return '';
}

$token=~s/^(\d+)\_.\_(\d+)$/$1\$2\*$lonhost/;
$token=~tr/a-z/A-Z/;

my %infohash=('resource.0.outtoken' => $token,
'resource.0.checkouttime' => $now,
'resource.0.outremote' => $ip);

unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
return '';
} else {
&logthis("<font color=\"blue\">WARNING: ".
"Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
"</font>");
}

if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
&escape('Checkout '.$infostr.' - '.
$token)) ne 'ok') {
return '';
} else {
&logthis("<font color=\"blue\">WARNING: ".
"Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
"</font>");
}
return $token;
}

# ------------------------------------------------------------ Check in an item

sub checkin {
my $token=shift;
my $now=time;
my ($ta,$tb,$lonhost)=split(/\*/,$token);
$lonhost=~tr/A-Z/a-z/;
my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb;
$dtoken=~s/\W/\_/g;
my $ip = &get_requestor_ip();
my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));

unless (($tuname) && ($tudom)) {
&logthis('Check in '.$token.' ('.$dtoken.') failed');
return '';
}

unless (&allowed('mgr',$tcrsid)) {
&logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '.
$env{'user.name'}.' - '.$env{'user.domain'});
return '';
}

my %infohash=('resource.0.intoken' => $token,
'resource.0.checkintime' => $now,
'resource.0.inremote' => $ip);

unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
return '';
}

if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
&escape('Checkin - '.$token)) ne 'ok') {
return '';
}

return ($symb,$tuname,$tudom,$tcrsid);
}

# --------------------------------------------- Set Expire Date for Spreadsheet	# --------------------------------------------- Set Expire Date for Spreadsheet

sub expirespread {	sub expirespread {
Line 6588 sub privileged {	Line 6899 sub privileged {
my $now = time;	my $now = time;
my $roles;	my $roles;
if (ref($possroles) eq 'ARRAY') {	if (ref($possroles) eq 'ARRAY') {
$roles = $possroles;	$roles = $possroles;
} else {	} else {
$roles = ['dc','su'];	$roles = ['dc','su'];
}	}
Line 6615 sub privileged {	Line 6926 sub privileged {
for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys(%rolesdump)}) {	for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys(%rolesdump)}) {
my ($trole, $tend, $tstart) = split(/_/, $role);	my ($trole, $tend, $tstart) = split(/_/, $role);
if (grep(/^\Q$trole\E$/,@{$roles})) {	if (grep(/^\Q$trole\E$/,@{$roles})) {
return 1 unless ($tend && $tend < $now)	return 1 unless ($tend && $tend < $now)
or ($tstart && $tstart > $now);	or ($tstart && $tstart > $now);
}	}
}	}
Line 6653 sub privileged_by_domain {	Line 6964 sub privileged_by_domain {
my ($trole,$uname,$udom,$rest) = split(/:/,$item,4);	my ($trole,$uname,$udom,$rest) = split(/:/,$item,4);
my ($end,$start) = split(/:/,$dompersonnel{$server}{$item});	my ($end,$start) = split(/:/,$dompersonnel{$server}{$item});
next if ($end && $end < $now);	next if ($end && $end < $now);
$privileged{$dom}{$trole}{$uname.':'.$udom} =	$privileged{$dom}{$trole}{$uname.':'.$udom} =
$dompersonnel{$server}{$item};	$dompersonnel{$server}{$item};
}	}
}	}
Line 6686 sub rolesinit {	Line 6997 sub rolesinit {
my %firstaccess = &dump('firstaccesstimes', $domain, $username);	my %firstaccess = &dump('firstaccesstimes', $domain, $username);
my %timerinterval = &dump('timerinterval', $domain, $username);	my %timerinterval = &dump('timerinterval', $domain, $username);
my (%coursetimerstarts, %firstaccchk, %firstaccenv, %coursetimerintervals,	my (%coursetimerstarts, %firstaccchk, %firstaccenv, %coursetimerintervals,
%timerintchk, %timerintenv);	%timerintchk, %timerintenv, %coauthorenv);

foreach my $key (keys(%firstaccess)) {	foreach my $key (keys(%firstaccess)) {
my ($cid, $rest) = split(/\0/, $key);	my ($cid, $rest) = split(/\0/, $key);
Line 6700 sub rolesinit {	Line 7011 sub rolesinit {

my %allroles=();	my %allroles=();
my %allgroups=();	my %allgroups=();
	my %gotcoauconfig=();
	my %domdefaults=();

for my $area (grep { ! /^rolesdef_/ } keys(%rolesdump)) {	for my $area (grep { ! /^rolesdef_/ } keys(%rolesdump)) {
my $role = $rolesdump{$area};	my $role = $rolesdump{$area};
Line 6751 sub rolesinit {	Line 7064 sub rolesinit {
} else {	} else {
# Normal role, defined in roles.tab	# Normal role, defined in roles.tab
&standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);	&standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
	if (($trole eq 'ca') \|\| ($trole eq 'aa')) {
	(undef,my ($audom,$auname)) = split(/\//,$area);
	unless ($gotcoauconfig{$area}) {
	my @ca_settings = ('authoreditors','coauthorlist','coauthoroptin');
	my %info = &userenvironment($audom,$auname,@ca_settings);
	$gotcoauconfig{$area} = 1;
	foreach my $item (@ca_settings) {
	if (exists($info{$item})) {
	my $name = $item;
	if ($item eq 'authoreditors') {
	$name = 'editors';
	unless ($info{'authoreditors'}) {
	my %domdefs;
	if (ref($domdefaults{$audom}) eq 'HASH') {
	%domdefs = %{$domdefaults{$audom}};
	} else {
	%domdefs = &get_domain_defaults($audom);
	$domdefaults{$audom} = \%domdefs;
	}
	if ($domdefs{$name} ne '') {
	$info{'authoreditors'} = $domdefs{$name};
	} else {
	$info{'authoreditors'} = 'edit,xml';
	}
	}
	}
	$coauthorenv{"environment.internal.$name.$area"} = $info{$item};
	}
	}
	}
	}
}	}

my $cid = $tdomain.'_'.$trest;	my $cid = $tdomain.'_'.$trest;
Line 6779 sub rolesinit {	Line 7123 sub rolesinit {
$env{'user.adv'} = $userroles{'user.adv'};	$env{'user.adv'} = $userroles{'user.adv'};
$env{'user.rar'} = $userroles{'user.rar'};	$env{'user.rar'} = $userroles{'user.rar'};

return (\%userroles,\%firstaccenv,\%timerintenv);	return (\%userroles,\%firstaccenv,\%timerintenv,\%coauthorenv);
}	}

sub set_arearole {	sub set_arearole {
Line 7086 sub check_adhoc_privs {	Line 7430 sub check_adhoc_privs {
my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;	my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;
if ($sec) {	if ($sec) {
$cckey .= '/'.$sec;	$cckey .= '/'.$sec;
}	}
my $setprivs;	my $setprivs;
if ($env{$cckey}) {	if ($env{$cckey}) {
my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);	my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);
Line 7132 sub set_adhoc_privileges {	Line 7476 sub set_adhoc_privileges {
($caller eq 'tiny')) {	($caller eq 'tiny')) {
&appenv( {'request.role' => $spec,	&appenv( {'request.role' => $spec,
'request.role.domain' => $dcdom,	'request.role.domain' => $dcdom,
'request.course.sec' => $sec,	'request.course.sec' => $sec,
}	}
);	);
my $tadv=0;	my $tadv=0;
Line 7192 sub unserialize {	Line 7536 sub unserialize {
return {} if $rep =~ /^error/;	return {} if $rep =~ /^error/;

my %returnhash=();	my %returnhash=();
foreach my $item (split(/\&/,$rep)) {	foreach my $item (split(/\&/,$rep)) {
my ($key, $value) = split(/=/, $item, 2);	my ($key, $value) = split(/=/, $item, 2);
$key = unescape($key) unless $escapedkeys;	$key = unescape($key) unless $escapedkeys;
next if $key =~ /^error: 2 /;	next if $key =~ /^error: 2 /;
$returnhash{$key} = &thaw_unescape($value);	$returnhash{$key} = &thaw_unescape($value);
}	}
	#return %returnhash;
return \%returnhash;	return \%returnhash;
}	}

# see Lond::dump_with_regexp	# see Lond::dump_with_regexp
# if $escapedkeys hash keys won't get unescaped.	# if $escapedkeys hash keys won't get unescaped.
Line 7214 sub dump {	Line 7559 sub dump {
} else {	} else {
$regexp='.';	$regexp='.';
}	}
if (grep { $_ eq $uhome } &current_machine_ids()) {	if (grep { $_ eq $uhome } current_machine_ids()) {
# user is hosted on this machine	# user is hosted on this machine
my $reply = LONCAPA::Lond::dump_with_regexp(join(':', ($udomain,	my $reply = LONCAPA::Lond::dump_with_regexp(join(":", ($udomain,
$uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});	$uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});
return %{&unserialize($reply, $escapedkeys)};	return %{unserialize($reply, $escapedkeys)};
}	}
my $rep;	my $rep;
if ($encrypt) {	if ($encrypt) {
Line 7231 sub dump {	Line 7576 sub dump {
if (!($rep =~ /^error/ )) {	if (!($rep =~ /^error/ )) {
foreach my $item (@pairs) {	foreach my $item (@pairs) {
my ($key,$value)=split(/=/,$item,2);	my ($key,$value)=split(/=/,$item,2);
$key = &unescape($key) unless ($escapedkeys);	$key = unescape($key) unless $escapedkeys;
	#$key = &unescape($key);
next if ($key =~ /^error: 2 /);	next if ($key =~ /^error: 2 /);
$returnhash{$key}=&thaw_unescape($value);	$returnhash{$key}=&thaw_unescape($value);
}	}
Line 7275 sub currentdump {	Line 7621 sub currentdump {
my $rep;	my $rep;

if (grep { $_ eq $uhome } current_machine_ids()) {	if (grep { $_ eq $uhome } current_machine_ids()) {
$rep = LONCAPA::Lond::dump_profile_database(join(":", ($sdom, $sname,	$rep = LONCAPA::Lond::dump_profile_database(join(":", ($sdom, $sname,
$courseid)));	$courseid)));
} else {	} else {
$rep = reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome);	$rep = reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome);
Line 7285 sub currentdump {	Line 7631 sub currentdump {
#	#
my %returnhash=();	my %returnhash=();
#	#
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 = &dumpstore($courseid,$sdom,$sname,'.');	my @tmp = &dumpstore($courseid,$sdom,$sname,'.');
Line 7429 sub putstore {	Line 7775 sub putstore {
'&host='.&escape($perlvar{'lonHostID'}).	'&host='.&escape($perlvar{'lonHostID'}).
'&version='.$esc_v.	'&version='.$esc_v.
'&by='.&escape($env{'user.name'}.':'.$env{'user.domain'});	'&by='.&escape($env{'user.name'}.':'.$env{'user.domain'});
&Apache::lonnet::courselog($symb.':'.$uname.':'.$udomain.':PUTSTORE:'.$namevalue);	&courselog($symb.':'.$uname.':'.$udomain.':PUTSTORE:'.$namevalue);
}	}
if ($reply eq 'unknown_cmd') {	if ($reply eq 'unknown_cmd') {
# gfall back to way things use to be done	# gfall back to way things use to be done
Line 7541 sub tmpdel {	Line 7887 sub tmpdel {
return &reply("tmpdel:$token",$server);	return &reply("tmpdel:$token",$server);
}	}

# ------------------------------------------------------------ get_timebased_id	# ------------------------------------------------------------ get_timebased_id

sub get_timebased_id {	sub get_timebased_id {
my ($prefix,$keyid,$namespace,$cdom,$cnum,$idtype,$who,$locktries,	my ($prefix,$keyid,$namespace,$cdom,$cnum,$idtype,$who,$locktries,
$maxtries) = @_;	$maxtries) = @_;
my ($newid,$error,$dellock);	my ($newid,$error,$dellock);
unless (($prefix =~ /^\w+$/) && ($keyid =~ /^\w+$/) && ($namespace ne '')) {	unless (($prefix =~ /^\w+$/) && ($keyid =~ /^\w+$/) && ($namespace ne '')) {
return ('','ok','invalid call to get suffix');	return ('','ok','invalid call to get suffix');
}	}

Line 7561 sub get_timebased_id {	Line 7907 sub get_timebased_id {
if (!$maxtries) {	if (!$maxtries) {
$maxtries = 10;	$maxtries = 10;
}	}

if (($cdom eq '') \|\| ($cnum eq '')) {	if (($cdom eq '') \|\| ($cnum eq '')) {
if ($env{'request.course.id'}) {	if ($env{'request.course.id'}) {
$cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};	$cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
Line 7579 sub get_timebased_id {	Line 7925 sub get_timebased_id {
my $tries = 0;	my $tries = 0;

# attempt to get lock on nohist_$namespace file	# attempt to get lock on nohist_$namespace file
my $gotlock = &Apache::lonnet::newput('nohist_'.$namespace,$lockhash,$cdom,$cnum);	my $gotlock = &newput('nohist_'.$namespace,$lockhash,$cdom,$cnum);
while (($gotlock ne 'ok') && $tries <$locktries) {	while (($gotlock ne 'ok') && $tries <$locktries) {
$tries ++;	$tries ++;
sleep 1;	sleep 1;
$gotlock = &Apache::lonnet::newput('nohist_'.$namespace,$lockhash,$cdom,$cnum);	$gotlock = &newput('nohist_'.$namespace,$lockhash,$cdom,$cnum);
}	}

# attempt to get unique identifier, based on current timestamp	# attempt to get unique identifier, based on current timestamp
if ($gotlock eq 'ok') {	if ($gotlock eq 'ok') {
my %inuse = &Apache::lonnet::dump('nohist_'.$namespace,$cdom,$cnum,$prefix);	my %inuse = &dump('nohist_'.$namespace,$cdom,$cnum,$prefix);
my $id = time;	my $id = time;
$newid = $id;	$newid = $id;
if ($idtype eq 'addcode') {	if ($idtype eq 'addcode') {
Line 7609 sub get_timebased_id {	Line 7955 sub get_timebased_id {
my %new_item = (	my %new_item = (
$prefix."\0".$newid => $who,	$prefix."\0".$newid => $who,
);	);
my $putresult = &Apache::lonnet::put('nohist_'.$namespace,\%new_item,	my $putresult = &put('nohist_'.$namespace,\%new_item,
$cdom,$cnum);	$cdom,$cnum);
if ($putresult ne 'ok') {	if ($putresult ne 'ok') {
undef($newid);	undef($newid);
Line 7651 sub portfolio_access {	Line 7997 sub portfolio_access {
if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {	if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
my ($startblock,$endblock,$triggerblock,$by_ip,$blockdom) =	my ($startblock,$endblock,$triggerblock,$by_ip,$blockdom) =
&Apache::loncommon::blockcheck(\%setters,'port',$clientip,$unum,$udom);	&Apache::loncommon::blockcheck(\%setters,'port',$clientip,$unum,$udom);
if (($startblock && $endblock) \|\| ($by_ip)) {	if (($startblock && $endblock) \|\| ($by_ip)) {
return 'B';	return 'B';
}	}
} else {	} else {
my ($startblock,$endblock,$triggerblock,$by_ip,$blockdo) =	my ($startblock,$endblock,$triggerblock,$by_ip,$blockdom) =
&Apache::loncommon::blockcheck(\%setters,'port',$clientip);	&Apache::loncommon::blockcheck(\%setters,'port',$clientip);
if (($startblock && $endblock) \|\| ($by_ip)) {	if (($startblock && $endblock) \|\| ($by_ip)) {
return 'B';	return 'B';
Line 7671 sub portfolio_access {	Line 8017 sub portfolio_access {
}	}

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

if (!ref($access_hash)) {	if (!ref($access_hash)) {
my $current_perms = &get_portfile_permissions($udom,$unum);	my $current_perms = &get_portfile_permissions($udom,$unum);
Line 7680 sub get_portfolio_access {	Line 8026 sub get_portfolio_access {
$access_hash = $access_controls{$file_name};	$access_hash = $access_controls{$file_name};
}	}

my ($public,$guest,@domains,@users,@courses,@groups,@ips);	my $portaccess;
	if (ref($portaccess) eq 'SCALAR') {
	$portaccess = $$portaccessref;
	} else {
	$portaccess = &usertools_access($unum,$udom,'portaccess',undef,'tools');
	}

	my ($public,$guest,@domains,@users,@courses,@groups,@ips,@userips);
my $now = time;	my $now = time;
if (ref($access_hash) eq 'HASH') {	if (ref($access_hash) eq 'HASH') {
foreach my $key (keys(%{$access_hash})) {	foreach my $key (keys(%{$access_hash})) {
my ($num,$scope,$end,$start) = ($key =~ /^([^:]+):([a-z]+)_(\d)_?(\d)$/);	my ($num,$scope,$end,$start) = ($key =~ /^([^:]+):([a-z]+)_(\d)_?(\d)$/);
	next if (($scope ne 'ip') && ($portaccess == 0));
if ($start > $now) {	if ($start > $now) {
next;	next;
}	}
Line 7706 sub get_portfolio_access {	Line 8060 sub get_portfolio_access {
push(@groups,$key);	push(@groups,$key);
} elsif ($scope eq 'ip') {	} elsif ($scope eq 'ip') {
push(@ips,$key);	push(@ips,$key);
	} elsif ($scope eq 'userip') {
	push(@userips,$key);
}	}
}	}
if ($public) {	if ($public) {
Line 7716 sub get_portfolio_access {	Line 8072 sub get_portfolio_access {
if (ref($access_hash->{$ipkey}{'ip'}) eq 'ARRAY') {	if (ref($access_hash->{$ipkey}{'ip'}) eq 'ARRAY') {
if (&Apache::loncommon::check_ip_acc(join(',',@{$access_hash->{$ipkey}{'ip'}}),$clientip)) {	if (&Apache::loncommon::check_ip_acc(join(',',@{$access_hash->{$ipkey}{'ip'}}),$clientip)) {
$allowed = 1;	$allowed = 1;
	last;
	}
	}
	}
	if ($allowed) {
	return 'ok';
	}
	} elsif (@userips > 0) {
	my $allowed;
	foreach my $useripkey (@userips) {
	if (ref($access_hash->{$useripkey}{'ip'}) eq 'ARRAY') {
	if (&Apache::loncommon::check_ip_acc(join(',',@{$access_hash->{$useripkey}{'ip'}}),$clientip)) {
	$allowed = 1;
last;	last;
}	}
}	}
Line 7921 sub usertools_access {	Line 8290 sub usertools_access {
unofficial => 1,	unofficial => 1,
community => 1,	community => 1,
textbook => 1,	textbook => 1,
	placement => 1,
lti => 1,	lti => 1,
);	);
} elsif ($context eq 'requestauthor') {	} elsif ($context eq 'requestauthor') {
%tools = (	%tools = (
requestauthor => 1,	requestauthor => 1,
);	);
	} elsif ($context eq 'authordefaults') {
	%tools = (
	webdav => 1,
	);
} else {	} else {
%tools = (	%tools = (
aboutme => 1,	aboutme => 1,
blog => 1,	blog => 1,
webdav => 1,	webdav => 1,
portfolio => 1,	portfolio => 1,
	portaccess => 1,
timezone => 1,	timezone => 1,
);	);
}	}
Line 7949 sub usertools_access {	Line 8324 sub usertools_access {
return $env{'environment.canrequest.'.$tool};	return $env{'environment.canrequest.'.$tool};
} elsif ($context eq 'requestauthor') {	} elsif ($context eq 'requestauthor') {
return $env{'environment.canrequest.author'};	return $env{'environment.canrequest.author'};
	} elsif ($context eq 'authordefaults') {
	if ($tool eq 'webdav') {
	return $env{'environment.availabletools.'.$tool};
	}
} else {	} else {
return $env{'environment.availabletools.'.$tool};	return $env{'environment.availabletools.'.$tool};
}	}
Line 7958 sub usertools_access {	Line 8337 sub usertools_access {
my ($toolstatus,$inststatus,$envkey);	my ($toolstatus,$inststatus,$envkey);
if ($context eq 'requestauthor') {	if ($context eq 'requestauthor') {
$envkey = $context;	$envkey = $context;
	} elsif ($context eq 'authordefaults') {
	if ($tool eq 'webdav') {
	$envkey = 'tools.'.$tool;
	}
} else {	} else {
$envkey = $context.'.'.$tool;	$envkey = $context.'.'.$tool;
}	}
Line 8058 sub is_course_owner {	Line 8441 sub is_course_owner {
if ($env{'course.'.$cdom.'_'.$cnum.'.internal.courseowner'} eq $uname.':'.$udom) {	if ($env{'course.'.$cdom.'_'.$cnum.'.internal.courseowner'} eq $uname.':'.$udom) {
return 1;	return 1;
} else {	} else {
my %courseinfo = &Apache::lonnet::coursedescription($cdom.'/'.$cnum);	my %courseinfo = &coursedescription($cdom.'/'.$cnum);
if ($courseinfo{'internal.courseowner'} eq $uname.':'.$udom) {	if ($courseinfo{'internal.courseowner'} eq $uname.':'.$udom) {
return 1;	return 1;
}	}
Line 8069 sub is_course_owner {	Line 8452 sub is_course_owner {
}	}

sub is_advanced_user {	sub is_advanced_user {
my ($udom,$uname) = @_;	my ($udom,$uname,$nocache) = @_;
	my ($is_adv,$is_author,$use_cache,$hashid);
if ($udom ne '' && $uname ne '') {	if ($udom ne '' && $uname ne '') {
if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {	if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
if (wantarray) {	if (wantarray) {
Line 8077 sub is_advanced_user {	Line 8461 sub is_advanced_user {
} else {	} else {
return $env{'user.adv'};	return $env{'user.adv'};
}	}
	} elsif (!$nocache) {
	$use_cache = 1;
	$hashid = "$udom:$uname";
	my ($info,$cached)=&is_cached_new('isadvau',$hashid);
	if ($cached) {
	($is_adv,$is_author) = split(/:/,$info);
	if (wantarray) {
	return ($is_adv,$is_author);
	}
	return $is_adv;
	}
}	}
}	}
my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1);	my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1);
my %allroles;	my %allroles;
my ($is_adv,$is_author);
foreach my $role (keys(%roleshash)) {	foreach my $role (keys(%roleshash)) {
my ($trest,$tdomain,$trole,$sec) = split(/:/,$role);	my ($trest,$tdomain,$trole,$sec) = split(/:/,$role);
my $area = '/'.$tdomain.'/'.$trest;	my $area = '/'.$tdomain.'/'.$trest;
Line 8112 sub is_advanced_user {	Line 8506 sub is_advanced_user {
}	}
}	}
}	}
	if ($use_cache) {
	my $cachetime = 600;
	&do_cache_new('isadvau',$hashid,$is_adv.':'.$is_author,$cachetime);
	}
if (wantarray) {	if (wantarray) {
return ($is_adv,$is_author);	return ($is_adv,$is_author);
}	}
Line 8129 sub check_can_request {	Line 8527 sub check_can_request {
my @options = ('approval','validate','autolimit');	my @options = ('approval','validate','autolimit');
my $optregex = join('\|',@options);	my $optregex = join('\|',@options);
if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) {	if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) {
	my %willtrust;
foreach my $type (@{$types}) {	foreach my $type (@{$types}) {
if (&usertools_access($uname,$udom,$type,undef,	if (&usertools_access($uname,$udom,$type,undef,
'requestcourses')) {	'requestcourses')) {
Line 8148 sub check_can_request {	Line 8547 sub check_can_request {
if (ref($request_domains) eq 'HASH') {	if (ref($request_domains) eq 'HASH') {
my ($otherdom) = ($item =~ /^($match_domain):($optregex)(=?\d*)$/);	my ($otherdom) = ($item =~ /^($match_domain):($optregex)(=?\d*)$/);
if ($otherdom ne '') {	if ($otherdom ne '') {
if (ref($request_domains->{$type}) eq 'ARRAY') {	unless (exists($willtrust{$otherdom})) {
unless (grep(/^\Q$otherdom\E$/,@{$request_domains->{$type}})) {	$willtrust{$otherdom} = &will_trust('reqcrs',$env{'user.domain'},$otherdom);
	}
	if ($willtrust{$otherdom}) {
	if (ref($request_domains->{$type}) eq 'ARRAY') {
	unless (grep(/^\Q$otherdom\E$/,@{$request_domains->{$type}})) {
	push(@{$request_domains->{$type}},$otherdom);
	}
	} else {
push(@{$request_domains->{$type}},$otherdom);	push(@{$request_domains->{$type}},$otherdom);
}	}
} else {
push(@{$request_domains->{$type}},$otherdom);
}	}
}	}
}	}
Line 8502 sub allowed {	Line 8906 sub allowed {
&& &is_portfolio_url($uri)) {	&& &is_portfolio_url($uri)) {
$thisallowed = &portfolio_access($uri,$clientip);	$thisallowed = &portfolio_access($uri,$clientip);
}	}

# 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/) {
return 'F';	return 'F';
Line 8510 sub allowed {	Line 8914 sub allowed {

# If this is generating or modifying users, exit with special codes	# If this is generating or modifying users, exit with special codes

if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:caa:'=~/\:\Q$priv\E\:/) {	if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:caa:vca:vaa:'=~/\:\Q$priv\E\:/) {
if (($priv eq 'cca') \|\| ($priv eq 'caa')) {	if (($priv eq 'cca') \|\| ($priv eq 'caa')) {
my ($audom,$auname)=split('/',$uri);	my ($audom,$auname)=split('/',$uri);
# no author name given, so this just checks on the general right to make a co-author in this domain	# no author name given, so this just checks on the general right to make a co-author in this domain
Line 8519 sub allowed {	Line 8923 sub allowed {
if (($auname ne $env{'user.name'} && $env{'request.role'} !~ /^dc\./) \|\|	if (($auname ne $env{'user.name'} && $env{'request.role'} !~ /^dc\./) \|\|
(($audom ne $env{'user.domain'} && $env{'request.role'} !~ /^dc\./) &&	(($audom ne $env{'user.domain'} && $env{'request.role'} !~ /^dc\./) &&
($audom ne $env{'request.role.domain'}))) { return ''; }	($audom ne $env{'request.role.domain'}))) { return ''; }
	} elsif (($priv eq 'vca') \|\| ($priv eq 'vaa')) {
	my ($audom,$auname)=split('/',$uri);
	unless ($auname) { return $thisallowed; }
	unless (($env{'request.role'} eq "dc./$audom") \|\|
	($env{'request.role'} eq "ca./$uri")) {
	return '';
	}
}	}
return $thisallowed;	return $thisallowed;
}	}
Line 8761 sub allowed {	Line 9172 sub allowed {
my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};	my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};
if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}	if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}
=~/\Q$rolecode\E/) {	=~/\Q$rolecode\E/) {
if (($priv ne 'pch') && ($priv ne 'plc')) {	if (($priv ne 'pch') && ($priv ne 'plc') && ($priv ne 'pac')) {
&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.	&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.	'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
$env{'request.course.id'});	$env{'request.course.id'});
Line 8771 sub allowed {	Line 9182 sub allowed {

if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}	if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}
=~/\Q$unamedom\E/) {	=~/\Q$unamedom\E/) {
if (($priv ne 'pch') && ($priv ne 'plc')) {	if (($priv ne 'pch') && ($priv ne 'plc') && ($priv ne 'pac')) {
&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.	&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.
'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.	'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
$env{'request.course.id'});	$env{'request.course.id'});
Line 8842 sub constructaccess {	Line 9253 sub constructaccess {
my ($ownername,$ownerdomain,$ownerhome);	my ($ownername,$ownerdomain,$ownerhome);

($ownerdomain,$ownername) =	($ownerdomain,$ownername) =
($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E\|)/priv/($match_domain)/($match_username)(?:/\|$)});	($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E\|)(?:/daxepage\|/daxeopen)?/priv/($match_domain)/($match_username)(?:/\|$)});

# The URL does not really point to any authorspace, forget it	# The URL does not really point to any authorspace, forget it
unless (($ownername) && ($ownerdomain)) { return ''; }	unless (($ownername) && ($ownerdomain)) { return ''; }
Line 8856 sub constructaccess {	Line 9267 sub constructaccess {
if (exists($env{'user.priv.au./'.$ownerdomain.'/./'})) {	if (exists($env{'user.priv.au./'.$ownerdomain.'/./'})) {
return ($ownername,$ownerdomain,$ownerhome);	return ($ownername,$ownerdomain,$ownerhome);
}	}
	} elsif (&is_course($ownerdomain,$ownername)) {
	# Course Authoring Space?
	if ($env{'request.course.id'}) {
	if (($ownername eq $env{'course.'.$env{'request.course.id'}.'.num'}) &&
	($ownerdomain eq $env{'course.'.$env{'request.course.id'}.'.domain'})) {
	if (&allowed('mdc',$env{'request.course.id'})) {
	return if ($env{'course.'.$env{'request.course.id'}.'.internal.crsauthor'} eq '0');
	unless ($env{'course.'.$env{'request.course.id'}.'.internal.crsauthor'}) {
	my %domdefs = &get_domain_defaults($ownerdomain);
	my $type = lc($env{'course.'.$env{'request.course.id'}.'.type'});
	unless (($type eq 'community') \|\| ($type eq 'placement')) {
	$type = 'unofficial';
	if ($env{'course.'.$env{'request.course.id'}.'internal.coursecode'} ne '') {
	$type = 'official';
	} elsif ($env{'course.'.$env{'request.course.id'}.'internal.textbook'} ne '') {
	$type = 'textbook';
	} else {
	$type = 'unofficial';
	}
	}
	return if ($domdefs{$type.'crsauthor'} eq '0');
	}
	$ownerhome = $env{'course.'.$env{'request.course.id'}.'.home'};
	return ($ownername,$ownerdomain,$ownerhome);
	}
	}
	}
	return '';
} else {	} else {
# Co-author for this?	# Co-author for this?
if (exists($env{'user.priv.ca./'.$ownerdomain.'/'.$ownername.'./'}) \|\|	if (exists($env{'user.priv.ca./'.$ownerdomain.'/'.$ownername.'./'}) \|\|
Line 8907 sub constructaccess {	Line 9346 sub constructaccess {
my $cacheduser='';	my $cacheduser='';
# Course for which data are being temporarily cached.	# Course for which data are being temporarily cached.
my $cachedcid='';	my $cachedcid='';
# Cached blockers for this user (a hash of blocking items).	# Cached blockers for this user (a hash of blocking items).
my %cachedblockers=();	my %cachedblockers=();
# When the data were last cached.	# When the data were last cached.
my $cachedlast='';	my $cachedlast='';

sub load_all_blockers {	sub load_all_blockers {
my ($uname,$udom)=@_;	my ($uname,$udom)=@_;
if (($uname ne '') && ($udom ne '')) {	if (($uname ne '') && ($udom ne '')) {
if (($cacheduser eq $uname.':'.$udom) &&	if (($cacheduser eq $uname.':'.$udom) &&
($cachedcid eq $env{'request.course.id'}) &&	($cachedcid eq $env{'request.course.id'}) &&
(abs($cachedlast-time)<5)) {	(abs($cachedlast-time)<5)) {
Line 8941 sub get_comm_blocks {	Line 9380 sub get_comm_blocks {
if ((defined($cached)) && (ref($blocksref) eq 'HASH')) {	if ((defined($cached)) && (ref($blocksref) eq 'HASH')) {
%commblocks = %{$blocksref};	%commblocks = %{$blocksref};
} else {	} else {
%commblocks = &Apache::lonnet::dump('comm_block',$cdom,$cnum);	%commblocks = &dump('comm_block',$cdom,$cnum);
my $cachetime = 600;	my $cachetime = 600;
&do_cache_new('comm_block',$hashid,\%commblocks,$cachetime);	&do_cache_new('comm_block',$hashid,\%commblocks,$cachetime);
}	}
Line 8963 sub get_commblock_resources {	Line 9402 sub get_commblock_resources {
} else {	} else {
%commblocks = &get_comm_blocks();	%commblocks = &get_comm_blocks();
}	}
return %blockers unless (keys(%commblocks) > 0);	return %blockers unless (keys(%commblocks) > 0);
my $navmap = Apache::lonnavmaps::navmap->new();	my $navmap = Apache::lonnavmaps::navmap->new();
return %blockers unless (ref($navmap));	return %blockers unless (ref($navmap));
my $now = time;	my $now = time;
Line 8975 sub get_commblock_resources {	Line 9414 sub get_commblock_resources {
if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {	if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {
if (ref($commblocks{$block}{'blocks'}{'docs'}{'maps'}) eq 'HASH') {	if (ref($commblocks{$block}{'blocks'}{'docs'}{'maps'}) eq 'HASH') {
if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'maps'}})) {	if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'maps'}})) {
$blockers{$block}{maps} = $commblocks{$block}{'blocks'}{'docs'}{'maps'};	$blockers{$block}{maps} = $commblocks{$block}{'blocks'}{'docs'}{'maps'};
}	}
}	}
if (ref($commblocks{$block}{'blocks'}{'docs'}{'resources'}) eq 'HASH') {	if (ref($commblocks{$block}{'blocks'}{'docs'}{'resources'}) eq 'HASH') {
Line 9008 sub get_commblock_resources {	Line 9447 sub get_commblock_resources {
}	}
}	}
if ($interval[0] =~ /^(\d+)/) {	if ($interval[0] =~ /^(\d+)/) {
my $timelimit = $1;	my $timelimit = $1;
my $first_access;	my $first_access;
if ($type eq 'resource') {	if ($type eq 'resource') {
$first_access=&get_first_access($interval[1],$item);	$first_access=&get_first_access($interval[1],$item);
Line 9101 sub has_comm_blocking {	Line 9540 sub has_comm_blocking {
}	}
if ($symb) {	if ($symb) {
@symbs = ($symb);	@symbs = ($symb);
} elsif (keys(%possibles)) {	} elsif (keys(%possibles)) {
@symbs = keys(%possibles);	@symbs = keys(%possibles);
}	}
my $noblock;	my $noblock;
Line 9136 sub has_comm_blocking {	Line 9575 sub has_comm_blocking {
}	}
}	}
}	}
unless ($noblock) {	unless ($noblock) {
return @blockers;	return @blockers;
}	}
return;	return;
Line 9224 sub deeplink_check {	Line 9663 sub deeplink_check {
return 1;	return 1;
}	}

# -------------------------------- Deversion and split uri into path an filename	# -------------------------------- Deversion and split uri into path an filename

#	#
# Removes the version from a URI and	# Removes the version from a URI and
Line 9350 sub metadata_query {	Line 9789 sub metadata_query {
my @server_list = (defined($server_array) ? @$server_array	my @server_list = (defined($server_array) ? @$server_array
: keys(%libserv) );	: keys(%libserv) );
for my $server (@server_list) {	for my $server (@server_list) {
my $domains = '';	my $domains = '';
if (ref($domains_hash) eq 'HASH') {	if (ref($domains_hash) eq 'HASH') {
$domains = $domains_hash->{$server};	$domains = $domains_hash->{$server};
}	}
unless ($custom or $customshow) {	unless ($custom or $customshow) {
my $reply=&reply("querysend:".&escape($query).':::'.&escape($domains),$server);	my $reply=&reply("querysend:".&escape($query).':::'.&escape($domains),$server);
Line 9983 sub auto_crsreq_update {	Line 10422 sub auto_crsreq_update {
':'.&escape($action).':'.&escape($ownername).':'.	':'.&escape($action).':'.&escape($ownername).':'.
&escape($ownerdomain).':'.&escape($fullname).':'.	&escape($ownerdomain).':'.&escape($fullname).':'.
&escape($title).':'.&escape($code).':'.	&escape($title).':'.&escape($code).':'.
&escape($accessstart).':'.&escape($accessend).':'.$info,$homeserver);	&escape($accessstart).':'.&escape($accessend).':'.$info,
	$homeserver);
unless ($response =~ /(con_lost\|error\|no_such_host\|refused)/) {	unless ($response =~ /(con_lost\|error\|no_such_host\|refused)/) {
my @items = split(/&/,$response);	my @items = split(/&/,$response);
foreach my $item (@items) {	foreach my $item (@items) {
Line 10140 sub toggle_coursegroup_status {	Line 10580 sub toggle_coursegroup_status {
}	}

sub modify_group_roles {	sub modify_group_roles {
my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs,$selfenroll,$context) = @_;	my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs,$selfenroll,$context,
	$othdomby,$requester) = @_;
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,'',$selfenroll,$context);	my $result = &assignrole($udom,$uname,$url,$role,$end,$start,'',$selfenroll,$context,
	$othdomby,$requester);
if ($result eq 'ok') {	if ($result eq 'ok') {
&devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);	&devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);
}	}
Line 10243 sub plaintext {	Line 10685 sub plaintext {
my %rolenames = (	my %rolenames = (
Course => 'std',	Course => 'std',
Community => 'alt1',	Community => 'alt1',
	Placement => 'std',
);	);
if ($cid ne '') {	if ($cid ne '') {
if ($env{'course.'.$cid.'.'.$short.'.plaintext'} ne '') {	if ($env{'course.'.$cid.'.'.$short.'.plaintext'} ne '') {
Line 10271 sub plaintext {	Line 10714 sub plaintext {

sub assignrole {	sub assignrole {
my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll,	my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll,
$context)=@_;	$context,$othdomby,$requester,$reqsec,$reqrole)=@_;
my $mrole;	my ($mrole,$rolelogcontext);
if ($role =~ /^cr\//) {	if ($role =~ /^cr\//) {
my $cwosec=$url;	my $cwosec=$url;
$cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;	$cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
unless (&allowed('ccr',$cwosec)) {	if ((!&allowed('ccr',$cwosec)) && (!&allowed('ccr',$udom))) {
my $refused = 1;	my $refused = 1;
if ($context eq 'requestcourses') {	if ($context eq 'requestcourses') {
if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) {	if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) {
if ($role =~ m{^cr/($match_domain)/($match_username)/([^/]+)$}) {	if ($role =~ m{^cr/($match_domain)/($match_username)/([^/]+)$}) {
if (($1 eq $env{'user.domain'}) && ($2 eq $env{'user.name'})) {	if (($1 eq $env{'user.domain'}) && ($2 eq $env{'user.name'})) {
my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});	my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));	my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
if ($crsenv{'internal.courseowner'} eq	if ($crsenv{'internal.courseowner'} eq
$env{'user.name'}.':'.$env{'user.domain'}) {	$env{'user.name'}.':'.$env{'user.domain'}) {
$refused = '';	$refused = '';
}	}
}	}
}	}
}	}
}	} elsif (($context eq 'course') && ($othdomby eq 'othdombyuser')) {
if ($refused) {	my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
&logthis('Refused custom assignrole: '.	my ($sec) = ($url =~ m{^/\Q$cwosec\E/(.*)$});
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.	my $key = "$uname:$udom:$role:$sec";
' by '.$env{'user.name'}.' at '.$env{'user.domain'});	my %queuedrolereq = &Apache::lonnet::get('nohist_othdomqueued',[$key],$cdom,$cnum);
return 'refused';	if ((exists($queuedrolereq{$key})) && (ref($queuedrolereq{$key}) eq 'HASH')) {
}	if (($queuedrolereq{$key}{'adj'} eq 'user') && ($queuedrolereq{$key}{'requester'} eq $requester)) {
	$refused = '';
	}
	}
	}
	if ($refused) {
	&logthis('Refused custom assignrole: '.
	$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.
	' by '.$env{'user.name'}.' at '.$env{'user.domain'});
	return 'refused';
	}
}	}
$mrole='cr';	$mrole='cr';
} elsif ($role =~ /^gr\//) {	} elsif ($role =~ /^gr\//) {
my $cwogrp=$url;	my $cwogrp=$url;
$cwogrp=~s{^/($match_domain)/($match_courseid)/.*}{$1/$2};	$cwogrp=~s{^/($match_domain)/($match_courseid)/.*}{$1/$2};
unless (&allowed('mdg',$cwogrp)) {	if (!&allowed('mdg',$cwogrp)) {
&logthis('Refused group assignrole: '.	my $refused = 1;
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.	if (($refused) && ($othdomby eq 'othdombyuser') && ($requester ne '') && ($reqrole ne '')) {
$env{'user.name'}.' at '.$env{'user.domain'});	my ($cdom,$cnum) = ($cwogrp =~ m{^/?($match_domain)/($match_courseid)$});
return 'refused';	my $key = "$uname:$udom:$reqrole:$reqsec";
	my %queuedrolereq = &Apache::lonnet::get('nohist_othdomqueued',[$key],$cdom,$cnum);
	if ((exists($queuedrolereq{$key})) && (ref($queuedrolereq{$key}) eq 'HASH')) {
	if (($queuedrolereq{$key}{'adj'} eq 'user') && ($queuedrolereq{$key}{'requester'} eq $requester)) {
	$refused = '';
	}
	}
	}
	if ($refused) {
	&logthis('Refused group assignrole: '.
	$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
	$env{'user.name'}.' at '.$env{'user.domain'});
	return 'refused';
	}
}	}
$mrole='gr';	$mrole='gr';
} else {	} else {
Line 10324 sub assignrole {	Line 10790 sub assignrole {
}	}
if ($refused) {	if ($refused) {
my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});	my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
if (!$selfenroll && $context eq 'course') {	if (!$selfenroll && ($othdomby ne 'othdombyuser') &&
	(($context eq 'course') \|\| ($context eq 'ltienroll' && $env{'request.lti.login'}))) {
my %crsenv;	my %crsenv;
if ($role eq 'cc' \|\| $role eq 'co') {	if ($role eq 'cc' \|\| $role eq 'co') {
%crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));	%crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
Line 10350 sub assignrole {	Line 10817 sub assignrole {
} elsif (($context eq 'ltienroll') && ($env{'request.lti.login'})) {	} elsif (($context eq 'ltienroll') && ($env{'request.lti.login'})) {
$refused = '';	$refused = '';
}	}
	} elsif ($othdomby eq 'othdombyuser') {
	my ($key,%queuedrolereq);
	if ($context eq 'course') {
	my ($sec) = ($url =~ m{^/\Q$cwosec\E/(.*)$});
	$key = "$uname:$udom:$role:$sec";
	%queuedrolereq = &Apache::lonnet::get('nohist_othdomqueued',[$key],$cdom,$cnum);
	if ((exists($queuedrolereq{$key})) && (ref($queuedrolereq{$key}) eq 'HASH')) {
	if (($queuedrolereq{$key}{'adj'} eq 'user') && ($queuedrolereq{$key}{'requester'} eq $requester)) {
	if ((($role eq 'cc') && ($cnum !~ /^$match_community$/)) \|\|
	(($role eq 'co') && ($cnum =~ /^$match_community$/))) {
	my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
	if ($crsenv{'internal.courseowner'} eq $requester) {
	$refused = '';
	}
	} elsif ($role =~ /^(?:in\|ta\|ep\|st)$/) {
	$refused = '';
	}
	}
	}
	} elsif (($context eq 'author') && ($role =~ /^ca\|aa$/)) {
	my $key = "$uname:$udom:$role";
	my ($audom,$auname) = ($url =~ m{^/($match_domain)/($match_username)$});
	if (($audom ne '') && ($auname ne '')) {
	my %queuedrolereq = &Apache::lonnet::get('nohist_othdomqueued',[$key],$audom,$auname);
	if ((exists($queuedrolereq{$key})) && (ref($queuedrolereq{$key}) eq 'HASH')) {
	if (($queuedrolereq{$key}{'adj'} eq 'user') && ($queuedrolereq{$key}{'requester'} eq $requester)) {
	$refused = '';
	}
	}
	}
	} elsif (($context eq 'domain') && ($role ne 'dc') && ($role ne 'su')) {
	my $key = "$uname:$udom:$role";
	my ($roledom) = ($url =~ m{^/($match_domain)/\Q$role\E$});
	if ($roledom ne '') {
	my $confname = $roledom.'-domainconfig';
	my %queuedrolereq = &Apache::lonnet::get('nohist_othdomqueued',[$key],$roledom,$confname);
	if ((exists($queuedrolereq{$key})) && (ref($queuedrolereq{$key}) eq 'HASH')) {
	if (($queuedrolereq{$key}{'adj'} eq 'user') && ($queuedrolereq{$key}{'requester'} eq $requester)) {
	$refused = '';
	}
	}
	}
	}
} elsif ($context eq 'requestcourses') {	} elsif ($context eq 'requestcourses') {
my @possroles = ('st','ta','ep','in','cc','co');	my @possroles = ('st','ta','ep','in','cc','co');
if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) {	if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) {
Line 10368 sub assignrole {	Line 10878 sub assignrole {
}	}
}	}
} elsif ($context eq 'requestauthor') {	} elsif ($context eq 'requestauthor') {
if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) &&	if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) &&
($url eq '/'.$udom.'/') && ($role eq 'au')) {	($url eq '/'.$udom.'/') && ($role eq 'au')) {
if ($env{'environment.requestauthor'} eq 'automatic') {	if ($env{'environment.requestauthor'} eq 'automatic') {
$refused = '';	$refused = '';
Line 10376 sub assignrole {	Line 10886 sub assignrole {
my %domdefaults = &get_domain_defaults($udom);	my %domdefaults = &get_domain_defaults($udom);
if (ref($domdefaults{'requestauthor'}) eq 'HASH') {	if (ref($domdefaults{'requestauthor'}) eq 'HASH') {
my $checkbystatus;	my $checkbystatus;
if ($env{'user.adv'}) {	if ($env{'user.adv'}) {
my $disposition = $domdefaults{'requestauthor'}{'_LC_adv'};	my $disposition = $domdefaults{'requestauthor'}{'_LC_adv'};
if ($disposition eq 'automatic') {	if ($disposition eq 'automatic') {
$refused = '';	$refused = '';
} elsif ($disposition eq '') {	} elsif ($disposition eq '') {
$checkbystatus = 1;	$checkbystatus = 1;
}	}
} else {	} else {
$checkbystatus = 1;	$checkbystatus = 1;
}	}
Line 10402 sub assignrole {	Line 10912 sub assignrole {
}	}
}	}
}	}
	} elsif (($context eq 'author') && (($role eq 'ca' \|\| $role eq 'aa'))) {
	if ($url =~ m{^/($match_domain)/($match_username)$}) {
	my ($audom,$auname) = ($1,$2);
	if ((&Apache::lonnet::allowed('v'.$role,"$audom/$auname")) &&
	($env{"environment.internal.manager.$url"})) {
	$refused = '';
	$rolelogcontext = 'coauthor';
	}
	}
}	}
if ($refused) {	if ($refused) {
&logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.	&logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.
Line 10462 sub assignrole {	Line 10981 sub assignrole {
$origstart,$selfenroll,$context);	$origstart,$selfenroll,$context);
}	}
&courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,	&courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
$selfenroll,$context);	$selfenroll,$context,$othdomby,$requester);
} elsif (($role eq 'li') \|\| ($role eq 'dg') \|\| ($role eq 'sc') \|\|	} elsif (($role eq 'li') \|\| ($role eq 'dg') \|\| ($role eq 'sc') \|\|
($role eq 'au') \|\| ($role eq 'dc') \|\| ($role eq 'dh') \|\|	($role eq 'au') \|\| ($role eq 'dc') \|\| ($role eq 'dh') \|\|
($role eq 'da')) {	($role eq 'da')) {
&domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,	&domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
$context);	$context,$othdomby,$requester);
} elsif (($role eq 'ca') \|\| ($role eq 'aa')) {	} elsif (($role eq 'ca') \|\| ($role eq 'aa')) {
	if ($rolelogcontext eq '') {
	$rolelogcontext = $context;
	}
&coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,	&coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
$context);	$rolelogcontext,$othdomby,$requester);
}	}
if ($role eq 'cc') {	if ($role eq 'cc') {
&autoupdate_coowners($url,$end,$start,$uname,$udom);	&autoupdate_coowners($url,$end,$start,$uname,$udom);
Line 10565 sub store_coowners {	Line 11087 sub store_coowners {
}	}
if (($putresult eq 'ok') \|\| ($delresult eq 'ok')) {	if (($putresult eq 'ok') \|\| ($delresult eq 'ok')) {
my %crsinfo =	my %crsinfo =
&Apache::lonnet::courseiddump($cdom,'.',1,'.','.',$cnum,undef,undef,'.');	&courseiddump($cdom,'.',1,'.','.',$cnum,undef,undef,'.');
if (ref($crsinfo{$cid}) eq 'HASH') {	if (ref($crsinfo{$cid}) eq 'HASH') {
$crsinfo{$cid}{'co-owners'} = \@newcoowners;	$crsinfo{$cid}{'co-owners'} = \@newcoowners;
my $cidput = &Apache::lonnet::courseidput($cdom,\%crsinfo,$chome,'notime');	my $cidput = &courseidput($cdom,\%crsinfo,$chome,'notime');
}	}
}	}
}	}
Line 10690 sub modifyuser {	Line 11212 sub modifyuser {
'current user id "'.$uidhash{$uname}.'".';	'current user id "'.$uidhash{$uname}.'".';
}	}
} else {	} else {
&idput($udom,($uname => $uid));	&idput($udom,{$uname => $uid},$uhome,'ids');
}	}
}	}
# -------------------------------------------------------------- Add names, etc	# -------------------------------------------------------------- Add names, etc
Line 10786 sub modifyuser {	Line 11308 sub modifyuser {
return 'error: '.$reply;	return 'error: '.$reply;
}	}
if ($names{'permanentemail'} ne $oldnames{'permanentemail'}) {	if ($names{'permanentemail'} ne $oldnames{'permanentemail'}) {
&Apache::lonnet::devalidate_cache_new('emailscache',$uname.':'.$udom);	&devalidate_cache_new('emailscache',$uname.':'.$udom);
}	}
my $sqlresult = &update_allusers_table($uname,$udom,\%names);	my $sqlresult = &update_allusers_table($uname,$udom,\%names);
&devalidate_cache_new('namescache',$uname.':'.$udom);	&devalidate_cache_new('namescache',$uname.':'.$udom);
Line 10815 sub modifystudent {	Line 11337 sub modifystudent {
# student's environment	# student's environment
$uid = undef if (!$forceid);	$uid = undef if (!$forceid);
$reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,	$reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
$gene,$usec,$end,$start,$type,$locktype,	$gene,$usec,$end,$start,$type,$locktype,
$cid,$selfenroll,$context,$credits,$instsec);	$cid,$selfenroll,$context,$credits,$instsec);
return $reply;	return $reply;
}	}

sub modify_student_enrollment {	sub modify_student_enrollment {
my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,	my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,
$locktype,$cid,$selfenroll,$context,$credits,$instsec) = @_;	$locktype,$cid,$selfenroll,$context,$credits,$instsec,$othdomby,$requester) = @_;
my ($cdom,$cnum,$chome);	my ($cdom,$cnum,$chome);
if (!$cid) {	if (!$cid) {
unless ($cid=$env{'request.course.id'}) {	unless ($cid=$env{'request.course.id'}) {
Line 10866 sub modify_student_enrollment {	Line 11388 sub modify_student_enrollment {
}	}
my $fullname = &format_name($first,$middle,$last,$gene,'lastname');	my $fullname = &format_name($first,$middle,$last,$gene,'lastname');
my $user = "$uname:$udom";	my $user = "$uname:$udom";
my %old_entry = &Apache::lonnet::get('classlist',[$user],$cdom,$cnum);	my %old_entry = &get('classlist',[$user],$cdom,$cnum);
my $reply=cput('classlist',	my $reply=cput('classlist',
{$user =>	{$user =>
join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype,$credits,$instsec) },	join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype,$credits,$instsec) },
Line 10883 sub modify_student_enrollment {	Line 11405 sub modify_student_enrollment {
$uurl.='/'.$usec;	$uurl.='/'.$usec;
}	}
my $result = &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,	my $result = &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,
$selfenroll,$context);	$selfenroll,$context,$othdomby,$requester);
if ($result ne 'ok') {	if ($result ne 'ok') {
if ($old_entry{$user} ne '') {	if ($old_entry{$user} ne '') {
$reply = &cput('classlist',\%old_entry,$cdom,$cnum);	$reply = &cput('classlist',\%old_entry,$cdom,$cnum);
Line 11000 sub createcourse {	Line 11522 sub createcourse {
}	}
}	}
my %host_servers =	my %host_servers =
&Apache::lonnet::get_servers($udom,'library');	&get_servers($udom,'library');
unless ($host_servers{$course_server}) {	unless ($host_servers{$course_server}) {
return 'error: invalid home server for course: '.$course_server;	return 'error: invalid home server for course: '.$course_server;
}	}
Line 11097 sub generate_coursenum {	Line 11619 sub generate_coursenum {
sub is_course {	sub is_course {
my ($cdom, $cnum) = scalar(@_) == 1 ?	my ($cdom, $cnum) = scalar(@_) == 1 ?
($_[0] =~ /^($match_domain)_($match_courseid)$/) : @_;	($_[0] =~ /^($match_domain)_($match_courseid)$/) : @_;

return unless (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/));	return unless (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/));
my $uhome=&homeserver($cnum,$cdom);	my $uhome=&homeserver($cnum,$cdom);
my $iscourse;	my $iscourse;
Line 11115 sub is_course {	Line 11638 sub is_course {
&do_cache_new('iscourse',$hashid,$iscourse,3600);	&do_cache_new('iscourse',$hashid,$iscourse,3600);
}	}
}	}
return unless($iscourse);	return unless ($iscourse);
return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum;	return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum;
}	}

Line 11158 sub store_userdata {	Line 11681 sub store_userdata {
# ---------------------------------------------------------- Assign Custom Role	# ---------------------------------------------------------- Assign Custom Role

sub assigncustomrole {	sub assigncustomrole {
my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag,$selfenroll,$context)=@_;	my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag,
	$selfenroll,$context,$othdomby,$requester)=@_;
return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,	return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,
$end,$start,$deleteflag,$selfenroll,$context);	$end,$start,$deleteflag,$selfenroll,$context,$othdomby,
	$requester);
}	}

# ----------------------------------------------------------------- Revoke Role	# ----------------------------------------------------------------- Revoke Role
Line 11314 sub files_not_in_path {	Line 11839 sub files_not_in_path {
return (@return_files);	return (@return_files);
}	}

	#------------------------------Submitted/Handedback Portfolio Files Versioning

	sub portfiles_versioning {
	my ($symb,$domain,$stu_name,$portfiles,$versioned_portfiles) = @_;
	my $portfolio_root = '/userfiles/portfolio';
	return unless ((ref($portfiles) eq 'ARRAY') && (ref($versioned_portfiles) eq 'ARRAY'));
	foreach my $file (@{$portfiles}) {
	&unmark_as_readonly($domain,$stu_name,[$symb,$env{'request.course.id'}],$file);
	my ($directory,$answer_file) =($file =~ /^(.?)([^\/])$/);
	my ($answer_name,$answer_ver,$answer_ext) = &file_name_version_ext($answer_file);
	my $getpropath = 1;
	my ($dir_list,$listerror) = &dirlist($portfolio_root.$directory,$domain,
	$stu_name,$getpropath);
	my $version = &get_next_version($answer_name,$answer_ext,$dir_list);
	my $new_answer =
	&version_selected_portfile($domain,$stu_name,$directory,$answer_file,$version);
	if ($new_answer ne 'problem getting file') {
	push(@{$versioned_portfiles}, $directory.$new_answer);
	&mark_as_readonly($domain,$stu_name,[$directory.$new_answer],
	[$symb,$env{'request.course.id'},'graded']);
	}
	}
	}

	sub get_next_version {
	my ($answer_name, $answer_ext, $dir_list) = @_;
	my $version;
	if (ref($dir_list) eq 'ARRAY') {
	foreach my $row (@{$dir_list}) {
	my ($file) = split(/\&/,$row,2);
	my ($file_name,$file_version,$file_ext) =
	&file_name_version_ext($file);
	if (($file_name eq $answer_name) &&
	($file_ext eq $answer_ext)) {
	# gets here if filename and extension match,
	# regardless of version
	if ($file_version ne '') {
	# a versioned file is found so save it for later
	if ($file_version > $version) {
	$version = $file_version;
	}
	}
	}
	}
	}
	$version ++;
	return($version);
	}

	sub version_selected_portfile {
	my ($domain,$stu_name,$directory,$file_name,$version) = @_;
	my ($answer_name,$answer_ver,$answer_ext) =
	&file_name_version_ext($file_name);
	my $new_answer;
	$env{'form.copy'} =
	&getfile("/uploaded/$domain/$stu_name/portfolio$directory$file_name");
	if($env{'form.copy'} eq '-1') {
	$new_answer = 'problem getting file';
	} else {
	$new_answer = $answer_name.'.'.$version.'.'.$answer_ext;
	my $copy_result =
	&finishuserfileupload($stu_name,$domain,'copy',
	'/portfolio'.$directory.$new_answer);
	}
	undef($env{'form.copy'});
	return ($new_answer);
	}

	sub file_name_version_ext {
	my ($file)=@_;
	my @file_parts = split(/\./, $file);
	my ($name,$version,$ext);
	if (@file_parts > 1) {
	$ext=pop(@file_parts);
	if (@file_parts > 1 && $file_parts[-1] =~ /^\d+$/) {
	$version=pop(@file_parts);
	}
	$name=join('.',@file_parts);
	} else {
	$name=join('.',@file_parts);
	}
	return($name,$version,$ext);
	}

#----------------------------------------------Get portfolio file permissions	#----------------------------------------------Get portfolio file permissions

sub get_portfile_permissions {	sub get_portfile_permissions {
Line 11458 sub modify_access_controls {	Line 12067 sub modify_access_controls {
}	}

sub make_public_indefinitely {	sub make_public_indefinitely {
my ($requrl) = @_;	my (@requrl) = @_;
	return &automated_portfile_access('public',\@requrl);
	}

	sub automated_portfile_access {
	my ($accesstype,$addsref,$delsref,$info) = @_;
	unless (($accesstype eq 'public') \|\| ($accesstype eq 'ip')) {
	return 'invalid';
	}
	my %urls;
	if (ref($addsref) eq 'ARRAY') {
	foreach my $requrl (@{$addsref}) {
	if (&is_portfolio_url($requrl)) {
	unless (exists($urls{$requrl})) {
	$urls{$requrl} = 'add';
	}
	}
	}
	}
	if (ref($delsref) eq 'ARRAY') {
	foreach my $requrl (@{$delsref}) {
	if (&is_portfolio_url($requrl)) {
	unless (exists($urls{$requrl})) {
	$urls{$requrl} = 'delete';
	}
	}
	}
	}
	unless (keys(%urls)) {
	return 'invalid';
	}
	my $ip;
	if ($accesstype eq 'ip') {
	if (ref($info) eq 'HASH') {
	if ($info->{'ip'} ne '') {
	$ip = $info->{'ip'};
	}
	}
	if ($ip eq '') {
	return 'invalid';
	}
	}
	my $errors;
my $now = time;	my $now = time;
my $action = 'activate';	my %current_perms;
my $aclnum = 0;	foreach my $requrl (sort(keys(%urls))) {
if (&is_portfolio_url($requrl)) {	my $action;
	if ($urls{$requrl} eq 'add') {
	$action = 'activate';
	} else {
	$action = 'none';
	}
	my $aclnum = 0;
my (undef,$udom,$unum,$file_name,$group) =	my (undef,$udom,$unum,$file_name,$group) =
&parse_portfolio_url($requrl);	&parse_portfolio_url($requrl);
my $current_perms = &get_portfile_permissions($udom,$unum);	unless (exists($current_perms{$unum.':'.$udom})) {
my %access_controls = &get_access_controls($current_perms,	$current_perms{$unum.':'.$udom} = &get_portfile_permissions($udom,$unum);
	}
	my %access_controls = &get_access_controls($current_perms{$unum.':'.$udom},
$group,$file_name);	$group,$file_name);
foreach my $key (keys(%{$access_controls{$file_name}})) {	foreach my $key (keys(%{$access_controls{$file_name}})) {
my ($num,$scope,$end,$start) =	my ($num,$scope,$end,$start) =
($key =~ /^([^:]+):([a-z]+)_(\d)_?(\d)$/);	($key =~ /^([^:]+):([a-z]+)_(\d)_?(\d)$/);
if ($scope eq 'public') {	if ($scope eq $accesstype) {
if ($start <= $now && $end == 0) {	if (($start <= $now) && ($end == 0)) {
$action = 'none';	if ($accesstype eq 'ip') {
} else {	if (ref($access_controls{$file_name}{$key}) eq 'HASH') {
	if (ref($access_controls{$file_name}{$key}{'ip'}) eq 'ARRAY') {
	if (grep(/^\Q$ip\E$/,@{$access_controls{$file_name}{$key}{'ip'}})) {
	if ($urls{$requrl} eq 'add') {
	$action = 'none';
	last;
	} else {
	$action = 'delete';
	$aclnum = $num;
	last;
	}
	}
	}
	}
	} elsif ($accesstype eq 'public') {
	if ($urls{$requrl} eq 'add') {
	$action = 'none';
	last;
	} else {
	$action = 'delete';
	$aclnum = $num;
	last;
	}
	}
	} elsif ($accesstype eq 'public') {
$action = 'update';	$action = 'update';
$aclnum = $num;	$aclnum = $num;
	last;
}	}
last;
}	}
}	}
if ($action eq 'none') {	if ($action eq 'none') {
return 'ok';	next;
} else {	} else {
my %changes;	my %changes;
my $newend = 0;	my $newend = 0;
my $newstart = $now;	my $newstart = $now;
my $newkey = $aclnum.':public_'.$newend.'_'.$newstart;	my $newkey = $aclnum.':'.$accesstype.'_'.$newend.'_'.$newstart;
$changes{$action}{$newkey} = {	$changes{$action}{$newkey} = {
type => 'public',	type => $accesstype,
time => {	time => {
start => $newstart,	start => $newstart,
end => $newend,	end => $newend,
},	},
};	};
	if ($accesstype eq 'ip') {
	$changes{$action}{$newkey}{'ip'} = [$ip];
	}
my ($outcome,$deloutcome,$new_values,$translation) =	my ($outcome,$deloutcome,$new_values,$translation) =
&modify_access_controls($file_name,\%changes,$udom,$unum);	&modify_access_controls($file_name,\%changes,$udom,$unum);
return $outcome;	unless ($outcome eq 'ok') {
	$errors .= $outcome.' ';
	}
}	}
	}
	if ($errors) {
	$errors =~ s/\s$//;
	return $errors;
} else {	} else {
return 'invalid';	return 'ok';
}	}
}	}

Line 11705 sub dirlist {	Line 12397 sub dirlist {
foreach my $user (sort(keys(%allusers))) {	foreach my $user (sort(keys(%allusers))) {
push(@alluserslist,$user.'&user');	push(@alluserslist,$user.'&user');
}	}

if (!%listerror) {	if (!%listerror) {
# no errors	# no errors
return (\@alluserslist);	return (\@alluserslist);
} elsif (scalar(keys(%servers)) == 1) {	} elsif (scalar(keys(%servers)) == 1) {
# one library server, one error	# one library server, one error
my ($key) = keys(%listerror);	my ($key) = keys(%listerror);
return (\@alluserslist, $listerror{$key});	return (\@alluserslist, $listerror{$key});
} elsif ( grep { $_ eq 'con_lost' } values(%listerror) ) {	} elsif ( grep { $_ eq 'con_lost' } values(%listerror) ) {
Line 11718 sub dirlist {	Line 12411 sub dirlist {
return (\@alluserslist, 'con_lost');	return (\@alluserslist, 'con_lost');
} else {	} else {
# multiple library servers and no con_lost -> data should be	# multiple library servers and no con_lost -> data should be
# complete.	# complete.
return (\@alluserslist);	return (\@alluserslist);
}	}

Line 11794 sub stat_file {	Line 12487 sub stat_file {
return ();	return ();
}	}

	# --------------------------------------------------------- recursedirs
	# Recursive function to traverse either a specific user's Authoring Space
	# or corresponding Published Resource Space, and populate the hash ref:
	# $dirhashref with URLs of all directories, and if $filehashref hash
	# ref arg is provided, the URLs of any files, excluding versioned, .meta,
	# or .rights files in resource space, and .meta, .save, .log, .bak and
	# .rights files in Authoring Space.
	#
	# Inputs:
	#
	# $is_home - true if current server is home server for user's space
	# $recurse - if true will also traverse subdirectories recursively
	# $include - reference to hash containing allowed file extensions. If provided,
	# files which do not have a matching extension will be ignored.
	# $exclude - reference to hash containing excluded file extensions. If provided,
	# files which have a matching extension will be ignored.
	# $nonemptydir - if true, will only populate $fileshashref hash entry for a particular
	# directory with first file found (with acceptable extension).
	# $addtopdir - if true, set $dirhashref->{'/'} = 1
	# $toppath - Top level directory (i.e., /res/$dom/$uname or /priv/$dom/$uname
	# $relpath - Current path (relative to top level).
	# $dirhashref - reference to hash to populate with URLs of directories (Required)
	# $filehashref - reference to hash to populate with URLs of files (Optional)
	#
	# Returns: nothing
	#
	# Side Effects: populates $dirhashref, and $filehashref (if provided).
	#
	# Currently used by interface/londocs.pm to create linked select boxes for
	# directory and filename to import a Course "Author" resource into a course, and
	# also to create linked select boxes for Authoring Space and Directory to choose
	# save location for creation of a new "standard" problem from the Course Editor.
	#

	sub recursedirs {
	my ($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$toppath,$relpath,$dirhashref,$filehashref) = @_;
	return unless (ref($dirhashref) eq 'HASH');
	my $docroot = $perlvar{'lonDocRoot'};
	my $currpath = $docroot.$toppath;
	if ($relpath ne '') {
	$currpath .= "/$relpath";
	}
	my ($savefile,$checkinc,$checkexc);
	if (ref($filehashref)) {
	$savefile = 1;
	}
	if (ref($include) eq 'HASH') {
	$checkinc = 1;
	}
	if (ref($exclude) eq 'HASH') {
	$checkexc = 1;
	}
	if ($is_home) {
	if ((-e $currpath) && (opendir(my $dirh,$currpath))) {
	my $filecount = 0;
	foreach my $item (sort { lc($a) cmp lc($b) } grep(!/^\.+$/,readdir($dirh))) {
	next if ($item eq '');
	if (-d "$currpath/$item") {
	my $newpath;
	if ($relpath ne '') {
	$newpath = "$relpath/$item";
	} else {
	$newpath = $item;
	}
	$dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;
	if ($recurse) {
	&recursedirs($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$toppath,$newpath,$dirhashref,$filehashref);
	}
	} elsif (($savefile) \|\| ($relpath eq '')) {
	next if ($nonemptydir && $filecount);
	if ($checkinc \|\| $checkexc) {
	my ($extension) = ($item =~ /\.(\w+)$/);
	if ($checkinc) {
	next unless ($extension && $include->{$extension});
	}
	if ($checkexc) {
	next if ($extension && $exclude->{$extension});
	}
	}
	if (($relpath eq '') && (!exists($dirhashref->{'/'}))) {
	$dirhashref->{'/'} = 1;
	}
	if ($savefile) {
	if ($relpath eq '') {
	$filehashref->{'/'}{$item} = 1;
	} else {
	$filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1;
	}
	}
	$filecount ++;
	}
	}
	closedir($dirh);
	}
	} else {
	my ($dirlistref,$listerror) =
	&dirlist($toppath.$relpath);
	my @dir_lines;
	my $dirptr=16384;
	if (ref($dirlistref) eq 'ARRAY') {
	my $filecount = 0;
	foreach my $dir_line (sort
	{
	my ($afile)=split('&',$a,2);
	my ($bfile)=split('&',$b,2);
	return (lc($afile) cmp lc($bfile));
	} (@{$dirlistref})) {
	my ($item,$dom,undef,$testdir,undef,undef,undef,undef,$size,undef,$mtime,undef,undef,undef,$obs,undef) =
	split(/\&/,$dir_line,16);
	$item =~ s/\s+$//;
	next if (($item =~ /^\.\.?$/) \|\| ($obs));
	if ($dirptr&$testdir) {
	my $newpath;
	if ($relpath) {
	$newpath = "$relpath/$item";
	} else {
	$newpath = $item;
	}
	$dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;
	if ($recurse) {
	&recursedirs($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$toppath,$newpath,$dirhashref,$filehashref);
	}
	} elsif (($savefile) \|\| ($relpath eq '')) {
	next if ($nonemptydir && $filecount);
	if ($checkinc \|\| $checkexc) {
	my $extension;
	if ($checkinc) {
	next unless ($extension && $include->{$extension});
	}
	if ($checkexc) {
	next if ($extension && $exclude->{$extension});
	}
	}
	if (($relpath eq '') && (!exists($dirhashref->{'/'}))) {
	$dirhashref->{'/'} = 1;
	}
	if ($savefile) {
	if ($relpath eq '') {
	$filehashref->{'/'}{$item} = 1;
	} else {
	$filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1;
	}
	}
	$filecount ++;
	}
	}
	}
	}
	if ($addtopdir) {
	if (($relpath eq '') && (!exists($dirhashref->{'/'}))) {
	$dirhashref->{'/'} = 1;
	}
	}
	return;
	}

	sub priv_exclude {
	return {
	meta => 1,
	save => 1,
	log => 1,
	bak => 1,
	rights => 1,
	DS_Store => 1,
	};
	}

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

# gets the value of a specific preevaluated condition	# gets the value of a specific preevaluated condition
Line 11957 sub get_userresdata {	Line 12817 sub get_userresdata {
# Parameters:	# Parameters:
# $name - Course/user name.	# $name - Course/user name.
# $domain - Name of the domain the user/course is registered on.	# $domain - Name of the domain the user/course is registered on.
# $type - Type of thing $name is (must be 'course' or 'user'	# $type - Type of thing $name is (must be 'course' or 'user')
	# $mapp - decluttered URL of enclosing map
	# $recursed - Ref to scalar -- set to 1, if nested maps have been recursed.
	# $recurseup - Ref to array of map URLs, starting with map containing
	# $mapp up through hierarchy of nested maps to top level map.
	# $courseid - CourseID (first part of param identifier).
	# $modifier - Middle part of param identifier.
	# $what - Last part of param identifier.
# @which - Array of names of resources desired.	# @which - Array of names of resources desired.
# Returns:	# Returns:
# The value of the first reasource in @which that is found in the	# The value of the first reasource in @which that is found in the
Line 11967 sub get_userresdata {	Line 12834 sub get_userresdata {
# 'user', an undefined reference is returned.	# 'user', an undefined reference is returned.
# If none of the resources are found, an undef is returned	# If none of the resources are found, an undef is returned
sub resdata {	sub resdata {
my ($name,$domain,$type,@which)=@_;	my ($name,$domain,$type,$mapp,$recursed,$recurseup,$courseid,
	$modifier,$what,@which)=@_;
my $result;	my $result;
if ($type eq 'course') {	if ($type eq 'course') {
$result=&get_courseresdata($name,$domain);	$result=&get_courseresdata($name,$domain);
Line 11976 sub resdata {	Line 12844 sub resdata {
}	}
if (!ref($result)) { return $result; }	if (!ref($result)) { return $result; }
foreach my $item (@which) {	foreach my $item (@which) {
if (defined($result->{$item->[0]})) {	if ($item->[1] eq 'course') {
	if ((ref($recurseup) eq 'ARRAY') && (ref($recursed) eq 'SCALAR')) {
	unless ($$recursed) {
	@{$recurseup} = &get_map_hierarchy($mapp,$courseid);
	$$recursed = 1;
	}
	foreach my $item (@${recurseup}) {
	my $norecursechk=$courseid.$modifier.$item.'___(all).'.$what;
	last if (defined($result->{$norecursechk}));
	my $recursechk=$courseid.$modifier.$item.'___(rec).'.$what;
	if (defined($result->{$recursechk})) { return [$result->{$recursechk},'map']; }
	}
	}
	}
	if (defined($result->{$item->[0]})) {
return [$result->{$item->[0]},$item->[1]];	return [$result->{$item->[0]},$item->[1]];
}	}
}	}
Line 12095 sub domainlti_itemid {	Line 12977 sub domainlti_itemid {
return $itemid;	return $itemid;
}	}

	sub get_ltitools_id {
	my ($context,$cdom,$cnum,$title) = @_;
	my ($lockhash,$tries,$gotlock,$id,$error);

	# get lock on ltitools db
	$lockhash = {
	lock => $env{'user.name'}.
	':'.$env{'user.domain'},
	};
	$tries = 0;
	if ($context eq 'domain') {
	$gotlock = &newput_dom('ltitools',$lockhash,$cdom);
	} else {
	$gotlock = &newput('ltitools',$lockhash,$cdom,$cnum);
	}
	while (($gotlock ne 'ok') && ($tries<10)) {
	$tries ++;
	sleep (0.1);
	if ($context eq 'domain') {
	$gotlock = &newput_dom('ltitools',$lockhash,$cdom);
	} else {
	$gotlock = &newput('ltitools',$lockhash,$cdom,$cnum);
	}
	}
	if ($gotlock eq 'ok') {
	my %currids;
	if ($context eq 'domain') {
	%currids = &dump_dom('ltitools',$cdom);
	} else {
	%currids = &dump('ltitools',$cdom,$cnum);
	}
	if ($currids{'lock'}) {
	delete($currids{'lock'});
	if (keys(%currids)) {
	my @curr = sort { $a <=> $b } keys(%currids);
	if ($curr[-1] =~ /^\d+$/) {
	$id = 1 + $curr[-1];
	}
	} else {
	$id = 1;
	}
	if ($id) {
	if ($context eq 'domain') {
	unless (&newput_dom('ltitools',{ $id => $title },$cdom) eq 'ok') {
	$error = 'nostore';
	}
	} else {
	unless (&newput('ltitools',{ $id => $title },$cdom,$cnum) eq 'ok') {
	$error = 'nostore';
	}
	}
	} else {
	$error = 'nonumber';
	}
	}
	my $dellockoutcome;
	if ($context eq 'domain') {
	$dellockoutcome = &del_dom('ltitools',['lock'],$cdom);
	} else {
	$dellockoutcome = &del('ltitools',['lock'],$cdom,$cnum);
	}
	} else {
	$error = 'nolock';
	}
	return ($id,$error);
	}

sub count_supptools {	sub count_supptools {
my ($cnum,$cdom,$ignorecache,$reload)=@_;	my ($cnum,$cdom,$ignorecache,$reload)=@_;
my $hashid=$cnum.':'.$cdom;	my $hashid=$cnum.':'.$cdom;
Line 12193 sub EXT_cache_set {	Line 13142 sub EXT_cache_set {
# --------------------------------------------------------- Value of a Variable	# --------------------------------------------------------- Value of a Variable
sub EXT {	sub EXT {

my ($varname,$symbparm,$udom,$uname,$usection,$recurse,$cid)=@_;	my ($varname,$symbparm,$udom,$uname,$usection,$recurse,$cid,$recurseupref)=@_;
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 12346 sub EXT {	Line 13295 sub EXT {
}	}
}	}

my ($section, $group, @groups);	my ($section, $group, @groups, @recurseup, $recursed);
my ($courselevelm,$courselevel);	if (ref($recurseupref) eq 'ARRAY') {
	@recurseup = @{$recurseupref};
	$recursed = 1;
	}
	my ($courselevelm,$courseleveli,$courselevel,$mapp);
if (($courseid eq '') && ($cid)) {	if (($courseid eq '') && ($cid)) {
$courseid = $cid;	$courseid = $cid;
}	}
if (($symbparm && $courseid) &&	if (($symbparm && $courseid) &&
(($courseid eq $env{'request.course.id'}) \|\| ($courseid eq $cid))) {	(($courseid eq $env{'request.course.id'}) \|\| ($courseid eq $cid))) {

#print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;	#print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;

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

my $symbparm=$symbp.'.'.$spacequalifierrest;	my $symbparm=$symbp.'.'.$spacequalifierrest;
	my $recurseparm=$mapp.'___(rec).'.$spacequalifierrest;
my $mapparm=$mapp.'___(all).'.$spacequalifierrest;	my $mapparm=$mapp.'___(all).'.$spacequalifierrest;

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'};
Line 12379 sub EXT {	Line 13331 sub EXT {

my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;	my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
my $seclevelr=$courseid.'.['.$section.'].'.$symbparm;	my $seclevelr=$courseid.'.['.$section.'].'.$symbparm;
	my $secleveli=$courseid.'.['.$section.'].'.$recurseparm;
my $seclevelm=$courseid.'.['.$section.'].'.$mapparm;	my $seclevelm=$courseid.'.['.$section.'].'.$mapparm;

$courselevel=$courseid.'.'.$spacequalifierrest;	$courselevel=$courseid.'.'.$spacequalifierrest;
my $courselevelr=$courseid.'.'.$symbparm;	my $courselevelr=$courseid.'.'.$symbparm;
	$courseleveli=$courseid.'.'.$recurseparm;
$courselevelm=$courseid.'.'.$mapparm;	$courselevelm=$courseid.'.'.$mapparm;

# ----------------------------------------------------------- first, check user	# ----------------------------------------------------------- first, check user

my $userreply=&resdata($uname,$udom,'user',	my $userreply=&resdata($uname,$udom,'user',$mapp,\$recursed,
	\@recurseup,$courseid,'.',$spacequalifierrest,
([$courselevelr,'resource'],	([$courselevelr,'resource'],
[$courselevelm,'map' ],	[$courselevelm,'map' ],
	[$courseleveli,'map' ],
[$courselevel, 'course' ]));	[$courselevel, 'course' ]));
if (defined($userreply)) { return &get_reply($userreply); }	if (defined($userreply)) { return &get_reply($userreply); }

Line 12397 sub EXT {	Line 13353 sub EXT {
my $coursereply;	my $coursereply;
if (@groups > 0) {	if (@groups > 0) {
$coursereply = &check_group_parms($courseid,\@groups,$symbparm,	$coursereply = &check_group_parms($courseid,\@groups,$symbparm,
$mapparm,$spacequalifierrest);	$recurseparm,$mapparm,$spacequalifierrest,
if (defined($coursereply)) { return &get_reply($coursereply); }	$mapp,\$recursed,\@recurseup);
	if (defined($coursereply)) { return &get_reply($coursereply); }
}	}

$coursereply=&resdata($env{'course.'.$courseid.'.num'},	$coursereply=&resdata($env{'course.'.$courseid.'.num'},
$env{'course.'.$courseid.'.domain'},	$env{'course.'.$courseid.'.domain'},
'course',	'course',$mapp,\$recursed,\@recurseup,
	$courseid,'.['.$section.'].',$spacequalifierrest,
([$seclevelr, 'resource'],	([$seclevelr, 'resource'],
[$seclevelm, 'map' ],	[$seclevelm, 'map' ],
	[$secleveli, 'map' ],
[$seclevel, 'course' ],	[$seclevel, 'course' ],
[$courselevelr,'resource']));	[$courselevelr,'resource']));
if (defined($coursereply)) { return &get_reply($coursereply); }	if (defined($coursereply)) { return &get_reply($coursereply); }
Line 12422 sub EXT {	Line 13381 sub EXT {
if ($thisparm) { return &get_reply([$thisparm,'resource']); }	if ($thisparm) { return &get_reply([$thisparm,'resource']); }
}	}
# ------------------------------------------ fourth, look in resource metadata	# ------------------------------------------ fourth, look in resource metadata

my $what = $spacequalifierrest;	my $what = $spacequalifierrest;
$what=~s/\./\_/;	$what=~s/\./\_/;
my $filename;	my $filename;
if (!$symbparm) { $symbparm=&symbread(); }	if (!$symbparm) { $symbparm=&symbread(); }
if ($symbparm) {	if ($symbparm) {
$filename=(&decode_symb($symbparm))[2];	$filename=(&decode_symb($symbparm))[2];
Line 12446 sub EXT {	Line 13405 sub EXT {
$courseid eq $env{'request.course.id'}) {	$courseid eq $env{'request.course.id'}) {
my $coursereply=&resdata($env{'course.'.$courseid.'.num'},	my $coursereply=&resdata($env{'course.'.$courseid.'.num'},
$env{'course.'.$courseid.'.domain'},	$env{'course.'.$courseid.'.domain'},
'course',	'course',$mapp,\$recursed,\@recurseup,
	$courseid,'.',$spacequalifierrest,
([$courselevelm,'map' ],	([$courselevelm,'map' ],
	[$courseleveli,'map' ],
[$courselevel, 'course']));	[$courselevel, 'course']));
if (defined($coursereply)) { return &get_reply($coursereply); }	if (defined($coursereply)) { return &get_reply($coursereply); }
}	}
Line 12508 sub get_reply {	Line 13469 sub get_reply {
}	}

sub check_group_parms {	sub check_group_parms {
my ($courseid,$groups,$symbparm,$mapparm,$what) = @_;	my ($courseid,$groups,$symbparm,$recurseparm,$mapparm,$what,$mapp,
my @groupitems = ();	$recursed,$recurseupref) = @_;
my $resultitem;	my @levels = ([$symbparm,'resource'],[$mapparm,'map'],[$recurseparm,'map'],
my @levels = ([$symbparm,'resource'],[$mapparm,'map'],[$what,'course']);	[$what,'course']);
	my $coursereply;
foreach my $group (@{$groups}) {	foreach my $group (@{$groups}) {
	my @groupitems = ();
foreach my $level (@levels) {	foreach my $level (@levels) {
my $item = $courseid.'.['.$group.'].'.$level->[0];	my $item = $courseid.'.['.$group.'].'.$level->[0];
push(@groupitems,[$item,$level->[1]]);	push(@groupitems,[$item,$level->[1]]);
}	}
	my $coursereply = &resdata($env{'course.'.$courseid.'.num'},
	$env{'course.'.$courseid.'.domain'},
	'course',$mapp,$recursed,$recurseupref,
	$courseid,'.['.$group.'].',$what,
	@groupitems);
	last if (defined($coursereply));
}	}
my $coursereply = &resdata($env{'course.'.$courseid.'.num'},
$env{'course.'.$courseid.'.domain'},
'course',@groupitems);
return $coursereply;	return $coursereply;
}	}

Line 12667 sub metadata {	Line 13633 sub metadata {
# gradable in the exttool_$marker.db file for the tool instance	# gradable in the exttool_$marker.db file for the tool instance
# is retrieved via &get().	# is retrieved via &get().
#	#
# When lonuserstate::traceroute() calls lonnet::EXT() for	# When lonuserstate::traceroute() calls lonnet::EXT() for
# hiddenresource and encrypturl (during course initialization)	# hiddenresource and encrypturl (during course initialization)
# the map-level parameter for resource.0.gradable included in the	# the map-level parameter for resource.0.gradable included in the
# uploaded map containing the tool will not yet have been stored	# uploaded map containing the tool will not yet have been stored
# in the user_course_parms.db file for the user's session, so in	# in the user_course_parms.db file for the user's session, so in
# this case fall back to retrieving gradable status from the	# this case fall back to retrieving gradable status from the
# exttool_$marker.db file.	# exttool_$marker.db file.
#	#
Line 12819 sub metadata {	Line 13785 sub metadata {
# Check metadata for imported file to	# Check metadata for imported file to
# see if it contained response items	# see if it contained response items
#	#
	my ($origfile,@libfilekeys);
my %currmetaentry = %metaentry;	my %currmetaentry = %metaentry;
my $libresponseorder = &metadata($location,'responseorder');	@libfilekeys = split(/,/,&metadata($location,'keys',undef,undef,undef,
my $origfile;	$depthcount+1));
if ($libresponseorder ne '') {	if (grep(/^responseorder$/,@libfilekeys)) {
if ($#origfiletagids<0) {	my $libresponseorder = &metadata($location,'responseorder',undef,undef,
undef(%importedrespids);	undef,$depthcount+1);
undef(%importedpartids);	if ($libresponseorder ne '') {
}	if ($#origfiletagids<0) {
@{$importedrespids{$importid}} = split(/\s,\s/,$libresponseorder);	undef(%importedrespids);
if (@{$importedrespids{$importid}} > 0) {	undef(%importedpartids);
$importedresponses = 1;	}
	my @respids = split(/\s,\s/,$libresponseorder);
	if (@respids) {
	$importedrespids{$importid} = join(',',map { $importid.'_'.$_ } @respids);
	}
	if ($importedrespids{$importid} ne '') {
	$importedresponses = 1;
# We need to get the original file and the imported file to get the response order correct	# We need to get the original file and the imported file to get the response order correct
# Load and inspect original file	# Load and inspect original file
if ($#origfiletagids<0) {	if ($#origfiletagids<0) {
my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);	my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);
$origfile=&getfile($origfilelocation);	$origfile=&getfile($origfilelocation);
@origfiletagids=($origfile=~/<((?:\w+)response\|import\|part)[^>]id\s=\s[\"\']([^\"\']+)[\"\'][^>]>/gs);	@origfiletagids=($origfile=~/<((?:\w+)response\|import\|part)[^>]id\s=\s[\"\']([^\"\']+)[\"\'][^>]>/gs);
	}
}	}
}	}
}	}
Line 12843 sub metadata {	Line 13817 sub metadata {
# hash populated for imported library file	# hash populated for imported library file
%metaentry = %currmetaentry;	%metaentry = %currmetaentry;
undef(%currmetaentry);	undef(%currmetaentry);
if ($importmode eq 'problem') {	if ($importmode eq 'part') {
# Import as problem/response
$unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});
} elsif ($importmode eq 'part') {
# Import as part(s)	# Import as part(s)
$importedparts=1;	$importedparts=1;
# We need to get the original file and the imported file to get the part order correct	# We need to get the original file and the imported file to get the part order correct
Line 12861 sub metadata {	Line 13832 sub metadata {
@origfiletagids=($origfile=~/<(part\|import)[^>]id\s=\s[\"\']([^\"\']+)[\"\'][^>]>/gs);	@origfiletagids=($origfile=~/<(part\|import)[^>]id\s=\s[\"\']([^\"\']+)[\"\'][^>]>/gs);
}	}
}	}
	my @impfilepartids;
# Load and inspect imported file	# If <partorder> tag is included in metadata for the imported file
my $impfile=&getfile($location);	# get the parts in the imported file from that.
my @impfilepartids=($impfile=~/<part[^>]id\s=\s[\"\']([^\"\']+)[\"\'][^>]>/gs);	if (grep(/^partorder$/,@libfilekeys)) {
	%currmetaentry = %metaentry;
	my $libpartorder = &metadata($location,'partorder',undef,undef,undef,
	$depthcount+1);
	%metaentry = %currmetaentry;
	undef(%currmetaentry);
	if ($libpartorder ne '') {
	@impfilepartids=split(/\s,\s/,$libpartorder);
	}
	} else {
	# If no <partorder> tag available, load and inspect imported file
	my $impfile=&getfile($location);
	@impfilepartids=($impfile=~/<part[^>]id\s=\s[\"\']([^\"\']+)[\"\'][^>]>/gs);
	}
if ($#impfilepartids>=0) {	if ($#impfilepartids>=0) {
# This problem had parts	# This problem had parts
$importedpartids{$token->[2]->{'id'}}=join(',',@impfilepartids);	$importedpartids{$token->[2]->{'id'}}=join(',',@impfilepartids);
Line 12875 sub metadata {	Line 13859 sub metadata {
$importedpartids{$token->[2]->{'id'}}=$token->[2]->{'id'};	$importedpartids{$token->[2]->{'id'}}=$token->[2]->{'id'};
}	}
} else {	} else {
	# Import as problem or as normal import
	$unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});
	unless ($importmode eq 'problem') {
# Normal import	# Normal import
$unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});	if (defined($token->[2]->{'id'})) {
if (defined($token->[2]->{'id'})) {	$unikey.='_'.$token->[2]->{'id'};
$unikey.='_'.$token->[2]->{'id'};	}
}	}
	# Check metadata for imported file to
	# see if it contained parts
	if (grep(/^partorder$/,@libfilekeys)) {
	%currmetaentry = %metaentry;
	my $libpartorder = &metadata($location,'partorder',undef,undef,undef,
	$depthcount+1);
	%metaentry = %currmetaentry;
	undef(%currmetaentry);
	if ($libpartorder ne '') {
	$importedparts = 1;
	$importedpartids{$token->[2]->{'id'}}=$libpartorder;
	}
	}
}	}

if ($depthcount<20) {	if ($depthcount<20) {
my $metadata =	my $metadata =
&metadata($uri,'keys',$toolsymb,$location,$unikey,	&metadata($uri,'keys',$toolsymb,$location,$unikey,
Line 12890 sub metadata {	Line 13889 sub metadata {
$metaentry{':'.$meta}=$metaentry{':'.$meta};	$metaentry{':'.$meta}=$metaentry{':'.$meta};
$metathesekeys{$meta}=1;	$metathesekeys{$meta}=1;
}	}

}	}
} else {	} else {
#	#
Line 12980 sub metadata {	Line 13978 sub metadata {
$metathesekeys{'partorder'}=1;	$metathesekeys{'partorder'}=1;
}	}
if ($importedresponses) {	if ($importedresponses) {
# We had imported responses and need to rebuild responseorder	# We had imported responses and need to rebuil responseorder
$metaentry{':responseorder'}='';	$metaentry{':responseorder'}='';
$metathesekeys{'responseorder'}=1;	$metathesekeys{'responseorder'}=1;
}	}
Line 12994 sub metadata {	Line 13992 sub metadata {
} elsif ($origfiletagids[$index] eq 'import') {	} elsif ($origfiletagids[$index] eq 'import') {
if ($importedparts) {	if ($importedparts) {
# We have imported parts at this position	# We have imported parts at this position
$metaentry{':partorder'}.=','.$importedpartids{$origid};	if ($importedpartids{$origid} ne '') {
	$metaentry{':partorder'}.=','.$importedpartids{$origid};
	}
}	}
if ($importedresponses) {	if ($importedresponses) {
# We have imported responses at this position	# We have imported responses at this position
if (ref($importedrespids{$origid}) eq 'ARRAY') {	if ($importedrespids{$origid} ne '') {
$metaentry{':responseorder'}.=','.join(',',map { $origid.'_'.$_ } @{$importedrespids{$origid}});	$metaentry{':responseorder'}.=','.$importedrespids{$origid};
}	}
}	}
} else {	} else {
Line 13016 sub metadata {	Line 14016 sub metadata {
$metaentry{':responseorder'}=~s/^\,//;	$metaentry{':responseorder'}=~s/^\,//;
}	}
}	}

$metaentry{':keys'} = join(',',keys(%metathesekeys));	$metaentry{':keys'} = join(',',keys(%metathesekeys));
&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);	&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
$metaentry{':allpossiblekeys'}=join(',',keys(%metathesekeys));	$metaentry{':allpossiblekeys'}=join(',',keys(%metathesekeys));
&do_cache_new('meta',$uri,\%metaentry,$cachetime);	unless ($liburi) {
	&do_cache_new('meta',$uri,\%metaentry,$cachetime);
	}
# this is the end of "was not already recently cached	# this is the end of "was not already recently cached
}	}
return $metaentry{':'.$what};	return $metaentry{':'.$what};
Line 13176 sub get_reservable_slots {	Line 14177 sub get_reservable_slots {
sub get_course_slots {	sub get_course_slots {
my ($cnum,$cdom) = @_;	my ($cnum,$cdom) = @_;
my $hashid=$cnum.':'.$cdom;	my $hashid=$cnum.':'.$cdom;
my ($result,$cached) = &Apache::lonnet::is_cached_new('allslots',$hashid);	my ($result,$cached) = &is_cached_new('allslots',$hashid);
if (defined($cached)) {	if (defined($cached)) {
if (ref($result) eq 'HASH') {	if (ref($result) eq 'HASH') {
return %{$result};	return %{$result};
}	}
} else {	} else {
my %slots=&Apache::lonnet::dump('slots',$cdom,$cnum);	my %slots=&dump('slots',$cdom,$cnum);
my ($tmp) = keys(%slots);	my ($tmp) = keys(%slots);
if ($tmp !~ /^(con_lost\|error\|no_such_host)/i) {	if ($tmp !~ /^(con_lost\|error\|no_such_host)/i) {
&do_cache_new('allslots',$hashid,\%slots,600);	&do_cache_new('allslots',$hashid,\%slots,600);
Line 13350 sub symbverify {	Line 14351 sub symbverify {
$ids=$bighash{'ids_'.&clutter($thisurl)};	$ids=$bighash{'ids_'.&clutter($thisurl)};
}	}
unless ($ids) {	unless ($ids) {
my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl;	my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl;
$ids=$bighash{$idkey};	$ids=$bighash{$idkey};
}	}
if ($ids) {	if ($ids) {
Line 13366 sub symbverify {	Line 14367 sub symbverify {
if (ref($encstate)) {	if (ref($encstate)) {
$$encstate = $bighash{'encrypted_'.$id};	$$encstate = $bighash{'encrypted_'.$id};
}	}
if (($env{'request.role.adv'}) \|\|	if (($env{'request.role.adv'}) \|\|
($bighash{'encrypted_'.$id} eq $env{'request.enc'}) \|\|	($bighash{'encrypted_'.$id} eq $env{'request.enc'}) \|\|
($thisurl eq '/adm/navmaps')) {	($thisurl eq '/adm/navmaps')) {
$okay=1;	$okay=1;
last;	last;
}	}
}	}
}	}
}	}
untie(%bighash);	untie(%bighash);
}	}
Line 13461 sub symbread {	Line 14462 sub symbread {
unless ($thisfn) {	unless ($thisfn) {
if ($env{'request.symb'}) {	if ($env{'request.symb'}) {
return $env{$cache_str}=&symbclean($env{'request.symb'});	return $env{$cache_str}=&symbclean($env{'request.symb'});
}	}
$thisfn=$env{'request.filename'};	$thisfn=$env{'request.filename'};
}	}
if ($thisfn=~m\|^/enc/\|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }	if ($thisfn=~m\|^/enc/\|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
# is that filename actually a symb? Verify, clean, and return	# is that filename actually a symb? Verify, clean, and return
Line 13534 sub symbread {	Line 14535 sub symbread {
}	}
}	}
}	}
} elsif ((!$donotrecurse) \|\| ($checkforblock) \|\| (ref($possibles) eq 'HASH')) {	} elsif ((!$donotrecurse) \|\| ($checkforblock) \|\| (ref($possibles) eq 'HASH')) {
# ------------------------------------------ There is more than one possibility	# ------------------------------------------ There is more than one possibility
my $realpossible=0;	my $realpossible=0;
foreach my $id (@possibilities) {	foreach my $id (@possibilities) {
Line 13542 sub symbread {	Line 14543 sub symbread {
my $canaccess;	my $canaccess;
if (($donotrecurse) \|\| ($checkforblock) \|\| (ref($possibles) eq 'HASH')) {	if (($donotrecurse) \|\| ($checkforblock) \|\| (ref($possibles) eq 'HASH')) {
$canaccess = 1;	$canaccess = 1;
} else {	} else {
$canaccess = &allowed('bre',$file);	$canaccess = &allowed('bre',$file);
}	}
if ($canaccess) {	if ($canaccess) {
my ($mapid,$resid)=split(/\./,$id);	my ($mapid,$resid)=split(/\./,$id);
if ($bighash{'map_type_'.$mapid} ne 'page') {	if ($bighash{'map_type_'.$mapid} ne 'page') {
my $poss_syval=&encode_symb($bighash{'map_id_'.$mapid},	my $poss_syval=&encode_symb($bighash{'map_id_'.$mapid},
$resid,$thisfn);	$resid,$thisfn);
next if ($bighash{'randomout_'.$id} && !$env{'request.role.adv'});	next if ($bighash{'randomout_'.$id} && !$env{'request.role.adv'});
next unless (($noenccheck) \|\| ($bighash{'encrypted_'.$id} eq $env{'request.enc'}));	next unless (($noenccheck) \|\| ($bighash{'encrypted_'.$id} eq $env{'request.enc'}));
if ($checkforblock) {	if ($checkforblock) {
Line 13730 sub rndseed {	Line 14731 sub rndseed {
$which =&get_rand_alg($courseid);	$which =&get_rand_alg($courseid);
}	}
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);
} elsif ($which eq '64bit4') {	} elsif ($which eq '64bit4') {
Line 13915 sub rndseed_CODE_64bit5 {	Line 14917 sub rndseed_CODE_64bit5 {
sub setup_random_from_rndseed {	sub setup_random_from_rndseed {
my ($rndseed)=@_;	my ($rndseed)=@_;
if ($rndseed =~/([,:])/) {	if ($rndseed =~/([,:])/) {
my ($num1,$num2) = map { abs($_); } (split(/[,:]/,$rndseed));	my ($num1,$num2) = map { abs($_); } (split(/[,:]/,$rndseed));
if ((!$num1) \|\| (!$num2) \|\| ($num1 > 2147483562) \|\| ($num2 > 2147483398)) {	if ((!$num1) \|\| (!$num2) \|\| ($num1 > 2147483562) \|\| ($num2 > 2147483398)) {
&Math::Random::random_set_seed_from_phrase($rndseed);	&Math::Random::random_set_seed_from_phrase($rndseed);
} else {	} else {
Line 14099 sub repcopy_userfile {	Line 15101 sub repcopy_userfile {
}	}
# now the path exists for sure	# now the path exists for sure
# get a user agent	# get a user agent
my $ua=new LWP::UserAgent;
my $transferfile=$file.'.in.transfer';	my $transferfile=$file.'.in.transfer';
# FIXME: this should flock	# FIXME: this should flock
if (-e $transferfile) { return 'ok'; }	if (-e $transferfile) { return 'ok'; }
Line 14110 sub repcopy_userfile {	Line 15111 sub repcopy_userfile {
my $protocol = $protocol{$homeserver};	my $protocol = $protocol{$homeserver};
$protocol = 'http' if ($protocol ne 'https');	$protocol = 'http' if ($protocol ne 'https');
$request=new HTTP::Request('GET',$protocol.'://'.$hostname.'/raw/'.$uri);	$request=new HTTP::Request('GET',$protocol.'://'.$hostname.'/raw/'.$uri);
my $response=$ua->request($request,$transferfile);	my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,$transferfile,\%perlvar,'',0,1);
# did it work?	# did it work?
if ($response->is_error()) {	if ($response->is_error()) {
unlink($transferfile);	unlink($transferfile);
Line 14156 sub getuploaded {	Line 15157 sub getuploaded {
my $protocol = $protocol{$homeserver};	my $protocol = $protocol{$homeserver};
$protocol = 'http' if ($protocol ne 'https');	$protocol = 'http' if ($protocol ne 'https');
$uri = $protocol.'://'.$hostname.'/raw/'.$uri;	$uri = $protocol.'://'.$hostname.'/raw/'.$uri;
my $ua=new LWP::UserAgent;
my $request=new HTTP::Request($reqtype,$uri);	my $request=new HTTP::Request($reqtype,$uri);
my $response=$ua->request($request);	my $response=&LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,'',0,1);
$$rtncode = $response->code;	$$rtncode = $response->code;
if (! $response->is_success()) {	if (! $response->is_success()) {
return 'failed';	return 'failed';
Line 14290 sub additional_machine_domains {	Line 15290 sub additional_machine_domains {
my @domains;	my @domains;
if (-e "$perlvar{'lonTabDir'}/expected_domains.tab") {	if (-e "$perlvar{'lonTabDir'}/expected_domains.tab") {
if (open(my $fh,"<","$perlvar{'lonTabDir'}/expected_domains.tab")) {	if (open(my $fh,"<","$perlvar{'lonTabDir'}/expected_domains.tab")) {
while( my $line = <$fh>) {	while (my $line = <$fh>) {
chomp($line);	chomp($line);
$line =~ s/\s//g;	$line =~ s/\s//g;
push(@domains,$line);	push(@domains,$line);
}	}
Line 14351 sub uses_sts {	Line 15351 sub uses_sts {
return $sts_on;	return $sts_on;
}	}
}	}
my $ua=new LWP::UserAgent;
my $url = $protocol{$lonhost}.'://'.$hostname.'/index.html';	my $url = $protocol{$lonhost}.'://'.$hostname.'/index.html';
my $request=new HTTP::Request('HEAD',$url);	my $request=new HTTP::Request('HEAD',$url);
my $response=$ua->request($request);	my $response=&LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,'','','',1);
if ($response->is_success) {	if ($response->is_success) {
my $has_sts = $response->header('Strict-Transport-Security');	my $has_sts = $response->header('Strict-Transport-Security');
if ($has_sts eq '') {	if ($has_sts eq '') {
Line 14411 sub get_requestor_ip {	Line 15410 sub get_requestor_ip {
} else {	} else {
$from_ip = $ENV{'REMOTE_ADDR'};	$from_ip = $ENV{'REMOTE_ADDR'};
}	}
return $from_ip if ($noproxy);	return $from_ip if ($noproxy);
# Who controls proxy settings for server	# Who controls proxy settings for server
my $dom_in_use = $Apache::lonnet::perlvar{'lonDefDomain'};	my $dom_in_use = $Apache::lonnet::perlvar{'lonDefDomain'};
my $proxyinfo = &get_proxy_settings($dom_in_use);	my $proxyinfo = &get_proxy_settings($dom_in_use);
if ((ref($proxyinfo) eq 'HASH') && ($from_ip)) {	if ((ref($proxyinfo) eq 'HASH') && ($from_ip)) {
Line 14455 sub get_requestor_ip {	Line 15454 sub get_requestor_ip {

sub get_proxy_settings {	sub get_proxy_settings {
my ($dom_in_use) = @_;	my ($dom_in_use) = @_;
my %domdefaults = &Apache::lonnet::get_domain_defaults($dom_in_use);	my %domdefaults = &get_domain_defaults($dom_in_use);
my $proxyinfo = {	my $proxyinfo = {
ipheader => $domdefaults{'waf_ipheader'},	ipheader => $domdefaults{'waf_ipheader'},
trusted => $domdefaults{'waf_trusted'},	trusted => $domdefaults{'waf_trusted'},
Line 14488 sub get_proxy_alias {	Line 15487 sub get_proxy_alias {
if ($cached) {	if ($cached) {
return $alias;	return $alias;
}	}
my $dom = &Apache::lonnet::host_domain($lonid);	my $dom = &host_domain($lonid);
if ($dom ne '') {	if ($dom ne '') {
my $cachetime = 606024;	my $cachetime = 606024;
my %domconfig =	my %domconfig =
&Apache::lonnet::get_dom('configuration',['wafproxy'],$dom);	&get_dom('configuration',['wafproxy'],$dom);
if (ref($domconfig{'wafproxy'}) eq 'HASH') {	if (ref($domconfig{'wafproxy'}) eq 'HASH') {
if (ref($domconfig{'wafproxy'}{'alias'}) eq 'HASH') {	if (ref($domconfig{'wafproxy'}{'alias'}) eq 'HASH') {
$alias = $domconfig{'wafproxy'}{'alias'}{$lonid};	$alias = $domconfig{'wafproxy'}{'alias'}{$lonid};
Line 14539 sub alias_sso {	Line 15538 sub alias_sso {
if ($cached) {	if ($cached) {
return $use_alias;	return $use_alias;
}	}
my $dom = &Apache::lonnet::host_domain($lonid);	my $dom = &host_domain($lonid);
if ($dom ne '') {	if ($dom ne '') {
my $cachetime = 606024;	my $cachetime = 606024;
my %domconfig =	my %domconfig =
&Apache::lonnet::get_dom('configuration',['wafproxy'],$dom);	&get_dom('configuration',['wafproxy'],$dom);
if (ref($domconfig{'wafproxy'}) eq 'HASH') {	if (ref($domconfig{'wafproxy'}) eq 'HASH') {
if (ref($domconfig{'wafproxy'}{'saml'}) eq 'HASH') {	if (ref($domconfig{'wafproxy'}{'saml'}) eq 'HASH') {
$use_alias = $domconfig{'wafproxy'}{'saml'}{$lonid};	$use_alias = $domconfig{'wafproxy'}{'saml'}{$lonid};
Line 14571 sub get_saml_landing {	Line 15570 sub get_saml_landing {
$lonid = $perlvar{'lonHostID'};	$lonid = $perlvar{'lonHostID'};
}	}
if ($lonid) {	if ($lonid) {
unless (&Apache::lonnet::host_domain($lonid) eq $defdom) {	unless (&host_domain($lonid) eq $defdom) {
return;	return;
}	}
} else {	} else {
Line 14584 sub get_saml_landing {	Line 15583 sub get_saml_landing {
if ($cached) {	if ($cached) {
return $landing;	return $landing;
}	}
my $dom = &Apache::lonnet::host_domain($lonid);	my $dom = &host_domain($lonid);
if ($dom ne '') {	if ($dom ne '') {
my $cachetime = 606024;	my $cachetime = 606024;
my %domconfig =	my %domconfig =
&Apache::lonnet::get_dom('configuration',['login'],$dom);	&get_dom('configuration',['login'],$dom);
if (ref($domconfig{'login'}) eq 'HASH') {	if (ref($domconfig{'login'}) eq 'HASH') {
if (ref($domconfig{'login'}{'saml'}) eq 'HASH') {	if (ref($domconfig{'login'}{'saml'}) eq 'HASH') {
if (ref($domconfig{'login'}{'saml'}{$lonid}) eq 'HASH') {	if (ref($domconfig{'login'}{'saml'}{$lonid}) eq 'HASH') {
Line 14718 sub get_dns {	Line 15717 sub get_dns {
my ($url,$func,$ignore_cache,$nocache,$hashref) = @_;	my ($url,$func,$ignore_cache,$nocache,$hashref) = @_;
if (!$ignore_cache) {	if (!$ignore_cache) {
my ($content,$cached)=	my ($content,$cached)=
&Apache::lonnet::is_cached_new('dns',$url);	&is_cached_new('dns',$url);
if ($cached) {	if ($cached) {
&$func($content,$hashref);	&$func($content,$hashref);
return;	return;
Line 14740 sub get_dns {	Line 15739 sub get_dns {
}	}
while (%alldns) {	while (%alldns) {
my ($dns) = sort { $b cmp $a } keys(%alldns);	my ($dns) = sort { $b cmp $a } keys(%alldns);
my @content;	my ($contents,@content);
if ($dns eq Sys::Hostname::FQDN::fqdn()) {	if ($dns eq Sys::Hostname::FQDN::fqdn()) {
my $command = (split('/',$url))[3];	my $command = (split('/',$url))[3];
my ($dir,$file) = &parse_getdns_url($command,$url);	my ($dir,$file) = &parse_getdns_url($command,$url);
Line 14750 sub get_dns {	Line 15749 sub get_dns {
@content = <$config>;	@content = <$config>;
close($config);	close($config);
}	}
	if ($url eq '/adm/dns/loncapaCRL') {
	$contents = join('',@content);
	}
} else {	} else {
my $ua=new LWP::UserAgent;
$ua->timeout(30);
my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");	my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
my $response=$ua->request($request);	my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar,30,0);
delete($alldns{$dns});	delete($alldns{$dns});
next if ($response->is_error());	next if ($response->is_error());
@content = split("\n",$response->content);	if ($url eq '/adm/dns/loncapaCRL') {
	$contents = $response->content;
	} else {
	@content = split("\n",$response->content);
	}
}	}
unless ($nocache) {	if ($url eq '/adm/dns/loncapaCRL') {
&do_cache_new('dns',$url,\@content,302460*60);	return &$func($contents);
	} else {
	unless ($nocache) {
	&do_cache_new('dns',$url,\@content,302460*60);
	}
	&$func(\@content,$hashref);
	return;
}	}
&$func(\@content,$hashref);
return;
}	}
my $which = (split('/',$url))[3];	my $which = (split('/',$url,4))[3];
&logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n");	if ($which eq 'loncapaCRL') {
if (open(my $config,"<","$perlvar{'lonTabDir'}/dns_$which.tab")) {	my $diskfile = "$perlvar{'lonCertificateDirectory'}/$perlvar{'lonnetCertRevocationList'}";
my @content = <$config>;	if (-e $diskfile) {
&$func(\@content,$hashref);	&logthis("unable to contact DNS, on disk file $diskfile not updated");
	} else {
	&logthis("unable to contact DNS, no on disk file $diskfile available");
	}
	} else {
	&logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n");
	if (open(my $config,"<","$perlvar{'lonTabDir'}/dns_$which.tab")) {
	my @content = <$config>;
	close($config);
	&$func(\@content,$hashref);
	}
}	}
return;	return;
}	}
Line 14778 sub get_dns {	Line 15796 sub get_dns {
sub parse_dns_checksums_tab {	sub parse_dns_checksums_tab {
my ($lines,$hashref) = @_;	my ($lines,$hashref) = @_;
my $lonhost = $perlvar{'lonHostID'};	my $lonhost = $perlvar{'lonHostID'};
my $machine_dom = &Apache::lonnet::host_domain($lonhost);	my $machine_dom = &host_domain($lonhost);
my $loncaparev = &get_server_loncaparev($machine_dom);	my $loncaparev = &get_server_loncaparev($machine_dom);
my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0];	my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0];
my $webconfdir = '/etc/httpd/conf';	my $webconfdir = '/etc/httpd/conf';
Line 14798 sub parse_dns_checksums_tab {	Line 15816 sub parse_dns_checksums_tab {
if (ref($lines) eq 'ARRAY') {	if (ref($lines) eq 'ARRAY') {
chomp(@{$lines});	chomp(@{$lines});
my $version = shift(@{$lines});	my $version = shift(@{$lines});
if ($version eq $release) {	if ($version eq $release) {
foreach my $line (@{$lines}) {	foreach my $line (@{$lines}) {
my ($file,$version,$shasum) = split(/,/,$line);	my ($file,$version,$shasum) = split(/,/,$line);
if ($file =~ m{^/etc/httpd/conf}) {	if ($file =~ m{^/etc/httpd/conf}) {
Line 14822 sub parse_dns_checksums_tab {	Line 15840 sub parse_dns_checksums_tab {

sub fetch_dns_checksums {	sub fetch_dns_checksums {
my %checksums;	my %checksums;
my $machine_dom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});	my $machine_dom = &host_domain($perlvar{'lonHostID'});
my $loncaparev = &get_server_loncaparev($machine_dom,$perlvar{'lonHostID'});	my $loncaparev = &get_server_loncaparev($machine_dom,$perlvar{'lonHostID'});
my ($release,$timestamp) = split(/\-/,$loncaparev);	my ($release,$timestamp) = split(/\-/,$loncaparev);
&get_dns("/adm/dns/checksums/$release",\&parse_dns_checksums_tab,1,1,	&get_dns("/adm/dns/checksums/$release",\&parse_dns_checksums_tab,1,1,
Line 14830 sub fetch_dns_checksums {	Line 15848 sub fetch_dns_checksums {
return \%checksums;	return \%checksums;
}	}

	sub fetch_crl_pemfile {
	return &get_dns("/adm/dns/loncapaCRL",\&save_crl_pem,1,1);
	}

	sub save_crl_pem {
	my ($content) = @_;
	my ($msg,$hadchanges);
	if ($content ne '') {
	my $now = time;
	my $lonca = $perlvar{'lonCertificateDirectory'}.'/'.$perlvar{'lonnetCertificateAuthority'};
	my $tmpcrl = $tmpdir.'/'.$perlvar{'lonnetCertRevocationList'}.'_'.$now.'.'.$$.'.tmp';
	if (open(my $fh,'>',"$tmpcrl")) {
	print $fh $content;
	close($fh);
	if (-e $lonca) {
	if (open(PIPE,"openssl crl -in $tmpcrl -inform pem -CAfile $lonca -noout 2>&1 \|")) {
	my $check = <PIPE>;
	close(PIPE);
	chomp($check);
	if ($check eq 'verify OK') {
	my $dest = "$perlvar{'lonCertificateDirectory'}/$perlvar{'lonnetCertRevocationList'}";
	my $backup;
	if (-e $dest) {
	if (&File::Copy::move($dest,"$dest.bak")) {
	$backup = 'ok';
	}
	}
	if (&File::Copy::move($tmpcrl,$dest)) {
	$msg = 'ok';
	if ($backup) {
	my (%oldnums,%newnums);
	if (open(PIPE, "openssl crl -inform PEM -text -noout -in $dest.bak \|grep 'Serial Number' \|")) {
	while (<PIPE>) {
	$oldnums{(split(/:/))[1]} = 1;
	}
	close(PIPE);
	}
	if (open(PIPE, "openssl crl -inform PEM -text -noout -in $dest \|grep 'Serial Number' \|")) {
	while(<PIPE>) {
	$newnums{(split(/:/))[1]} = 1;
	}
	close(PIPE);
	}
	foreach my $key (sort {$b <=> $a } (keys(%newnums))) {
	unless (exists($oldnums{$key})) {
	$hadchanges = 1;
	last;
	}
	}
	unless ($hadchanges) {
	foreach my $key (sort {$b <=> $a } (keys(%oldnums))) {
	unless (exists($newnums{$key})) {
	$hadchanges = 1;
	last;
	}
	}
	}
	}
	}
	} else {
	unlink($tmpcrl);
	}
	} else {
	unlink($tmpcrl);
	}
	} else {
	unlink($tmpcrl);
	}
	}
	}
	return ($msg,$hadchanges);
	}

sub parse_getdns_url {	sub parse_getdns_url {
my ($command,$url) = @_;	my ($command,$url) = @_;
my $dir = $perlvar{'lonTabDir'};	my $dir = $perlvar{'lonTabDir'};
Line 14841 sub parse_getdns_url {	Line 15932 sub parse_getdns_url {
} elsif ($command eq 'checksums') {	} elsif ($command eq 'checksums') {
my $version = (split('/',$url))[4];	my $version = (split('/',$url))[4];
$file = "dns_checksums/$version.tab",	$file = "dns_checksums/$version.tab",
	} elsif ($command eq 'loncapaCRL') {
	$dir = $perlvar{'lonCertificateDirectory'};
	$file = $perlvar{'lonnetCertRevocationList'};
}	}
return ($dir,$file);	return ($dir,$file);
}	}
Line 14967 sub parse_getdns_url {	Line 16061 sub parse_getdns_url {
&purge_remembered();	&purge_remembered();
&reset_domain_info();	&reset_domain_info();
&reset_hosts_ip_info();	&reset_hosts_ip_info();
	undef(%internetdom);
undef(%name_to_host);	undef(%name_to_host);
undef(%hostname);	undef(%hostname);
undef(%hostdom);	undef(%hostdom);
Line 15009 sub parse_getdns_url {	Line 16104 sub parse_getdns_url {
return %hostdom;	return %hostdom;
}	}

	sub all_host_intdom {
	&load_hosts_tab() if (!$loaded);
	return %internetdom;
	}

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

Line 15128 sub parse_getdns_url {	Line 16228 sub parse_getdns_url {
return %iphost;	return %iphost;
}	}
my ($ip_info,$cached)=	my ($ip_info,$cached)=
&Apache::lonnet::is_cached_new('iphost','iphost');	&is_cached_new('iphost','iphost');
if ($cached) {	if ($cached) {
%iphost = %{$ip_info->[0]};	%iphost = %{$ip_info->[0]};
%name_to_ip = %{$ip_info->[1]};	%name_to_ip = %{$ip_info->[1]};
Line 15140 sub parse_getdns_url {	Line 16240 sub parse_getdns_url {
# get yesterday's info for fallback	# get yesterday's info for fallback
my %old_name_to_ip;	my %old_name_to_ip;
my ($ip_info,$cached)=	my ($ip_info,$cached)=
&Apache::lonnet::is_cached_new('iphost','iphost');	&is_cached_new('iphost','iphost');
if ($cached) {	if ($cached) {
%old_name_to_ip = %{$ip_info->[1]};	%old_name_to_ip = %{$ip_info->[1]};
}	}
Line 15207 sub parse_getdns_url {	Line 16307 sub parse_getdns_url {
my ($lonid) = @_;	my ($lonid) = @_;
return if ($lonid eq '');	return if ($lonid eq '');
my ($idnref,$cached)=	my ($idnref,$cached)=
&Apache::lonnet::is_cached_new('internetnames',$lonid);	&is_cached_new('internetnames',$lonid);
if ($cached) {	if ($cached) {
return $idnref;	return $idnref;
}	}
Line 15239 sub all_loncaparevs {	Line 16339 sub all_loncaparevs {
return qw(1.1 1.2 1.3 2.0 2.1 2.2 2.3 2.4 2.5 2.6 2.7 2.8 2.9 2.10 2.11);	return qw(1.1 1.2 1.3 2.0 2.1 2.2 2.3 2.4 2.5 2.6 2.7 2.8 2.9 2.10 2.11);
}	}

# ------------------------------------------------------- Read loncaparev table	# ---------------------------------------------------------- Read loncaparev table
{	{
sub load_loncaparevs {	sub load_loncaparevs {
if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") {	if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") {
if (open(my $config,"<","$perlvar{'lonTabDir'}/loncaparevs.tab")) {	if (open(my $config,"<","$perlvar{'lonTabDir'}/loncaparevs.tab")) {
while (my $configline=<$config>) {	while (my $configline=<$config>) {
Line 15255 sub all_loncaparevs {	Line 16355 sub all_loncaparevs {
}	}
}	}

# ----------------------------------------------------- Read serverhostID table	# ---------------------------------------------------------- Read serverhostID table
{	{
sub load_serverhomeIDs {	sub load_serverhomeIDs {
if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") {	if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") {
Line 15347 BEGIN {	Line 16447 BEGIN {
close($config);	close($config);
}	}

# --------------------------------------------------------- Read loncaparev table	# ---------------------------------------------------------- Read loncaparev table

&load_loncaparevs();	&load_loncaparevs();

# ------------------------------------------------------- Read serverhostID table	# ---------------------------------------------------------- Read serverhostID table

&load_serverhomeIDs();	&load_serverhomeIDs();

Line 15365 BEGIN {	Line 16465 BEGIN {
my $item = $token->[1];	my $item = $token->[1];
my $name = $token->[2]{'name'};	my $name = $token->[2]{'name'};
my $value = $token->[2]{'value'};	my $value = $token->[2]{'value'};
if ($item ne '' && $name ne '' && $value ne '') {	my $valuematch = $token->[2]{'valuematch'};
	my $namematch = $token->[2]{'namematch'};
	if ($item eq 'parameter') {
	if (($namematch ne '') \|\| (($name ne '') && ($value ne '' \|\| $valuematch ne ''))) {
	my $release = $parser->get_text();
	$release =~ s/(^\s\|\s$ )//gx;
	$needsrelease{$item.':'.$name.':'.$value.':'.$valuematch.':'.$namematch} = $release;
	}
	} elsif ($item ne '' && $name ne '') {
my $release = $parser->get_text();	my $release = $parser->get_text();
$release =~ s/(^\s\|\s$ )//gx;	$release =~ s/(^\s\|\s$ )//gx;
$needsrelease{$item.':'.$name.':'.$value} = $release;	$needsrelease{$item.':'.$name.':'.$value} = $release;
Line 15648 the answer, and also caches if there is	Line 16756 the answer, and also caches if there is

=item *	=item *
X<idget()>	X<idget()>
B<idget($udom,@ids)>: find the usernames behind a list of IDs	B<idget($udom,$idsref,$namespace)>: find the usernames behind either
(IDs are a unique resource in a domain, there must be only 1 ID per	a list of student/employee IDs or clicker IDs
username, and only 1 username per ID in a specific domain) (returns	(student/employee IDs are a unique resource in a domain, there must be
hash: id=>name,id=>name)	only 1 ID per username, and only 1 username per ID in a specific domain).
	clickerIDs are not necessarily unique, as students might share clickers.
	(returns hash: id=>name,id=>name)

=item *	=item *
X<idrget()>	X<idrget()>
Line 15660 usernames (returns hash: name=>id,name=>	Line 16770 usernames (returns hash: name=>id,name=>

=item *	=item *
X<idput()>	X<idput()>
B<idput($udom,%ids)>: store away a list of names and associated IDs	B<idput($udom,$idsref,$uhome,$namespace)>: store away a list of
	names and associated student/employee IDs or clicker IDs.

	=item *
	X<iddel()>
	B<iddel($udom,$idshashref,$uhome,$namespace)>: delete unwanted
	student/employee ID or clicker ID username look-ups from domain.
	The homeserver ($uhome) and namespace ($namespace) are optional.
	If no $uhome is provided, it will be determined usig &homeserver()
	for each user. If no $namespace is provided, the default is ids.

	=item *
	X<updateclickers()>
	B<updateclickers($udom,$action,$idshashref,$uhome,$critical)>: update
	clicker ID-to-username look-ups in clickers.db on library server.
	Permitted actions are add or del (i.e., add or delete). The
	clickers.db contains clickerID as keys (escaped), and each corresponding
	value is an escaped comma-separated list of usernames (for whom the
	library server is the homeserver), who registered that particular ID.
	If $critical is true, the update will be sent via &critical, otherwise
	&reply() will be used.

=item *	=item *
X<rolesinit()>	X<rolesinit()>
Line 15708 The first argument is required, all othe	Line 16838 The first argument is required, all othe

$priv is the privilege being checked.	$priv is the privilege being checked.
$uri contains additional information about what is being checked for access (e.g.,	$uri contains additional information about what is being checked for access (e.g.,
URL, course ID etc.).	URL, course ID etc.).
$symb is the unique resource instance identifier in a course; if needed,	$symb is the unique resource instance identifier in a course; if needed,
but not provided, it will be retrieved via a call to &symbread().	but not provided, it will be retrieved via a call to &symbread().
$role is the role for which a priv is being checked (only used if priv is evb).	$role is the role for which a priv is being checked (only used if priv is evb).
$clientip is the user's IP address (only used when checking for access to portfolio	$clientip is the user's IP address (only used when checking for access to portfolio
files).	files).
$noblockcheck, if true, skips calls to &has_comm_blocking() for the bre priv. This	$noblockcheck, if true, skips calls to &has_comm_blocking() for the bre priv. This
prevents recursive calls to &allowed.	prevents recursive calls to &allowed.

F: full access	F: full access
Line 15724 prevents recursive calls to &allowed.	Line 16854 prevents recursive calls to &allowed.
2: browse allowed	2: browse allowed
A: passphrase authentication needed	A: passphrase authentication needed
B: access temporarily blocked because of a blocking event in a course.	B: access temporarily blocked because of a blocking event in a course.
D: access blocked because access is required via session initiated via deep-link	D: access blocked because access is required via session initiated via deep-link

=item *	=item *

Line 15777 provided for types, will default to retu	Line 16907 provided for types, will default to retu
=item *	=item *

in_course($udom,$uname,$cdom,$cnum,$type,$hideprivileged) : determine if	in_course($udom,$uname,$cdom,$cnum,$type,$hideprivileged) : determine if
user: $uname:$udom has a role in the course: $cdom_$cnum.	user: $uname:$udom has a role in the course: $cdom_$cnum.

Additional optional arguments are: $type (if role checking is to be restricted	Additional optional arguments are: $type (if role checking is to be restricted
to certain user status types -- previous (expired roles), active (currently	to certain user status types -- previous (expired roles), active (currently
available roles) or future (roles available in the future), and	available roles) or future (roles available in the future), and
$hideprivileged -- if true will not report course roles for users who	$hideprivileged -- if true will not report course roles for users who
Line 16187 condval($condidx) : value of condition i	Line 17317 condval($condidx) : value of condition i
metadata($uri,$what,$toolsymb,$liburi,$prefix,$depthcount) : request a	metadata($uri,$what,$toolsymb,$liburi,$prefix,$depthcount) : request a
resource's metadata, $what should be either a specific key, or either	resource's metadata, $what should be either a specific key, or either
'keys' (to get a list of possible keys) or 'packages' to get a list of	'keys' (to get a list of possible keys) or 'packages' to get a list of
packages that this resource currently uses, the last 3 arguments are	packages that this resource currently uses, the last 3 arguments are
only used internally for recursive metadata.	only used internally for recursive metadata.

the toolsymb is only used where the uri is for an external tool (for which	the toolsymb is only used where the uri is for an external tool (for which
the uri as well as the symb are guaranteed to be unique).	the uri as well as the symb are guaranteed to be unique).

this function automatically caches all requests	this function automatically caches all requests except any made recursively
	to retrieve a list of metadata keys for an imported library file ($liburi is
	defined).

=item *	=item *

Line 16203 will be stored for query	Line 17335 will be stored for query

=item *	=item *

symbread($filename,$donotrecurse,$ignorecachednull,$checkforblock,$possibles) :	symbread($filename,$donotrecurse,$ignorecachednull,$checkforblock,$possibles) :
return symbolic list entry (all arguments optional).	return symbolic list entry (all arguments optional).

Args: filename is the filename (including path) for the file for which a symb	Args: filename is the filename (including path) for the file for which a symb
is required; donotrecurse, if true will prevent calls to allowed() being made	is required; donotrecurse, if true will prevent calls to allowed() being made
to check access status if more than one resource was found in the bighash	to check access status if more than one resource was found in the bighash
(see rev. 1.249) to avoid an infinite loop if an ambiguous resource is part of	(see rev. 1.249) to avoid an infinite loop if an ambiguous resource is part of
a randompick); ignorecachednull, if true will prevent a symb of '' being	a randompick); ignorecachednull, if true will prevent a symb of '' being
returned if $env{$cache_str} is defined as ''; checkforblock if true will	returned if $env{$cache_str} is defined as ''; checkforblock if true will
cause possible symbs to be checked to determine if they are subject to content	cause possible symbs to be checked to determine if they are subject to content
blocking, if so they will not be included as possible symbs; possibles is a	blocking, if so they will not be included as possible symbs; possibles is a
ref to a hash, which, as a side effect, will be populated with all possible	ref to a hash, which, as a side effect, will be populated with all possible
symbs (content blocking not tested).	symbs (content blocking not tested).

returns the data handle	returns the data handle

=item *	=item *
Line 16226 and is a possible symb for the URL in $t	Line 17358 and is a possible symb for the URL in $t
resource that the user accessed using /enc/ returns a 1 on success, 0	resource that the user accessed using /enc/ returns a 1 on success, 0
on failure, user must be in a course, as it assumes the existence of	on failure, user must be in a course, as it assumes the existence of
the course initial hash, and uses $env('request.course.id'}. The third	the course initial hash, and uses $env('request.course.id'}. The third
arg is an optional reference to a scalar. If this arg is passed in the	arg is an optional reference to a scalar. If this arg is passed in the
call to symbverify, it will be set to 1 if the symb has been set to be	call to symbverify, it will be set to 1 if the symb has been set to be
encrypted; otherwise it will be null.	encrypted; otherwise it will be null.

=item *	=item *

Line 16281 expirespread($uname,$udom,$stype,$usymb)	Line 17413 expirespread($uname,$udom,$stype,$usymb)
devalidate($symb) : devalidate temporary spreadsheet calculations,	devalidate($symb) : devalidate temporary spreadsheet calculations,
forcing spreadsheet to reevaluate the resource scores next time.	forcing spreadsheet to reevaluate the resource scores next time.

=item *	=item *

can_edit_resource($file,$cnum,$cdom,$resurl,$symb,$group) : determine if current user can edit a particular resource,	can_edit_resource($file,$cnum,$cdom,$resurl,$symb,$group) : determine if current user can edit a particular resource,
when viewing in course context.	when viewing in course context.

input: six args -- filename (decluttered), course number, course domain,	input: six args -- filename (decluttered), course number, course domain,
url, symb (if registered) and group (if this is a	url, symb (if registered) and group (if this is a
group item -- e.g., bulletin board, group page etc.).	group item -- e.g., bulletin board, group page etc.).

output: array of five scalars --	output: array of five scalars --
Line 16295 when viewing in course context.	Line 17427 when viewing in course context.
$home -- homeserver of resource (i.e., for author if published,	$home -- homeserver of resource (i.e., for author if published,
or course if uploaded.).	or course if uploaded.).
$switchserver -- 1 if server switch will be needed.	$switchserver -- 1 if server switch will be needed.
$forceedit -- 1 if icon/link should be to go to edit mode	$forceedit -- 1 if icon/link should be to go to edit mode
$forceview -- 1 if icon/link should be to go to view mode	$forceview -- 1 if icon/link should be to go to view mode

=item *	=item *

is_course_upload($file,$cnum,$cdom)	is_course_upload($file,$cnum,$cdom)

Used in course context to determine if current file was uploaded to	Used in course context to determine if current file was uploaded to
the course (i.e., would be found in /userfiles/docs on the course's	the course (i.e., would be found in /userfiles/docs on the course's
homeserver.	homeserver.

input: 3 args -- filename (decluttered), course number and course domain.	input: 3 args -- filename (decluttered), course number and course domain.
Line 16317 homeserver.	Line 17449 homeserver.

=item *	=item *

store($storehash,$symb,$namespace,$udom,$uname,$laststore) : stores hash	store($storehash,$symb,$namespace,$udom,$uname,$laststore) : stores hash
permanently for this url; hashref needs to be given and should be a \%hashname;	permanently for this url; hashref needs to be given and should be a \%hashname;
the remaining args aren't required and if they aren't passed or are '' they will	the remaining args aren't required and if they aren't passed or are '' they will
be derived from the env (with the exception of $laststore, which is an	be derived from the env (with the exception of $laststore, which is an
optional arg used when a user's submission is stored in grading).	optional arg used when a user's submission is stored in grading).
$laststore is $version=$timestamp, where $version is the most recent version	$laststore is $version=$timestamp, where $version is the most recent version
number retrieved for the corresponding $symb in the $namespace db file, and	number retrieved for the corresponding $symb in the $namespace db file, and
$timestamp is the timestamp for that transaction (UNIX time).	$timestamp is the timestamp for that transaction (UNIX time).
$laststore is currently only passed when cstore() is called by	$laststore is currently only passed when cstore() is called by
structuretags::finalize_storage().	structuretags::finalize_storage().

=item *	=item *

cstore($storehash,$symb,$namespace,$udom,$uname,$laststore) : same as store	cstore($storehash,$symb,$namespace,$udom,$uname,$laststore) : same as store
but uses critical subroutine	but uses critical subroutine

=item *	=item *
Line 16468 server ($udom and $uhome are optional)	Line 17600 server ($udom and $uhome are optional)

=item *	=item *

get_domain_defaults($target_domain,$ignore_cache) : returns hash with defaults	get_domain_defaults($target_domain,$ignore_cache) : returns hash with defaults
for: authentication, language, quotas, timezone, date locale, and portal URL in	for: authentication, language, quotas, timezone, date locale, and portal URL in
the target domain.	the target domain.

Line 16502 requestcourses: ability to request cours	Line 17634 requestcourses: ability to request cours
=over	=over

=item	=item
official, unofficial, community, textbook	official, unofficial, community, textbook, placement

=back	=back

Line 16523 for course's uploaded content.	Line 17655 for course's uploaded content.
=over	=over

=item	=item
canuse_pdfforms, officialcredits, unofficialcredits, textbookcredits, officialquota, unofficialquota,	canuse_pdfforms, officialcredits, unofficialcredits, textbookcredits, officialquota, unofficialquota,
communityquota, textbookquota	communityquota, textbookquota, placementquota

=back	=back

Line 16534 on your servers.	Line 17666 on your servers.

=over	=over

=item	=item
remotesessions, hostedsessions	remotesessions, hostedsessions

=back	=back
Line 16542 remotesessions, hostedsessions	Line 17674 remotesessions, hostedsessions
=back	=back

In cases where a domain coordinator has never used the "Set Domain Configuration"	In cases where a domain coordinator has never used the "Set Domain Configuration"
utility to create a configuration.db file on a domain's primary library server	utility to create a configuration.db file on a domain's primary library server
only the following domain defaults: auth_def, auth_arg_def, lang_def	only the following domain defaults: auth_def, auth_arg_def, lang_def
-- corresponding values are authentication type (internal, krb4, krb5,	-- corresponding values are authentication type (internal, krb4, krb5,
or localauth), initial password or a kerberos realm, language (e.g., en-us) --	or localauth), initial password or a kerberos realm, language (e.g., en-us) --
will be available. Values are retrieved from cache (if current), unless the	will be available. Values are retrieved from cache (if current), unless the
optional $ignore_cache arg is true, or from domain's configuration.db (if available),	optional $ignore_cache arg is true, or from domain's configuration.db (if available),
or lastly from values in lonTabs/dns_domain,tab, or lonTabs/domain.tab.	or lastly from values in lonTabs/dns_domain,tab, or lonTabs/domain.tab.
Line 16974 Returns:	Line 18106 Returns:

get_timebased_id():	get_timebased_id():

Attempts to get a unique timestamp-based suffix for use with items added to a	Attempts to get a unique timestamp-based suffix for use with items added to a
course via the Course Editor (e.g., folders, composite pages,	course via the Course Editor (e.g., folders, composite pages,
group bulletin boards).	group bulletin boards).

Args: (first three required; six others optional)	Args: (first three required; six others optional)
Line 16986 Args: (first three required; six others	Line 18118 Args: (first three required; six others
2. keyid (alphanumeric): name of temporary locking key in hash,	2. keyid (alphanumeric): name of temporary locking key in hash,
e.g., num, boardids	e.g., num, boardids

3. namespace: name of gdbm file used to store suffixes already assigned;	3. namespace: name of gdbm file used to store suffixes already assigned;
file will be named nohist_namespace.db	file will be named nohist_namespace.db

4. cdom: domain of course; default is current course domain from %env	4. cdom: domain of course; default is current course domain from %env

5. cnum: course number; default is current course number from %env	5. cnum: course number; default is current course number from %env

6. idtype: set to concat if an additional digit is to be appended to the	6. idtype: set to concat if an additional digit is to be appended to the
unix timestamp to form the suffix, if the plain timestamp is already	unix timestamp to form the suffix, if the plain timestamp is already
in use. Default is to not do this, but simply increment the unix	in use. Default is to not do this, but simply increment the unix
timestamp by 1 until a unique key is obtained.	timestamp by 1 until a unique key is obtained.

7. who: holder of locking key; defaults to user:domain for user.	7. who: holder of locking key; defaults to user:domain for user.

8. locktries: number of attempts to obtain a lock (sleep of 1s before	8. locktries: number of attempts to obtain a lock (sleep of 1s before
retrying); default is 3.	retrying); default is 3.

9. maxtries: number of attempts to obtain a unique suffix; default is 20.	9. maxtries: number of attempts to obtain a unique suffix; default is 20.

Returns:	Returns:

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

Removed from v.1.1172.2.146.2.14
changed lines
	Added in v.1.1526