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.1467 and 1.1506

version 1.1467, 2021/10/07 15:51:16	version 1.1506, 2023/03/27 21:32:41
Line 985 sub spareserver {	Line 985 sub spareserver {
: $userloadpercent;	: $userloadpercent;
my ($uint_dom,$remotesessions);	my ($uint_dom,$remotesessions);
if (($udom ne '') && (&domain($udom) ne '')) {	if (($udom ne '') && (&domain($udom) ne '')) {
my $uprimary_id = &Apache::lonnet::domain($udom,'primary');	my $uprimary_id = &domain($udom,'primary');
$uint_dom = &Apache::lonnet::internet_dom($uprimary_id);	$uint_dom = &internet_dom($uprimary_id);
my %udomdefaults = &Apache::lonnet::get_domain_defaults($udom);	my %udomdefaults = &get_domain_defaults($udom);
$remotesessions = $udomdefaults{'remotesessions'};	$remotesessions = $udomdefaults{'remotesessions'};
}	}
my $spareshash = &this_host_spares($udom);	my $spareshash = &this_host_spares($udom);
Line 1023 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 = &Apache::lonnet::use_proxy_alias($r,$spare_server);	my $alias = &use_proxy_alias($r,$spare_server);
$hostname = $alias if ($alias ne '');	$hostname = $alias if ($alias ne '');
$spare_server = $protocol.'://'.$hostname;	$spare_server = $protocol.'://'.$hostname;
}	}
Line 1211 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 1323 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 1372 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 1417 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 1510 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 1562 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 1578 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 1639 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 1772 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 1836 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 2262 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 2271 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 2304 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 2542 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 2571 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 2612 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','wafproxy'],$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 2626 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 2666 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 2698 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 2773 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 2786 sub get_domain_defaults {	Line 2876 sub get_domain_defaults {
$domdefaults{'waf_'.$item} = $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 2806 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 2823 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 2861 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 = &Apache::lonnet::use_proxy_alias($r,$chome);	my $alias = &use_proxy_alias($r,$chome);
$hostname = $alias if ($alias ne '');	$hostname = $alias if ($alias ne '');
$firsturl = $protocol.'://'.$hostname;	$firsturl = $protocol.'://'.$hostname;
}	}
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 3039 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 3237 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 3254 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 3266 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 3550 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;
}	}
$response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,	$response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,
Line 3702 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 3731 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 4147 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 4159 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 4370 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 4606 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 4659 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 4842 sub get_scantronformat_file {	Line 5013 sub get_scantronformat_file {
close($fh);	close($fh);
}	}
}	}
	chomp(@lines);
}	}
return @lines;	return @lines;
}	}
Line 4963 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 4989 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 5188 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 5419 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 5747 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 6749 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 7340 sub putstore {	Line 7535 sub putstore {
'&host='.&escape($perlvar{'lonHostID'}).	'&host='.&escape($perlvar{'lonHostID'}).
'&version='.$esc_v.	'&version='.$esc_v.
'&by='.&escape($env{'user.name'}.':'.$env{'user.domain'});	'&by='.&escape($env{'user.name'}.':'.$env{'user.domain'});
&Apache::lonnet::courselog($symb.':'.$uname.':'.$udomain.':PUTSTORE:'.$namevalue);	&courselog($symb.':'.$uname.':'.$udomain.':PUTSTORE:'.$namevalue);
}	}
if ($reply eq 'unknown_cmd') {	if ($reply eq 'unknown_cmd') {
# gfall back to way things use to be done	# gfall back to way things use to be done
Line 7490 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 7520 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 7560 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 7809 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 7834 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 7958 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 8029 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 8048 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 8130 sub allowed {	Line 8343 sub allowed {
$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 8151 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 8430 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 8750 sub constructaccess {	Line 8969 sub constructaccess {
if (exists($env{'user.priv.au./'.$ownerdomain.'/./'})) {	if (exists($env{'user.priv.au./'.$ownerdomain.'/./'})) {
return ($ownername,$ownerdomain,$ownerhome);	return ($ownername,$ownerdomain,$ownerhome);
}	}
} else {	} elsif (&is_course($ownerdomain,$ownername)) {
# Co-author for this?	# Course Authoring Space?
if (exists($env{'user.priv.ca./'.$ownerdomain.'/'.$ownername.'./'}) \|\|
exists($env{'user.priv.aa./'.$ownerdomain.'/'.$ownername.'./'}) ) {
$ownerhome = &homeserver($ownername,$ownerdomain);
return ($ownername,$ownerdomain,$ownerhome);
}
if ($env{'request.course.id'}) {	if ($env{'request.course.id'}) {
if (($ownername eq $env{'course.'.$env{'request.course.id'}.'.num'}) &&	if (($ownername eq $env{'course.'.$env{'request.course.id'}.'.num'}) &&
($ownerdomain eq $env{'course.'.$env{'request.course.id'}.'.domain'})) {	($ownerdomain eq $env{'course.'.$env{'request.course.id'}.'.domain'})) {
Line 8766 sub constructaccess {	Line 8980 sub constructaccess {
}	}
}	}
}	}
	return '';
	} else {
	# Co-author for this?
	if (exists($env{'user.priv.ca./'.$ownerdomain.'/'.$ownername.'./'}) \|\|
	exists($env{'user.priv.aa./'.$ownerdomain.'/'.$ownername.'./'}) ) {
	$ownerhome = &homeserver($ownername,$ownerdomain);
	return ($ownername,$ownerdomain,$ownerhome);
	}
}	}

# We don't have any access right now. If we are not possibly going to do anything about this,	# We don't have any access right now. If we are not possibly going to do anything about this,
Line 8844 sub get_comm_blocks {	Line 9066 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 8855 sub get_commblock_resources {	Line 9077 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 8887 sub get_commblock_resources {	Line 9113 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 8899 sub get_commblock_resources {	Line 9124 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 8946 sub get_commblock_resources {	Line 9146 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 8979 sub has_comm_blocking {	Line 9206 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 9379 sub fetch_enrollment_query {	Line 9610 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 10172 sub assignrole {	Line 10403 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 10461 sub store_coowners {	Line 10692 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 10682 sub modifyuser {	Line 10913 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 10762 sub modify_student_enrollment {	Line 10993 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 10896 sub createcourse {	Line 11127 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 11864 sub stat_file {	Line 12095 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).
	# $addtopdir - if true, set $dirhashref->{'/'} = 1
# $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 11888 sub stat_file {	Line 12125 sub stat_file {
#	#

sub recursedirs {	sub recursedirs {
my ($is_home,$context,$docroot,$toppath,$relpath,$dirhashref,$filehashref) = @_;	my ($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$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 ((-e $currpath) && (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,$addtopdir,$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) {
} else {	my ($extension) = ($item =~ /\.(\w+)$/);
unless (($item =~ /\.meta$/) \|\| ($item =~ /\.\d+\.\w+$/) \|\| ($item =~ /\.rights$/)) {	if ($checkinc) {
	next unless ($extension && $include->{$extension});
	}
	if ($checkexc) {
	next if ($extension && $exclude->{$extension});
	}
	}
	if (($relpath eq '') && (!exists($dirhashref->{'/'}))) {
	$dirhashref->{'/'} = 1;
	}
	if ($savefile) {
	if ($relpath eq '') {
	$filehashref->{'/'}{$item} = 1;
	} else {
$filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1;	$filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1;
}	}
}	}
	$filecount ++;
}	}
}	}
closedir($dirh);	closedir($dirh);
Line 11931 sub recursedirs {	Line 12190 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 11946 sub recursedirs {	Line 12206 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,$addtopdir,$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) {
} else {	my $extension;
unless (($item =~ /\.meta$/) \|\| ($item =~ /\.\d+\.\w+$/)) {	if ($checkinc) {
$filehashref->{$relpath}{$item} = 1;	next unless ($extension && $include->{$extension});
	}
	if ($checkexc) {
	next if ($extension && $exclude->{$extension});
	}
	}
	if (($relpath eq '') && (!exists($dirhashref->{'/'}))) {
	$dirhashref->{'/'} = 1;
	}
	if ($savefile) {
	if ($relpath eq '') {
	$filehashref->{'/'}{$item} = 1;
	} else {
	$filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1;
}	}
}	}
	$filecount ++;
}	}
}	}
}	}
}	}
	if ($addtopdir) {
	if (($relpath eq '') && (!exists($dirhashref->{'/'}))) {
	$dirhashref->{'/'} = 1;
	}
	}
return;	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 12181 sub resdata {	Line 12470 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 12197 sub get_domain_lti {	Line 12495 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,undef,1);	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;
}	}
Line 12232 sub get_course_lti {	Line 12538 sub get_course_lti {
return %courselti;	return %courselti;
}	}

sub get_numsuppfiles {	sub courselti_itemid {
my ($cnum,$cdom,$ignorecache)=@_;	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 $hashid=$cnum.':'.$cdom;
my ($suppcount,$cached);	my ($numexttools,$cached);
unless ($ignorecache) {	unless ($ignorecache) {
($suppcount,$cached) = &is_cached_new('suppcount',$hashid);	($numexttools,$cached) = &is_cached_new('supptools',$hashid);
}	}
unless (defined($cached)) {	unless (defined($cached)) {
my $chome=&homeserver($cnum,$cdom);	my $chome=&homeserver($cnum,$cdom);
	$numexttools = 0;
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,$reload);
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);	if ($key =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) {
	$numexttools ++;
	}
	}
	}
	}
}	}
&do_cache_new('suppcount',$hashid,$suppcount,600);	&do_cache_new('supptools',$hashid,$numexttools,600);
}	}
return $suppcount;	return $numexttools;
	}

	sub has_unhidden_suppfiles {
	my ($cnum,$cdom,$ignorecache,$possdel)=@_;
	my $hashid=$cnum.':'.$cdom;
	my ($showsupp,$cached);
	unless ($ignorecache) {
	($showsupp,$cached) = &is_cached_new('showsupp',$hashid);
	}
	unless (defined($cached)) {
	my $chome=&homeserver($cnum,$cdom);
	unless ($chome eq 'no_host') {
	my ($supplemental) = &Apache::loncommon::get_supplemental($cnum,$cdom,$ignorecache,$possdel);
	if (ref($supplemental) eq 'HASH') {
	if ((ref($supplemental->{'ids'}) eq 'HASH') && (ref($supplemental->{'hidden'}) eq 'HASH')) {
	foreach my $key (keys(%{$supplemental->{'ids'}})) {
	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('showsupp',$hashid,$showsupp,600);
	}
	return $showsupp;
}	}

#	#
Line 12323 sub EXT {	Line 12715 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 13326 sub get_reservable_slots {	Line 13718 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 13378 sub get_coursechange {	Line 13770 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 13569 sub symbread {	Line 14018 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 14553 sub get_requestor_ip {	Line 14995 sub get_requestor_ip {

sub get_proxy_settings {	sub get_proxy_settings {
my ($dom_in_use) = @_;	my ($dom_in_use) = @_;
my %domdefaults = &Apache::lonnet::get_domain_defaults($dom_in_use);	my %domdefaults = &get_domain_defaults($dom_in_use);
my $proxyinfo = {	my $proxyinfo = {
ipheader => $domdefaults{'waf_ipheader'},	ipheader => $domdefaults{'waf_ipheader'},
trusted => $domdefaults{'waf_trusted'},	trusted => $domdefaults{'waf_trusted'},
Line 14586 sub get_proxy_alias {	Line 15028 sub get_proxy_alias {
if ($cached) {	if ($cached) {
return $alias;	return $alias;
}	}
my $dom = &Apache::lonnet::host_domain($lonid);	my $dom = &host_domain($lonid);
if ($dom ne '') {	if ($dom ne '') {
my $cachetime = 606024;	my $cachetime = 606024;
my %domconfig =	my %domconfig =
&Apache::lonnet::get_dom('configuration',['wafproxy'],$dom);	&get_dom('configuration',['wafproxy'],$dom);
if (ref($domconfig{'wafproxy'}) eq 'HASH') {	if (ref($domconfig{'wafproxy'}) eq 'HASH') {
if (ref($domconfig{'wafproxy'}{'alias'}) eq 'HASH') {	if (ref($domconfig{'wafproxy'}{'alias'}) eq 'HASH') {
$alias = $domconfig{'wafproxy'}{'alias'}{$lonid};	$alias = $domconfig{'wafproxy'}{'alias'}{$lonid};
Line 14624 sub use_proxy_alias {	Line 15066 sub use_proxy_alias {
return;	return;
}	}

sub alias_shibboleth {	sub alias_sso {
my ($lonid) = @_;	my ($lonid) = @_;
if ($lonid eq '') {	if ($lonid eq '') {
$lonid = $perlvar{'lonHostID'};	$lonid = $perlvar{'lonHostID'};
Line 14637 sub alias_shibboleth {	Line 15079 sub alias_shibboleth {
if ($cached) {	if ($cached) {
return $use_alias;	return $use_alias;
}	}
my $dom = &Apache::lonnet::host_domain($lonid);	my $dom = &host_domain($lonid);
if ($dom ne '') {	if ($dom ne '') {
my $cachetime = 606024;	my $cachetime = 606024;
my %domconfig =	my %domconfig =
&Apache::lonnet::get_dom('configuration',['wafproxy'],$dom);	&get_dom('configuration',['wafproxy'],$dom);
if (ref($domconfig{'wafproxy'}) eq 'HASH') {	if (ref($domconfig{'wafproxy'}) eq 'HASH') {
if (ref($domconfig{'wafproxy'}{'saml'}) eq 'HASH') {	if (ref($domconfig{'wafproxy'}{'saml'}) eq 'HASH') {
$use_alias = $domconfig{'wafproxy'}{'saml'}{$lonid};	$use_alias = $domconfig{'wafproxy'}{'saml'}{$lonid};
Line 14669 sub get_saml_landing {	Line 15111 sub get_saml_landing {
$lonid = $perlvar{'lonHostID'};	$lonid = $perlvar{'lonHostID'};
}	}
if ($lonid) {	if ($lonid) {
unless (&Apache::lonnet::host_domain($lonid) eq $defdom) {	unless (&host_domain($lonid) eq $defdom) {
return;	return;
}	}
} else {	} else {
Line 14682 sub get_saml_landing {	Line 15124 sub get_saml_landing {
if ($cached) {	if ($cached) {
return $landing;	return $landing;
}	}
my $dom = &Apache::lonnet::host_domain($lonid);	my $dom = &host_domain($lonid);
if ($dom ne '') {	if ($dom ne '') {
my $cachetime = 606024;	my $cachetime = 606024;
my %domconfig =	my %domconfig =
&Apache::lonnet::get_dom('configuration',['login'],$dom);	&get_dom('configuration',['login'],$dom);
if (ref($domconfig{'login'}) eq 'HASH') {	if (ref($domconfig{'login'}) eq 'HASH') {
if (ref($domconfig{'login'}{'saml'}) eq 'HASH') {	if (ref($domconfig{'login'}{'saml'}) eq 'HASH') {
if (ref($domconfig{'login'}{'saml'}{$lonid}) eq 'HASH') {	if (ref($domconfig{'login'}{'saml'}{$lonid}) eq 'HASH') {
Line 14816 sub get_dns {	Line 15258 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 14895 sub get_dns {	Line 15337 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 14939 sub parse_dns_checksums_tab {	Line 15381 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 15327 sub parse_getdns_url {	Line 15769 sub parse_getdns_url {
return %iphost;	return %iphost;
}	}
my ($ip_info,$cached)=	my ($ip_info,$cached)=
&Apache::lonnet::is_cached_new('iphost','iphost');	&is_cached_new('iphost','iphost');
if ($cached) {	if ($cached) {
%iphost = %{$ip_info->[0]};	%iphost = %{$ip_info->[0]};
%name_to_ip = %{$ip_info->[1]};	%name_to_ip = %{$ip_info->[1]};
Line 15339 sub parse_getdns_url {	Line 15781 sub parse_getdns_url {
# get yesterday's info for fallback	# get yesterday's info for fallback
my %old_name_to_ip;	my %old_name_to_ip;
my ($ip_info,$cached)=	my ($ip_info,$cached)=
&Apache::lonnet::is_cached_new('iphost','iphost');	&is_cached_new('iphost','iphost');
if ($cached) {	if ($cached) {
%old_name_to_ip = %{$ip_info->[1]};	%old_name_to_ip = %{$ip_info->[1]};
}	}
Line 15406 sub parse_getdns_url {	Line 15848 sub parse_getdns_url {
my ($lonid) = @_;	my ($lonid) = @_;
return if ($lonid eq '');	return if ($lonid eq '');
my ($idnref,$cached)=	my ($idnref,$cached)=
&Apache::lonnet::is_cached_new('internetnames',$lonid);	&is_cached_new('internetnames',$lonid);
if ($cached) {	if ($cached) {
return $idnref;	return $idnref;
}	}
Line 16246 data base, returning a hash that is keye	Line 16688 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.1467
changed lines
	Added in v.1.1506