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.1380 and 1.1513

version 1.1380, 2018/08/07 17:12:25	version 1.1513, 2023/07/20 12:47:09
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;

use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir	use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $deftex
$_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease	$_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease
%managerstab);	%managerstab $passwdmin);

my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,	my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,
%userrolehash, $processmarker, $dumpcount, %coursedombuf,	%userrolehash, $processmarker, $dumpcount, %coursedombuf,
Line 96 use Cache::Memcached;	Line 96 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;
use LONCAPA::Lond;	use LONCAPA::Lond;
use LONCAPA::LWPReq;	use LONCAPA::LWPReq;
	use LONCAPA::transliterate;

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

Line 127 our @EXPORT = qw(%env);	Line 130 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 184 sub create_connection {	Line 188 sub create_connection {
Type => SOCK_STREAM,	Type => SOCK_STREAM,
Timeout => 10);	Timeout => 10);
return 0 if (!$client);	return 0 if (!$client);
print $client (join(':',$hostname,$lonid,&machine_ids($hostname))."\n");	print $client (join(':',$hostname,$lonid,&machine_ids($hostname),$loncaparevs{$lonid})."\n");
my $result = <$client>;	my $result = <$client>;
chomp($result);	chomp($result);
return 1 if ($result eq 'done');	return 1 if ($result eq 'done');
Line 230 sub get_server_distarch {	Line 234 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 261 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 315 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 408 sub remote_devalidate_cache {	Line 415 sub remote_devalidate_cache {
return $response;	return $response;
}	}

	sub sign_lti {
	my ($cdom,$cnum,$crsdef,$type,$context,$url,$ltinum,$keynum,$paramsref,$inforef) = @_;
	my $chome;
	if (&domain($cdom) ne '') {
	if ($crsdef) {
	$chome = &homeserver($cnum,$cdom);
	} else {
	$chome = &domain($cdom,'primary');
	}
	}
	if ($cdom && $chome && ($chome ne 'no_host')) {
	if ((ref($paramsref) eq 'HASH') &&
	(ref($inforef) eq 'HASH')) {
	my $rep;
	if (grep { $_ eq $chome } &current_machine_ids()) {
	# domain information is hosted on this machine
	$rep =
	&LONCAPA::Lond::sign_lti_payload($cdom,$cnum,$crsdef,$type,
	$context,$url,$ltinum,$keynum,
	$perlvar{'lonVersion'},
	$paramsref,$inforef);
	if (ref($rep) eq 'HASH') {
	return ('ok',$rep);
	}
	} else {
	my ($escurl,$params,$info);
	$escurl = &escape($url);
	if (ref($paramsref) eq 'HASH') {
	$params = &freeze_escape($paramsref);
	}
	if (ref($inforef) eq 'HASH') {
	$info = &freeze_escape($inforef);
	}
	$rep=&reply("encrypt:signlti:$cdom:$cnum:$crsdef:$type:$context:$escurl:$ltinum:$keynum:$params:$info",$chome);
	}
	if (($rep eq '') \|\| ($rep =~ /^con_lost\|error\|no_such_host\|unknown_cmd/i)) {
	return ();
	} elsif (($inforef->{'respfmt'} eq 'to_post_body') \|\|
	($inforef->{'respfmt'} eq 'to_authorization_header')) {
	return ('ok',$rep);
	} else {
	my %returnhash;
	foreach my $item (split(/\&/,$rep)) {
	my ($name,$value)=split(/\=/,$item);
	$returnhash{&unescape($name)}=&thaw_unescape($value);
	}
	return('ok',\%returnhash);
	}
	} else {
	return ();
	}
	} else {
	return ();
	&logthis("sign_lti failed - no homeserver and/or domain ($cdom) ($chome)");
	}
	}

# -------------------------------------------------- Non-critical communication	# -------------------------------------------------- Non-critical communication
sub subreply {	sub subreply {
my ($cmd,$server)=@_;	my ($cmd,$server)=@_;
Line 456 sub reply {	Line 520 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') \|\|
	($subcmd eq 'put')) {
	(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') \|\| ($subcmd eq 'put')) {
	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 669 sub check_for_valid_session {	Line 752 sub check_for_valid_session {
$lonid=$cookies{$secure};	$lonid=$cookies{$secure};
} elsif (exists($cookies{$name})) {	} elsif (exists($cookies{$name})) {
$lonid=$cookies{$name};	$lonid=$cookies{$name};
} elsif (exists($cookies{$linkname})) {	} elsif ((exists($cookies{$linkname})) && ($ENV{'SERVER_PORT'} != 443)) {
$lonid=$cookies{$linkname};	$lonid=$cookies{$linkname};
} elsif (exists($cookies{$pubname})) {	} elsif (exists($cookies{$pubname})) {
$lonid=$cookies{$pubname};	$lonid=$cookies{$pubname};
Line 709 sub check_for_valid_session {	Line 792 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;
}	}

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

return $handle;	return $handle;
}	}
Line 745 sub timed_flock {	Line 833 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 898 sub userload {	Line 1017 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 915 sub userload {	Line 1035 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
: $userloadpercent;	: $userloadpercent;
my ($uint_dom,$remotesessions);	my ($uint_dom,$remotesessions);
if (($udom ne '') && (&domain($udom) ne '')) {	if (($udom ne '') && (&domain($udom) ne '')) {
my $uprimary_id = &Apache::lonnet::domain($udom,'primary');	my $uprimary_id = &domain($udom,'primary');
$uint_dom = &Apache::lonnet::internet_dom($uprimary_id);	$uint_dom = &internet_dom($uprimary_id);
my %udomdefaults = &Apache::lonnet::get_domain_defaults($udom);	my %udomdefaults = &get_domain_defaults($udom);
$remotesessions = $udomdefaults{'remotesessions'};	$remotesessions = $udomdefaults{'remotesessions'};
}	}
my $spareshash = &this_host_spares($udom);	my $spareshash = &this_host_spares($udom);
Line 953 sub spareserver {	Line 1073 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};
	}
	my $alias = &use_proxy_alias($r,$spare_server);
	$hostname = $alias if ($alias ne '');
$spare_server = $protocol.'://'.$hostname;	$spare_server = $protocol.'://'.$hostname;
}	}
}	}
Line 1026 sub find_existing_session {	Line 1148 sub find_existing_session {
return;	return;
}	}

	sub delusersession {
	my ($lonid,$udom,$uname) = @_;
	my $uprimary_id = &domain($udom,'primary');
	my $uintdom = &internet_dom($uprimary_id);
	my $intdom = &internet_dom($lonid);
	my $serverhomedom = &host_domain($lonid);
	if (($uintdom ne '') && ($uintdom eq $intdom)) {
	return &reply(join(':','delusersession',
	map {&escape($_)} ($udom,$uname)),$lonid);
	}
	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 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 {
	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:'.&escape($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 1049 sub choose_server {	Line 1268 sub choose_server {
unless (defined($cached)) {	unless (defined($cached)) {
my $cachetime = 606024;	my $cachetime = 606024;
my %domconfig =	my %domconfig =
&Apache::lonnet::get_dom('configuration',['loadbalancing'],$udom);	&get_dom('configuration',['loadbalancing'],$udom);
if (ref($domconfig{'loadbalancing'}) eq 'HASH') {	if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
$balancers = &do_cache_new('loadbalancing',$udom,$domconfig{'loadbalancing'},	$balancers = &do_cache_new('loadbalancing',$udom,$domconfig{'loadbalancing'},
$cachetime);	$cachetime);
Line 1061 sub choose_server {	Line 1280 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 1092 sub choose_server {	Line 1311 sub choose_server {
return ($login_host,$hostname,$portal_path,$isredirect,$lowest_load);	return ($login_host,$hostname,$portal_path,$isredirect,$lowest_load);
}	}

	sub get_course_sessions {
	my ($cnum,$cdom,$lastactivity) = @_;
	my %servers = &internet_dom_servers($cdom);
	my %returnhash;
	foreach my $server (sort(keys(%servers))) {
	my $rep = &reply("coursesessions:$cdom:$cnum:$lastactivity",$server);
	my @pairs=split(/\&/,$rep);
	unless (($rep eq 'unknown_cmd') \|\| ($rep =~ /^error/)) {
	foreach my $item (@pairs) {
	my ($key,$value)=split(/=/,$item,2);
	$key = &unescape($key);
	next if ($key =~ /^error: 2 /);
	if (exists($returnhash{$key})) {
	next if ($value < $returnhash{$key});
	}
	$returnhash{$key}=$value;
	}
	}
	}
	return %returnhash;
	}

# --------------------------------------------- Try to change a user's password	# --------------------------------------------- Try to change a user's password

sub changepass {	sub changepass {
Line 1127 sub changepass {	Line 1368 sub changepass {
} elsif ($answer =~ "invalid_client") {	} elsif ($answer =~ "invalid_client") {
&logthis("$server refused to change $uname in $udom password because ".	&logthis("$server refused to change $uname in $udom password because ".
"it was a reset by e-mail originating from an invalid server.");	"it was a reset by e-mail originating from an invalid server.");
	} elsif ($answer =~ "^prioruse") {
	&logthis("$server refused to change $uname in $udom password because ".
	"the password had been used before");
}	}
return $answer;	return $answer;
}	}
Line 1136 sub changepass {	Line 1380 sub changepass {
sub queryauthenticate {	sub queryauthenticate {
my ($uname,$udom)=@_;	my ($uname,$udom)=@_;
my $uhome=&homeserver($uname,$udom);	my $uhome=&homeserver($uname,$udom);
if (!$uhome) {	if ((!$uhome) \|\| ($uhome eq 'no_host')) {
&logthis("User $uname at $udom is unknown when looking for authentication mechanism");	&logthis("User $uname at $udom is unknown when looking for authentication mechanism");
return 'no_host';	return 'no_host';
}	}
Line 1185 sub authenticate {	Line 1429 sub authenticate {
}	}
if ($answer eq 'non_authorized') {	if ($answer eq 'non_authorized') {
&logthis("User $uname at $udom rejected by $uhome");	&logthis("User $uname at $udom rejected by $uhome");
return 'no_host';	return 'no_host';
}	}
&logthis("User $uname at $udom threw error $answer when checking authentication mechanism");	&logthis("User $uname at $udom threw error $answer when checking authentication mechanism");
return 'no_host';	return 'no_host';
}	}

	sub can_switchserver {
	my ($udom,$home) = @_;
	my ($canswitch,@intdoms);
	my $internet_names = &get_internet_names($home);
	if (ref($internet_names) eq 'ARRAY') {
	@intdoms = @{$internet_names};
	}
	my $uint_dom = &internet_dom(&domain($udom,'primary'));
	if ($uint_dom ne '' && grep(/^\Q$uint_dom\E$/,@intdoms)) {
	$canswitch = 1;
	} else {
	my $serverhomeID = &get_server_homeID(&hostname($home));
	my $serverhomedom = &host_domain($serverhomeID);
	my %defdomdefaults = &get_domain_defaults($serverhomedom);
	my %udomdefaults = &get_domain_defaults($udom);
	my $remoterev = &get_server_loncaparev('',$home);
	$canswitch = &can_host_session($udom,$home,$remoterev,
	$udomdefaults{'remotesessions'},
	$defdomdefaults{'hostedsessions'});
	}
	return $canswitch;
	}

sub can_host_session {	sub can_host_session {
my ($udom,$lonhost,$remoterev,$remotesessions,$hostedsessions) = @_;	my ($udom,$lonhost,$remoterev,$remotesessions,$hostedsessions) = @_;
my $canhost = 1;	my $canhost = 1;
my $host_idn = &Apache::lonnet::internet_dom($lonhost);	my $host_idn = &internet_dom($lonhost);
if (ref($remotesessions) eq 'HASH') {	if (ref($remotesessions) eq 'HASH') {
if (ref($remotesessions->{'excludedomain'}) eq 'ARRAY') {	if (ref($remotesessions->{'excludedomain'}) eq 'ARRAY') {
if (grep(/^\Q$host_idn\E$/,@{$remotesessions->{'excludedomain'}})) {	if (grep(/^\Q$host_idn\E$/,@{$remotesessions->{'excludedomain'}})) {
Line 1230 sub can_host_session {	Line 1497 sub can_host_session {
}	}
if ($canhost) {	if ($canhost) {
if (ref($hostedsessions) eq 'HASH') {	if (ref($hostedsessions) eq 'HASH') {
my $uprimary_id = &Apache::lonnet::domain($udom,'primary');	my $uprimary_id = &domain($udom,'primary');
my $uint_dom = &Apache::lonnet::internet_dom($uprimary_id);	my $uint_dom = &internet_dom($uprimary_id);
if (ref($hostedsessions->{'excludedomain'}) eq 'ARRAY') {	if (ref($hostedsessions->{'excludedomain'}) eq 'ARRAY') {
if (($uint_dom ne '') &&	if (($uint_dom ne '') &&
(grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'excludedomain'}}))) {	(grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'excludedomain'}}))) {
Line 1265 sub spare_can_host {	Line 1532 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 1314 sub spares_for_offload {	Line 1590 sub spares_for_offload {
} else {	} else {
my $cachetime = 606024;	my $cachetime = 606024;
my %domconfig =	my %domconfig =
&Apache::lonnet::get_dom('configuration',['usersessions'],$dom_in_use);	&get_dom('configuration',['usersessions'],$dom_in_use);
if (ref($domconfig{'usersessions'}) eq 'HASH') {	if (ref($domconfig{'usersessions'}) eq 'HASH') {
if (ref($domconfig{'usersessions'}{'spares'}) eq 'HASH') {	if (ref($domconfig{'usersessions'}{'spares'}) eq 'HASH') {
if (ref($domconfig{'usersessions'}{'spares'}{$lonhost_in_use}) eq 'HASH') {	if (ref($domconfig{'usersessions'}{'spares'}{$lonhost_in_use}) eq 'HASH') {
Line 1363 sub get_lonbalancer_config {	Line 1639 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 = &domain($udom,'primary');
my $uintdom = &Apache::lonnet::internet_dom($uprimary_id);	my $uintdom = &internet_dom($uprimary_id);
my $intdom = &Apache::lonnet::internet_dom($lonhost);	my $intdom = &internet_dom($lonhost);
my $serverhomedom = &host_domain($lonhost);	my $serverhomedom = &host_domain($lonhost);
my $domneedscache;	my $domneedscache;
my $cachetime = 606024;	my $cachetime = 606024;
Line 1382 sub check_loadbalancing {	Line 1658 sub check_loadbalancing {
my ($result,$cached)=&is_cached_new('loadbalancing',$dom_in_use);	my ($result,$cached)=&is_cached_new('loadbalancing',$dom_in_use);
unless (defined($cached)) {	unless (defined($cached)) {
my %domconfig =	my %domconfig =
&Apache::lonnet::get_dom('configuration',['loadbalancing'],$dom_in_use);	&get_dom('configuration',['loadbalancing'],$dom_in_use);
if (ref($domconfig{'loadbalancing'}) eq 'HASH') {	if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
$result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime);	$result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime);
} else {	} else {
Line 1390 sub check_loadbalancing {	Line 1666 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 1443 sub check_loadbalancing {	Line 1719 sub check_loadbalancing {
($result,$cached)=&is_cached_new('loadbalancing',$serverhomedom);	($result,$cached)=&is_cached_new('loadbalancing',$serverhomedom);
unless (defined($cached)) {	unless (defined($cached)) {
my %domconfig =	my %domconfig =
&Apache::lonnet::get_dom('configuration',['loadbalancing'],$serverhomedom);	&get_dom('configuration',['loadbalancing'],$serverhomedom);
if (ref($domconfig{'loadbalancing'}) eq 'HASH') {	if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
$result = &do_cache_new('loadbalancing',$serverhomedom,$domconfig{'loadbalancing'},$cachetime);	$result = &do_cache_new('loadbalancing',$serverhomedom,$domconfig{'loadbalancing'},$cachetime);
} else {	} else {
Line 1451 sub check_loadbalancing {	Line 1727 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 1483 sub check_loadbalancing {	Line 1759 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 1517 sub check_loadbalancing {	Line 1793 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});
}	}
}	}
}	}
}	}
}	}
return ($is_balancer,$otherserver);	if (($is_balancer) && (!$homeintdom)) {
	undef($setcookie);
	}
	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 1539 sub check_balancer_result {	Line 1817 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 1569 sub get_loadbalancer_targets {	Line 1852 sub get_loadbalancer_targets {
}	}
} elsif ($rule_in_effect eq 'externalbalancer') {	} elsif ($rule_in_effect eq 'externalbalancer') {
my %domconfig =	my %domconfig =
&Apache::lonnet::get_dom('configuration',['loadbalancing'],$udom);	&get_dom('configuration',['loadbalancing'],$udom);
if (ref($domconfig{'loadbalancing'}) eq 'HASH') {	if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
if ($domconfig{'loadbalancing'}{'lonhost'} ne '') {	if ($domconfig{'loadbalancing'}{'lonhost'} ne '') {
if (&hostname($domconfig{'loadbalancing'}{'lonhost'}) ne '') {	if (&hostname($domconfig{'loadbalancing'}{'lonhost'}) ne '') {
Line 1629 sub trusted_domains {	Line 1912 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');
my $intcalldom = &Apache::lonnet::internet_dom($callprimary);	my $intcalldom = &internet_dom($callprimary);
if ($intcalldom eq '') {	if ($intcalldom eq '') {
return ($trusted,$untrusted);	return ($trusted,$untrusted);
}	}

my ($trustconfig,$cached)=&Apache::lonnet::is_cached_new('trust',$calldom);	my ($trustconfig,$cached)=&is_cached_new('trust',$calldom);
unless (defined($cached)) {	unless (defined($cached)) {
my %domconfig = &Apache::lonnet::get_dom('configuration',['trust'],$calldom);	my %domconfig = &get_dom('configuration',['trust'],$calldom);
&Apache::lonnet::do_cache_new('trust',$calldom,$domconfig{'trust'},3600);	&do_cache_new('trust',$calldom,$domconfig{'trust'},3600);
$trustconfig = $domconfig{'trust'};	$trustconfig = $domconfig{'trust'};
}	}
if (ref($trustconfig)) {	if (ref($trustconfig)) {
Line 1651 sub trusted_domains {	Line 1934 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 1685 sub trusted_domains {	Line 1969 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 1943 sub dump_dom {	Line 2227 sub dump_dom {
# ------------------------------------------ get items from domain db files	# ------------------------------------------ get items from domain db files

sub get_dom {	sub get_dom {
my ($namespace,$storearr,$udom,$uhome)=@_;	my ($namespace,$storearr,$udom,$uhome,$encrypt)=@_;
return if ($udom eq 'public');	return if ($udom eq 'public');
my $items='';	my $items='';
foreach my $item (@$storearr) {	foreach my $item (@$storearr) {
Line 1967 sub get_dom {	Line 2251 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
	$rep = &LONCAPA::Lond::get_dom("getdom:$udom:$namespace:$items");
} else {	} else {
$rep=&reply("getdom:$udom:$namespace:$items",$uhome);	if ($encrypt) {
	$rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome);
	} else {
	$rep=&reply("getdom:$udom:$namespace:$items",$uhome);
	}
}	}
my %returnhash;	my %returnhash;
if ($rep eq '' \|\| $rep =~ /^error: 2 /) {	if ($rep eq '' \|\| $rep =~ /^error: 2 /) {
Line 1994 sub get_dom {	Line 2283 sub get_dom {
# -------------------------------------------- put items in domain db files	# -------------------------------------------- put items in domain db files

sub put_dom {	sub put_dom {
my ($namespace,$storehash,$udom,$uhome)=@_;	my ($namespace,$storehash,$udom,$uhome,$encrypt)=@_;
if (!$udom) {	if (!$udom) {
$udom=$env{'user.domain'};	$udom=$env{'user.domain'};
if (defined(&domain($udom,'primary'))) {	if (defined(&domain($udom,'primary'))) {
Line 2015 sub put_dom {	Line 2304 sub put_dom {
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';	$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
}	}
$items=~s/\&$//;	$items=~s/\&$//;
if ($namespace =~ /^enc/) {	if ($encrypt) {
return &reply("encrypt:putdom:$udom:$namespace:$items",$uhome);	return &reply("encrypt:putdom:$udom:$namespace:$items",$uhome);
} else {	} else {
return &reply("putdom:$udom:$namespace:$items",$uhome);	return &reply("putdom:$udom:$namespace:$items",$uhome);
Line 2053 sub del_dom {	Line 2342 sub del_dom {
}	}
}	}

	sub store_dom {
	my ($storehash,$id,$namespace,$dom,$home,$encrypt) = @_;
	$$storehash{'ip'}=&get_requestor_ip();
	$$storehash{'host'}=$perlvar{'lonHostID'};
	my $namevalue='';
	foreach my $key (keys(%{$storehash})) {
	$namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
	}
	$namevalue=~s/\&$//;
	if (grep { $_ eq $home } current_machine_ids()) {
	return LONCAPA::Lond::store_dom("storedom:$dom:$namespace:$id:$namevalue");
	} else {
	if ($namespace eq 'private') {
	return 'refused';
	} elsif ($encrypt) {
	return reply("encrypt:storedom:$dom:$namespace:$id:$namevalue",$home);
	} else {
	return reply("storedom:$dom:$namespace:$id:$namevalue",$home);
	}
	}
	}

	sub restore_dom {
	my ($id,$namespace,$dom,$home,$encrypt) = @_;
	my $answer;
	if (grep { $_ eq $home } current_machine_ids()) {
	$answer = LONCAPA::Lond::restore_dom("restoredom:$dom:$namespace:$id");
	} elsif ($namespace ne 'private') {
	if ($encrypt) {
	$answer=&reply("encrypt:restoredom:$dom:$namespace:$id",$home);
	} else {
	$answer=&reply("restoredom:$dom:$namespace:$id",$home);
	}
	}
	my %returnhash=();
	unless (($answer eq '') \|\| ($answer eq 'con_lost') \|\| ($answer eq 'refused') \|\|
	($answer eq 'unknown_cmd') \|\| ($answer eq 'rejected')) {
	foreach my $line (split(/\&/,$answer)) {
	my ($name,$value)=split(/\=/,$line);
	$returnhash{&unescape($name)}=&thaw_unescape($value);
	}
	my $version;
	for ($version=1;$version<=$returnhash{'version'};$version++) {
	foreach my $item (split(/\:/,$returnhash{$version.':keys'})) {
	$returnhash{$item}=$returnhash{$version.':'.$item};
	}
	}
	}
	return %returnhash;
	}

# ----------------------------------construct domainconfig user for a domain	# ----------------------------------construct domainconfig user for a domain
sub get_domainconfiguser {	sub get_domainconfiguser {
my ($udom) = @_;	my ($udom) = @_;
Line 2062 sub get_domainconfiguser {	Line 2402 sub get_domainconfiguser {
sub retrieve_inst_usertypes {	sub retrieve_inst_usertypes {
my ($udom) = @_;	my ($udom) = @_;
my (%returnhash,@order);	my (%returnhash,@order);
my %domdefs = &Apache::lonnet::get_domain_defaults($udom);	my %domdefs = &get_domain_defaults($udom);
if ((ref($domdefs{'inststatustypes'}) eq 'HASH') &&	if ((ref($domdefs{'inststatustypes'}) eq 'HASH') &&
(ref($domdefs{'inststatusorder'}) eq 'ARRAY')) {	(ref($domdefs{'inststatusorder'}) eq 'ARRAY')) {
return ($domdefs{'inststatustypes'},$domdefs{'inststatusorder'});	return ($domdefs{'inststatustypes'},$domdefs{'inststatusorder'});
Line 2095 sub retrieve_inst_usertypes {	Line 2435 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 2112 sub inst_directory_query {	Line 2452 sub inst_directory_query {
if ($homeserver ne '') {	if ($homeserver ne '') {
unless ($homeserver eq $perlvar{'lonHostID'}) {	unless ($homeserver eq $perlvar{'lonHostID'}) {
if ($srch->{'srchby'} eq 'email') {	if ($srch->{'srchby'} eq 'email') {
my $lcrev = &get_server_loncaparev(undef,$homeserver);	my $lcrev = &get_server_loncaparev($udom,$homeserver);
my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);	my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);
if (($major eq '' && $minor eq '') \|\| ($major < 2) \|\|	if (($major eq '' && $minor eq '') \|\| ($major < 2) \|\|
(($major == 2) && ($minor < 12))) {	(($major == 2) && ($minor < 12))) {
Line 2163 sub usersearch {	Line 2503 sub usersearch {
if (&host_domain($tryserver) eq $dom) {	if (&host_domain($tryserver) eq $dom) {
unless ($tryserver eq $perlvar{'lonHostID'}) {	unless ($tryserver eq $perlvar{'lonHostID'}) {
if ($srch->{'srchby'} eq 'email') {	if ($srch->{'srchby'} eq 'email') {
my $lcrev = &get_server_loncaparev(undef,$tryserver);	my $lcrev = &get_server_loncaparev($dom,$tryserver);
my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);	my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);
next if (($major eq '' && $minor eq '') \|\| ($major < 2) \|\|	next if (($major eq '' && $minor eq '') \|\| ($major < 2) \|\|
(($major == 2) && ($minor < 12)));	(($major == 2) && ($minor < 12)));
Line 2333 sub inst_rulecheck {	Line 2673 sub inst_rulecheck {
$response=&unescape(&reply('instselfcreatecheck:'.	$response=&unescape(&reply('instselfcreatecheck:'.
&escape($udom).':'.&escape($uname).	&escape($udom).':'.&escape($uname).
':'.$rulestr,$homeserver));	':'.$rulestr,$homeserver));
	} elsif ($item eq 'unamemap') {
	$response=&unescape(&reply('instunamemapcheck:'.
	&escape($udom).':'.&escape($uname).
	':'.$rulestr,$homeserver));
}	}
if ($response ne 'refused') {	if ($response ne 'refused') {
my @pairs=split(/\&/,$response);	my @pairs=split(/\&/,$response);
Line 2362 sub inst_userrules {	Line 2706 sub inst_userrules {
} elsif ($check eq 'email') {	} elsif ($check eq 'email') {
$response=&reply('instemailrules:'.&escape($udom),	$response=&reply('instemailrules:'.&escape($udom),
$homeserver);	$homeserver);
	} elsif ($check eq 'unamemap') {
	$response=&reply('unamemaprules:'.&escape($udom),
	$homeserver);
} else {	} else {
$response=&reply('instuserrules:'.&escape($udom),	$response=&reply('instuserrules:'.&escape($udom),
$homeserver);	$homeserver);
Line 2403 sub get_domain_defaults {	Line 2750 sub get_domain_defaults {
}	}
my %domdefaults;	my %domdefaults;
my %domconfig =	my %domconfig =
&Apache::lonnet::get_dom('configuration',['defaults','quotas',	&get_dom('configuration',['defaults','quotas',
'requestcourses','inststatus',	'requestcourses','inststatus',
'coursedefaults','usersessions',	'coursedefaults','usersessions',
'requestauthor','selfenrollment',	'requestauthor','selfenrollment',
'coursecategories','ssl','autoenroll',	'coursecategories','ssl','autoenroll',
'trust','helpsettings'],$domain);	'trust','helpsettings','wafproxy',
	'ltisec','toolsec','domexttool',
	'exttool','privacy'],$domain);
my @coursetypes = ('official','unofficial','community','textbook','placement');	my @coursetypes = ('official','unofficial','community','textbook','placement');
if (ref($domconfig{'defaults'}) eq 'HASH') {	if (ref($domconfig{'defaults'}) eq 'HASH') {
$domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};	$domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};
Line 2417 sub get_domain_defaults {	Line 2766 sub get_domain_defaults {
$domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'};	$domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'};
$domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'};	$domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'};
$domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'};	$domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'};
	$domdefaults{'portal_def_email'} = $domconfig{'defaults'}{'portal_def_email'};
	$domdefaults{'portal_def_web'} = $domconfig{'defaults'}{'portal_def_web'};
$domdefaults{'intauth_cost'} = $domconfig{'defaults'}{'intauth_cost'};	$domdefaults{'intauth_cost'} = $domconfig{'defaults'}{'intauth_cost'};
$domdefaults{'intauth_switch'} = $domconfig{'defaults'}{'intauth_switch'};	$domdefaults{'intauth_switch'} = $domconfig{'defaults'}{'intauth_switch'};
$domdefaults{'intauth_check'} = $domconfig{'defaults'}{'intauth_check'};	$domdefaults{'intauth_check'} = $domconfig{'defaults'}{'intauth_check'};
	$domdefaults{'unamemap_rule'} = $domconfig{'defaults'}{'unamemap_rule'};
} else {	} else {
$domdefaults{'lang_def'} = &domain($domain,'lang_def');	$domdefaults{'lang_def'} = &domain($domain,'lang_def');
$domdefaults{'auth_def'} = &domain($domain,'auth_def');	$domdefaults{'auth_def'} = &domain($domain,'auth_def');
Line 2457 sub get_domain_defaults {	Line 2809 sub get_domain_defaults {
if (ref($domconfig{'coursedefaults'}) eq 'HASH') {	if (ref($domconfig{'coursedefaults'}) eq 'HASH') {
$domdefaults{'canuse_pdfforms'} = $domconfig{'coursedefaults'}{'canuse_pdfforms'};	$domdefaults{'canuse_pdfforms'} = $domconfig{'coursedefaults'}{'canuse_pdfforms'};
$domdefaults{'usejsme'} = $domconfig{'coursedefaults'}{'usejsme'};	$domdefaults{'usejsme'} = $domconfig{'coursedefaults'}{'usejsme'};
	$domdefaults{'inline_chem'} = $domconfig{'coursedefaults'}{'inline_chem'};
$domdefaults{'uselcmath'} = $domconfig{'coursedefaults'}{'uselcmath'};	$domdefaults{'uselcmath'} = $domconfig{'coursedefaults'}{'uselcmath'};
if (ref($domconfig{'coursedefaults'}{'postsubmit'}) eq 'HASH') {	if (ref($domconfig{'coursedefaults'}{'postsubmit'}) eq 'HASH') {
$domdefaults{'postsubmit'} = $domconfig{'coursedefaults'}{'postsubmit'}{'client'};	$domdefaults{'postsubmit'} = $domconfig{'coursedefaults'}{'postsubmit'}{'client'};
Line 2476 sub get_domain_defaults {	Line 2829 sub get_domain_defaults {
$domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}{$type};	$domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}{$type};
}	}
}	}
	if (ref($domconfig{'coursedefaults'}{'domexttool'}) eq 'HASH') {
	$domdefaults{$type.'domexttool'} = $domconfig{'coursedefaults'}{'domexttool'}{$type};
	} else {
	$domdefaults{$type.'domexttool'} = 1;
	}
	if (ref($domconfig{'coursedefaults'}{'exttool'}) eq 'HASH') {
	$domdefaults{$type.'exttool'} = $domconfig{'coursedefaults'}{'exttool'}{$type};
	} else {
	$domdefaults{$type.'exttool'} = 0;
	}
}	}
if (ref($domconfig{'coursedefaults'}{'canclone'}) eq 'HASH') {	if (ref($domconfig{'coursedefaults'}{'canclone'}) eq 'HASH') {
if (ref($domconfig{'coursedefaults'}{'canclone'}{'instcode'}) eq 'ARRAY') {	if (ref($domconfig{'coursedefaults'}{'canclone'}{'instcode'}) eq 'ARRAY') {
Line 2489 sub get_domain_defaults {	Line 2852 sub get_domain_defaults {
}	}
if ($domconfig{'coursedefaults'}{'texengine'}) {	if ($domconfig{'coursedefaults'}{'texengine'}) {
$domdefaults{'texengine'} = $domconfig{'coursedefaults'}{'texengine'};	$domdefaults{'texengine'} = $domconfig{'coursedefaults'}{'texengine'};
}	}
	if (exists($domconfig{'coursedefaults'}{'ltiauth'})) {
	$domdefaults{'crsltiauth'} = $domconfig{'coursedefaults'}{'ltiauth'};
	}
}	}
if (ref($domconfig{'usersessions'}) eq 'HASH') {	if (ref($domconfig{'usersessions'}) eq 'HASH') {
if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') {	if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') {
Line 2501 sub get_domain_defaults {	Line 2867 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 2533 sub get_domain_defaults {	Line 2902 sub get_domain_defaults {
if (ref($domconfig{'coursecategories'}) eq 'HASH') {	if (ref($domconfig{'coursecategories'}) eq 'HASH') {
$domdefaults{'catauth'} = 'std';	$domdefaults{'catauth'} = 'std';
$domdefaults{'catunauth'} = 'std';	$domdefaults{'catunauth'} = 'std';
if ($domconfig{'coursecategories'}{'auth'}) {	if ($domconfig{'coursecategories'}{'auth'}) {
$domdefaults{'catauth'} = $domconfig{'coursecategories'}{'auth'};	$domdefaults{'catauth'} = $domconfig{'coursecategories'}{'auth'};
}	}
if ($domconfig{'coursecategories'}{'unauth'}) {	if ($domconfig{'coursecategories'}{'unauth'}) {
Line 2561 sub get_domain_defaults {	Line 2930 sub get_domain_defaults {
}	}
if (ref($domconfig{'autoenroll'}) eq 'HASH') {	if (ref($domconfig{'autoenroll'}) eq 'HASH') {
$domdefaults{'autofailsafe'} = $domconfig{'autoenroll'}{'autofailsafe'};	$domdefaults{'autofailsafe'} = $domconfig{'autoenroll'}{'autofailsafe'};
	$domdefaults{'failsafe'} = $domconfig{'autoenroll'}{'failsafe'};
}	}
if (ref($domconfig{'helpsettings'}) eq 'HASH') {	if (ref($domconfig{'helpsettings'}) eq 'HASH') {
$domdefaults{'submitbugs'} = $domconfig{'helpsettings'}{'submitbugs'};	$domdefaults{'submitbugs'} = $domconfig{'helpsettings'}{'submitbugs'};
Line 2568 sub get_domain_defaults {	Line 2938 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};
	}
	}
	}
	if (ref($domconfig{'ltisec'}) eq 'HASH') {
	if (ref($domconfig{'ltisec'}{'encrypt'}) eq 'HASH') {
	$domdefaults{'linkprotenc_crs'} = $domconfig{'ltisec'}{'encrypt'}{'crs'};
	$domdefaults{'linkprotenc_dom'} = $domconfig{'ltisec'}{'encrypt'}{'dom'};
	$domdefaults{'ltienc_consumers'} = $domconfig{'ltisec'}{'encrypt'}{'consumers'};
	}
	if (ref($domconfig{'ltisec'}{'private'}) eq 'HASH') {
	if (ref($domconfig{'ltisec'}{'private'}{'keys'}) eq 'ARRAY') {
	$domdefaults{'ltiprivhosts'} = $domconfig{'ltisec'}{'private'}{'keys'};
	}
	}
	}
	if (ref($domconfig{'toolsec'}) eq 'HASH') {
	if (ref($domconfig{'toolsec'}{'encrypt'}) eq 'HASH') {
	$domdefaults{'toolenc_crs'} = $domconfig{'toolsec'}{'encrypt'}{'crs'};
	$domdefaults{'toolenc_dom'} = $domconfig{'toolsec'}{'encrypt'}{'dom'};
	}
	if (ref($domconfig{'toolsec'}{'private'}) eq 'HASH') {
	if (ref($domconfig{'toolsec'}{'private'}{'keys'}) eq 'ARRAY') {
	$domdefaults{'toolprivhosts'} = $domconfig{'toolsec'}{'private'}{'keys'};
	}
	}
	}
	if (ref($domconfig{'privacy'}) eq 'HASH') {
	if (ref($domconfig{'privacy'}{'approval'}) eq 'HASH') {
	foreach my $domtype ('instdom','extdom') {
	if (ref($domconfig{'privacy'}{'approval'}{$domtype}) eq 'HASH') {
	foreach my $roletype ('domain','author','course','community') {
	if ($domconfig{'privacy'}{'approval'}{$domtype}{$roletype} eq 'user') {
	$domdefaults{'userapprovals'} = 1;
	last;
	}
	}
	}
	last if ($domdefaults{'userapprovals'});
	}
	}
	}
&do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);	&do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);
return %domdefaults;	return %domdefaults;
}	}

	sub get_dom_cats {
	my ($dom) = @_;
	return unless (&domain($dom));
	my ($cats,$cached)=&is_cached_new('cats',$dom);
	unless (defined($cached)) {
	my %domconfig = &get_dom('configuration',['coursecategories'],$dom);
	if (ref($domconfig{'coursecategories'}) eq 'HASH') {
	if (ref($domconfig{'coursecategories'}{'cats'}) eq 'HASH') {
	%{$cats} = %{$domconfig{'coursecategories'}{'cats'}};
	} else {
	$cats = {};
	}
	} else {
	$cats = {};
	}
	&do_cache_new('cats',$dom,$cats,3600);
	}
	return $cats;
	}

	sub get_dom_instcats {
	my ($dom) = @_;
	return unless (&domain($dom));
	my ($instcats,$cached)=&is_cached_new('instcats',$dom);
	unless (defined($cached)) {
	my (%coursecodes,%codes,@codetitles,%cat_titles,%cat_order);
	my $totcodes = &retrieve_instcodes(\%coursecodes,$dom);
	if ($totcodes > 0) {
	my $caller = 'global';
	if (&auto_instcode_format($caller,$dom,\%coursecodes,\%codes,
	\@codetitles,\%cat_titles,\%cat_order) eq 'ok') {
	$instcats = {
	totcodes => $totcodes,
	codes => \%codes,
	codetitles => \@codetitles,
	cat_titles => \%cat_titles,
	cat_order => \%cat_order,
	};
	&do_cache_new('instcats',$dom,$instcats,3600);
	}
	}
	}
	return $instcats;
	}

	sub retrieve_instcodes {
	my ($coursecodes,$dom) = @_;
	my $totcodes;
	my %courses = &courseiddump($dom,'.',1,'.','.','.',undef,undef,'Course');
	foreach my $course (keys(%courses)) {
	if (ref($courses{$course}) eq 'HASH') {
	if ($courses{$course}{'inst_code'} ne '') {
	$$coursecodes{$course} = $courses{$course}{'inst_code'};
	$totcodes ++;
	}
	}
	}
	return $totcodes;
	}

sub course_portal_url {	sub course_portal_url {
my ($cnum,$cdom) = @_;	my ($cnum,$cdom,$r) = @_;
my $chome = &homeserver($cnum,$cdom);	my $chome = &homeserver($cnum,$cdom);
my $hostname = &hostname($chome);	my $hostname = &hostname($chome);
my $protocol = $protocol{$chome};	my $protocol = $protocol{$chome};
Line 2583 sub course_portal_url {	Line 3058 sub course_portal_url {
if ($domdefaults{'portal_def'}) {	if ($domdefaults{'portal_def'}) {
$firsturl = $domdefaults{'portal_def'};	$firsturl = $domdefaults{'portal_def'};
} else {	} else {
	my $alias = &use_proxy_alias($r,$chome);
	$hostname = $alias if ($alias ne '');
$firsturl = $protocol.'://'.$hostname;	$firsturl = $protocol.'://'.$hostname;
}	}
return $firsturl;	return $firsturl;
}	}

	sub url_prefix {
	my ($r,$dom,$home,$context) = @_;
	my $prefix;
	my %domdefs = &get_domain_defaults($dom);
	if ($domdefs{'portal_def'} && $domdefs{'portal_def_'.$context}) {
	if ($domdefs{'portal_def'} =~ m{^(https?://[^/]+)}) {
	$prefix = $1;
	}
	}
	if ($prefix eq '') {
	my $hostname = &hostname($home);
	my $protocol = $protocol{$home};
	$protocol = 'http' if ($protocol{$home} ne 'https');
	my $alias = &use_proxy_alias($r,$home);
	$hostname = $alias if ($alias ne '');
	$prefix = $protocol.'://'.$hostname;
	}
	return $prefix;
	}

	# --------------------------------------------- Get domain config for passwords

	sub get_passwdconf {
	my ($dom) = @_;
	my (%passwdconf,$gotconf,$lookup);
	my ($result,$cached)=&is_cached_new('passwdconf',$dom);
	if (defined($cached)) {
	if (ref($result) eq 'HASH') {
	%passwdconf = %{$result};
	$gotconf = 1;
	}
	}
	unless ($gotconf) {
	my %domconfig = &get_dom('configuration',['passwords'],$dom);
	if (ref($domconfig{'passwords'}) eq 'HASH') {
	%passwdconf = %{$domconfig{'passwords'}};
	}
	my $cachetime = 246060;
	&do_cache_new('passwdconf',$dom,\%passwdconf,$cachetime);
	}
	return %passwdconf;
	}

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

sub assign_access_key {	sub assign_access_key {
Line 2736 sub courseid_to_courseurl {	Line 3256 sub courseid_to_courseurl {
return "/$cdom/$cnum";	return "/$cdom/$cnum";
}	}

my %courseinfo=&Apache::lonnet::coursedescription($courseid);	my %courseinfo=&coursedescription($courseid);
if (exists($courseinfo{'num'})) {	if (exists($courseinfo{'num'})) {
return "/$courseinfo{'domain'}/$courseinfo{'num'}";	return "/$courseinfo{'domain'}/$courseinfo{'num'}";
}	}
Line 2934 sub userenvironment {	Line 3454 sub userenvironment {
# ---------------------------------------------------------- Get a studentphoto	# ---------------------------------------------------------- Get a studentphoto
sub studentphoto {	sub studentphoto {
my ($udom,$unam,$ext) = @_;	my ($udom,$unam,$ext) = @_;
my $home=&Apache::lonnet::homeserver($unam,$udom);	my $home=&homeserver($unam,$udom);
if (defined($env{'request.course.id'})) {	if (defined($env{'request.course.id'})) {
if ($env{'course.'.$env{'request.course.id'}.'.internal.showphoto'}) {	if ($env{'course.'.$env{'request.course.id'}.'.internal.showphoto'}) {
if ($udom eq $env{'course.'.$env{'request.course.id'}.'.domain'}) {	if ($udom eq $env{'course.'.$env{'request.course.id'}.'.domain'}) {
return(&retrievestudentphoto($udom,$unam,$ext));	return(&retrievestudentphoto($udom,$unam,$ext));
} else {	} else {
my ($result,$perm_reqd)=	my ($result,$perm_reqd)=
&Apache::lonnet::auto_photo_permission($unam,$udom);	&auto_photo_permission($unam,$udom);
if ($result eq 'ok') {	if ($result eq 'ok') {
if (!($perm_reqd eq 'yes')) {	if (!($perm_reqd eq 'yes')) {
return(&retrievestudentphoto($udom,$unam,$ext));	return(&retrievestudentphoto($udom,$unam,$ext));
Line 2951 sub studentphoto {	Line 3471 sub studentphoto {
}	}
} else {	} else {
my ($result,$perm_reqd) =	my ($result,$perm_reqd) =
&Apache::lonnet::auto_photo_permission($unam,$udom);	&auto_photo_permission($unam,$udom);
if ($result eq 'ok') {	if ($result eq 'ok') {
if (!($perm_reqd eq 'yes')) {	if (!($perm_reqd eq 'yes')) {
return(&retrievestudentphoto($udom,$unam,$ext));	return(&retrievestudentphoto($udom,$unam,$ext));
Line 2963 sub studentphoto {	Line 3483 sub studentphoto {

sub retrievestudentphoto {	sub retrievestudentphoto {
my ($udom,$unam,$ext,$type) = @_;	my ($udom,$unam,$ext,$type) = @_;
my $home=&Apache::lonnet::homeserver($unam,$udom);	my $home=&homeserver($unam,$udom);
my $ret=&Apache::lonnet::reply("studentphoto:$udom:$unam:$ext:$type",$home);	my $ret=&reply("studentphoto:$udom:$unam:$ext:$type",$home);
if ($ret eq 'ok') {	if ($ret eq 'ok') {
my $url="/uploaded/$udom/$unam/internal/studentphoto.$ext";	my $url="/uploaded/$udom/$unam/internal/studentphoto.$ext";
if ($type eq 'thumbnail') {	if ($type eq 'thumbnail') {
$url="/uploaded/$udom/$unam/internal/studentphoto_tn.$ext";	$url="/uploaded/$udom/$unam/internal/studentphoto_tn.$ext";
}	}
my $tokenurl=&Apache::lonnet::tokenwrapper($url);	my $tokenurl=&tokenwrapper($url);
return $tokenurl;	return $tokenurl;
} else {	} else {
if ($type eq 'thumbnail') {	if ($type eq 'thumbnail') {
Line 3130 sub repcopy {	Line 3650 sub repcopy {
}	}
}	}

	# ------------------------------------------------- Unsubscribe from a resource

	sub unsubscribe {
	my ($fname) = @_;
	my $answer;
	if ($fname=~/\/(aboutme\|syllabus\|bulletinboard\|smppg)$/) { return $answer; }
	$fname=~s/[\n\r]//g;
	my $author=$fname;
	$author=~s/\/home\/httpd\/html\/res\/([^\/])\/([^\/]).*/$1\/$2/;
	my ($udom,$uname)=split(/\//,$author);
	my $home=homeserver($uname,$udom);
	if ($home eq 'no_host') {
	$answer = 'no_host';
	} elsif (grep { $_ eq $home } &current_machine_ids()) {
	$answer = 'home';
	} else {
	my $defdom = $perlvar{'lonDefDomain'};
	if (&will_trust('content',$defdom,$udom)) {
	$answer = reply("unsub:$fname",$home);
	} else {
	$answer = 'untrusted';
	}
	}
	return $answer;
	}

# ------------------------------------------------ Get server side include body	# ------------------------------------------------ Get server side include body
sub ssi_body {	sub ssi_body {
my ($filelink,%form)=@_;	my ($filelink,%form)=@_;
Line 3158 sub ssi_body {	Line 3704 sub ssi_body {
# --------------------------------------------------------- Server Side Include	# --------------------------------------------------------- Server Side Include

sub absolute_url {	sub absolute_url {
my ($host_name) = @_;	my ($host_name,$unalias,$keep_proto) = @_;
my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://');	my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://');
if ($host_name eq '') {	if ($host_name eq '') {
$host_name = $ENV{'SERVER_NAME'};	$host_name = $ENV{'SERVER_NAME'};
}	}
	if ($unalias) {
	my $alias = &get_proxy_alias();
	if ($alias eq $host_name) {
	my $lonhost = $perlvar{'lonHostID'};
	my $hostname = &hostname($lonhost);
	my $lcproto;
	if (($keep_proto) \|\| ($hostname eq '')) {
	$lcproto = $protocol;
	} else {
	$lcproto = $protocol{$lonhost};
	$lcproto = 'http' if ($lcproto ne 'https');
	$lcproto .= '://';
	}
	unless ($hostname eq '') {
	return $lcproto.$hostname;
	}
	}
	}
return $protocol.$host_name;	return $protocol.$host_name;
}	}

Line 3179 sub absolute_url {	Line 3743 sub absolute_url {
sub ssi {	sub ssi {

my ($fn,%form)=@_;	my ($fn,%form)=@_;
my $request;	my ($host,$request,$response);
	$host = &absolute_url('',1);

$form{'no_update_last_known'}=1;	$form{'no_update_last_known'}=1;
&Apache::lonenc::check_encrypt(\$fn);	&Apache::lonenc::check_encrypt(\$fn);
if (%form) {	if (%form) {
$request=new HTTP::Request('POST',&absolute_url().$fn);	$request=new HTTP::Request('POST',$host.$fn);
$request->content(join('&',map {	$request->content(join('&',map {
my $name = escape($_);	my $name = escape($_);
"$name=" . ( ref($form{$_}) eq 'ARRAY'	"$name=" . ( ref($form{$_}) eq 'ARRAY'
Line 3192 sub ssi {	Line 3757 sub ssi {
: &escape($form{$_}) );	: &escape($form{$_}) );
} keys(%form)));	} keys(%form)));
} else {	} else {
$request=new HTTP::Request('GET',&absolute_url().$fn);	$request=new HTTP::Request('GET',$host.$fn);
}	}

$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 '') &&
	(&allowed('mgr',$env{'request.course.id'}.
	($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:'')))) {
	$islocal = 1;
	}
	$response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,
	'','','',$islocal);

if (wantarray) {	if (wantarray) {
return ($response->content, $response);	return ($response->content, $response);
Line 3235 sub remove_stale_resfile {	Line 3810 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 3265 sub remove_stale_resfile {	Line 3840 sub remove_stale_resfile {
$stale = 1;	$stale = 1;
}	}
if ($stale) {	if ($stale) {
unlink($fname);	if (unlink($fname)) {
if ($uri!~/\.meta$/) {	if ($uri!~/\.meta$/) {
unlink($fname.'.meta');	if (-e $fname.'.meta') {
	unlink($fname.'.meta');
	}
	}
	my $unsubresult = &unsubscribe($fname);
	unless ($unsubresult eq 'ok') {
	&logthis("no unsub of $fname from $homeserver, reason: $unsubresult");
	}
	$removed = 1;
}	}
&reply("unsub:$fname",$homeserver);
$removed = 1;
}	}
}	}
}	}
Line 3338 sub can_edit_resource {	Line 3919 sub can_edit_resource {
}	}

if ($env{'request.course.id'}) {	if ($env{'request.course.id'}) {
my $crsedit = &Apache::lonnet::allowed('mdc',$env{'request.course.id'});	my $crsedit = &allowed('mdc',$env{'request.course.id'});
if ($group ne '') {	if ($group ne '') {
# if this is a group homepage or group bulletin board, check group privs	# if this is a group homepage or group bulletin board, check group privs
my $allowed = 0;	my $allowed = 0;
Line 3367 sub can_edit_resource {	Line 3948 sub can_edit_resource {
}	}
} else {	} else {
if ($resurl =~ m{^/?adm/viewclasslist$}) {	if ($resurl =~ m{^/?adm/viewclasslist$}) {
unless (&Apache::lonnet::allowed('opa',$env{'request.course.id'})) {	unless (&allowed('opa',$env{'request.course.id'})) {
return;	return;
}	}
} elsif (!$crsedit) {	} elsif (!$crsedit) {
	if ($env{'request.role'} =~ m{^st\./$cdom/$cnum}) {
#	#
# No edit allowed where CC has switched to student role.	# No edit allowed where CC has switched to student role.
#	#
return;	return;
	} elsif (($resurl !~ m{^/res/$match_domain/$match_username/}) \|\|
	($resurl =~ m{^/res/lib/templates/})) {
	return;
	}
}	}
}	}
}	}
Line 3400 sub can_edit_resource {	Line 3986 sub can_edit_resource {
$forceedit = 1;	$forceedit = 1;
}	}
$cfile = $resurl;	$cfile = $resurl;
} elsif (($resurl ne '') && (&is_on_map($resurl))) {	} elsif (($resurl ne '') && (&is_on_map($resurl))) {
if ($resurl =~ m{^/adm/$match_domain/$match_username/\d+/smppg\|bulletinboard$}) {	if ($resurl =~ m{^/adm/$match_domain/$match_username/\d+/smppg\|bulletinboard$}) {
$incourse = 1;	$incourse = 1;
if ($env{'form.forceedit'}) {	if ($env{'form.forceedit'}) {
Line 3420 sub can_edit_resource {	Line 4006 sub can_edit_resource {
$forceedit = 1;	$forceedit = 1;
}	}
$cfile = $resurl;	$cfile = $resurl;
	} elsif (($resurl =~ m{^/ext/}) && ($symb ne '')) {
	my ($map,$id,$res) = &decode_symb($symb);
	if ($map =~ /\.page$/) {
	$incourse = 1;
	if ($env{'form.forceedit'}) {
	$forceview = 1;
	$cfile = $map;
	} else {
	$forceedit = 1;
	$cfile = '/adm/wrapper'.$resurl;
	}
	}
} elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) {	} elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) {
$incourse = 1;	$incourse = 1;
if ($env{'form.forceedit'}) {	if ($env{'form.forceedit'}) {
Line 3445 sub can_edit_resource {	Line 4043 sub can_edit_resource {
$cfile = $template;	$cfile = $template;
}	}
} elsif (($resurl =~ m{^/adm/wrapper/ext/}) && ($env{'form.folderpath'} =~ /^supplemental/)) {	} elsif (($resurl =~ m{^/adm/wrapper/ext/}) && ($env{'form.folderpath'} =~ /^supplemental/)) {
$incourse = 1;	$incourse = 1;
if ($env{'form.forceedit'}) {	if ($env{'form.forceedit'}) {
$forceview = 1;	$forceview = 1;
} else {	} else {
$forceedit = 1;	$forceedit = 1;
}	}
$cfile = $resurl;	$cfile = $resurl;
} elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) && ($env{'form.folderpath'} =~ /^supplemental/)) {	} elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) && ($env{'form.folderpath'} =~ /^supplemental/)) {
$incourse = 1;	$incourse = 1;
if ($env{'form.forceedit'}) {	if ($env{'form.forceedit'}) {
Line 3714 sub clean_filename {	Line 4312 sub clean_filename {
}	}
# Replace spaces by underscores	# Replace spaces by underscores
$fname=~s/\s+/\_/g;	$fname=~s/\s+/\_/g;
	# Transliterate non-ascii text to ascii
	my $lang = &Apache::lonlocal::current_language();
	$fname = &LONCAPA::transliterate::fname_to_ascii($fname,$lang);
# Replace all other weird characters by nothing	# Replace all other weird characters by nothing
$fname=~s{[^/\w\.\-]}{}g;	$fname=~s{[^/\w\.\-]}{}g;
# 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;
}	}

# This Function checks if an Image's dimensions exceed either $resizewidth (width)	# This Function checks if an Image's dimensions exceed either $resizewidth (width)
# or $resizeheight (height) - both pixels. If so, the image is scaled to produce an	# or $resizeheight (height) - both pixels. If so, the image is scaled to produce an
# image with the same aspect ratio as the original, but with dimensions which do	# image with the same aspect ratio as the original, but with dimensions which do
Line 3763 sub resizeImage {	Line 4369 sub resizeImage {
# input: $formname - the contents of the file are in $env{"form.$formname"}	# input: $formname - the contents of the file are in $env{"form.$formname"}
# the desired filename is in $env{"form.$formname.filename"}	# the desired filename is in $env{"form.$formname.filename"}
# $context - possible values: coursedoc, existingfile, overwrite,	# $context - possible values: coursedoc, existingfile, overwrite,
# canceloverwrite, or ''.	# canceloverwrite, scantron, toollogo or ''.
# if 'coursedoc': upload to the current course	# if 'coursedoc': upload to the current course
# if 'existingfile': write file to tmp/overwrites directory	# if 'existingfile': write file to tmp/overwrites directory
# if 'canceloverwrite': delete file written to tmp/overwrites directory	# if 'canceloverwrite': delete file written to tmp/overwrites directory
# $context is passed as argument to &finishuserfileupload	# $context is passed as argument to &finishuserfileupload
# $subdir - directory in userfile to store the file into	# $subdir - directory in userfile to store the file into
# $parser - instruction to parse file for objects ($parser = parse)	# $parser - instruction to parse file for objects ($parser = parse) or
	# if context is 'scantron', $parser is hashref of csv column mapping
	# (e.g.,{ PaperID => 0, LastName => 1, FirstName => 2, ID => 3,
	# Section => 4, CODE => 5, FirstQuestion => 9 }).
# $allfiles - reference to hash for embedded objects	# $allfiles - reference to hash for embedded objects
# $codebase - reference to hash for codebase of java objects	# $codebase - reference to hash for codebase of java objects
# $desuname - username for permanent storage of uploaded file	# $destuname - username for permanent storage of uploaded file
# $dsetudom - domain for permanaent storage of uploaded file	# $destudom - domain for permanaent storage of uploaded file
# $thumbwidth - width (pixels) of thumbnail to make for uploaded image	# $thumbwidth - width (pixels) of thumbnail to make for uploaded image
# $thumbheight - height (pixels) of thumbnail to make for uploaded image	# $thumbheight - height (pixels) of thumbnail to make for uploaded image
# $resizewidth - width (pixels) to which to resize uploaded image	# $resizewidth - width (pixels) to which to resize uploaded image
Line 3792 sub userfileupload {	Line 4401 sub userfileupload {
$fname=&clean_filename($fname);	$fname=&clean_filename($fname);
# See if there is anything left	# See if there is anything left
unless ($fname) { return 'error: no uploaded file'; }	unless ($fname) { return 'error: no uploaded file'; }
	# If filename now begins with a . prepend unix timestamp _ milliseconds
	if ($fname =~ /^\./) {
	my ($s,$usec) = &gettimeofday();
	while (length($usec) < 6) {
	$usec = '0'.$usec;
	}
	$fname = $s.'_'.substr($usec,0,3).$fname;
	}
# Files uploaded to help request form, or uploaded to "create course" page are handled differently	# Files uploaded to help request form, or uploaded to "create course" page are handled differently
if ((($formname eq 'screenshot') && ($subdir eq 'helprequests')) \|\|	if ((($formname eq 'screenshot') && ($subdir eq 'helprequests')) \|\|
(($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) \|\|	(($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) \|\|
Line 3959 sub finishuserfileupload {	Line 4576 sub finishuserfileupload {
}	}
}	}
}	}
if ($parser eq 'parse') {	if (($context ne 'scantron') && ($parser eq 'parse')) {
if ((ref($mimetype)) && ($$mimetype eq 'text/html')) {	if ((ref($mimetype)) && ($$mimetype eq 'text/html')) {
my $parse_result = &extract_embedded_items($filepath.'/'.$file,	my $parse_result = &extract_embedded_items($filepath.'/'.$file,
$allfiles,$codebase);	$allfiles,$codebase);
Line 3968 sub finishuserfileupload {	Line 4585 sub finishuserfileupload {
' for embedded media: '.$parse_result);	' for embedded media: '.$parse_result);
}	}
}	}
	} elsif (($context eq 'scantron') && (ref($parser) eq 'HASH')) {
	my $format = $env{'form.scantron_format'};
	&bubblesheet_converter($docudom,$filepath.'/'.$file,$parser,$format);
}	}
if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {	if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {
my $input = $filepath.'/'.$file;	my $input = $filepath.'/'.$file;
my $output = $filepath.'/'.'tn-'.$file;	my $output = $filepath.'/'.'tn-'.$file;
	my $makethumb;
my $thumbsize = $thumbwidth.'x'.$thumbheight;	my $thumbsize = $thumbwidth.'x'.$thumbheight;
my @args = ('convert','-sample',$thumbsize,$input,$output);	if ($context eq 'toollogo') {
system({$args[0]} @args);	my ($fullwidth,$fullheight) = &check_dimensions($input);
if (-e $filepath.'/'.'tn-'.$file) {	if ($fullwidth ne '' && $fullheight ne '') {
$fetchthumb = 1;	if ($fullwidth > $thumbwidth && $fullheight > $thumbheight) {
	$makethumb = 1;
	}
	}
	} else {
	$makethumb = 1;
	}
	if ($makethumb) {
	my @args = ('convert','-sample',$thumbsize,$input,$output);
	system({$args[0]} @args);
	if (-e $filepath.'/'.'tn-'.$file) {
	$fetchthumb = 1;
	}
}	}
}	}

Line 4208 sub embedded_dependency {	Line 4841 sub embedded_dependency {
return;	return;
}	}

	sub check_dimensions {
	my ($inputfile) = @_;
	my ($fullwidth,$fullheight);
	if (($inputfile =~ m\|^[/\w.\-]+$\|) && (-e $inputfile)) {
	my $mm = new File::MMagic;
	my $mime_type = $mm->checktype_filename($inputfile);
	if ($mime_type =~ m{^image/}) {
	if (open(PIPE,"identify $inputfile 2>&1 \|")) {
	my $imageinfo = <PIPE>;
	if (!close(PIPE)) {
	&Apache::lonnet::logthis("Failed to close PIPE opened to retrieve image information for $inputfile");
	}
	chomp($imageinfo);
	my ($fullsize) =
	($imageinfo =~ /^\Q$inputfile\E\s+\w+\s+(\d+x\d+)/);
	if ($fullsize) {
	($fullwidth,$fullheight) = split(/x/,$fullsize);
	}
	}
	}
	}
	return ($fullwidth,$fullheight);
	}

	sub bubblesheet_converter {
	my ($cdom,$fullpath,$config,$format) = @_;
	if ((&domain($cdom) ne '') &&
	($fullpath =~ m{^\Q$perlvar{'lonDocRoot'}/userfiles/$cdom/\E$match_courseid/scantron_orig}) &&
	(-e $fullpath) && (ref($config) eq 'HASH') && ($format ne '')) {
	my (%csvcols,%csvoptions);
	if (ref($config->{'fields'}) eq 'HASH') {
	%csvcols = %{$config->{'fields'}};
	}
	if (ref($config->{'options'}) eq 'HASH') {
	%csvoptions = %{$config->{'options'}};
	}
	my %csvbynum = reverse(%csvcols);
	my %scantronconf = &get_scantron_config($format,$cdom);
	if (keys(%scantronconf)) {
	my %bynum = (
	$scantronconf{CODEstart} => 'CODEstart',
	$scantronconf{IDstart} => 'IDstart',
	$scantronconf{PaperID} => 'PaperID',
	$scantronconf{FirstName} => 'FirstName',
	$scantronconf{LastName} => 'LastName',
	$scantronconf{Qstart} => 'Qstart',
	);
	my @ordered;
	foreach my $item (sort { $a <=> $b } keys(%bynum)) {
	push(@ordered,$bynum{$item});
	}
	my %mapstart = (
	CODEstart => 'CODE',
	IDstart => 'ID',
	PaperID => 'PaperID',
	FirstName => 'FirstName',
	LastName => 'LastName',
	Qstart => 'FirstQuestion',
	);
	my %maplength = (
	CODEstart => 'CODElength',
	IDstart => 'IDlength',
	PaperID => 'PaperIDlength',
	FirstName => 'FirstNamelength',
	LastName => 'LastNamelength',
	);
	if (open(my $fh,'<',$fullpath)) {
	my $output;
	my %lettdig = &letter_to_digits();
	my %diglett = reverse(%lettdig);
	my $numletts = scalar(keys(%lettdig));
	my $num = 0;
	while (my $line=<$fh>) {
	$num ++;
	next if (($num == 1) && ($csvoptions{'hdr'} == 1));
	$line =~ s{[\r\n]+$}{};
	my %found;
	my @values = split(/,/,$line,-1);
	my ($qstart,$record);
	for (my $i=0; $i<@values; $i++) {
	if ((($qstart ne '') && ($i > $qstart)) \|\|
	($csvbynum{$i} eq 'FirstQuestion')) {
	if ($values[$i] eq '') {
	$values[$i] = $scantronconf{'Qoff'};
	} elsif ($scantronconf{'Qon'} eq 'number') {
	if ($values[$i] =~ /^[A-Ja-j]$/) {
	$values[$i] = $lettdig{uc($values[$i])};
	}
	} elsif ($scantronconf{'Qon'} eq 'letter') {
	if ($values[$i] =~ /^[0-9]$/) {
	$values[$i] = $diglett{$values[$i]};
	}
	} else {
	if ($values[$i] =~ /^[0-9A-Ja-j]$/) {
	my $digit;
	if ($values[$i] =~ /^[A-Ja-j]$/) {
	$digit = $lettdig{uc($values[$i])}-1;
	if ($values[$i] eq 'J') {
	$digit += $numletts;
	}
	} elsif ($values[$i] =~ /^[0-9]$/) {
	$digit = $values[$i]-1;
	if ($values[$i] eq '0') {
	$digit += $numletts;
	}
	}
	my $qval='';
	for (my $j=0; $j<$scantronconf{'Qlength'}; $j++) {
	if ($j == $digit) {
	$qval .= $scantronconf{'Qon'};
	} else {
	$qval .= $scantronconf{'Qoff'};
	}
	}
	$values[$i] = $qval;
	}
	}
	if (length($values[$i]) > $scantronconf{'Qlength'}) {
	$values[$i] = substr($values[$i],0,$scantronconf{'Qlength'});
	}
	my $numblank = $scantronconf{'Qlength'} - length($values[$i]);
	if ($numblank > 0) {
	$values[$i] .= ($scantronconf{'Qoff'} x $numblank);
	}
	if ($csvbynum{$i} eq 'FirstQuestion') {
	$qstart = $i;
	$found{$csvbynum{$i}} = $values[$i];
	} else {
	$found{'FirstQuestion'} .= $values[$i];
	}
	} elsif (exists($csvbynum{$i})) {
	if ($csvoptions{'rem'}) {
	$values[$i] =~ s/^\s+//;
	}
	if (($csvbynum{$i} eq 'PaperID') && ($csvoptions{'pad'})) {
	while (length($values[$i]) < $scantronconf{$maplength{$csvbynum{$i}}}) {
	$values[$i] = '0'.$values[$i];
	}
	}
	$found{$csvbynum{$i}} = $values[$i];
	}
	}
	foreach my $item (@ordered) {
	my $currlength = 1+length($record);
	my $numspaces = $scantronconf{$item} - $currlength;
	if ($numspaces > 0) {
	$record .= (' ' x $numspaces);
	}
	if (($mapstart{$item} ne '') && (exists($found{$mapstart{$item}}))) {
	unless ($item eq 'Qstart') {
	if (length($found{$mapstart{$item}}) > $scantronconf{$maplength{$item}}) {
	$found{$mapstart{$item}} = substr($found{$mapstart{$item}},0,$scantronconf{$maplength{$item}});
	}
	}
	$record .= $found{$mapstart{$item}};
	}
	}
	$output .= "$record\n";
	}
	close($fh);
	if ($output) {
	if (open(my $fh,'>',$fullpath)) {
	print $fh $output;
	close($fh);
	}
	}
	}
	}
	return;
	}
	}

	sub letter_to_digits {
	my %lettdig = (
	A => 1,
	B => 2,
	C => 3,
	D => 4,
	E => 5,
	F => 6,
	G => 7,
	H => 8,
	I => 9,
	J => 0,
	);
	return %lettdig;
	}

	sub get_scantron_config {
	my ($which,$cdom) = @_;
	my @lines = &get_scantronformat_file($cdom);
	my %config;
	#FIXME probably should move to XML it has already gotten a bit much now
	foreach my $line (@lines) {
	my ($name,$descrip)=split(/:/,$line);
	if ($name ne $which ) { next; }
	chomp($line);
	my @config=split(/:/,$line);
	$config{'name'}=$config[0];
	$config{'description'}=$config[1];
	$config{'CODElocation'}=$config[2];
	$config{'CODEstart'}=$config[3];
	$config{'CODElength'}=$config[4];
	$config{'IDstart'}=$config[5];
	$config{'IDlength'}=$config[6];
	$config{'Qstart'}=$config[7];
	$config{'Qlength'}=$config[8];
	$config{'Qoff'}=$config[9];
	$config{'Qon'}=$config[10];
	$config{'PaperID'}=$config[11];
	$config{'PaperIDlength'}=$config[12];
	$config{'FirstName'}=$config[13];
	$config{'FirstNamelength'}=$config[14];
	$config{'LastName'}=$config[15];
	$config{'LastNamelength'}=$config[16];
	$config{'BubblesPerRow'}=$config[17];
	last;
	}
	return %config;
	}

	sub get_scantronformat_file {
	my ($cdom) = @_;
	if ($cdom eq '') {
	$cdom= $env{'course.'.$env{'request.course.id'}.'.domain'};
	}
	my %domconfig = &get_dom('configuration',['scantron'],$cdom);
	my $gottab = 0;
	my @lines;
	if (ref($domconfig{'scantron'}) eq 'HASH') {
	if ($domconfig{'scantron'}{'scantronformat'} ne '') {
	my $formatfile = &getfile($perlvar{'lonDocRoot'}.$domconfig{'scantron'}{'scantronformat'});
	if ($formatfile ne '-1') {
	@lines = split("\n",$formatfile,-1);
	$gottab = 1;
	}
	}
	}
	if (!$gottab) {
	my $confname = $cdom.'-domainconfig';
	my $default = $perlvar{'lonDocRoot'}.'/res/'.$cdom.'/'.$confname.'/default.tab';
	my $formatfile = &getfile($default);
	if ($formatfile ne '-1') {
	@lines = split("\n",$formatfile,-1);
	$gottab = 1;
	}
	}
	if (!$gottab) {
	my @domains = &current_machine_domains();
	if (grep(/^\Q$cdom\E$/,@domains)) {
	if (open(my $fh,'<',$perlvar{'lonTabDir'}.'/scantronformat.tab')) {
	@lines = <$fh>;
	close($fh);
	}
	} else {
	if (open(my $fh,'<',$perlvar{'lonTabDir'}.'/default_scantronformat.tab')) {
	@lines = <$fh>;
	close($fh);
	}
	}
	chomp(@lines);
	}
	return @lines;
	}

sub removeuploadedurl {	sub removeuploadedurl {
my ($url)=@_;	my ($url)=@_;
my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);	my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);
Line 4325 sub flushcourselogs {	Line 5223 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 remain 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 4351 sub flushcourselogs {	Line 5272 sub flushcourselogs {
foreach my $entry (keys(%userrolehash)) {	foreach my $entry (keys(%userrolehash)) {
my ($role,$uname,$udom,$runame,$rudom,$rsec)=	my ($role,$uname,$udom,$runame,$rudom,$rsec)=
split(/\:/,$entry);	split(/\:/,$entry);
if (&Apache::lonnet::put('nohist_userroles',	if (&put('nohist_userroles',
{ $role.':'.$uname.':'.$udom.':'.$rsec => $userrolehash{$entry} },	{ $role.':'.$uname.':'.$udom.':'.$rsec => $userrolehash{$entry} },
$rudom,$runame) eq 'ok') {	$rudom,$runame) eq 'ok') {
delete $userrolehash{$entry};	delete $userrolehash{$entry};
Line 4434 sub courseacclog {	Line 5355 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 4514 sub userrolelog {	Line 5439 sub userrolelog {
}	}

sub courserolelog {	sub courserolelog {
my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,$context)=@_;	my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,
	$context,$othdomby,$requester)=@_;
if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) {	if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) {
my $cdom = $1;	my $cdom = $1;
my $cnum = $2;	my $cnum = $2;
Line 4527 sub courserolelog {	Line 5453 sub courserolelog {
selfenroll => $selfenroll,	selfenroll => $selfenroll,
context => $context,	context => $context,
);	);
	if ($othdomby) {
	if ($othdomby eq 'othdombydc') {
	$storehash{'approval'} = 'domain';
	} elsif ($othdomby eq 'othdombyuser') {
	$storehash{'approval'} = 'user';
	}
	if ($requester ne '') {
	$storehash{'requester'} = $requester;
	}
	}
if ($trole eq 'gr') {	if ($trole eq 'gr') {
$namespace = 'groupslog';	$namespace = 'groupslog';
$storehash{'group'} = $sec;	$storehash{'group'} = $sec;
Line 4543 sub courserolelog {	Line 5479 sub courserolelog {
}	}

sub domainrolelog {	sub domainrolelog {
my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_;	my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,
	$context,$othdomby,$requester)=@_;
if ($area =~ m{^/($match_domain)/$}) {	if ($area =~ m{^/($match_domain)/$}) {
my $cdom = $1;	my $cdom = $1;
my $domconfiguser = &Apache::lonnet::get_domainconfiguser($cdom);	my $domconfiguser = &get_domainconfiguser($cdom);
my $namespace = 'rolelog';	my $namespace = 'rolelog';
my %storehash = (	my %storehash = (
role => $trole,	role => $trole,
Line 4554 sub domainrolelog {	Line 5491 sub domainrolelog {
end => $tend,	end => $tend,
context => $context,	context => $context,
);	);
	if ($othdomby) {
	if ($othdomby eq 'othdombydc') {
	$storehash{'approval'} = 'domain';
	} elsif ($othdomby eq 'othdombyuser') {
	$storehash{'approval'} = 'user';
	}
	if ($requester ne '') {
	$storehash{'requester'} = $requester;
	}
	}
&write_log('domain',$namespace,\%storehash,$delflag,$username,	&write_log('domain',$namespace,\%storehash,$delflag,$username,
$domain,$domconfiguser,$cdom);	$domain,$domconfiguser,$cdom);
}	}
Line 4562 sub domainrolelog {	Line 5509 sub domainrolelog {
}	}

sub coauthorrolelog {	sub coauthorrolelog {
my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_;	my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,
	$context,$othdomby,$requester)=@_;
if ($area =~ m{^/($match_domain)/($match_username)$}) {	if ($area =~ m{^/($match_domain)/($match_username)$}) {
my $audom = $1;	my $audom = $1;
my $auname = $2;	my $auname = $2;
Line 4573 sub coauthorrolelog {	Line 5521 sub coauthorrolelog {
end => $tend,	end => $tend,
context => $context,	context => $context,
);	);
	if ($othdomby) {
	if ($othdomby eq 'othdombydc') {
	$storehash{'approval'} = 'domain';
	} elsif ($othdomby eq 'othdombyuser') {
	$storehash{'approval'} = 'user';
	}
	if ($requester ne '') {
	$storehash{'requester'} = $requester;
	}
	}
&write_log('author',$namespace,\%storehash,$delflag,$username,	&write_log('author',$namespace,\%storehash,$delflag,$username,
$domain,$auname,$audom);	$domain,$auname,$audom);
}	}
Line 4777 sub get_my_adhocroles {	Line 5735 sub get_my_adhocroles {
} elsif ($cid =~ /^($match_domain)_($match_courseid)$/) {	} elsif ($cid =~ /^($match_domain)_($match_courseid)$/) {
$cdom = $1;	$cdom = $1;
$cnum = $2;	$cnum = $2;
%info = &Apache::lonnet::get('environment',['internal.coursecode'],	%info = &get('environment',['internal.coursecode'],
$cdom,$cnum);	$cdom,$cnum);
}	}
if (($info{'internal.coursecode'} ne '') && ($checkreg)) {	if (($info{'internal.coursecode'} ne '') && ($checkreg)) {
my $user = $env{'user.name'}.':'.$env{'user.domain'};	my $user = $env{'user.name'}.':'.$env{'user.domain'};
Line 5105 sub extract_lastaccess {	Line 6063 sub extract_lastaccess {

sub dcmailput {	sub dcmailput {
my ($domain,$msgid,$message,$server)=@_;	my ($domain,$msgid,$message,$server)=@_;
my $status = &Apache::lonnet::critical(	my $status = &critical(
'dcmailput:'.$domain.':'.&escape($msgid).'='.	'dcmailput:'.$domain.':'.&escape($msgid).'='.
&escape($message),$server);	&escape($message),$server);
return $status;	return $status;
Line 5231 sub set_first_access {	Line 6189 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 5247 sub set_first_access {	Line 6210 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 5508 sub tmpreset {	Line 6474 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 5545 sub tmpstore {	Line 6511 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 5589 sub tmprestore {	Line 6555 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 5645 sub store {	Line 6611 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 5681 sub cstore {	Line 6647 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 6099 sub course_adhocrole_privs {	Line 7065 sub course_adhocrole_privs {
$full{$priv} = $restrict;	$full{$priv} = $restrict;
}	}
foreach my $item (split(/,/,$overrides{"internal.adhocpriv.$rolename"})) {	foreach my $item (split(/,/,$overrides{"internal.adhocpriv.$rolename"})) {
next if ($item eq '');	next if ($item eq '');
my ($rule,$rest) = split(/=/,$item);	my ($rule,$rest) = split(/=/,$item);
next unless (($rule eq 'off') \|\| ($rule eq 'on'));	next unless (($rule eq 'off') \|\| ($rule eq 'on'));
foreach my $priv (split(/:/,$rest)) {	foreach my $priv (split(/:/,$rest)) {
if ($priv ne '') {	if ($priv ne '') {
if ($rule eq 'off') {	if ($rule eq 'off') {
$possremove{$priv} = 1;	$possremove{$priv} = 1;
} else {	} else {
$possadd{$priv} = 1;	$possadd{$priv} = 1;
}	}
}	}
}	}
}	}
foreach my $priv (sort(keys(%full))) {	foreach my $priv (sort(keys(%full))) {
if (exists($currprivs{$priv})) {	if (exists($currprivs{$priv})) {
unless (exists($possremove{$priv})) {	unless (exists($possremove{$priv})) {
$storeprivs{$priv} = $currprivs{$priv};	$storeprivs{$priv} = $currprivs{$priv};
}	}
} elsif (exists($possadd{$priv})) {	} elsif (exists($possadd{$priv})) {
$storeprivs{$priv} = $full{$priv};	$storeprivs{$priv} = $full{$priv};
}	}
}	}
$coursepriv = ':'.join(':',map { $_.'&'.$storeprivs{$_}; } sort(keys(%storeprivs)));	$coursepriv = ':'.join(':',map { $_.'&'.$storeprivs{$_}; } sort(keys(%storeprivs)));
}	}
return $coursepriv;	return $coursepriv;
}	}

sub group_roleprivs {	sub group_roleprivs {
Line 6387 sub set_adhoc_privileges {	Line 7353 sub set_adhoc_privileges {
my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%rolehash);	my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%rolehash);
&appenv(\%userroles,[$role,'cm']);	&appenv(\%userroles,[$role,'cm']);
&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec);	&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec);
unless ($caller eq 'constructaccess' && $env{'request.course.id'}) {	unless (($caller eq 'constructaccess' && $env{'request.course.id'}) \|\|
	($caller eq 'tiny')) {
&appenv( {'request.role' => $spec,	&appenv( {'request.role' => $spec,
'request.role.domain' => $dcdom,	'request.role.domain' => $dcdom,
'request.course.sec' => $sec,	'request.course.sec' => $sec,
Line 6463 sub unserialize {	Line 7430 sub unserialize {
# see Lond::dump_with_regexp	# see Lond::dump_with_regexp
# if $escapedkeys hash keys won't get unescaped.	# if $escapedkeys hash keys won't get unescaped.
sub dump {	sub dump {
my ($namespace,$udomain,$uname,$regexp,$range,$escapedkeys)=@_;	my ($namespace,$udomain,$uname,$regexp,$range,$escapedkeys,$encrypt)=@_;
if (!$udomain) { $udomain=$env{'user.domain'}; }	if (!$udomain) { $udomain=$env{'user.domain'}; }
if (!$uname) { $uname=$env{'user.name'}; }	if (!$uname) { $uname=$env{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);	my $uhome=&homeserver($uname,$udomain);
Line 6479 sub dump {	Line 7446 sub dump {
$uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});	$uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});
return %{unserialize($reply, $escapedkeys)};	return %{unserialize($reply, $escapedkeys)};
}	}
my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);	my $rep;
	if ($encrypt) {
	$rep=&reply("encrypt:edump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
	} else {
	$rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
	}
my @pairs=split(/\&/,$rep);	my @pairs=split(/\&/,$rep);
my %returnhash=();	my %returnhash=();
if (!($rep =~ /^error/ )) {	if (!($rep =~ /^error/ )) {
Line 6626 sub inc {	Line 7598 sub inc {
# --------------------------------------------------------------- put interface	# --------------------------------------------------------------- put interface

sub put {	sub put {
my ($namespace,$storehash,$udomain,$uname)=@_;	my ($namespace,$storehash,$udomain,$uname,$encrypt)=@_;
if (!$udomain) { $udomain=$env{'user.domain'}; }	if (!$udomain) { $udomain=$env{'user.domain'}; }
if (!$uname) { $uname=$env{'user.name'}; }	if (!$uname) { $uname=$env{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);	my $uhome=&homeserver($uname,$udomain);
Line 6635 sub put {	Line 7607 sub put {
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';	$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
}	}
$items=~s/\&$//;	$items=~s/\&$//;
return &reply("put:$udomain:$uname:$namespace:$items",$uhome);	if ($encrypt) {
	return &reply("encrypt:put:$udomain:$uname:$namespace:$items",$uhome);
	} else {
	return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
	}
}	}

# ------------------------------------------------------------ newput interface	# ------------------------------------------------------------ newput interface
Line 6675 sub putstore {	Line 7651 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'});
&Apache::lonnet::courselog($symb.':'.$uname.':'.$udomain.':PUTSTORE:'.$namevalue);	&courselog($symb.':'.$uname.':'.$udomain.':PUTSTORE:'.$namevalue);
}	}
if ($reply eq 'unknown_cmd') {	if ($reply eq 'unknown_cmd') {
# gfall back to way things use to be done	# gfall back to way things use to be done
Line 6829 sub get_timebased_id {	Line 7806 sub get_timebased_id {
my $tries = 0;	my $tries = 0;

# attempt to get lock on nohist_$namespace file	# attempt to get lock on nohist_$namespace file
my $gotlock = &Apache::lonnet::newput('nohist_'.$namespace,$lockhash,$cdom,$cnum);	my $gotlock = &newput('nohist_'.$namespace,$lockhash,$cdom,$cnum);
while (($gotlock ne 'ok') && $tries <$locktries) {	while (($gotlock ne 'ok') && $tries <$locktries) {
$tries ++;	$tries ++;
sleep 1;	sleep 1;
$gotlock = &Apache::lonnet::newput('nohist_'.$namespace,$lockhash,$cdom,$cnum);	$gotlock = &newput('nohist_'.$namespace,$lockhash,$cdom,$cnum);
}	}

# attempt to get unique identifier, based on current timestamp	# attempt to get unique identifier, based on current timestamp
if ($gotlock eq 'ok') {	if ($gotlock eq 'ok') {
my %inuse = &Apache::lonnet::dump('nohist_'.$namespace,$cdom,$cnum,$prefix);	my %inuse = &dump('nohist_'.$namespace,$cdom,$cnum,$prefix);
my $id = time;	my $id = time;
$newid = $id;	$newid = $id;
if ($idtype eq 'addcode') {	if ($idtype eq 'addcode') {
Line 6859 sub get_timebased_id {	Line 7836 sub get_timebased_id {
my %new_item = (	my %new_item = (
$prefix."\0".$newid => $who,	$prefix."\0".$newid => $who,
);	);
my $putresult = &Apache::lonnet::put('nohist_'.$namespace,\%new_item,	my $putresult = &put('nohist_'.$namespace,\%new_item,
$cdom,$cnum);	$cdom,$cnum);
if ($putresult ne 'ok') {	if ($putresult ne 'ok') {
undef($newid);	undef($newid);
Line 6899 sub portfolio_access {	Line 7876 sub portfolio_access {
if ($result) {	if ($result) {
my %setters;	my %setters;
if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {	if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
my ($startblock,$endblock) =	my ($startblock,$endblock,$triggerblock,$by_ip,$blockdom) =
&Apache::loncommon::blockcheck(\%setters,'port',$unum,$udom);	&Apache::loncommon::blockcheck(\%setters,'port',$clientip,$unum,$udom);
if ($startblock && $endblock) {	if (($startblock && $endblock) \|\| ($by_ip)) {
return 'B';	return 'B';
}	}
} else {	} else {
my ($startblock,$endblock) =	my ($startblock,$endblock,$triggerblock,$by_ip,$blockdom) =
&Apache::loncommon::blockcheck(\%setters,'port');	&Apache::loncommon::blockcheck(\%setters,'port',$clientip);
if ($startblock && $endblock) {	if (($startblock && $endblock) \|\| ($by_ip)) {
return 'B';	return 'B';
}	}
}	}
Line 7148 sub is_portfolio_file {	Line 8125 sub is_portfolio_file {
return;	return;
}	}

	sub is_coursetool_logo {
	my ($uri) = @_;
	if ($env{'request.course.id'}) {
	my $courseurl = &courseid_to_courseurl($env{'request.course.id'});
	if ($uri =~ m{^/*uploaded\Q$courseurl\E/toollogo/\d+/[^/]+$}) {
	return 1;
	}
	}
	return;
	}

sub usertools_access {	sub usertools_access {
my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref)=@_;	my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref)=@_;
my ($access,%tools);	my ($access,%tools);
Line 7173 sub usertools_access {	Line 8161 sub usertools_access {
blog => 1,	blog => 1,
webdav => 1,	webdav => 1,
portfolio => 1,	portfolio => 1,
	timezone => 1,
);	);
}	}
return if (!defined($tools{$tool}));	return if (!defined($tools{$tool}));
Line 7297 sub is_course_owner {	Line 8286 sub is_course_owner {
if ($env{'course.'.$cdom.'_'.$cnum.'.internal.courseowner'} eq $uname.':'.$udom) {	if ($env{'course.'.$cdom.'_'.$cnum.'.internal.courseowner'} eq $uname.':'.$udom) {
return 1;	return 1;
} else {	} else {
my %courseinfo = &Apache::lonnet::coursedescription($cdom.'/'.$cnum);	my %courseinfo = &coursedescription($cdom.'/'.$cnum);
if ($courseinfo{'internal.courseowner'} eq $uname.':'.$udom) {	if ($courseinfo{'internal.courseowner'} eq $uname.':'.$udom) {
return 1;	return 1;
}	}
Line 7308 sub is_course_owner {	Line 8297 sub is_course_owner {
}	}

sub is_advanced_user {	sub is_advanced_user {
my ($udom,$uname) = @_;	my ($udom,$uname,$nocache) = @_;
	my ($is_adv,$is_author,$use_cache,$hashid);
if ($udom ne '' && $uname ne '') {	if ($udom ne '' && $uname ne '') {
if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {	if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
if (wantarray) {	if (wantarray) {
Line 7316 sub is_advanced_user {	Line 8306 sub is_advanced_user {
} else {	} else {
return $env{'user.adv'};	return $env{'user.adv'};
}	}
	} elsif (!$nocache) {
	$use_cache = 1;
	$hashid = "$udom:$uname";
	my ($info,$cached)=&is_cached_new('isadvau',$hashid);
	if ($cached) {
	($is_adv,$is_author) = split(/:/,$info);
	if (wantarray) {
	return ($is_adv,$is_author);
	}
	return $is_adv;
	}
}	}
}	}
my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1);	my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1);
my %allroles;	my %allroles;
my ($is_adv,$is_author);
foreach my $role (keys(%roleshash)) {	foreach my $role (keys(%roleshash)) {
my ($trest,$tdomain,$trole,$sec) = split(/:/,$role);	my ($trest,$tdomain,$trole,$sec) = split(/:/,$role);
my $area = '/'.$tdomain.'/'.$trest;	my $area = '/'.$tdomain.'/'.$trest;
Line 7351 sub is_advanced_user {	Line 8351 sub is_advanced_user {
}	}
}	}
}	}
	if ($use_cache) {
	my $cachetime = 600;
	&do_cache_new('isadvau',$hashid,$is_adv.':'.$is_author,$cachetime);
	}
if (wantarray) {	if (wantarray) {
return ($is_adv,$is_author);	return ($is_adv,$is_author);
}	}
Line 7368 sub check_can_request {	Line 8372 sub check_can_request {
my @options = ('approval','validate','autolimit');	my @options = ('approval','validate','autolimit');
my $optregex = join('\|',@options);	my $optregex = join('\|',@options);
if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) {	if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) {
	my %willtrust;
foreach my $type (@{$types}) {	foreach my $type (@{$types}) {
if (&usertools_access($uname,$udom,$type,undef,	if (&usertools_access($uname,$udom,$type,undef,
'requestcourses')) {	'requestcourses')) {
Line 7387 sub check_can_request {	Line 8392 sub check_can_request {
if (ref($request_domains) eq 'HASH') {	if (ref($request_domains) eq 'HASH') {
my ($otherdom) = ($item =~ /^($match_domain):($optregex)(=?\d*)$/);	my ($otherdom) = ($item =~ /^($match_domain):($optregex)(=?\d*)$/);
if ($otherdom ne '') {	if ($otherdom ne '') {
if (ref($request_domains->{$type}) eq 'ARRAY') {	unless (exists($willtrust{$otherdom})) {
unless (grep(/^\Q$otherdom\E$/,@{$request_domains->{$type}})) {	$willtrust{$otherdom} = &will_trust('reqcrs',$env{'user.domain'},$otherdom);
	}
	if ($willtrust{$otherdom}) {
	if (ref($request_domains->{$type}) eq 'ARRAY') {
	unless (grep(/^\Q$otherdom\E$/,@{$request_domains->{$type}})) {
	push(@{$request_domains->{$type}},$otherdom);
	}
	} else {
push(@{$request_domains->{$type}},$otherdom);	push(@{$request_domains->{$type}},$otherdom);
}	}
} else {
push(@{$request_domains->{$type}},$otherdom);
}	}
}	}
}	}
Line 7462 sub customaccess {	Line 8472 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,$nodeeplinkcheck,$nodeeplinkout)=@_;
my $ver_orguri=$uri;	my $ver_orguri=$uri;
$uri=&deversion($uri);	$uri=&deversion($uri);
my $orguri=$uri;	my $orguri=$uri;
$uri=&declutter($uri);	$uri=&declutter($uri);

if ($priv eq 'evb') {	if ($priv eq 'evb') {
# Evade communication block restrictions for specified role in a course	# Evade communication block restrictions for specified role in a course or domain
if ($env{'user.priv.'.$role} =~/evb\&([^\:]*)/) {	if ($env{'user.priv.'.$role} =~/evb\&([^\:]*)/) {
return $1;	return $1;
} else {	} else {
Line 7479 sub allowed {	Line 8489 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\|ext\.tool)$}))
\|\| (($uri=~/\.meta$/) && ($uri!~m\|^uploaded/\|) ))	\|\| (($uri=~/\.meta$/) && ($uri!~m\|^uploaded/\|) ))
&& ($priv eq 'bre')) {	&& ($priv eq 'bre')) {
return 'F';	return 'F';
Line 7490 sub allowed {	Line 8500 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 7588 sub allowed {	Line 8598 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 7601 sub allowed {	Line 8611 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 7647 sub allowed {	Line 8657 sub allowed {

if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri}	if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri}
=~/\Q$priv\E\&([^\:]*)/) {	=~/\Q$priv\E\&([^\:]*)/) {
unless (($priv eq 'bro') && (!$ownaccess)) {	if ($priv eq 'mip') {
$thisallowed.=$1;	my $rem = $1;
	if (($uri ne '') && ($env{'request.course.id'} eq $uri) &&
	($env{'course.'.$env{'request.course.id'}.'.internal.courseowner'} eq $env{'user.name'}.':'.$env{'user.domain'})) {
	my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
	if ($cdom ne '') {
	my %passwdconf = &get_passwdconf($cdom);
	if (ref($passwdconf{'crsownerchg'}) eq 'HASH') {
	if (ref($passwdconf{'crsownerchg'}{'by'}) eq 'ARRAY') {
	if (@{$passwdconf{'crsownerchg'}{'by'}}) {
	my @inststatuses = split(':',$env{'environment.inststatus'});
	unless (@inststatuses) {
	@inststatuses = ('default');
	}
	foreach my $status (@inststatuses) {
	if (grep(/^\Q$status\E$/,@{$passwdconf{'crsownerchg'}{'by'}})) {
	$thisallowed.=$rem;
	}
	}
	}
	}
	}
	}
	}
	} else {
	unless (($priv eq 'bro') && (!$ownaccess)) {
	$thisallowed.=$1;
	}
}	}
}	}

Line 7661 sub allowed {	Line 8697 sub allowed {
if ($env{'user.priv.'.$env{'request.role'}.'./'}	if ($env{'user.priv.'.$env{'request.role'}.'./'}
=~/\Q$priv\E\&([^\:]*)/) {	=~/\Q$priv\E\&([^\:]*)/) {
my $value = $1;	my $value = $1;
if ($noblockcheck) {	my $deeplinkblock;
	unless ($nodeeplinkcheck) {
	$deeplinkblock = &deeplink_check($priv,$symb,$uri);
	}
	if ($deeplinkblock) {
	$thisallowed='D';
	} elsif ($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 7681 sub allowed {	Line 8723 sub allowed {
$refuri=&declutter($refuri);	$refuri=&declutter($refuri);
my ($match) = &is_on_map($refuri);	my ($match) = &is_on_map($refuri);
if ($match) {	if ($match) {
if ($noblockcheck) {	my $deeplinkblock;
	unless ($nodeeplinkcheck) {
	$deeplinkblock = &deeplink_check($priv,$symb,$refuri);
	}
	if ($deeplinkblock) {
	$thisallowed='D';
	} elsif ($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 7731 sub allowed {	Line 8779 sub allowed {

if ($env{'request.course.id'}) {	if ($env{'request.course.id'}) {

	if ($priv eq 'bre') {
	if (&is_coursetool_logo($uri)) {
	return 'F';
	}
	}

	# If this is modifying password (internal auth) domains must match for user and user's role.

	if ($priv eq 'mip') {
	if ($env{'user.domain'} eq $env{'request.role.domain'}) {
	return $thisallowed;
	} else {
	return '';
	}
	}

$courseprivid=$env{'request.course.id'};	$courseprivid=$env{'request.course.id'};
if ($env{'request.course.sec'}) {	if ($env{'request.course.sec'}) {
$courseprivid.='/'.$env{'request.course.sec'};	$courseprivid.='/'.$env{'request.course.sec'};
Line 7744 sub allowed {	Line 8808 sub allowed {
=~/\Q$priv\E\&([^\:]*)/) {	=~/\Q$priv\E\&([^\:]*)/) {
my $value = $1;	my $value = $1;
if ($priv eq 'bre') {	if ($priv eq 'bre') {
if ($noblockcheck) {	my $deeplinkblock;
	unless ($nodeeplinkcheck) {
	$deeplinkblock = &deeplink_check($priv,$symb,$uri);
	}
	if ($deeplinkblock) {
	$thisallowed = 'D';
	} elsif ($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 7760 sub allowed {	Line 8830 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 7786 sub allowed {	Line 8856 sub allowed {
=~/\Q$priv\E\&([^\:]*)/) {	=~/\Q$priv\E\&([^\:]*)/) {
my $value = $1;	my $value = $1;
if ($priv eq 'bre') {	if ($priv eq 'bre') {
if ($noblockcheck) {	my $deeplinkblock;
	unless ($nodeeplinkcheck) {
	$deeplinkblock = &deeplink_check($priv,$symb,$refuri);
	}
	if ($deeplinkblock) {
	$thisallowed = 'D';
	} elsif ($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 7831 sub allowed {	Line 8907 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 7863 sub allowed {	Line 8971 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 7875 sub allowed {	Line 8983 sub allowed {
}	}
}	}
}	}

#	#
# Rest of the restrictions depend on selected course	# Rest of the restrictions depend on selected course
#	#
Line 7934 sub allowed {	Line 9042 sub allowed {
}	}
}	}

	# Restricted for deeplinked session?

	if ($env{'request.deeplink.login'}) {
	if ($env{'acc.deeplinkout'} && !$nodeeplinkout) {
	if (!$symb) { $symb=&symbread($uri,1); }
	if (($symb) && ($env{'acc.deeplinkout'}=~/\&\Q$symb\E\&/)) {
	return '';
	}
	}
	}

# Restricted by state or randomout?	# Restricted by state or randomout?

if ($thisallowed=~/X/) {	if ($thisallowed=~/X/) {
Line 7954 sub allowed {	Line 9073 sub allowed {
return 'A';	return 'A';
} elsif ($thisallowed eq 'B') {	} elsif ($thisallowed eq 'B') {
return 'B';	return 'B';
	} elsif ($thisallowed eq 'D') {
	return 'D';
}	}
return 'F';	return 'F';
}	}
Line 7984 sub constructaccess {	Line 9105 sub constructaccess {
if (exists($env{'user.priv.au./'.$ownerdomain.'/./'})) {	if (exists($env{'user.priv.au./'.$ownerdomain.'/./'})) {
return ($ownername,$ownerdomain,$ownerhome);	return ($ownername,$ownerdomain,$ownerhome);
}	}
} else {	} elsif (&is_course($ownerdomain,$ownername)) {
# Co-author for this?	# Course Authoring Space?
if (exists($env{'user.priv.ca./'.$ownerdomain.'/'.$ownername.'./'}) \|\|
exists($env{'user.priv.aa./'.$ownerdomain.'/'.$ownername.'./'}) ) {
$ownerhome = &homeserver($ownername,$ownerdomain);
return ($ownername,$ownerdomain,$ownerhome);
}
if ($env{'request.course.id'}) {	if ($env{'request.course.id'}) {
if (($ownername eq $env{'course.'.$env{'request.course.id'}.'.num'}) &&	if (($ownername eq $env{'course.'.$env{'request.course.id'}.'.num'}) &&
($ownerdomain eq $env{'course.'.$env{'request.course.id'}.'.domain'})) {	($ownerdomain eq $env{'course.'.$env{'request.course.id'}.'.domain'})) {
Line 8000 sub constructaccess {	Line 9116 sub constructaccess {
}	}
}	}
}	}
	return '';
	} else {
	# Co-author for this?
	if (exists($env{'user.priv.ca./'.$ownerdomain.'/'.$ownername.'./'}) \|\|
	exists($env{'user.priv.aa./'.$ownerdomain.'/'.$ownername.'./'}) ) {
	$ownerhome = &homeserver($ownername,$ownerdomain);
	return ($ownername,$ownerdomain,$ownerhome);
	}
}	}

# We don't have any access right now. If we are not possibly going to do anything about this,	# We don't have any access right now. If we are not possibly going to do anything about this,
Line 8042 sub constructaccess {	Line 9166 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 8073 sub get_comm_blocks {	Line 9202 sub get_comm_blocks {
if ((defined($cached)) && (ref($blocksref) eq 'HASH')) {	if ((defined($cached)) && (ref($blocksref) eq 'HASH')) {
%commblocks = %{$blocksref};	%commblocks = %{$blocksref};
} else {	} else {
%commblocks = &Apache::lonnet::dump('comm_block',$cdom,$cnum);	%commblocks = &dump('comm_block',$cdom,$cnum);
my $cachetime = 600;	my $cachetime = 600;
&do_cache_new('comm_block',$hashid,\%commblocks,$cachetime);	&do_cache_new('comm_block',$hashid,\%commblocks,$cachetime);
}	}
Line 8084 sub get_commblock_resources {	Line 9213 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 8116 sub get_commblock_resources {	Line 9249 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 8128 sub get_commblock_resources {	Line 9260 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;
}
}
}
}
}	}
}	}
}	}
Line 8166 sub get_commblock_resources {	Line 9282 sub get_commblock_resources {
my $timesup = $first_access+$timelimit;	my $timesup = $first_access+$timelimit;
if ($timesup > $now) {	if ($timesup > $now) {
my $activeblock;	my $activeblock;
foreach my $res (@to_test) {	if ($type eq 'resource') {
if ($res->answerable()) {	if (ref($navmap)) {
$activeblock = 1;	my $res = $navmap->getBySymb($item);
last;	if ($res->answerable()) {
	$activeblock = 1;
	}
	}
	} elsif ($type eq 'map') {
	my $mapsymb = &symbread($mapname,1);
	if (($mapsymb) && (ref($navmap))) {
	my $mapres = $navmap->getBySymb($mapsymb);
	if (ref($mapres)) {
	my $first = $mapres->map_start();
	my $finish = $mapres->map_finish();
	my $it = $navmap->getIterator($first,$finish,undef,0,0);
	if (ref($it)) {
	my $res;
	while ($res = $it->next(undef,1)) {
	next unless (ref($res));
	my $symb = $res->symb();
	next if (($symb eq $mapsymb) \|\| ($symb eq ''));
	@interval=&EXT("resource.0.interval",$symb);
	if ($interval[1] eq 'map') {
	if ($res->answerable()) {
	$activeblock = 1;
	last;
	}
	}
	}
	}
	}
}	}
}	}
if ($activeblock) {	if ($activeblock) {
Line 8195 sub get_commblock_resources {	Line 9338 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 8216 sub has_comm_blocking {	Line 9369 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;
	}
}	}

	sub deeplink_check {
	my ($priv,$symb,$uri) = @_;
	return unless ($env{'request.course.id'});
	return unless ($priv eq 'bre');
	return if ($env{'request.state'} eq 'construct');
	return if ($env{'request.role.adv'});
	my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
	my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
	my (%possibles,@symbs);
	if (!$symb) {
	$symb = &symbread($uri,1,1,1,\%possibles);
	}
	if ($symb) {
	@symbs = ($symb);
	} elsif (keys(%possibles)) {
	@symbs = keys(%possibles);
	}

	my ($deeplink_symb,$allow);
	if ($env{'request.deeplink.login'}) {
	$deeplink_symb = &Apache::loncommon::deeplink_login_symb($cnum,$cdom);
	}
	foreach my $symb (@symbs) {
	last if ($allow);
	my $deeplink = &EXT("resource.0.deeplink",$symb);
	if ($deeplink eq '') {
	$allow = 1;
	} else {
	my ($state,$others,$listed,$scope,$protect) = split(/,/,$deeplink);
	if ($state ne 'only') {
	$allow = 1;
	} else {
	my $check_deeplink_entry;
	if ($protect ne 'none') {
	my ($acctype,$item) = split(/:/,$protect);
	if (($acctype eq 'ltic') && ($env{'user.linkprotector'})) {
	if (grep(/^\Q$item\Ec$/,split(/,/,$env{'user.linkprotector'}))) {
	$check_deeplink_entry = 1
	}
	} elsif (($acctype eq 'ltid') && ($env{'user.linkprotector'})) {
	if (grep(/^\Q$item\Ed$/,split(/,/,$env{'user.linkprotector'}))) {
	$check_deeplink_entry = 1;
	}
	} elsif (($acctype eq 'key') && ($env{'user.deeplinkkey'})) {
	if (grep(/^\Q$item\E$/,split(/,/,$env{'user.deeplinkkey'}))) {
	$check_deeplink_entry = 1;
	}
	}
	}
	if (($protect eq 'none') \|\| ($check_deeplink_entry)) {
	if ($scope eq 'res') {
	if ($symb eq $deeplink_symb) {
	$allow = 1;
	}
	} elsif (($scope eq 'map') \|\| ($scope eq 'rec')) {
	my ($map_from_symb,$map_from_login);
	$map_from_symb = &deversion((&decode_symb($symb))[0]);
	if ($deeplink_symb =~ /\.(page\|sequence)$/) {
	$map_from_login = &deversion((&decode_symb($deeplink_symb))[2]);
	} else {
	$map_from_login = &deversion((&decode_symb($deeplink_symb))[0]);
	}
	if (($map_from_symb) && ($map_from_login)) {
	if ($map_from_symb eq $map_from_login) {
	$allow = 1;
	} elsif ($scope eq 'rec') {
	my @recurseup = &get_map_hierarchy($map_from_symb,$env{'request.course.id'});
	if (grep(/^\Q$map_from_login\E$/,@recurseup)) {
	$allow = 1;
	}
	}
	}
	}
	}
	}
	}
	}
	return if ($allow);
	return 1;
}	}

# -------------------------------- Deversion and split uri into path an filename	# -------------------------------- Deversion and split uri into path an filename
Line 8508 sub fetch_enrollment_query {	Line 9746 sub fetch_enrollment_query {
}	}

sub get_query_reply {	sub get_query_reply {
my ($queryid,$sleep,$loopmax) = @_;;	my ($queryid,$sleep,$loopmax) = @_;
if (($sleep eq '') \|\| ($sleep !~ /^\d+\.?\d*$/)) {	if (($sleep eq '') \|\| ($sleep !~ /^\d+\.?\d*$/)) {
$sleep = 0.2;	$sleep = 0.2;
}	}
Line 8641 sub auto_validate_instcode {	Line 9879 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 8912 sub auto_validate_class_sec {	Line 10169 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 9113 sub toggle_coursegroup_status {	Line 10402 sub toggle_coursegroup_status {
}	}

sub modify_group_roles {	sub modify_group_roles {
my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs,$selfenroll,$context) = @_;	my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs,$selfenroll,$context,
	$othdomby,$requester) = @_;
my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;	my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;
my $role = 'gr/'.&escape($userprivs);	my $role = 'gr/'.&escape($userprivs);
my ($uname,$udom) = split(/:/,$user);	my ($uname,$udom) = split(/:/,$user);
my $result = &assignrole($udom,$uname,$url,$role,$end,$start,'',$selfenroll,$context);	my $result = &assignrole($udom,$uname,$url,$role,$end,$start,'',$selfenroll,$context,
	$othdomby,$requester);
if ($result eq 'ok') {	if ($result eq 'ok') {
&devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);	&devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);
}	}
Line 9245 sub plaintext {	Line 10536 sub plaintext {

sub assignrole {	sub assignrole {
my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll,	my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll,
$context)=@_;	$context,$othdomby,$requester,$reqsec,$reqrole)=@_;
my $mrole;	my $mrole;
if ($role =~ /^cr\//) {	if ($role =~ /^cr\//) {
my $cwosec=$url;	my $cwosec=$url;
$cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;	$cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
unless (&allowed('ccr',$cwosec)) {	if ((!&allowed('ccr',$cwosec)) && (!&allowed('ccr',$udom))) {
my $refused = 1;	my $refused = 1;
if ($context eq 'requestcourses') {	if ($context eq 'requestcourses') {
if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) {	if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) {
if ($role =~ m{^cr/($match_domain)/($match_username)/([^/]+)$}) {	if ($role =~ m{^cr/($match_domain)/($match_username)/([^/]+)$}) {
if (($1 eq $env{'user.domain'}) && ($2 eq $env{'user.name'})) {	if (($1 eq $env{'user.domain'}) && ($2 eq $env{'user.name'})) {
my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});	my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));	my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
if ($crsenv{'internal.courseowner'} eq	if ($crsenv{'internal.courseowner'} eq
$env{'user.name'}.':'.$env{'user.domain'}) {	$env{'user.name'}.':'.$env{'user.domain'}) {
$refused = '';	$refused = '';
}	}
}	}
}	}
}	}
}	} elsif (($context eq 'course') && ($othdomby eq 'othdombyuser')) {
if ($refused) {	my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
&logthis('Refused custom assignrole: '.	my ($sec) = ($url =~ m{^/\Q$cwosec\E/(.*)$});
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.	my $key = "$uname:$udom:$role:$sec";
' by '.$env{'user.name'}.' at '.$env{'user.domain'});	my %queuedrolereq = &Apache::lonnet::get('nohist_othdomqueued',[$key],$cdom,$cnum);
return 'refused';	if ((exists($queuedrolereq{$key})) && (ref($queuedrolereq{$key}) eq 'HASH')) {
}	if (($queuedrolereq{$key}{'adj'} eq 'user') && ($queuedrolereq{$key}{'requester'} eq $requester)) {
	$refused = '';
	}
	}
	}
	if ($refused) {
	&logthis('Refused custom assignrole: '.
	$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.
	' by '.$env{'user.name'}.' at '.$env{'user.domain'});
	return 'refused';
	}
}	}
$mrole='cr';	$mrole='cr';
} elsif ($role =~ /^gr\//) {	} elsif ($role =~ /^gr\//) {
my $cwogrp=$url;	my $cwogrp=$url;
$cwogrp=~s{^/($match_domain)/($match_courseid)/.*}{$1/$2};	$cwogrp=~s{^/($match_domain)/($match_courseid)/.*}{$1/$2};
unless (&allowed('mdg',$cwogrp)) {	if (!&allowed('mdg',$cwogrp)) {
&logthis('Refused group assignrole: '.	my $refused = 1;
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.	if (($refused) && ($othdomby eq 'othdombyuser') && ($requester ne '') && ($reqrole ne '')) {
$env{'user.name'}.' at '.$env{'user.domain'});	my ($cdom,$cnum) = ($cwogrp =~ m{^/?($match_domain)/($match_courseid)$});
return 'refused';	my $key = "$uname:$udom:$reqrole:$reqsec";
	my %queuedrolereq = &Apache::lonnet::get('nohist_othdomqueued',[$key],$cdom,$cnum);
	if ((exists($queuedrolereq{$key})) && (ref($queuedrolereq{$key}) eq 'HASH')) {
	if (($queuedrolereq{$key}{'adj'} eq 'user') && ($queuedrolereq{$key}{'requester'} eq $requester)) {
	$refused = '';
	}
	}
	}
	if ($refused) {
	&logthis('Refused group assignrole: '.
	$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
	$env{'user.name'}.' at '.$env{'user.domain'});
	return 'refused';
	}
}	}
$mrole='gr';	$mrole='gr';
} else {	} else {
Line 9298 sub assignrole {	Line 10612 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') \|\| ($context eq 'ltienroll' && $env{'request.lti.login'}))) {	if (!$selfenroll && ($othdomby ne 'othdombyuser') &&
	(($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 9324 sub assignrole {	Line 10639 sub assignrole {
} elsif (($context eq 'ltienroll') && ($env{'request.lti.login'})) {	} elsif (($context eq 'ltienroll') && ($env{'request.lti.login'})) {
$refused = '';	$refused = '';
}	}
	} elsif ($othdomby eq 'othdombyuser') {
	my ($key,%queuedrolereq);
	if ($context eq 'course') {
	my ($sec) = ($url =~ m{^/\Q$cwosec\E/(.*)$});
	$key = "$uname:$udom:$role:$sec";
	%queuedrolereq = &Apache::lonnet::get('nohist_othdomqueued',[$key],$cdom,$cnum);
	if ((exists($queuedrolereq{$key})) && (ref($queuedrolereq{$key}) eq 'HASH')) {
	if (($queuedrolereq{$key}{'adj'} eq 'user') && ($queuedrolereq{$key}{'requester'} eq $requester)) {
	if ((($role eq 'cc') && ($cnum !~ /^$match_community$/)) \|\|
	(($role eq 'co') && ($cnum =~ /^$match_community$/))) {
	my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
	if ($crsenv{'internal.courseowner'} eq $requester) {
	$refused = '';
	}
	} elsif ($role =~ /^(?:in\|ta\|ep\|st)$/) {
	$refused = '';
	}
	}
	}
	} elsif (($context eq 'author') && ($role =~ /^ca\|aa$/)) {
	my $key = "$uname:$udom:$role";
	my ($audom,$auname) = ($url =~ m{^/($match_domain)/($match_username)$});
	if (($audom ne '') && ($auname ne '')) {
	my %queuedrolereq = &Apache::lonnet::get('nohist_othdomqueued',[$key],$audom,$auname);
	if ((exists($queuedrolereq{$key})) && (ref($queuedrolereq{$key}) eq 'HASH')) {
	if (($queuedrolereq{$key}{'adj'} eq 'user') && ($queuedrolereq{$key}{'requester'} eq $requester)) {
	$refused = '';
	}
	}
	}
	} elsif (($context eq 'domain') && ($role ne 'dc') && ($role ne 'su')) {
	my $key = "$uname:$udom:$role";
	my ($roledom) = ($url =~ m{^/($match_domain)/\Q$role\E$});
	if ($roledom ne '') {
	my $confname = $roledom.'-domainconfig';
	my %queuedrolereq = &Apache::lonnet::get('nohist_othdomqueued',[$key],$roledom,$confname);
	if ((exists($queuedrolereq{$key})) && (ref($queuedrolereq{$key}) eq 'HASH')) {
	if (($queuedrolereq{$key}{'adj'} eq 'user') && ($queuedrolereq{$key}{'requester'} eq $requester)) {
	$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 9436 sub assignrole {	Line 10794 sub assignrole {
$origstart,$selfenroll,$context);	$origstart,$selfenroll,$context);
}	}
&courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,	&courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
$selfenroll,$context);	$selfenroll,$context,$othdomby,$requester);
} elsif (($role eq 'li') \|\| ($role eq 'dg') \|\| ($role eq 'sc') \|\|	} elsif (($role eq 'li') \|\| ($role eq 'dg') \|\| ($role eq 'sc') \|\|
($role eq 'au') \|\| ($role eq 'dc') \|\| ($role eq 'dh') \|\|	($role eq 'au') \|\| ($role eq 'dc') \|\| ($role eq 'dh') \|\|
($role eq 'da')) {	($role eq 'da')) {
&domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,	&domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
$context);	$context,$othdomby,$requester);
} elsif (($role eq 'ca') \|\| ($role eq 'aa')) {	} elsif (($role eq 'ca') \|\| ($role eq 'aa')) {
&coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,	&coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
$context);	$context,$othdomby,$requester);
}	}
if ($role eq 'cc') {	if ($role eq 'cc') {
&autoupdate_coowners($url,$end,$start,$uname,$udom);	&autoupdate_coowners($url,$end,$start,$uname,$udom);
Line 9462 sub autoupdate_coowners {	Line 10820 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 9479 sub autoupdate_coowners {	Line 10849 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 9529 sub store_coowners {	Line 10897 sub store_coowners {
}	}
if (($putresult eq 'ok') \|\| ($delresult eq 'ok')) {	if (($putresult eq 'ok') \|\| ($delresult eq 'ok')) {
my %crsinfo =	my %crsinfo =
&Apache::lonnet::courseiddump($cdom,'.',1,'.','.',$cnum,undef,undef,'.');	&courseiddump($cdom,'.',1,'.','.',$cnum,undef,undef,'.');
if (ref($crsinfo{$cid}) eq 'HASH') {	if (ref($crsinfo{$cid}) eq 'HASH') {
$crsinfo{$cid}{'co-owners'} = \@newcoowners;	$crsinfo{$cid}{'co-owners'} = \@newcoowners;
my $cidput = &Apache::lonnet::courseidput($cdom,\%crsinfo,$chome,'notime');	my $cidput = &courseidput($cdom,\%crsinfo,$chome,'notime');
}	}
}	}
}	}
Line 9543 sub store_coowners {	Line 10911 sub store_coowners {
sub modifyuserauth {	sub modifyuserauth {
my ($udom,$uname,$umode,$upass)=@_;	my ($udom,$uname,$umode,$upass)=@_;
my $uhome=&homeserver($uname,$udom);	my $uhome=&homeserver($uname,$udom);
unless (&allowed('mau',$udom)) { return 'refused'; }	my $allowed;
	if (&allowed('mau',$udom)) {
	$allowed = 1;
	} elsif (($umode eq 'internal') && ($udom eq $env{'user.domain'}) &&
	($env{'request.course.id'}) && (&allowed('mip',$env{'request.course.id'})) &&
	(!$env{'course.'.$env{'request.course.id'}.'.internal.nopasswdchg'})) {
	my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
	my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
	if (($cdom ne '') && ($cnum ne '')) {
	my $is_owner = &is_course_owner($cdom,$cnum);
	if ($is_owner) {
	$allowed = 1;
	}
	}
	}
	unless ($allowed) { return 'refused'; }
&logthis('Call to modify user authentication '.$udom.', '.$uname.', '.	&logthis('Call to modify user authentication '.$udom.', '.$uname.', '.
$umode.' by '.$env{'user.name'}.' at '.$env{'user.domain'}.	$umode.' by '.$env{'user.name'}.' at '.$env{'user.domain'}.
' 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 9734 sub modifyuser {	Line 11118 sub modifyuser {
return 'error: '.$reply;	return 'error: '.$reply;
}	}
if ($names{'permanentemail'} ne $oldnames{'permanentemail'}) {	if ($names{'permanentemail'} ne $oldnames{'permanentemail'}) {
&Apache::lonnet::devalidate_cache_new('emailscache',$uname.':'.$udom);	&devalidate_cache_new('emailscache',$uname.':'.$udom);
}	}
my $sqlresult = &update_allusers_table($uname,$udom,\%names);	my $sqlresult = &update_allusers_table($uname,$udom,\%names);
&devalidate_cache_new('namescache',$uname.':'.$udom);	&devalidate_cache_new('namescache',$uname.':'.$udom);
Line 9770 sub modifystudent {	Line 11154 sub modifystudent {

sub modify_student_enrollment {	sub modify_student_enrollment {
my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,	my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,
$locktype,$cid,$selfenroll,$context,$credits,$instsec) = @_;	$locktype,$cid,$selfenroll,$context,$credits,$instsec,$othdomby,$requester) = @_;
my ($cdom,$cnum,$chome);	my ($cdom,$cnum,$chome);
if (!$cid) {	if (!$cid) {
unless ($cid=$env{'request.course.id'}) {	unless ($cid=$env{'request.course.id'}) {
Line 9814 sub modify_student_enrollment {	Line 11198 sub modify_student_enrollment {
}	}
my $fullname = &format_name($first,$middle,$last,$gene,'lastname');	my $fullname = &format_name($first,$middle,$last,$gene,'lastname');
my $user = "$uname:$udom";	my $user = "$uname:$udom";
my %old_entry = &Apache::lonnet::get('classlist',[$user],$cdom,$cnum);	my %old_entry = &get('classlist',[$user],$cdom,$cnum);
my $reply=cput('classlist',	my $reply=cput('classlist',
{$user =>	{$user =>
join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype,$credits,$instsec) },	join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype,$credits,$instsec) },
Line 9831 sub modify_student_enrollment {	Line 11215 sub modify_student_enrollment {
$uurl.='/'.$usec;	$uurl.='/'.$usec;
}	}
my $result = &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,	my $result = &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,
$selfenroll,$context);	$selfenroll,$context,$othdomby,$requester);
if ($result ne 'ok') {	if ($result ne 'ok') {
if ($old_entry{$user} ne '') {	if ($old_entry{$user} ne '') {
$reply = &cput('classlist',\%old_entry,$cdom,$cnum);	$reply = &cput('classlist',\%old_entry,$cdom,$cnum);
Line 9884 sub writecoursepref {	Line 11268 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)=@_;	$course_owner,$crstype,$cnum,$context,$category,$callercontext)=@_;
$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) {
if (&usertools_access($ownername,$ownerdom,$category,undef,	my $reload;
	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 9943 sub createcourse {	Line 11332 sub createcourse {
}	}
}	}
my %host_servers =	my %host_servers =
&Apache::lonnet::get_servers($udom,'library');	&get_servers($udom,'library');
unless ($host_servers{$course_server}) {	unless ($host_servers{$course_server}) {
return 'error: invalid home server for course: '.$course_server;	return 'error: invalid home server for course: '.$course_server;
}	}
Line 10041 sub is_course {	Line 11430 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 10063 sub store_userdata {	Line 11465 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 10089 sub store_userdata {	Line 11491 sub store_userdata {
# ---------------------------------------------------------- Assign Custom Role	# ---------------------------------------------------------- Assign Custom Role

sub assigncustomrole {	sub assigncustomrole {
my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag,$selfenroll,$context)=@_;	my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag,
	$selfenroll,$context,$othdomby,$requester)=@_;
return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,	return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,
$end,$start,$deleteflag,$selfenroll,$context);	$end,$start,$deleteflag,$selfenroll,$context,$othdomby,
	$requester);
}	}

# ----------------------------------------------------------------- Revoke Role	# ----------------------------------------------------------------- Revoke Role
Line 10898 sub stat_file {	Line 12302 sub stat_file {
# or corresponding Published Resource Space, and populate the hash ref:	# or corresponding Published Resource Space, and populate the hash ref:
# $dirhashref with URLs of all directories, and if $filehashref hash	# $dirhashref with URLs of all directories, and if $filehashref hash
# ref arg is provided, the URLs of any files, excluding versioned, .meta,	# ref arg is provided, the URLs of any files, excluding versioned, .meta,
# or .rights files in resource space, and .meta, .save, .log, and .bak	# or .rights files in resource space, and .meta, .save, .log, .bak and
# files in Authoring Space.	# .rights files in Authoring Space.
#	#
# Inputs:	# Inputs:
#	#
# $is_home - true if current server is home server for user's space	# $is_home - true if current server is home server for user's space
# $context - either: priv, or res respectively for Authoring or Resource Space.	# $recurse - if true will also traverse subdirectories recursively
# $docroot - Document root (i.e., /home/httpd/html	# $include - reference to hash containing allowed file extensions. If provided,
	# files which do not have a matching extension will be ignored.
	# $exclude - reference to hash containing excluded file extensions. If provided,
	# files which have a matching extension will be ignored.
	# $nonemptydir - if true, will only populate $fileshashref hash entry for a particular
	# directory with first file found (with acceptable extension).
	# $addtopdir - if true, set $dirhashref->{'/'} = 1
# $toppath - Top level directory (i.e., /res/$dom/$uname or /priv/$dom/$uname	# $toppath - Top level directory (i.e., /res/$dom/$uname or /priv/$dom/$uname
# $relpath - Current path (relative to top level).	# $relpath - Current path (relative to top level).
# $dirhashref - reference to hash to populate with URLs of directories (Required)	# $dirhashref - reference to hash to populate with URLs of directories (Required)
Line 10922 sub stat_file {	Line 12332 sub stat_file {
#	#

sub recursedirs {	sub recursedirs {
my ($is_home,$context,$docroot,$toppath,$relpath,$dirhashref,$filehashref) = @_;	my ($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$toppath,$relpath,$dirhashref,$filehashref) = @_;
return unless (ref($dirhashref) eq 'HASH');	return unless (ref($dirhashref) eq 'HASH');
	my $docroot = $perlvar{'lonDocRoot'};
my $currpath = $docroot.$toppath;	my $currpath = $docroot.$toppath;
if ($relpath) {	if ($relpath ne '') {
$currpath .= "/$relpath";	$currpath .= "/$relpath";
}	}
my $savefile;	my ($savefile,$checkinc,$checkexc);
if (ref($filehashref)) {	if (ref($filehashref)) {
$savefile = 1;	$savefile = 1;
}	}
	if (ref($include) eq 'HASH') {
	$checkinc = 1;
	}
	if (ref($exclude) eq 'HASH') {
	$checkexc = 1;
	}
if ($is_home) {	if ($is_home) {
if (opendir(my $dirh,$currpath)) {	if ((-e $currpath) && (opendir(my $dirh,$currpath))) {
	my $filecount = 0;
foreach my $item (sort { lc($a) cmp lc($b) } grep(!/^\.+$/,readdir($dirh))) {	foreach my $item (sort { lc($a) cmp lc($b) } grep(!/^\.+$/,readdir($dirh))) {
next if ($item eq '');	next if ($item eq '');
if (-d "$currpath/$item") {	if (-d "$currpath/$item") {
my $newpath;	my $newpath;
if ($relpath) {	if ($relpath ne '') {
$newpath = "$relpath/$item";	$newpath = "$relpath/$item";
} else {	} else {
$newpath = $item;	$newpath = $item;
}	}
$dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;	$dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;
&recursedirs($is_home,$context,$docroot,$toppath,$newpath,$dirhashref,$filehashref);	if ($recurse) {
} elsif ($savefile) {	&recursedirs($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$toppath,$newpath,$dirhashref,$filehashref);
if ($context eq 'priv') {	}
unless ($item =~ /\.(meta\|save\|log\|bak\|DS_Store)$/) {	} elsif (($savefile) \|\| ($relpath eq '')) {
$filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1;	next if ($nonemptydir && $filecount);
	if ($checkinc \|\| $checkexc) {
	my ($extension) = ($item =~ /\.(\w+)$/);
	if ($checkinc) {
	next unless ($extension && $include->{$extension});
}	}
} else {	if ($checkexc) {
unless (($item =~ /\.meta$/) \|\| ($item =~ /\.\d+\.\w+$/) \|\| ($item =~ /\.rights$/)) {	next if ($extension && $exclude->{$extension});
	}
	}
	if (($relpath eq '') && (!exists($dirhashref->{'/'}))) {
	$dirhashref->{'/'} = 1;
	}
	if ($savefile) {
	if ($relpath eq '') {
	$filehashref->{'/'}{$item} = 1;
	} else {
$filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1;	$filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1;
}	}
}	}
	$filecount ++;
}	}
}	}
closedir($dirh);	closedir($dirh);
Line 10965 sub recursedirs {	Line 12397 sub recursedirs {
my @dir_lines;	my @dir_lines;
my $dirptr=16384;	my $dirptr=16384;
if (ref($dirlistref) eq 'ARRAY') {	if (ref($dirlistref) eq 'ARRAY') {
	my $filecount = 0;
foreach my $dir_line (sort	foreach my $dir_line (sort
{	{
my ($afile)=split('&',$a,2);	my ($afile)=split('&',$a,2);
Line 10980 sub recursedirs {	Line 12413 sub recursedirs {
if ($relpath) {	if ($relpath) {
$newpath = "$relpath/$item";	$newpath = "$relpath/$item";
} else {	} else {
$relpath = '/';
$newpath = $item;	$newpath = $item;
}	}
$dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;	$dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;
&recursedirs($is_home,$context,$docroot,$toppath,$newpath,$dirhashref,$filehashref);	if ($recurse) {
} elsif ($savefile) {	&recursedirs($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$toppath,$newpath,$dirhashref,$filehashref);
if ($context eq 'priv') {	}
unless ($item =~ /\.(meta\|save\|log\|bak\|DS_Store)$/) {	} elsif (($savefile) \|\| ($relpath eq '')) {
$filehashref->{$relpath}{$item} = 1;	next if ($nonemptydir && $filecount);
	if ($checkinc \|\| $checkexc) {
	my $extension;
	if ($checkinc) {
	next unless ($extension && $include->{$extension});
}	}
} else {	if ($checkexc) {
unless (($item =~ /\.meta$/) \|\| ($item =~ /\.\d+\.\w+$/)) {	next if ($extension && $exclude->{$extension});
$filehashref->{$relpath}{$item} = 1;
}	}
}	}
	if (($relpath eq '') && (!exists($dirhashref->{'/'}))) {
	$dirhashref->{'/'} = 1;
	}
	if ($savefile) {
	if ($relpath eq '') {
	$filehashref->{'/'}{$item} = 1;
	} else {
	$filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1;
	}
	}
	$filecount ++;
}	}
}	}
}	}
}	}
	if ($addtopdir) {
	if (($relpath eq '') && (!exists($dirhashref->{'/'}))) {
	$dirhashref->{'/'} = 1;
	}
	}
return;	return;
}	}

	sub priv_exclude {
	return {
	meta => 1,
	save => 1,
	log => 1,
	bak => 1,
	rights => 1,
	DS_Store => 1,
	};
	}

# -------------------------------------------------------- Value of a Condition	# -------------------------------------------------------- Value of a Condition

# gets the value of a specific preevaluated condition	# gets the value of a specific preevaluated condition
Line 11215 sub resdata {	Line 12677 sub resdata {

sub get_domain_lti {	sub get_domain_lti {
my ($cdom,$context) = @_;	my ($cdom,$context) = @_;
my ($name,%lti);	my ($name,$cachename,%lti);
if ($context eq 'consumer') {	if ($context eq 'consumer') {
$name = 'ltitools';	$name = 'ltitools';
} elsif ($context eq 'provider') {	} elsif ($context eq 'provider') {
$name = 'lti';	$name = 'lti';
	} elsif ($context eq 'linkprot') {
	$name = 'ltisec';
} else {	} else {
return %lti;	return %lti;
}	}
my ($result,$cached)=&is_cached_new($name,$cdom);	if ($context eq 'linkprot') {
	$cachename = $context;
	} else {
	$cachename = $name;
	}
	my ($result,$cached)=&is_cached_new($cachename,$cdom);
if (defined($cached)) {	if (defined($cached)) {
if (ref($result) eq 'HASH') {	if (ref($result) eq 'HASH') {
%lti = %{$result};	%lti = %{$result};
Line 11231 sub get_domain_lti {	Line 12700 sub get_domain_lti {
} else {	} else {
my %domconfig = &get_dom('configuration',[$name],$cdom);	my %domconfig = &get_dom('configuration',[$name],$cdom);
if (ref($domconfig{$name}) eq 'HASH') {	if (ref($domconfig{$name}) eq 'HASH') {
%lti = %{$domconfig{$name}};	if ($context eq 'linkprot') {
my %encdomconfig = &get_dom('encconfig',[$name],$cdom);	if (ref($domconfig{$name}{'linkprot'}) eq 'HASH') {
if (ref($encdomconfig{$name}) eq 'HASH') {	%lti = %{$domconfig{$name}{'linkprot'}};
foreach my $id (keys(%lti)) {
if (ref($encdomconfig{$name}{$id}) eq 'HASH') {
foreach my $item ('key','secret') {
$lti{$id}{$item} = $encdomconfig{$name}{$id}{$item};
}
}
}	}
	} else {
	%lti = %{$domconfig{$name}};
}	}
}	}
my $cachetime = 246060;	my $cachetime = 246060;
&do_cache_new($name,$cdom,\%lti,$cachetime);	&do_cache_new($cachename,$cdom,\%lti,$cachetime);
	}
	return %lti;
	}

	sub get_course_lti {
	my ($cnum,$cdom,$context) = @_;
	my ($name,$cachename,%lti);
	if ($context eq 'consumer') {
	$name = 'ltitools';
	$cachename = 'courseltitools';
	} elsif ($context eq 'provider') {
	$name = 'lti';
	$cachename = 'courselti';
	} else {
	return %lti;
	}
	my $hashid=$cdom.'_'.$cnum;
	my ($result,$cached)=&is_cached_new($cachename,$hashid);
	if (defined($cached)) {
	if (ref($result) eq 'HASH') {
	%lti = %{$result};
	}
	} else {
	%lti = &dump($name,$cdom,$cnum,undef,undef,undef,1);
	my $cachetime = 246060;
	&do_cache_new($cachename,$hashid,\%lti,$cachetime);
}	}
return %lti;	return %lti;
}	}

sub get_numsuppfiles {	sub courselti_itemid {
my ($cnum,$cdom,$ignorecache)=@_;	my ($cnum,$cdom,$url,$method,$params,$context) = @_;
	my ($chome,$itemid);
	$chome = &homeserver($cnum,$cdom);
	return if ($chome eq 'no_host');
	if (ref($params) eq 'HASH') {
	my $rep;
	if (grep { $_ eq $chome } current_machine_ids()) {
	$rep = LONCAPA::Lond::crslti_itemid($cdom,$cnum,$url,$method,$params,$perlvar{'lonVersion'});
	} else {
	my $escurl = &escape($url);
	my $escmethod = &escape($method);
	my $items = &freeze_escape($params);
	$rep = &reply("encrypt:lti:$cdom:$cnum:$context:$escurl:$escmethod:$items",$chome);
	}
	unless (($rep=~/^(refused\|rejected\|error)/) \|\| ($rep eq 'con_lost') \|\|
	($rep eq 'unknown_cmd')) {
	$itemid = $rep;
	}
	}
	return $itemid;
	}

	sub domainlti_itemid {
	my ($cdom,$url,$method,$params,$context) = @_;
	my ($primary_id,$itemid);
	$primary_id = &domain($cdom,'primary');
	return if ($primary_id eq '');
	if (ref($params) eq 'HASH') {
	my $rep;
	if (grep { $_ eq $primary_id } current_machine_ids()) {
	$rep = LONCAPA::Lond::domlti_itemid($cdom,$context,$url,$method,$params,$perlvar{'lonVersion'});
	} else {
	my $cnum = '';
	my $escurl = &escape($url);
	my $escmethod = &escape($method);
	my $items = &freeze_escape($params);
	$rep = &reply("encrypt:lti:$cdom:$cnum:$context:$escurl:$escmethod:$items",$primary_id);
	}
	unless (($rep=~/^(refused\|rejected\|error)/) \|\| ($rep eq 'con_lost') \|\|
	($rep eq 'unknown_cmd')) {
	$itemid = $rep;
	}
	}
	return $itemid;
	}

	sub get_ltitools_id {
	my ($context,$cdom,$cnum,$title) = @_;
	my ($lockhash,$tries,$gotlock,$id,$error);

	# get lock on ltitools db
	$lockhash = {
	lock => $env{'user.name'}.
	':'.$env{'user.domain'},
	};
	$tries = 0;
	if ($context eq 'domain') {
	$gotlock = &newput_dom('ltitools',$lockhash,$cdom);
	} else {
	$gotlock = &newput('ltitools',$lockhash,$cdom,$cnum);
	}
	while (($gotlock ne 'ok') && ($tries<10)) {
	$tries ++;
	sleep (0.1);
	if ($context eq 'domain') {
	$gotlock = &newput_dom('ltitools',$lockhash,$cdom);
	} else {
	$gotlock = &newput('ltitools',$lockhash,$cdom,$cnum);
	}
	}
	if ($gotlock eq 'ok') {
	my %currids;
	if ($context eq 'domain') {
	%currids = &dump_dom('ltitools',$cdom);
	} else {
	%currids = &dump('ltitools',$cdom,$cnum);
	}
	if ($currids{'lock'}) {
	delete($currids{'lock'});
	if (keys(%currids)) {
	my @curr = sort { $a <=> $b } keys(%currids);
	if ($curr[-1] =~ /^\d+$/) {
	$id = 1 + $curr[-1];
	}
	} else {
	$id = 1;
	}
	if ($id) {
	if ($context eq 'domain') {
	unless (&newput_dom('ltitools',{ $id => $title },$cdom) eq 'ok') {
	$error = 'nostore';
	}
	} else {
	unless (&newput('ltitools',{ $id => $title },$cdom,$cnum) eq 'ok') {
	$error = 'nostore';
	}
	}
	} else {
	$error = 'nonumber';
	}
	}
	my $dellockoutcome;
	if ($context eq 'domain') {
	$dellockoutcome = &del_dom('ltitools',['lock'],$cdom);
	} else {
	$dellockoutcome = &del('ltitools',['lock'],$cdom,$cnum);
	}
	} else {
	$error = 'nolock';
	}
	return ($id,$error);
	}

	sub count_supptools {
	my ($cnum,$cdom,$ignorecache,$reload)=@_;
	my $hashid=$cnum.':'.$cdom;
	my ($numexttools,$cached);
	unless ($ignorecache) {
	($numexttools,$cached) = &is_cached_new('supptools',$hashid);
	}
	unless (defined($cached)) {
	my $chome=&homeserver($cnum,$cdom);
	$numexttools = 0;
	unless ($chome eq 'no_host') {
	my ($supplemental) = &Apache::loncommon::get_supplemental($cnum,$cdom,$reload);
	if (ref($supplemental) eq 'HASH') {
	if ((ref($supplemental->{'ids'}) eq 'HASH') && (ref($supplemental->{'hidden'}) eq 'HASH')) {
	foreach my $key (keys(%{$supplemental->{'ids'}})) {
	if ($key =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) {
	$numexttools ++;
	}
	}
	}
	}
	}
	&do_cache_new('supptools',$hashid,$numexttools,600);
	}
	return $numexttools;
	}

	sub has_unhidden_suppfiles {
	my ($cnum,$cdom,$ignorecache,$possdel)=@_;
my $hashid=$cnum.':'.$cdom;	my $hashid=$cnum.':'.$cdom;
my ($suppcount,$cached);	my ($showsupp,$cached);
unless ($ignorecache) {	unless ($ignorecache) {
($suppcount,$cached) = &is_cached_new('suppcount',$hashid);	($showsupp,$cached) = &is_cached_new('showsupp',$hashid);
}	}
unless (defined($cached)) {	unless (defined($cached)) {
my $chome=&homeserver($cnum,$cdom);	my $chome=&homeserver($cnum,$cdom);
unless ($chome eq 'no_host') {	unless ($chome eq 'no_host') {
($suppcount,my $supptools,my $errors) = (0,0,0);	my ($supplemental) = &Apache::loncommon::get_supplemental($cnum,$cdom,$ignorecache,$possdel);
my $suppmap = 'supplemental.sequence';	if (ref($supplemental) eq 'HASH') {
($suppcount,$supptools,$errors) =	if ((ref($supplemental->{'ids'}) eq 'HASH') && (ref($supplemental->{'hidden'}) eq 'HASH')) {
&Apache::loncommon::recurse_supplemental($cnum,$cdom,$suppmap,$suppcount,	foreach my $key (keys(%{$supplemental->{'ids'}})) {
$supptools,$errors);	next if ($key =~ /\.sequence$/);
	if (ref($supplemental->{'ids'}->{$key}) eq 'ARRAY') {
	foreach my $id (@{$supplemental->{'ids'}->{$key}}) {
	unless ($supplemental->{'hidden'}->{$id}) {
	$showsupp = 1;
	last;
	}
	}
	}
	last if ($showsupp);
	}
	}
	}
}	}
&do_cache_new('suppcount',$hashid,$suppcount,600);	&do_cache_new('showsupp',$hashid,$showsupp,600);
}	}
return $suppcount;	return $showsupp;
}	}

#	#
Line 11308 sub EXT_cache_set {	Line 12952 sub EXT_cache_set {
# --------------------------------------------------------- Value of a Variable	# --------------------------------------------------------- Value of a Variable
sub EXT {	sub EXT {

my ($varname,$symbparm,$udom,$uname,$usection,$recurse,$cid)=@_;	my ($varname,$symbparm,$udom,$uname,$usection,$recurse,$cid,$recurseupref)=@_;
unless ($varname) { return ''; }	unless ($varname) { return ''; }
#get real user name/domain, courseid and symb	#get real user name/domain, courseid and symb
my $courseid;	my $courseid;
Line 11340 sub EXT {	Line 12984 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 11462 sub EXT {	Line 13106 sub EXT {
}	}

my ($section, $group, @groups, @recurseup, $recursed);	my ($section, $group, @groups, @recurseup, $recursed);
	if (ref($recurseupref) eq 'ARRAY') {
	@recurseup = @{$recurseupref};
	$recursed = 1;
	}
my ($courselevelm,$courseleveli,$courselevel,$mapp);	my ($courselevelm,$courseleveli,$courselevel,$mapp);
if (($courseid eq '') && ($cid)) {	if (($courseid eq '') && ($cid)) {
$courseid = $cid;	$courseid = $cid;
Line 11610 sub EXT {	Line 13258 sub EXT {
if ($space eq 'name') {	if ($space eq 'name') {
return $ENV{'SERVER_NAME'};	return $ENV{'SERVER_NAME'};
}	}
	} elsif ($realm eq 'client') {
	if ($space eq 'remote_addr') {
	return &get_requestor_ip();
	}
}	}
return '';	return '';
}	}
Line 12335 sub get_reservable_slots {	Line 13987 sub get_reservable_slots {
sub get_course_slots {	sub get_course_slots {
my ($cnum,$cdom) = @_;	my ($cnum,$cdom) = @_;
my $hashid=$cnum.':'.$cdom;	my $hashid=$cnum.':'.$cdom;
my ($result,$cached) = &Apache::lonnet::is_cached_new('allslots',$hashid);	my ($result,$cached) = &is_cached_new('allslots',$hashid);
if (defined($cached)) {	if (defined($cached)) {
if (ref($result) eq 'HASH') {	if (ref($result) eq 'HASH') {
return %{$result};	return %{$result};
}	}
} else {	} else {
my %slots=&Apache::lonnet::dump('slots',$cdom,$cnum);	my %slots=&dump('slots',$cdom,$cnum);
my ($tmp) = keys(%slots);	my ($tmp) = keys(%slots);
if ($tmp !~ /^(con_lost\|error\|no_such_host)/i) {	if ($tmp !~ /^(con_lost\|error\|no_such_host)/i) {
&do_cache_new('allslots',$hashid,\%slots,600);	&do_cache_new('allslots',$hashid,\%slots,600);
Line 12387 sub get_coursechange {	Line 14039 sub get_coursechange {
}	}

sub devalidate_coursechange_cache {	sub devalidate_coursechange_cache {
my ($cnum,$cdom)=@_;	my ($cdom,$cnum)=@_;
my $hashid=$cnum.':'.$cdom;	my $hashid=$cdom.'_'.$cnum;
&devalidate_cache_new('crschange',$hashid);	&devalidate_cache_new('crschange',$hashid);
}	}

	sub get_suppchange {
	my ($cdom,$cnum) = @_;
	if ($cdom eq '' \|\| $cnum eq '') {
	return unless ($env{'request.course.id'});
	$cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
	$cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
	}
	my $hashid=$cdom.'_'.$cnum;
	my ($change,$cached)=&is_cached_new('suppchange',$hashid);
	if ((defined($cached)) && ($change ne '')) {
	return $change;
	} else {
	my %crshash = &get('environment',['internal.supplementalchange'],$cdom,$cnum);
	if ($crshash{'internal.supplementalchange'} eq '') {
	$change = $env{'course.'.$cdom.'_'.$cnum.'.internal.created'};
	if ($change eq '') {
	%crshash = &get('environment',['internal.created'],$cdom,$cnum);
	$change = $crshash{'internal.created'};
	}
	} else {
	$change = $crshash{'internal.supplementalchange'};
	}
	my $cachetime = 600;
	&do_cache_new('suppchange',$hashid,$change,$cachetime);
	}
	return $change;
	}

	sub devalidate_suppchange_cache {
	my ($cdom,$cnum)=@_;
	my $hashid=$cdom.'_'.$cnum;
	&devalidate_cache_new('suppchange',$hashid);
	}

	sub update_supp_caches {
	my ($cdom,$cnum) = @_;
	my %servers = &internet_dom_servers($cdom);
	my @ids=&current_machine_ids();
	foreach my $server (keys(%servers)) {
	next if (grep(/^\Q$server\E$/,@ids));
	my $hashid=$cnum.':'.$cdom;
	my $cachekey = &escape('showsupp').':'.&escape($hashid);
	&remote_devalidate_cache($server,[$cachekey]);
	}
	&has_unhidden_suppfiles($cnum,$cdom,1,1);
	&count_supptools($cnum,$cdom,1);
	my $now = time;
	if ($env{'request.course.id'} eq $cdom.'_'.$cnum) {
	&Apache::lonnet::appenv({'request.course.suppupdated' => $now});
	}
	&put('environment',{'internal.supplementalchange' => $now},
	$cdom,$cnum);
	&Apache::lonnet::appenv(
	{'course.'.$cdom.'_'.$cnum.'.internal.supplementalchange' => $now});
	&do_cache_new('suppchange',$cdom.'_'.$cnum,$now,600);
	}

# ------------------------------------------------- Update symbolic store links	# ------------------------------------------------- Update symbolic store links

sub symblist {	sub symblist {
Line 12438 sub symbverify {	Line 14147 sub symbverify {

if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',	if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
&GDBM_READER(),0640)) {	&GDBM_READER(),0640)) {
my $noclutter;
if (($thisurl =~ m{^/adm/wrapper/ext/}) \|\| ($thisurl =~ m{^ext/})) {	if (($thisurl =~ m{^/adm/wrapper/ext/}) \|\| ($thisurl =~ m{^ext/})) {
$thisurl =~ s/\?.+$//;	$thisurl =~ s/\?.+$//;
if ($map =~ m{^uploaded/.+\.page$}) {	if ($map =~ m{^uploaded/.+\.page$}) {
$thisurl =~ s{^(/adm/wrapper\|)/ext/}{http://};	$thisurl =~ s{^(/adm/wrapper\|)/ext/}{http://};
$thisurl =~ s{^\Qhttp://https://\E}{https://};	$thisurl =~ s{^\Qhttp://https://\E}{https://};
$noclutter = 1;
}	}
}	}
my $ids;	my $ids;
if ($noclutter) {	if ($map =~ m{^uploaded/.+\.page$}) {
$ids=$bighash{'ids_'.$thisurl};	$ids=$bighash{'ids_'.&clutter_with_no_wrapper($thisurl)};
} else {	} else {
$ids=$bighash{'ids_'.&clutter($thisurl)};	$ids=$bighash{'ids_'.&clutter($thisurl)};
}	}
Line 12549 sub deversion {	Line 14256 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
unless ($thisfn) {	unless ($thisfn) {
if ($env{'request.symb'}) {	if ($env{'request.symb'}) {
return $env{$cache_str}=&symbclean($env{'request.symb'});	return $env{$cache_str}=&symbclean($env{'request.symb'});
}	}
$thisfn=$env{'request.filename'};	$thisfn=$env{'request.filename'};
}	}
Line 12577 sub symbread {	Line 14287 sub symbread {
my %bighash;	my %bighash;
my $syval='';	my $syval='';
if (($env{'request.course.fn'}) && ($thisfn)) {	if (($env{'request.course.fn'}) && ($thisfn)) {
my $targetfn = $thisfn;	unless ($ignoresymbdb) {
if ( ($thisfn =~ m/^(uploaded\|editupload)\//) && ($thisfn !~ m/\.(page\|sequence)$/) ) {	if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
$targetfn = 'adm/wrapper/'.$thisfn;	&GDBM_READER(),0640)) {
}	$syval=$hash{$thisfn};
if ($targetfn =~ m\|^adm/wrapper/(ext/.*)\|) {	untie(%hash);
$targetfn=$1;	}
}	if ($syval && $checkforblock) {
if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',	my @blockers = &has_comm_blocking('bre',$syval,$thisfn,$ignoresymbdb,$noenccheck);
&GDBM_READER(),0640)) {	if (@blockers) {
$syval=$hash{$targetfn};	$syval='';
untie(%hash);	}
	}
}	}
# ---------------------------------------------------------- There was an entry	# ---------------------------------------------------------- There was an entry
if ($syval) {	if ($syval) {
Line 12620 sub symbread {	Line 14331 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 12645 sub symbread {	Line 14361 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 12658 sub symbread {	Line 14375 sub symbread {
$syval = $poss_syval;	$syval = $poss_syval;
$realpossible++;	$realpossible++;
}	}
	if ($syval) {
	if (ref($possibles) eq 'HASH') {
	$possibles->{$syval} = 1;
	}
	}
}	}
}	}
}	}
Line 13195 sub repcopy_userfile {	Line 14917 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 13221 sub tokenwrapper {	Line 14944 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 13239 sub getuploaded {	Line 14963 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 13373 sub machine_ids {	Line 15098 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 13394 sub default_login_domain {	Line 15124 sub default_login_domain {
return $domain;	return $domain;
}	}

	sub shared_institution {
	my ($dom,$lonhost) = @_;
	if ($lonhost eq '') {
	$lonhost = $perlvar{'lonHostID'};
	}
	my $same_intdom;
	my $hostintdom = &internet_dom($lonhost);
	if ($hostintdom ne '') {
	my %iphost = &get_iphost();
	my $primary_id = &domain($dom,'primary');
	my $primary_ip = &get_host_ip($primary_id);
	if (ref($iphost{$primary_ip}) eq 'ARRAY') {
	foreach my $id (@{$iphost{$primary_ip}}) {
	my $intdom = &internet_dom($id);
	if ($intdom eq $hostintdom) {
	$same_intdom = 1;
	last;
	}
	}
	}
	}
	return $same_intdom;
	}

	sub uses_sts {
	my ($ignore_cache) = @_;
	my $lonhost = $perlvar{'lonHostID'};
	my $hostname = &hostname($lonhost);
	my $sts_on;
	if ($protocol{$lonhost} eq 'https') {
	my $cachetime = 12*3600;
	if (!$ignore_cache) {
	($sts_on,my $cached)=&is_cached_new('stspolicy',$lonhost);
	if (defined($cached)) {
	return $sts_on;
	}
	}
	my $url = $protocol{$lonhost}.'://'.$hostname.'/index.html';
	my $request=new HTTP::Request('HEAD',$url);
	my $response=&LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,'','','',1);
	if ($response->is_success) {
	my $has_sts = $response->header('Strict-Transport-Security');
	if ($has_sts eq '') {
	$sts_on = 0;
	} else {
	if ($has_sts =~ /\Qmax-age=\E(\d+)/) {
	my $maxage = $1;
	if ($maxage) {
	$sts_on = 1;
	} else {
	$sts_on = 0;
	}
	} else {
	$sts_on = 0;
	}
	}
	return &do_cache_new('stspolicy',$lonhost,$sts_on,$cachetime);
	}
	}
	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 = &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 = &host_domain($lonid);
	if ($dom ne '') {
	my $cachetime = 606024;
	my %domconfig =
	&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 = &host_domain($lonid);
	if ($dom ne '') {
	my $cachetime = 606024;
	my %domconfig =
	&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 (&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 = &host_domain($lonid);
	if ($dom ne '') {
	my $cachetime = 606024;
	my %domconfig =
	&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 13511 sub get_dns {	Line 15527 sub get_dns {
my ($url,$func,$ignore_cache,$nocache,$hashref) = @_;	my ($url,$func,$ignore_cache,$nocache,$hashref) = @_;
if (!$ignore_cache) {	if (!$ignore_cache) {
my ($content,$cached)=	my ($content,$cached)=
&Apache::lonnet::is_cached_new('dns',$url);	&is_cached_new('dns',$url);
if ($cached) {	if ($cached) {
&$func($content,$hashref);	&$func($content,$hashref);
return;	return;
Line 13533 sub get_dns {	Line 15549 sub get_dns {
}	}
while (%alldns) {	while (%alldns) {
my ($dns) = sort { $b cmp $a } keys(%alldns);	my ($dns) = sort { $b cmp $a } keys(%alldns);
my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");	my ($contents,@content);
my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar,30,0);	if ($dns eq Sys::Hostname::FQDN::fqdn()) {
delete($alldns{$dns});	my $command = (split('/',$url))[3];
next if ($response->is_error());	my ($dir,$file) = &parse_getdns_url($command,$url);
	delete($alldns{$dns});
	next if (($dir eq '') \|\| ($file eq ''));
	if (open(my $config,'<',"$dir/$file")) {
	@content = <$config>;
	close($config);
	}
	if ($url eq '/adm/dns/loncapaCRL') {
	$contents = join('',@content);
	}
	} else {
	my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
	my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar,30,0);
	delete($alldns{$dns});
	next if ($response->is_error());
	if ($url eq '/adm/dns/loncapaCRL') {
	$contents = $response->content;
	} else {
	@content = split("\n",$response->content);
	}
	}
if ($url eq '/adm/dns/loncapaCRL') {	if ($url eq '/adm/dns/loncapaCRL') {
return &$func($response);	return &$func($contents);
} else {	} else {
my @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 13571 sub get_dns {	Line 15606 sub get_dns {
sub parse_dns_checksums_tab {	sub parse_dns_checksums_tab {
my ($lines,$hashref) = @_;	my ($lines,$hashref) = @_;
my $lonhost = $perlvar{'lonHostID'};	my $lonhost = $perlvar{'lonHostID'};
my $machine_dom = &Apache::lonnet::host_domain($lonhost);	my $machine_dom = &host_domain($lonhost);
my $loncaparev = &get_server_loncaparev($machine_dom);	my $loncaparev = &get_server_loncaparev($machine_dom);
my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0];	my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0];
my $webconfdir = '/etc/httpd/conf';	my $webconfdir = '/etc/httpd/conf';
Line 13615 sub parse_dns_checksums_tab {	Line 15650 sub parse_dns_checksums_tab {

sub fetch_dns_checksums {	sub fetch_dns_checksums {
my %checksums;	my %checksums;
my $machine_dom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});	my $machine_dom = &host_domain($perlvar{'lonHostID'});
my $loncaparev = &get_server_loncaparev($machine_dom,$perlvar{'lonHostID'});	my $loncaparev = &get_server_loncaparev($machine_dom,$perlvar{'lonHostID'});
my ($release,$timestamp) = split(/\-/,$loncaparev);	my ($release,$timestamp) = split(/\-/,$loncaparev);
&get_dns("/adm/dns/checksums/$release",\&parse_dns_checksums_tab,1,1,	&get_dns("/adm/dns/checksums/$release",\&parse_dns_checksums_tab,1,1,
Line 13628 sub fetch_crl_pemfile {	Line 15663 sub fetch_crl_pemfile {
}	}

sub save_crl_pem {	sub save_crl_pem {
my ($response) = @_;	my ($content) = @_;
my ($msg,$hadchanges);	my ($msg,$hadchanges);
if (ref($response)) {	if ($content ne '') {
my $now = time;	my $now = time;
my $lonca = $perlvar{'lonCertificateDirectory'}.'/'.$perlvar{'lonnetCertificateAuthority'};	my $lonca = $perlvar{'lonCertificateDirectory'}.'/'.$perlvar{'lonnetCertificateAuthority'};
my $tmpcrl = $tmpdir.'/'.$perlvar{'lonnetCertRevocationList'}.'_'.$now.'.'.$$.'.tmp';	my $tmpcrl = $tmpdir.'/'.$perlvar{'lonnetCertRevocationList'}.'_'.$now.'.'.$$.'.tmp';
if (open(my $fh,'>',"$tmpcrl")) {	if (open(my $fh,'>',"$tmpcrl")) {
print $fh $response->content;	print $fh $content;
close($fh);	close($fh);
if (-e $lonca) {	if (-e $lonca) {
if (open(PIPE,"openssl crl -in $tmpcrl -inform pem -CAfile $lonca -noout 2>&1 \|")) {	if (open(PIPE,"openssl crl -in $tmpcrl -inform pem -CAfile $lonca -noout 2>&1 \|")) {
Line 13696 sub save_crl_pem {	Line 15731 sub save_crl_pem {
return ($msg,$hadchanges);	return ($msg,$hadchanges);
}	}

	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",
	} elsif ($command eq 'loncapaCRL') {
	$dir = $perlvar{'lonCertificateDirectory'};
	$file = $perlvar{'lonnetCertRevocationList'};
	}
	return ($dir,$file);
	}

# ------------------------------------------------------------ Read domain file	# ------------------------------------------------------------ Read domain file
{	{
my $loaded;	my $loaded;
Line 13985 sub save_crl_pem {	Line 16038 sub save_crl_pem {
return %iphost;	return %iphost;
}	}
my ($ip_info,$cached)=	my ($ip_info,$cached)=
&Apache::lonnet::is_cached_new('iphost','iphost');	&is_cached_new('iphost','iphost');
if ($cached) {	if ($cached) {
%iphost = %{$ip_info->[0]};	%iphost = %{$ip_info->[0]};
%name_to_ip = %{$ip_info->[1]};	%name_to_ip = %{$ip_info->[1]};
Line 13997 sub save_crl_pem {	Line 16050 sub save_crl_pem {
# get yesterday's info for fallback	# get yesterday's info for fallback
my %old_name_to_ip;	my %old_name_to_ip;
my ($ip_info,$cached)=	my ($ip_info,$cached)=
&Apache::lonnet::is_cached_new('iphost','iphost');	&is_cached_new('iphost','iphost');
if ($cached) {	if ($cached) {
%old_name_to_ip = %{$ip_info->[1]};	%old_name_to_ip = %{$ip_info->[1]};
}	}
Line 14064 sub save_crl_pem {	Line 16117 sub save_crl_pem {
my ($lonid) = @_;	my ($lonid) = @_;
return if ($lonid eq '');	return if ($lonid eq '');
my ($idnref,$cached)=	my ($idnref,$cached)=
&Apache::lonnet::is_cached_new('internetnames',$lonid);	&is_cached_new('internetnames',$lonid);
if ($cached) {	if ($cached) {
return $idnref;	return $idnref;
}	}
Line 14262 BEGIN {	Line 16315 BEGIN {

}	}

	# ------------- set default texengine (domain default overrides this)
	{
	$deftex = LONCAPA::texengine();
	}

	# ------------- set default minimum length for passwords for internal auth users
	{
	$passwdmin = LONCAPA::passwd_min();
	}

$memcache=new Cache::Memcached({'servers' => ['127.0.0.1:11211'],	$memcache=new Cache::Memcached({'servers' => ['127.0.0.1:11211'],
'compress_threshold'=> 20_000,	'compress_threshold'=> 20_000,
});	});
Line 14601 prevents recursive calls to &allowed.	Line 16664 prevents recursive calls to &allowed.
2: browse allowed	2: browse allowed
A: passphrase authentication needed	A: passphrase authentication needed
B: access temporarily blocked because of a blocking event in a course.	B: access temporarily blocked because of a blocking event in a course.
	D: access blocked because access is required via session initiated via deep-link

=item *	=item *

Line 14893 data base, returning a hash that is keye	Line 16957 data base, returning a hash that is keye
values that are the resource value. I believe that the timestamps and	values that are the resource value. I believe that the timestamps and
versions are also returned.	versions are also returned.

get_numsuppfiles($cnum,$cdom) : retrieve number of files in a course's
supplemental content area. This routine caches the number of files for
10 minutes.

=back	=back

=head2 Course Modification	=head2 Course Modification
Line 14931 Returns:	Line 16991 Returns:

=back	=back

	=head2 Bubblesheet Configuration

	=over 4

	=item *

	get_scantron_config($which)

	$which - the name of the configuration to parse from the file.

	Parses and returns the bubblesheet configuration line selected as a
	hash of configuration file fields.


	Returns:
	If the named configuration is not in the file, an empty
	hash is returned.

	a hash with the fields
	name - internal name for the this configuration setup
	description - text to display to operator that describes this config
	CODElocation - if 0 or the string 'none'
	- no CODE exists for this config
	if -1 \|\| the string 'letter'
	- a CODE exists for this config and is
	a string of letters
	Unsupported value (but planned for future support)
	if a positive integer
	- The CODE exists as the first n items from
	the question section of the form
	if the string 'number'
	- The CODE exists for this config and is
	a string of numbers
	CODEstart - (only matter if a CODE exists) column in the line where
	the CODE starts
	CODElength - length of the CODE
	IDstart - column where the student/employee ID starts
	IDlength - length of the student/employee ID info
	Qstart - column where the information from the bubbled
	'questions' start
	Qlength - number of columns comprising a single bubble line from
	the sheet. (usually either 1 or 10)
	Qon - either a single character representing the character used
	to signal a bubble was chosen in the positional setup, or
	the string 'letter' if the letter of the chosen bubble is
	in the final, or 'number' if a number representing the
	chosen bubble is in the file (1->A 0->J)
	Qoff - the character used to represent that a bubble was
	left blank
	PaperID - if the scanning process generates a unique number for each
	sheet scanned the column that this ID number starts in
	PaperIDlength - number of columns that comprise the unique ID number
	for the sheet of paper
	FirstName - column that the first name starts in
	FirstNameLength - number of columns that the first name spans
	LastName - column that the last name starts in
	LastNameLength - number of columns that the last name spans
	BubblesPerRow - number of bubbles available in each row used to
	bubble an answer. (If not specified, 10 assumed).


	=item *

	get_scantronformat_file($cdom)

	$cdom - the course's domain (optional); if not supplied, uses
	domain for current $env{'request.course.id'}.

	Returns an array containing lines from the scantron format file for
	the domain of the course.

	If a url for a custom.tab file is listed in domain's configuration.db,
	lines are from this file.

	Otherwise, if a default.tab has been published in RES space by the
	domainconfig user, lines are from this file.

	Otherwise, fall back to getting lines from the legacy file on the
	local server: /home/httpd/lonTabs/default_scantronformat.tab

	=back

=head2 Resource Subroutines	=head2 Resource Subroutines

=over 4	=over 4
Line 15628 userspace, probably shouldn't be called	Line 17770 userspace, probably shouldn't be called
formname: same as for userfileupload()	formname: same as for userfileupload()
fname: filename (including subdirectories) for the file	fname: filename (including subdirectories) for the file
parser: if 'parse', will parse (html) file to extract references to objects, links etc.	parser: if 'parse', will parse (html) file to extract references to objects, links etc.
	if hashref, and context is scantron, will convert csv format to standard format
allfiles: reference to hash used to store objects found by parser	allfiles: reference to hash used to store objects found by parser
codebase: reference to hash used for codebases of java objects found by parser	codebase: reference to hash used for codebases of java objects found by parser
thumbwidth: width (pixels) of thumbnail to be created for uploaded image	thumbwidth: width (pixels) of thumbnail to be created for uploaded image

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

Removed from v.1.1380
changed lines
	Added in v.1.1513