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.10 and 1.1524

version 1.1172.2.146.2.10, 2023/01/22 17:32:08	version 1.1524, 2024/03/29 17:32:03
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 {
	my ($cdom,$cnum,$crsdef,$type,$context,$url,$ltinum,$keynum,$paramsref,$inforef) = @_;
	my $chome;
	if (&domain($cdom) ne '') {
	if ($crsdef) {
	$chome = &homeserver($cnum,$cdom);
	} else {
	$chome = &domain($cdom,'primary');
	}
	}
	if ($cdom && $chome && ($chome ne 'no_host')) {
	if ((ref($paramsref) eq 'HASH') &&
	(ref($inforef) eq 'HASH')) {
	my $rep;
	if (grep { $_ eq $chome } &current_machine_ids()) {
	# domain information is hosted on this machine
	$rep =
	&LONCAPA::Lond::sign_lti_payload($cdom,$cnum,$crsdef,$type,
	$context,$url,$ltinum,$keynum,
	$perlvar{'lonVersion'},
	$paramsref,$inforef);
	if (ref($rep) eq 'HASH') {
	return ('ok',$rep);
	}
	} else {
	my ($escurl,$params,$info);
	$escurl = &escape($url);
	if (ref($paramsref) eq 'HASH') {
	$params = &freeze_escape($paramsref);
	}
	if (ref($inforef) eq 'HASH') {
	$info = &freeze_escape($inforef);
	}
	$rep=&reply("encrypt:signlti:$cdom:$cnum:$crsdef:$type:$context:$escurl:$ltinum:$keynum:$params:$info",$chome);
	}
	if (($rep eq '') \|\| ($rep =~ /^con_lost\|error\|no_such_host\|unknown_cmd/i)) {
	return ();
	} elsif (($inforef->{'respfmt'} eq 'to_post_body') \|\|
	($inforef->{'respfmt'} eq 'to_authorization_header')) {
	return ('ok',$rep);
	} else {
	my %returnhash;
	foreach my $item (split(/\&/,$rep)) {
	my ($name,$value)=split(/\=/,$item);
	$returnhash{&unescape($name)}=&thaw_unescape($value);
	}
	return('ok',\%returnhash);
	}
	} else {
	return ();
	}
	} else {
	return ();
	&logthis("sign_lti failed - no homeserver and/or domain ($cdom) ($chome)");
	}
}	}

# -------------------------------------------------- Non-critical communication	# -------------------------------------------------- Non-critical communication
Line 394 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 418 sub reply {	Line 525 sub reply {
my $subcmd = $1;	my $subcmd = $1;
if (($subcmd eq 'auth') \|\| ($subcmd eq 'passwd') \|\|	if (($subcmd eq 'auth') \|\| ($subcmd eq 'passwd') \|\|
($subcmd eq 'changeuserauth') \|\| ($subcmd eq 'makeuser') \|\|	($subcmd eq 'changeuserauth') \|\| ($subcmd eq 'makeuser') \|\|
($subcmd eq 'putdom') \|\| ($subcmd eq 'autoexportgrades')) {	($subcmd eq 'putdom') \|\| ($subcmd eq 'autoexportgrades') \|\|
	($subcmd eq 'put')) {
(undef,undef,my @rest) = split(/:/,$cmd);	(undef,undef,my @rest) = split(/:/,$cmd);
if (($subcmd eq 'auth') \|\| ($subcmd eq 'putdom')) {	if (($subcmd eq 'auth') \|\| ($subcmd eq 'putdom')) {
splice(@rest,2,1,'Hidden');	splice(@rest,2,1,'Hidden');
} elsif ($subcmd eq 'passwd') {	} elsif ($subcmd eq 'passwd') {
splice(@rest,2,2,('Hidden','Hidden'));	splice(@rest,2,2,('Hidden','Hidden'));
} elsif (($subcmd eq 'changeuserauth') \|\| ($subcmd eq 'makeuser') \|\|	} elsif (($subcmd eq 'changeuserauth') \|\| ($subcmd eq 'makeuser') \|\|
($subcmd eq 'autoexportgrades')) {	($subcmd eq 'autoexportgrades') \|\| ($subcmd eq 'put')) {
splice(@rest,3,1,'Hidden');	splice(@rest,3,1,'Hidden');
}	}
$logged = join(':',('encrypt:'.$subcmd,@rest));	$logged = join(':',('encrypt:'.$subcmd,@rest));
Line 467 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 662 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 694 sub check_for_valid_session {	Line 802 sub check_for_valid_session {
if ($disk_env{'request.role'}) {	if ($disk_env{'request.role'}) {
$userhashref->{'role'} = $disk_env{'request.role'};	$userhashref->{'role'} = $disk_env{'request.role'};
}	}
	$userhashref->{'lti'} = $disk_env{'request.lti.login'};
	if ($userhashref->{'lti'}) {
	$userhashref->{'ltitarget'} = $disk_env{'request.lti.target'};
	$userhashref->{'ltiuri'} = $disk_env{'request.lti.uri'};
	}
}	}
untie(%disk_env);	untie(%disk_env);

Line 929 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 967 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 1035 sub find_existing_session {	Line 1148 sub find_existing_session {
return;	return;
}	}

	sub delusersession {
	my ($lonid,$udom,$uname) = @_;
	my $uprimary_id = &domain($udom,'primary');
	my $uintdom = &internet_dom($uprimary_id);
	my $intdom = &internet_dom($lonid);
	my $serverhomedom = &host_domain($lonid);
	if (($uintdom ne '') && ($uintdom eq $intdom)) {
	return &reply(join(':','delusersession',
	map {&escape($_)} ($udom,$uname)),$lonid);
	}
	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 1142 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 1150 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 1335 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 1371 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 1464 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 1513 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 1532 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 1540 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 1593 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 1601 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 1677 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 1691 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 1722 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 1776 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 1801 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 1820 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 1837 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 2055 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 2080 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 2131 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 2183 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 2278 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 2322 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 2349 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 2388 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 2430 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'],$domain);	'ssl','autoenroll','trust',
my @coursetypes = ('official','unofficial','community','textbook');	'helpsettings','wafproxy',
	'ltisec','toolsec','privacy'],$domain);
	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 2444 sub get_domain_defaults {	Line 2766 sub get_domain_defaults {
$domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'};	$domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'};
$domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'};	$domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'};
$domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'};	$domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'};
	$domdefaults{'portal_def_email'} = $domconfig{'defaults'}{'portal_def_email'};
	$domdefaults{'portal_def_web'} = $domconfig{'defaults'}{'portal_def_web'};
$domdefaults{'intauth_cost'} = $domconfig{'defaults'}{'intauth_cost'};	$domdefaults{'intauth_cost'} = $domconfig{'defaults'}{'intauth_cost'};
$domdefaults{'intauth_switch'} = $domconfig{'defaults'}{'intauth_switch'};	$domdefaults{'intauth_switch'} = $domconfig{'defaults'}{'intauth_switch'};
$domdefaults{'intauth_check'} = $domconfig{'defaults'}{'intauth_check'};	$domdefaults{'intauth_check'} = $domconfig{'defaults'}{'intauth_check'};
Line 2459 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 2470 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 2498 sub get_domain_defaults {	Line 2834 sub get_domain_defaults {
if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') {	if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') {
$domdefaults{$type.'quota'} = $domconfig{'coursedefaults'}{'uploadquota'}{$type};	$domdefaults{$type.'quota'} = $domconfig{'coursedefaults'}{'uploadquota'}{$type};
}	}
	if (ref($domconfig{'coursedefaults'}{'coursequota'}) eq 'HASH') {
	$domdefaults{$type.'coursequota'} = $domconfig{'coursedefaults'}{'coursequota'}{$type};
	}
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') {
	$domdefaults{$type.'domexttool'} = $domconfig{'coursedefaults'}{'domexttool'}{$type};
	} else {
	$domdefaults{$type.'domexttool'} = 1;
	}
	if (ref($domconfig{'coursedefaults'}{'exttool'}) eq 'HASH') {
	$domdefaults{$type.'exttool'} = $domconfig{'coursedefaults'}{'exttool'}{$type};
	} else {
	$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'}{'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 2574 sub get_domain_defaults {	Line 2928 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 2599 sub get_domain_defaults {	Line 2972 sub get_domain_defaults {
}	}
if (ref($domconfig{'ltisec'}{'private'}) eq 'HASH') {	if (ref($domconfig{'ltisec'}{'private'}) eq 'HASH') {
if (ref($domconfig{'ltisec'}{'private'}{'keys'}) eq 'ARRAY') {	if (ref($domconfig{'ltisec'}{'private'}{'keys'}) eq 'ARRAY') {
$domdefaults{'privhosts'} = $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'}{'encrypt'}) eq 'HASH') {
	$domdefaults{'toolenc_crs'} = $domconfig{'toolsec'}{'encrypt'}{'crs'};
	$domdefaults{'toolenc_dom'} = $domconfig{'toolsec'}{'encrypt'}{'dom'};
	}
	if (ref($domconfig{'toolsec'}{'private'}) eq 'HASH') {
	if (ref($domconfig{'toolsec'}{'private'}{'keys'}) eq 'ARRAY') {
	$domdefaults{'toolprivhosts'} = $domconfig{'toolsec'}{'private'}{'keys'};
	}
	}
	}
	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'});
}	}
}	}
}	}
Line 2622 sub get_dom_cats {	Line 3032 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 2667 sub retrieve_instcodes {	Line 3077 sub retrieve_instcodes {
return $totcodes;	return $totcodes;
}	}

	sub course_portal_url {
	my ($cnum,$cdom,$r) = @_;
	my $chome = &homeserver($cnum,$cdom);
	my $hostname = &hostname($chome);
	my $protocol = $protocol{$chome};
	$protocol = 'http' if ($protocol ne 'https');
	my %domdefaults = &get_domain_defaults($cdom);
	my $firsturl;
	if ($domdefaults{'portal_def'}) {
	$firsturl = $domdefaults{'portal_def'};
	} else {
	my $alias = &use_proxy_alias($r,$chome);
	$hostname = $alias if ($alias ne '');
	$firsturl = $protocol.'://'.$hostname;
	}
	return $firsturl;
	}

	sub url_prefix {
	my ($r,$dom,$home,$context) = @_;
	my $prefix;
	my %domdefs = &get_domain_defaults($dom);
	if ($domdefs{'portal_def'} && $domdefs{'portal_def_'.$context}) {
	if ($domdefs{'portal_def'} =~ m{^(https?://[^/]+)}) {
	$prefix = $1;
	}
	}
	if ($prefix eq '') {
	my $hostname = &hostname($home);
	my $protocol = $protocol{$home};
	$protocol = 'http' if ($protocol{$home} ne 'https');
	my $alias = &use_proxy_alias($r,$home);
	$hostname = $alias if ($alias ne '');
	$prefix = $protocol.'://'.$hostname;
	}
	return $prefix;
	}

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

sub get_passwdconf {	sub get_passwdconf {
Line 2690 sub get_passwdconf {	Line 3138 sub get_passwdconf {
return %passwdconf;	return %passwdconf;
}	}

sub course_portal_url {
my ($cnum,$cdom,$r) = @_;
my $chome = &homeserver($cnum,$cdom);
my $hostname = &hostname($chome);
my $protocol = $protocol{$chome};
$protocol = 'http' if ($protocol ne 'https');
my %domdefaults = &get_domain_defaults($cdom);
my $firsturl;
if ($domdefaults{'portal_def'}) {
$firsturl = $domdefaults{'portal_def'};
} else {
my $alias = &Apache::lonnet::use_proxy_alias($r,$chome);
$hostname = $alias if ($alias ne '');
$firsturl = $protocol.'://'.$hostname;
}
return $firsturl;
}

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

sub assign_access_key {	sub assign_access_key {
Line 2856 sub courseid_to_courseurl {	Line 3286 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 2953 sub devalidate_cache_new {	Line 3383 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 3056 sub userenvironment {	Line 3484 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 3073 sub studentphoto {	Line 3501 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 3085 sub studentphoto {	Line 3513 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 3217 sub repcopy {	Line 3645 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 3229 sub repcopy {	Line 3661 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 3259 sub unsubscribe {	Line 3696 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 3302 sub absolute_url {	Line 3744 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 3314 sub absolute_url {	Line 3756 sub absolute_url {
return $lcproto.$hostname;	return $lcproto.$hostname;
}	}
}	}
}	}
return $protocol.$host_name;	return $protocol.$host_name;
}	}

Line 3338 sub ssi {	Line 3780 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 3382 sub ssi {	Line 3813 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 3392 sub externalssi {	Line 3822 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 3413 sub remove_stale_resfile {	Line 3844 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 3480 sub allowuploaded {	Line 3909 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 3488 sub allowuploaded {	Line 3917 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 3519 sub can_edit_resource {	Line 3948 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 3549 sub can_edit_resource {	Line 4001 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 3633 sub can_edit_resource {	Line 4090 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 3693 sub can_edit_resource {	Line 4150 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 3720 sub in_course {	Line 4177 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 3916 sub clean_filename {	Line 4373 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 3965 sub resizeImage {	Line 4422 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 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 3973 sub resizeImage {	Line 4430 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
# $desuname - username for permanent storage of uploaded file	# $destuname - username for permanent storage of uploaded file
# $dsetudom - domain for permanaent storage of uploaded file	# $destudom - domain for permanaent storage of uploaded file
# $thumbwidth - width (pixels) of thumbnail to make for uploaded image	# $thumbwidth - width (pixels) of thumbnail to make for uploaded image
# $thumbheight - height (pixels) of thumbnail to make for uploaded image	# $thumbheight - height (pixels) of thumbnail to make for uploaded image
# $resizewidth - width (pixels) to which to resize uploaded image	# $resizewidth - width (pixels) to which to resize uploaded image
Line 4023 sub userfileupload {	Line 4480 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 4188 sub finishuserfileupload {	Line 4645 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 $thumbsize = $thumbwidth.'x'.$thumbheight;	my $thumbsize = $thumbwidth.'x'.$thumbheight;
my @args = ('convert','-sample',$thumbsize,$input,$output);	if ($context eq 'toollogo') {
system({$args[0]} @args);	my ($fullwidth,$fullheight) = &check_dimensions($input);
if (-e $filepath.'/'.'tn-'.$file) {	if ($fullwidth ne '' && $fullheight ne '') {
$fetchthumb = 1;	if ($fullwidth > $thumbwidth && $fullheight > $thumbheight) {
	$makethumb = 1;
	}
	}
	} else {
	$makethumb = 1;
	}
	if ($makethumb) {
	my @args = ('convert','-sample',$thumbsize,$input,$output);
	system({$args[0]} @args);
	if (-e $filepath.'/'.'tn-'.$file) {
	$fetchthumb = 1;
	}
}	}
}	}

Line 4249 sub extract_embedded_items {	Line 4719 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 4424 sub embedded_dependency {	Line 4894 sub embedded_dependency {
return;	return;
}	}

	sub check_dimensions {
	my ($inputfile) = @_;
	my ($fullwidth,$fullheight);
	if (($inputfile =~ m\|^[/\w.\-]+$\|) && (-e $inputfile)) {
	my $mm = new File::MMagic;
	my $mime_type = $mm->checktype_filename($inputfile);
	if ($mime_type =~ m{^image/}) {
	if (open(PIPE,"identify $inputfile 2>&1 \|")) {
	my $imageinfo = <PIPE>;
	if (!close(PIPE)) {
	&Apache::lonnet::logthis("Failed to close PIPE opened to retrieve image information for $inputfile");
	}
	chomp($imageinfo);
	my ($fullsize) =
	($imageinfo =~ /^\Q$inputfile\E\s+\w+\s+(\d+x\d+)/);
	if ($fullsize) {
	($fullwidth,$fullheight) = split(/x/,$fullsize);
	}
	}
	}
	}
	return ($fullwidth,$fullheight);
	}

sub bubblesheet_converter {	sub bubblesheet_converter {
my ($cdom,$fullpath,$config,$format) = @_;	my ($cdom,$fullpath,$config,$format) = @_;
if ((&domain($cdom) ne '') &&	if ((&domain($cdom) ne '') &&
($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 4787 sub flushcourselogs {	Line 5281 sub flushcourselogs {
# Typo in rev. 1.458 (2003/12/09)??	# Typo in rev. 1.458 (2003/12/09)??
# These should likely by $env{'course.'.$cid.'.domain'} and $env{'course.'.$cid.'.num'}	# These should likely by $env{'course.'.$cid.'.domain'} and $env{'course.'.$cid.'.num'}
#	#
# While these ramain as $env{'request.'.$cid.'.domain'} and $env{'request.'.$cid.'.num'}	# While these remain as $env{'request.'.$cid.'.domain'} and $env{'request.'.$cid.'.num'}
# $dom and $name will always be null, so the &inc() call will default to storing this data	# $dom and $name will always be null, so the &inc() call will default to storing this data
# in a nohist_accesscount.db file for the user rather than the course.	# in a nohist_accesscount.db file for the user rather than the course.
#	#
# 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 4831 sub flushcourselogs {	Line 5325 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 4853 sub flushcourselogs {	Line 5347 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 4998 sub userrolelog {	Line 5492 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 5011 sub courserolelog {	Line 5506 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 5027 sub courserolelog {	Line 5562 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 5038 sub domainrolelog {	Line 5574 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 5046 sub domainrolelog {	Line 5592 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 5057 sub coauthorrolelog {	Line 5604 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 5197 sub get_my_roles {	Line 5754 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 5261 sub get_my_adhocroles {	Line 5818 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 5494 sub courseiddump {	Line 6051 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 5519 sub courseiddump {	Line 6076 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 5589 sub extract_lastaccess {	Line 6146 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 5746 sub set_first_access {	Line 6303 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 6426 sub privileged {	Line 6896 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 6453 sub privileged {	Line 6923 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 6491 sub privileged_by_domain {	Line 6961 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 6524 sub rolesinit {	Line 6994 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 6538 sub rolesinit {	Line 7008 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 6589 sub rolesinit {	Line 7061 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 6617 sub rolesinit {	Line 7120 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 6924 sub check_adhoc_privs {	Line 7427 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 6970 sub set_adhoc_privileges {	Line 7473 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 7030 sub unserialize {	Line 7533 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 7052 sub dump {	Line 7556 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 7069 sub dump {	Line 7573 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 7113 sub currentdump {	Line 7618 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 7123 sub currentdump {	Line 7628 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 7267 sub putstore {	Line 7772 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 7379 sub tmpdel {	Line 7884 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 7399 sub get_timebased_id {	Line 7904 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 7417 sub get_timebased_id {	Line 7922 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 7447 sub get_timebased_id {	Line 7952 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 7489 sub portfolio_access {	Line 7994 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 7509 sub portfolio_access {	Line 8014 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 7518 sub get_portfolio_access {	Line 8023 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 7544 sub get_portfolio_access {	Line 8057 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 7554 sub get_portfolio_access {	Line 8069 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 7736 sub is_portfolio_file {	Line 8264 sub is_portfolio_file {
return;	return;
}	}

	sub is_coursetool_logo {
	my ($uri) = @_;
	if ($env{'request.course.id'}) {
	my $courseurl = &courseid_to_courseurl($env{'request.course.id'});
	if ($uri =~ m{^/*uploaded\Q$courseurl\E/toollogo/\d+/[^/]+$}) {
	return 1;
	}
	}
	return;
	}

sub usertools_access {	sub usertools_access {
my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref)=@_;	my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref)=@_;
my ($access,%tools);	my ($access,%tools);
Line 7748 sub usertools_access {	Line 8287 sub usertools_access {
unofficial => 1,	unofficial => 1,
community => 1,	community => 1,
textbook => 1,	textbook => 1,
	placement => 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,
portfolio => 1,	portfolio => 1,
	portaccess => 1,
timezone => 1,	timezone => 1,
);	);
}	}
Line 7775 sub usertools_access {	Line 8320 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 7784 sub usertools_access {	Line 8333 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 7884 sub is_course_owner {	Line 8437 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 7895 sub is_course_owner {	Line 8448 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 7903 sub is_advanced_user {	Line 8457 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 7938 sub is_advanced_user {	Line 8502 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 7945 sub is_advanced_user {	Line 8513 sub is_advanced_user {
}	}

sub check_can_request {	sub check_can_request {
my ($dom,$can_request,$request_domains) = @_;	my ($dom,$can_request,$request_domains,$uname,$udom) = @_;
my $canreq = 0;	my $canreq = 0;
	if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) {
	$uname = $env{'user.name'};
	$udom = $env{'user.domain'};
	}
my ($types,$typename) = &Apache::loncommon::course_types();	my ($types,$typename) = &Apache::loncommon::course_types();
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($env{'user.name'},	if (&usertools_access($uname,$udom,$type,undef,
$env{'user.domain'},	'requestcourses')) {
$type,undef,'requestcourses')) {
$canreq ++;	$canreq ++;
if (ref($request_domains) eq 'HASH') {	if (ref($request_domains) eq 'HASH') {
push(@{$request_domains->{$type}},$env{'user.domain'});	push(@{$request_domains->{$type}},$udom);
}	}
if ($dom eq $env{'user.domain'}) {	if ($dom eq $udom) {
$can_request->{$type} = 1;	$can_request->{$type} = 1;
}	}
}	}
if ($env{'environment.reqcrsotherdom.'.$type} ne '') {	if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '') &&
	($env{'environment.reqcrsotherdom.'.$type} ne '')) {
my @curr = split(',',$env{'environment.reqcrsotherdom.'.$type});	my @curr = split(',',$env{'environment.reqcrsotherdom.'.$type});
if (@curr > 0) {	if (@curr > 0) {
foreach my $item (@curr) {	foreach my $item (@curr) {
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);
}	}
}	}
}	}
}	}
unless($dom eq $env{'user.domain'}) {	unless ($dom eq $env{'user.domain'}) {
$canreq ++;	$canreq ++;
if (grep(/^\Q$dom\E:($optregex)(=?\d*)$/,@curr)) {	if (grep(/^\Q$dom\E:($optregex)(=?\d*)$/,@curr)) {
$can_request->{$type} = 1;	$can_request->{$type} = 1;
Line 8324 sub allowed {	Line 8902 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 8332 sub allowed {	Line 8910 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 8341 sub allowed {	Line 8919 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 8352 sub allowed {	Line 8937 sub allowed {

if ($env{'request.course.id'}) {	if ($env{'request.course.id'}) {

	if ($priv eq 'bre') {
	if (&is_coursetool_logo($uri)) {
	return 'F';
	}
	}

# If this is modifying password (internal auth) domains must match for user and user's role.	# If this is modifying password (internal auth) domains must match for user and user's role.

if ($priv eq 'mip') {	if ($priv eq 'mip') {
Line 8577 sub allowed {	Line 9168 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 8587 sub allowed {	Line 9178 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 8658 sub constructaccess {	Line 9249 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 8672 sub constructaccess {	Line 9263 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 8723 sub constructaccess {	Line 9342 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 8757 sub get_comm_blocks {	Line 9376 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 8779 sub get_commblock_resources {	Line 9398 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 8791 sub get_commblock_resources {	Line 9410 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 8824 sub get_commblock_resources {	Line 9443 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 8917 sub has_comm_blocking {	Line 9536 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 8952 sub has_comm_blocking {	Line 9571 sub has_comm_blocking {
}	}
}	}
}	}
unless ($noblock) {	unless ($noblock) {
return @blockers;	return @blockers;
}	}
return;	return;
Line 9040 sub deeplink_check {	Line 9659 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 9166 sub metadata_query {	Line 9785 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 9799 sub auto_crsreq_update {	Line 10418 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 9956 sub toggle_coursegroup_status {	Line 10576 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 10059 sub plaintext {	Line 10681 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 10087 sub plaintext {	Line 10710 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 10140 sub assignrole {	Line 10786 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 10160 sub assignrole {	Line 10807 sub assignrole {
}	}
}	}
}	}
} elsif (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {	} elsif (($selfenroll == 1) && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
$refused = '';	if ($role eq 'st') {
	$refused = '';
	} elsif (($context eq 'ltienroll') && ($env{'request.lti.login'})) {
	$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 10180 sub assignrole {	Line 10874 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 10188 sub assignrole {	Line 10882 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 10214 sub assignrole {	Line 10908 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 10274 sub assignrole {	Line 10977 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 10377 sub store_coowners {	Line 11083 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 10453 sub modifyuser {	Line 11159 sub modifyuser {
my $newuser;	my $newuser;
if ($uhome eq 'no_host') {	if ($uhome eq 'no_host') {
$newuser = 1;	$newuser = 1;
	unless (($umode && ($upass ne '')) \|\| ($umode eq 'localauth') \|\|
	($umode eq 'lti')) {
	return 'error: more information needed to create new user';
	}
}	}
# ----------------------------------------------------------------- Create User	# ----------------------------------------------------------------- Create User
if (($uhome eq 'no_host') &&	if (($uhome eq 'no_host') &&
(($umode && $upass) \|\| ($umode eq 'localauth'))) {	(($umode && $upass) \|\| ($umode eq 'localauth') \|\| ($umode eq 'lti'))) {
my $unhome='';	my $unhome='';
if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) {	if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) {
$unhome = $desiredhome;	$unhome = $desiredhome;
Line 10498 sub modifyuser {	Line 11208 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 10594 sub modifyuser {	Line 11304 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 10623 sub modifystudent {	Line 11333 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 10674 sub modify_student_enrollment {	Line 11384 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 10691 sub modify_student_enrollment {	Line 11401 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 10808 sub createcourse {	Line 11518 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 10905 sub generate_coursenum {	Line 11615 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 10923 sub is_course {	Line 11634 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 10966 sub store_userdata {	Line 11677 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 11122 sub files_not_in_path {	Line 11835 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 11266 sub modify_access_controls {	Line 12063 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 11513 sub dirlist {	Line 12393 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 11526 sub dirlist {	Line 12407 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 11602 sub stat_file {	Line 12483 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 11765 sub get_userresdata {	Line 12813 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 11775 sub get_userresdata {	Line 12830 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 11784 sub resdata {	Line 12840 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 11803 sub get_domain_lti {	Line 12873 sub get_domain_lti {
} else {	} else {
return %lti;	return %lti;
}	}

if ($context eq 'linkprot') {	if ($context eq 'linkprot') {
$cachename = $context;	$cachename = $context;
} else {	} else {
$cachename = $name;	$cachename = $name;
}	}

my ($result,$cached)=&is_cached_new($cachename,$cdom);	my ($result,$cached)=&is_cached_new($cachename,$cdom);
if (defined($cached)) {	if (defined($cached)) {
if (ref($result) eq 'HASH') {	if (ref($result) eq 'HASH') {
Line 11825 sub get_domain_lti {	Line 12893 sub get_domain_lti {
} else {	} else {
%lti = %{$domconfig{$name}};	%lti = %{$domconfig{$name}};
}	}
if (($context eq 'consumer') && (keys(%lti))) {
my %encdomconfig = &get_dom('encconfig',[$name],$cdom,undef,1);
if (ref($encdomconfig{$name}) eq 'HASH') {
foreach my $id (keys(%lti)) {
if (ref($encdomconfig{$name}{$id}) eq 'HASH') {
foreach my $item ('key','secret') {
$lti{$id}{$item} = $encdomconfig{$name}{$id}{$item};
}
}
}
}
}
}	}
my $cachetime = 246060;	my $cachetime = 246060;
&do_cache_new($cachename,$cdom,\%lti,$cachetime);	&do_cache_new($cachename,$cdom,\%lti,$cachetime);
Line 11845 sub get_domain_lti {	Line 12901 sub get_domain_lti {
}	}

sub get_course_lti {	sub get_course_lti {
my ($cnum,$cdom) = @_;	my ($cnum,$cdom,$context) = @_;
	my ($name,$cachename,%lti);
	if ($context eq 'consumer') {
	$name = 'ltitools';
	$cachename = 'courseltitools';
	} elsif ($context eq 'provider') {
	$name = 'lti';
	$cachename = 'courselti';
	} else {
	return %lti;
	}
my $hashid=$cdom.'_'.$cnum;	my $hashid=$cdom.'_'.$cnum;
my %courselti;	my ($result,$cached)=&is_cached_new($cachename,$hashid);
my ($result,$cached)=&is_cached_new('courselti',$hashid);
if (defined($cached)) {	if (defined($cached)) {
if (ref($result) eq 'HASH') {	if (ref($result) eq 'HASH') {
%courselti = %{$result};	%lti = %{$result};
}	}
} else {	} else {
%courselti = &dump('lti',$cdom,$cnum,undef,undef,undef,1);	%lti = &dump($name,$cdom,$cnum,undef,undef,undef,1);
my $cachetime = 246060;	my $cachetime = 246060;
&do_cache_new('courselti',$hashid,\%courselti,$cachetime);	&do_cache_new($cachename,$hashid,\%lti,$cachetime);
}	}
return %courselti;	return %lti;
}	}

sub courselti_itemid {	sub courselti_itemid {
Line 11867 sub courselti_itemid {	Line 12932 sub courselti_itemid {
$chome = &homeserver($cnum,$cdom);	$chome = &homeserver($cnum,$cdom);
return if ($chome eq 'no_host');	return if ($chome eq 'no_host');
if (ref($params) eq 'HASH') {	if (ref($params) eq 'HASH') {
my $items = &freeze_escape($params);
my $rep;	my $rep;
if (grep { $_ eq $chome } current_machine_ids()) {	if (grep { $_ eq $chome } current_machine_ids()) {
$rep = LONCAPA::Lond::crslti_itemid($cdom,$cnum,$url,$method,$params,$perlvar{'lonVersion'});	$rep = LONCAPA::Lond::crslti_itemid($cdom,$cnum,$url,$method,$params,$perlvar{'lonVersion'});
Line 11891 sub domainlti_itemid {	Line 12955 sub domainlti_itemid {
$primary_id = &domain($cdom,'primary');	$primary_id = &domain($cdom,'primary');
return if ($primary_id eq '');	return if ($primary_id eq '');
if (ref($params) eq 'HASH') {	if (ref($params) eq 'HASH') {
my $items = &freeze_escape($params);
my $rep;	my $rep;
if (grep { $_ eq $primary_id } current_machine_ids()) {	if (grep { $_ eq $primary_id } current_machine_ids()) {
$rep = LONCAPA::Lond::domlti_itemid($cdom,$context,$url,$method,$params,$perlvar{'lonVersion'});	$rep = LONCAPA::Lond::domlti_itemid($cdom,$context,$url,$method,$params,$perlvar{'lonVersion'});
Line 11910 sub domainlti_itemid {	Line 12973 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 12008 sub EXT_cache_set {	Line 13138 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 12161 sub EXT {	Line 13291 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 12194 sub EXT {	Line 13327 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 12212 sub EXT {	Line 13349 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 12237 sub EXT {	Line 13377 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

$spacequalifierrest=~s/\./\_/;	my $what = $spacequalifierrest;
	$what=~s/\./\_/;
my $filename;	my $filename;
if (!$symbparm) { $symbparm=&symbread(); }	if (!$symbparm) { $symbparm=&symbread(); }
if ($symbparm) {	if ($symbparm) {
Line 12246 sub EXT {	Line 13387 sub EXT {
} else {	} else {
$filename=$env{'request.filename'};	$filename=$env{'request.filename'};
}	}
my $metadata=&metadata($filename,$spacequalifierrest);	my $toolsymb;
	if (($filename =~ /ext\.tool$/) && ($what ne '0_gradable')) {
	$toolsymb = $symbparm;
	}
	my $metadata=&metadata($filename,$what,$toolsymb);
if (defined($metadata)) { return &get_reply([$metadata,'resource']); }	if (defined($metadata)) { return &get_reply([$metadata,'resource']); }
$metadata=&metadata($filename,'parameter_'.$spacequalifierrest);	$metadata=&metadata($filename,'parameter_'.$what,$toolsymb);
if (defined($metadata)) { return &get_reply([$metadata,'resource']); }	if (defined($metadata)) { return &get_reply([$metadata,'resource']); }

# ---------------------------------------------- fourth, look in rest of course	# ----------------------------------------------- fifth, look in rest of course
if ($symbparm && defined($courseid) &&	if ($symbparm && defined($courseid) &&
$courseid eq $env{'request.course.id'}) {	$courseid eq $env{'request.course.id'}) {
my $coursereply=&resdata($env{'course.'.$courseid.'.num'},	my $coursereply=&resdata($env{'course.'.$courseid.'.num'},
$env{'course.'.$courseid.'.domain'},	$env{'course.'.$courseid.'.domain'},
'course',	'course',$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 12272 sub EXT {	Line 13419 sub EXT {
if (defined($partgeneral[0])) { return &get_reply(\@partgeneral); }	if (defined($partgeneral[0])) { return &get_reply(\@partgeneral); }
}	}
if ($recurse) { return undef; }	if ($recurse) { return undef; }
my $pack_def=&packages_tab_default($filename,$varname);	my $pack_def=&packages_tab_default($filename,$varname,$toolsymb);
if (defined($pack_def)) { return &get_reply([$pack_def,'resource']); }	if (defined($pack_def)) { return &get_reply([$pack_def,'resource']); }
# ---------------------------------------------------- Any other user namespace	# ---------------------------------------------------- Any other user namespace
} elsif ($realm eq 'environment') {	} elsif ($realm eq 'environment') {
Line 12318 sub get_reply {	Line 13465 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 12365 sub sort_course_groups { # Sort groups b	Line 13517 sub sort_course_groups { # Sort groups b
}	}

sub packages_tab_default {	sub packages_tab_default {
my ($uri,$varname)=@_;	my ($uri,$varname,$toolsymb)=@_;
my (undef,$part,$name)=split(/\./,$varname);	my (undef,$part,$name)=split(/\./,$varname);

my (@extension,@specifics,$do_default);	my (@extension,@specifics,$do_default);
foreach my $package (split(/,/,&metadata($uri,'packages'))) {	foreach my $package (split(/,/,&metadata($uri,'packages',$toolsymb))) {
my ($pack_type,$pack_part)=split(/_/,$package,2);	my ($pack_type,$pack_part)=split(/_/,$package,2);
if ($pack_type eq 'default') {	if ($pack_type eq 'default') {
$do_default=1;	$do_default=1;
Line 12438 my %metaentry;	Line 13590 my %metaentry;
my %importedpartids;	my %importedpartids;
my %importedrespids;	my %importedrespids;
sub metadata {	sub metadata {
my ($uri,$what,$liburi,$prefix,$depthcount)=@_;	my ($uri,$what,$toolsymb,$liburi,$prefix,$depthcount)=@_;
$uri=&declutter($uri);	$uri=&declutter($uri);
# if it is a non metadata possible uri return quickly	# if it is a non metadata possible uri return quickly
if (($uri eq '') \|\|	if (($uri eq '') \|\|
Line 12462 sub metadata {	Line 13614 sub metadata {
my ($result,$cached)=&is_cached_new('meta',$uri);	my ($result,$cached)=&is_cached_new('meta',$uri);
if (defined($cached)) { return $result->{':'.$what}; }	if (defined($cached)) { return $result->{':'.$what}; }
}	}

	#
	# If the uri is for an external tool the file from
	# which metadata should be retrieved depends on whether
	# the tool had been configured to be gradable (set in the Course
	# Editor or Resource Editor).
	#
	# If a valid symb has been included as the third arg in the call
	# to &metadata() that can be used to retrieve the value of
	# parameter_0_gradable set for the resource, and included in the
	# uploaded map containing the tool. The value is retrieved via
	# &EXT(), if a valid symb is available. Otherwise the value of
	# gradable in the exttool_$marker.db file for the tool instance
	# is retrieved via &get().
	#
	# When lonuserstate::traceroute() calls lonnet::EXT() for
	# hiddenresource and encrypturl (during course initialization)
	# the map-level parameter for resource.0.gradable included in the
	# 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
	# this case fall back to retrieving gradable status from the
	# exttool_$marker.db file.
	#
	# In order to avoid an infinite loop, &metadata() will return
	# before a call to &EXT(), if the uri is for an external tool
	# and the $what for which metadata is being requested is
	# parameter_0_gradable or 0_gradable.
	#

	if ($uri =~ /ext\.tool$/) {
	if (($what eq 'parameter_0_gradable') \|\| ($what eq '0_gradable')) {
	return;
	} else {
	my ($checked,$use_passback);
	if ($toolsymb ne '') {
	(undef,undef,my $tooluri) = &decode_symb($toolsymb);
	if (($tooluri eq $uri) && (&EXT('resource.0.gradable',$toolsymb))) {
	$checked = 1;
	if (&EXT('resource.0.gradable',$toolsymb) =~ /^yes$/i) {
	$use_passback = 1;
	}
	}
	}
	unless ($checked) {
	my ($ignore,$cdom,$cnum,$marker) = split(m{/},$uri);
	$marker=~s/\D//g;
	if ($marker) {
	my %toolsettings=&get('exttool_'.$marker,['gradable'],$cdom,$cnum);
	$use_passback = $toolsettings{'gradable'};
	}
	}
	if ($use_passback) {
	$filename = '/home/httpd/html/res/lib/templates/LTIpassback.tool';
	} else {
	$filename = '/home/httpd/html/res/lib/templates/LTIstandard.tool';
	}
	}
	}

{	{
# Imported parts would go here	# Imported parts would go here
my @origfiletagids=();	my @origfiletagids=();
Line 12570 sub metadata {	Line 13781 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 12594 sub metadata {	Line 13813 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 12612 sub metadata {	Line 13828 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 12626 sub metadata {	Line 13855 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', $location,$unikey,	&metadata($uri,'keys',$toolsymb,$location,$unikey,
$depthcount+1);	$depthcount+1);
foreach my $meta (split(',',$metadata)) {	foreach my $meta (split(',',$metadata)) {
$metaentry{':'.$meta}=$metaentry{':'.$meta};	$metaentry{':'.$meta}=$metaentry{':'.$meta};
$metathesekeys{$meta}=1;	$metathesekeys{$meta}=1;
}	}

}	}
} else {	} else {
#	#
Line 12710 sub metadata {	Line 13953 sub metadata {
$dir=~s\|[^/]*$\|\|;	$dir=~s\|[^/]*$\|\|;
$location=&filelocation($dir,$location);	$location=&filelocation($dir,$location);
my $rights_metadata =	my $rights_metadata =
&metadata($uri,'keys',$location,'_rights',	&metadata($uri,'keys',$toolsymb,$location,'_rights',
$depthcount+1);	$depthcount+1);
foreach my $rights (split(',',$rights_metadata)) {	foreach my $rights (split(',',$rights_metadata)) {
#$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights};	#$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights};
Line 12731 sub metadata {	Line 13974 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 12745 sub metadata {	Line 13988 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 12767 sub metadata {	Line 14012 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 12927 sub get_reservable_slots {	Line 14173 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 13101 sub symbverify {	Line 14347 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 13117 sub symbverify {	Line 14363 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 13212 sub symbread {	Line 14458 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 13285 sub symbread {	Line 14531 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 13293 sub symbread {	Line 14539 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 13481 sub rndseed {	Line 14727 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 13666 sub rndseed_CODE_64bit5 {	Line 14913 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 13850 sub repcopy_userfile {	Line 15097 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 13861 sub repcopy_userfile {	Line 15107 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 13907 sub getuploaded {	Line 15153 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 14041 sub additional_machine_domains {	Line 15286 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 14102 sub uses_sts {	Line 15347 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 14162 sub get_requestor_ip {	Line 15406 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 14206 sub get_requestor_ip {	Line 15450 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 14239 sub get_proxy_alias {	Line 15483 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 14290 sub alias_sso {	Line 15534 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 14322 sub get_saml_landing {	Line 15566 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 14335 sub get_saml_landing {	Line 15579 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 14469 sub get_dns {	Line 15713 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 14491 sub get_dns {	Line 15735 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 14501 sub get_dns {	Line 15745 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 14529 sub get_dns {	Line 15792 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 14549 sub parse_dns_checksums_tab {	Line 15812 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 14573 sub parse_dns_checksums_tab {	Line 15836 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 14581 sub fetch_dns_checksums {	Line 15844 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 14592 sub parse_getdns_url {	Line 15928 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 14718 sub parse_getdns_url {	Line 16057 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 14760 sub parse_getdns_url {	Line 16100 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 14879 sub parse_getdns_url {	Line 16224 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 14891 sub parse_getdns_url {	Line 16236 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 14958 sub parse_getdns_url {	Line 16303 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 14990 sub all_loncaparevs {	Line 16335 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 15006 sub all_loncaparevs {	Line 16351 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 15098 BEGIN {	Line 16443 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 15116 BEGIN {	Line 16461 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 15399 the answer, and also caches if there is	Line 16752 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 15411 usernames (returns hash: name=>id,name=>	Line 16766 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 15459 The first argument is required, all othe	Line 16834 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 15475 prevents recursive calls to &allowed.	Line 16850 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 15528 provided for types, will default to retu	Line 16903 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 15935 condval($condidx) : value of condition i	Line 17310 condval($condidx) : value of condition i

=item *	=item *

metadata($uri,$what,$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 only used internally for recursive metadata.	packages that this resource currently uses, the last 3 arguments are
	only used internally for recursive metadata.

this function automatically caches all requests	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).

	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 15950 will be stored for query	Line 17331 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 15973 and is a possible symb for the URL in $t	Line 17354 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 16028 expirespread($uname,$udom,$stype,$usymb)	Line 17409 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 16042 when viewing in course context.	Line 17423 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 16064 homeserver.	Line 17445 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 16215 server ($udom and $uhome are optional)	Line 17596 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 16249 requestcourses: ability to request cours	Line 17630 requestcourses: ability to request cours
=over	=over

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

=back	=back

Line 16270 for course's uploaded content.	Line 17651 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 16281 on your servers.	Line 17662 on your servers.

=over	=over

=item	=item
remotesessions, hostedsessions	remotesessions, hostedsessions

=back	=back
Line 16289 remotesessions, hostedsessions	Line 17670 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 16721 Returns:	Line 18102 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 16733 Args: (first three required; six others	Line 18114 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.10
changed lines
	Added in v.1.1524