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.1324 and 1.1371

version 1.1324, 2016/09/21 05:15:40	version 1.1371, 2018/03/30 21:30:00
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 243 sub get_servercerts_info {	Line 243 sub get_servercerts_info {
if ($1 < 6) {	if ($1 < 6) {
$uselocal = 0;	$uselocal = 0;
}	}
	} elsif ($distro =~ /^(?:sles)(\d+)$/) {
	if ($1 < 12) {
	$uselocal = 0;
	}
}	}
}	}
if ($uselocal) {	if ($uselocal) {
Line 305 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 483 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 523 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 532 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 648 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'));
	my ($linkname,$pubname);
if ($name eq '') {	if ($name eq '') {
$name = 'lonID';	$name = 'lonID';
	$linkname = 'lonLinkID';
	$pubname = 'lonPubID';
}	}
my $lonid=$cookies{$name};	my $lonid=$cookies{$name};
	if (!$lonid) {
	if (($name eq 'lonID') && ($ENV{'SERVER_PORT'} != 443) && ($linkname)) {
	$lonid=$cookies{$linkname};
	}
	if (!$lonid) {
	if (($name eq 'lonID') && ($pubname)) {
	$lonid=$cookies{$pubname};
	}
	}
	}
return undef if (!$lonid);	return undef if (!$lonid);

my $handle=&LONCAPA::clean_handle($lonid->value);	my $handle=&LONCAPA::clean_handle($lonid->value);
Line 663 sub check_for_valid_session {	Line 678 sub check_for_valid_session {
} else {	} else {
$lonidsdir=$r->dir_config('lonIDsDir');	$lonidsdir=$r->dir_config('lonIDsDir');
}	}
return undef if (!-e "$lonidsdir/$handle.id");	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;
	}

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 683 sub check_for_valid_session {	Line 707 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'};
}	}

return $handle;	return $handle;
Line 1049 sub choose_server {	Line 1074 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 1321 sub get_lonbalancer_config {	Line 1346 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 1472 sub check_loadbalancing {	Line 1497 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 1581 sub internet_dom_servers {	Line 1608 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 1830 sub get_dom {	Line 1951 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 1874 sub put_dom {	Line 2000 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 1965 sub inst_directory_query {	Line 2095 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 2006 sub usersearch {	Line 2146 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 2245 sub get_domain_defaults {	Line 2393 sub get_domain_defaults {
'coursedefaults','usersessions',	'coursedefaults','usersessions',
'requestauthor','selfenrollment',	'requestauthor','selfenrollment',
'coursecategories','ssl','autoenroll',	'coursecategories','ssl','autoenroll',
'trust'],$domain);	'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 2254 sub get_domain_defaults {	Line 2402 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 2321 sub get_domain_defaults {	Line 2472 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 2375 sub get_domain_defaults {	Line 2529 sub get_domain_defaults {
if (ref($domconfig{'ssl'}{'replication'}) eq 'HASH') {	if (ref($domconfig{'ssl'}{'replication'}) eq 'HASH') {
$domdefaults{'replication'} = $domconfig{'ssl'}{'replication'};	$domdefaults{'replication'} = $domconfig{'ssl'}{'replication'};
}	}
if (ref($domconfig{'ssl'}{'connect'}) eq 'HASH') {	if (ref($domconfig{'ssl'}{'connto'}) eq 'HASH') {
$domdefaults{'connect'} = $domconfig{'ssl'}{'connect'};	$domdefaults{'connect'} = $domconfig{'ssl'}{'connto'};
	}
	if (ref($domconfig{'ssl'}{'connfrom'}) eq 'HASH') {
	$domdefaults{'connect'} = $domconfig{'ssl'}{'connfrom'};
}	}
}	}
if (ref($domconfig{'trust'}) eq 'HASH') {	if (ref($domconfig{'trust'}) eq 'HASH') {
Line 2390 sub get_domain_defaults {	Line 2547 sub get_domain_defaults {
if (ref($domconfig{'autoenroll'}) eq 'HASH') {	if (ref($domconfig{'autoenroll'}) eq 'HASH') {
$domdefaults{'autofailsafe'} = $domconfig{'autoenroll'}{'autofailsafe'};	$domdefaults{'autofailsafe'} = $domconfig{'autoenroll'}{'autofailsafe'};
}	}
	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 2917 sub repcopy {	Line 3080 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 2929 sub repcopy {	Line 3096 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 2992 sub absolute_url {	Line 3164 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 3010 sub ssi {	Line 3181 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 3033 sub externalssi {	Line 3202 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 3171 sub can_edit_resource {	Line 3405 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 3203 sub can_edit_resource {	Line 3437 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 3221 sub can_edit_resource {	Line 3455 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 3382 sub process_coursefile {	Line 3616 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 3440 sub store_edited_file {	Line 3674 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 3556 sub userfileupload {	Line 3790 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 3591 sub userfileupload {	Line 3825 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 3666 sub finishuserfileupload {	Line 3900 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 3724 sub finishuserfileupload {	Line 3958 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 4108 sub flushcourselogs {	Line 4343 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 4255 sub userrolelog {	Line 4490 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 4482 sub get_my_roles {	Line 4717 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 4495 sub postannounce {	Line 4919 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 4722 sub get_domain_roles {	Line 5146 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 4790 sub set_first_access {	Line 5229 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 5576 sub rolesinit {	Line 6018 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 5614 sub custom_roleprivs {	Line 6057 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 5622 sub custom_roleprivs {	Line 6069 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 5656 sub set_userprivs {	Line 6145 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 5703 sub set_userprivs {	Line 6193 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 5711 sub set_userprivs {	Line 6202 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 5756 sub role_status {	Line 6247 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 5834 sub delete_env_groupprivs {	Line 6326 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 6016 sub currentdump {	Line 6525 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 6250 sub tmpget {	Line 6759 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 6635 sub usertools_access {	Line 7146 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 6831 sub is_advanced_user {	Line 7343 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 6866 sub check_can_request {	Line 7382 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 6948 sub allowed {	Line 7464 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 6996 sub allowed {	Line 7512 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 7436 sub constructaccess {	Line 7955 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 7784 sub get_symb_from_alias {	Line 8303 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 7812 sub definerole {	Line 8331 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 7949 sub fetch_enrollment_query {	Line 8476 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 7978 sub get_query_reply {	Line 8505 sub get_query_reply {
for (1..$loopmax) {	for (1..$loopmax) {
sleep($sleep);	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 8370 sub auto_validate_class_sec {	Line 8897 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 8749 sub assignrole {	Line 9303 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'})) {
	$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 8865 sub assignrole {	Line 9423 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 9015 sub modifyuser {	Line 9574 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 9604 sub save_selected_files {	Line 10167 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 9618 sub save_selected_files {	Line 10181 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 9628 sub files_in_path {	Line 10191 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 9650 sub files_not_in_path {	Line 10213 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 10635 sub resdata {	Line 11198 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 10664 sub get_numsuppfiles {	Line 11244 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 10957 sub EXT {	Line 11538 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 10985 sub EXT {	Line 11570 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 11079 sub sort_course_groups { # Sort groups b	Line 11664 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 11150 sub add_prefix_and_part {	Line 11735 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 11175 sub metadata {	Line 11761 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 11274 sub metadata {	Line 11921 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'};
	#
	# Check metadata for imported file to
	# see if it contained response items
	#
	my %currmetaentry = %metaentry;
	my $libresponseorder = &metadata($location,'responseorder');
	my $origfile;
	if ($libresponseorder ne '') {
	if ($#origfiletagids<0) {
	undef(%importedrespids);
	undef(%importedpartids);
	}
	@{$importedrespids{$importid}} = split(/\s,\s/,$libresponseorder);
	if (@{$importedrespids{$importid}} > 0) {
	$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 'problem') {	if ($importmode eq 'problem') {
# Import as problem/response	# Import as problem/response
$unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});	$unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});
Line 11284 sub metadata {	Line 11960 sub metadata {
$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);
	}
}	}

# Load and inspect imported file	# Load and inspect imported file
Line 11314 sub metadata {	Line 11993 sub metadata {

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 11389 sub metadata {	Line 12067 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 11403 sub metadata {	Line 12081 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
	$metaentry{':partorder'}.=','.$importedpartids{$origid};
	}
	if ($importedresponses) {
	# We have imported responses at this position
	if (ref($importedrespids{$origid}) eq 'ARRAY') {
	$metaentry{':responseorder'}.=','.join(',',map { $origid.'_'.$_ } @{$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 12432 sub repcopy_userfile {	Line 13140 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 12442 sub repcopy_userfile {	Line 13149 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 12486 sub getuploaded {	Line 13193 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 12505 sub readfile {	Line 13211 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 12618 sub machine_ids {	Line 13324 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 12689 sub clutter {	Line 13395 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 12764 sub get_dns {	Line 13470 sub get_dns {
}	}

my %alldns;	my %alldns;
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");	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;
Line 12776 sub get_dns {	Line 13482 sub get_dns {
}	}
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);	my @content = split("\n",$response->content);
Line 12792 sub get_dns {	Line 13496 sub get_dns {
close($config);	close($config);
my $which = (split('/',$url))[3];	my $which = (split('/',$url))[3];
&logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n");	&logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n");
open($config,"<$perlvar{'lonTabDir'}/dns_$which.tab");	open($config,"<","$perlvar{'lonTabDir'}/dns_$which.tab");
my @content = <$config>;	my @content = <$config>;
&$func(\@content,$hashref);	&$func(\@content,$hashref);
return;	return;
Line 12885 sub fetch_dns_checksums {	Line 13589 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 12937 sub fetch_dns_checksums {	Line 13641 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 12961 sub fetch_dns_checksums {	Line 13680 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 12971 sub fetch_dns_checksums {	Line 13691 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 13003 sub fetch_dns_checksums {	Line 13723 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 13237 sub all_loncaparevs {	Line 13962 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 13253 sub all_loncaparevs {	Line 13978 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 13278 BEGIN {	Line 14003 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 13292 BEGIN {	Line 14017 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 13306 BEGIN {	Line 14031 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 13326 BEGIN {	Line 14051 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 13380 BEGIN {	Line 14105 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 13756 in which case the null string is returne	Line 14481 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 14118 condval($condidx) : value of condition i	Line 14844 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.1324
changed lines
	Added in v.1.1371