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.1311 and 1.1381

version 1.1311, 2016/06/19 00:19:24	version 1.1381, 2018/08/09 14:04:35
Line 71 delayed.	Line 71 delayed.
package Apache::lonnet;	package Apache::lonnet;

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

Line 101 use LONCAPA qw(:DEFAULT :match);	Line 100 use LONCAPA qw(:DEFAULT :match);
use LONCAPA::Configuration;	use LONCAPA::Configuration;
use LONCAPA::lonmetadata;	use LONCAPA::lonmetadata;
use LONCAPA::Lond;	use LONCAPA::Lond;
	use LONCAPA::LWPReq;

use File::Copy;	use File::Copy;

Line 146 our @EXPORT = qw(%env);	Line 146 our @EXPORT = qw(%env);
sub logtouch {	sub logtouch {
my $execdir=$perlvar{'lonDaemons'};	my $execdir=$perlvar{'lonDaemons'};
unless (-e "$execdir/logs/lonnet.log") {	unless (-e "$execdir/logs/lonnet.log") {
open(my $fh,">>$execdir/logs/lonnet.log");	open(my $fh,">>","$execdir/logs/lonnet.log");
close $fh;	close $fh;
}	}
my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3];	my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3];
Line 158 sub logthis {	Line 158 sub logthis {
my $execdir=$perlvar{'lonDaemons'};	my $execdir=$perlvar{'lonDaemons'};
my $now=time;	my $now=time;
my $local=localtime($now);	my $local=localtime($now);
if (open(my $fh,">>$execdir/logs/lonnet.log")) {	if (open(my $fh,">>","$execdir/logs/lonnet.log")) {
my $logstring = $local. " ($$): ".$message."\n"; # Keep any \'s in string.	my $logstring = $local. " ($$): ".$message."\n"; # Keep any \'s in string.
print $fh $logstring;	print $fh $logstring;
close($fh);	close($fh);
Line 171 sub logperm {	Line 171 sub logperm {
my $execdir=$perlvar{'lonDaemons'};	my $execdir=$perlvar{'lonDaemons'};
my $now=time;	my $now=time;
my $local=localtime($now);	my $local=localtime($now);
if (open(my $fh,">>$execdir/logs/lonnet.perm.log")) {	if (open(my $fh,">>","$execdir/logs/lonnet.perm.log")) {
print $fh "$now:$message:$local\n";	print $fh "$now:$message:$local\n";
close($fh);	close($fh);
}	}
Line 229 sub get_server_distarch {	Line 229 sub get_server_distarch {
return;	return;
}	}

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

sub get_server_loncaparev {	sub get_server_loncaparev {
my ($dom,$lonhost,$ignore_cache,$caller) = @_;	my ($dom,$lonhost,$ignore_cache,$caller) = @_;
if (defined($lonhost)) {	if (defined($lonhost)) {
Line 263 sub get_server_loncaparev {	Line 309 sub get_server_loncaparev {
$answer = &reply('serverloncaparev',$lonhost);	$answer = &reply('serverloncaparev',$lonhost);
if (($answer eq 'unknown_cmd') \|\| ($answer eq 'con_lost')) {	if (($answer eq 'unknown_cmd') \|\| ($answer eq 'con_lost')) {
if ($caller eq 'loncron') {	if ($caller eq 'loncron') {
my $ua=new LWP::UserAgent;
$ua->timeout(4);
my $protocol = $protocol{$lonhost};	my $protocol = $protocol{$lonhost};
$protocol = 'http' if ($protocol ne 'https');	$protocol = 'http' if ($protocol ne 'https');
my $url = $protocol.'://'.&hostname($lonhost).'/adm/about.html';	my $url = $protocol.'://'.&hostname($lonhost).'/adm/about.html';
my $request=new HTTP::Request('GET',$url);	my $request=new HTTP::Request('GET',$url);
my $response=$ua->request($request);	my $response=&LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,4,1);
unless ($response->is_error()) {	unless ($response->is_error()) {
my $content = $response->content;	my $content = $response->content;
if ($content =~ /<p>VERSION\:\s*([\w.\-]+)<\/p>/) {	if ($content =~ /<p>VERSION\:\s*([\w.\-]+)<\/p>/) {
Line 441 sub reconlonc {	Line 485 sub reconlonc {

&logthis("Trying to reconnect lonc");	&logthis("Trying to reconnect lonc");
my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";	my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
if (open(my $fh,"<$loncfile")) {	if (open(my $fh,"<",$loncfile)) {
my $loncpid=<$fh>;	my $loncpid=<$fh>;
chomp($loncpid);	chomp($loncpid);
if (kill 0 => $loncpid) {	if (kill 0 => $loncpid) {
Line 481 sub critical {	Line 525 sub critical {
$dumpcount++;	$dumpcount++;
{	{
my $dfh;	my $dfh;
if (open($dfh,">$dfilename")) {	if (open($dfh,">",$dfilename)) {
print $dfh "$cmd\n";	print $dfh "$cmd\n";
close($dfh);	close($dfh);
}	}
Line 490 sub critical {	Line 534 sub critical {
my $wcmd='';	my $wcmd='';
{	{
my $dfh;	my $dfh;
if (open($dfh,"<$dfilename")) {	if (open($dfh,"<",$dfilename)) {
$wcmd=<$dfh>;	$wcmd=<$dfh>;
close($dfh);	close($dfh);
}	}
Line 606 sub transfer_profile_to_env {	Line 650 sub transfer_profile_to_env {

# ---------------------------------------------------- Check for valid session	# ---------------------------------------------------- Check for valid session
sub check_for_valid_session {	sub check_for_valid_session {
my ($r,$name,$userhashref) = @_;	my ($r,$name,$userhashref,$domref) = @_;
my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));	my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
if ($name eq '') {	my ($lonidsdir,$linkname,$pubname,$secure,$lonid);
$name = 'lonID';
}
my $lonid=$cookies{$name};
return undef if (!$lonid);

my $handle=&LONCAPA::clean_handle($lonid->value);
my $lonidsdir;
if ($name eq 'lonDAV') {	if ($name eq 'lonDAV') {
$lonidsdir=$r->dir_config('lonDAVsessDir');	$lonidsdir=$r->dir_config('lonDAVsessDir');
} else {	} else {
$lonidsdir=$r->dir_config('lonIDsDir');	$lonidsdir=$r->dir_config('lonIDsDir');
	if ($name eq '') {
	$name = 'lonID';
	}
	}
	if ($name eq 'lonID') {
	$secure = 'lonSID';
	$linkname = 'lonLinkID';
	$pubname = 'lonPubID';
	if (exists($cookies{$secure})) {
	$lonid=$cookies{$secure};
	} elsif (exists($cookies{$name})) {
	$lonid=$cookies{$name};
	} elsif (exists($cookies{$linkname})) {
	$lonid=$cookies{$linkname};
	} elsif (exists($cookies{$pubname})) {
	$lonid=$cookies{$pubname};
	}
	} else {
	$lonid=$cookies{$name};
	}
	return undef if (!$lonid);

	my $handle=&LONCAPA::clean_handle($lonid->value);
	if (-l "$lonidsdir/$handle.id") {
	my $link = readlink("$lonidsdir/$handle.id");
	if ((-e $link) && ($link =~ m{^\Q$lonidsdir\E/(.+)\.id$})) {
	$handle = $1;
	}
	}
	if (!-e "$lonidsdir/$handle.id") {
	if ((ref($domref)) && ($name eq 'lonID') &&
	($handle =~ /^($match_username)\_\d+\_($match_domain)\_(.+)$/)) {
	my ($possuname,$possudom,$possuhome) = ($1,$2,$3);
	if ((&domain($possudom) ne '') && (&homeserver($possuname,$possudom) eq $possuhome)) {
	$$domref = $possudom;
	}
	}
	return undef;
}	}
return undef if (!-e "$lonidsdir/$handle.id");

my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");	my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
return undef if (!$opened);	return undef if (!$opened);
Line 641 sub check_for_valid_session {	Line 715 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'};
	$userhashref->{'lti'} = $disk_env{'request.lti.login'};
	if ($userhashref->{'lti'}) {
	$userhashref->{'ltitarget'} = $disk_env{'request.lti.target'};
	$userhashref->{'ltiuri'} = $disk_env{'request.lti.uri'};
	}
}	}

return $handle;	return $handle;
Line 691 sub appenv {	Line 770 sub appenv {
$env{$key}=$newenv->{$key};	$env{$key}=$newenv->{$key};
}	}
}	}
my $opened = open(my $env_file,'+<',$env{'user.environment'});	my $lonids = $perlvar{'lonIDsDir'};
if ($opened	if ($env{'user.environment'} =~ m{^\Q$lonids/\E$match_username\_\d+\_$match_domain\_[\w\-.]+\.id$}) {
&& &timed_flock($env_file,LOCK_EX)	my $opened = open(my $env_file,'+<',$env{'user.environment'});
&&	if ($opened
tie(my %disk_env,'GDBM_File',$env{'user.environment'},	&& &timed_flock($env_file,LOCK_EX)
(&GDBM_WRITER()\|&GDBM_NOLOCK()),0640)) {	&&
while (my ($key,$value) = each(%{$newenv})) {	tie(my %disk_env,'GDBM_File',$env{'user.environment'},
$disk_env{$key} = $value;	(&GDBM_WRITER()\|&GDBM_NOLOCK()),0640)) {
}	while (my ($key,$value) = each(%{$newenv})) {
untie(%disk_env);	$disk_env{$key} = $value;
	}
	untie(%disk_env);
	}
}	}
}	}
return 'ok';	return 'ok';
Line 1007 sub choose_server {	Line 1089 sub choose_server {
if ($login_host ne '') {	if ($login_host ne '') {
$hostname = &hostname($login_host);	$hostname = &hostname($login_host);
}	}
return ($login_host,$hostname,$portal_path,$isredirect);	return ($login_host,$hostname,$portal_path,$isredirect,$lowest_load);
}	}

# --------------------------------------------- Try to change a user's password	# --------------------------------------------- Try to change a user's password
Line 1279 sub get_lonbalancer_config {	Line 1361 sub get_lonbalancer_config {
}	}

sub check_loadbalancing {	sub check_loadbalancing {
my ($uname,$udom) = @_;	my ($uname,$udom,$caller) = @_;
my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom,	my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom,
$rule_in_effect,$offloadto,$otherserver);	$rule_in_effect,$offloadto,$otherserver);
my $lonhost = $perlvar{'lonHostID'};	my $lonhost = $perlvar{'lonHostID'};
Line 1430 sub check_loadbalancing {	Line 1512 sub check_loadbalancing {
}	}
}	}
}	}
if (($otherserver ne '') && (grep(/^\Q$otherserver\E$/,@hosts))) {	unless ($caller eq 'login') {
$is_balancer = 0;	if (($otherserver ne '') && (grep(/^\Q$otherserver\E$/,@hosts))) {
if ($uname ne '' && $udom ne '') {	$is_balancer = 0;
if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {	if ($uname ne '' && $udom ne '') {
	if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {

&appenv({'user.loadbalexempt' => $lonhost,	&appenv({'user.loadbalexempt' => $lonhost,
'user.loadbalcheck.time' => time});	'user.loadbalcheck.time' => time});
	}
}	}
}	}
}	}
Line 1539 sub internet_dom_servers {	Line 1623 sub internet_dom_servers {
return %uniqservers;	return %uniqservers;
}	}

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

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

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

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

my %homecache;	my %homecache;
Line 1788 sub get_dom {	Line 1966 sub get_dom {
}	}
}	}
if ($udom && $uhome && ($uhome ne 'no_host')) {	if ($udom && $uhome && ($uhome ne 'no_host')) {
my $rep=&reply("getdom:$udom:$namespace:$items",$uhome);	my $rep;
	if ($namespace =~ /^enc/) {
	$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 /) {
return %returnhash;	return %returnhash;
Line 1832 sub put_dom {	Line 2015 sub put_dom {
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';	$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
}	}
$items=~s/\&$//;	$items=~s/\&$//;
return &reply("putdom:$udom:$namespace:$items",$uhome);	if ($namespace =~ /^enc/) {
	return &reply("encrypt:putdom:$udom:$namespace:$items",$uhome);
	} else {
	return &reply("putdom:$udom:$namespace:$items",$uhome);
	}
} else {	} else {
&logthis("put_dom failed - no homeserver and/or domain");	&logthis("put_dom failed - no homeserver and/or domain");
}	}
Line 1923 sub inst_directory_query {	Line 2110 sub inst_directory_query {
my $homeserver = &domain($udom,'primary');	my $homeserver = &domain($udom,'primary');
my $outcome;	my $outcome;
if ($homeserver ne '') {	if ($homeserver ne '') {
	unless ($homeserver eq $perlvar{'lonHostID'}) {
	if ($srch->{'srchby'} eq 'email') {
	my $lcrev = &get_server_loncaparev(undef,$homeserver);
	my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);
	if (($major eq '' && $minor eq '') \|\| ($major < 2) \|\|
	(($major == 2) && ($minor < 12))) {
	return;
	}
	}
	}
my $queryid=&reply("querysend:instdirsearch:".	my $queryid=&reply("querysend:instdirsearch:".
&escape($srch->{'srchby'}).':'.	&escape($srch->{'srchby'}).':'.
&escape($srch->{'srchterm'}).':'.	&escape($srch->{'srchterm'}).':'.
&escape($srch->{'srchtype'}),$homeserver);	&escape($srch->{'srchtype'}),$homeserver);
my $host=&hostname($homeserver);	my $host=&hostname($homeserver);
if ($queryid !~/^\Q$host\E\_/) {	if ($queryid !~/^\Q$host\E\_/) {
&logthis('instituional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom);	&logthis('institutional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.' in domain '.$udom);
return;	return;
}	}
my $response = &get_query_reply($queryid);	my $response = &get_query_reply($queryid);
Line 1964 sub usersearch {	Line 2161 sub usersearch {
my $query = 'usersearch';	my $query = 'usersearch';
foreach my $tryserver (keys(%libserv)) {	foreach my $tryserver (keys(%libserv)) {
if (&host_domain($tryserver) eq $dom) {	if (&host_domain($tryserver) eq $dom) {
	unless ($tryserver eq $perlvar{'lonHostID'}) {
	if ($srch->{'srchby'} eq 'email') {
	my $lcrev = &get_server_loncaparev(undef,$tryserver);
	my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);
	next if (($major eq '' && $minor eq '') \|\| ($major < 2) \|\|
	(($major == 2) && ($minor < 12)));
	}
	}
my $host=&hostname($tryserver);	my $host=&hostname($tryserver);
my $queryid=	my $queryid=
&reply("querysend:".&escape($query).':'.	&reply("querysend:".&escape($query).':'.
Line 2202 sub get_domain_defaults {	Line 2407 sub get_domain_defaults {
'requestcourses','inststatus',	'requestcourses','inststatus',
'coursedefaults','usersessions',	'coursedefaults','usersessions',
'requestauthor','selfenrollment',	'requestauthor','selfenrollment',
'coursecategories'],$domain);	'coursecategories','ssl','autoenroll',
	'trust','helpsettings'],$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 2211 sub get_domain_defaults {	Line 2417 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{'intauth_cost'} = $domconfig{'defaults'}{'intauth_cost'};
	$domdefaults{'intauth_switch'} = $domconfig{'defaults'}{'intauth_switch'};
	$domdefaults{'intauth_check'} = $domconfig{'defaults'}{'intauth_check'};
} 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 2278 sub get_domain_defaults {	Line 2487 sub get_domain_defaults {
} elsif ($domconfig{'coursedefaults'}{'canclone'}) {	} elsif ($domconfig{'coursedefaults'}{'canclone'}) {
$domdefaults{'canclone'}=$domconfig{'coursedefaults'}{'canclone'};	$domdefaults{'canclone'}=$domconfig{'coursedefaults'}{'canclone'};
}	}
	if ($domconfig{'coursedefaults'}{'texengine'}) {
	$domdefaults{'texengine'} = $domconfig{'coursedefaults'}{'texengine'};
	}
}	}
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 2328 sub get_domain_defaults {	Line 2540 sub get_domain_defaults {
$domdefaults{'catunauth'} = $domconfig{'coursecategories'}{'unauth'};	$domdefaults{'catunauth'} = $domconfig{'coursecategories'}{'unauth'};
}	}
}	}
	if (ref($domconfig{'ssl'}) eq 'HASH') {
	if (ref($domconfig{'ssl'}{'replication'}) eq 'HASH') {
	$domdefaults{'replication'} = $domconfig{'ssl'}{'replication'};
	}
	if (ref($domconfig{'ssl'}{'connto'}) eq 'HASH') {
	$domdefaults{'connect'} = $domconfig{'ssl'}{'connto'};
	}
	if (ref($domconfig{'ssl'}{'connfrom'}) eq 'HASH') {
	$domdefaults{'connect'} = $domconfig{'ssl'}{'connfrom'};
	}
	}
	if (ref($domconfig{'trust'}) eq 'HASH') {
	my @prefixes = qw(content shared enroll othcoau coaurem domroles catalog reqcrs msg);
	foreach my $prefix (@prefixes) {
	if (ref($domconfig{'trust'}{$prefix}) eq 'HASH') {
	$domdefaults{'trust'.$prefix} = $domconfig{'trust'}{$prefix};
	}
	}
	}
	if (ref($domconfig{'autoenroll'}) eq 'HASH') {
	$domdefaults{'autofailsafe'} = $domconfig{'autoenroll'}{'autofailsafe'};
	}
	if (ref($domconfig{'helpsettings'}) eq 'HASH') {
	$domdefaults{'submitbugs'} = $domconfig{'helpsettings'}{'submitbugs'};
	if (ref($domconfig{'helpsettings'}{'adhoc'}) eq 'HASH') {
	$domdefaults{'adhocroles'} = $domconfig{'helpsettings'}{'adhoc'};
	}
	}
&do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);	&do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);
return %domdefaults;	return %domdefaults;
}	}
Line 2584 sub make_key {	Line 2824 sub make_key {
sub devalidate_cache_new {	sub devalidate_cache_new {
my ($name,$id,$debug) = @_;	my ($name,$id,$debug) = @_;
if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }	if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }
	my $remembered_id=$name.':'.$id;
$id=&make_key($name,$id);	$id=&make_key($name,$id);
$memcache->delete($id);	$memcache->delete($id);
delete($remembered{$id});	delete($remembered{$remembered_id});
delete($accessed{$id});	delete($accessed{$remembered_id});
}	}

sub is_cached_new {	sub is_cached_new {
my ($name,$id,$debug) = @_;	my ($name,$id,$debug) = @_;
$id=&make_key($name,$id);	my $remembered_id=$name.':'.$id; # this is to avoid make_key (which is slow) whenever possible
if (exists($remembered{$id})) {	if (exists($remembered{$remembered_id})) {
if ($debug) { &Apache::lonnet::logthis("Early return $id of $remembered{$id} "); }	if ($debug) { &Apache::lonnet::logthis("Early return $remembered_id of $remembered{$remembered_id} "); }
$accessed{$id}=[&gettimeofday()];	$accessed{$remembered_id}=[&gettimeofday()];
$hits++;	$hits++;
return ($remembered{$id},1);	return ($remembered{$remembered_id},1);
}	}
	$id=&make_key($name,$id);
my $value = $memcache->get($id);	my $value = $memcache->get($id);
if (!(defined($value))) {	if (!(defined($value))) {
if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); }	if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); }
Line 2608 sub is_cached_new {	Line 2850 sub is_cached_new {
if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); }	if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); }
$value=undef;	$value=undef;
}	}
&make_room($id,$value,$debug);	&make_room($remembered_id,$value,$debug);
if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); }	if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); }
return ($value,1);	return ($value,1);
}	}

sub do_cache_new {	sub do_cache_new {
my ($name,$id,$value,$time,$debug) = @_;	my ($name,$id,$value,$time,$debug) = @_;
	my $remembered_id=$name.':'.$id;
$id=&make_key($name,$id);	$id=&make_key($name,$id);
my $setvalue=$value;	my $setvalue=$value;
if (!defined($setvalue)) {	if (!defined($setvalue)) {
Line 2630 sub do_cache_new {	Line 2873 sub do_cache_new {
$memcache->disconnect_all();	$memcache->disconnect_all();
}	}
# need to make a copy of $value	# need to make a copy of $value
&make_room($id,$value,$debug);	&make_room($remembered_id,$value,$debug);
return $value;	return $value;
}	}

sub make_room {	sub make_room {
my ($id,$value,$debug)=@_;	my ($remembered_id,$value,$debug)=@_;

$remembered{$id}= (ref($value)) ? &Storable::dclone($value)	$remembered{$remembered_id}= (ref($value)) ? &Storable::dclone($value)
: $value;	: $value;
if ($to_remember<0) { return; }	if ($to_remember<0) { return; }
$accessed{$id}=[&gettimeofday()];	$accessed{$remembered_id}=[&gettimeofday()];
if (scalar(keys(%remembered)) <= $to_remember) { return; }	if (scalar(keys(%remembered)) <= $to_remember) { return; }
my $to_kick;	my $to_kick;
my $max_time=0;	my $max_time=0;
Line 2852 sub repcopy {	Line 3095 sub repcopy {
mkdir($path,0777);	mkdir($path,0777);
}	}
}	}
my $ua=new LWP::UserAgent;
my $request=new HTTP::Request('GET',"$remoteurl");	my $request=new HTTP::Request('GET',"$remoteurl");
my $response=$ua->request($request,$transname);	my $response;
	if ($remoteurl =~ m{/raw/}) {
	$response=&LONCAPA::LWPReq::makerequest($home,$request,$transname,\%perlvar,'',0,1);
	} else {
	$response=&LONCAPA::LWPReq::makerequest($home,$request,$transname,\%perlvar,'',1);
	}
if ($response->is_error()) {	if ($response->is_error()) {
unlink($transname);	unlink($transname);
my $message=$response->status_line;	my $message=$response->status_line;
Line 2864 sub repcopy {	Line 3111 sub repcopy {
} else {	} else {
if ($remoteurl!~/\.meta$/) {	if ($remoteurl!~/\.meta$/) {
my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');	my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');
my $mresponse=$ua->request($mrequest,$filename.'.meta');	my $mresponse;
	if ($remoteurl =~ m{/raw/}) {
	$mresponse = &LONCAPA::LWPReq::makerequest($home,$mrequest,$filename.'.meta',\%perlvar,'',0,1);
	} else {
	$mresponse = &LONCAPA::LWPReq::makerequest($home,$mrequest,$filename.'.meta',\%perlvar,'',1);
	}
if ($mresponse->is_error()) {	if ($mresponse->is_error()) {
unlink($filename.'.meta');	unlink($filename.'.meta');
&logthis(	&logthis(
Line 2927 sub absolute_url {	Line 3179 sub absolute_url {
sub ssi {	sub ssi {

my ($fn,%form)=@_;	my ($fn,%form)=@_;
my $ua=new LWP::UserAgent;
my $request;	my $request;

$form{'no_update_last_known'}=1;	$form{'no_update_last_known'}=1;
Line 2945 sub ssi {	Line 3196 sub ssi {
}	}

$request->header(Cookie => $ENV{'HTTP_COOKIE'});	$request->header(Cookie => $ENV{'HTTP_COOKIE'});
my $response= $ua->request($request);	my $lonhost = $perlvar{'lonHostID'};
my $content = $response->content;	my $response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar);


if (wantarray) {	if (wantarray) {
return ($content, $response);	return ($response->content, $response);
} else {	} else {
return $content;	return $response->content;
}	}
}	}

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


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

	sub remove_stale_resfile {
	my ($url) = @_;
	my $removed;
	if ($url=~m{^/res/($match_domain)/($match_username)/}) {
	my $audom = $1;
	my $auname = $2;
	unless (($url =~ /\.\d+\.\w+$/) \|\| ($url =~ m{^/res/lib/templates/})) {
	my $homeserver = &homeserver($auname,$audom);
	unless (($homeserver eq 'no_host') \|\|
	(grep { $_ eq $homeserver } &current_machine_ids())) {
	my $fname = &filelocation('',$url);
	if (-e $fname) {
	my $protocol = $protocol{$homeserver};
	$protocol = 'http' if ($protocol ne 'https');
	my $hostname = &hostname($homeserver);
	if ($hostname) {
	my $uri = &declutter($url);
	my $request=new HTTP::Request('HEAD',$protocol.'://'.$hostname.'/raw/'.$uri);
	my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,5,0,1);
	if ($response->is_success()) {
	my $remmodtime = &HTTP::Date::str2time( $response->header('Last-modified') );
	my $locmodtime = (stat($fname))[9];
	if ($locmodtime < $remmodtime) {
	my $stale;
	my $answer = &reply('pong',$homeserver);
	if ($answer eq $homeserver.':'.$perlvar{'lonHostID'}) {
	sleep(0.2);
	$locmodtime = (stat($fname))[9];
	if ($locmodtime < $remmodtime) {
	my $posstransfer = $fname.'.in.transfer';
	if ((-e $posstransfer) && ($remmodtime < (stat($posstransfer))[9])) {
	$removed = 1;
	} else {
	$stale = 1;
	}
	} else {
	$removed = 1;
	}
	} else {
	$stale = 1;
	}
	if ($stale) {
	unlink($fname);
	if ($uri!~/\.meta$/) {
	unlink($fname.'.meta');
	}
	&reply("unsub:$fname",$homeserver);
	$removed = 1;
	}
	}
	}
	}
	}
	}
	}
	}
	return $removed;
	}

# -------------------------------- Allow a /uploaded/ URI to be vouched for	# -------------------------------- Allow a /uploaded/ URI to be vouched for

sub allowuploaded {	sub allowuploaded {
Line 3106 sub can_edit_resource {	Line 3420 sub can_edit_resource {
$forceedit = 1;	$forceedit = 1;
}	}
$cfile = $resurl;	$cfile = $resurl;
} elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/exttools?$}) {	} elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) {
$incourse = 1;	$incourse = 1;
if ($env{'form.forceedit'}) {	if ($env{'form.forceedit'}) {
$forceview = 1;	$forceview = 1;
Line 3138 sub can_edit_resource {	Line 3452 sub can_edit_resource {
$forceedit = 1;	$forceedit = 1;
}	}
$cfile = $resurl;	$cfile = $resurl;
} elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/exttools?$}) && ($env{'form.folderpath'} =~ /^supplemental/)) {	} elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) && ($env{'form.folderpath'} =~ /^supplemental/)) {
$incourse = 1;	$incourse = 1;
if ($env{'form.forceedit'}) {	if ($env{'form.forceedit'}) {
$forceview = 1;	$forceview = 1;
Line 3156 sub can_edit_resource {	Line 3470 sub can_edit_resource {
} else {	} else {
$cfile = $env{'form.suppurl'};	$cfile = $env{'form.suppurl'};
my $escfile = &unescape($cfile);	my $escfile = &unescape($cfile);
if ($escfile =~ m{^/adm/$cdom/$cnum/\d+/exttools?$}) {	if ($escfile =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) {
$cfile = '/adm/wrapper'.$escfile;	$cfile = '/adm/wrapper'.$escfile;
} else {	} else {
$escfile =~ s{^http://}{};	$escfile =~ s{^http://}{};
Line 3317 sub process_coursefile {	Line 3631 sub process_coursefile {
$home);	$home);
}	}
} elsif ($action eq 'uploaddoc') {	} elsif ($action eq 'uploaddoc') {
open(my $fh,'>'.$filepath.'/'.$fname);	open(my $fh,'>',$filepath.'/'.$fname);
print $fh $env{'form.'.$source};	print $fh $env{'form.'.$source};
close($fh);	close($fh);
if ($parser eq 'parse') {	if ($parser eq 'parse') {
Line 3375 sub store_edited_file {	Line 3689 sub store_edited_file {
($fpath,$fname) = ($file =~ m\|^(.*)/([^/]+)$\|);	($fpath,$fname) = ($file =~ m\|^(.*)/([^/]+)$\|);
$fpath=$docudom.'/'.$docuname.'/'.$fpath;	$fpath=$docudom.'/'.$docuname.'/'.$fpath;
my $filepath = &build_filepath($fpath);	my $filepath = &build_filepath($fpath);
open(my $fh,'>'.$filepath.'/'.$fname);	open(my $fh,'>',$filepath.'/'.$fname);
print $fh $content;	print $fh $content;
close($fh);	close($fh);
my $home=&homeserver($docuname,$docudom);	my $home=&homeserver($docuname,$docudom);
Line 3491 sub userfileupload {	Line 3805 sub userfileupload {
'_'.$env{'user.domain'}.'/pending';	'_'.$env{'user.domain'}.'/pending';
} elsif (($context eq 'existingfile') \|\| ($context eq 'canceloverwrite')) {	} elsif (($context eq 'existingfile') \|\| ($context eq 'canceloverwrite')) {
my ($docuname,$docudom);	my ($docuname,$docudom);
if ($destudom) {	if ($destudom =~ /^$match_domain$/) {
$docudom = $destudom;	$docudom = $destudom;
} else {	} else {
$docudom = $env{'user.domain'};	$docudom = $env{'user.domain'};
}	}
if ($destuname) {	if ($destuname =~ /^$match_username$/) {
$docuname = $destuname;	$docuname = $destuname;
} else {	} else {
$docuname = $env{'user.name'};	$docuname = $env{'user.name'};
Line 3526 sub userfileupload {	Line 3840 sub userfileupload {
mkdir($fullpath,0777);	mkdir($fullpath,0777);
}	}
}	}
open(my $fh,'>'.$fullpath.'/'.$fname);	open(my $fh,'>',$fullpath.'/'.$fname);
print $fh $env{'form.'.$formname};	print $fh $env{'form.'.$formname};
close($fh);	close($fh);
if ($context eq 'existingfile') {	if ($context eq 'existingfile') {
Line 3601 sub finishuserfileupload {	Line 3915 sub finishuserfileupload {

# Save the file	# Save the file
{	{
if (!open(FH,'>'.$filepath.'/'.$file)) {	if (!open(FH,'>',$filepath.'/'.$file)) {
&logthis('Failed to create '.$filepath.'/'.$file);	&logthis('Failed to create '.$filepath.'/'.$file);
print STDERR ('Failed to create '.$filepath.'/'.$file."\n");	print STDERR ('Failed to create '.$filepath.'/'.$file."\n");
return '/adm/notfound.html';	return '/adm/notfound.html';
Line 3659 sub finishuserfileupload {	Line 3973 sub finishuserfileupload {
my $input = $filepath.'/'.$file;	my $input = $filepath.'/'.$file;
my $output = $filepath.'/'.'tn-'.$file;	my $output = $filepath.'/'.'tn-'.$file;
my $thumbsize = $thumbwidth.'x'.$thumbheight;	my $thumbsize = $thumbwidth.'x'.$thumbheight;
system("convert -sample $thumbsize $input $output");	my @args = ('convert','-sample',$thumbsize,$input,$output);
	system({$args[0]} @args);
if (-e $filepath.'/'.'tn-'.$file) {	if (-e $filepath.'/'.'tn-'.$file) {
$fetchthumb = 1;	$fetchthumb = 1;
}	}
Line 4043 sub flushcourselogs {	Line 4358 sub flushcourselogs {
}	}
}	}
#	#
# Reverse lookup of domain roles (dc, ad, li, sc, au)	# Reverse lookup of domain roles (dc, ad, li, sc, dh, da, au)
#	#
my %domrolebuffer = ();	my %domrolebuffer = ();
foreach my $entry (keys(%domainrolehash)) {	foreach my $entry (keys(%domainrolehash)) {
Line 4058 sub flushcourselogs {	Line 4373 sub flushcourselogs {
delete $domainrolehash{$entry};	delete $domainrolehash{$entry};
}	}
foreach my $dom (keys(%domrolebuffer)) {	foreach my $dom (keys(%domrolebuffer)) {
my %servers = &get_servers($dom,'library');	my %servers;
	if (defined(&domain($dom,'primary'))) {
	my $primary=&domain($dom,'primary');
	my $hostname=&hostname($primary);
	$servers{$primary} = $hostname;
	} else {
	%servers = &get_servers($dom,'library');
	}
foreach my $tryserver (keys(%servers)) {	foreach my $tryserver (keys(%servers)) {
unless (&reply('domroleput:'.$dom.':'.	if (&reply('domroleput:'.$dom.':'.
$domrolebuffer{$dom},$tryserver) eq 'ok') {	$domrolebuffer{$dom},$tryserver) eq 'ok') {
	last;
	} else {
&logthis('Put of domain roles failed for '.$dom.' and '.$tryserver);	&logthis('Put of domain roles failed for '.$dom.' and '.$tryserver);
}	}
}	}
Line 4181 sub userrolelog {	Line 4505 sub userrolelog {
{$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'}	{$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'}
=$tend.':'.$tstart;	=$tend.':'.$tstart;
}	}
if ($trole =~ /^(dc\|ad\|li\|au\|dg\|sc)/ ) {	if ($trole =~ /^(dc\|ad\|li\|au\|dg\|sc\|dh\|da)/ ) {
my (undef,$rudom,$runame,$rsec)=split(/\//,$area);	my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
$domainrolehash	$domainrolehash
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}	{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
Line 4408 sub get_my_roles {	Line 4732 sub get_my_roles {
return %returnhash;	return %returnhash;
}	}

	sub get_all_adhocroles {
	my ($dom) = @_;
	my @roles_by_num = ();
	my %domdefaults = &get_domain_defaults($dom);
	my (%description,%access_in_dom,%access_info);
	if (ref($domdefaults{'adhocroles'}) eq 'HASH') {
	my $count = 0;
	my %domcurrent = %{$domdefaults{'adhocroles'}};
	my %ordered;
	foreach my $role (sort(keys(%domcurrent))) {
	my ($order,$desc,$access_in_dom);
	if (ref($domcurrent{$role}) eq 'HASH') {
	$order = $domcurrent{$role}{'order'};
	$desc = $domcurrent{$role}{'desc'};
	$access_in_dom{$role} = $domcurrent{$role}{'access'};
	$access_info{$role} = $domcurrent{$role}{$access_in_dom{$role}};
	}
	if ($order eq '') {
	$order = $count;
	}
	$ordered{$order} = $role;
	if ($desc ne '') {
	$description{$role} = $desc;
	} else {
	$description{$role}= $role;
	}
	$count++;
	}
	foreach my $item (sort {$a <=> $b } (keys(%ordered))) {
	push(@roles_by_num,$ordered{$item});
	}
	}
	return (\@roles_by_num,\%description,\%access_in_dom,\%access_info);
	}

	sub get_my_adhocroles {
	my ($cid,$checkreg) = @_;
	my ($cdom,$cnum,%info,@possroles,$description,$roles_by_num);
	if ($env{'request.course.id'} eq $cid) {
	$cdom = $env{'course.'.$cid.'.domain'};
	$cnum = $env{'course.'.$cid.'.num'};
	$info{'internal.coursecode'} = $env{'course.'.$cid.'.internal.coursecode'};
	} elsif ($cid =~ /^($match_domain)_($match_courseid)$/) {
	$cdom = $1;
	$cnum = $2;
	%info = &Apache::lonnet::get('environment',['internal.coursecode'],
	$cdom,$cnum);
	}
	if (($info{'internal.coursecode'} ne '') && ($checkreg)) {
	my $user = $env{'user.name'}.':'.$env{'user.domain'};
	my %rosterhash = &get('classlist',[$user],$cdom,$cnum);
	if ($rosterhash{$user} ne '') {
	my $type = (split(/:/,$rosterhash{$user}))[5];
	return ([],{}) if ($type eq 'auto');
	}
	}
	if (($cdom ne '') && ($cnum ne '')) {
	if (($env{"user.role.dh./$cdom/"}) \|\| ($env{"user.role.da./$cdom/"})) {
	my $then=$env{'user.login.time'};
	my $update=$env{'user.update.time'};
	if (!$update) {
	$update = $then;
	}
	my @liveroles;
	foreach my $role ('dh','da') {
	if ($env{"user.role.$role./$cdom/"}) {
	my ($tstart,$tend)=split(/\./,$env{"user.role.$role./$cdom/"});
	my $limit = $update;
	if ($env{'request.role'} eq "$role./$cdom/") {
	$limit = $then;
	}
	my $activerole = 1;
	if ($tstart && $tstart>$limit) { $activerole = 0; }
	if ($tend && $tend <$limit) { $activerole = 0; }
	if ($activerole) {
	push(@liveroles,$role);
	}
	}
	}
	if (@liveroles) {
	if (&homeserver($cnum,$cdom) ne 'no_host') {
	my ($accessref,$accessinfo,%access_in_dom);
	($roles_by_num,$description,$accessref,$accessinfo) = &get_all_adhocroles($cdom);
	if (ref($roles_by_num) eq 'ARRAY') {
	if (@{$roles_by_num}) {
	my %settings;
	if ($env{'request.course.id'} eq $cid) {
	foreach my $envkey (keys(%env)) {
	if ($envkey =~ /^\Qcourse.$cid.\E(internal\.adhoc.+)$/) {
	$settings{$1} = $env{$envkey};
	}
	}
	} else {
	%settings = &dump('environment',$cdom,$cnum,'internal\.adhoc');
	}
	my %setincrs;
	if ($settings{'internal.adhocaccess'}) {
	map { $setincrs{$_} = 1; } split(/,/,$settings{'internal.adhocaccess'});
	}
	my @statuses;
	if ($env{'environment.inststatus'}) {
	@statuses = split(/,/,$env{'environment.inststatus'});
	}
	my $user = $env{'user.name'}.':'.$env{'user.domain'};
	if (ref($accessref) eq 'HASH') {
	%access_in_dom = %{$accessref};
	}
	foreach my $role (@{$roles_by_num}) {
	my ($curraccess,@okstatus,@personnel);
	if ($setincrs{$role}) {
	($curraccess,my $rest) = split(/=/,$settings{'internal.adhoc.'.$role});
	if ($curraccess eq 'status') {
	@okstatus = split(/\&/,$rest);
	} elsif (($curraccess eq 'exc') \|\| ($curraccess eq 'inc')) {
	@personnel = split(/\&/,$rest);
	}
	} else {
	$curraccess = $access_in_dom{$role};
	if (ref($accessinfo) eq 'HASH') {
	if ($curraccess eq 'status') {
	if (ref($accessinfo->{$role}) eq 'ARRAY') {
	@okstatus = @{$accessinfo->{$role}};
	}
	} elsif (($curraccess eq 'exc') \|\| ($curraccess eq 'inc')) {
	if (ref($accessinfo->{$role}) eq 'ARRAY') {
	@personnel = @{$accessinfo->{$role}};
	}
	}
	}
	}
	if ($curraccess eq 'none') {
	next;
	} elsif ($curraccess eq 'all') {
	push(@possroles,$role);
	} elsif ($curraccess eq 'dh') {
	if (grep(/^dh$/,@liveroles)) {
	push(@possroles,$role);
	} else {
	next;
	}
	} elsif ($curraccess eq 'da') {
	if (grep(/^da$/,@liveroles)) {
	push(@possroles,$role);
	} else {
	next;
	}
	} elsif ($curraccess eq 'status') {
	if (@okstatus) {
	if (!@statuses) {
	if (grep(/^default$/,@okstatus)) {
	push(@possroles,$role);
	}
	} else {
	foreach my $status (@okstatus) {
	if (grep(/^\Q$status\E$/,@statuses)) {
	push(@possroles,$role);
	last;
	}
	}
	}
	}
	} elsif (($curraccess eq 'exc') \|\| ($curraccess eq 'inc')) {
	if (grep(/^\Q$user\E$/,@personnel)) {
	if ($curraccess eq 'exc') {
	push(@possroles,$role);
	}
	} elsif ($curraccess eq 'inc') {
	push(@possroles,$role);
	}
	}
	}
	}
	}
	}
	}
	}
	}
	unless (ref($description) eq 'HASH') {
	if (ref($roles_by_num) eq 'ARRAY') {
	my %desc;
	map { $desc{$_} = $_; } (@{$roles_by_num});
	$description = \%desc;
	} else {
	$description = {};
	}
	}
	return (\@possroles,$description);
	}

# ----------------------------------------------------- Frontpage Announcements	# ----------------------------------------------------- Frontpage Announcements
#	#
#	#
Line 4421 sub postannounce {	Line 4934 sub postannounce {

sub getannounce {	sub getannounce {

if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) {	if (open(my $fh,"<",$perlvar{'lonDocRoot'}.'/announcement.txt')) {
my $announcement='';	my $announcement='';
while (my $line = <$fh>) { $announcement .= $line; }	while (my $line = <$fh>) { $announcement .= $line; }
close($fh);	close($fh);
Line 4648 sub get_domain_roles {	Line 5161 sub get_domain_roles {
return %personnel;	return %personnel;
}	}

	sub get_active_domroles {
	my ($dom,$roles) = @_;
	return () unless (ref($roles) eq 'ARRAY');
	my $now = time;
	my %dompersonnel = &get_domain_roles($dom,$roles,$now,$now);
	my %domroles;
	foreach my $server (keys(%dompersonnel)) {
	foreach my $user (sort(keys(%{$dompersonnel{$server}}))) {
	my ($trole,$uname,$udom,$runame,$rudom,$rsec) = split(/:/,$user);
	$domroles{$uname.':'.$udom} = $dompersonnel{$server}{$user};
	}
	}
	return %domroles;
	}

# ----------------------------------------------------------- Interval timing	# ----------------------------------------------------------- Interval timing

{	{
Line 4716 sub set_first_access {	Line 5244 sub set_first_access {
'course.'.$courseid.'.timerinterval.'.$res => $interval,	'course.'.$courseid.'.timerinterval.'.$res => $interval,
}	}
);	);
	if (($cachedtime) && (abs($start-$cachedtime) < 5)) {
	$cachedtimes{"$courseid\0$res"} = $start;
	}
}	}
return $putres;	return $putres;
}	}
Line 5502 sub rolesinit {	Line 6033 sub rolesinit {
}	}
}	}

@userroles{'user.author', 'user.adv'} = &set_userprivs(\%userroles,	@userroles{'user.author','user.adv','user.rar'} = &set_userprivs(\%userroles,
\%allroles, \%allgroups);	\%allroles, \%allgroups);
$env{'user.adv'} = $userroles{'user.adv'};	$env{'user.adv'} = $userroles{'user.adv'};
	$env{'user.rar'} = $userroles{'user.rar'};

return (\%userroles,\%firstaccenv,\%timerintenv);	return (\%userroles,\%firstaccenv,\%timerintenv);
}	}
Line 5540 sub custom_roleprivs {	Line 6072 sub custom_roleprivs {
$$allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;	$$allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;
}	}
if (($trest ne '') && (defined($coursepriv))) {	if (($trest ne '') && (defined($coursepriv))) {
	if ($trole =~ m{^cr/$tdomain/$tdomain\Q-domainconfig\E/([^/]+)$}) {
	my $rolename = $1;
	$coursepriv = &course_adhocrole_privs($rolename,$tdomain,$trest,$coursepriv);
	}
$$allroles{'cm.'.$area}.=':'.$coursepriv;	$$allroles{'cm.'.$area}.=':'.$coursepriv;
$$allroles{$spec.'.'.$area}.=':'.$coursepriv;	$$allroles{$spec.'.'.$area}.=':'.$coursepriv;
}	}
Line 5548 sub custom_roleprivs {	Line 6084 sub custom_roleprivs {
}	}
}	}

	sub course_adhocrole_privs {
	my ($rolename,$cdom,$cnum,$coursepriv) = @_;
	my %overrides = &get('environment',["internal.adhocpriv.$rolename"],$cdom,$cnum);
	if ($overrides{"internal.adhocpriv.$rolename"}) {
	my (%currprivs,%storeprivs);
	foreach my $item (split(/:/,$coursepriv)) {
	my ($priv,$restrict) = split(/\&/,$item);
	$currprivs{$priv} = $restrict;
	}
	my (%possadd,%possremove,%full);
	foreach my $item (split(/\:/,$Apache::lonnet::pr{'cr:c'})) {
	my ($priv,$restrict)=split(/\&/,$item);
	$full{$priv} = $restrict;
	}
	foreach my $item (split(/,/,$overrides{"internal.adhocpriv.$rolename"})) {
	next if ($item eq '');
	my ($rule,$rest) = split(/=/,$item);
	next unless (($rule eq 'off') \|\| ($rule eq 'on'));
	foreach my $priv (split(/:/,$rest)) {
	if ($priv ne '') {
	if ($rule eq 'off') {
	$possremove{$priv} = 1;
	} else {
	$possadd{$priv} = 1;
	}
	}
	}
	}
	foreach my $priv (sort(keys(%full))) {
	if (exists($currprivs{$priv})) {
	unless (exists($possremove{$priv})) {
	$storeprivs{$priv} = $currprivs{$priv};
	}
	} elsif (exists($possadd{$priv})) {
	$storeprivs{$priv} = $full{$priv};
	}
	}
	$coursepriv = ':'.join(':',map { $_.'&'.$storeprivs{$_}; } sort(keys(%storeprivs)));
	}
	return $coursepriv;
	}

sub group_roleprivs {	sub group_roleprivs {
my ($allgroups,$area,$group_privs,$tend,$tstart) = @_;	my ($allgroups,$area,$group_privs,$tend,$tstart) = @_;
my $access = 1;	my $access = 1;
Line 5582 sub set_userprivs {	Line 6160 sub set_userprivs {
my ($userroles,$allroles,$allgroups,$groups_roles) = @_;	my ($userroles,$allroles,$allgroups,$groups_roles) = @_;
my $author=0;	my $author=0;
my $adv=0;	my $adv=0;
	my $rar=0;
my %grouproles = ();	my %grouproles = ();
if (keys(%{$allgroups}) > 0) {	if (keys(%{$allgroups}) > 0) {
my @groupkeys;	my @groupkeys;
Line 5629 sub set_userprivs {	Line 6208 sub set_userprivs {
$thesepriv{$privilege}.=$restrictions;	$thesepriv{$privilege}.=$restrictions;
}	}
if ($thesepriv{'adv'} eq 'F') { $adv=1; }	if ($thesepriv{'adv'} eq 'F') { $adv=1; }
	if ($thesepriv{'rar'} eq 'F') { $rar=1; }
}	}
}	}
my $thesestr='';	my $thesestr='';
Line 5637 sub set_userprivs {	Line 6217 sub set_userprivs {
}	}
$userroles->{'user.priv.'.$role} = $thesestr;	$userroles->{'user.priv.'.$role} = $thesestr;
}	}
return ($author,$adv);	return ($author,$adv,$rar);
}	}

sub role_status {	sub role_status {
Line 5682 sub role_status {	Line 6262 sub role_status {
push(@rolecodes,$$role);	push(@rolecodes,$$role);
&standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where);	&standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where);
}	}
my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups,\%groups_roles);	my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%allroles,\%allgroups,
	\%groups_roles);
&appenv(\%userroles,\@rolecodes);	&appenv(\%userroles,\@rolecodes);
&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);	&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec);
}	}
}	}
$$tstatus = 'is';	$$tstatus = 'is';
Line 5760 sub delete_env_groupprivs {	Line 6341 sub delete_env_groupprivs {
}	}

sub check_adhoc_privs {	sub check_adhoc_privs {
my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller) = @_;	my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller,$sec) = @_;
my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;	my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;
	if ($sec) {
	$cckey .= '/'.$sec;
	}
my $setprivs;	my $setprivs;
if ($env{$cckey}) {	if ($env{$cckey}) {
my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);	my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);
&role_status($cckey,$update,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);	&role_status($cckey,$update,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);
unless (($tstatus eq 'is') \|\| ($tstatus eq 'will_not')) {	unless (($tstatus eq 'is') \|\| ($tstatus eq 'will_not')) {
&set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);	&set_adhoc_privileges($cdom,$cnum,$checkrole,$caller,$sec);
$setprivs = 1;	$setprivs = 1;
}	}
} else {	} else {
&set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);	&set_adhoc_privileges($cdom,$cnum,$checkrole,$caller,$sec);
$setprivs = 1;	$setprivs = 1;
}	}
return $setprivs;	return $setprivs;
}	}

sub set_adhoc_privileges {	sub set_adhoc_privileges {
# role can be cc or ca	# role can be cc, ca, or cr/<dom>/<dom>-domainconfig/role
my ($dcdom,$pickedcourse,$role,$caller) = @_;	my ($dcdom,$pickedcourse,$role,$caller,$sec) = @_;
my $area = '/'.$dcdom.'/'.$pickedcourse;	my $area = '/'.$dcdom.'/'.$pickedcourse;
	if ($sec ne '') {
	$area .= '/'.$sec;
	}
my $spec = $role.'.'.$area;	my $spec = $role.'.'.$area;
my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'},	my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'},
$env{'user.name'},1);	$env{'user.name'},1);
my %ccrole = ();	my %rolehash = ();
&standard_roleprivs(\%ccrole,$role,$dcdom,$spec,$pickedcourse,$area);	if ($role =~ m{^\Qcr/$dcdom/$dcdom\E\-domainconfig/(\w+)$}) {
my ($author,$adv)= &set_userprivs(\%userroles,\%ccrole);	my $rolename = $1;
	&custom_roleprivs(\%rolehash,$role,$dcdom,$pickedcourse,$spec,$area);
	my %domdef = &get_domain_defaults($dcdom);
	if (ref($domdef{'adhocroles'}) eq 'HASH') {
	if (ref($domdef{'adhocroles'}{$rolename}) eq 'HASH') {
	&appenv({'request.role.desc' => $domdef{'adhocroles'}{$rolename}{'desc'},});
	}
	}
	} else {
	&standard_roleprivs(\%rolehash,$role,$dcdom,$spec,$pickedcourse,$area);
	}
	my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%rolehash);
&appenv(\%userroles,[$role,'cm']);	&appenv(\%userroles,[$role,'cm']);
&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);	&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec);
unless ($caller eq 'constructaccess' && $env{'request.course.id'}) {	unless ($caller eq 'constructaccess' && $env{'request.course.id'}) {
&appenv( {'request.role' => $spec,	&appenv( {'request.role' => $spec,
'request.role.domain' => $dcdom,	'request.role.domain' => $dcdom,
'request.course.sec' => ''	'request.course.sec' => $sec,
}	}
);	);
my $tadv=0;	my $tadv=0;
Line 5942 sub currentdump {	Line 6540 sub currentdump {
#	#
my %returnhash=();	my %returnhash=();
#	#
if ($rep eq "unknown_cmd") {	if ($rep eq 'unknown_cmd') {
# an old lond will not know currentdump	# an old lond will not know currentdump
# Do a dump and make it look like a currentdump	# Do a dump and make it look like a currentdump
my @tmp = &dumpstore($courseid,$sdom,$sname,'.');	my @tmp = &dumpstore($courseid,$sdom,$sname,'.');
Line 6176 sub tmpget {	Line 6774 sub tmpget {
if (!defined($server)) { $server = $perlvar{'lonHostID'}; }	if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
my $rep=&reply("tmpget:$token",$server);	my $rep=&reply("tmpget:$token",$server);
my %returnhash;	my %returnhash;
	if ($rep =~ /^(con_lost\|error\|no_such_host)/i) {
	return %returnhash;
	}
foreach my $item (split(/\&/,$rep)) {	foreach my $item (split(/\&/,$rep)) {
my ($key,$value)=split(/=/,$item);	my ($key,$value)=split(/=/,$item);
next if ($key =~ /^error: 2 /);
$returnhash{&unescape($key)}=&thaw_unescape($value);	$returnhash{&unescape($key)}=&thaw_unescape($value);
}	}
return %returnhash;	return %returnhash;
Line 6561 sub usertools_access {	Line 7161 sub usertools_access {
community => 1,	community => 1,
textbook => 1,	textbook => 1,
placement => 1,	placement => 1,
	lti => 1,
);	);
} elsif ($context eq 'requestauthor') {	} elsif ($context eq 'requestauthor') {
%tools = (	%tools = (
Line 6757 sub is_advanced_user {	Line 7358 sub is_advanced_user {
}	}

sub check_can_request {	sub check_can_request {
my ($dom,$can_request,$request_domains) = @_;	my ($dom,$can_request,$request_domains,$uname,$udom) = @_;
my $canreq = 0;	my $canreq = 0;
	if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) {
	$uname = $env{'user.name'};
	$udom = $env{'user.domain'};
	}
my ($types,$typename) = &Apache::loncommon::course_types();	my ($types,$typename) = &Apache::loncommon::course_types();
my @options = ('approval','validate','autolimit');	my @options = ('approval','validate','autolimit');
my $optregex = join('\|',@options);	my $optregex = join('\|',@options);
if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) {	if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) {
foreach my $type (@{$types}) {	foreach my $type (@{$types}) {
if (&usertools_access($env{'user.name'},	if (&usertools_access($uname,$udom,$type,undef,
$env{'user.domain'},	'requestcourses')) {
$type,undef,'requestcourses')) {
$canreq ++;	$canreq ++;
if (ref($request_domains) eq 'HASH') {	if (ref($request_domains) eq 'HASH') {
push(@{$request_domains->{$type}},$env{'user.domain'});	push(@{$request_domains->{$type}},$udom);
}	}
if ($dom eq $env{'user.domain'}) {	if ($dom eq $udom) {
$can_request->{$type} = 1;	$can_request->{$type} = 1;
}	}
}	}
if ($env{'environment.reqcrsotherdom.'.$type} ne '') {	if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '') &&
	($env{'environment.reqcrsotherdom.'.$type} ne '')) {
my @curr = split(',',$env{'environment.reqcrsotherdom.'.$type});	my @curr = split(',',$env{'environment.reqcrsotherdom.'.$type});
if (@curr > 0) {	if (@curr > 0) {
foreach my $item (@curr) {	foreach my $item (@curr) {
Line 6792 sub check_can_request {	Line 7397 sub check_can_request {
}	}
}	}
}	}
unless($dom eq $env{'user.domain'}) {	unless ($dom eq $env{'user.domain'}) {
$canreq ++;	$canreq ++;
if (grep(/^\Q$dom\E:($optregex)(=?\d*)$/,@curr)) {	if (grep(/^\Q$dom\E:($optregex)(=?\d*)$/,@curr)) {
$can_request->{$type} = 1;	$can_request->{$type} = 1;
Line 6874 sub allowed {	Line 7479 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)$}))	if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg\|bulletinboard\|ext\.tool)$}))
\|\| (($uri=~/\.meta$/) && ($uri!~m\|^uploaded/\|) ))	\|\| (($uri=~/\.meta$/) && ($uri!~m\|^uploaded/\|) ))
&& ($priv eq 'bre')) {	&& ($priv eq 'bre')) {
return 'F';	return 'F';
Line 6922 sub allowed {	Line 7527 sub allowed {
# Free bre to public access	# Free bre to public access

if ($priv eq 'bre') {	if ($priv eq 'bre') {
my $copyright=&metadata($uri,'copyright');	my $copyright;
	unless ($uri =~ /ext\.tool/) {
	$copyright=&metadata($uri,'copyright');
	}
if (($copyright eq 'public') && (!$env{'request.course.id'})) {	if (($copyright eq 'public') && (!$env{'request.course.id'})) {
return 'F';	return 'F';
}	}
Line 7362 sub constructaccess {	Line 7970 sub constructaccess {
my ($ownername,$ownerdomain,$ownerhome);	my ($ownername,$ownerdomain,$ownerhome);

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

# The URL does not really point to any authorspace, forget it	# The URL does not really point to any authorspace, forget it
unless (($ownername) && ($ownerdomain)) { return ''; }	unless (($ownername) && ($ownerdomain)) { return ''; }
Line 7383 sub constructaccess {	Line 7991 sub constructaccess {
$ownerhome = &homeserver($ownername,$ownerdomain);	$ownerhome = &homeserver($ownername,$ownerdomain);
return ($ownername,$ownerdomain,$ownerhome);	return ($ownername,$ownerdomain,$ownerhome);
}	}
	if ($env{'request.course.id'}) {
	if (($ownername eq $env{'course.'.$env{'request.course.id'}.'.num'}) &&
	($ownerdomain eq $env{'course.'.$env{'request.course.id'}.'.domain'})) {
	if (&allowed('mdc',$env{'request.course.id'})) {
	$ownerhome = $env{'course.'.$env{'request.course.id'}.'.home'};
	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 7701 sub get_symb_from_alias {	Line 8318 sub get_symb_from_alias {

sub definerole {	sub definerole {
if (allowed('mcr','/')) {	if (allowed('mcr','/')) {
my ($rolename,$sysrole,$domrole,$courole)=@_;	my ($rolename,$sysrole,$domrole,$courole,$uname,$udom)=@_;
foreach my $role (split(':',$sysrole)) {	foreach my $role (split(':',$sysrole)) {
my ($crole,$cqual)=split(/\&/,$role);	my ($crole,$cqual)=split(/\&/,$role);
if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; }	if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; }
Line 7729 sub definerole {	Line 8346 sub definerole {
}	}
}	}
}	}
	my $uhome;
	if (($uname ne '') && ($udom ne '')) {
	$uhome = &homeserver($uname,$udom);
	return $uhome if ($uhome eq 'no_host');
	} else {
	$uname = $env{'user.name'};
	$udom = $env{'user.domain'};
	$uhome = $env{'user.home'};
	}
my $command="encrypt:rolesput:$env{'user.domain'}:$env{'user.name'}:".	my $command="encrypt:rolesput:$env{'user.domain'}:$env{'user.name'}:".
"$env{'user.domain'}:$env{'user.name'}:".	"$udom:$uname:rolesdef_$rolename=".
"rolesdef_$rolename=".
escape($sysrole.'_'.$domrole.'_'.$courole);	escape($sysrole.'_'.$domrole.'_'.$courole);
return reply($command,$env{'user.home'});	return reply($command,$uhome);
} else {	} else {
return 'refused';	return 'refused';
}	}
Line 7815 sub update_allusers_table {	Line 8440 sub update_allusers_table {

sub fetch_enrollment_query {	sub fetch_enrollment_query {
my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_;	my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_;
my $homeserver;	my ($homeserver,$sleep,$loopmax);
my $maxtries = 1;	my $maxtries = 1;
if ($context eq 'automated') {	if ($context eq 'automated') {
$homeserver = $perlvar{'lonHostID'};	$homeserver = $perlvar{'lonHostID'};
	$sleep = 2;
	$loopmax = 100;
$maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout	$maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout
} else {	} else {
$homeserver = &homeserver($cnum,$dom);	$homeserver = &homeserver($cnum,$dom);
Line 7836 sub fetch_enrollment_query {	Line 8463 sub fetch_enrollment_query {
&logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum);	&logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum);
return 'error: '.$queryid;	return 'error: '.$queryid;
}	}
my $reply = &get_query_reply($queryid);	my $reply = &get_query_reply($queryid,$sleep,$loopmax);
my $tries = 1;	my $tries = 1;
while (($reply=~/^timeout/) && ($tries < $maxtries)) {	while (($reply=~/^timeout/) && ($tries < $maxtries)) {
$reply = &get_query_reply($queryid);	$reply = &get_query_reply($queryid,$sleep,$loopmax);
$tries ++;	$tries ++;
}	}
if ( ($reply =~/^timeout/) \|\| ($reply =~/^error/) ) {	if ( ($reply =~/^timeout/) \|\| ($reply =~/^error/) ) {
&logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);	&logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
} else {	} else {
my @responses = split(/:/,$reply);	my @responses = split(/:/,$reply);
if ($homeserver eq $perlvar{'lonHostID'}) {	if (grep { $_ eq $homeserver } &current_machine_ids()) {
foreach my $line (@responses) {	foreach my $line (@responses) {
my ($key,$value) = split(/=/,$line,2);	my ($key,$value) = split(/=/,$line,2);
$$replyref{$key} = $value;	$$replyref{$key} = $value;
Line 7864 sub fetch_enrollment_query {	Line 8491 sub fetch_enrollment_query {
if ($xml_classlist =~ /^error/) {	if ($xml_classlist =~ /^error/) {
&logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum);	&logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum);
} else {	} else {
if ( open(FILE,">$destname") ) {	if ( open(FILE,">",$destname) ) {
print FILE &unescape($xml_classlist);	print FILE &unescape($xml_classlist);
close(FILE);	close(FILE);
} else {	} else {
Line 7881 sub fetch_enrollment_query {	Line 8508 sub fetch_enrollment_query {
}	}

sub get_query_reply {	sub get_query_reply {
my $queryid=shift;	my ($queryid,$sleep,$loopmax) = @_;;
	if (($sleep eq '') \|\| ($sleep !~ /^\d+\.?\d*$/)) {
	$sleep = 0.2;
	}
	if (($loopmax eq '') \|\| ($loopmax =~ /\D/)) {
	$loopmax = 100;
	}
my $replyfile=LONCAPA::tempdir().$queryid;	my $replyfile=LONCAPA::tempdir().$queryid;
my $reply='';	my $reply='';
for (1..100) {	for (1..$loopmax) {
sleep(0.2);	sleep($sleep);
if (-e $replyfile.'.end') {	if (-e $replyfile.'.end') {
if (open(my $fh,$replyfile)) {	if (open(my $fh,"<",$replyfile)) {
$reply = join('',<$fh>);	$reply = join('',<$fh>);
close($fh);	close($fh);
} else { return 'error: reply_file_error'; }	} else { return 'error: reply_file_error'; }
Line 8279 sub auto_validate_class_sec {	Line 8912 sub auto_validate_class_sec {
return $response;	return $response;
}	}

	sub auto_validate_instclasses {
	my ($cdom,$cnum,$owners,$classesref) = @_;
	my ($homeserver,%validations);
	$homeserver = &homeserver($cnum,$cdom);
	unless ($homeserver eq 'no_host') {
	my $ownerlist;
	if (ref($owners) eq 'ARRAY') {
	$ownerlist = join(',',@{$owners});
	} else {
	$ownerlist = $owners;
	}
	if (ref($classesref) eq 'HASH') {
	my $classes = &freeze_escape($classesref);
	my $response=&reply('autovalidateinstclasses:'.&escape($ownerlist).
	':'.$cdom.':'.$classes,$homeserver);
	unless ($response =~ /(con_lost\|error\|no_such_host\|refused)/) {
	my @items = split(/&/,$response);
	foreach my $item (@items) {
	my ($key,$value) = split('=',$item);
	$validations{&unescape($key)} = &thaw_unescape($value);
	}
	}
	}
	}
	return %validations;
	}

sub auto_crsreq_update {	sub auto_crsreq_update {
my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title,	my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title,
$code,$accessstart,$accessend,$inbound) = @_;	$code,$accessstart,$accessend,$inbound) = @_;
Line 8638 sub assignrole {	Line 9298 sub assignrole {
}	}
if ($refused) {	if ($refused) {
my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});	my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
if (!$selfenroll && $context eq 'course') {	if (!$selfenroll && (($context eq 'course') \|\| ($context eq 'ltienroll' && $env{'request.lti.login'}))) {
my %crsenv;	my %crsenv;
if ($role eq 'cc' \|\| $role eq 'co') {	if ($role eq 'cc' \|\| $role eq 'co') {
%crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));	%crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
Line 8658 sub assignrole {	Line 9318 sub assignrole {
}	}
}	}
}	}
} elsif (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {	} elsif (($selfenroll == 1) && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
$refused = '';	if ($role eq 'st') {
	$refused = '';
	} elsif (($context eq 'ltienroll') && ($env{'request.lti.login'})) {
	$refused = '';
	}
} elsif ($context eq 'requestcourses') {	} elsif ($context eq 'requestcourses') {
my @possroles = ('st','ta','ep','in','cc','co');	my @possroles = ('st','ta','ep','in','cc','co');
if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) {	if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) {
Line 8774 sub assignrole {	Line 9438 sub assignrole {
&courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,	&courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
$selfenroll,$context);	$selfenroll,$context);
} elsif (($role eq 'li') \|\| ($role eq 'dg') \|\| ($role eq 'sc') \|\|	} elsif (($role eq 'li') \|\| ($role eq 'dg') \|\| ($role eq 'sc') \|\|
($role eq 'au') \|\| ($role eq 'dc')) {	($role eq 'au') \|\| ($role eq 'dc') \|\| ($role eq 'dh') \|\|
	($role eq 'da')) {
&domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,	&domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
$context);	$context);
} elsif (($role eq 'ca') \|\| ($role eq 'aa')) {	} elsif (($role eq 'ca') \|\| ($role eq 'aa')) {
Line 8924 sub modifyuser {	Line 9589 sub modifyuser {
my $newuser;	my $newuser;
if ($uhome eq 'no_host') {	if ($uhome eq 'no_host') {
$newuser = 1;	$newuser = 1;
	unless (($umode && ($upass ne '')) \|\| ($umode eq 'localauth') \|\|
	($umode eq 'lti')) {
	return 'error: more information needed to create new user';
	}
}	}
# ----------------------------------------------------------------- Create User	# ----------------------------------------------------------------- Create User
if (($uhome eq 'no_host') &&	if (($uhome eq 'no_host') &&
(($umode && $upass) \|\| ($umode eq 'localauth'))) {	(($umode && $upass) \|\| ($umode eq 'localauth') \|\| ($umode eq 'lti'))) {
my $unhome='';	my $unhome='';
if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) {	if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) {
$unhome = $desiredhome;	$unhome = $desiredhome;
Line 9079 sub modifyuser {	Line 9748 sub modifyuser {
sub modifystudent {	sub modifystudent {
my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,	my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
$end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid,	$end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid,
$selfenroll,$context,$inststatus,$credits)=@_;	$selfenroll,$context,$inststatus,$credits,$instsec)=@_;
if (!$cid) {	if (!$cid) {
unless ($cid=$env{'request.course.id'}) {	unless ($cid=$env{'request.course.id'}) {
return 'not_in_class';	return 'not_in_class';
Line 9095 sub modifystudent {	Line 9764 sub modifystudent {
$uid = undef if (!$forceid);	$uid = undef if (!$forceid);
$reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,	$reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
$gene,$usec,$end,$start,$type,$locktype,	$gene,$usec,$end,$start,$type,$locktype,
$cid,$selfenroll,$context,$credits);	$cid,$selfenroll,$context,$credits,$instsec);
return $reply;	return $reply;
}	}

sub modify_student_enrollment {	sub modify_student_enrollment {
my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,	my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,
$locktype,$cid,$selfenroll,$context,$credits) = @_;	$locktype,$cid,$selfenroll,$context,$credits,$instsec) = @_;
my ($cdom,$cnum,$chome);	my ($cdom,$cnum,$chome);
if (!$cid) {	if (!$cid) {
unless ($cid=$env{'request.course.id'}) {	unless ($cid=$env{'request.course.id'}) {
Line 9148 sub modify_student_enrollment {	Line 9817 sub modify_student_enrollment {
my %old_entry = &Apache::lonnet::get('classlist',[$user],$cdom,$cnum);	my %old_entry = &Apache::lonnet::get('classlist',[$user],$cdom,$cnum);
my $reply=cput('classlist',	my $reply=cput('classlist',
{$user =>	{$user =>
join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype,$credits) },	join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype,$credits,$instsec) },
$cdom,$cnum);	$cdom,$cnum);
if (($reply eq 'ok') \|\| ($reply eq 'delayed')) {	if (($reply eq 'ok') \|\| ($reply eq 'delayed')) {
&devalidate_getsection_cache($udom,$uname,$cid);	&devalidate_getsection_cache($udom,$uname,$cid);
Line 9372 sub is_course {	Line 10041 sub is_course {
my ($cdom, $cnum) = scalar(@_) == 1 ?	my ($cdom, $cnum) = scalar(@_) == 1 ?
($_[0] =~ /^($match_domain)_($match_courseid)$/) : @_;	($_[0] =~ /^($match_domain)_($match_courseid)$/) : @_;

return unless $cdom and $cnum;	return unless (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/));
	my $uhome=&homeserver($cnum,$cdom);
my %courses = &courseiddump($cdom, '.', 1, '.', '.', $cnum, undef, undef,	my $iscourse;
'.');	if (grep { $_ eq $uhome } current_machine_ids()) {
	$iscourse = &Lond::is_course($cdom,$cnum);
return unless(exists($courses{$cdom.'_'.$cnum}));	} else {
	my $hashid = $cdom.':'.$cnum;
	($iscourse,my $cached) = &is_cached_new('iscourse',$hashid);
	unless (defined($cached)) {
	my %courses = &courseiddump($cdom, '.', 1, '.', '.',
	$cnum,undef,undef,'.');
	$iscourse = 0;
	if (exists($courses{$cdom.'_'.$cnum})) {
	$iscourse = 1;
	}
	&do_cache_new('iscourse',$hashid,$iscourse,3600);
	}
	}
	return unless ($iscourse);
return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum;	return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum;
}	}

Line 9513 sub save_selected_files {	Line 10195 sub save_selected_files {
my ($user, $path, @files) = @_;	my ($user, $path, @files) = @_;
my $filename = $user."savedfiles";	my $filename = $user."savedfiles";
my @other_files = &files_not_in_path($user, $path);	my @other_files = &files_not_in_path($user, $path);
open (OUT, '>'.$tmpdir.$filename);	open (OUT,'>',LONCAPA::tempdir().$filename);
foreach my $file (@files) {	foreach my $file (@files) {
print (OUT $env{'form.currentpath'}.$file."\n");	print (OUT $env{'form.currentpath'}.$file."\n");
}	}
Line 9527 sub save_selected_files {	Line 10209 sub save_selected_files {
sub clear_selected_files {	sub clear_selected_files {
my ($user) = @_;	my ($user) = @_;
my $filename = $user."savedfiles";	my $filename = $user."savedfiles";
open (OUT, '>'.LONCAPA::tempdir().$filename);	open (OUT,'>',LONCAPA::tempdir().$filename);
print (OUT undef);	print (OUT undef);
close (OUT);	close (OUT);
return ("ok");	return ("ok");
Line 9537 sub files_in_path {	Line 10219 sub files_in_path {
my ($user, $path) = @_;	my ($user, $path) = @_;
my $filename = $user."savedfiles";	my $filename = $user."savedfiles";
my %return_files;	my %return_files;
open (IN, '<'.LONCAPA::tempdir().$filename);	open (IN,'<',LONCAPA::tempdir().$filename);
while (my $line_in = <IN>) {	while (my $line_in = <IN>) {
chomp ($line_in);	chomp ($line_in);
my @paths_and_file = split (m!/!, $line_in);	my @paths_and_file = split (m!/!, $line_in);
Line 9559 sub files_not_in_path {	Line 10241 sub files_not_in_path {
my $filename = $user."savedfiles";	my $filename = $user."savedfiles";
my @return_files;	my @return_files;
my $path_part;	my $path_part;
open(IN, '<'.LONCAPA::.$filename);	open(IN, '<',LONCAPA::tempdir().$filename);
while (my $line = <IN>) {	while (my $line = <IN>) {
#ok, I know it's clunky, but I want it to work	#ok, I know it's clunky, but I want it to work
my @paths_and_file = split(m\|/\|, $line);	my @paths_and_file = split(m\|/\|, $line);
Line 10134 sub dirlist {	Line 10816 sub dirlist {
foreach my $user (sort(keys(%allusers))) {	foreach my $user (sort(keys(%allusers))) {
push(@alluserslist,$user.'&user');	push(@alluserslist,$user.'&user');
}	}
return (\@alluserslist);
	if (!%listerror) {
	# no errors
	return (\@alluserslist);
	} elsif (scalar(keys(%servers)) == 1) {
	# one library server, one error
	my ($key) = keys(%listerror);
	return (\@alluserslist, $listerror{$key});
	} elsif ( grep { $_ eq 'con_lost' } values(%listerror) ) {
	# con_lost indicates that we might miss data from at least one
	# library server
	return (\@alluserslist, 'con_lost');
	} else {
	# multiple library servers and no con_lost -> data should be
	# complete.
	return (\@alluserslist);
	}

} else {	} else {
return ([],'missing username');	return ([],'missing username');
}	}
Line 10207 sub stat_file {	Line 10906 sub stat_file {
return ();	return ();
}	}

	# --------------------------------------------------------- recursedirs
	# Recursive function to traverse either a specific user's Authoring Space
	# or corresponding Published Resource Space, and populate the hash ref:
	# $dirhashref with URLs of all directories, and if $filehashref hash
	# ref arg is provided, the URLs of any files, excluding versioned, .meta,
	# or .rights files in resource space, and .meta, .save, .log, and .bak
	# files in Authoring Space.
	#
	# Inputs:
	#
	# $is_home - true if current server is home server for user's space
	# $context - either: priv, or res respectively for Authoring or Resource Space.
	# $docroot - Document root (i.e., /home/httpd/html
	# $toppath - Top level directory (i.e., /res/$dom/$uname or /priv/$dom/$uname
	# $relpath - Current path (relative to top level).
	# $dirhashref - reference to hash to populate with URLs of directories (Required)
	# $filehashref - reference to hash to populate with URLs of files (Optional)
	#
	# Returns: nothing
	#
	# Side Effects: populates $dirhashref, and $filehashref (if provided).
	#
	# Currently used by interface/londocs.pm to create linked select boxes for
	# directory and filename to import a Course "Author" resource into a course, and
	# also to create linked select boxes for Authoring Space and Directory to choose
	# save location for creation of a new "standard" problem from the Course Editor.
	#

	sub recursedirs {
	my ($is_home,$context,$docroot,$toppath,$relpath,$dirhashref,$filehashref) = @_;
	return unless (ref($dirhashref) eq 'HASH');
	my $currpath = $docroot.$toppath;
	if ($relpath) {
	$currpath .= "/$relpath";
	}
	my $savefile;
	if (ref($filehashref)) {
	$savefile = 1;
	}
	if ($is_home) {
	if (opendir(my $dirh,$currpath)) {
	foreach my $item (sort { lc($a) cmp lc($b) } grep(!/^\.+$/,readdir($dirh))) {
	next if ($item eq '');
	if (-d "$currpath/$item") {
	my $newpath;
	if ($relpath) {
	$newpath = "$relpath/$item";
	} else {
	$newpath = $item;
	}
	$dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;
	&recursedirs($is_home,$context,$docroot,$toppath,$newpath,$dirhashref,$filehashref);
	} elsif ($savefile) {
	if ($context eq 'priv') {
	unless ($item =~ /\.(meta\|save\|log\|bak\|DS_Store)$/) {
	$filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1;
	}
	} else {
	unless (($item =~ /\.meta$/) \|\| ($item =~ /\.\d+\.\w+$/) \|\| ($item =~ /\.rights$/)) {
	$filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1;
	}
	}
	}
	}
	closedir($dirh);
	}
	} else {
	my ($dirlistref,$listerror) =
	&dirlist($toppath.$relpath);
	my @dir_lines;
	my $dirptr=16384;
	if (ref($dirlistref) eq 'ARRAY') {
	foreach my $dir_line (sort
	{
	my ($afile)=split('&',$a,2);
	my ($bfile)=split('&',$b,2);
	return (lc($afile) cmp lc($bfile));
	} (@{$dirlistref})) {
	my ($item,$dom,undef,$testdir,undef,undef,undef,undef,$size,undef,$mtime,undef,undef,undef,$obs,undef) =
	split(/\&/,$dir_line,16);
	$item =~ s/\s+$//;
	next if (($item =~ /^\.\.?$/) \|\| ($obs));
	if ($dirptr&$testdir) {
	my $newpath;
	if ($relpath) {
	$newpath = "$relpath/$item";
	} else {
	$relpath = '/';
	$newpath = $item;
	}
	$dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;
	&recursedirs($is_home,$context,$docroot,$toppath,$newpath,$dirhashref,$filehashref);
	} elsif ($savefile) {
	if ($context eq 'priv') {
	unless ($item =~ /\.(meta\|save\|log\|bak\|DS_Store)$/) {
	$filehashref->{$relpath}{$item} = 1;
	}
	} else {
	unless (($item =~ /\.meta$/) \|\| ($item =~ /\.\d+\.\w+$/)) {
	$filehashref->{$relpath}{$item} = 1;
	}
	}
	}
	}
	}
	}
	return;
	}

# -------------------------------------------------------- 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 10418 sub resdata {	Line 11226 sub resdata {
return undef;	return undef;
}	}

sub get_domain_ltitools {	sub get_domain_lti {
my ($cdom) = @_;	my ($cdom,$context) = @_;
my %ltitools;	my ($name,%lti);
my ($result,$cached)=&is_cached_new('ltitools',$cdom);	if ($context eq 'consumer') {
	$name = 'ltitools';
	} elsif ($context eq 'provider') {
	$name = 'lti';
	} else {
	return %lti;
	}
	my ($result,$cached)=&is_cached_new($name,$cdom);
if (defined($cached)) {	if (defined($cached)) {
if (ref($result) eq 'HASH') {	if (ref($result) eq 'HASH') {
%ltitools = %{$result};	%lti = %{$result};
}	}
} else {	} else {
my %domconfig = &get_dom('configuration',['ltitools'],$cdom);	my %domconfig = &get_dom('configuration',[$name],$cdom);
if (ref($domconfig{'ltitools'}) eq 'HASH') {	if (ref($domconfig{$name}) eq 'HASH') {
%ltitools = %{$domconfig{'ltitools'}};	%lti = %{$domconfig{$name}};
	my %encdomconfig = &get_dom('encconfig',[$name],$cdom);
	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('ltitools',$cdom,\%ltitools,$cachetime);	&do_cache_new($name,$cdom,\%lti,$cachetime);
}	}
return %ltitools;	return %lti;
}	}

sub get_numsuppfiles {	sub get_numsuppfiles {
Line 10447 sub get_numsuppfiles {	Line 11272 sub get_numsuppfiles {
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 $errors) = (0,0);	($suppcount,my $supptools,my $errors) = (0,0,0);
my $suppmap = 'supplemental.sequence';	my $suppmap = 'supplemental.sequence';
($suppcount,$errors) =	($suppcount,$supptools,$errors) =
&Apache::loncommon::recurse_supplemental($cnum,$cdom,$suppmap,$suppcount,$errors);	&Apache::loncommon::recurse_supplemental($cnum,$cdom,$suppmap,$suppcount,
	$supptools,$errors);
}	}
&do_cache_new('suppcount',$hashid,$suppcount,600);	&do_cache_new('suppcount',$hashid,$suppcount,600);
}	}
Line 10740 sub EXT {	Line 11566 sub EXT {
} else {	} else {
$filename=$env{'request.filename'};	$filename=$env{'request.filename'};
}	}
my $metadata=&metadata($filename,$what);	my $toolsymb;
	if (($filename =~ /ext\.tool$/) && ($what ne '0_gradable')) {
	$toolsymb = $symbparm;
	}
	my $metadata=&metadata($filename,$what,$toolsymb);
if (defined($metadata)) { return &get_reply([$metadata,'resource']); }	if (defined($metadata)) { return &get_reply([$metadata,'resource']); }
$metadata=&metadata($filename,'parameter_'.$what);	$metadata=&metadata($filename,'parameter_'.$what,$toolsymb);
if (defined($metadata)) { return &get_reply([$metadata,'resource']); }	if (defined($metadata)) { return &get_reply([$metadata,'resource']); }

# ----------------------------------------------- fifth, look in rest of course	# ----------------------------------------------- fifth, look in rest of course
Line 10768 sub EXT {	Line 11598 sub EXT {
if (defined($partgeneral[0])) { return &get_reply(\@partgeneral); }	if (defined($partgeneral[0])) { return &get_reply(\@partgeneral); }
}	}
if ($recurse) { return undef; }	if ($recurse) { return undef; }
my $pack_def=&packages_tab_default($filename,$varname);	my $pack_def=&packages_tab_default($filename,$varname,$toolsymb);
if (defined($pack_def)) { return &get_reply([$pack_def,'resource']); }	if (defined($pack_def)) { return &get_reply([$pack_def,'resource']); }
# ---------------------------------------------------- Any other user namespace	# ---------------------------------------------------- Any other user namespace
} elsif ($realm eq 'environment') {	} elsif ($realm eq 'environment') {
Line 10862 sub sort_course_groups { # Sort groups b	Line 11692 sub sort_course_groups { # Sort groups b
}	}

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

my (@extension,@specifics,$do_default);	my (@extension,@specifics,$do_default);
foreach my $package (split(/,/,&metadata($uri,'packages'))) {	foreach my $package (split(/,/,&metadata($uri,'packages',$toolsymb))) {
my ($pack_type,$pack_part)=split(/_/,$package,2);	my ($pack_type,$pack_part)=split(/_/,$package,2);
if ($pack_type eq 'default') {	if ($pack_type eq 'default') {
$do_default=1;	$do_default=1;
Line 10933 sub add_prefix_and_part {	Line 11763 sub add_prefix_and_part {

my %metaentry;	my %metaentry;
my %importedpartids;	my %importedpartids;
	my %importedrespids;
sub metadata {	sub metadata {
my ($uri,$what,$liburi,$prefix,$depthcount)=@_;	my ($uri,$what,$toolsymb,$liburi,$prefix,$depthcount)=@_;
$uri=&declutter($uri);	$uri=&declutter($uri);
# if it is a non metadata possible uri return quickly	# if it is a non metadata possible uri return quickly
if (($uri eq '') \|\|	if (($uri eq '') \|\|
(($uri =~ m\|^/*adm/\|) &&	(($uri =~ m\|^/*adm/\|) &&
($uri !~ m\|^adm/includes\|) && ($uri !~ m{/(smppg\|bulletinboard\|exttools?)$})) \|\|	($uri !~ m\|^adm/includes\|) && ($uri !~ m{/(smppg\|bulletinboard\|ext\.tool)$})) \|\|
($uri =~ m\|/$\|) \|\| ($uri =~ m\|/.meta$\|) \|\| ($uri =~ m{^/*uploaded/.+\.sequence$})) {	($uri =~ m\|/$\|) \|\| ($uri =~ m\|/.meta$\|) \|\| ($uri =~ m{^/*uploaded/.+\.sequence$})) {
return undef;	return undef;
}	}
Line 10958 sub metadata {	Line 11789 sub metadata {
my ($result,$cached)=&is_cached_new('meta',$uri);	my ($result,$cached)=&is_cached_new('meta',$uri);
if (defined($cached)) { return $result->{':'.$what}; }	if (defined($cached)) { return $result->{':'.$what}; }
}	}

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

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

{	{
# Imported parts would go here	# Imported parts would go here
my %importedids=();	my @origfiletagids=();
my @origfileimportpartids=();
my $importedparts=0;	my $importedparts=0;

	# Imported responseids would go here
	my $importedresponses=0;
#	#
# Is this a recursive call for a library?	# Is this a recursive call for a library?
#	#
Line 11057 sub metadata {	Line 11949 sub metadata {
my $dir=$filename;	my $dir=$filename;
$dir=~s\|[^/]*$\|\|;	$dir=~s\|[^/]*$\|\|;
$location=&filelocation($dir,$location);	$location=&filelocation($dir,$location);

	my $importid=$token->[2]->{'id'};
my $importmode=$token->[2]->{'importmode'};	my $importmode=$token->[2]->{'importmode'};
if ($importmode eq 'problem') {	#
# Import as problem/response	# Check metadata for imported file to
$unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});	# see if it contained response items
} elsif ($importmode eq 'part') {	#
	my ($origfile,@libfilekeys);
	my %currmetaentry = %metaentry;
	@libfilekeys = split(/,/,&metadata($location,'keys',undef,undef,undef,
	$depthcount+1));
	if (grep(/^responseorder$/,@libfilekeys)) {
	my $libresponseorder = &metadata($location,'responseorder',undef,undef,
	undef,$depthcount+1);
	if ($libresponseorder ne '') {
	if ($#origfiletagids<0) {
	undef(%importedrespids);
	undef(%importedpartids);
	}
	my @respids = split(/\s,\s/,$libresponseorder);
	if (@respids) {
	$importedrespids{$importid} = join(',',map { $importid.'_'.$_ } @respids);
	}
	if ($importedrespids{$importid} ne '') {
	$importedresponses = 1;
	# We need to get the original file and the imported file to get the response order correct
	# Load and inspect original file
	if ($#origfiletagids<0) {
	my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);
	$origfile=&getfile($origfilelocation);
	@origfiletagids=($origfile=~/<((?:\w+)response\|import\|part)[^>]id\s=\s[\"\']([^\"\']+)[\"\'][^>]>/gs);
	}
	}
	}
	}
	# Do not overwrite contents of %metaentry hash for resource itself with
	# hash populated for imported library file
	%metaentry = %currmetaentry;
	undef(%currmetaentry);
	if ($importmode eq 'part') {
# Import as part(s)	# Import as part(s)
$importedparts=1;	$importedparts=1;
# We need to get the original file and the imported file to get the part order correct	# We need to get the original file and the imported file to get the part order correct
# Good news: we do not need to worry about nested libraries, since parts cannot be nested	# Good news: we do not need to worry about nested libraries, since parts cannot be nested
# Load and inspect original file	# Load and inspect original file if we didn't do that already
if ($#origfileimportpartids<0) {	if ($#origfiletagids<0) {
undef(%importedpartids);	undef(%importedrespids);
my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);	undef(%importedpartids);
my $origfile=&getfile($origfilelocation);	if ($origfile eq '') {
@origfileimportpartids=($origfile=~/<(part\|import)[^>]id\s=\s[\"\']([^\"\']+)[\"\'][^>]>/gs);	my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);
	$origfile=&getfile($origfilelocation);
	@origfiletagids=($origfile=~/<(part\|import)[^>]id\s=\s[\"\']([^\"\']+)[\"\'][^>]>/gs);
	}
	}
	my @impfilepartids;
	# If <partorder> tag is included in metadata for the imported file
	# get the parts in the imported file from that.
	if (grep(/^partorder$/,@libfilekeys)) {
	%currmetaentry = %metaentry;
	my $libpartorder = &metadata($location,'partorder',undef,undef,undef,
	$depthcount+1);
	%metaentry = %currmetaentry;
	undef(%currmetaentry);
	if ($libpartorder ne '') {
	@impfilepartids=split(/\s,\s/,$libpartorder);
	}
	} else {
	# If no <partorder> tag available, load and inspect imported file
	my $impfile=&getfile($location);
	@impfilepartids=($impfile=~/<part[^>]id\s=\s[\"\']([^\"\']+)[\"\'][^>]>/gs);
}	}

# Load and inspect imported file
my $impfile=&getfile($location);
my @impfilepartids=($impfile=~/<part[^>]id\s=\s[\"\']([^\"\']+)[\"\'][^>]>/gs);
if ($#impfilepartids>=0) {	if ($#impfilepartids>=0) {
# This problem had parts	# This problem had parts
$importedpartids{$token->[2]->{'id'}}=join(',',@impfilepartids);	$importedpartids{$token->[2]->{'id'}}=join(',',@impfilepartids);
Line 11088 sub metadata {	Line 12030 sub metadata {
$importedpartids{$token->[2]->{'id'}}=$token->[2]->{'id'};	$importedpartids{$token->[2]->{'id'}}=$token->[2]->{'id'};
}	}
} else {	} else {
	# Import as problem or as normal import
	$unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});
	unless ($importmode eq 'problem') {
# Normal import	# Normal import
$unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});	if (defined($token->[2]->{'id'})) {
if (defined($token->[2]->{'id'})) {	$unikey.='_'.$token->[2]->{'id'};
$unikey.='_'.$token->[2]->{'id'};	}
}	}
	# Check metadata for imported file to
	# see if it contained parts
	if (grep(/^partorder$/,@libfilekeys)) {
	%currmetaentry = %metaentry;
	my $libpartorder = &metadata($location,'partorder',undef,undef,undef,
	$depthcount+1);
	%metaentry = %currmetaentry;
	undef(%currmetaentry);
	if ($libpartorder ne '') {
	$importedparts = 1;
	$importedpartids{$token->[2]->{'id'}}=$libpartorder;
	}
	}
}	}

if ($depthcount<20) {	if ($depthcount<20) {
my $metadata =	my $metadata =
&metadata($uri,'keys', $location,$unikey,	&metadata($uri,'keys',$toolsymb,$location,$unikey,
$depthcount+1);	$depthcount+1);
foreach my $meta (split(',',$metadata)) {	foreach my $meta (split(',',$metadata)) {
$metaentry{':'.$meta}=$metaentry{':'.$meta};	$metaentry{':'.$meta}=$metaentry{':'.$meta};
$metathesekeys{$meta}=1;	$metathesekeys{$meta}=1;
}	}

}	}
} else {	} else {
#	#
Line 11172 sub metadata {	Line 12128 sub metadata {
$dir=~s\|[^/]*$\|\|;	$dir=~s\|[^/]*$\|\|;
$location=&filelocation($dir,$location);	$location=&filelocation($dir,$location);
my $rights_metadata =	my $rights_metadata =
&metadata($uri,'keys',$location,'_rights',	&metadata($uri,'keys',$toolsymb,$location,'_rights',
$depthcount+1);	$depthcount+1);
foreach my $rights (split(',',$rights_metadata)) {	foreach my $rights (split(',',$rights_metadata)) {
#$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights};	#$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights};
Line 11186 sub metadata {	Line 12142 sub metadata {
grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));	grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));
$metaentry{':packages'} = join(',',@uniq_packages);	$metaentry{':packages'} = join(',',@uniq_packages);

if ($importedparts) {	if (($importedresponses) \|\| ($importedparts)) {
	if ($importedparts) {
# We had imported parts and need to rebuild partorder	# We had imported parts and need to rebuild partorder
$metaentry{':partorder'}='';	$metaentry{':partorder'}='';
$metathesekeys{'partorder'}=1;	$metathesekeys{'partorder'}=1;
for (my $index=0;$index<$#origfileimportpartids;$index+=2) {	}
if ($origfileimportpartids[$index] eq 'part') {	if ($importedresponses) {
# original part, part of the problem	# We had imported responses and need to rebuil responseorder
$metaentry{':partorder'}.=','.$origfileimportpartids[$index+1];	$metaentry{':responseorder'}='';
} else {	$metathesekeys{'responseorder'}=1;
# we have imported parts at this position	}
$metaentry{':partorder'}.=','.$importedpartids{$origfileimportpartids[$index+1]};	for (my $index=0;$index<$#origfiletagids;$index+=2) {
}	my $origid = $origfiletagids[$index+1];
}	if ($origfiletagids[$index] eq 'part') {
$metaentry{':partorder'}=~s/^\,//;	# Original part, part of the problem
	if ($importedparts) {
	$metaentry{':partorder'}.=','.$origid;
	}
	} elsif ($origfiletagids[$index] eq 'import') {
	if ($importedparts) {
	# We have imported parts at this position
	if ($importedpartids{$origid} ne '') {
	$metaentry{':partorder'}.=','.$importedpartids{$origid};
	}
	}
	if ($importedresponses) {
	# We have imported responses at this position
	if ($importedrespids{$origid} ne '') {
	$metaentry{':responseorder'}.=','.$importedrespids{$origid};
	}
	}
	} else {
	# Original response item, part of the problem
	if ($importedresponses) {
	$metaentry{':responseorder'}.=','.$origid;
	}
	}
	}
	if ($importedparts) {
	$metaentry{':partorder'}=~s/^\,//;
	}
	if ($importedresponses) {
	$metaentry{':responseorder'}=~s/^\,//;
	}
}	}

$metaentry{':keys'} = join(',',keys(%metathesekeys));	$metaentry{':keys'} = join(',',keys(%metathesekeys));
&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);	&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
$metaentry{':allpossiblekeys'}=join(',',keys(%metathesekeys));	$metaentry{':allpossiblekeys'}=join(',',keys(%metathesekeys));
&do_cache_new('meta',$uri,\%metaentry,$cachetime);	unless ($liburi) {
	&do_cache_new('meta',$uri,\%metaentry,$cachetime);
	}
# this is the end of "was not already recently cached	# this is the end of "was not already recently cached
}	}
return $metaentry{':'.$what};	return $metaentry{':'.$what};
Line 12215 sub repcopy_userfile {	Line 13202 sub repcopy_userfile {
}	}
# now the path exists for sure	# now the path exists for sure
# get a user agent	# get a user agent
my $ua=new LWP::UserAgent;
my $transferfile=$file.'.in.transfer';	my $transferfile=$file.'.in.transfer';
# FIXME: this should flock	# FIXME: this should flock
if (-e $transferfile) { return 'ok'; }	if (-e $transferfile) { return 'ok'; }
Line 12225 sub repcopy_userfile {	Line 13211 sub repcopy_userfile {
my $protocol = $protocol{$homeserver};	my $protocol = $protocol{$homeserver};
$protocol = 'http' if ($protocol ne 'https');	$protocol = 'http' if ($protocol ne 'https');
$request=new HTTP::Request('GET',$protocol.'://'.&hostname($homeserver).'/raw/'.$uri);	$request=new HTTP::Request('GET',$protocol.'://'.&hostname($homeserver).'/raw/'.$uri);
my $response=$ua->request($request,$transferfile);	my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,$transferfile,\%perlvar,'',0,1);
# did it work?	# did it work?
if ($response->is_error()) {	if ($response->is_error()) {
unlink($transferfile);	unlink($transferfile);
Line 12269 sub getuploaded {	Line 13255 sub getuploaded {
my $protocol = $protocol{$homeserver};	my $protocol = $protocol{$homeserver};
$protocol = 'http' if ($protocol ne 'https');	$protocol = 'http' if ($protocol ne 'https');
$uri = $protocol.'://'.&hostname($homeserver).'/raw/'.$uri;	$uri = $protocol.'://'.&hostname($homeserver).'/raw/'.$uri;
my $ua=new LWP::UserAgent;
my $request=new HTTP::Request($reqtype,$uri);	my $request=new HTTP::Request($reqtype,$uri);
my $response=$ua->request($request);	my $response=&LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,'',0,1);
$$rtncode = $response->code;	$$rtncode = $response->code;
if (! $response->is_success()) {	if (! $response->is_success()) {
return 'failed';	return 'failed';
Line 12288 sub readfile {	Line 13273 sub readfile {
my $file = shift;	my $file = shift;
if ( (! -e $file ) \|\| ($file eq '') ) { return -1; };	if ( (! -e $file ) \|\| ($file eq '') ) { return -1; };
my $fh;	my $fh;
open($fh,"<$file");	open($fh,"<",$file);
my $a='';	my $a='';
while (my $line = <$fh>) { $a .= $line; }	while (my $line = <$fh>) { $a .= $line; }
return $a;	return $a;
Line 12401 sub machine_ids {	Line 13386 sub machine_ids {

sub additional_machine_domains {	sub additional_machine_domains {
my @domains;	my @domains;
open(my $fh,"<$perlvar{'lonTabDir'}/expected_domains.tab");	open(my $fh,"<","$perlvar{'lonTabDir'}/expected_domains.tab");
while( my $line = <$fh>) {	while( my $line = <$fh>) {
$line =~ s/\s//g;	$line =~ s/\s//g;
push(@domains,$line);	push(@domains,$line);
Line 12472 sub clutter {	Line 13457 sub clutter {
# &logthis("Got a blank emb style");	# &logthis("Got a blank emb style");
}	}
}	}
} elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/exttools?$}) {	} elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/ext\.tool$}) {
$thisfn='/adm/wrapper'.$thisfn;	$thisfn='/adm/wrapper'.$thisfn;
}	}
return $thisfn;	return $thisfn;
Line 12547 sub get_dns {	Line 13532 sub get_dns {
}	}

my %alldns;	my %alldns;
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");	if (open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab")) {
foreach my $dns (<$config>) {	foreach my $dns (<$config>) {
next if ($dns !~ /^\^(\S*)/x);	next if ($dns !~ /^\^(\S*)/x);
my $line = $1;	my $line = $1;
my ($host,$protocol) = split(/:/,$line);	my ($host,$protocol) = split(/:/,$line);
if ($protocol ne 'https') {	if ($protocol ne 'https') {
$protocol = 'http';	$protocol = 'http';
	}
	$alldns{$host} = $protocol;
}	}
$alldns{$host} = $protocol;	close($config);
}	}
while (%alldns) {	while (%alldns) {
my ($dns) = sort { $b cmp $a } keys(%alldns);	my ($dns) = sort { $b cmp $a } keys(%alldns);
my $ua=new LWP::UserAgent;
$ua->timeout(30);
my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");	my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
my $response=$ua->request($request);	my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar,30,0);
delete($alldns{$dns});	delete($alldns{$dns});
next if ($response->is_error());	next if ($response->is_error());
my @content = split("\n",$response->content);	if ($url eq '/adm/dns/loncapaCRL') {
unless ($nocache) {	return &$func($response);
&do_cache_new('dns',$url,\@content,302460*60);	} else {
}	my @content = split("\n",$response->content);
&$func(\@content,$hashref);	unless ($nocache) {
return;	&do_cache_new('dns',$url,\@content,302460*60);
	}
	&$func(\@content,$hashref);
	return;
	}
	}
	my $which = (split('/',$url,4))[3];
	if ($which eq 'loncapaCRL') {
	my $diskfile = "$perlvar{'lonCertificateDirectory'}/$perlvar{'lonnetCertRevocationList'}";
	if (-e $diskfile) {
	&logthis("unable to contact DNS, on disk file $diskfile not updated");
	} else {
	&logthis("unable to contact DNS, no on disk file $diskfile available");
	}
	} else {
	&logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n");
	if (open(my $config,"<","$perlvar{'lonTabDir'}/dns_$which.tab")) {
	my @content = <$config>;
	close($config);
	&$func(\@content,$hashref);
	}
}	}
close($config);
my $which = (split('/',$url))[3];
&logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n");
open($config,"<$perlvar{'lonTabDir'}/dns_$which.tab");
my @content = <$config>;
&$func(\@content,$hashref);
return;	return;
}	}

Line 12637 sub fetch_dns_checksums {	Line 13636 sub fetch_dns_checksums {
return \%checksums;	return \%checksums;
}	}

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

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

# ------------------------------------------------------------ Read domain file	# ------------------------------------------------------------ Read domain file
{	{
my $loaded;	my $loaded;
Line 12668 sub fetch_dns_checksums {	Line 13740 sub fetch_dns_checksums {
my ($ignore_cache,$nocache) = @_;	my ($ignore_cache,$nocache) = @_;
&get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache,$nocache);	&get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache,$nocache);
my $fh;	my $fh;
if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) {	if (open($fh,"<",$perlvar{'lonTabDir'}.'/domain.tab')) {
my @lines = <$fh>;	my @lines = <$fh>;
&parse_domain_tab(\@lines);	&parse_domain_tab(\@lines);
}	}
Line 12720 sub fetch_dns_checksums {	Line 13792 sub fetch_dns_checksums {
my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline);	my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline);
$name=~s/\s//g;	$name=~s/\s//g;
if ($id && $domain && $role && $name) {	if ($id && $domain && $role && $name) {
	if ((exists($hostname{$id})) && ($hostname{$id} ne '')) {
	my $curr = $hostname{$id};
	my $skip;
	if (ref($name_to_host{$curr}) eq 'ARRAY') {
	if (($curr eq $name) && (@{$name_to_host{$curr}} == 1)) {
	$skip = 1;
	} else {
	@{$name_to_host{$curr}} = grep { $_ ne $id } @{$name_to_host{$curr}};
	}
	}
	unless ($skip) {
	push(@{$name_to_host{$name}},$id);
	}
	} else {
	push(@{$name_to_host{$name}},$id);
	}
$hostname{$id}=$name;	$hostname{$id}=$name;
push(@{$name_to_host{$name}}, $id);
$hostdom{$id}=$domain;	$hostdom{$id}=$domain;
if ($role eq 'library') { $libserv{$id}=$name; }	if ($role eq 'library') { $libserv{$id}=$name; }
if (defined($protocol)) {	if (defined($protocol)) {
Line 12744 sub fetch_dns_checksums {	Line 13831 sub fetch_dns_checksums {
&purge_remembered();	&purge_remembered();
&reset_domain_info();	&reset_domain_info();
&reset_hosts_ip_info();	&reset_hosts_ip_info();
	undef(%internetdom);
undef(%name_to_host);	undef(%name_to_host);
undef(%hostname);	undef(%hostname);
undef(%hostdom);	undef(%hostdom);
Line 12754 sub fetch_dns_checksums {	Line 13842 sub fetch_dns_checksums {
sub load_hosts_tab {	sub load_hosts_tab {
my ($ignore_cache,$nocache) = @_;	my ($ignore_cache,$nocache) = @_;
&get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache,$nocache);	&get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache,$nocache);
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");	open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab");
my @config = <$config>;	my @config = <$config>;
&parse_hosts_tab(\@config);	&parse_hosts_tab(\@config);
close($config);	close($config);
Line 12786 sub fetch_dns_checksums {	Line 13874 sub fetch_dns_checksums {
return %hostdom;	return %hostdom;
}	}

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

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

Line 13020 sub all_loncaparevs {	Line 14113 sub all_loncaparevs {
{	{
sub load_loncaparevs {	sub load_loncaparevs {
if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") {	if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") {
if (open(my $config,"<$perlvar{'lonTabDir'}/loncaparevs.tab")) {	if (open(my $config,"<","$perlvar{'lonTabDir'}/loncaparevs.tab")) {
while (my $configline=<$config>) {	while (my $configline=<$config>) {
chomp($configline);	chomp($configline);
my ($hostid,$loncaparev)=split(/:/,$configline);	my ($hostid,$loncaparev)=split(/:/,$configline);
Line 13036 sub all_loncaparevs {	Line 14129 sub all_loncaparevs {
{	{
sub load_serverhomeIDs {	sub load_serverhomeIDs {
if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") {	if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") {
if (open(my $config,"<$perlvar{'lonTabDir'}/serverhomeIDs.tab")) {	if (open(my $config,"<","$perlvar{'lonTabDir'}/serverhomeIDs.tab")) {
while (my $configline=<$config>) {	while (my $configline=<$config>) {
chomp($configline);	chomp($configline);
my ($name,$id)=split(/:/,$configline);	my ($name,$id)=split(/:/,$configline);
Line 13061 BEGIN {	Line 14154 BEGIN {

# ------------------------------------------------------ Read spare server file	# ------------------------------------------------------ Read spare server file
{	{
open(my $config,"<$perlvar{'lonTabDir'}/spare.tab");	open(my $config,"<","$perlvar{'lonTabDir'}/spare.tab");

while (my $configline=<$config>) {	while (my $configline=<$config>) {
chomp($configline);	chomp($configline);
Line 13075 BEGIN {	Line 14168 BEGIN {
}	}
# ------------------------------------------------------------ Read permissions	# ------------------------------------------------------------ Read permissions
{	{
open(my $config,"<$perlvar{'lonTabDir'}/roles.tab");	open(my $config,"<","$perlvar{'lonTabDir'}/roles.tab");

while (my $configline=<$config>) {	while (my $configline=<$config>) {
chomp($configline);	chomp($configline);
Line 13089 BEGIN {	Line 14182 BEGIN {

# -------------------------------------------- Read plain texts for permissions	# -------------------------------------------- Read plain texts for permissions
{	{
open(my $config,"<$perlvar{'lonTabDir'}/rolesplain.tab");	open(my $config,"<","$perlvar{'lonTabDir'}/rolesplain.tab");

while (my $configline=<$config>) {	while (my $configline=<$config>) {
chomp($configline);	chomp($configline);
Line 13109 BEGIN {	Line 14202 BEGIN {

# ---------------------------------------------------------- Read package table	# ---------------------------------------------------------- Read package table
{	{
open(my $config,"<$perlvar{'lonTabDir'}/packages.tab");	open(my $config,"<","$perlvar{'lonTabDir'}/packages.tab");

while (my $configline=<$config>) {	while (my $configline=<$config>) {
if ($configline !~ /\S/ \|\| $configline=~/^#/) { next; }	if ($configline !~ /\S/ \|\| $configline=~/^#/) { next; }
Line 13163 BEGIN {	Line 14256 BEGIN {
# ---------------------------------------------------------- Read managers table	# ---------------------------------------------------------- Read managers table
{	{
if (-e "$perlvar{'lonTabDir'}/managers.tab") {	if (-e "$perlvar{'lonTabDir'}/managers.tab") {
if (open(my $config,"<$perlvar{'lonTabDir'}/managers.tab")) {	if (open(my $config,"<","$perlvar{'lonTabDir'}/managers.tab")) {
while (my $configline=<$config>) {	while (my $configline=<$config>) {
chomp($configline);	chomp($configline);
next if ($configline =~ /^\#/);	next if ($configline =~ /^\#/);
Line 13539 in which case the null string is returne	Line 14632 in which case the null string is returne

=item *	=item *

definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom	definerole($rolename,$sysrole,$domrole,$courole,$uname,$udom) : define role;
role rolename set privileges in format of lonTabs/roles.tab for system, domain,	define a custom role rolename set privileges in format of lonTabs/roles.tab
and course level	for system, domain, and course level. $uname and $udom are optional (current
	user's username and domain will be used when either of $uname or $udom are absent.

=item *	=item *

Line 13745 Inputs:	Line 14839 Inputs:

=item $credits, number of credits student will earn from this class	=item $credits, number of credits student will earn from this class

	=item $instsec, institutional course section code for student

=back	=back


Line 13899 condval($condidx) : value of condition i	Line 14995 condval($condidx) : value of condition i

=item *	=item *

metadata($uri,$what,$liburi,$prefix,$depthcount) : request a	metadata($uri,$what,$toolsymb,$liburi,$prefix,$depthcount) : request a
resource's metadata, $what should be either a specific key, or either	resource's metadata, $what should be either a specific key, or either
'keys' (to get a list of possible keys) or 'packages' to get a list of	'keys' (to get a list of possible keys) or 'packages' to get a list of
packages that this resource currently uses, the last 3 arguments are only used internally for recursive metadata.	packages that this resource currently uses, the last 3 arguments are
	only used internally for recursive metadata.

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

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

=item *	=item *

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

Removed from v.1.1311
changed lines
	Added in v.1.1381