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.1172.2.118.2.7 and 1.1172.2.142

version 1.1172.2.118.2.7, 2020/09/08 02:08:27	version 1.1172.2.142, 2021/12/14 20:23:40
Line 95 use Cache::Memcached;	Line 95 use Cache::Memcached;
use Digest::MD5;	use Digest::MD5;
use Math::Random;	use Math::Random;
use File::MMagic;	use File::MMagic;
	use Net::CIDR;
	use Sys::Hostname::FQDN();
use LONCAPA qw(:DEFAULT :match);	use LONCAPA qw(:DEFAULT :match);
use LONCAPA::Configuration;	use LONCAPA::Configuration;
use LONCAPA::lonmetadata;	use LONCAPA::lonmetadata;
Line 125 our @EXPORT = qw(%env);	Line 127 our @EXPORT = qw(%env);
$logid ++;	$logid ++;
my $now = time();	my $now = time();
my $id=$now.'00000'.$$.'00000'.$logid;	my $id=$now.'00000'.$$.'00000'.$logid;
	my $ip = &get_requestor_ip();
my $logentry = {	my $logentry = {
$id => {	$id => {
'exe_uname' => $env{'user.name'},	'exe_uname' => $env{'user.name'},
'exe_udom' => $env{'user.domain'},	'exe_udom' => $env{'user.domain'},
'exe_time' => $now,	'exe_time' => $now,
'exe_ip' => $ENV{'REMOTE_ADDR'},	'exe_ip' => $ip,
'delflag' => $delflag,	'delflag' => $delflag,
'logentry' => $storehash,	'logentry' => $storehash,
'uname' => $uname,	'uname' => $uname,
Line 688 sub check_for_valid_session {	Line 691 sub check_for_valid_session {
if (ref($userhashref) eq 'HASH') {	if (ref($userhashref) eq 'HASH') {
$userhashref->{'name'} = $disk_env{'user.name'};	$userhashref->{'name'} = $disk_env{'user.name'};
$userhashref->{'domain'} = $disk_env{'user.domain'};	$userhashref->{'domain'} = $disk_env{'user.domain'};
	if ($disk_env{'request.role'}) {
	$userhashref->{'role'} = $disk_env{'request.role'};
	}
}	}
untie(%disk_env);	untie(%disk_env);

Line 916 sub userload {	Line 922 sub userload {
# ------------------------------ Find server with least workload from spare.tab	# ------------------------------ Find server with least workload from spare.tab

sub spareserver {	sub spareserver {
my ($loadpercent,$userloadpercent,$want_server_name,$udom) = @_;	my ($r,$loadpercent,$userloadpercent,$want_server_name,$udom) = @_;
my $spare_server;	my $spare_server;
if ($userloadpercent !~ /\d/) { $userloadpercent=0; }	if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent	my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent
Line 961 sub spareserver {	Line 967 sub spareserver {
if ($protocol{$spare_server} eq 'https') {	if ($protocol{$spare_server} eq 'https') {
$protocol = $protocol{$spare_server};	$protocol = $protocol{$spare_server};
}	}
	my $alias = &Apache::lonnet::use_proxy_alias($r,$spare_server);
	$hostname = $alias if ($alias ne '');
$spare_server = $protocol.'://'.$hostname;	$spare_server = $protocol.'://'.$hostname;
}	}
}	}
Line 1082 sub check_for_balancer_cookie {	Line 1090 sub check_for_balancer_cookie {
return ($otherserver,$cookie);	return ($otherserver,$cookie);
}	}

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

sub delbalcookie {	sub delbalcookie {
my ($cookie,$balancer) =@_;	my ($cookie,$balancer) =@_;
if ($cookie =~ /^($match_domain)\_($match_username)\_[a-f0-9]{32}$/) {	if ($cookie =~ /^($match_domain)\_($match_username)\_[a-f0-9]{32}$/) {
Line 1091 sub delbalcookie {	Line 1114 sub delbalcookie {
my $intdom = &internet_dom($balancer);	my $intdom = &internet_dom($balancer);
my $serverhomedom = &host_domain($balancer);	my $serverhomedom = &host_domain($balancer);
if (($uintdom ne '') && ($uintdom eq $intdom)) {	if (($uintdom ne '') && ($uintdom eq $intdom)) {
return &reply("delbalcookie:$cookie",$balancer);	return &reply('delbalcookie:'.&escape($cookie),$balancer);
}	}
}	}
}	}
Line 1360 sub spare_can_host {	Line 1383 sub spare_can_host {
$canhost = 0;	$canhost = 0;
}	}
}	}
	if ($canhost) {
	if (ref($defdomdefaults{'offloadoth'}) eq 'HASH') {
	if ($defdomdefaults{'offloadoth'}{$try_server}) {
	unless (&shared_institution($udom,$try_server)) {
	$canhost = 0;
	}
	}
	}
	}
if (($canhost) && ($uint_dom)) {	if (($canhost) && ($uint_dom)) {
my @intdoms;	my @intdoms;
my $internet_names = &get_internet_names($try_server);	my $internet_names = &get_internet_names($try_server);
Line 1578 sub check_loadbalancing {	Line 1610 sub check_loadbalancing {
if ($domneedscache) {	if ($domneedscache) {
&do_cache_new('loadbalancing',$domneedscache,$is_balancer,$cachetime);	&do_cache_new('loadbalancing',$domneedscache,$is_balancer,$cachetime);
}	}
if ($is_balancer) {	if (($is_balancer) && ($caller ne 'switchserver')) {
my $lowest_load = 30000;	my $lowest_load = 30000;
if (ref($offloadto) eq 'HASH') {	if (ref($offloadto) eq 'HASH') {
if (ref($offloadto->{'primary'}) eq 'ARRAY') {	if (ref($offloadto->{'primary'}) eq 'ARRAY') {
Line 1618 sub check_loadbalancing {	Line 1650 sub check_loadbalancing {
}	}
}	}
}	}
unless ($homeintdom) {	}
undef($setcookie);	if (($is_balancer) && (!$homeintdom)) {
}	undef($setcookie);
}	}
return ($is_balancer,$otherserver,$setcookie);	return ($is_balancer,$otherserver,$setcookie);
}	}
Line 1874 sub get_dom {	Line 1906 sub get_dom {
}	}
if ($udom && $uhome && ($uhome ne 'no_host')) {	if ($udom && $uhome && ($uhome ne 'no_host')) {
my $rep;	my $rep;
if ($namespace =~ /^enc/) {	if (grep { $_ eq $uhome } &current_machine_ids()) {
$rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome);	# domain information is hosted on this machine
} else {	$rep = &LONCAPA::Lond::get_dom("getdom:$udom:$namespace:$items");
	} else {
$rep=&reply("getdom:$udom:$namespace:$items",$uhome);	$rep=&reply("getdom:$udom:$namespace:$items",$uhome);
}	}
my %returnhash;	my %returnhash;
Line 1922 sub put_dom {	Line 1955 sub put_dom {
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';	$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
}	}
$items=~s/\&$//;	$items=~s/\&$//;
if ($namespace =~ /^enc/) {	return &reply("putdom:$udom:$namespace:$items",$uhome);
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 2002 sub retrieve_inst_usertypes {	Line 2031 sub retrieve_inst_usertypes {

sub is_domainimage {	sub is_domainimage {
my ($url) = @_;	my ($url) = @_;
if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img\|logo\|domlogo)/+[^/]-) {	if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img\|logo\|domlogo\|login)/+[^/]-) {
if (&domain($1) ne '') {	if (&domain($1) ne '') {
return '1';	return '1';
}	}
Line 2409 sub get_domain_defaults {	Line 2438 sub get_domain_defaults {
if (ref($domconfig{'usersessions'}{'offloadnow'}) eq 'HASH') {	if (ref($domconfig{'usersessions'}{'offloadnow'}) eq 'HASH') {
$domdefaults{'offloadnow'} = $domconfig{'usersessions'}{'offloadnow'};	$domdefaults{'offloadnow'} = $domconfig{'usersessions'}{'offloadnow'};
}	}
	if (ref($domconfig{'usersessions'}{'offloadoth'}) eq 'HASH') {
	$domdefaults{'offloadoth'} = $domconfig{'usersessions'}{'offloadoth'};
	}
}	}
if (ref($domconfig{'selfenrollment'}) eq 'HASH') {	if (ref($domconfig{'selfenrollment'}) eq 'HASH') {
if (ref($domconfig{'selfenrollment'}{'admin'}) eq 'HASH') {	if (ref($domconfig{'selfenrollment'}{'admin'}) eq 'HASH') {
Line 2457 sub get_domain_defaults {	Line 2489 sub get_domain_defaults {
$domdefaults{'adhocroles'} = $domconfig{'helpsettings'}{'adhoc'};	$domdefaults{'adhocroles'} = $domconfig{'helpsettings'}{'adhoc'};
}	}
}	}
	if (ref($domconfig{'wafproxy'}) eq 'HASH') {
	foreach my $item ('ipheader','trusted','vpnint','vpnext','sslopt') {
	if ($domconfig{'wafproxy'}{$item}) {
	$domdefaults{'waf_'.$item} = $domconfig{'wafproxy'}{$item};
	}
	}
	}
&do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);	&do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);
return %domdefaults;	return %domdefaults;
}	}
Line 2543 sub get_passwdconf {	Line 2582 sub get_passwdconf {
return %passwdconf;	return %passwdconf;
}	}

sub course_portal_url {
my ($cnum,$cdom) = @_;
my $chome = &homeserver($cnum,$cdom);
my $hostname = &hostname($chome);
my $protocol = $protocol{$chome};
$protocol = 'http' if ($protocol ne 'https');
my %domdefaults = &get_domain_defaults($cdom);
my $firsturl;
if ($domdefaults{'portal_def'}) {
$firsturl = $domdefaults{'portal_def'};
} else {
$firsturl = $protocol.'://'.$hostname;
}
return $firsturl;
}

# --------------------------------------------------- Assign a key to a student	# --------------------------------------------------- Assign a key to a student

sub assign_access_key {	sub assign_access_key {
Line 3446 sub can_edit_resource {	Line 3469 sub can_edit_resource {
$cfile = '/adm/wrapper'.$resurl;	$cfile = '/adm/wrapper'.$resurl;
}	}
}	}
} elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) {
$incourse = 1;
if ($env{'form.forceedit'}) {
$forceview = 1;
} else {
$forceedit = 1;
}
$cfile = $resurl;
} elsif ($resurl =~ m{^/?adm/viewclasslist$}) {	} elsif ($resurl =~ m{^/?adm/viewclasslist$}) {
$incourse = 1;	$incourse = 1;
if ($env{'form.forceedit'}) {	if ($env{'form.forceedit'}) {
Line 3478 sub can_edit_resource {	Line 3493 sub can_edit_resource {
$forceedit = 1;	$forceedit = 1;
}	}
$cfile = $resurl;	$cfile = $resurl;
} elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) && ($env{'form.folderpath'} =~ /^supplemental/)) {
$incourse = 1;
if ($env{'form.forceedit'}) {
$forceview = 1;
} else {
$forceedit = 1;
}
$cfile = $resurl;
} elsif (($resurl eq '/adm/extresedit') && ($symb \|\| $env{'form.folderpath'})) {	} elsif (($resurl eq '/adm/extresedit') && ($symb \|\| $env{'form.folderpath'})) {
$incourse = 1;	$incourse = 1;
$forceview = 1;	$forceview = 1;
Line 3495 sub can_edit_resource {	Line 3502 sub can_edit_resource {
$cfile = &clutter($res);	$cfile = &clutter($res);
} else {	} else {
$cfile = $env{'form.suppurl'};	$cfile = $env{'form.suppurl'};
my $escfile = &unescape($cfile);	$cfile =~ s{^http://}{};
if ($escfile =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) {	$cfile = '/adm/wrapper/ext/'.$cfile;
$cfile = '/adm/wrapper'.$escfile;
} else {
$escfile =~ s{^http://}{};
$cfile = &escape("/adm/wrapper/ext/$escfile");
}
}	}
} elsif ($resurl =~ m{^/?adm/viewclasslist$}) {	} elsif ($resurl =~ m{^/?adm/viewclasslist$}) {
if ($env{'form.forceedit'}) {	if ($env{'form.forceedit'}) {
Line 3748 sub clean_filename {	Line 3750 sub clean_filename {
# Replace all .\d. sequences with _\d. so they no longer look like version	# Replace all .\d. sequences with _\d. so they no longer look like version
# numbers	# numbers
$fname=~s/\.(\d+)(?=\.)/_$1/g;	$fname=~s/\.(\d+)(?=\.)/_$1/g;
	# Replace three or more adjacent underscores with one for consistency
	# with loncfile::filename_check() so complete url can be extracted by
	# lonnet::decode_symb()
	$fname=~s/_{3,}/_/g;
return $fname;	return $fname;
}	}

Line 4609 sub flushcourselogs {	Line 4615 sub flushcourselogs {
if (! defined($dom) \|\| $dom eq '' \|\|	if (! defined($dom) \|\| $dom eq '' \|\|
! defined($name) \|\| $name eq '') {	! defined($name) \|\| $name eq '') {
my $cid = $env{'request.course.id'};	my $cid = $env{'request.course.id'};
	#
	# FIXME 11/29/2021
	# Typo in rev. 1.458 (2003/12/09)??
	# These should likely by $env{'course.'.$cid.'.domain'} and $env{'course.'.$cid.'.num'}
	#
	# While these ramain as $env{'request.'.$cid.'.domain'} and $env{'request.'.$cid.'.num'}
	# $dom and $name will always be null, so the &inc() call will default to storing this data
	# in a nohist_accesscount.db file for the user rather than the course.
	#
	# That said there is a lot of noise in the data being stored.
	# So counts for prtspool/ and adm/ etc. are recorded.
	#
	# A review of which items ending '___count' are written to %accesshash should likely be
	# made before deciding whether to set these to 'course.' instead of 'request.'
	#
	# Under the current scheme each user receives a nohist_accesscount.db file listing
	# accesses for things which are not published resources, regardless of course, and
	# there is not a nohist_accesscount.db file in a course, which might log accesses from
	# anyone in the course for things which are not published resources.
	#
	# For an author, nohist_accesscount.db ends up having records for other items
	# mixed up with the legitimate access counts for the author's published resources.
	#
$dom = $env{'request.'.$cid.'.domain'};	$dom = $env{'request.'.$cid.'.domain'};
$name = $env{'request.'.$cid.'.num'};	$name = $env{'request.'.$cid.'.num'};
}	}
Line 4718 sub courseacclog {	Line 4747 sub courseacclog {
if ($formitem =~ /^HWFILE(?:SIZE\|TOOBIG)/) {	if ($formitem =~ /^HWFILE(?:SIZE\|TOOBIG)/) {
$what.=':'.$formitem.'='.$env{$key};	$what.=':'.$formitem.'='.$env{$key};
} elsif ($formitem !~ /^HWFILE(?:[^.]+)$/) {	} elsif ($formitem !~ /^HWFILE(?:[^.]+)$/) {
$what.=':'.$formitem.'='.$env{$key};	if ($formitem eq 'proctorpassword') {
	$what.=':'.$formitem.'=' . '*' x length($env{$key});
	} else {
	$what.=':'.$formitem.'='.$env{$key};
	}
}	}
}	}
}	}
Line 5474 my %cachedtimes=();	Line 5507 my %cachedtimes=();
my $cachedtime='';	my $cachedtime='';

sub load_all_first_access {	sub load_all_first_access {
my ($uname,$udom,$ignorecache)=@_;	my ($uname,$udom)=@_;
if (($cachedkey eq $uname.':'.$udom) &&	if (($cachedkey eq $uname.':'.$udom) &&
(abs($cachedtime-time)<5) && (!$env{'form.markaccess'}) &&	(abs($cachedtime-time)<5) && (!$env{'form.markaccess'})) {
(!$ignorecache)) {
return;	return;
}	}
$cachedtime=time;	$cachedtime=time;
Line 5486 sub load_all_first_access {	Line 5518 sub load_all_first_access {
}	}

sub get_first_access {	sub get_first_access {
my ($type,$argsymb,$argmap,$ignorecache)=@_;	my ($type,$argsymb,$argmap)=@_;
my ($symb,$courseid,$udom,$uname)=&whichuser();	my ($symb,$courseid,$udom,$uname)=&whichuser();
if ($argsymb) { $symb=$argsymb; }	if ($argsymb) { $symb=$argsymb; }
my ($map,$id,$res)=&decode_symb($symb);	my ($map,$id,$res)=&decode_symb($symb);
Line 5498 sub get_first_access {	Line 5530 sub get_first_access {
} else {	} else {
$res=$symb;	$res=$symb;
}	}
&load_all_first_access($uname,$udom,$ignorecache);	&load_all_first_access($uname,$udom);
return $cachedtimes{"$courseid\0$res"};	return $cachedtimes{"$courseid\0$res"};
}	}

Line 5550 sub checkout {	Line 5582 sub checkout {
my ($symb,$tuname,$tudom,$tcrsid)=@_;	my ($symb,$tuname,$tudom,$tcrsid)=@_;
my $now=time;	my $now=time;
my $lonhost=$perlvar{'lonHostID'};	my $lonhost=$perlvar{'lonHostID'};
	my $ip = &get_requestor_ip();
my $infostr=&escape(	my $infostr=&escape(
'CHECKOUTTOKEN&'.	'CHECKOUTTOKEN&'.
$tuname.'&'.	$tuname.'&'.
$tudom.'&'.	$tudom.'&'.
$tcrsid.'&'.	$tcrsid.'&'.
$symb.'&'.	$symb.'&'.
$now.'&'.$ENV{'REMOTE_ADDR'});	$now.'&'.$ip);
my $token=&reply('tmpput:'.$infostr,$lonhost);	my $token=&reply('tmpput:'.$infostr,$lonhost);
if ($token=~/^error\:/) {	if ($token=~/^error\:/) {
&logthis("<font color=\"blue\">WARNING: ".	&logthis("<font color=\"blue\">WARNING: ".
Line 5570 sub checkout {	Line 5603 sub checkout {

my %infohash=('resource.0.outtoken' => $token,	my %infohash=('resource.0.outtoken' => $token,
'resource.0.checkouttime' => $now,	'resource.0.checkouttime' => $now,
'resource.0.outremote' => $ENV{'REMOTE_ADDR'});	'resource.0.outremote' => $ip);

unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {	unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
return '';	return '';
Line 5601 sub checkin {	Line 5634 sub checkin {
$lonhost=~tr/A-Z/a-z/;	$lonhost=~tr/A-Z/a-z/;
my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb;	my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb;
$dtoken=~s/\W/\_/g;	$dtoken=~s/\W/\_/g;
	my $ip = &get_requestor_ip();
my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=	my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));	split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));

Line 5617 sub checkin {	Line 5651 sub checkin {

my %infohash=('resource.0.intoken' => $token,	my %infohash=('resource.0.intoken' => $token,
'resource.0.checkintime' => $now,	'resource.0.checkintime' => $now,
'resource.0.inremote' => $ENV{'REMOTE_ADDR'});	'resource.0.inremote' => $ip);

unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {	unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
return '';	return '';
Line 5885 sub tmpreset {	Line 5919 sub tmpreset {
if (!$domain) { $domain=$env{'user.domain'}; }	if (!$domain) { $domain=$env{'user.domain'}; }
if (!$stuname) { $stuname=$env{'user.name'}; }	if (!$stuname) { $stuname=$env{'user.name'}; }
if ($domain eq 'public' && $stuname eq 'public') {	if ($domain eq 'public' && $stuname eq 'public') {
$stuname=$ENV{'REMOTE_ADDR'};	$stuname=&get_requestor_ip();
}	}
my $path=LONCAPA::tempdir();	my $path=LONCAPA::tempdir();
my %hash;	my %hash;
Line 5922 sub tmpstore {	Line 5956 sub tmpstore {
if (!$domain) { $domain=$env{'user.domain'}; }	if (!$domain) { $domain=$env{'user.domain'}; }
if (!$stuname) { $stuname=$env{'user.name'}; }	if (!$stuname) { $stuname=$env{'user.name'}; }
if ($domain eq 'public' && $stuname eq 'public') {	if ($domain eq 'public' && $stuname eq 'public') {
$stuname=$ENV{'REMOTE_ADDR'};	$stuname=&get_requestor_ip();
}	}
my $now=time;	my $now=time;
my %hash;	my %hash;
Line 5966 sub tmprestore {	Line 6000 sub tmprestore {
if (!$domain) { $domain=$env{'user.domain'}; }	if (!$domain) { $domain=$env{'user.domain'}; }
if (!$stuname) { $stuname=$env{'user.name'}; }	if (!$stuname) { $stuname=$env{'user.name'}; }
if ($domain eq 'public' && $stuname eq 'public') {	if ($domain eq 'public' && $stuname eq 'public') {
$stuname=$ENV{'REMOTE_ADDR'};	$stuname=&get_requestor_ip();
}	}
my %returnhash;	my %returnhash;
$namespace=~s/\//\_/g;	$namespace=~s/\//\_/g;
Line 6022 sub store {	Line 6056 sub store {
}	}
if (!$home) { $home=$env{'user.home'}; }	if (!$home) { $home=$env{'user.home'}; }

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

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

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

my $namevalue='';	my $namevalue='';
Line 6915 sub currentdump {	Line 6949 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 7050 sub putstore {	Line 7084 sub putstore {
foreach my $key (keys(%{$storehash})) {	foreach my $key (keys(%{$storehash})) {
$namevalue.=&escape($key).'='.&freeze_escape($storehash->{$key}).'&';	$namevalue.=&escape($key).'='.&freeze_escape($storehash->{$key}).'&';
}	}
$namevalue .= 'ip='.&escape($ENV{'REMOTE_ADDR'}).	my $ip = &get_requestor_ip();
	$namevalue .= 'ip='.&escape($ip).
'&host='.&escape($perlvar{'lonHostID'}).	'&host='.&escape($perlvar{'lonHostID'}).
'&version='.$esc_v.	'&version='.$esc_v.
'&by='.&escape($env{'user.name'}.':'.$env{'user.domain'});	'&by='.&escape($env{'user.name'}.':'.$env{'user.domain'});
Line 7274 sub portfolio_access {	Line 7309 sub portfolio_access {
if ($result) {	if ($result) {
my %setters;	my %setters;
if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {	if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
my ($startblock,$endblock) =	my ($startblock,$endblock,$triggerblock,$by_ip,$blockdom) =
&Apache::loncommon::blockcheck(\%setters,'port',$unum,$udom);	&Apache::loncommon::blockcheck(\%setters,'port',$clientip,$unum,$udom);
if ($startblock && $endblock) {	if (($startblock && $endblock) \|\| ($by_ip)) {
return 'B';	return 'B';
}	}
} else {	} else {
my ($startblock,$endblock) =	my ($startblock,$endblock,$triggerblock,$by_ip,$blockdo) =
&Apache::loncommon::blockcheck(\%setters,'port');	&Apache::loncommon::blockcheck(\%setters,'port',$clientip);
if ($startblock && $endblock) {	if (($startblock && $endblock) \|\| ($by_ip)) {
return 'B';	return 'B';
}	}
}	}
Line 7831 sub customaccess {	Line 7866 sub customaccess {
# ------------------------------------------------- Check for a user privilege	# ------------------------------------------------- Check for a user privilege

sub allowed {	sub allowed {
my ($priv,$uri,$symb,$role,$clientip,$noblockcheck)=@_;	my ($priv,$uri,$symb,$role,$clientip,$noblockcheck,$ignorecache)=@_;
my $ver_orguri=$uri;	my $ver_orguri=$uri;
$uri=&deversion($uri);	$uri=&deversion($uri);
my $orguri=$uri;	my $orguri=$uri;
Line 7848 sub allowed {	Line 7883 sub allowed {

if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }	if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }
# Free bre access to adm and meta resources	# Free bre access to adm and meta resources
if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg\|bulletinboard\|ext\.tool)$}))	if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg\|bulletinboard\|viewclasslist\|aboutme)$}))
\|\| (($uri=~/\.meta$/) && ($uri!~m\|^uploaded/\|) ))	\|\| (($uri=~/\.meta$/) && ($uri!~m\|^uploaded/\|) ))
&& ($priv eq 'bre')) {	&& ($priv eq 'bre')) {
return 'F';	return 'F';
Line 7859 sub allowed {	Line 7894 sub allowed {
if (($space=~/^(uploaded\|editupload)$/) && ($env{'user.name'} eq $name) &&	if (($space=~/^(uploaded\|editupload)$/) && ($env{'user.name'} eq $name) &&
($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) {	($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) {
my %setters;	my %setters;
my ($startblock,$endblock) =	my ($startblock,$endblock,$triggerblock,$by_ip,$blockdom) =
&Apache::loncommon::blockcheck(\%setters,'port');	&Apache::loncommon::blockcheck(\%setters,'port',$clientip);
if ($startblock && $endblock) {	if (($startblock && $endblock) \|\| ($by_ip)) {
return 'B';	return 'B';
} else {	} else {
return 'F';	return 'F';
Line 7954 sub allowed {	Line 7989 sub allowed {
my $adom = $1;	my $adom = $1;
foreach my $key (keys(%env)) {	foreach my $key (keys(%env)) {
if ($key =~ m{^user\.role\.(ca\|aa)/\Q$adom\E}) {	if ($key =~ m{^user\.role\.(ca\|aa)/\Q$adom\E}) {
my ($start,$end) = split('.',$env{$key});	my ($start,$end) = split(/\./,$env{$key});
if (($now >= $start) && (!$end \|\| $end < $now)) {	if (($now >= $start) && (!$end \|\| $end > $now)) {
$ownaccess = 1;	$ownaccess = 1;
last;	last;
}	}
Line 7967 sub allowed {	Line 8002 sub allowed {
foreach my $role ('ca','aa') {	foreach my $role ('ca','aa') {
if ($env{"user.role.$role./$adom/$aname"}) {	if ($env{"user.role.$role./$adom/$aname"}) {
my ($start,$end) =	my ($start,$end) =
split('.',$env{"user.role.$role./$adom/$aname"});	split(/\./,$env{"user.role.$role./$adom/$aname"});
if (($now >= $start) && (!$end \|\| $end < $now)) {	if (($now >= $start) && (!$end \|\| $end > $now)) {
$ownaccess = 1;	$ownaccess = 1;
last;	last;
}	}
Line 8056 sub allowed {	Line 8091 sub allowed {
if ($noblockcheck) {	if ($noblockcheck) {
$thisallowed.=$value;	$thisallowed.=$value;
} else {	} else {
my @blockers = &has_comm_blocking($priv,$symb,$uri);	my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache);
if (@blockers > 0) {	if (@blockers > 0) {
$thisallowed = 'B';	$thisallowed = 'B';
} else {	} else {
Line 8076 sub allowed {	Line 8111 sub allowed {
if ($noblockcheck) {	if ($noblockcheck) {
$thisallowed='F';	$thisallowed='F';
} else {	} else {
my @blockers = &has_comm_blocking($priv,$symb,$refuri);	my @blockers = &has_comm_blocking($priv,'',$refuri,'',1);
if (@blockers > 0) {	if (@blockers > 0) {
$thisallowed = 'B';	$thisallowed = 'B';
} else {	} else {
Line 8149 sub allowed {	Line 8184 sub allowed {
if ($noblockcheck) {	if ($noblockcheck) {
$thisallowed.=$value;	$thisallowed.=$value;
} else {	} else {
my @blockers = &has_comm_blocking($priv,$symb,$uri);	my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache);
if (@blockers > 0) {	if (@blockers > 0) {
$thisallowed = 'B';	$thisallowed = 'B';
} else {	} else {
Line 8162 sub allowed {	Line 8197 sub allowed {
$checkreferer=0;	$checkreferer=0;
}	}
}	}

if ($checkreferer) {	if ($checkreferer) {
my $refuri=$env{'httpref.'.$orguri};	my $refuri=$env{'httpref.'.$orguri};
unless ($refuri) {	unless ($refuri) {
Line 8191 sub allowed {	Line 8226 sub allowed {
if ($noblockcheck) {	if ($noblockcheck) {
$thisallowed.=$value;	$thisallowed.=$value;
} else {	} else {
my @blockers = &has_comm_blocking($priv,$symb,$refuri);	my @blockers = &has_comm_blocking($priv,'',$refuri,'',1);
if (@blockers > 0) {	if (@blockers > 0) {
$thisallowed = 'B';	$thisallowed = 'B';
} else {	} else {
Line 8233 sub allowed {	Line 8268 sub allowed {
#	#

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

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

#	#
# Rest of the restrictions depend on selected course	# Rest of the restrictions depend on selected course
#	#
Line 8435 sub constructaccess {	Line 8502 sub constructaccess {
#	#
# User for whom data are being temporarily cached.	# User for whom data are being temporarily cached.
my $cacheduser='';	my $cacheduser='';
	# Course for which data are being temporarily cached.
	my $cachedcid='';
# Cached blockers for this user (a hash of blocking items).	# Cached blockers for this user (a hash of blocking items).
my %cachedblockers=();	my %cachedblockers=();
# When the data were last cached.	# When the data were last cached.
my $cachedlast='';	my $cachedlast='';

sub load_all_blockers {	sub load_all_blockers {
my ($uname,$udom,$blocks)=@_;	my ($uname,$udom)=@_;
if (($uname ne '') && ($udom ne '')) {	if (($uname ne '') && ($udom ne '')) {
if (($cacheduser eq $uname.':'.$udom) &&	if (($cacheduser eq $uname.':'.$udom) &&
	($cachedcid eq $env{'request.course.id'}) &&
(abs($cachedlast-time)<5)) {	(abs($cachedlast-time)<5)) {
return;	return;
}	}
}	}
$cachedlast=time;	$cachedlast=time;
$cacheduser=$uname.':'.$udom;	$cacheduser=$uname.':'.$udom;
%cachedblockers = &get_commblock_resources($blocks);	$cachedcid=$env{'request.course.id'};
	%cachedblockers = &get_commblock_resources();
	return;
}	}

sub get_comm_blocks {	sub get_comm_blocks {
Line 8477 sub get_commblock_resources {	Line 8549 sub get_commblock_resources {
my ($blocks) = @_;	my ($blocks) = @_;
my %blockers = ();	my %blockers = ();
return %blockers unless ($env{'request.course.id'});	return %blockers unless ($env{'request.course.id'});
return %blockers if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/);	my $courseurl = &courseid_to_courseurl($env{'request.course.id'});
	if ($env{'request.course.sec'}) {
	$courseurl .= '/'.$env{'request.course.sec'};
	}
	return %blockers if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseurl} =~/evb\&([^\:]*)/);
my %commblocks;	my %commblocks;
if (ref($blocks) eq 'HASH') {	if (ref($blocks) eq 'HASH') {
%commblocks = %{$blocks};	%commblocks = %{$blocks};
Line 8509 sub get_commblock_resources {	Line 8585 sub get_commblock_resources {
}	}
} elsif ($block =~ /^firstaccess____(.+)$/) {	} elsif ($block =~ /^firstaccess____(.+)$/) {
my $item = $1;	my $item = $1;
my @to_test;
if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {	if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {
if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {	if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {
my @interval;	my (@interval,$mapname);
my $type = 'map';	my $type = 'map';
if ($item eq 'course') {	if ($item eq 'course') {
$type = 'course';	$type = 'course';
Line 8521 sub get_commblock_resources {	Line 8596 sub get_commblock_resources {
if ($item =~ /___\d+___/) {	if ($item =~ /___\d+___/) {
$type = 'resource';	$type = 'resource';
@interval=&EXT("resource.0.interval",$item);	@interval=&EXT("resource.0.interval",$item);
if (ref($navmap)) {
my $res = $navmap->getBySymb($item);
push(@to_test,$res);
}
} else {	} else {
my $mapsymb = &symbread($item,1);	$mapname = &deversion($item);
if ($mapsymb) {	if (ref($navmap)) {
if (ref($navmap)) {	my $timelimit = $navmap->get_mapparam(undef,$mapname,'0.interval');
my $mapres = $navmap->getBySymb($mapsymb);	@interval = ($timelimit,'map');
@to_test = $mapres->retrieveResources($mapres,undef,0,0,0,1);
foreach my $res (@to_test) {
my $symb = $res->symb();
next if ($symb eq $mapsymb);
if ($symb ne '') {
@interval=&EXT("resource.0.interval",$symb);
if ($interval[1] eq 'map') {
last;
}
}
}
}
}	}
}	}
}	}
if ($interval[0] =~ /^(\d+)/) {	if ($interval[0] =~ /^\d+$/) {
my $timelimit = $1;
my $first_access;	my $first_access;
if ($type eq 'resource') {	if ($type eq 'resource') {
$first_access=&get_first_access($interval[1],$item);	$first_access=&get_first_access($interval[1],$item);
Line 8556 sub get_commblock_resources {	Line 8614 sub get_commblock_resources {
$first_access=&get_first_access($interval[1]);	$first_access=&get_first_access($interval[1]);
}	}
if ($first_access) {	if ($first_access) {
my $timesup = $first_access+$timelimit;	my $timesup = $first_access+$interval[0];
if ($timesup > $now) {	if ($timesup > $now) {
my $activeblock;	my $activeblock;
foreach my $res (@to_test) {	if ($type eq 'resource') {
if ($res->answerable()) {	if (ref($navmap)) {
$activeblock = 1;	my $res = $navmap->getBySymb($item);
last;	if ($res->answerable()) {
	$activeblock = 1;
	}
	}
	} elsif ($type eq 'map') {
	my $mapsymb = &symbread($mapname,1);
	if (($mapsymb) && (ref($navmap))) {
	my $mapres = $navmap->getBySymb($mapsymb);
	if (ref($mapres)) {
	my $first = $mapres->map_start();
	my $finish = $mapres->map_finish();
	my $it = $navmap->getIterator($first,$finish,undef,0,0);
	if (ref($it)) {
	my $res;
	while ($res = $it->next(undef,1)) {
	next unless (ref($res));
	my $symb = $res->symb();
	next if (($symb eq $mapsymb) \|\| ($symb eq ''));
	@interval=&EXT("resource.0.interval",$symb);
	if ($interval[1] eq 'map') {
	if ($res->answerable()) {
	$activeblock = 1;
	last;
	}
	}
	}
	}
	}
}	}
}	}
if ($activeblock) {	if ($activeblock) {
Line 8588 sub get_commblock_resources {	Line 8673 sub get_commblock_resources {
}	}

sub has_comm_blocking {	sub has_comm_blocking {
my ($priv,$symb,$uri,$blocks) = @_;	my ($priv,$symb,$uri,$ignoresymbdb,$noenccheck,$blocked,$blocks) = @_;
my @blockers;	my @blockers;
return unless ($env{'request.course.id'});	return unless ($env{'request.course.id'});
return unless ($priv eq 'bre');	return unless ($priv eq 'bre');
return if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/);
return if ($env{'request.state'} eq 'construct');	return if ($env{'request.state'} eq 'construct');
&load_all_blockers($env{'user.name'},$env{'user.domain'},$blocks);	my $courseurl = &courseid_to_courseurl($env{'request.course.id'});
return unless (keys(%cachedblockers) > 0);	if ($env{'request.course.sec'}) {
	$courseurl .= '/'.$env{'request.course.sec'};
	}
	return if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseurl} =~/evb\&([^\:]*)/);
	my %blockinfo;
	if (ref($blocks) eq 'HASH') {
	%blockinfo = &get_commblock_resources($blocks);
	} else {
	&load_all_blockers($env{'user.name'},$env{'user.domain'});
	%blockinfo = %cachedblockers;
	}
	return unless (keys(%blockinfo) > 0);
my (%possibles,@symbs);	my (%possibles,@symbs);
if (!$symb) {	if (!$symb) {
$symb = &symbread($uri,1,1,1,\%possibles);	$symb = &symbread($uri,1,1,1,\%possibles,$ignoresymbdb,$noenccheck);
}	}
if ($symb) {	if ($symb) {
@symbs = ($symb);	@symbs = ($symb);
Line 8609 sub has_comm_blocking {	Line 8704 sub has_comm_blocking {
foreach my $symb (@symbs) {	foreach my $symb (@symbs) {
last if ($noblock);	last if ($noblock);
my ($map,$resid,$resurl)=&decode_symb($symb);	my ($map,$resid,$resurl)=&decode_symb($symb);
foreach my $block (keys(%cachedblockers)) {	foreach my $block (keys(%blockinfo)) {
if ($block =~ /^firstaccess____(.+)$/) {	if ($block =~ /^firstaccess____(.+)$/) {
my $item = $1;	my $item = $1;
if (($item eq $map) \|\| ($item eq $symb)) {	unless ($blocked) {
$noblock = 1;	if (($item eq $map) \|\| ($item eq $symb)) {
last;	$noblock = 1;
	last;
	}
}	}
}	}
if (ref($cachedblockers{$block}) eq 'HASH') {	if (ref($blockinfo{$block}) eq 'HASH') {
if (ref($cachedblockers{$block}{'resources'}) eq 'HASH') {	if (ref($blockinfo{$block}{'resources'}) eq 'HASH') {
if ($cachedblockers{$block}{'resources'}{$symb}) {	if ($blockinfo{$block}{'resources'}{$symb}) {
unless (grep(/^\Q$block\E$/,@blockers)) {	unless (grep(/^\Q$block\E$/,@blockers)) {
push(@blockers,$block);	push(@blockers,$block);
}	}
}	}
}	}
}	if (ref($blockinfo{$block}{'maps'}) eq 'HASH') {
if (ref($cachedblockers{$block}{'maps'}) eq 'HASH') {	if ($blockinfo{$block}{'maps'}{$map}) {
if ($cachedblockers{$block}{'maps'}{$map}) {	unless (grep(/^\Q$block\E$/,@blockers)) {
unless (grep(/^\Q$block\E$/,@blockers)) {	push(@blockers,$block);
push(@blockers,$block);	}
}	}
}	}
}	}
}	}
}	}
return if ($noblock);	unless ($noblock) {
return @blockers;	return @blockers;
	}
	return;
}	}
}	}

Line 9034 sub auto_validate_instcode {	Line 9133 sub auto_validate_instcode {
return ($outcome,$description,$defaultcredits);	return ($outcome,$description,$defaultcredits);
}	}

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

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

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

sub auto_validate_instclasses {	sub auto_validate_instclasses {
my ($cdom,$cnum,$owners,$classesref) = @_;	my ($cdom,$cnum,$owners,$classesref) = @_;
my ($homeserver,%validations);	my ($homeserver,%validations);
Line 9849 sub autoupdate_coowners {	Line 9999 sub autoupdate_coowners {
if ($domdesign{$cdom.'.autoassign.co-owners'}) {	if ($domdesign{$cdom.'.autoassign.co-owners'}) {
my %coursehash = &coursedescription($cdom.'_'.$cnum);	my %coursehash = &coursedescription($cdom.'_'.$cnum);
my $instcode = $coursehash{'internal.coursecode'};	my $instcode = $coursehash{'internal.coursecode'};
	my $xlists = $coursehash{'internal.crosslistings'};
if ($instcode ne '') {	if ($instcode ne '') {
if (($start && $start <= $now) && ($end == 0) \|\| ($end > $now)) {	if (($start && $start <= $now) && ($end == 0) \|\| ($end > $now)) {
unless ($coursehash{'internal.courseowner'} eq $uname.':'.$udom) {	unless ($coursehash{'internal.courseowner'} eq $uname.':'.$udom) {
my ($delcoowners,@newcoowners,$putresult,$delresult,$coowners);	my ($delcoowners,@newcoowners,$putresult,$delresult,$coowners);
my ($result,$desc) = &auto_validate_instcode($cnum,$cdom,$instcode,$uname.':'.$udom);	my ($result,$desc) = &auto_validate_instcode($cnum,$cdom,$instcode,$uname.':'.$udom);
	unless ($result eq 'valid') {
	if ($xlists ne '') {
	foreach my $xlist (split(',',$xlists)) {
	my ($inst_crosslist,$lcsec) = split(':',$xlist);
	$result =
	&auto_validate_inst_crosslist($cnum,$cdom,$instcode,
	$inst_crosslist,$uname.':'.$udom);
	last if ($result eq 'valid');
	}
	}
	}
if ($result eq 'valid') {	if ($result eq 'valid') {
if ($coursehash{'internal.co-owners'}) {	if ($coursehash{'internal.co-owners'}) {
foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {	foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {
Line 9866 sub autoupdate_coowners {	Line 10028 sub autoupdate_coowners {
} else {	} else {
push(@newcoowners,$uname.':'.$udom);	push(@newcoowners,$uname.':'.$udom);
}	}
} else {	} elsif ($coursehash{'internal.co-owners'}) {
if ($coursehash{'internal.co-owners'}) {	foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {
foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {	unless ($coowner eq $uname.':'.$udom) {
unless ($coowner eq $uname.':'.$udom) {	push(@newcoowners,$coowner);
push(@newcoowners,$coowner);
}
}
unless (@newcoowners > 0) {
$delcoowners = 1;
$coowners = '';
}	}
}	}
	unless (@newcoowners > 0) {
	$delcoowners = 1;
	$coowners = '';
	}
}	}
if (@newcoowners \|\| $delcoowners) {	if (@newcoowners \|\| $delcoowners) {
&store_coowners($cdom,$cnum,$coursehash{'home'},	&store_coowners($cdom,$cnum,$coursehash{'home'},
Line 9951 sub modifyuserauth {	Line 10111 sub modifyuserauth {
' in domain '.$env{'request.role.domain'});	' in domain '.$env{'request.role.domain'});
my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'.	my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'.
&escape($upass),$uhome);	&escape($upass),$uhome);
	my $ip = &get_requestor_ip();
&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},	&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},
'Authentication changed for '.$udom.', '.$uname.', '.$umode.	'Authentication changed for '.$udom.', '.$uname.', '.$umode.
'(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);	'(Remote '.$ip.'): '.$reply);
&log($udom,,$uname,$uhome,	&log($udom,,$uname,$uhome,
'Authentication changed by '.$env{'user.domain'}.', '.	'Authentication changed by '.$env{'user.domain'}.', '.
$env{'user.name'}.', '.$umode.	$env{'user.name'}.', '.$umode.
'(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);	'(Remote '.$ip.'): '.$reply);
unless ($reply eq 'ok') {	unless ($reply eq 'ok') {
&logthis('Authentication mode error: '.$reply);	&logthis('Authentication mode error: '.$reply);
return 'error: '.$reply;	return 'error: '.$reply;
Line 10282 sub writecoursepref {	Line 10443 sub writecoursepref {

sub createcourse {	sub createcourse {
my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,	my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,
$course_owner,$crstype,$cnum,$context,$category,$callercontext)=@_;	$course_owner,$crstype,$cnum,$context,$category)=@_;
$url=&declutter($url);	$url=&declutter($url);
my $cid='';	my $cid='';
if ($context eq 'requestcourses') {	if ($context eq 'requestcourses') {
my $can_create = 0;	my $can_create = 0;
my ($ownername,$ownerdom) = split(':',$course_owner);	my ($ownername,$ownerdom) = split(':',$course_owner);
if ($udom eq $ownerdom) {	if ($udom eq $ownerdom) {
my $reload;	if (&usertools_access($ownername,$ownerdom,$category,undef,
if (($callercontext eq 'auto') &&
($ownerdom eq $env{'user.domain'}) && ($ownername eq $env{'user.name'})) {
$reload = 'reload';
}
if (&usertools_access($ownername,$ownerdom,$category,$reload,
$context)) {	$context)) {
$can_create = 1;	$can_create = 1;
}	}
Line 10478 sub store_userdata {	Line 10634 sub store_userdata {
if (($uhome eq '') \|\| ($uhome eq 'no_host')) {	if (($uhome eq '') \|\| ($uhome eq 'no_host')) {
$result = 'error: no_host';	$result = 'error: no_host';
} else {	} else {
$storehash->{'ip'} = $ENV{'REMOTE_ADDR'};	$storehash->{'ip'} = &get_requestor_ip();
$storehash->{'host'} = $perlvar{'lonHostID'};	$storehash->{'host'} = $perlvar{'lonHostID'};

my $namevalue='';	my $namevalue='';
Line 11303 sub get_userresdata {	Line 11459 sub get_userresdata {
# Parameters:	# Parameters:
# $name - Course/user name.	# $name - Course/user name.
# $domain - Name of the domain the user/course is registered on.	# $domain - Name of the domain the user/course is registered on.
# $type - Type of thing $name is (must be 'course' or 'user')	# $type - Type of thing $name is (must be 'course' or 'user'
# @which - Array of names of resources desired.	# @which - Array of names of resources desired.
# Returns:	# Returns:
# The value of the first reasource in @which that is found in the	# The value of the first reasource in @which that is found in the
Line 11322 sub resdata {	Line 11478 sub resdata {
}	}
if (!ref($result)) { return $result; }	if (!ref($result)) { return $result; }
foreach my $item (@which) {	foreach my $item (@which) {
if (ref($item) eq 'ARRAY') {	if (defined($result->{$item->[0]})) {
if (defined($result->{$item->[0]})) {	return [$result->{$item->[0]},$item->[1]];
return [$result->{$item->[0]},$item->[1]];	}
}
}
}	}
return undef;	return undef;
}	}

sub get_domain_ltitools {
my ($cdom) = @_;
my %ltitools;
my ($result,$cached)=&is_cached_new('ltitools',$cdom);
if (defined($cached)) {
if (ref($result) eq 'HASH') {
%ltitools = %{$result};
}
} else {
my %domconfig = &get_dom('configuration',['ltitools'],$cdom);
if (ref($domconfig{'ltitools'}) eq 'HASH') {
%ltitools = %{$domconfig{'ltitools'}};
my %encdomconfig = &get_dom('encconfig',['ltitools'],$cdom);
if (ref($encdomconfig{'ltitools'}) eq 'HASH') {
foreach my $id (keys(%ltitools)) {
if (ref($encdomconfig{'ltitools'}{$id}) eq 'HASH') {
foreach my $item ('key','secret') {
$ltitools{$id}{$item} = $encdomconfig{'ltitools'}{$id}{$item};
}
}
}
}
}
my $cachetime = 246060;
&do_cache_new('ltitools',$cdom,\%ltitools,$cachetime);
}
return %ltitools;
}

sub get_numsuppfiles {	sub get_numsuppfiles {
my ($cnum,$cdom,$ignorecache)=@_;	my ($cnum,$cdom,$ignorecache)=@_;
my $hashid=$cnum.':'.$cdom;	my $hashid=$cnum.':'.$cdom;
Line 11440 sub EXT {	Line 11565 sub EXT {
if ( (defined($Apache::lonhomework::parsing_a_problem)	if ( (defined($Apache::lonhomework::parsing_a_problem)
\|\| defined($Apache::lonhomework::parsing_a_task))	\|\| defined($Apache::lonhomework::parsing_a_task))
&&	&&
($symbparm eq &symbread()) ) {	($symbparm eq &symbread()) ) {
# if we are in the middle of processing the resource the	# if we are in the middle of processing the resource the
# get the value we are planning on committing	# get the value we are planning on committing
if (defined($Apache::lonhomework::results{$qualifierrest})) {	if (defined($Apache::lonhomework::results{$qualifierrest})) {
Line 11815 sub metadata {	Line 11940 sub metadata {
# 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\|ext\.tool)$})) \|\|	($uri !~ m\|^adm/includes\|) && ($uri !~ m{/(smppg\|bulletinboard)$})) \|\|
($uri =~ m\|/$\|) \|\| ($uri =~ m\|/.meta$\|) \|\| ($uri =~ m{^/*uploaded/.+\.sequence$})) {	($uri =~ m\|/$\|) \|\| ($uri =~ m\|/.meta$\|) \|\| ($uri =~ m{^/*uploaded/.+\.sequence$})) {
return undef;	return undef;
}	}
Line 12511 sub deversion {	Line 12636 sub deversion {
# ------------------------------------------------------ Return symb list entry	# ------------------------------------------------------ Return symb list entry

sub symbread {	sub symbread {
my ($thisfn,$donotrecurse,$ignorecachednull,$checkforblock,$possibles)=@_;	my ($thisfn,$donotrecurse,$ignorecachednull,$checkforblock,$possibles,
	$ignoresymbdb,$noenccheck)=@_;
my $cache_str='request.symbread.cached.'.$thisfn;	my $cache_str='request.symbread.cached.'.$thisfn;
if (defined($env{$cache_str})) {	if (defined($env{$cache_str})) {
if ($ignorecachednull) {	unless (ref($possibles) eq 'HASH') {
return $env{$cache_str} unless ($env{$cache_str} eq '');	if ($ignorecachednull) {
} else {	return $env{$cache_str} unless ($env{$cache_str} eq '');
return $env{$cache_str};	} else {
	return $env{$cache_str};
	}
}	}
}	}
# no filename provided? try from environment	# no filename provided? try from environment
Line 12546 sub symbread {	Line 12674 sub symbread {
if ($targetfn =~ m\|^adm/wrapper/(ext/.*)\|) {	if ($targetfn =~ m\|^adm/wrapper/(ext/.*)\|) {
$targetfn=$1;	$targetfn=$1;
}	}
if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',	unless ($ignoresymbdb) {
&GDBM_READER(),0640)) {	if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
$syval=$hash{$targetfn};	&GDBM_READER(),0640)) {
untie(%hash);	$syval=$hash{$targetfn};
	untie(%hash);
	}
	if ($syval && $checkforblock) {
	my @blockers = &has_comm_blocking('bre',$syval,$thisfn,$ignoresymbdb,$noenccheck);
	if (@blockers) {
	$syval='';
	}
	}
}	}
# ---------------------------------------------------------- There was an entry	# ---------------------------------------------------------- There was an entry
if ($syval) {	if ($syval) {
Line 12582 sub symbread {	Line 12718 sub symbread {
$syval=&encode_symb($bighash{'map_id_'.$mapid},	$syval=&encode_symb($bighash{'map_id_'.$mapid},
$resid,$thisfn);	$resid,$thisfn);
if (ref($possibles) eq 'HASH') {	if (ref($possibles) eq 'HASH') {
$possibles->{$syval} = 1;	unless ($bighash{'randomout_'.$ids} \|\| $env{'request.role.adv'}) {
	$possibles->{$syval} = 1;
	}
}	}
if ($checkforblock) {	if ($checkforblock) {
my @blockers = &has_comm_blocking('bre',$syval,$bighash{'src_'.$ids});	unless ($bighash{'randomout_'.$ids} \|\| $env{'request.role.adv'}) {
if (@blockers) {	my @blockers = &has_comm_blocking('bre',$syval,$bighash{'src_'.$ids},'',$noenccheck);
$syval = '';	if (@blockers) {
return;	$syval = '';
	untie(%bighash);
	return $env{$cache_str}='';
	}
}	}
}	}
} elsif ((!$donotrecurse) \|\| ($checkforblock) \|\| (ref($possibles) eq 'HASH')) {	} elsif ((!$donotrecurse) \|\| ($checkforblock) \|\| (ref($possibles) eq 'HASH')) {
Line 12607 sub symbread {	Line 12748 sub symbread {
if ($bighash{'map_type_'.$mapid} ne 'page') {	if ($bighash{'map_type_'.$mapid} ne 'page') {
my $poss_syval=&encode_symb($bighash{'map_id_'.$mapid},	my $poss_syval=&encode_symb($bighash{'map_id_'.$mapid},
$resid,$thisfn);	$resid,$thisfn);
if (ref($possibles) eq 'HASH') {	next if ($bighash{'randomout_'.$id} && !$env{'request.role.adv'});
$possibles->{$syval} = 1;	next unless (($noenccheck) \|\| ($bighash{'encrypted_'.$id} eq $env{'request.enc'}));
}
if ($checkforblock) {	if ($checkforblock) {
my @blockers = &has_comm_blocking('bre',$poss_syval,$file);	my @blockers = &has_comm_blocking('bre',$poss_syval,$file,'',$noenccheck);
unless (@blockers > 0) {	if (@blockers > 0) {
	$syval = '';
	} else {
$syval = $poss_syval;	$syval = $poss_syval;
$realpossible++;	$realpossible++;
}	}
Line 12620 sub symbread {	Line 12762 sub symbread {
$syval = $poss_syval;	$syval = $poss_syval;
$realpossible++;	$realpossible++;
}	}
	if ($syval) {
	if (ref($possibles) eq 'HASH') {
	$possibles->{$syval} = 1;
	}
	}
}	}
}	}
}	}
Line 13339 sub machine_ids {	Line 13486 sub machine_ids {

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

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

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

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

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

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

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

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

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

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

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

sub declutter {	sub declutter {
Line 13470 sub clutter {	Line 13849 sub clutter {
# &logthis("Got a blank emb style");	# &logthis("Got a blank emb style");
}	}
}	}
} elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/ext\.tool$}) {
$thisfn='/adm/wrapper'.$thisfn;
}	}
return $thisfn;	return $thisfn;
}	}
Line 13559 sub get_dns {	Line 13936 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;	my @content;
$ua->timeout(30);	if ($dns eq Sys::Hostname::FQDN::fqdn()) {
my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");	my $command = (split('/',$url))[3];
my $response=$ua->request($request);	my ($dir,$file) = &parse_getdns_url($command,$url);
delete($alldns{$dns});	delete($alldns{$dns});
next if ($response->is_error());	next if (($dir eq '') \|\| ($file eq ''));
my @content = split("\n",$response->content);	if (open(my $config,'<',"$dir/$file")) {
	@content = <$config>;
	close($config);
	}
	} else {
	my $ua=new LWP::UserAgent;
	$ua->timeout(30);
	my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
	my $response=$ua->request($request);
	delete($alldns{$dns});
	next if ($response->is_error());
	@content = split("\n",$response->content);
	}
unless ($nocache) {	unless ($nocache) {
&do_cache_new('dns',$url,\@content,302460*60);	&do_cache_new('dns',$url,\@content,302460*60);
}	}
Line 13637 sub fetch_dns_checksums {	Line 14026 sub fetch_dns_checksums {
return \%checksums;	return \%checksums;
}	}

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

# ------------------------------------------------------------ Read domain file	# ------------------------------------------------------------ Read domain file
{	{
my $loaded;	my $loaded;

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

Removed from v.1.1172.2.118.2.7
changed lines
	Added in v.1.1172.2.142