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.1430 and 1.1504

version 1.1430, 2020/10/20 01:38:12	version 1.1504, 2023/03/19 16:05:48
Line 96 use Cache::Memcached;	Line 96 use Cache::Memcached;
use Digest::MD5;	use Digest::MD5;
use Math::Random;	use Math::Random;
use File::MMagic;	use File::MMagic;
	use Net::CIDR;
	use Sys::Hostname::FQDN();
use LONCAPA qw(:DEFAULT :match);	use LONCAPA qw(:DEFAULT :match);
use LONCAPA::Configuration;	use LONCAPA::Configuration;
use LONCAPA::lonmetadata;	use LONCAPA::lonmetadata;
Line 128 our @EXPORT = qw(%env);	Line 130 our @EXPORT = qw(%env);
$logid ++;	$logid ++;
my $now = time();	my $now = time();
my $id=$now.'00000'.$$.'00000'.$logid;	my $id=$now.'00000'.$$.'00000'.$logid;
	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' => $ENV{'REMOTE_ADDR'},	'exe_ip' => $ip,
'delflag' => $delflag,	'delflag' => $delflag,
'logentry' => $storehash,	'logentry' => $storehash,
'uname' => $uname,	'uname' => $uname,
Line 465 sub reply {	Line 468 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 738 sub check_for_valid_session {	Line 742 sub check_for_valid_session {
if (ref($userhashref) eq 'HASH') {	if (ref($userhashref) eq 'HASH') {
$userhashref->{'name'} = $disk_env{'user.name'};	$userhashref->{'name'} = $disk_env{'user.name'};
$userhashref->{'domain'} = $disk_env{'user.domain'};	$userhashref->{'domain'} = $disk_env{'user.domain'};
	if ($disk_env{'request.role'}) {
	$userhashref->{'role'} = $disk_env{'request.role'};
	}
$userhashref->{'lti'} = $disk_env{'request.lti.login'};	$userhashref->{'lti'} = $disk_env{'request.lti.login'};
if ($userhashref->{'lti'}) {	if ($userhashref->{'lti'}) {
$userhashref->{'ltitarget'} = $disk_env{'request.lti.target'};	$userhashref->{'ltitarget'} = $disk_env{'request.lti.target'};
Line 971 sub userload {	Line 978 sub userload {
# ------------------------------ Find server with least workload from spare.tab	# ------------------------------ Find server with least workload from spare.tab

sub spareserver {	sub spareserver {
my ($loadpercent,$userloadpercent,$want_server_name,$udom) = @_;	my ($r,$loadpercent,$userloadpercent,$want_server_name,$udom) = @_;
my $spare_server;	my $spare_server;
if ($userloadpercent !~ /\d/) { $userloadpercent=0; }	if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent	my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent
: $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 1016 sub spareserver {	Line 1023 sub spareserver {
if ($protocol{$spare_server} eq 'https') {	if ($protocol{$spare_server} eq 'https') {
$protocol = $protocol{$spare_server};	$protocol = $protocol{$spare_server};
}	}
	my $alias = &use_proxy_alias($r,$spare_server);
	$hostname = $alias if ($alias ne '');
$spare_server = $protocol.'://'.$hostname;	$spare_server = $protocol.'://'.$hostname;
}	}
}	}
Line 1150 sub check_for_balancer_cookie {	Line 1159 sub check_for_balancer_cookie {
return ($otherserver,$cookie);	return ($otherserver,$cookie);
}	}

	sub updatebalcookie {
	my ($cookie,$balancer,$lastentry)=@_;
	if ($cookie =~ /^($match_domain)\_($match_username)\_[a-f0-9]{32}$/) {
	my ($udom,$uname) = ($1,$2);
	my $uprimary_id = &domain($udom,'primary');
	my $uintdom = &internet_dom($uprimary_id);
	my $intdom = &internet_dom($balancer);
	my $serverhomedom = &host_domain($balancer);
	if (($uintdom ne '') && ($uintdom eq $intdom)) {
	return &reply('updatebalcookie:'.&escape($cookie).':'.&escape($lastentry),$balancer);
	}
	}
	return;
	}

sub delbalcookie {	sub delbalcookie {
my ($cookie,$balancer) =@_;	my ($cookie,$balancer) =@_;
if ($cookie =~ /^($match_domain)\_($match_username)\_[a-f0-9]{32}$/) {	if ($cookie =~ /^($match_domain)\_($match_username)\_[a-f0-9]{32}$/) {
Line 1159 sub delbalcookie {	Line 1183 sub delbalcookie {
my $intdom = &internet_dom($balancer);	my $intdom = &internet_dom($balancer);
my $serverhomedom = &host_domain($balancer);	my $serverhomedom = &host_domain($balancer);
if (($uintdom ne '') && ($uintdom eq $intdom)) {	if (($uintdom ne '') && ($uintdom eq $intdom)) {
return &reply("delbalcookie:$cookie",$balancer);	return &reply('delbalcookie:'.&escape($cookie),$balancer);
}	}
}	}
}	}
Line 1187 sub choose_server {	Line 1211 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 1299 sub changepass {	Line 1323 sub changepass {
sub queryauthenticate {	sub queryauthenticate {
my ($uname,$udom)=@_;	my ($uname,$udom)=@_;
my $uhome=&homeserver($uname,$udom);	my $uhome=&homeserver($uname,$udom);
if (!$uhome) {	if ((!$uhome) \|\| ($uhome eq 'no_host')) {
&logthis("User $uname at $udom is unknown when looking for authentication mechanism");	&logthis("User $uname at $udom is unknown when looking for authentication mechanism");
return 'no_host';	return 'no_host';
}	}
Line 1348 sub authenticate {	Line 1372 sub authenticate {
}	}
if ($answer eq 'non_authorized') {	if ($answer eq 'non_authorized') {
&logthis("User $uname at $udom rejected by $uhome");	&logthis("User $uname at $udom rejected by $uhome");
return 'no_host';	return 'no_host';
}	}
&logthis("User $uname at $udom threw error $answer when checking authentication mechanism");	&logthis("User $uname at $udom threw error $answer when checking authentication mechanism");
return 'no_host';	return 'no_host';
}	}

	sub can_switchserver {
	my ($udom,$home) = @_;
	my ($canswitch,@intdoms);
	my $internet_names = &get_internet_names($home);
	if (ref($internet_names) eq 'ARRAY') {
	@intdoms = @{$internet_names};
	}
	my $uint_dom = &internet_dom(&domain($udom,'primary'));
	if ($uint_dom ne '' && grep(/^\Q$uint_dom\E$/,@intdoms)) {
	$canswitch = 1;
	} else {
	my $serverhomeID = &get_server_homeID(&hostname($home));
	my $serverhomedom = &host_domain($serverhomeID);
	my %defdomdefaults = &get_domain_defaults($serverhomedom);
	my %udomdefaults = &get_domain_defaults($udom);
	my $remoterev = &get_server_loncaparev('',$home);
	$canswitch = &can_host_session($udom,$home,$remoterev,
	$udomdefaults{'remotesessions'},
	$defdomdefaults{'hostedsessions'});
	}
	return $canswitch;
	}

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 1393 sub can_host_session {	Line 1440 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 1428 sub spare_can_host {	Line 1475 sub spare_can_host {
$canhost = 0;	$canhost = 0;
}	}
}	}
	if ($canhost) {
	if (ref($defdomdefaults{'offloadoth'}) eq 'HASH') {
	if ($defdomdefaults{'offloadoth'}{$try_server}) {
	unless (&shared_institution($udom,$try_server)) {
	$canhost = 0;
	}
	}
	}
	}
if (($canhost) && ($uint_dom)) {	if (($canhost) && ($uint_dom)) {
my @intdoms;	my @intdoms;
my $internet_names = &get_internet_names($try_server);	my $internet_names = &get_internet_names($try_server);
Line 1477 sub spares_for_offload {	Line 1533 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 1529 sub check_loadbalancing {	Line 1585 sub check_loadbalancing {
$rule_in_effect,$offloadto,$otherserver,$setcookie,$dom_balancers);	$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;
Line 1545 sub check_loadbalancing {	Line 1601 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 1606 sub check_loadbalancing {	Line 1662 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 1739 sub get_loadbalancer_targets {	Line 1795 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 1803 sub trusted_domains {	Line 1859 sub trusted_domains {
return ($trusted,$untrusted);	return ($trusted,$untrusted);
}	}
my $callprimary = &domain($calldom,'primary');	my $callprimary = &domain($calldom,'primary');
my $intcalldom = &Apache::lonnet::internet_dom($callprimary);	my $intcalldom = &internet_dom($callprimary);
if ($intcalldom eq '') {	if ($intcalldom eq '') {
return ($trusted,$untrusted);	return ($trusted,$untrusted);
}	}

my ($trustconfig,$cached)=&Apache::lonnet::is_cached_new('trust',$calldom);	my ($trustconfig,$cached)=&is_cached_new('trust',$calldom);
unless (defined($cached)) {	unless (defined($cached)) {
my %domconfig = &Apache::lonnet::get_dom('configuration',['trust'],$calldom);	my %domconfig = &get_dom('configuration',['trust'],$calldom);
&Apache::lonnet::do_cache_new('trust',$calldom,$domconfig{'trust'},3600);	&do_cache_new('trust',$calldom,$domconfig{'trust'},3600);
$trustconfig = $domconfig{'trust'};	$trustconfig = $domconfig{'trust'};
}	}
if (ref($trustconfig)) {	if (ref($trustconfig)) {
Line 2114 sub dump_dom {	Line 2170 sub dump_dom {
# ------------------------------------------ get items from domain db files	# ------------------------------------------ get items from domain db files

sub get_dom {	sub get_dom {
my ($namespace,$storearr,$udom,$uhome)=@_;	my ($namespace,$storearr,$udom,$uhome,$encrypt)=@_;
return if ($udom eq 'public');	return if ($udom eq 'public');
my $items='';	my $items='';
foreach my $item (@$storearr) {	foreach my $item (@$storearr) {
Line 2138 sub get_dom {	Line 2194 sub get_dom {
}	}
if ($udom && $uhome && ($uhome ne 'no_host')) {	if ($udom && $uhome && ($uhome ne 'no_host')) {
my $rep;	my $rep;
if ($namespace =~ /^enc/) {	if (grep { $_ eq $uhome } &current_machine_ids()) {
$rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome);	# domain information is hosted on this machine
	$rep = &LONCAPA::Lond::get_dom("getdom:$udom:$namespace:$items");
} else {	} else {
$rep=&reply("getdom:$udom:$namespace:$items",$uhome);	if ($encrypt) {
	$rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome);
	} else {
	$rep=&reply("getdom:$udom:$namespace:$items",$uhome);
	}
}	}
my %returnhash;	my %returnhash;
if ($rep eq '' \|\| $rep =~ /^error: 2 /) {	if ($rep eq '' \|\| $rep =~ /^error: 2 /) {
Line 2165 sub get_dom {	Line 2226 sub get_dom {
# -------------------------------------------- put items in domain db files	# -------------------------------------------- put items in domain db files

sub put_dom {	sub put_dom {
my ($namespace,$storehash,$udom,$uhome)=@_;	my ($namespace,$storehash,$udom,$uhome,$encrypt)=@_;
if (!$udom) {	if (!$udom) {
$udom=$env{'user.domain'};	$udom=$env{'user.domain'};
if (defined(&domain($udom,'primary'))) {	if (defined(&domain($udom,'primary'))) {
Line 2186 sub put_dom {	Line 2247 sub put_dom {
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';	$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
}	}
$items=~s/\&$//;	$items=~s/\&$//;
if ($namespace =~ /^enc/) {	if ($encrypt) {
return &reply("encrypt:putdom:$udom:$namespace:$items",$uhome);	return &reply("encrypt:putdom:$udom:$namespace:$items",$uhome);
} else {	} else {
return &reply("putdom:$udom:$namespace:$items",$uhome);	return &reply("putdom:$udom:$namespace:$items",$uhome);
Line 2224 sub del_dom {	Line 2285 sub del_dom {
}	}
}	}

	sub store_dom {
	my ($storehash,$id,$namespace,$dom,$home,$encrypt) = @_;
	$$storehash{'ip'}=&get_requestor_ip();
	$$storehash{'host'}=$perlvar{'lonHostID'};
	my $namevalue='';
	foreach my $key (keys(%{$storehash})) {
	$namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
	}
	$namevalue=~s/\&$//;
	if (grep { $_ eq $home } current_machine_ids()) {
	return LONCAPA::Lond::store_dom("storedom:$dom:$namespace:$id:$namevalue");
	} else {
	if ($namespace eq 'private') {
	return 'refused';
	} elsif ($encrypt) {
	return reply("encrypt:storedom:$dom:$namespace:$id:$namevalue",$home);
	} else {
	return reply("storedom:$dom:$namespace:$id:$namevalue",$home);
	}
	}
	}

	sub restore_dom {
	my ($id,$namespace,$dom,$home,$encrypt) = @_;
	my $answer;
	if (grep { $_ eq $home } current_machine_ids()) {
	$answer = LONCAPA::Lond::restore_dom("restoredom:$dom:$namespace:$id");
	} elsif ($namespace ne 'private') {
	if ($encrypt) {
	$answer=&reply("encrypt:restoredom:$dom:$namespace:$id",$home);
	} else {
	$answer=&reply("restoredom:$dom:$namespace:$id",$home);
	}
	}
	my %returnhash=();
	unless (($answer eq '') \|\| ($answer eq 'con_lost') \|\| ($answer eq 'refused') \|\|
	($answer eq 'unknown_cmd') \|\| ($answer eq 'rejected')) {
	foreach my $line (split(/\&/,$answer)) {
	my ($name,$value)=split(/\=/,$line);
	$returnhash{&unescape($name)}=&thaw_unescape($value);
	}
	my $version;
	for ($version=1;$version<=$returnhash{'version'};$version++) {
	foreach my $item (split(/\:/,$returnhash{$version.':keys'})) {
	$returnhash{$item}=$returnhash{$version.':'.$item};
	}
	}
	}
	return %returnhash;
	}

# ----------------------------------construct domainconfig user for a domain	# ----------------------------------construct domainconfig user for a domain
sub get_domainconfiguser {	sub get_domainconfiguser {
my ($udom) = @_;	my ($udom) = @_;
Line 2233 sub get_domainconfiguser {	Line 2345 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 2266 sub retrieve_inst_usertypes {	Line 2378 sub retrieve_inst_usertypes {

sub is_domainimage {	sub is_domainimage {
my ($url) = @_;	my ($url) = @_;
if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img\|logo\|domlogo)/+[^/]-) {	if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img\|logo\|domlogo\|login)/+[^/]-) {
if (&domain($1) ne '') {	if (&domain($1) ne '') {
return '1';	return '1';
}	}
Line 2504 sub inst_rulecheck {	Line 2616 sub inst_rulecheck {
$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 2533 sub inst_userrules {	Line 2649 sub inst_userrules {
} elsif ($check eq 'email') {	} elsif ($check eq 'email') {
$response=&reply('instemailrules:'.&escape($udom),	$response=&reply('instemailrules:'.&escape($udom),
$homeserver);	$homeserver);
	} elsif ($check eq 'unamemap') {
	$response=&reply('unamemaprules:'.&escape($udom),
	$homeserver);
} else {	} else {
$response=&reply('instuserrules:'.&escape($udom),	$response=&reply('instuserrules:'.&escape($udom),
$homeserver);	$homeserver);
Line 2574 sub get_domain_defaults {	Line 2693 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','selfenrollment',
'coursecategories','ssl','autoenroll',	'coursecategories','ssl','autoenroll',
'trust','helpsettings'],$domain);	'trust','helpsettings','wafproxy',
	'ltisec','toolsec'],$domain);
my @coursetypes = ('official','unofficial','community','textbook','placement');	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'};
Line 2588 sub get_domain_defaults {	Line 2708 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'};
	$domdefaults{'unamemap_rule'} = $domconfig{'defaults'}{'unamemap_rule'};
} else {	} else {
$domdefaults{'lang_def'} = &domain($domain,'lang_def');	$domdefaults{'lang_def'} = &domain($domain,'lang_def');
$domdefaults{'auth_def'} = &domain($domain,'auth_def');	$domdefaults{'auth_def'} = &domain($domain,'auth_def');
Line 2628 sub get_domain_defaults {	Line 2751 sub get_domain_defaults {
if (ref($domconfig{'coursedefaults'}) eq 'HASH') {	if (ref($domconfig{'coursedefaults'}) eq 'HASH') {
$domdefaults{'canuse_pdfforms'} = $domconfig{'coursedefaults'}{'canuse_pdfforms'};	$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{'uselcmath'} = $domconfig{'coursedefaults'}{'uselcmath'};	$domdefaults{'uselcmath'} = $domconfig{'coursedefaults'}{'uselcmath'};
if (ref($domconfig{'coursedefaults'}{'postsubmit'}) eq 'HASH') {	if (ref($domconfig{'coursedefaults'}{'postsubmit'}) eq 'HASH') {
$domdefaults{'postsubmit'} = $domconfig{'coursedefaults'}{'postsubmit'}{'client'};	$domdefaults{'postsubmit'} = $domconfig{'coursedefaults'}{'postsubmit'}{'client'};
Line 2660 sub get_domain_defaults {	Line 2784 sub get_domain_defaults {
}	}
if ($domconfig{'coursedefaults'}{'texengine'}) {	if ($domconfig{'coursedefaults'}{'texengine'}) {
$domdefaults{'texengine'} = $domconfig{'coursedefaults'}{'texengine'};	$domdefaults{'texengine'} = $domconfig{'coursedefaults'}{'texengine'};
}	}
	if (exists($domconfig{'coursedefaults'}{'ltiauth'})) {
	$domdefaults{'crsltiauth'} = $domconfig{'coursedefaults'}{'ltiauth'};
	}
}	}
if (ref($domconfig{'usersessions'}) eq 'HASH') {	if (ref($domconfig{'usersessions'}) eq 'HASH') {
if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') {	if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') {
Line 2672 sub get_domain_defaults {	Line 2799 sub get_domain_defaults {
if (ref($domconfig{'usersessions'}{'offloadnow'}) eq 'HASH') {	if (ref($domconfig{'usersessions'}{'offloadnow'}) eq 'HASH') {
$domdefaults{'offloadnow'} = $domconfig{'usersessions'}{'offloadnow'};	$domdefaults{'offloadnow'} = $domconfig{'usersessions'}{'offloadnow'};
}	}
	if (ref($domconfig{'usersessions'}{'offloadoth'}) eq 'HASH') {
	$domdefaults{'offloadoth'} = $domconfig{'usersessions'}{'offloadoth'};
	}
}	}
if (ref($domconfig{'selfenrollment'}) eq 'HASH') {	if (ref($domconfig{'selfenrollment'}) eq 'HASH') {
if (ref($domconfig{'selfenrollment'}{'admin'}) eq 'HASH') {	if (ref($domconfig{'selfenrollment'}{'admin'}) eq 'HASH') {
Line 2732 sub get_domain_defaults {	Line 2862 sub get_domain_defaults {
}	}
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'};
}	}
if (ref($domconfig{'helpsettings'}) eq 'HASH') {	if (ref($domconfig{'helpsettings'}) eq 'HASH') {
$domdefaults{'submitbugs'} = $domconfig{'helpsettings'}{'submitbugs'};	$domdefaults{'submitbugs'} = $domconfig{'helpsettings'}{'submitbugs'};
Line 2739 sub get_domain_defaults {	Line 2870 sub get_domain_defaults {
$domdefaults{'adhocroles'} = $domconfig{'helpsettings'}{'adhoc'};	$domdefaults{'adhocroles'} = $domconfig{'helpsettings'}{'adhoc'};
}	}
}	}
	if (ref($domconfig{'wafproxy'}) eq 'HASH') {
	foreach my $item ('ipheader','trusted','vpnint','vpnext','sslopt') {
	if ($domconfig{'wafproxy'}{$item}) {
	$domdefaults{'waf_'.$item} = $domconfig{'wafproxy'}{$item};
	}
	}
	}
	if (ref($domconfig{'ltisec'}) eq 'HASH') {
	if (ref($domconfig{'ltisec'}{'encrypt'}) eq 'HASH') {
	$domdefaults{'linkprotenc_crs'} = $domconfig{'ltisec'}{'encrypt'}{'crs'};
	$domdefaults{'linkprotenc_dom'} = $domconfig{'ltisec'}{'encrypt'}{'dom'};
	$domdefaults{'ltienc_consumers'} = $domconfig{'ltisec'}{'encrypt'}{'consumers'};
	}
	if (ref($domconfig{'ltisec'}{'private'}) eq 'HASH') {
	if (ref($domconfig{'ltisec'}{'private'}{'keys'}) eq 'ARRAY') {
	$domdefaults{'ltiprivhosts'} = $domconfig{'ltisec'}{'private'}{'keys'};
	}
	}
	}
	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'};
	}
	}
	}
&do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);	&do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);
return %domdefaults;	return %domdefaults;
}	}
Line 2758 sub get_dom_cats {	Line 2919 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 2775 sub get_dom_instcats {	Line 2936 sub get_dom_instcats {
if (&auto_instcode_format($caller,$dom,\%coursecodes,\%codes,	if (&auto_instcode_format($caller,$dom,\%coursecodes,\%codes,
\@codetitles,\%cat_titles,\%cat_order) eq 'ok') {	\@codetitles,\%cat_titles,\%cat_order) eq 'ok') {
$instcats = {	$instcats = {
	totcodes => $totcodes,
codes => \%codes,	codes => \%codes,
codetitles => \@codetitles,	codetitles => \@codetitles,
cat_titles => \%cat_titles,	cat_titles => \%cat_titles,
Line 2803 sub retrieve_instcodes {	Line 2965 sub retrieve_instcodes {
}	}

sub course_portal_url {	sub course_portal_url {
my ($cnum,$cdom) = @_;	my ($cnum,$cdom,$r) = @_;
my $chome = &homeserver($cnum,$cdom);	my $chome = &homeserver($cnum,$cdom);
my $hostname = &hostname($chome);	my $hostname = &hostname($chome);
my $protocol = $protocol{$chome};	my $protocol = $protocol{$chome};
Line 2813 sub course_portal_url {	Line 2975 sub course_portal_url {
if ($domdefaults{'portal_def'}) {	if ($domdefaults{'portal_def'}) {
$firsturl = $domdefaults{'portal_def'};	$firsturl = $domdefaults{'portal_def'};
} else {	} else {
	my $alias = &use_proxy_alias($r,$chome);
	$hostname = $alias if ($alias ne '');
$firsturl = $protocol.'://'.$hostname;	$firsturl = $protocol.'://'.$hostname;
}	}
return $firsturl;	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 2989 sub courseid_to_courseurl {	Line 3173 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 3187 sub userenvironment {	Line 3371 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 3204 sub studentphoto {	Line 3388 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 3216 sub studentphoto {	Line 3400 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 3437 sub ssi_body {	Line 3621 sub ssi_body {
# --------------------------------------------------------- Server Side Include	# --------------------------------------------------------- Server Side Include

sub absolute_url {	sub absolute_url {
my ($host_name) = @_;	my ($host_name,$unalias,$keep_proto) = @_;
my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://');	my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://');
if ($host_name eq '') {	if ($host_name eq '') {
$host_name = $ENV{'SERVER_NAME'};	$host_name = $ENV{'SERVER_NAME'};
}	}
	if ($unalias) {
	my $alias = &get_proxy_alias();
	if ($alias eq $host_name) {
	my $lonhost = $perlvar{'lonHostID'};
	my $hostname = &hostname($lonhost);
	my $lcproto;
	if (($keep_proto) \|\| ($hostname eq '')) {
	$lcproto = $protocol;
	} else {
	$lcproto = $protocol{$lonhost};
	$lcproto = 'http' if ($lcproto ne 'https');
	$lcproto .= '://';
	}
	unless ($hostname eq '') {
	return $lcproto.$hostname;
	}
	}
	}
return $protocol.$host_name;	return $protocol.$host_name;
}	}

Line 3458 sub absolute_url {	Line 3660 sub absolute_url {
sub ssi {	sub ssi {

my ($fn,%form)=@_;	my ($fn,%form)=@_;
my $request;	my ($host,$request,$response);
	$host = &absolute_url('',1);

$form{'no_update_last_known'}=1;	$form{'no_update_last_known'}=1;
&Apache::lonenc::check_encrypt(\$fn);	&Apache::lonenc::check_encrypt(\$fn);
if (%form) {	if (%form) {
$request=new HTTP::Request('POST',&absolute_url().$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'
Line 3471 sub ssi {	Line 3674 sub ssi {
: &escape($form{$_}) );	: &escape($form{$_}) );
} keys(%form)));	} keys(%form)));
} else {	} else {
$request=new HTTP::Request('GET',&absolute_url().$fn);	$request=new HTTP::Request('GET',$host.$fn);
}	}

$request->header(Cookie => $ENV{'HTTP_COOKIE'});	$request->header(Cookie => $ENV{'HTTP_COOKIE'});
Line 3481 sub ssi {	Line 3684 sub ssi {
($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'}:'')))) {
$islocal = 1;	$islocal = 1;
}	}
my $response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,	$response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,
'','','',$islocal);	'','','',$islocal);

if (wantarray) {	if (wantarray) {
return ($response->content, $response);	return ($response->content, $response);
Line 3633 sub can_edit_resource {	Line 3836 sub can_edit_resource {
}	}

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 3662 sub can_edit_resource {	Line 3865 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) {
Line 4029 sub clean_filename {	Line 4232 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
	# with loncfile::filename_check() so complete url can be extracted by
	# lonnet::decode_symb()
	$fname=~s/_{3,}/_/g;
return $fname;	return $fname;
}	}

Line 4074 sub resizeImage {	Line 4281 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 4086 sub resizeImage {	Line 4293 sub resizeImage {
# 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 4297 sub finishuserfileupload {	Line 4504 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 4533 sub embedded_dependency {	Line 4753 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 '') &&
Line 4586 sub bubblesheet_converter {	Line 4830 sub bubblesheet_converter {
next if (($num == 1) && ($csvoptions{'hdr'} == 1));	next if (($num == 1) && ($csvoptions{'hdr'} == 1));
$line =~ s{[\r\n]+$}{};	$line =~ s{[\r\n]+$}{};
my %found;	my %found;
my @values = split(/,/,$line);	my @values = split(/,/,$line,-1);
my ($qstart,$record);	my ($qstart,$record);
for (my $i=0; $i<@values; $i++) {	for (my $i=0; $i<@values; $i++) {
if ((($qstart ne '') && ($i > $qstart)) \|\|	if ((($qstart ne '') && ($i > $qstart)) \|\|
Line 4769 sub get_scantronformat_file {	Line 5013 sub get_scantronformat_file {
close($fh);	close($fh);
}	}
}	}
	chomp(@lines);
}	}
return @lines;	return @lines;
}	}
Line 4890 sub flushcourselogs {	Line 5135 sub flushcourselogs {
if (! defined($dom) \|\| $dom eq '' \|\|	if (! defined($dom) \|\| $dom eq '' \|\|
! defined($name) \|\| $name eq '') {	! defined($name) \|\| $name eq '') {
my $cid = $env{'request.course.id'};	my $cid = $env{'request.course.id'};
	#
	# FIXME 11/29/2021
	# Typo in rev. 1.458 (2003/12/09)??
	# 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'}
	# $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.
	#
	# That said there is a lot of noise in the data being stored.
	# So counts for prtspool/ and adm/ etc. are recorded.
	#
	# 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.'
	#
	# 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
	# 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.
	#
	# For an author, nohist_accesscount.db ends up having records for other items
	# mixed up with the legitimate access counts for the author's published resources.
	#
$dom = $env{'request.'.$cid.'.domain'};	$dom = $env{'request.'.$cid.'.domain'};
$name = $env{'request.'.$cid.'.num'};	$name = $env{'request.'.$cid.'.num'};
}	}
Line 4916 sub flushcourselogs {	Line 5184 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 4999 sub courseacclog {	Line 5267 sub courseacclog {
if ($formitem =~ /^HWFILE(?:SIZE\|TOOBIG)/) {	if ($formitem =~ /^HWFILE(?:SIZE\|TOOBIG)/) {
$what.=':'.$formitem.'='.$env{$key};	$what.=':'.$formitem.'='.$env{$key};
} elsif ($formitem !~ /^HWFILE(?:[^.]+)$/) {	} elsif ($formitem !~ /^HWFILE(?:[^.]+)$/) {
$what.=':'.$formitem.'='.$env{$key};	if ($formitem eq 'proctorpassword') {
	$what.=':'.$formitem.'=' . '*' x length($env{$key});
	} else {
	$what.=':'.$formitem.'='.$env{$key};
	}
}	}
}	}
}	}
Line 5111 sub domainrolelog {	Line 5383 sub domainrolelog {
my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_;	my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_;
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 5342 sub get_my_adhocroles {	Line 5614 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 5670 sub extract_lastaccess {	Line 5942 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 6081 sub tmpreset {	Line 6353 sub tmpreset {
if (!$domain) { $domain=$env{'user.domain'}; }	if (!$domain) { $domain=$env{'user.domain'}; }
if (!$stuname) { $stuname=$env{'user.name'}; }	if (!$stuname) { $stuname=$env{'user.name'}; }
if ($domain eq 'public' && $stuname eq 'public') {	if ($domain eq 'public' && $stuname eq 'public') {
$stuname=$ENV{'REMOTE_ADDR'};	$stuname=&get_requestor_ip();
}	}
my $path=LONCAPA::tempdir();	my $path=LONCAPA::tempdir();
my %hash;	my %hash;
Line 6118 sub tmpstore {	Line 6390 sub tmpstore {
if (!$domain) { $domain=$env{'user.domain'}; }	if (!$domain) { $domain=$env{'user.domain'}; }
if (!$stuname) { $stuname=$env{'user.name'}; }	if (!$stuname) { $stuname=$env{'user.name'}; }
if ($domain eq 'public' && $stuname eq 'public') {	if ($domain eq 'public' && $stuname eq 'public') {
$stuname=$ENV{'REMOTE_ADDR'};	$stuname=&get_requestor_ip();
}	}
my $now=time;	my $now=time;
my %hash;	my %hash;
Line 6162 sub tmprestore {	Line 6434 sub tmprestore {
if (!$domain) { $domain=$env{'user.domain'}; }	if (!$domain) { $domain=$env{'user.domain'}; }
if (!$stuname) { $stuname=$env{'user.name'}; }	if (!$stuname) { $stuname=$env{'user.name'}; }
if ($domain eq 'public' && $stuname eq 'public') {	if ($domain eq 'public' && $stuname eq 'public') {
$stuname=$ENV{'REMOTE_ADDR'};	$stuname=&get_requestor_ip();
}	}
my %returnhash;	my %returnhash;
$namespace=~s/\//\_/g;	$namespace=~s/\//\_/g;
Line 6218 sub store {	Line 6490 sub store {
}	}
if (!$home) { $home=$env{'user.home'}; }	if (!$home) { $home=$env{'user.home'}; }

$$storehash{'ip'}=$ENV{'REMOTE_ADDR'};	$$storehash{'ip'}=&get_requestor_ip();
$$storehash{'host'}=$perlvar{'lonHostID'};	$$storehash{'host'}=$perlvar{'lonHostID'};

my $namevalue='';	my $namevalue='';
Line 6254 sub cstore {	Line 6526 sub cstore {
}	}
if (!$home) { $home=$env{'user.home'}; }	if (!$home) { $home=$env{'user.home'}; }

$$storehash{'ip'}=$ENV{'REMOTE_ADDR'};	$$storehash{'ip'}=&get_requestor_ip();
$$storehash{'host'}=$perlvar{'lonHostID'};	$$storehash{'host'}=$perlvar{'lonHostID'};

my $namevalue='';	my $namevalue='';
Line 6672 sub course_adhocrole_privs {	Line 6944 sub course_adhocrole_privs {
$full{$priv} = $restrict;	$full{$priv} = $restrict;
}	}
foreach my $item (split(/,/,$overrides{"internal.adhocpriv.$rolename"})) {	foreach my $item (split(/,/,$overrides{"internal.adhocpriv.$rolename"})) {
next if ($item eq '');	next if ($item eq '');
my ($rule,$rest) = split(/=/,$item);	my ($rule,$rest) = split(/=/,$item);
next unless (($rule eq 'off') \|\| ($rule eq 'on'));	next unless (($rule eq 'off') \|\| ($rule eq 'on'));
foreach my $priv (split(/:/,$rest)) {	foreach my $priv (split(/:/,$rest)) {
if ($priv ne '') {	if ($priv ne '') {
if ($rule eq 'off') {	if ($rule eq 'off') {
$possremove{$priv} = 1;	$possremove{$priv} = 1;
} else {	} else {
$possadd{$priv} = 1;	$possadd{$priv} = 1;
}	}
}	}
}	}
}	}
foreach my $priv (sort(keys(%full))) {	foreach my $priv (sort(keys(%full))) {
if (exists($currprivs{$priv})) {	if (exists($currprivs{$priv})) {
unless (exists($possremove{$priv})) {	unless (exists($possremove{$priv})) {
$storeprivs{$priv} = $currprivs{$priv};	$storeprivs{$priv} = $currprivs{$priv};
}	}
} elsif (exists($possadd{$priv})) {	} elsif (exists($possadd{$priv})) {
$storeprivs{$priv} = $full{$priv};	$storeprivs{$priv} = $full{$priv};
}	}
}	}
$coursepriv = ':'.join(':',map { $_.'&'.$storeprivs{$_}; } sort(keys(%storeprivs)));	$coursepriv = ':'.join(':',map { $_.'&'.$storeprivs{$_}; } sort(keys(%storeprivs)));
}	}
return $coursepriv;	return $coursepriv;
}	}

sub group_roleprivs {	sub group_roleprivs {
Line 7037 sub unserialize {	Line 7309 sub unserialize {
# 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.
sub dump {	sub dump {
my ($namespace,$udomain,$uname,$regexp,$range,$escapedkeys)=@_;	my ($namespace,$udomain,$uname,$regexp,$range,$escapedkeys,$encrypt)=@_;
if (!$udomain) { $udomain=$env{'user.domain'}; }	if (!$udomain) { $udomain=$env{'user.domain'}; }
if (!$uname) { $uname=$env{'user.name'}; }	if (!$uname) { $uname=$env{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);	my $uhome=&homeserver($uname,$udomain);
Line 7053 sub dump {	Line 7325 sub dump {
$uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});	$uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});
return %{unserialize($reply, $escapedkeys)};	return %{unserialize($reply, $escapedkeys)};
}	}
my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);	my $rep;
	if ($encrypt) {
	$rep=&reply("encrypt:edump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
	} else {
	$rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
	}
my @pairs=split(/\&/,$rep);	my @pairs=split(/\&/,$rep);
my %returnhash=();	my %returnhash=();
if (!($rep =~ /^error/ )) {	if (!($rep =~ /^error/ )) {
Line 7200 sub inc {	Line 7477 sub inc {
# --------------------------------------------------------------- put interface	# --------------------------------------------------------------- put interface

sub put {	sub put {
my ($namespace,$storehash,$udomain,$uname)=@_;	my ($namespace,$storehash,$udomain,$uname,$encrypt)=@_;
if (!$udomain) { $udomain=$env{'user.domain'}; }	if (!$udomain) { $udomain=$env{'user.domain'}; }
if (!$uname) { $uname=$env{'user.name'}; }	if (!$uname) { $uname=$env{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);	my $uhome=&homeserver($uname,$udomain);
Line 7209 sub put {	Line 7486 sub put {
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';	$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
}	}
$items=~s/\&$//;	$items=~s/\&$//;
return &reply("put:$udomain:$uname:$namespace:$items",$uhome);	if ($encrypt) {
	return &reply("encrypt:put:$udomain:$uname:$namespace:$items",$uhome);
	} else {
	return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
	}
}	}

# ------------------------------------------------------------ newput interface	# ------------------------------------------------------------ newput interface
Line 7249 sub putstore {	Line 7530 sub putstore {
foreach my $key (keys(%{$storehash})) {	foreach my $key (keys(%{$storehash})) {
$namevalue.=&escape($key).'='.&freeze_escape($storehash->{$key}).'&';	$namevalue.=&escape($key).'='.&freeze_escape($storehash->{$key}).'&';
}	}
$namevalue .= 'ip='.&escape($ENV{'REMOTE_ADDR'}).	my $ip = &get_requestor_ip();
	$namevalue .= 'ip='.&escape($ip).
'&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 7403 sub get_timebased_id {	Line 7685 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 7433 sub get_timebased_id {	Line 7715 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 7473 sub portfolio_access {	Line 7755 sub portfolio_access {
if ($result) {	if ($result) {
my %setters;	my %setters;
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) =	my ($startblock,$endblock,$triggerblock,$by_ip,$blockdom) =
&Apache::loncommon::blockcheck(\%setters,'port',$unum,$udom);	&Apache::loncommon::blockcheck(\%setters,'port',$clientip,$unum,$udom);
if ($startblock && $endblock) {	if (($startblock && $endblock) \|\| ($by_ip)) {
return 'B';	return 'B';
}	}
} else {	} else {
my ($startblock,$endblock) =	my ($startblock,$endblock,$triggerblock,$by_ip,$blockdom) =
&Apache::loncommon::blockcheck(\%setters,'port');	&Apache::loncommon::blockcheck(\%setters,'port',$clientip);
if ($startblock && $endblock) {	if (($startblock && $endblock) \|\| ($by_ip)) {
return 'B';	return 'B';
}	}
}	}
Line 7722 sub is_portfolio_file {	Line 8004 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 7747 sub usertools_access {	Line 8040 sub usertools_access {
blog => 1,	blog => 1,
webdav => 1,	webdav => 1,
portfolio => 1,	portfolio => 1,
	timezone => 1,
);	);
}	}
return if (!defined($tools{$tool}));	return if (!defined($tools{$tool}));
Line 7871 sub is_course_owner {	Line 8165 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 7942 sub check_can_request {	Line 8236 sub check_can_request {
my @options = ('approval','validate','autolimit');	my @options = ('approval','validate','autolimit');
my $optregex = join('\|',@options);	my $optregex = join('\|',@options);
if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) {	if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) {
	my %willtrust;
foreach my $type (@{$types}) {	foreach my $type (@{$types}) {
if (&usertools_access($uname,$udom,$type,undef,	if (&usertools_access($uname,$udom,$type,undef,
'requestcourses')) {	'requestcourses')) {
Line 7961 sub check_can_request {	Line 8256 sub check_can_request {
if (ref($request_domains) eq 'HASH') {	if (ref($request_domains) eq 'HASH') {
my ($otherdom) = ($item =~ /^($match_domain):($optregex)(=?\d*)$/);	my ($otherdom) = ($item =~ /^($match_domain):($optregex)(=?\d*)$/);
if ($otherdom ne '') {	if ($otherdom ne '') {
if (ref($request_domains->{$type}) eq 'ARRAY') {	unless (exists($willtrust{$otherdom})) {
unless (grep(/^\Q$otherdom\E$/,@{$request_domains->{$type}})) {	$willtrust{$otherdom} = &will_trust('reqcrs',$env{'user.domain'},$otherdom);
	}
	if ($willtrust{$otherdom}) {
	if (ref($request_domains->{$type}) eq 'ARRAY') {
	unless (grep(/^\Q$otherdom\E$/,@{$request_domains->{$type}})) {
	push(@{$request_domains->{$type}},$otherdom);
	}
	} else {
push(@{$request_domains->{$type}},$otherdom);	push(@{$request_domains->{$type}},$otherdom);
}	}
} else {
push(@{$request_domains->{$type}},$otherdom);
}	}
}	}
}	}
Line 8036 sub customaccess {	Line 8336 sub customaccess {
# ------------------------------------------------- Check for a user privilege	# ------------------------------------------------- Check for a user privilege

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

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

if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }	if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }
# Free bre access to adm and meta resources	# Free bre access to adm and meta resources
if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg\|bulletinboard\|ext\.tool)$}))	if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg\|bulletinboard\|viewclasslist\|aboutme\|ext\.tool)$}))
\|\| (($uri=~/\.meta$/) && ($uri!~m\|^uploaded/\|) ))	\|\| (($uri=~/\.meta$/) && ($uri!~m\|^uploaded/\|) ))
&& ($priv eq 'bre')) {	&& ($priv eq 'bre')) {
return 'F';	return 'F';
Line 8064 sub allowed {	Line 8364 sub allowed {
if (($space=~/^(uploaded\|editupload)$/) && ($env{'user.name'} eq $name) &&	if (($space=~/^(uploaded\|editupload)$/) && ($env{'user.name'} eq $name) &&
($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) {	($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) {
my %setters;	my %setters;
my ($startblock,$endblock) =	my ($startblock,$endblock,$triggerblock,$by_ip,$blockdom) =
&Apache::loncommon::blockcheck(\%setters,'port');	&Apache::loncommon::blockcheck(\%setters,'port',$clientip);
if ($startblock && $endblock) {	if (($startblock && $endblock) \|\| ($by_ip)) {
return 'B';	return 'B';
} else {	} else {
return 'F';	return 'F';
Line 8162 sub allowed {	Line 8462 sub allowed {
my $adom = $1;	my $adom = $1;
foreach my $key (keys(%env)) {	foreach my $key (keys(%env)) {
if ($key =~ m{^user\.role\.(ca\|aa)/\Q$adom\E}) {	if ($key =~ m{^user\.role\.(ca\|aa)/\Q$adom\E}) {
my ($start,$end) = split('.',$env{$key});	my ($start,$end) = split(/\./,$env{$key});
if (($now >= $start) && (!$end \|\| $end < $now)) {	if (($now >= $start) && (!$end \|\| $end > $now)) {
$ownaccess = 1;	$ownaccess = 1;
last;	last;
}	}
Line 8175 sub allowed {	Line 8475 sub allowed {
foreach my $role ('ca','aa') {	foreach my $role ('ca','aa') {
if ($env{"user.role.$role./$adom/$aname"}) {	if ($env{"user.role.$role./$adom/$aname"}) {
my ($start,$end) =	my ($start,$end) =
split('.',$env{"user.role.$role./$adom/$aname"});	split(/\./,$env{"user.role.$role./$adom/$aname"});
if (($now >= $start) && (!$end \|\| $end < $now)) {	if (($now >= $start) && (!$end \|\| $end > $now)) {
$ownaccess = 1;	$ownaccess = 1;
last;	last;
}	}
Line 8261 sub allowed {	Line 8561 sub allowed {
if ($env{'user.priv.'.$env{'request.role'}.'./'}	if ($env{'user.priv.'.$env{'request.role'}.'./'}
=~/\Q$priv\E\&([^\:]*)/) {	=~/\Q$priv\E\&([^\:]*)/) {
my $value = $1;	my $value = $1;
my $deeplinkblock = &deeplink_check($priv,$symb,$uri);	my $deeplinkblock;
	unless ($nodeeplinkcheck) {
	$deeplinkblock = &deeplink_check($priv,$symb,$uri);
	}
if ($deeplinkblock) {	if ($deeplinkblock) {
$thisallowed='D';	$thisallowed='D';
} elsif ($noblockcheck) {	} elsif ($noblockcheck) {
Line 8284 sub allowed {	Line 8587 sub allowed {
$refuri=&declutter($refuri);	$refuri=&declutter($refuri);
my ($match) = &is_on_map($refuri);	my ($match) = &is_on_map($refuri);
if ($match) {	if ($match) {
my $deeplinkblock = &deeplink_check($priv,$symb,$refuri);	my $deeplinkblock;
	unless ($nodeeplinkcheck) {
	$deeplinkblock = &deeplink_check($priv,$symb,$refuri);
	}
if ($deeplinkblock) {	if ($deeplinkblock) {
$thisallowed='D';	$thisallowed='D';
} elsif ($noblockcheck) {	} elsif ($noblockcheck) {
Line 8337 sub allowed {	Line 8643 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 8360 sub allowed {	Line 8672 sub allowed {
=~/\Q$priv\E\&([^\:]*)/) {	=~/\Q$priv\E\&([^\:]*)/) {
my $value = $1;	my $value = $1;
if ($priv eq 'bre') {	if ($priv eq 'bre') {
if ($noblockcheck) {	my $deeplinkblock;
	unless ($nodeeplinkcheck) {
	$deeplinkblock = &deeplink_check($priv,$symb,$uri);
	}
	if ($deeplinkblock) {
	$thisallowed = 'D';
	} elsif ($noblockcheck) {
$thisallowed.=$value;	$thisallowed.=$value;
} else {	} else {
my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache);	my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache);
Line 8402 sub allowed {	Line 8720 sub allowed {
=~/\Q$priv\E\&([^\:]*)/) {	=~/\Q$priv\E\&([^\:]*)/) {
my $value = $1;	my $value = $1;
if ($priv eq 'bre') {	if ($priv eq 'bre') {
my $deeplinkblock = &deeplink_check($priv,$symb,$refuri);	my $deeplinkblock;
	unless ($nodeeplinkcheck) {
	$deeplinkblock = &deeplink_check($priv,$symb,$refuri);
	}
if ($deeplinkblock) {	if ($deeplinkblock) {
$thisallowed = 'D';	$thisallowed = 'D';
} elsif ($noblockcheck) {	} elsif ($noblockcheck) {
Line 8450 sub allowed {	Line 8771 sub allowed {
#	#

# Possibly locked functionality, check all courses	# Possibly locked functionality, check all courses
	# In roles.tab, L (unless locked) available for bre, pch, plc, pac and sma.
# Locks might take effect only after 10 minutes cache expiration for other	# Locks might take effect only after 10 minutes cache expiration for other
# courses, and 2 minutes for current course	# courses, and 2 minutes for current course, in which user has st or ta role
	# which is neither expired nor a future role (unless current course).

my $envkey;	my ($needlockcheck,$now,$crsonly);
if ($thisallowed=~/L/) {	if ($thisallowed=~/L/) {
foreach $envkey (keys(%env)) {	$now = time;
	if ($priv eq 'bre') {
	if ($uri ne '') {
	if ($orguri =~ m{^/+res/}) {
	if ($uri =~ m{^lib/templates/}) {
	if ($env{'request.course.id'}) {
	$crsonly = 1;
	$needlockcheck = 1;
	}
	} else {
	$needlockcheck = 1;
	}
	} elsif ($env{'request.course.id'}) {
	my ($crsdom,$crsnum) = split('_',$env{'request.course.id'});
	if (($uri =~ m{^(adm\|uploaded\|public)/$crsdom/$crsnum/}) \|\|
	($uri =~ m{^adm/$match_domain/$match_username/\d+/(smppg\|bulletinboard)$})) {
	$crsonly = 1;
	}
	$needlockcheck = 1;
	}
	}
	} elsif (($priv eq 'pch') \|\| ($priv eq 'plc') \|\| ($priv eq 'pac') \|\| ($priv eq 'sma')) {
	$needlockcheck = 1;
	}
	}
	if ($needlockcheck) {
	foreach my $envkey (keys(%env)) {
if ($envkey=~/^user\.role\.(st\|ta)\.([^\.]*)/) {	if ($envkey=~/^user\.role\.(st\|ta)\.([^\.]*)/) {
my $courseid=$2;	my $courseid=$2;
my $roleid=$1.'.'.$2;	my $roleid=$1.'.'.$2;
$courseid=~s/^\///;	$courseid=~s/^\///;
	unless ($env{'request.role'} eq $roleid) {
	my ($start,$end) = split(/\./,$env{$envkey});
	next unless (($now >= $start) && (!$end \|\| $end > $now));
	}
my $expiretime=600;	my $expiretime=600;
if ($env{'request.role'} eq $roleid) {	if ($env{'request.role'} eq $roleid) {
$expiretime=120;	$expiretime=120;
Line 8482 sub allowed {	Line 8835 sub allowed {
}	}
if (($env{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/)	if (($env{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/)
\|\| ($env{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {	\|\| ($env{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {
if ($env{'priv.'.$priv.'.lock.expire'}>time) {	if ($env{$prefix.'priv.'.$priv.'.lock.expire'}>time) {
&log($env{'user.domain'},$env{'user.name'},	&log($env{'user.domain'},$env{'user.name'},
$env{'user.home'},	$env{'user.home'},
'Locked by priv: '.$priv.' for '.$uri.' due to '.	'Locked by priv: '.$priv.' for '.$uri.' due to '.
Line 8553 sub allowed {	Line 8906 sub allowed {
}	}
}	}

	# Restricted for deeplinked session?

	if ($env{'request.deeplink.login'}) {
	if ($env{'acc.deeplinkout'} && !$nodeeplinkout) {
	if (!$symb) { $symb=&symbread($uri,1); }
	if (($symb) && ($env{'acc.deeplinkout'}=~/\&\Q$symb\E\&/)) {
	return '';
	}
	}
	}

# Restricted by state or randomout?	# Restricted by state or randomout?

if ($thisallowed=~/X/) {	if ($thisallowed=~/X/) {
Line 8699 sub get_comm_blocks {	Line 9063 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 8710 sub get_commblock_resources {	Line 9074 sub get_commblock_resources {
my ($blocks) = @_;	my ($blocks) = @_;
my %blockers = ();	my %blockers = ();
return %blockers unless ($env{'request.course.id'});	return %blockers unless ($env{'request.course.id'});
return %blockers if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/);	my $courseurl = &courseid_to_courseurl($env{'request.course.id'});
	if ($env{'request.course.sec'}) {
	$courseurl .= '/'.$env{'request.course.sec'};
	}
	return %blockers if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseurl} =~/evb\&([^\:]*)/);
my %commblocks;	my %commblocks;
if (ref($blocks) eq 'HASH') {	if (ref($blocks) eq 'HASH') {
%commblocks = %{$blocks};	%commblocks = %{$blocks};
Line 8742 sub get_commblock_resources {	Line 9110 sub get_commblock_resources {
}	}
} elsif ($block =~ /^firstaccess____(.+)$/) {	} elsif ($block =~ /^firstaccess____(.+)$/) {
my $item = $1;	my $item = $1;
my @to_test;
if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {	if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {
if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {	if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {
my @interval;	my (@interval,$mapname);
my $type = 'map';	my $type = 'map';
if ($item eq 'course') {	if ($item eq 'course') {
$type = 'course';	$type = 'course';
Line 8754 sub get_commblock_resources {	Line 9121 sub get_commblock_resources {
if ($item =~ /___\d+___/) {	if ($item =~ /___\d+___/) {
$type = 'resource';	$type = 'resource';
@interval=&EXT("resource.0.interval",$item);	@interval=&EXT("resource.0.interval",$item);
if (ref($navmap)) {
my $res = $navmap->getBySymb($item);
push(@to_test,$res);
}
} else {	} else {
my $mapsymb = &symbread($item,1);	$mapname = &deversion($item);
if ($mapsymb) {	if (ref($navmap)) {
if (ref($navmap)) {	my $timelimit = $navmap->get_mapparam(undef,$mapname,'0.interval');
my $mapres = $navmap->getBySymb($mapsymb);	@interval = ($timelimit,'map');
if (ref($mapres)) {
my $first = $mapres->map_start();
my $finish = $mapres->map_finish();
my $it = $navmap->getIterator($first,$finish,undef,0,0);
if (ref($it)) {
my $res;
while ($res = $it->next(undef,1)) {
next unless (ref($res));
my $symb = $res->symb();
next if (($symb eq $mapsymb) \|\| ($symb eq ''));
@interval=&EXT("resource.0.interval",$symb);
if ($interval[1] eq 'map') {
if ($res->answerable()) {
push(@to_test,$res);
last;
}
}
}
}
}
}
}	}
}	}
}	}
Line 8801 sub get_commblock_resources {	Line 9143 sub get_commblock_resources {
my $timesup = $first_access+$timelimit;	my $timesup = $first_access+$timelimit;
if ($timesup > $now) {	if ($timesup > $now) {
my $activeblock;	my $activeblock;
foreach my $res (@to_test) {	if ($type eq 'resource') {
if ($res->answerable()) {	if (ref($navmap)) {
$activeblock = 1;	my $res = $navmap->getBySymb($item);
last;	if ($res->answerable()) {
	$activeblock = 1;
	}
	}
	} elsif ($type eq 'map') {
	my $mapsymb = &symbread($mapname,1);
	if (($mapsymb) && (ref($navmap))) {
	my $mapres = $navmap->getBySymb($mapsymb);
	if (ref($mapres)) {
	my $first = $mapres->map_start();
	my $finish = $mapres->map_finish();
	my $it = $navmap->getIterator($first,$finish,undef,0,0);
	if (ref($it)) {
	my $res;
	while ($res = $it->next(undef,1)) {
	next unless (ref($res));
	my $symb = $res->symb();
	next if (($symb eq $mapsymb) \|\| ($symb eq ''));
	@interval=&EXT("resource.0.interval",$symb);
	if ($interval[1] eq 'map') {
	if ($res->answerable()) {
	$activeblock = 1;
	last;
	}
	}
	}
	}
	}
}	}
}	}
if ($activeblock) {	if ($activeblock) {
Line 8834 sub has_comm_blocking {	Line 9203 sub has_comm_blocking {
my @blockers;	my @blockers;
return unless ($env{'request.course.id'});	return unless ($env{'request.course.id'});
return unless ($priv eq 'bre');	return unless ($priv eq 'bre');
return if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/);
return if ($env{'request.state'} eq 'construct');	return if ($env{'request.state'} eq 'construct');
	my $courseurl = &courseid_to_courseurl($env{'request.course.id'});
	if ($env{'request.course.sec'}) {
	$courseurl .= '/'.$env{'request.course.sec'};
	}
	return if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseurl} =~/evb\&([^\:]*)/);
my %blockinfo;	my %blockinfo;
if (ref($blocks) eq 'HASH') {	if (ref($blocks) eq 'HASH') {
%blockinfo = &get_commblock_resources($blocks);	%blockinfo = &get_commblock_resources($blocks);
Line 8910 sub deeplink_check {	Line 9283 sub deeplink_check {
@symbs = keys(%possibles);	@symbs = keys(%possibles);
}	}

my ($login,$switchrole,$allow);	my ($deeplink_symb,$allow);
if ($env{'request.deeplink.login'} =~ m{^\Q/tiny/$cdom/\E(\w+)$}) {	if ($env{'request.deeplink.login'}) {
my $key = $1;	$deeplink_symb = &Apache::loncommon::deeplink_login_symb($cnum,$cdom);
my $tinyurl;
my ($result,$cached)=&Apache::lonnet::is_cached_new('tiny',$cdom."\0".$key);
if (defined($cached)) {
$tinyurl = $result;
} else {
my $configuname = &Apache::lonnet::get_domainconfiguser($cdom);
my %currtiny = &Apache::lonnet::get('tiny',[$key],$cdom,$configuname);
if ($currtiny{$key} ne '') {
$tinyurl = $currtiny{$key};
&Apache::lonnet::do_cache_new('tiny',$cdom."\0".$key,$currtiny{$key},600);
}
}
if ($tinyurl ne '') {
my ($cnumreq,$posslogin) = split(/\&/,$tinyurl);
if ($cnumreq eq $cnum) {
$login = $posslogin;
} else {
$switchrole = 1;
}
}
}	}
foreach my $symb (@symbs) {	foreach my $symb (@symbs) {
last if ($allow);	last if ($allow);
Line 8940 sub deeplink_check {	Line 9293 sub deeplink_check {
if ($deeplink eq '') {	if ($deeplink eq '') {
$allow = 1;	$allow = 1;
} else {	} else {
my ($listed,$scope,$access) = split(/,/,$deeplink);	my ($state,$others,$listed,$scope,$protect) = split(/,/,$deeplink);
if ($access eq 'any') {	if ($state ne 'only') {
$allow = 1;	$allow = 1;
} elsif ($login) {	} else {
if ($access eq 'only') {	my $check_deeplink_entry;
if ($scope eq 'res') {	if ($protect ne 'none') {
if ($symb eq $login) {	my ($acctype,$item) = split(/:/,$protect);
$allow = 1;	if (($acctype eq 'ltic') && ($env{'user.linkprotector'})) {
	if (grep(/^\Q$item\Ec$/,split(/,/,$env{'user.linkprotector'}))) {
	$check_deeplink_entry = 1
}	}
} elsif ($scope eq 'map') {	} elsif (($acctype eq 'ltid') && ($env{'user.linkprotector'})) {
#FIXME Compare map for $env{'request.deeplink.login'} with map for $symb	if (grep(/^\Q$item\Ed$/,split(/,/,$env{'user.linkprotector'}))) {
} elsif ($scope eq 'rec') {	$check_deeplink_entry = 1;
#FIXME Recurse up for $env{'request.deeplink.login'} with map for $symb
}
} else {
my ($acctype,$item) = split(/:/,$access);
if (($acctype eq 'lti') && ($env{'user.linkprotector'})) {
if (grep(/^\Q$item\E$/,split(/,/,$env{'user.linkprotector'}))) {
my %tinyurls = &get('tiny',[$symb],$cdom,$cnum);
if (grep(/\Q$tinyurls{$symb}\E$/,split(/,/,$env{'user.linkproturis'}))) {
$allow = 1;
}
}	}
} elsif (($acctype eq 'key') && ($env{'user.deeplinkkey'})) {	} elsif (($acctype eq 'key') && ($env{'user.deeplinkkey'})) {
if (grep(/^\Q$item\E$/,split(/,/,$env{'user.deeplinkkey'}))) {	if (grep(/^\Q$item\E$/,split(/,/,$env{'user.deeplinkkey'}))) {
my %tinyurls = &get('tiny',[$symb],$cdom,$cnum);	$check_deeplink_entry = 1;
if (grep(/\Q$tinyurls{$symb}\E$/,split(/,/,$env{'user.keyedlinkuri'}))) {	}
	}
	}
	if (($protect eq 'none') \|\| ($check_deeplink_entry)) {
	if ($scope eq 'res') {
	if ($symb eq $deeplink_symb) {
	$allow = 1;
	}
	} elsif (($scope eq 'map') \|\| ($scope eq 'rec')) {
	my ($map_from_symb,$map_from_login);
	$map_from_symb = &deversion((&decode_symb($symb))[0]);
	if ($deeplink_symb =~ /\.(page\|sequence)$/) {
	$map_from_login = &deversion((&decode_symb($deeplink_symb))[2]);
	} else {
	$map_from_login = &deversion((&decode_symb($deeplink_symb))[0]);
	}
	if (($map_from_symb) && ($map_from_login)) {
	if ($map_from_symb eq $map_from_login) {
$allow = 1;	$allow = 1;
	} elsif ($scope eq 'rec') {
	my @recurseup = &get_map_hierarchy($map_from_symb,$env{'request.course.id'});
	if (grep(/^\Q$map_from_login\E$/,@recurseup)) {
	$allow = 1;
	}
}	}
}	}
}	}
Line 9240 sub fetch_enrollment_query {	Line 9607 sub fetch_enrollment_query {
}	}

sub get_query_reply {	sub get_query_reply {
my ($queryid,$sleep,$loopmax) = @_;;	my ($queryid,$sleep,$loopmax) = @_;
if (($sleep eq '') \|\| ($sleep !~ /^\d+\.?\d*$/)) {	if (($sleep eq '') \|\| ($sleep !~ /^\d+\.?\d*$/)) {
$sleep = 0.2;	$sleep = 0.2;
}	}
Line 9373 sub auto_validate_instcode {	Line 9740 sub auto_validate_instcode {
return ($outcome,$description,$defaultcredits);	return ($outcome,$description,$defaultcredits);
}	}

	sub auto_validate_inst_crosslist {
	my ($cnum,$cdom,$instcode,$inst_xlist,$coowner) = @_;
	my ($homeserver,$response);
	if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) {
	$homeserver = &homeserver($cnum,$cdom);
	}
	if (!defined($homeserver)) {
	if ($cdom =~ /^$match_domain$/) {
	$homeserver = &domain($cdom,'primary');
	}
	}
	unless (($homeserver eq '') \|\| ($homeserver eq 'no_host')) {
	$response=&reply('autovalidateinstcrosslist:'.$cdom.':'.
	&escape($instcode).':'.&escape($inst_xlist).':'.
	&escape($coowner),$homeserver);
	}
	return $response;
	}

sub auto_create_password {	sub auto_create_password {
my ($cnum,$cdom,$authparam,$udom) = @_;	my ($cnum,$cdom,$authparam,$udom) = @_;
my ($homeserver,$response);	my ($homeserver,$response);
Line 9644 sub auto_validate_class_sec {	Line 10030 sub auto_validate_class_sec {
return $response;	return $response;
}	}

	sub auto_instsec_reformat {
	my ($cdom,$action,$instsecref) = @_;
	return unless(($action eq 'clutter') \|\| ($action eq 'declutter'));
	my @homeservers;
	if (defined(&domain($cdom,'primary'))) {
	push(@homeservers,&domain($cdom,'primary'));
	} else {
	my %servers = &get_servers($cdom,'library');
	foreach my $tryserver (keys(%servers)) {
	if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
	push(@homeservers,$tryserver);
	}
	}
	}
	my $response;
	my %reformatted = %{$instsecref};
	foreach my $server (@homeservers) {
	if (ref($instsecref) eq 'HASH') {
	my $info = &freeze_escape($instsecref);
	my $response=&reply('autoinstsecreformat:'.$cdom.':'.
	$action.':'.$info,$server);
	next if ($response =~ /(con_lost\|error\|no_such_host\|refused\|unknown_command)/);
	my @items = split(/&/,$response);
	foreach my $item (@items) {
	my ($key,$value) = split(/=/,$item);
	$reformatted{&unescape($key)} = &thaw_unescape($value);
	}
	}
	}
	return %reformatted;
	}

sub auto_validate_instclasses {	sub auto_validate_instclasses {
my ($cdom,$cnum,$owners,$classesref) = @_;	my ($cdom,$cnum,$owners,$classesref) = @_;
my ($homeserver,%validations);	my ($homeserver,%validations);
Line 9982 sub assignrole {	Line 10400 sub assignrole {
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 '')) {
Line 10194 sub autoupdate_coowners {	Line 10612 sub autoupdate_coowners {
if ($domdesign{$cdom.'.autoassign.co-owners'}) {	if ($domdesign{$cdom.'.autoassign.co-owners'}) {
my %coursehash = &coursedescription($cdom.'_'.$cnum);	my %coursehash = &coursedescription($cdom.'_'.$cnum);
my $instcode = $coursehash{'internal.coursecode'};	my $instcode = $coursehash{'internal.coursecode'};
	my $xlists = $coursehash{'internal.crosslistings'};
if ($instcode ne '') {	if ($instcode ne '') {
if (($start && $start <= $now) && ($end == 0) \|\| ($end > $now)) {	if (($start && $start <= $now) && ($end == 0) \|\| ($end > $now)) {
unless ($coursehash{'internal.courseowner'} eq $uname.':'.$udom) {	unless ($coursehash{'internal.courseowner'} eq $uname.':'.$udom) {
my ($delcoowners,@newcoowners,$putresult,$delresult,$coowners);	my ($delcoowners,@newcoowners,$putresult,$delresult,$coowners);
my ($result,$desc) = &auto_validate_instcode($cnum,$cdom,$instcode,$uname.':'.$udom);	my ($result,$desc) = &auto_validate_instcode($cnum,$cdom,$instcode,$uname.':'.$udom);
	unless ($result eq 'valid') {
	if ($xlists ne '') {
	foreach my $xlist (split(',',$xlists)) {
	my ($inst_crosslist,$lcsec) = split(':',$xlist);
	$result =
	&auto_validate_inst_crosslist($cnum,$cdom,$instcode,
	$inst_crosslist,$uname.':'.$udom);
	last if ($result eq 'valid');
	}
	}
	}
if ($result eq 'valid') {	if ($result eq 'valid') {
if ($coursehash{'internal.co-owners'}) {	if ($coursehash{'internal.co-owners'}) {
foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {	foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {
Line 10211 sub autoupdate_coowners {	Line 10641 sub autoupdate_coowners {
} else {	} else {
push(@newcoowners,$uname.':'.$udom);	push(@newcoowners,$uname.':'.$udom);
}	}
} else {	} elsif ($coursehash{'internal.co-owners'}) {
if ($coursehash{'internal.co-owners'}) {	foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {
foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {	unless ($coowner eq $uname.':'.$udom) {
unless ($coowner eq $uname.':'.$udom) {	push(@newcoowners,$coowner);
push(@newcoowners,$coowner);
}
}
unless (@newcoowners > 0) {
$delcoowners = 1;
$coowners = '';
}	}
}	}
	unless (@newcoowners > 0) {
	$delcoowners = 1;
	$coowners = '';
	}
}	}
if (@newcoowners \|\| $delcoowners) {	if (@newcoowners \|\| $delcoowners) {
&store_coowners($cdom,$cnum,$coursehash{'home'},	&store_coowners($cdom,$cnum,$coursehash{'home'},
Line 10261 sub store_coowners {	Line 10689 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 10296 sub modifyuserauth {	Line 10724 sub modifyuserauth {
' in domain '.$env{'request.role.domain'});	' in domain '.$env{'request.role.domain'});
my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'.	my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'.
&escape($upass),$uhome);	&escape($upass),$uhome);
	my $ip = &get_requestor_ip();
&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},	&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},
'Authentication changed for '.$udom.', '.$uname.', '.$umode.	'Authentication changed for '.$udom.', '.$uname.', '.$umode.
'(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);	'(Remote '.$ip.'): '.$reply);
&log($udom,,$uname,$uhome,	&log($udom,,$uname,$uhome,
'Authentication changed by '.$env{'user.domain'}.', '.	'Authentication changed by '.$env{'user.domain'}.', '.
$env{'user.name'}.', '.$umode.	$env{'user.name'}.', '.$umode.
'(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);	'(Remote '.$ip.'): '.$reply);
unless ($reply eq 'ok') {	unless ($reply eq 'ok') {
&logthis('Authentication mode error: '.$reply);	&logthis('Authentication mode error: '.$reply);
return 'error: '.$reply;	return 'error: '.$reply;
Line 10481 sub modifyuser {	Line 10910 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 10561 sub modify_student_enrollment {	Line 10990 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 10695 sub createcourse {	Line 11124 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 10828 sub store_userdata {	Line 11257 sub store_userdata {
if (($uhome eq '') \|\| ($uhome eq 'no_host')) {	if (($uhome eq '') \|\| ($uhome eq 'no_host')) {
$result = 'error: no_host';	$result = 'error: no_host';
} else {	} else {
$storehash->{'ip'} = $ENV{'REMOTE_ADDR'};	$storehash->{'ip'} = &get_requestor_ip();
$storehash->{'host'} = $perlvar{'lonHostID'};	$storehash->{'host'} = $perlvar{'lonHostID'};

my $namevalue='';	my $namevalue='';
Line 11663 sub stat_file {	Line 12092 sub stat_file {
# or corresponding Published Resource Space, and populate the hash ref:	# or corresponding Published Resource Space, and populate the hash ref:
# $dirhashref with URLs of all directories, and if $filehashref hash	# $dirhashref with URLs of all directories, and if $filehashref hash
# ref arg is provided, the URLs of any files, excluding versioned, .meta,	# ref arg is provided, the URLs of any files, excluding versioned, .meta,
# or .rights files in resource space, and .meta, .save, .log, and .bak	# or .rights files in resource space, and .meta, .save, .log, .bak and
# files in Authoring Space.	# .rights files in Authoring Space.
#	#
# Inputs:	# Inputs:
#	#
# $is_home - true if current server is home server for user's space	# $is_home - true if current server is home server for user's space
# $context - either: priv, or res respectively for Authoring or Resource Space.	# $recurse - if true will also traverse subdirectories recursively
# $docroot - Document root (i.e., /home/httpd/html	# $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).
# $toppath - Top level directory (i.e., /res/$dom/$uname or /priv/$dom/$uname	# $toppath - Top level directory (i.e., /res/$dom/$uname or /priv/$dom/$uname
# $relpath - Current path (relative to top level).	# $relpath - Current path (relative to top level).
# $dirhashref - reference to hash to populate with URLs of directories (Required)	# $dirhashref - reference to hash to populate with URLs of directories (Required)
Line 11687 sub stat_file {	Line 12121 sub stat_file {
#	#

sub recursedirs {	sub recursedirs {
my ($is_home,$context,$docroot,$toppath,$relpath,$dirhashref,$filehashref) = @_;	my ($is_home,$recurse,$include,$exclude,$nonemptydir,$toppath,$relpath,$dirhashref,$filehashref) = @_;
return unless (ref($dirhashref) eq 'HASH');	return unless (ref($dirhashref) eq 'HASH');
	my $docroot = $perlvar{'lonDocRoot'};
my $currpath = $docroot.$toppath;	my $currpath = $docroot.$toppath;
if ($relpath) {	if ($relpath ne '') {
$currpath .= "/$relpath";	$currpath .= "/$relpath";
}	}
my $savefile;	my ($savefile,$checkinc,$checkexc);
if (ref($filehashref)) {	if (ref($filehashref)) {
$savefile = 1;	$savefile = 1;
}	}
	if (ref($include) eq 'HASH') {
	$checkinc = 1;
	}
	if (ref($exclude) eq 'HASH') {
	$checkexc = 1;
	}
if ($is_home) {	if ($is_home) {
if (opendir(my $dirh,$currpath)) {	if (opendir(my $dirh,$currpath)) {
	my $filecount = 0;
foreach my $item (sort { lc($a) cmp lc($b) } grep(!/^\.+$/,readdir($dirh))) {	foreach my $item (sort { lc($a) cmp lc($b) } grep(!/^\.+$/,readdir($dirh))) {
next if ($item eq '');	next if ($item eq '');
if (-d "$currpath/$item") {	if (-d "$currpath/$item") {
my $newpath;	my $newpath;
if ($relpath) {	if ($relpath ne '') {
$newpath = "$relpath/$item";	$newpath = "$relpath/$item";
} else {	} else {
$newpath = $item;	$newpath = $item;
}	}
$dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;	$dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;
&recursedirs($is_home,$context,$docroot,$toppath,$newpath,$dirhashref,$filehashref);	if ($recurse) {
} elsif ($savefile) {	&recursedirs($is_home,$recurse,$include,$exclude,$nonemptydir,$toppath,$newpath,$dirhashref,$filehashref);
if ($context eq 'priv') {	}
unless ($item =~ /\.(meta\|save\|log\|bak\|DS_Store)$/) {	} elsif (($savefile) \|\| ($relpath eq '')) {
$filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1;	next if ($nonemptydir && $filecount);
	if ($checkinc \|\| $checkexc) {
	my ($extension) = ($item =~ /\.(\w+)$/);
	if ($checkinc) {
	next unless ($extension && $include->{$extension});
}	}
} else {	if ($checkexc) {
unless (($item =~ /\.meta$/) \|\| ($item =~ /\.\d+\.\w+$/) \|\| ($item =~ /\.rights$/)) {	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;	$filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1;
}	}
}	}
	$filecount ++;
}	}
}	}
closedir($dirh);	closedir($dirh);
Line 11730 sub recursedirs {	Line 12186 sub recursedirs {
my @dir_lines;	my @dir_lines;
my $dirptr=16384;	my $dirptr=16384;
if (ref($dirlistref) eq 'ARRAY') {	if (ref($dirlistref) eq 'ARRAY') {
	my $filecount = 0;
foreach my $dir_line (sort	foreach my $dir_line (sort
{	{
my ($afile)=split('&',$a,2);	my ($afile)=split('&',$a,2);
Line 11745 sub recursedirs {	Line 12202 sub recursedirs {
if ($relpath) {	if ($relpath) {
$newpath = "$relpath/$item";	$newpath = "$relpath/$item";
} else {	} else {
$relpath = '/';
$newpath = $item;	$newpath = $item;
}	}
$dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;	$dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;
&recursedirs($is_home,$context,$docroot,$toppath,$newpath,$dirhashref,$filehashref);	if ($recurse) {
} elsif ($savefile) {	&recursedirs($is_home,$recurse,$include,$exclude,$nonemptydir,$toppath,$newpath,$dirhashref,$filehashref);
if ($context eq 'priv') {	}
unless ($item =~ /\.(meta\|save\|log\|bak\|DS_Store)$/) {	} elsif (($savefile) \|\| ($relpath eq '')) {
$filehashref->{$relpath}{$item} = 1;	next if ($nonemptydir && $filecount);
	if ($checkinc \|\| $checkexc) {
	my $extension;
	if ($checkinc) {
	next unless ($extension && $include->{$extension});
}	}
} else {	if ($checkexc) {
unless (($item =~ /\.meta$/) \|\| ($item =~ /\.\d+\.\w+$/)) {	next if ($extension && $exclude->{$extension});
$filehashref->{$relpath}{$item} = 1;
}	}
}	}
	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 ++;
}	}
}	}
}	}
Line 11767 sub recursedirs {	Line 12237 sub recursedirs {
return;	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 11980 sub resdata {	Line 12461 sub resdata {

sub get_domain_lti {	sub get_domain_lti {
my ($cdom,$context) = @_;	my ($cdom,$context) = @_;
my ($name,%lti);	my ($name,$cachename,%lti);
if ($context eq 'consumer') {	if ($context eq 'consumer') {
$name = 'ltitools';	$name = 'ltitools';
} elsif ($context eq 'provider') {	} elsif ($context eq 'provider') {
$name = 'lti';	$name = 'lti';
	} elsif ($context eq 'linkprot') {
	$name = 'ltisec';
} else {	} else {
return %lti;	return %lti;
}	}
my ($result,$cached)=&is_cached_new($name,$cdom);
	if ($context eq 'linkprot') {
	$cachename = $context;
	} else {
	$cachename = $name;
	}

	my ($result,$cached)=&is_cached_new($cachename,$cdom);
if (defined($cached)) {	if (defined($cached)) {
if (ref($result) eq 'HASH') {	if (ref($result) eq 'HASH') {
%lti = %{$result};	%lti = %{$result};
Line 11996 sub get_domain_lti {	Line 12486 sub get_domain_lti {
} else {	} else {
my %domconfig = &get_dom('configuration',[$name],$cdom);	my %domconfig = &get_dom('configuration',[$name],$cdom);
if (ref($domconfig{$name}) eq 'HASH') {	if (ref($domconfig{$name}) eq 'HASH') {
%lti = %{$domconfig{$name}};	if ($context eq 'linkprot') {
my %encdomconfig = &get_dom('encconfig',[$name],$cdom);	if (ref($domconfig{$name}{'linkprot'}) eq 'HASH') {
if (ref($encdomconfig{$name}) eq 'HASH') {	%lti = %{$domconfig{$name}{'linkprot'}};
foreach my $id (keys(%lti)) {	}
if (ref($encdomconfig{$name}{$id}) eq 'HASH') {	} else {
foreach my $item ('key','secret') {	%lti = %{$domconfig{$name}};
$lti{$id}{$item} = $encdomconfig{$name}{$id}{$item};	}
	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($name,$cdom,\%lti,$cachetime);	&do_cache_new($cachename,$cdom,\%lti,$cachetime);
}	}
return %lti;	return %lti;
}	}

sub get_numsuppfiles {	sub get_course_lti {
my ($cnum,$cdom,$ignorecache)=@_;	my ($cnum,$cdom) = @_;
	my $hashid=$cdom.'_'.$cnum;
	my %courselti;
	my ($result,$cached)=&is_cached_new('courselti',$hashid);
	if (defined($cached)) {
	if (ref($result) eq 'HASH') {
	%courselti = %{$result};
	}
	} else {
	%courselti = &dump('lti',$cdom,$cnum,undef,undef,undef,1);
	my $cachetime = 246060;
	&do_cache_new('courselti',$hashid,\%courselti,$cachetime);
	}
	return %courselti;
	}

	sub courselti_itemid {
	my ($cnum,$cdom,$url,$method,$params,$context) = @_;
	my ($chome,$itemid);
	$chome = &homeserver($cnum,$cdom);
	return if ($chome eq 'no_host');
	if (ref($params) eq 'HASH') {
	my $rep;
	if (grep { $_ eq $chome } current_machine_ids()) {
	$rep = LONCAPA::Lond::crslti_itemid($cdom,$cnum,$url,$method,$params,$perlvar{'lonVersion'});
	} else {
	my $escurl = &escape($url);
	my $escmethod = &escape($method);
	my $items = &freeze_escape($params);
	$rep = &reply("encrypt:lti:$cdom:$cnum:$context:$escurl:$escmethod:$items",$chome);
	}
	unless (($rep=~/^(refused\|rejected\|error)/) \|\| ($rep eq 'con_lost') \|\|
	($rep eq 'unknown_cmd')) {
	$itemid = $rep;
	}
	}
	return $itemid;
	}

	sub domainlti_itemid {
	my ($cdom,$url,$method,$params,$context) = @_;
	my ($primary_id,$itemid);
	$primary_id = &domain($cdom,'primary');
	return if ($primary_id eq '');
	if (ref($params) eq 'HASH') {
	my $rep;
	if (grep { $_ eq $primary_id } current_machine_ids()) {
	$rep = LONCAPA::Lond::domlti_itemid($cdom,$context,$url,$method,$params,$perlvar{'lonVersion'});
	} else {
	my $cnum = '';
	my $escurl = &escape($url);
	my $escmethod = &escape($method);
	my $items = &freeze_escape($params);
	$rep = &reply("encrypt:lti:$cdom:$cnum:$context:$escurl:$escmethod:$items",$primary_id);
	}
	unless (($rep=~/^(refused\|rejected\|error)/) \|\| ($rep eq 'con_lost') \|\|
	($rep eq 'unknown_cmd')) {
	$itemid = $rep;
	}
	}
	return $itemid;
	}

	sub count_supptools {
	my ($cnum,$cdom,$ignorecache,$reload)=@_;
	my $hashid=$cnum.':'.$cdom;
	my ($numexttools,$cached);
	unless ($ignorecache) {
	($numexttools,$cached) = &is_cached_new('supptools',$hashid);
	}
	unless (defined($cached)) {
	my $chome=&homeserver($cnum,$cdom);
	$numexttools = 0;
	unless ($chome eq 'no_host') {
	my ($supplemental) = &Apache::loncommon::get_supplemental($cnum,$cdom,$reload);
	if (ref($supplemental) eq 'HASH') {
	if ((ref($supplemental->{'ids'}) eq 'HASH') && (ref($supplemental->{'hidden'}) eq 'HASH')) {
	foreach my $key (keys(%{$supplemental->{'ids'}})) {
	if ($key =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) {
	$numexttools ++;
	}
	}
	}
	}
	}
	&do_cache_new('supptools',$hashid,$numexttools,600);
	}
	return $numexttools;
	}

	sub has_unhidden_suppfiles {
	my ($cnum,$cdom,$ignorecache,$possdel)=@_;
my $hashid=$cnum.':'.$cdom;	my $hashid=$cnum.':'.$cdom;
my ($suppcount,$cached);	my ($showsupp,$cached);
unless ($ignorecache) {	unless ($ignorecache) {
($suppcount,$cached) = &is_cached_new('suppcount',$hashid);	($showsupp,$cached) = &is_cached_new('showsupp',$hashid);
}	}
unless (defined($cached)) {	unless (defined($cached)) {
my $chome=&homeserver($cnum,$cdom);	my $chome=&homeserver($cnum,$cdom);
unless ($chome eq 'no_host') {	unless ($chome eq 'no_host') {
($suppcount,my $supptools,my $errors) = (0,0,0);	my ($supplemental) = &Apache::loncommon::get_supplemental($cnum,$cdom,$ignorecache,$possdel);
my $suppmap = 'supplemental.sequence';	if (ref($supplemental) eq 'HASH') {
($suppcount,$supptools,$errors) =	if ((ref($supplemental->{'ids'}) eq 'HASH') && (ref($supplemental->{'hidden'}) eq 'HASH')) {
&Apache::loncommon::recurse_supplemental($cnum,$cdom,$suppmap,$suppcount,	foreach my $key (keys(%{$supplemental->{'ids'}})) {
$supptools,$errors);	next if ($key =~ /\.sequence$/);
	if (ref($supplemental->{'ids'}->{$key}) eq 'ARRAY') {
	foreach my $id (@{$supplemental->{'ids'}->{$key}}) {
	unless ($supplemental->{'hidden'}->{$id}) {
	$showsupp = 1;
	last;
	}
	}
	}
	last if ($showsupp);
	}
	}
	}
}	}
&do_cache_new('suppcount',$hashid,$suppcount,600);	&do_cache_new('showsupp',$hashid,$showsupp,600);
}	}
return $suppcount;	return $showsupp;
}	}

#	#
Line 12073 sub EXT_cache_set {	Line 12674 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 12105 sub EXT {	Line 12706 sub EXT {
if ( (defined($Apache::lonhomework::parsing_a_problem)	if ( (defined($Apache::lonhomework::parsing_a_problem)
\|\| defined($Apache::lonhomework::parsing_a_task))	\|\| defined($Apache::lonhomework::parsing_a_task))
&&	&&
($symbparm eq &symbread()) ) {	($symbparm eq &symbread()) ) {
# if we are in the middle of processing the resource the	# if we are in the middle of processing the resource the
# get the value we are planning on committing	# get the value we are planning on committing
if (defined($Apache::lonhomework::results{$qualifierrest})) {	if (defined($Apache::lonhomework::results{$qualifierrest})) {
Line 12227 sub EXT {	Line 12828 sub EXT {
}	}

my ($section, $group, @groups, @recurseup, $recursed);	my ($section, $group, @groups, @recurseup, $recursed);
	if (ref($recurseupref) eq 'ARRAY') {
	@recurseup = @{$recurseupref};
	$recursed = 1;
	}
my ($courselevelm,$courseleveli,$courselevel,$mapp);	my ($courselevelm,$courseleveli,$courselevel,$mapp);
if (($courseid eq '') && ($cid)) {	if (($courseid eq '') && ($cid)) {
$courseid = $cid;	$courseid = $cid;
Line 12377 sub EXT {	Line 12982 sub EXT {
}	}
} elsif ($realm eq 'client') {	} elsif ($realm eq 'client') {
if ($space eq 'remote_addr') {	if ($space eq 'remote_addr') {
return $ENV{'REMOTE_ADDR'};	return &get_requestor_ip();
}	}
}	}
return '';	return '';
Line 13104 sub get_reservable_slots {	Line 13709 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 13156 sub get_coursechange {	Line 13761 sub get_coursechange {
}	}

sub devalidate_coursechange_cache {	sub devalidate_coursechange_cache {
my ($cnum,$cdom)=@_;	my ($cdom,$cnum)=@_;
my $hashid=$cnum.':'.$cdom;	my $hashid=$cdom.'_'.$cnum;
&devalidate_cache_new('crschange',$hashid);	&devalidate_cache_new('crschange',$hashid);
}	}

	sub get_suppchange {
	my ($cdom,$cnum) = @_;
	if ($cdom eq '' \|\| $cnum eq '') {
	return unless ($env{'request.course.id'});
	$cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
	$cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
	}
	my $hashid=$cdom.'_'.$cnum;
	my ($change,$cached)=&is_cached_new('suppchange',$hashid);
	if ((defined($cached)) && ($change ne '')) {
	return $change;
	} else {
	my %crshash = &get('environment',['internal.supplementalchange'],$cdom,$cnum);
	if ($crshash{'internal.supplementalchange'} eq '') {
	$change = $env{'course.'.$cdom.'_'.$cnum.'.internal.created'};
	if ($change eq '') {
	%crshash = &get('environment',['internal.created'],$cdom,$cnum);
	$change = $crshash{'internal.created'};
	}
	} else {
	$change = $crshash{'internal.supplementalchange'};
	}
	my $cachetime = 600;
	&do_cache_new('suppchange',$hashid,$change,$cachetime);
	}
	return $change;
	}

	sub devalidate_suppchange_cache {
	my ($cdom,$cnum)=@_;
	my $hashid=$cdom.'_'.$cnum;
	&devalidate_cache_new('suppchange',$hashid);
	}

	sub update_supp_caches {
	my ($cdom,$cnum) = @_;
	my %servers = &internet_dom_servers($cdom);
	my @ids=&current_machine_ids();
	foreach my $server (keys(%servers)) {
	next if (grep(/^\Q$server\E$/,@ids));
	my $hashid=$cnum.':'.$cdom;
	my $cachekey = &escape('showsupp').':'.&escape($hashid);
	&remote_devalidate_cache($server,[$cachekey]);
	}
	&has_unhidden_suppfiles($cnum,$cdom,1,1);
	&count_supptools($cnum,$cdom,1);
	my $now = time;
	if ($env{'request.course.id'} eq $cdom.'_'.$cnum) {
	&Apache::lonnet::appenv({'request.course.suppupdated' => $now});
	}
	&put('environment',{'internal.supplementalchange' => $now},
	$cdom,$cnum);
	&Apache::lonnet::appenv(
	{'course.'.$cdom.'_'.$cnum.'.internal.supplementalchange' => $now});
	&do_cache_new('suppchange',$cdom.'_'.$cnum,$now,600);
	}

# ------------------------------------------------- Update symbolic store links	# ------------------------------------------------- Update symbolic store links

sub symblist {	sub symblist {
Line 13347 sub symbread {	Line 14009 sub symbread {
my %bighash;	my %bighash;
my $syval='';	my $syval='';
if (($env{'request.course.fn'}) && ($thisfn)) {	if (($env{'request.course.fn'}) && ($thisfn)) {
my $targetfn = $thisfn;
if ( ($thisfn =~ m/^(uploaded\|editupload)\//) && ($thisfn !~ m/\.(page\|sequence)$/) ) {
$targetfn = 'adm/wrapper/'.$thisfn;
}
if ($targetfn =~ m\|^adm/wrapper/(ext/.*)\|) {
$targetfn=$1;
}
unless ($ignoresymbdb) {	unless ($ignoresymbdb) {
if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',	if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
&GDBM_READER(),0640)) {	&GDBM_READER(),0640)) {
$syval=$hash{$targetfn};	$syval=$hash{$thisfn};
untie(%hash);	untie(%hash);
}	}
if ($syval && $checkforblock) {	if ($syval && $checkforblock) {
Line 14165 sub machine_ids {	Line 14820 sub machine_ids {

sub additional_machine_domains {	sub additional_machine_domains {
my @domains;	my @domains;
open(my $fh,"<","$perlvar{'lonTabDir'}/expected_domains.tab");	if (-e "$perlvar{'lonTabDir'}/expected_domains.tab") {
while( my $line = <$fh>) {	if (open(my $fh,"<","$perlvar{'lonTabDir'}/expected_domains.tab")) {
$line =~ s/\s//g;	while (my $line = <$fh>) {
push(@domains,$line);	chomp($line);
	$line =~ s/\s//g;
	push(@domains,$line);
	}
	close($fh);
	}
}	}
return @domains;	return @domains;
}	}
Line 14187 sub default_login_domain {	Line 14847 sub default_login_domain {
}	}

sub shared_institution {	sub shared_institution {
my ($dom) = @_;	my ($dom,$lonhost) = @_;
	if ($lonhost eq '') {
	$lonhost = $perlvar{'lonHostID'};
	}
my $same_intdom;	my $same_intdom;
my $hostintdom = &internet_dom($perlvar{'lonHostID'});	my $hostintdom = &internet_dom($lonhost);
if ($hostintdom ne '') {	if ($hostintdom ne '') {
my %iphost = &get_iphost();	my %iphost = &get_iphost();
my $primary_id = &domain($dom,'primary');	my $primary_id = &domain($dom,'primary');
Line 14245 sub uses_sts {	Line 14908 sub uses_sts {
return;	return;
}	}

	sub waf_allssl {
	my ($host_name) = @_;
	my $alias = &get_proxy_alias();
	if ($host_name eq '') {
	$host_name = $ENV{'SERVER_NAME'};
	}
	if (($host_name ne '') && ($alias eq $host_name)) {
	my $serverhomedom = &host_domain($perlvar{'lonHostID'});
	my %defdomdefaults = &get_domain_defaults($serverhomedom);
	if ($defdomdefaults{'waf_sslopt'}) {
	return $defdomdefaults{'waf_sslopt'};
	}
	}
	return;
	}

	sub get_requestor_ip {
	my ($r,$nolookup,$noproxy) = @_;
	my $from_ip;
	if (ref($r)) {
	if ($r->can('useragent_ip')) {
	if ($noproxy && $r->can('client_ip')) {
	$from_ip = $r->client_ip();
	} else {
	$from_ip = $r->useragent_ip();
	}
	} elsif ($r->connection->can('remote_ip')) {
	$from_ip = $r->connection->remote_ip();
	} else {
	$from_ip = $r->get_remote_host($nolookup);
	}
	} else {
	$from_ip = $ENV{'REMOTE_ADDR'};
	}
	return $from_ip if ($noproxy);
	# Who controls proxy settings for server
	my $dom_in_use = $Apache::lonnet::perlvar{'lonDefDomain'};
	my $proxyinfo = &get_proxy_settings($dom_in_use);
	if ((ref($proxyinfo) eq 'HASH') && ($from_ip)) {
	if ($proxyinfo->{'vpnint'}) {
	if (&ip_match($from_ip,$proxyinfo->{'vpnint'})) {
	return $from_ip;
	}
	}
	if ($proxyinfo->{'trusted'}) {
	if (&ip_match($from_ip,$proxyinfo->{'trusted'})) {
	my $ipheader = $proxyinfo->{'ipheader'};
	my ($ip,$xfor);
	if (ref($r)) {
	if ($ipheader) {
	$ip = $r->headers_in->{$ipheader};
	}
	$xfor = $r->headers_in->{'X-Forwarded-For'};
	} else {
	if ($ipheader) {
	$ip = $ENV{'HTTP_'.uc($ipheader)};
	}
	$xfor = $ENV{'HTTP_X_FORWARDED_FOR'};
	}
	if (($ip eq '') && ($xfor ne '')) {
	foreach my $poss_ip (reverse(split(/\s,\s/,$xfor))) {
	unless (&ip_match($poss_ip,$proxyinfo->{'trusted'})) {
	$ip = $poss_ip;
	last;
	}
	}
	}
	if ($ip ne '') {
	return $ip;
	}
	}
	}
	}
	return $from_ip;
	}

	sub get_proxy_settings {
	my ($dom_in_use) = @_;
	my %domdefaults = &get_domain_defaults($dom_in_use);
	my $proxyinfo = {
	ipheader => $domdefaults{'waf_ipheader'},
	trusted => $domdefaults{'waf_trusted'},
	vpnint => $domdefaults{'waf_vpnint'},
	vpnext => $domdefaults{'waf_vpnext'},
	sslopt => $domdefaults{'waf_sslopt'},
	};
	return $proxyinfo;
	}

	sub ip_match {
	my ($ip,$pattern_str) = @_;
	$ip=Net::CIDR::cidrvalidate($ip);
	if ($ip) {
	return Net::CIDR::cidrlookup($ip,split(/\s,\s/,$pattern_str));
	}
	return;
	}

	sub get_proxy_alias {
	my ($lonid) = @_;
	if ($lonid eq '') {
	$lonid = $perlvar{'lonHostID'};
	}
	if (!defined(&hostname($lonid))) {
	return;
	}
	if ($lonid ne '') {
	my ($alias,$cached) = &is_cached_new('proxyalias',$lonid);
	if ($cached) {
	return $alias;
	}
	my $dom = &host_domain($lonid);
	if ($dom ne '') {
	my $cachetime = 606024;
	my %domconfig =
	&get_dom('configuration',['wafproxy'],$dom);
	if (ref($domconfig{'wafproxy'}) eq 'HASH') {
	if (ref($domconfig{'wafproxy'}{'alias'}) eq 'HASH') {
	$alias = $domconfig{'wafproxy'}{'alias'}{$lonid};
	}
	}
	return &do_cache_new('proxyalias',$lonid,$alias,$cachetime);
	}
	}
	return;
	}

	sub use_proxy_alias {
	my ($r,$lonid) = @_;
	my $alias = &get_proxy_alias($lonid);
	if ($alias) {
	my $dom = &host_domain($lonid);
	if ($dom ne '') {
	my $proxyinfo = &get_proxy_settings($dom);
	my ($vpnint,$remote_ip);
	if (ref($proxyinfo) eq 'HASH') {
	$vpnint = $proxyinfo->{'vpnint'};
	if ($vpnint) {
	$remote_ip = &get_requestor_ip($r,1,1);
	}
	}
	unless ($vpnint && &ip_match($remote_ip,$vpnint)) {
	return $alias;
	}
	}
	}
	return;
	}

	sub alias_sso {
	my ($lonid) = @_;
	if ($lonid eq '') {
	$lonid = $perlvar{'lonHostID'};
	}
	if (!defined(&hostname($lonid))) {
	return;
	}
	if ($lonid ne '') {
	my ($use_alias,$cached) = &is_cached_new('proxysaml',$lonid);
	if ($cached) {
	return $use_alias;
	}
	my $dom = &host_domain($lonid);
	if ($dom ne '') {
	my $cachetime = 606024;
	my %domconfig =
	&get_dom('configuration',['wafproxy'],$dom);
	if (ref($domconfig{'wafproxy'}) eq 'HASH') {
	if (ref($domconfig{'wafproxy'}{'saml'}) eq 'HASH') {
	$use_alias = $domconfig{'wafproxy'}{'saml'}{$lonid};
	}
	}
	return &do_cache_new('proxysaml',$lonid,$use_alias,$cachetime);
	}
	}
	return;
	}

	sub get_saml_landing {
	my ($lonid) = @_;
	if ($lonid eq '') {
	my $defdom = &default_login_domain();
	my @hosts = &current_machine_ids();
	if (@hosts > 1) {
	foreach my $hostid (@hosts) {
	if (&host_domain($hostid) eq $defdom) {
	$lonid = $hostid;
	last;
	}
	}
	} else {
	$lonid = $perlvar{'lonHostID'};
	}
	if ($lonid) {
	unless (&host_domain($lonid) eq $defdom) {
	return;
	}
	} else {
	return;
	}
	} elsif (!defined(&hostname($lonid))) {
	return;
	}
	my ($landing,$cached) = &is_cached_new('samllanding',$lonid);
	if ($cached) {
	return $landing;
	}
	my $dom = &host_domain($lonid);
	if ($dom ne '') {
	my $cachetime = 606024;
	my %domconfig =
	&get_dom('configuration',['login'],$dom);
	if (ref($domconfig{'login'}) eq 'HASH') {
	if (ref($domconfig{'login'}{'saml'}) eq 'HASH') {
	if (ref($domconfig{'login'}{'saml'}{$lonid}) eq 'HASH') {
	$landing = 1;
	}
	}
	}
	return &do_cache_new('samllanding',$lonid,$landing,$cachetime);
	}
	return;
	}

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

sub declutter {	sub declutter {
Line 14362 sub get_dns {	Line 15249 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 14384 sub get_dns {	Line 15271 sub get_dns {
}	}
while (%alldns) {	while (%alldns) {
my ($dns) = sort { $b cmp $a } keys(%alldns);	my ($dns) = sort { $b cmp $a } keys(%alldns);
my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");	my ($contents,@content);
my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar,30,0);	if ($dns eq Sys::Hostname::FQDN::fqdn()) {
delete($alldns{$dns});	my $command = (split('/',$url))[3];
next if ($response->is_error());	my ($dir,$file) = &parse_getdns_url($command,$url);
	delete($alldns{$dns});
	next if (($dir eq '') \|\| ($file eq ''));
	if (open(my $config,'<',"$dir/$file")) {
	@content = <$config>;
	close($config);
	}
	if ($url eq '/adm/dns/loncapaCRL') {
	$contents = join('',@content);
	}
	} else {
	my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
	my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar,30,0);
	delete($alldns{$dns});
	next if ($response->is_error());
	if ($url eq '/adm/dns/loncapaCRL') {
	$contents = $response->content;
	} else {
	@content = split("\n",$response->content);
	}
	}
if ($url eq '/adm/dns/loncapaCRL') {	if ($url eq '/adm/dns/loncapaCRL') {
return &$func($response);	return &$func($contents);
} else {	} else {
my @content = split("\n",$response->content);
unless ($nocache) {	unless ($nocache) {
&do_cache_new('dns',$url,\@content,302460*60);	&do_cache_new('dns',$url,\@content,302460*60);
}	}
Line 14422 sub get_dns {	Line 15328 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 14466 sub parse_dns_checksums_tab {	Line 15372 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 14479 sub fetch_crl_pemfile {	Line 15385 sub fetch_crl_pemfile {
}	}

sub save_crl_pem {	sub save_crl_pem {
my ($response) = @_;	my ($content) = @_;
my ($msg,$hadchanges);	my ($msg,$hadchanges);
if (ref($response)) {	if ($content ne '') {
my $now = time;	my $now = time;
my $lonca = $perlvar{'lonCertificateDirectory'}.'/'.$perlvar{'lonnetCertificateAuthority'};	my $lonca = $perlvar{'lonCertificateDirectory'}.'/'.$perlvar{'lonnetCertificateAuthority'};
my $tmpcrl = $tmpdir.'/'.$perlvar{'lonnetCertRevocationList'}.'_'.$now.'.'.$$.'.tmp';	my $tmpcrl = $tmpdir.'/'.$perlvar{'lonnetCertRevocationList'}.'_'.$now.'.'.$$.'.tmp';
if (open(my $fh,'>',"$tmpcrl")) {	if (open(my $fh,'>',"$tmpcrl")) {
print $fh $response->content;	print $fh $content;
close($fh);	close($fh);
if (-e $lonca) {	if (-e $lonca) {
if (open(PIPE,"openssl crl -in $tmpcrl -inform pem -CAfile $lonca -noout 2>&1 \|")) {	if (open(PIPE,"openssl crl -in $tmpcrl -inform pem -CAfile $lonca -noout 2>&1 \|")) {
Line 14547 sub save_crl_pem {	Line 15453 sub save_crl_pem {
return ($msg,$hadchanges);	return ($msg,$hadchanges);
}	}

	sub parse_getdns_url {
	my ($command,$url) = @_;
	my $dir = $perlvar{'lonTabDir'};
	my $file;
	if ($command eq 'hosts') {
	$file = 'dns_hosts.tab';
	} elsif ($command eq 'domain') {
	$file = 'dns_domain.tab';
	} elsif ($command eq 'checksums') {
	my $version = (split('/',$url))[4];
	$file = "dns_checksums/$version.tab",
	} elsif ($command eq 'loncapaCRL') {
	$dir = $perlvar{'lonCertificateDirectory'};
	$file = $perlvar{'lonnetCertRevocationList'};
	}
	return ($dir,$file);
	}

# ------------------------------------------------------------ Read domain file	# ------------------------------------------------------------ Read domain file
{	{
my $loaded;	my $loaded;
Line 14836 sub save_crl_pem {	Line 15760 sub save_crl_pem {
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 14848 sub save_crl_pem {	Line 15772 sub save_crl_pem {
# 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 14915 sub save_crl_pem {	Line 15839 sub save_crl_pem {
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 15755 data base, returning a hash that is keye	Line 16679 data base, returning a hash that is keye
values that are the resource value. I believe that the timestamps and	values that are the resource value. I believe that the timestamps and
versions are also returned.	versions are also returned.

get_numsuppfiles($cnum,$cdom) : retrieve number of files in a course's
supplemental content area. This routine caches the number of files for
10 minutes.

=back	=back

=head2 Course Modification	=head2 Course Modification

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

Removed from v.1.1430
changed lines
	Added in v.1.1504