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.1366 and 1.1397

version 1.1366, 2018/01/03 04:21:02	version 1.1397, 2018/12/27 18:14:50
Line 73 package Apache::lonnet;	Line 73 package Apache::lonnet;
use strict;	use strict;
use HTTP::Date;	use HTTP::Date;
use Image::Magick;	use Image::Magick;
	use CGI::Cookie;

use Encode;	use Encode;

Line 230 sub get_server_distarch {	Line 230 sub get_server_distarch {
}	}

sub get_servercerts_info {	sub get_servercerts_info {
my ($lonhost,$context) = @_;	my ($lonhost,$hostname,$context) = @_;
	return if ($lonhost eq '');
	if ($hostname eq '') {
	$hostname = &hostname($lonhost);
	}
	return if ($hostname eq '');
my ($rep,$uselocal);	my ($rep,$uselocal);
if (grep { $_ eq $lonhost } &current_machine_ids()) {	if ($context eq 'install') {
	$uselocal = 1;
	} elsif (grep { $_ eq $lonhost } &current_machine_ids()) {
$uselocal = 1;	$uselocal = 1;
}	}
if (($context ne 'cgi') && ($uselocal)) {	if (($context ne 'cgi') && ($context ne 'install') && ($uselocal)) {
my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0];	my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0];
if ($distro eq '') {	if ($distro eq '') {
$uselocal = 0;	$uselocal = 0;
Line 250 sub get_servercerts_info {	Line 257 sub get_servercerts_info {
}	}
}	}
if ($uselocal) {	if ($uselocal) {
$rep = LONCAPA::Lond::server_certs(\%perlvar);	$rep = LONCAPA::Lond::server_certs(\%perlvar,$lonhost,$hostname);
} else {	} else {
$rep=&reply('servercerts',$lonhost);	$rep=&reply('servercerts',$lonhost);
}	}
my ($result,%returnhash);	my ($result,%returnhash);
if (defined($lonhost)) {
if (!defined(&hostname($lonhost))) {
return;
}
}
if (($rep=~/^(refused\|rejected\|error)/) \|\| ($rep eq 'con_lost') \|\|	if (($rep=~/^(refused\|rejected\|error)/) \|\| ($rep eq 'con_lost') \|\|
($rep eq 'unknown_cmd')) {	($rep eq 'unknown_cmd')) {
$result = $rep;	$result = $rep;
Line 309 sub get_server_loncaparev {	Line 311 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 $hostname = &hostname($lonhost);
my $protocol = $protocol{$lonhost};	my $protocol = $protocol{$lonhost};
$protocol = 'http' if ($protocol ne 'https');	$protocol = 'http' if ($protocol ne 'https');
my $url = $protocol.'://'.&hostname($lonhost).'/adm/about.html';	my $url = $protocol.'://'.$hostname.'/adm/about.html';
my $request=new HTTP::Request('GET',$url);	my $request=new HTTP::Request('GET',$url);
my $response=&LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,4,1);	my $response=&LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,4,1);
unless ($response->is_error()) {	unless ($response->is_error()) {
Line 456 sub reply {	Line 459 sub reply {
unless (defined(&hostname($server))) { return 'no_such_host'; }	unless (defined(&hostname($server))) { return 'no_such_host'; }
my $answer=subreply($cmd,$server);	my $answer=subreply($cmd,$server);
if (($answer=~/^refused/) \|\| ($answer=~/^rejected/)) {	if (($answer=~/^refused/) \|\| ($answer=~/^rejected/)) {
&logthis("<font color=\"blue\">WARNING:".	my $logged = $cmd;
" $cmd to $server returned $answer</font>");	if ($cmd =~ /^encrypt:([^:]+):/) {
	my $subcmd = $1;
	if (($subcmd eq 'auth') \|\| ($subcmd eq 'passwd') \|\|
	($subcmd eq 'changeuserauth') \|\| ($subcmd eq 'makeuser') \|\|
	($subcmd eq 'putdom') \|\| ($subcmd eq 'autoexportgrades')) {
	(undef,undef,my @rest) = split(/:/,$cmd);
	if (($subcmd eq 'auth') \|\| ($subcmd eq 'putdom')) {
	splice(@rest,2,1,'Hidden');
	} elsif ($subcmd eq 'passwd') {
	splice(@rest,2,2,('Hidden','Hidden'));
	} elsif (($subcmd eq 'changeuserauth') \|\| ($subcmd eq 'makeuser') \|\|
	($subcmd eq 'autoexportgrades')) {
	splice(@rest,3,1,'Hidden');
	}
	$logged = join(':',('encrypt:'.$subcmd,@rest));
	}
	}
	&logthis("<font color=\"blue\">WARNING:".
	" $logged to $server returned $answer</font>");
}	}
return $answer;	return $answer;
}	}
Line 652 sub transfer_profile_to_env {	Line 673 sub transfer_profile_to_env {
sub check_for_valid_session {	sub check_for_valid_session {
my ($r,$name,$userhashref,$domref) = @_;	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);	my ($lonidsdir,$linkname,$pubname,$secure,$lonid);
if ($name eq '') {	if ($name eq 'lonDAV') {
$name = 'lonID';	$lonidsdir=$r->dir_config('lonDAVsessDir');
	} else {
	$lonidsdir=$r->dir_config('lonIDsDir');
	if ($name eq '') {
	$name = 'lonID';
	}
	}
	if ($name eq 'lonID') {
	$secure = 'lonSID';
$linkname = 'lonLinkID';	$linkname = 'lonLinkID';
$pubname = 'lonPubID';	$pubname = 'lonPubID';
}	if (exists($cookies{$secure})) {
my $lonid=$cookies{$name};	$lonid=$cookies{$secure};
if (!$lonid) {	} elsif (exists($cookies{$name})) {
if (($name eq 'lonID') && ($ENV{'SERVER_PORT'} != 443) && ($linkname)) {	$lonid=$cookies{$name};
	} elsif (exists($cookies{$linkname})) {
$lonid=$cookies{$linkname};	$lonid=$cookies{$linkname};
	} elsif (exists($cookies{$pubname})) {
	$lonid=$cookies{$pubname};
}	}
if (!$lonid) {	} else {
if (($name eq 'lonID') && ($pubname)) {	$lonid=$cookies{$name};
$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);
my $lonidsdir;	if (-l "$lonidsdir/$handle.id") {
if ($name eq 'lonDAV') {	my $link = readlink("$lonidsdir/$handle.id");
$lonidsdir=$r->dir_config('lonDAVsessDir');	if ((-e $link) && ($link =~ m{^\Q$lonidsdir\E/(.+)\.id$})) {
} else {	$handle = $1;
$lonidsdir=$r->dir_config('lonIDsDir');	}
}	}
if (!-e "$lonidsdir/$handle.id") {	if (!-e "$lonidsdir/$handle.id") {
if ((ref($domref)) && ($name eq 'lonID') &&	if ((ref($domref)) && ($name eq 'lonID') &&
Line 701 sub check_for_valid_session {	Line 730 sub check_for_valid_session {

if (!defined($disk_env{'user.name'})	if (!defined($disk_env{'user.name'})
\|\| !defined($disk_env{'user.domain'})) {	\|\| !defined($disk_env{'user.domain'})) {
	untie(%disk_env);
return undef;	return undef;
}	}

Line 708 sub check_for_valid_session {	Line 738 sub check_for_valid_session {
$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'};	$userhashref->{'lti'} = $disk_env{'request.lti.login'};
	if ($userhashref->{'lti'}) {
	$userhashref->{'ltitarget'} = $disk_env{'request.lti.target'};
	$userhashref->{'ltiuri'} = $disk_env{'request.lti.uri'};
	}
}	}
	untie(%disk_env);

return $handle;	return $handle;
}	}
Line 733 sub timed_flock {	Line 768 sub timed_flock {
}	}
}	}

	sub get_sessionfile_vars {
	my ($handle,$lonidsdir,$storearr) = @_;
	my %returnhash;
	unless (ref($storearr) eq 'ARRAY') {
	return %returnhash;
	}
	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") &&
	($handle =~ /^($match_username)\_\d+\_($match_domain)\_(.+)$/)) {
	my ($possuname,$possudom,$possuhome) = ($1,$2,$3);
	if ((&domain($possudom) ne '') && (&homeserver($possuname,$possudom) eq $possuhome)) {
	if (open(my $idf,'+<',"$lonidsdir/$handle.id")) {
	flock($idf,LOCK_SH);
	if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",
	&GDBM_READER(),0640)) {
	foreach my $item (@{$storearr}) {
	$returnhash{$item} = $disk_env{$item};
	}
	untie(%disk_env);
	}
	}
	}
	}
	return %returnhash;
	}

# ---------------------------------------------------------- Append Environment	# ---------------------------------------------------------- Append Environment

sub appenv {	sub appenv {
Line 758 sub appenv {	Line 824 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 883 sub userload {	Line 952 sub userload {
while ($filename=readdir(LONIDS)) {	while ($filename=readdir(LONIDS)) {
next if ($filename eq '.' \|\| $filename eq '..');	next if ($filename eq '.' \|\| $filename eq '..');
next if ($filename =~ /publicuser_\d+\.id/);	next if ($filename =~ /publicuser_\d+\.id/);
	next if ($filename =~ /^[a-f0-9]+_linked\.id$/);
my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];	my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
if ($curtime-$mtime < 1800) { $numusers++; }	if ($curtime-$mtime < 1800) { $numusers++; }
}	}
Line 938 sub spareserver {	Line 1008 sub spareserver {
}	}

if (!$want_server_name) {	if (!$want_server_name) {
my $protocol = 'http';
if ($protocol{$spare_server} eq 'https') {
$protocol = $protocol{$spare_server};
}
if (defined($spare_server)) {	if (defined($spare_server)) {
my $hostname = &hostname($spare_server);	my $hostname = &hostname($spare_server);
if (defined($hostname)) {	if (defined($hostname)) {
	my $protocol = 'http';
	if ($protocol{$spare_server} eq 'https') {
	$protocol = $protocol{$spare_server};
	}
$spare_server = $protocol.'://'.$hostname;	$spare_server = $protocol.'://'.$hostname;
}	}
}	}
Line 1011 sub find_existing_session {	Line 1081 sub find_existing_session {
return;	return;
}	}

	# check if user's browser sent load balancer cookie and server still has session
	# and is not overloaded.
	sub check_for_balancer_cookie {
	my ($r,$update_mtime) = @_;
	my ($otherserver,$cookie);
	my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
	if (exists($cookies{'balanceID'})) {
	my $balid = $cookies{'balanceID'};
	$cookie=&LONCAPA::clean_handle($balid->value);
	my $balancedir=$r->dir_config('lonBalanceDir');
	if ((-d $balancedir) && (-e "$balancedir/$cookie.id")) {
	if ($cookie =~ /^($match_domain)_($match_username)_[a-f0-9]+$/) {
	my ($possudom,$possuname) = ($1,$2);
	my $has_session = 0;
	if ((&domain($possudom) ne '') &&
	(&homeserver($possuname,$possudom) ne 'no_host')) {
	my $try_server;
	my $opened = open(my $idf,'+<',"$balancedir/$cookie.id");
	if ($opened) {
	flock($idf,LOCK_SH);
	while (my $line = <$idf>) {
	chomp($line);
	if (&hostname($line) ne '') {
	$try_server = $line;
	last;
	}
	}
	close($idf);
	if (($try_server) &&
	(&has_user_session($try_server,$possudom,$possuname))) {
	my $lowest_load = 30000;
	($otherserver,$lowest_load) =
	&compare_server_load($try_server,undef,$lowest_load);
	if ($otherserver ne '' && $lowest_load < 100) {
	$has_session = 1;
	} else {
	undef($otherserver);
	}
	}
	}
	}
	if ($has_session) {
	if ($update_mtime) {
	my $atime = my $mtime = time;
	utime($atime,$mtime,"$balancedir/$cookie.id");
	}
	} else {
	unlink("$balancedir/$cookie.id");
	}
	}
	}
	}
	return ($otherserver,$cookie);
	}

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

# -------------------------------- ask if server already has a session for user	# -------------------------------- ask if server already has a session for user
sub has_user_session {	sub has_user_session {
my ($lonid,$udom,$uname) = @_;	my ($lonid,$udom,$uname) = @_;
Line 1046 sub choose_server {	Line 1185 sub choose_server {
if (ref($balancers) eq 'HASH') {	if (ref($balancers) eq 'HASH') {
next if (exists($balancers->{$lonhost}));	next if (exists($balancers->{$lonhost}));
}	}
}	}
my $loginvia;	my $loginvia;
if ($checkloginvia) {	if ($checkloginvia) {
$loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};	$loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};
Line 1348 sub get_lonbalancer_config {	Line 1487 sub get_lonbalancer_config {
sub check_loadbalancing {	sub check_loadbalancing {
my ($uname,$udom,$caller) = @_;	my ($uname,$udom,$caller) = @_;
my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom,	my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom,
$rule_in_effect,$offloadto,$otherserver);	$rule_in_effect,$offloadto,$otherserver,$setcookie,$dom_balancers);
my $lonhost = $perlvar{'lonHostID'};	my $lonhost = $perlvar{'lonHostID'};
my @hosts = &current_machine_ids();	my @hosts = &current_machine_ids();
my $uprimary_id = &Apache::lonnet::domain($udom,'primary');	my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
Line 1375 sub check_loadbalancing {	Line 1514 sub check_loadbalancing {
}	}
}	}
if (ref($result) eq 'HASH') {	if (ref($result) eq 'HASH') {
($is_balancer,$currtargets,$currrules) =	($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers) =
&check_balancer_result($result,@hosts);	&check_balancer_result($result,@hosts);
if ($is_balancer) {	if ($is_balancer) {
if (ref($currrules) eq 'HASH') {	if (ref($currrules) eq 'HASH') {
Line 1436 sub check_loadbalancing {	Line 1575 sub check_loadbalancing {
}	}
}	}
if (ref($result) eq 'HASH') {	if (ref($result) eq 'HASH') {
($is_balancer,$currtargets,$currrules) =	($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers) =
&check_balancer_result($result,@hosts);	&check_balancer_result($result,@hosts);
if ($is_balancer) {	if ($is_balancer) {
if (ref($currrules) eq 'HASH') {	if (ref($currrules) eq 'HASH') {
Line 1502 sub check_loadbalancing {	Line 1641 sub check_loadbalancing {
$is_balancer = 0;	$is_balancer = 0;
if ($uname ne '' && $udom ne '') {	if ($uname ne '' && $udom ne '') {
if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {	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});
}	}
}	}
}	}
}	}
	unless ($homeintdom) {
	undef($setcookie);
	}
}	}
return ($is_balancer,$otherserver);	return ($is_balancer,$otherserver,$setcookie,$offloadto,$dom_balancers);
}	}

sub check_balancer_result {	sub check_balancer_result {
my ($result,@hosts) = @_;	my ($result,@hosts) = @_;
my ($is_balancer,$currtargets,$currrules);	my ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers);
if (ref($result) eq 'HASH') {	if (ref($result) eq 'HASH') {
if ($result->{'lonhost'} ne '') {	if ($result->{'lonhost'} ne '') {
my $currbalancer = $result->{'lonhost'};	my $currbalancer = $result->{'lonhost'};
Line 1524 sub check_balancer_result {	Line 1665 sub check_balancer_result {
$currtargets = $result->{'targets'};	$currtargets = $result->{'targets'};
$currrules = $result->{'rules'};	$currrules = $result->{'rules'};
}	}
	$dom_balancers = $currbalancer;
} else {	} else {
foreach my $key (keys(%{$result})) {	if (keys(%{$result})) {
if (($key ne '') && (grep(/^\Q$key\E$/,@hosts)) &&	foreach my $key (keys(%{$result})) {
(ref($result->{$key}) eq 'HASH')) {	if (($key ne '') && (grep(/^\Q$key\E$/,@hosts)) &&
$is_balancer = 1;	(ref($result->{$key}) eq 'HASH')) {
$currrules = $result->{$key}{'rules'};	$is_balancer = 1;
$currtargets = $result->{$key}{'targets'};	$currrules = $result->{$key}{'rules'};
last;	$currtargets = $result->{$key}{'targets'};
	$setcookie = $result->{$key}{'cookie'};
	last;
	}
}	}
	$dom_balancers = join(',',sort(keys(%{$result})));
}	}
}	}
}	}
return ($is_balancer,$currtargets,$currrules);	return ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers);
}	}

sub get_loadbalancer_targets {	sub get_loadbalancer_targets {
Line 1614 sub trusted_domains {	Line 1760 sub trusted_domains {
if (&domain($calldom) eq '') {	if (&domain($calldom) eq '') {
return ($trusted,$untrusted);	return ($trusted,$untrusted);
}	}
unless ($cmdtype =~ /^(content\|shared\|enroll\|coaurem\|domroles\|catalog\|reqcrs\|msg)$/) {	unless ($cmdtype =~ /^(content\|shared\|enroll\|coaurem\|othcoau\|domroles\|catalog\|reqcrs\|msg)$/) {
return ($trusted,$untrusted);	return ($trusted,$untrusted);
}	}
my $callprimary = &domain($calldom,'primary');	my $callprimary = &domain($calldom,'primary');
Line 1636 sub trusted_domains {	Line 1782 sub trusted_domains {
map { $possexc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'exc'}};	map { $possexc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'exc'}};
}	}
if (ref($trustconfig->{$cmdtype}->{'inc'}) eq 'ARRAY') {	if (ref($trustconfig->{$cmdtype}->{'inc'}) eq 'ARRAY') {
	$possinc{$intcalldom} = 1;
map { $possinc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'inc'}};	map { $possinc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'inc'}};
}	}
}	}
Line 1670 sub trusted_domains {	Line 1817 sub trusted_domains {
}	}
foreach my $exc (@allexc) {	foreach my $exc (@allexc) {
if (ref($doms_by_intdom{$exc}) eq 'ARRAY') {	if (ref($doms_by_intdom{$exc}) eq 'ARRAY') {
$untrusted = $doms_by_intdom{$exc};	push(@{$untrusted},@{$doms_by_intdom{$exc}});
}	}
}	}
foreach my $inc (@allinc) {	foreach my $inc (@allinc) {
if (ref($doms_by_intdom{$inc}) eq 'ARRAY') {	if (ref($doms_by_intdom{$inc}) eq 'ARRAY') {
$trusted = $doms_by_intdom{$inc};	push(@{$trusted},@{$doms_by_intdom{$inc}});
}	}
}	}
}	}
Line 3182 sub ssi {	Line 3329 sub ssi {

$request->header(Cookie => $ENV{'HTTP_COOKIE'});	$request->header(Cookie => $ENV{'HTTP_COOKIE'});
my $lonhost = $perlvar{'lonHostID'};	my $lonhost = $perlvar{'lonHostID'};
my $response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar);	my $islocal;
	if (($env{'request.course.id'}) &&
	($form{'grade_courseid'} eq $env{'request.course.id'}) &&
	($form{'grade_username'} ne '') && ($form{'grade_domain'} ne '') &&
	($form{'grade_symb'} ne '') &&
	(&Apache::lonnet::allowed('mgr',$env{'request.course.id'}.
	($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:'')))) {
	$islocal = 1;
	}
	my $response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,
	'','','',$islocal);

if (wantarray) {	if (wantarray) {
return ($response->content, $response);	return ($response->content, $response);
Line 3220 sub remove_stale_resfile {	Line 3377 sub remove_stale_resfile {
(grep { $_ eq $homeserver } &current_machine_ids())) {	(grep { $_ eq $homeserver } &current_machine_ids())) {
my $fname = &filelocation('',$url);	my $fname = &filelocation('',$url);
if (-e $fname) {	if (-e $fname) {
my $protocol = $protocol{$homeserver};
$protocol = 'http' if ($protocol ne 'https');
my $hostname = &hostname($homeserver);	my $hostname = &hostname($homeserver);
if ($hostname) {	if ($hostname) {
	my $protocol = $protocol{$homeserver};
	$protocol = 'http' if ($protocol ne 'https');
my $uri = &declutter($url);	my $uri = &declutter($url);
my $request=new HTTP::Request('HEAD',$protocol.'://'.$hostname.'/raw/'.$uri);	my $request=new HTTP::Request('HEAD',$protocol.'://'.$hostname.'/raw/'.$uri);
my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,5,0,1);	my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,5,0,1);
Line 5216 sub set_first_access {	Line 5373 sub set_first_access {
}	}
$cachedkey='';	$cachedkey='';
my $firstaccess=&get_first_access($type,$symb,$map);	my $firstaccess=&get_first_access($type,$symb,$map);
if (!$firstaccess) {	if ($firstaccess) {
	&logthis("First access time already set ($firstaccess) when attempting ".
	"to set new value (type: $type, extent: $res) for $uname:$udom ".
	"in $courseid");
	return 'already_set';
	} else {
my $start = time;	my $start = time;
my $putres = &put('firstaccesstimes',{"$courseid\0$res"=>$start},	my $putres = &put('firstaccesstimes',{"$courseid\0$res"=>$start},
$udom,$uname);	$udom,$uname);
Line 5232 sub set_first_access {	Line 5394 sub set_first_access {
if (($cachedtime) && (abs($start-$cachedtime) < 5)) {	if (($cachedtime) && (abs($start-$cachedtime) < 5)) {
$cachedtimes{"$courseid\0$res"} = $start;	$cachedtimes{"$courseid\0$res"} = $start;
}	}
	} elsif ($putres ne 'refused') {
	&logthis("Result: $putres when attempting to set first access time ".
	"(type: $type, extent: $res) for $uname:$udom in $courseid");
}	}
return $putres;	return $putres;
}	}
Line 7146 sub usertools_access {	Line 7311 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 7342 sub is_advanced_user {	Line 7508 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 7377 sub check_can_request {	Line 7547 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 8892 sub auto_validate_class_sec {	Line 9062 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 9251 sub assignrole {	Line 9448 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 9271 sub assignrole {	Line 9468 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 9538 sub modifyuser {	Line 9739 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 9986 sub is_course {	Line 10191 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 = &LONCAPA::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 11695 sub add_prefix_and_part {	Line 11913 sub add_prefix_and_part {

my %metaentry;	my %metaentry;
my %importedpartids;	my %importedpartids;
	my %importedrespids;
sub metadata {	sub metadata {
my ($uri,$what,$toolsymb,$liburi,$prefix,$depthcount)=@_;	my ($uri,$what,$toolsymb,$liburi,$prefix,$depthcount)=@_;
$uri=&declutter($uri);	$uri=&declutter($uri);
Line 11781 sub metadata {	Line 12000 sub metadata {

{	{
# 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 11878 sub metadata {	Line 12099 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 11909 sub metadata {	Line 12180 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',$toolsymb,$location,$unikey,	&metadata($uri,'keys',$toolsymb,$location,$unikey,
Line 11924 sub metadata {	Line 12210 sub metadata {
$metaentry{':'.$meta}=$metaentry{':'.$meta};	$metaentry{':'.$meta}=$metaentry{':'.$meta};
$metathesekeys{$meta}=1;	$metathesekeys{$meta}=1;
}	}

}	}
} else {	} else {
#	#
Line 12007 sub metadata {	Line 12292 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 13042 sub repcopy_userfile {	Line 13358 sub repcopy_userfile {
my $request;	my $request;
$uri=~s/^\///;	$uri=~s/^\///;
my $homeserver = &homeserver($cnum,$cdom);	my $homeserver = &homeserver($cnum,$cdom);
	my $hostname = &hostname($homeserver);
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.'/raw/'.$uri);
my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,$transferfile,\%perlvar,'',0,1);	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()) {
Line 13068 sub tokenwrapper {	Line 13385 sub tokenwrapper {
$file=~s\|(\?\.)$\|\|;	$file=~s\|(\?\.)$\|\|;
&appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}});	&appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}});
my $homeserver = &homeserver($uname,$udom);	my $homeserver = &homeserver($uname,$udom);
	my $hostname = &hostname($homeserver);
my $protocol = $protocol{$homeserver};	my $protocol = $protocol{$homeserver};
$protocol = 'http' if ($protocol ne 'https');	$protocol = 'http' if ($protocol ne 'https');
return $protocol.'://'.&hostname($homeserver).'/'.$uri.	return $protocol.'://'.$hostname.'/'.$uri.
(($uri=~/\?/)?'&':'?').'token='.$token.	(($uri=~/\?/)?'&':'?').'token='.$token.
'&tokenissued='.$perlvar{'lonHostID'};	'&tokenissued='.$perlvar{'lonHostID'};
} else {	} else {
Line 13086 sub getuploaded {	Line 13404 sub getuploaded {
my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;	my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
$uri=~s/^\///;	$uri=~s/^\///;
my $homeserver = &homeserver($cnum,$cdom);	my $homeserver = &homeserver($cnum,$cdom);
	my $hostname = &hostname($homeserver);
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.'/raw/'.$uri;
my $request=new HTTP::Request($reqtype,$uri);	my $request=new HTTP::Request($reqtype,$uri);
my $response=&LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,'',0,1);	my $response=&LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,'',0,1);
$$rtncode = $response->code;	$$rtncode = $response->code;
Line 13366 sub get_dns {	Line 13685 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);
Line 13382 sub get_dns {	Line 13703 sub get_dns {
my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar,30,0);	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 13454 sub fetch_dns_checksums {	Line 13789 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 14749 only used internally for recursive metad	Line 15157 only used internally for recursive metad
the toolsymb is only used where the uri is for an external tool (for which	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).	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.1366
changed lines
	Added in v.1.1397