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.828 and 1.857

version 1.828, 2007/01/18 21:02:06	version 1.857, 2007/04/03 00:49:14
Line 35 use HTTP::Headers;	Line 35 use HTTP::Headers;
use HTTP::Date;	use HTTP::Date;
# use Date::Parse;	# use Date::Parse;
use vars	use vars
qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom	qw(%perlvar %badServerCache %spareid
%libserv %pr %prp $memcache %packagetab	%pr %prp $memcache %packagetab
%courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount	%courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf	%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf
%domaindescription %domain_auth_def %domain_auth_arg_def
%domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary
$tmpdir $_64bit %env);	$tmpdir $_64bit %env);

use IO::Socket;	use IO::Socket;
Line 146 sub logperm {	Line 144 sub logperm {
return 1;	return 1;
}	}

	sub create_connection {
	my ($hostname,$lonid) = @_;
	my $client=IO::Socket::UNIX->new(Peer => $perlvar{'lonSockCreate'},
	Type => SOCK_STREAM,
	Timeout => 10);
	return 0 if (!$client);
	print $client (join(':',$hostname,$lonid,&machine_ids($lonid))."\n");
	my $result = <$client>;
	chomp($result);
	return 1 if ($result eq 'done');
	return 0;
	}


# -------------------------------------------------- Non-critical communication	# -------------------------------------------------- Non-critical communication
sub subreply {	sub subreply {
my ($cmd,$server)=@_;	my ($cmd,$server)=@_;
my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server};	my $peerfile="$perlvar{'lonSockDir'}/".&hostname($server);
#	#
# With loncnew process trimming, there's a timing hole between lonc server	# With loncnew process trimming, there's a timing hole between lonc server
# process exit and the master server picking up the listen on the AF_UNIX	# process exit and the master server picking up the listen on the AF_UNIX
Line 172 sub subreply {	Line 184 sub subreply {
Timeout => 10);	Timeout => 10);
if($client) {	if($client) {
last; # Connected!	last; # Connected!
	} else {
	&create_connection(&hostname($server),$server);
}	}
sleep(1); # Try again later if failed connection.	sleep(1); # Try again later if failed connection.
}	}
my $answer;	my $answer;
if ($client) {	if ($client) {
Line 189 sub subreply {	Line 203 sub subreply {

sub reply {	sub reply {
my ($cmd,$server)=@_;	my ($cmd,$server)=@_;
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:".	&logthis("<font color=\"blue\">WARNING:".
Line 201 sub reply {	Line 215 sub reply {
# ----------------------------------------------------------- Send USR1 to lonc	# ----------------------------------------------------------- Send USR1 to lonc

sub reconlonc {	sub reconlonc {
my $peerfile=shift;	&logthis("Trying to reconnect lonc");
&logthis("Trying to reconnect for $peerfile");
my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";	my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
if (open(my $fh,"<$loncfile")) {	if (open(my $fh,"<$loncfile")) {
my $loncpid=<$fh>;	my $loncpid=<$fh>;
Line 211 sub reconlonc {	Line 224 sub reconlonc {
&logthis("lonc at pid $loncpid responding, sending USR1");	&logthis("lonc at pid $loncpid responding, sending USR1");
kill USR1 => $loncpid;	kill USR1 => $loncpid;
sleep 1;	sleep 1;
if (-e "$peerfile") { return; }	} else {
&logthis("$peerfile still not there, give it another try");
sleep 5;
if (-e "$peerfile") { return; }
&logthis(
"<font color=\"blue\">WARNING: $peerfile still not there, giving up</font>");
} else {
&logthis(	&logthis(
"<font color=\"blue\">WARNING:".	"<font color=\"blue\">WARNING:".
" lonc at pid $loncpid not responding, giving up</font>");	" lonc at pid $loncpid not responding, giving up</font>");
}	}
} else {	} else {
&logthis('<font color="blue">WARNING: lonc not running, giving up</font>');	&logthis('<font color="blue">WARNING: lonc not running, giving up</font>');
}	}
}	}

Line 231 sub reconlonc {	Line 238 sub reconlonc {

sub critical {	sub critical {
my ($cmd,$server)=@_;	my ($cmd,$server)=@_;
unless ($hostname{$server}) {	unless (&hostname($server)) {
&logthis("<font color=\"blue\">WARNING:".	&logthis("<font color=\"blue\">WARNING:".
" Critical message to unknown server ($server)</font>");	" Critical message to unknown server ($server)</font>");
return 'no_such_host';	return 'no_such_host';
Line 367 sub transfer_profile_to_env {	Line 374 sub transfer_profile_to_env {
}	}
}	}

	sub timed_flock {
	my ($file,$lock_type) = @_;
	my $failed=0;
	eval {
	local $SIG{__DIE__}='DEFAULT';
	local $SIG{ALRM}=sub {
	$failed=1;
	die("failed lock");
	};
	alarm(13);
	flock($file,$lock_type);
	alarm(0);
	};
	if ($failed) {
	return undef;
	} else {
	return 1;
	}
	}

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

sub appenv {	sub appenv {
Line 381 sub appenv {	Line 408 sub appenv {
$env{$key}=$newenv{$key};	$env{$key}=$newenv{$key};
}	}
}	}
if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(),	open(my $env_file,$env{'user.environment'});
0640)) {	if (&timed_flock($env_file,LOCK_EX)
	&&
	tie(my %disk_env,'GDBM_File',$env{'user.environment'},
	(&GDBM_WRITER()\|&GDBM_NOLOCK()),0640)) {
while (my ($key,$value) = each(%newenv)) {	while (my ($key,$value) = each(%newenv)) {
$disk_env{$key} = $value;	$disk_env{$key} = $value;
}	}
Line 399 sub delenv {	Line 429 sub delenv {
"Attempt to delete from environment ".$delthis);	"Attempt to delete from environment ".$delthis);
return 'error';	return 'error';
}	}
if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(),	open(my $env_file,$env{'user.environment'});
0640)) {	if (&timed_flock($env_file,LOCK_EX)
	&&
	tie(my %disk_env,'GDBM_File',$env{'user.environment'},
	(&GDBM_WRITER()\|&GDBM_NOLOCK()),0640)) {
foreach my $key (keys(%disk_env)) {	foreach my $key (keys(%disk_env)) {
if ($key=~/^$delthis/) {	if ($key=~/^$delthis/) {
delete($env{$key});	delete($env{$key});
Line 498 sub spareserver {	Line 531 sub spareserver {
}	}

if (!$want_server_name) {	if (!$want_server_name) {
$spare_server="http://$hostname{$spare_server}";	$spare_server="http://".&hostname($spare_server);
}	}
return $spare_server;	return $spare_server;
}	}
Line 589 sub authenticate {	Line 622 sub authenticate {
my ($uname,$upass,$udom)=@_;	my ($uname,$upass,$udom)=@_;
$upass=&escape($upass);	$upass=&escape($upass);
$uname= &LONCAPA::clean_username($uname);	$uname= &LONCAPA::clean_username($uname);
my $uhome=&homeserver($uname,$udom);	my $uhome=&homeserver($uname,$udom,1);
if (!$uhome) {	if ((!$uhome) \|\| ($uhome eq 'no_host')) {
&logthis("User $uname at $udom is unknown in authenticate");	# Maybe the machine was offline and only re-appeared again recently?
	&reconlonc();
	# One more
	my $uhome=&homeserver($uname,$udom,1);
	if ((!$uhome) \|\| ($uhome eq 'no_host')) {
	&logthis("User $uname at $udom is unknown in authenticate");
	}
return 'no_host';	return 'no_host';
}	}
my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome);	my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome);
Line 615 sub homeserver {	Line 654 sub homeserver {
my $index="$uname:$udom";	my $index="$uname:$udom";

if (exists($homecache{$index})) { return $homecache{$index}; }	if (exists($homecache{$index})) { return $homecache{$index}; }
my $tryserver;
foreach $tryserver (keys %libserv) {	my %servers = &get_servers($udom,'library');
	foreach my $tryserver (keys(%servers)) {
next if ($ignoreBadCache ne 'true' &&	next if ($ignoreBadCache ne 'true' &&
exists($badServerCache{$tryserver}));	exists($badServerCache{$tryserver}));
if ($hostdom{$tryserver} eq $udom) {
my $answer=reply("home:$udom:$uname",$tryserver);	my $answer=reply("home:$udom:$uname",$tryserver);
if ($answer eq 'found') {	if ($answer eq 'found') {
return $homecache{$index}=$tryserver;	delete($badServerCache{$tryserver});
} elsif ($answer eq 'no_host') {	return $homecache{$index}=$tryserver;
$badServerCache{$tryserver}=1;	} elsif ($answer eq 'no_host') {
}	$badServerCache{$tryserver}=1;
}	}
}	}
return 'no_host';	return 'no_host';
}	}
Line 637 sub idget {	Line 677 sub idget {
my ($udom,@ids)=@_;	my ($udom,@ids)=@_;
my %returnhash=();	my %returnhash=();

my $tryserver;	my %servers = &get_servers($udom,'library');
foreach $tryserver (keys %libserv) {	foreach my $tryserver (keys(%servers)) {
if ($hostdom{$tryserver} eq $udom) {	my $idlist=join('&',@ids);
my $idlist=join('&',@ids);	$idlist=~tr/A-Z/a-z/;
$idlist=~tr/A-Z/a-z/;	my $reply=&reply("idget:$udom:".$idlist,$tryserver);
my $reply=&reply("idget:$udom:".$idlist,$tryserver);	my @answer=();
my @answer=();	if (($reply ne 'con_lost') && ($reply!~/^error\:/)) {
if (($reply ne 'con_lost') && ($reply!~/^error\:/)) {	@answer=split(/\&/,$reply);
@answer=split(/\&/,$reply);	} ;
} ;	my $i;
my $i;	for ($i=0;$i<=$#ids;$i++) {
for ($i=0;$i<=$#ids;$i++) {	if ($answer[$i]) {
if ($answer[$i]) {	$returnhash{$ids[$i]}=$answer[$i];
$returnhash{$ids[$i]}=$answer[$i];	}
}	}
}	}
}
}
return %returnhash;	return %returnhash;
}	}

Line 703 sub get_dom {	Line 741 sub get_dom {
}	}
$items=~s/\&$//;	$items=~s/\&$//;
if (!$udom) { $udom=$env{'user.domain'}; }	if (!$udom) { $udom=$env{'user.domain'}; }
if (exists($domain_primary{$udom})) {	if (defined(&domain($udom,'primary'))) {
my $uhome=$domain_primary{$udom};	my $uhome=&domain($udom,'primary');
my $rep=&reply("getdom:$udom:$namespace:$items",$uhome);	my $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
my @pairs=split(/\&/,$rep);	my @pairs=split(/\&/,$rep);
if ( $#pairs==0 && $pairs[0] =~ /^(con_lost\|error\|no_such_host)/i) {	if ( $#pairs==0 && $pairs[0] =~ /^(con_lost\|error\|no_such_host)/i) {
Line 727 sub get_dom {	Line 765 sub get_dom {
sub put_dom {	sub put_dom {
my ($namespace,$storehash,$udom)=@_;	my ($namespace,$storehash,$udom)=@_;
if (!$udom) { $udom=$env{'user.domain'}; }	if (!$udom) { $udom=$env{'user.domain'}; }
if (exists($domain_primary{$udom})) {	if (defined(&domain($udom,'primary'))) {
my $uhome=$domain_primary{$udom};	my $uhome=&domain($udom,'primary');
my $items='';	my $items='';
foreach my $item (keys(%$storehash)) {	foreach my $item (keys(%$storehash)) {
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';	$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
Line 740 sub put_dom {	Line 778 sub put_dom {
}	}
}	}

	sub retrieve_inst_usertypes {
	my ($udom) = @_;
	my (%returnhash,@order);
	if (defined(&domain($udom,'primary'))) {
	my $uhome=&domain($udom,'primary');
	my $rep=&reply("inst_usertypes:$udom",$uhome);
	my ($hashitems,$orderitems) = split(/:/,$rep);
	my @pairs=split(/\&/,$hashitems);
	foreach my $item (@pairs) {
	my ($key,$value)=split(/=/,$item,2);
	$key = &unescape($key);
	next if ($key =~ /^error: 2 /);
	$returnhash{$key}=&thaw_unescape($value);
	}
	my @esc_order = split(/\&/,$orderitems);
	foreach my $item (@esc_order) {
	push(@order,&unescape($item));
	}
	} else {
	&logthis("get_dom failed - no primary domain server for $udom");
	}
	return (\%returnhash,\@order);
	}

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

sub assign_access_key {	sub assign_access_key {
Line 964 my %remembered;	Line 1026 my %remembered;
my %accessed;	my %accessed;
my $kicks=0;	my $kicks=0;
my $hits=0;	my $hits=0;
	sub make_key {
	my ($name,$id) = @_;
	if (length($id) > 200) { $id=length($id).':'.&Digest::MD5::md5_hex($id); }
	return &escape($name.':'.$id);
	}

sub devalidate_cache_new {	sub devalidate_cache_new {
my ($name,$id,$debug) = @_;	my ($name,$id,$debug) = @_;
if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }	if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }
$id=&escape($name.':'.$id);	$id=&make_key($name,$id);
$memcache->delete($id);	$memcache->delete($id);
delete($remembered{$id});	delete($remembered{$id});
delete($accessed{$id});	delete($accessed{$id});
Line 975 sub devalidate_cache_new {	Line 1043 sub devalidate_cache_new {

sub is_cached_new {	sub is_cached_new {
my ($name,$id,$debug) = @_;	my ($name,$id,$debug) = @_;
$id=&escape($name.':'.$id);	$id=&make_key($name,$id);
if (exists($remembered{$id})) {	if (exists($remembered{$id})) {
if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); }	if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); }
$accessed{$id}=[&gettimeofday()];	$accessed{$id}=[&gettimeofday()];
Line 998 sub is_cached_new {	Line 1066 sub is_cached_new {

sub do_cache_new {	sub do_cache_new {
my ($name,$id,$value,$time,$debug) = @_;	my ($name,$id,$value,$time,$debug) = @_;
$id=&escape($name.':'.$id);	$id=&make_key($name,$id);
my $setvalue=$value;	my $setvalue=$value;
if (!defined($setvalue)) {	if (!defined($setvalue)) {
$setvalue='__undef__';	$setvalue='__undef__';
Line 1425 sub store_edited_file {	Line 1493 sub store_edited_file {
}	}

sub clean_filename {	sub clean_filename {
my ($fname)=@_;	my ($fname,$args)=@_;
# Replace Windows backslashes by forward slashes	# Replace Windows backslashes by forward slashes
$fname=~s/\\/\//g;	$fname=~s/\\/\//g;
# Get rid of everything but the actual filename	if (!$args->{'keep_path'}) {
$fname=~s/^.*\/([^\/]+)$/$1/;	# Get rid of everything but the actual filename
	$fname=~s/^.*\/([^\/]+)$/$1/;
	}
# Replace spaces by underscores	# Replace spaces by underscores
$fname=~s/\s+/\_/g;	$fname=~s/\s+/\_/g;
# 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;
Line 1791 sub flushcourselogs {	Line 1861 sub flushcourselogs {
# Write course id database (reverse lookup) to homeserver of courses	# Write course id database (reverse lookup) to homeserver of courses
# Is used in pickcourse	# Is used in pickcourse
#	#
foreach my $crsid (keys(%courseidbuffer)) {	foreach my $crs_home (keys(%courseidbuffer)) {
&courseidput($hostdom{$crsid},$courseidbuffer{$crsid},$crsid);	&courseidput(&host_domain($crs_home),$courseidbuffer{$crs_home},
	$crs_home);
}	}
#	#
# File accesses	# File accesses
Line 1859 sub flushcourselogs {	Line 1930 sub flushcourselogs {
delete $domainrolehash{$entry};	delete $domainrolehash{$entry};
}	}
foreach my $dom (keys(%domrolebuffer)) {	foreach my $dom (keys(%domrolebuffer)) {
foreach my $tryserver (keys %libserv) {	my %servers = &get_servers($dom,'library');
if ($hostdom{$tryserver} eq $dom) {	foreach my $tryserver (keys(%servers)) {
unless (&reply('domroleput:'.$dom.':'.	unless (&reply('domroleput:'.$dom.':'.
$domrolebuffer{$dom},$tryserver) eq 'ok') {	$domrolebuffer{$dom},$tryserver) eq 'ok') {
&logthis('Put of domain roles failed for '.$dom.' and '.$tryserver);	&logthis('Put of domain roles failed for '.$dom.' and '.$tryserver);
}	}
}
}	}
}	}
$dumpcount++;	$dumpcount++;
Line 1999 sub get_course_adv_roles {	Line 2069 sub get_course_adv_roles {
}	}

sub get_my_roles {	sub get_my_roles {
my ($uname,$udom)=@_;	my ($uname,$udom,$types,$roles,$roledoms)=@_;
unless (defined($uname)) { $uname=$env{'user.name'}; }	unless (defined($uname)) { $uname=$env{'user.name'}; }
unless (defined($udom)) { $udom=$env{'user.domain'}; }	unless (defined($udom)) { $udom=$env{'user.domain'}; }
my %dumphash=	my %dumphash=
Line 2009 sub get_my_roles {	Line 2079 sub get_my_roles {
foreach my $entry (keys(%dumphash)) {	foreach my $entry (keys(%dumphash)) {
my ($tend,$tstart)=split(/\:/,$dumphash{$entry});	my ($tend,$tstart)=split(/\:/,$dumphash{$entry});
if (($tstart) && ($tstart<0)) { next; }	if (($tstart) && ($tstart<0)) { next; }
if (($tend) && ($tend<$now)) { next; }	my $status = 'active';
if (($tstart) && ($now<$tstart)) { next; }	if (($tend) && ($tend<$now)) {
	$status = 'previous';
	}
	if (($tstart) && ($now<$tstart)) {
	$status = 'future';
	}
	if (ref($types) eq 'ARRAY') {
	if (!grep(/^\Q$status\E$/,@{$types})) {
	next;
	}
	} else {
	if ($status ne 'active') {
	next;
	}
	}
my ($role,$username,$domain,$section)=split(/\:/,$entry);	my ($role,$username,$domain,$section)=split(/\:/,$entry);
	if (ref($roledoms) eq 'ARRAY') {
	if (!grep(/^\Q$domain\E$/,@{$roledoms})) {
	next;
	}
	}
	if (ref($roles) eq 'ARRAY') {
	if (!grep(/^\Q$role\E$/,@{$roles})) {
	next;
	}
	}
$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;	$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
}	}
return %returnhash;	return %returnhash;
}	}

Line 2023 sub get_my_roles {	Line 2117 sub get_my_roles {

sub postannounce {	sub postannounce {
my ($server,$text)=@_;	my ($server,$text)=@_;
unless (&allowed('psa',$hostdom{$server})) { return 'refused'; }	unless (&allowed('psa',&host_domain($server))) { return 'refused'; }
unless ($text=~/\w/) { $text=''; }	unless ($text=~/\w/) { $text=''; }
return &reply('setannounce:'.&escape($text),$server);	return &reply('setannounce:'.&escape($text),$server);
}	}
Line 2059 sub courseiddump {	Line 2153 sub courseiddump {
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_;	my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_;
my %returnhash=();	my %returnhash=();
unless ($domfilter) { $domfilter=''; }	unless ($domfilter) { $domfilter=''; }
foreach my $tryserver (keys %libserv) {	my %libserv = &all_library();
if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) \|\| (!defined($hostidflag)) ) {	foreach my $tryserver (keys(%libserv)) {
if ((!$domfilter) \|\| ($hostdom{$tryserver} eq $domfilter)) {	if ( ( $hostidflag == 1
	&& grep(/^\Q$tryserver\E$/,@{$hostidref}) )
	\|\| (!defined($hostidflag)) ) {

	if ($domfilter eq ''
	\|\| (&host_domain($tryserver) eq $domfilter)) {
foreach my $line (	foreach my $line (
split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.	split(/\&/,&reply('courseiddump:'.&host_domain($tryserver).':'.
$sincefilter.':'.&escape($descfilter).':'.	$sincefilter.':'.&escape($descfilter).':'.
&escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter).':'.&escape($regexp_ok),	&escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter).':'.&escape($regexp_ok),
$tryserver))) {	$tryserver))) {
Line 2091 sub dcmailput {	Line 2190 sub dcmailput {
sub dcmaildump {	sub dcmaildump {
my ($dom,$startdate,$enddate,$senders) = @_;	my ($dom,$startdate,$enddate,$senders) = @_;
my %returnhash=();	my %returnhash=();
if (exists($domain_primary{$dom})) {
	if (defined(&domain($dom,'primary'))) {
my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'.	my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'.
&escape($enddate).':';	&escape($enddate).':';
my @esc_senders=map { &escape($_)} @$senders;	my @esc_senders=map { &escape($_)} @$senders;
$cmd.=&escape(join('&',@esc_senders));	$cmd.=&escape(join('&',@esc_senders));
foreach my $line (split(/\&/,&reply($cmd,$domain_primary{$dom}))) {	foreach my $line (split(/\&/,&reply($cmd,&domain($dom,'primary')))) {
my ($key,$value) = split(/\=/,$line,2);	my ($key,$value) = split(/\=/,$line,2);
if (($key) && ($value)) {	if (($key) && ($value)) {
$returnhash{&unescape($key)} = &unescape($value);	$returnhash{&unescape($key)} = &unescape($value);
Line 2117 sub get_domain_roles {	Line 2217 sub get_domain_roles {
}	}
my $rolelist = join(':',@{$roles});	my $rolelist = join(':',@{$roles});
my %personnel = ();	my %personnel = ();
foreach my $tryserver (keys(%libserv)) {
if ($hostdom{$tryserver} eq $dom) {	my %servers = &get_servers($dom,'library');
%{$personnel{$tryserver}}=();	foreach my $tryserver (keys(%servers)) {
foreach my $line (	%{$personnel{$tryserver}}=();
split(/\&/,&reply('domrolesdump:'.$dom.':'.	foreach my $line (split(/\&/,&reply('domrolesdump:'.$dom.':'.
&escape($startdate).':'.&escape($enddate).':'.	&escape($startdate).':'.
&escape($rolelist), $tryserver))) {	&escape($enddate).':'.
my ($key,$value) = split(/\=/,$line,2);	&escape($rolelist), $tryserver))) {
if (($key) && ($value)) {	my ($key,$value) = split(/\=/,$line,2);
$personnel{$tryserver}{&unescape($key)} = &unescape($value);	if (($key) && ($value)) {
}	$personnel{$tryserver}{&unescape($key)} = &unescape($value);
}	}
}	}
}	}
return %personnel;	return %personnel;
}	}
Line 2219 sub checkin {	Line 2319 sub checkin {
my $now=time;	my $now=time;
my ($ta,$tb,$lonhost)=split(/\*/,$token);	my ($ta,$tb,$lonhost)=split(/\*/,$token);
$lonhost=~tr/A-Z/a-z/;	$lonhost=~tr/A-Z/a-z/;
my $dtoken=$ta.'_'.$hostname{$lonhost}.'_'.$tb;	my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb;
$dtoken=~s/\W/\_/g;	$dtoken=~s/\W/\_/g;
my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=	my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));	split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
Line 2888 sub custom_roleprivs {	Line 2988 sub custom_roleprivs {
my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;	my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;
my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);	my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
my $homsvr=homeserver($rauthor,$rdomain);	my $homsvr=homeserver($rauthor,$rdomain);
if ($hostname{$homsvr} ne '') {	if (&hostname($homsvr) ne '') {
my ($rdummy,$roledef)=	my ($rdummy,$roledef)=
&get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);	&get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);
if (($rdummy ne 'con_lost') && ($roledef ne '')) {	if (($rdummy ne 'con_lost') && ($roledef ne '')) {
Line 4096 sub definerole {	Line 4196 sub definerole {
sub metadata_query {	sub metadata_query {
my ($query,$custom,$customshow,$server_array)=@_;	my ($query,$custom,$customshow,$server_array)=@_;
my %rhash;	my %rhash;
	my %libserv = &all_library();
my @server_list = (defined($server_array) ? @$server_array	my @server_list = (defined($server_array) ? @$server_array
: keys(%libserv) );	: keys(%libserv) );
for my $server (@server_list) {	for my $server (@server_list) {
Line 4119 sub log_query {	Line 4220 sub log_query {
my ($uname,$udom,$query,%filters)=@_;	my ($uname,$udom,$query,%filters)=@_;
my $uhome=&homeserver($uname,$udom);	my $uhome=&homeserver($uname,$udom);
if ($uhome eq 'no_host') { return 'error: no_host'; }	if ($uhome eq 'no_host') { return 'error: no_host'; }
my $uhost=$hostname{$uhome};	my $uhost=&hostname($uhome);
my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys(%filters)));	my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys(%filters)));
my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command,	my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command,
$uhome);	$uhome);
Line 4151 sub fetch_enrollment_query {	Line 4252 sub fetch_enrollment_query {
} else {	} else {
$homeserver = &homeserver($cnum,$dom);	$homeserver = &homeserver($cnum,$dom);
}	}
my $host=$hostname{$homeserver};	my $host=&hostname($homeserver);
my $cmd = '';	my $cmd = '';
foreach my $affiliate (keys %{$affiliatesref}) {	foreach my $affiliate (keys %{$affiliatesref}) {
$cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';	$cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
Line 4342 sub auto_photochoice {	Line 4443 sub auto_photochoice {
sub auto_photoupdate {	sub auto_photoupdate {
my ($affiliatesref,$dom,$cnum,$photo) = @_;	my ($affiliatesref,$dom,$cnum,$photo) = @_;
my $homeserver = &homeserver($cnum,$dom);	my $homeserver = &homeserver($cnum,$dom);
my $host=$hostname{$homeserver};	my $host=&hostname($homeserver);
my $cmd = '';	my $cmd = '';
my $maxtries = 1;	my $maxtries = 1;
foreach my $affiliate (keys(%{$affiliatesref})) {	foreach my $affiliate (keys(%{$affiliatesref})) {
Line 4382 sub auto_instcode_format {	Line 4483 sub auto_instcode_format {
my $courses = '';	my $courses = '';
my @homeservers;	my @homeservers;
if ($caller eq 'global') {	if ($caller eq 'global') {
foreach my $tryserver (keys(%libserv)) {	my %servers = &get_servers($codedom,'library');
if ($hostdom{$tryserver} eq $codedom) {	foreach my $tryserver (keys(%servers)) {
if (!grep(/^\Q$tryserver\E$/,@homeservers)) {	if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
push(@homeservers,$tryserver);	push(@homeservers,$tryserver);
}	}
}
}	}
} else {	} else {
push(@homeservers,&homeserver($caller,$codedom));	push(@homeservers,&homeserver($caller,$codedom));
Line 4421 sub auto_instcode_format {	Line 4521 sub auto_instcode_format {
sub auto_instcode_defaults {	sub auto_instcode_defaults {
my ($domain,$returnhash,$code_order) = @_;	my ($domain,$returnhash,$code_order) = @_;
my @homeservers;	my @homeservers;
foreach my $tryserver (keys(%libserv)) {
if ($hostdom{$tryserver} eq $domain) {	my %servers = &get_servers($domain,'library');
if (!grep(/^\Q$tryserver\E$/,@homeservers)) {	foreach my $tryserver (keys(%servers)) {
push(@homeservers,$tryserver);	if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
}	push(@homeservers,$tryserver);
}	}
}	}
my $ok_response = 0;
my $response;	my $response;
while (@homeservers > 0 && $ok_response == 0) {	foreach my $server (@homeservers) {
my $server = shift(@homeservers);
$response=&reply('autoinstcodedefaults:'.$domain,$server);	$response=&reply('autoinstcodedefaults:'.$domain,$server);
if ($response !~ /(con_lost\|error\|no_such_host\|refused)/) {	next if ($response =~ /(con_lost\|error\|no_such_host\|refused)/);
foreach my $pair (split(/\&/,$response)) {
my ($name,$value)=split(/\=/,$pair);	foreach my $pair (split(/\&/,$response)) {
if ($name eq 'code_order') {	my ($name,$value)=split(/\=/,$pair);
@{$code_order} = split(/\&/,&unescape($value));	if ($name eq 'code_order') {
} else {	@{$code_order} = split(/\&/,&unescape($value));
$returnhash->{&unescape($name)}=&unescape($value);	} else {
}	$returnhash->{&unescape($name)}=&unescape($value);
}	}
$ok_response = 1;	}
}	return 'ok';
}
if ($ok_response) {
return 'ok';
} else {
return $response;
}	}

	return $response;
}	}

sub auto_validate_class_sec {	sub auto_validate_class_sec {
Line 4742 sub modifyuser {	Line 4838 sub modifyuser {
if (($uhome eq 'no_host') &&	if (($uhome eq 'no_host') &&
(($umode && $upass) \|\| ($umode eq 'localauth'))) {	(($umode && $upass) \|\| ($umode eq 'localauth'))) {
my $unhome='';	my $unhome='';
if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) {	if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) {
$unhome = $desiredhome;	$unhome = $desiredhome;
} elsif($env{'course.'.$env{'request.course.id'}.'.domain'} eq $udom) {	} elsif($env{'course.'.$env{'request.course.id'}.'.domain'} eq $udom) {
$unhome=$env{'course.'.$env{'request.course.id'}.'.home'};	$unhome=$env{'course.'.$env{'request.course.id'}.'.home'};
} else { # load balancing routine for determining $unhome	} else { # load balancing routine for determining $unhome
my $tryserver;
my $loadm=10000000;	my $loadm=10000000;
foreach $tryserver (keys %libserv) {	my %servers = &get_servers($udom,'library');
if ($hostdom{$tryserver} eq $udom) {	foreach my $tryserver (keys(%servers)) {
my $answer=reply('load',$tryserver);	my $answer=reply('load',$tryserver);
if (($answer=~/\d+/) && ($answer<$loadm)) {	if (($answer=~/\d+/) && ($answer<$loadm)) {
$loadm=$answer;	$loadm=$answer;
$unhome=$tryserver;	$unhome=$tryserver;
}	}
}
}	}
}	}
if (($unhome eq '') \|\| ($unhome eq 'no_host')) {	if (($unhome eq '') \|\| ($unhome eq 'no_host')) {
Line 4971 sub createcourse {	Line 5065 sub createcourse {
}	}
# ------------------------------------------------ Check supplied server name	# ------------------------------------------------ Check supplied server name
$course_server = $env{'user.homeserver'} if (! defined($course_server));	$course_server = $env{'user.homeserver'} if (! defined($course_server));
if (! exists($libserv{$course_server})) {	if (! &is_library($course_server)) {
return 'error:bad server name '.$course_server;	return 'error:bad server name '.$course_server;
}	}
# ------------------------------------------------------------- Make the course	# ------------------------------------------------------------- Make the course
Line 5082 sub is_locked {	Line 5176 sub is_locked {

sub declutter_portfile {	sub declutter_portfile {
my ($file) = @_;	my ($file) = @_;
&logthis("got $file");	$file =~ s{^(/portfolio/\|portfolio/)}{/};
$file =~ s-^(/portfolio/\|portfolio/)-/-;
&logthis("ret $file");
return $file;	return $file;
}	}

Line 5506 sub dirlist {	Line 5598 sub dirlist {
return @listing_results;	return @listing_results;
} elsif(!defined($alternateDirectoryRoot)) {	} elsif(!defined($alternateDirectoryRoot)) {
my %allusers;	my %allusers;
foreach my $tryserver (keys(%libserv)) {	my %servers = &get_servers($udom,'library');
if($hostdom{$tryserver} eq $udom) {	foreach my $tryserver (keys(%servers)) {
my $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.	my $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.
$udom, $tryserver);	$udom, $tryserver);
my @listing_results;	my @listing_results;
if ($listing eq 'unknown_cmd') {	if ($listing eq 'unknown_cmd') {
$listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.	$listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.
$udom, $tryserver);	$udom, $tryserver);
@listing_results = split(/:/,$listing);	@listing_results = split(/:/,$listing);
} else {	} else {
@listing_results =	@listing_results =
map { &unescape($_); } split(/:/,$listing);	map { &unescape($_); } split(/:/,$listing);
}	}
if ($listing_results[0] ne 'no_such_dir' &&	if ($listing_results[0] ne 'no_such_dir' &&
$listing_results[0] ne 'empty' &&	$listing_results[0] ne 'empty' &&
$listing_results[0] ne 'con_lost') {	$listing_results[0] ne 'con_lost') {
foreach my $line (@listing_results) {	foreach my $line (@listing_results) {
my ($entry) = split(/&/,$line,2);	my ($entry) = split(/&/,$line,2);
$allusers{$entry} = 1;	$allusers{$entry} = 1;
}	}
}	}
}
}	}
my $alluserstr='';	my $alluserstr='';
foreach my $user (sort(keys(%allusers))) {	foreach my $user (sort(keys(%allusers))) {
Line 5539 sub dirlist {	Line 5630 sub dirlist {
return ('missing user name');	return ('missing user name');
}	}
} elsif(!defined($alternateDirectoryRoot)) {	} elsif(!defined($alternateDirectoryRoot)) {
my $tryserver;	my @all_domains = sort(&all_domains());
my %alldom=();	foreach my $domain (@all_domains) {
foreach $tryserver (keys(%libserv)) {	$domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain';
$alldom{$hostdom{$tryserver}}=1;	}
}	return @all_domains;
my $alldomstr='';	} else {
foreach my $domain (sort(keys(%alldom))) {
$alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain:';
}
$alldomstr=~s/:$//;
return split(/:/,$alldomstr);
} else {
return ('missing domain');	return ('missing domain');
}	}
}	}
Line 6113 sub packages_tab_default {	Line 6198 sub packages_tab_default {
$do_default=1;	$do_default=1;
} elsif ($pack_type eq 'extension') {	} elsif ($pack_type eq 'extension') {
push(@extension,[$package,$pack_type,$pack_part]);	push(@extension,[$package,$pack_type,$pack_part]);
} else {	} elsif ($pack_part eq $part) {
	# only look at packages defaults for packages that this id is
push(@specifics,[$package,$pack_type,$pack_part]);	push(@specifics,[$package,$pack_type,$pack_part]);
}	}
}	}
Line 7035 sub setup_random_from_rndseed {	Line 7121 sub setup_random_from_rndseed {
}	}

sub latest_receipt_algorithm_id {	sub latest_receipt_algorithm_id {
return 'receipt2';	return 'receipt3';
}	}

sub recunique {	sub recunique {
my $fucourseid=shift;	my $fucourseid=shift;
my $unique;	my $unique;
if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') {	if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' \|\|
	$env{"course.$fucourseid.receiptalg"} eq 'receipt3' ) {
$unique=$env{"course.$fucourseid.internal.encseed"};	$unique=$env{"course.$fucourseid.internal.encseed"};
} else {	} else {
$unique=$perlvar{'lonReceipt'};	$unique=$perlvar{'lonReceipt'};
Line 7052 sub recunique {	Line 7139 sub recunique {
sub recprefix {	sub recprefix {
my $fucourseid=shift;	my $fucourseid=shift;
my $prefix;	my $prefix;
if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') {	if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2'\|\|
	$env{"course.$fucourseid.receiptalg"} eq 'receipt3' ) {
$prefix=$env{"course.$fucourseid.internal.encpref"};	$prefix=$env{"course.$fucourseid.internal.encpref"};
} else {	} else {
$prefix=$perlvar{'lonHostID'};	$prefix=$perlvar{'lonHostID'};
Line 7062 sub recprefix {	Line 7150 sub recprefix {

sub ireceipt {	sub ireceipt {
my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_;	my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_;

	my $return =&recprefix($fucourseid).'-';

	if ($env{"course.$fucourseid.receiptalg"} eq 'receipt3' \|\|
	$env{'request.state'} eq 'construct') {
	$return .= (&digest("$funame,$fudom,$fucourseid,$fusymb,$part")%10000);
	return $return;
	}

my $cuname=unpack("%32C*",$funame);	my $cuname=unpack("%32C*",$funame);
my $cudom=unpack("%32C*",$fudom);	my $cudom=unpack("%32C*",$fudom);
my $cucourseid=unpack("%32C*",$fucourseid);	my $cucourseid=unpack("%32C*",$fucourseid);
my $cusymb=unpack("%32C*",$fusymb);	my $cusymb=unpack("%32C*",$fusymb);
my $cunique=&recunique($fucourseid);	my $cunique=&recunique($fucourseid);
my $cpart=unpack("%32S*",$part);	my $cpart=unpack("%32S*",$part);
my $return =&recprefix($fucourseid).'-';	if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') {
if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' \|\|
$env{'request.state'} eq 'construct') {
#&logthis("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname)." and ".($cpart%$cudom));	#&logthis("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname)." and ".($cpart%$cudom));

$return.= ($cunique%$cuname+	$return.= ($cunique%$cuname+
Line 7202 sub repcopy_userfile {	Line 7298 sub repcopy_userfile {
if (-e $transferfile) { return 'ok'; }	if (-e $transferfile) { return 'ok'; }
my $request;	my $request;
$uri=~s/^\///;	$uri=~s/^\///;
if (&homeserver($cnum,$cdom) eq $perlvar{'lonHostID'}) {	$request=new HTTP::Request('GET','http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri);
# if this is my own server, get it via tokenwrapper
$request=new HTTP::Request('GET',&tokenwrapper('/'.$uri));
} else {
# get it from another server, raw request
$request=new HTTP::Request('GET','http://'.$hostname{&homeserver($cnum,$cdom)}.'/raw/'.$uri);
}
my $response=$ua->request($request,$transferfile);	my $response=$ua->request($request,$transferfile);
# did it work?	# did it work?
if ($response->is_error()) {	if ($response->is_error()) {
Line 7231 sub tokenwrapper {	Line 7321 sub tokenwrapper {
if ($udom && $uname && $file) {	if ($udom && $uname && $file) {
$file=~s\|(\?\.)$\|\|;	$file=~s\|(\?\.)$\|\|;
&appenv("userfile.$udom/$uname/$file" => $env{'request.course.id'});	&appenv("userfile.$udom/$uname/$file" => $env{'request.course.id'});
return 'http://'.$hostname{ &homeserver($uname,$udom)}.'/'.$uri.	return 'http://'.&hostname(&homeserver($uname,$udom)).'/'.$uri.
(($uri=~/\?/)?'&':'?').'token='.$token.	(($uri=~/\?/)?'&':'?').'token='.$token.
'&tokenissued='.$perlvar{'lonHostID'};	'&tokenissued='.$perlvar{'lonHostID'};
} else {	} else {
Line 7246 sub tokenwrapper {	Line 7336 sub tokenwrapper {
sub getuploaded {	sub getuploaded {
my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;	my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
$uri=~s/^\///;	$uri=~s/^\///;
$uri = 'http://'.$hostname{ &homeserver($cnum,$cdom)}.'/raw/'.$uri;	$uri = 'http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri;
my $ua=new LWP::UserAgent;	my $ua=new LWP::UserAgent;
my $request=new HTTP::Request($reqtype,$uri);	my $request=new HTTP::Request($reqtype,$uri);
my $response=$ua->request($request);	my $response=$ua->request($request);
Line 7336 sub hreflocation {	Line 7426 sub hreflocation {
}	}

sub current_machine_domains {	sub current_machine_domains {
my $hostname=$hostname{$perlvar{'lonHostID'}};	return &machine_domains(&hostname($perlvar{'lonHostID'}));
	}

	sub machine_domains {
	my ($hostname) = @_;
my @domains;	my @domains;
	my %hostname = &all_hostnames();
while( my($id, $name) = each(%hostname)) {	while( my($id, $name) = each(%hostname)) {
# &logthis("-$id-$name-$hostname-");	# &logthis("-$id-$name-$hostname-");
if ($hostname eq $name) {	if ($hostname eq $name) {
push(@domains,$hostdom{$id});	push(@domains,&host_domain($id));
}	}
}	}
return @domains;	return @domains;
}	}

sub current_machine_ids {	sub current_machine_ids {
my $hostname=$hostname{$perlvar{'lonHostID'}};	return &machine_ids(&hostname($perlvar{'lonHostID'}));
	}

	sub machine_ids {
	my ($hostname) = @_;
	$hostname \|\|= &hostname($perlvar{'lonHostID'});
my @ids;	my @ids;
	my %hostname = &all_hostnames();
while( my($id, $name) = each(%hostname)) {	while( my($id, $name) = each(%hostname)) {
# &logthis("-$id-$name-$hostname-");	# &logthis("-$id-$name-$hostname-");
if ($hostname eq $name) {	if ($hostname eq $name) {
Line 7488 sub goodbye {	Line 7589 sub goodbye {
}	}

BEGIN {	BEGIN {

# ----------------------------------- Read loncapa.conf and loncapa_apache.conf	# ----------------------------------- Read loncapa.conf and loncapa_apache.conf
unless ($readit) {	unless ($readit) {
{	{
Line 7495 BEGIN {	Line 7597 BEGIN {
%perlvar = (%perlvar,%{$configvars});	%perlvar = (%perlvar,%{$configvars});
}	}

	sub get_dns {
	my ($url,$func) = @_;
	open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
	foreach my $dns (<$config>) {
	next if ($dns !~ /^\^(\S*)/x);
	$dns = $1;
	my $ua=new LWP::UserAgent;
	my $request=new HTTP::Request('GET',"http://$dns$url");
	my $response=$ua->request($request);
	next if ($response->is_error());
	my @content = split("\n",$response->content);
	&$func(\@content);
	}
	close($config);
	}
# ------------------------------------------------------------ Read domain file	# ------------------------------------------------------------ Read domain file
{	{
%domaindescription = ();	my $loaded;
%domain_auth_def = ();	my %domain;
%domain_auth_arg_def = ();
my $fh;	sub parse_domain_tab {
if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) {	my ($lines) = @_;
while (my $line = <$fh>) {	foreach my $line (@$lines) {
next if ($line =~ /^(\#\|\s*$)/);	next if ($line =~ /^(\#\|\s*$ )/x);
# next if /^\#/;
chomp $line;	chomp($line);
my ($domain, $domain_description, $def_auth, $def_auth_arg,	my ($name,@elements) = split(/:/,$line,9);
$def_lang, $city, $longi, $lati, $primary) = split(/:/,$line,9);	my %this_domain;
$domain_auth_def{$domain}=$def_auth;	foreach my $field ('description', 'auth_def', 'auth_arg_def',
$domain_auth_arg_def{$domain}=$def_auth_arg;	'lang_def', 'city', 'longi', 'lati',
$domaindescription{$domain}=$domain_description;	'primary') {
$domain_lang_def{$domain}=$def_lang;	$this_domain{$field} = shift(@elements);
$domain_city{$domain}=$city;	}
$domain_longi{$domain}=$longi;	$domain{$name} = \%this_domain;
$domain_lati{$domain}=$lati;	&logthis("Domain.tab: $name ".$domain{$name}{'description'} );
$domain_primary{$domain}=$primary;	}
	}

	sub load_domain_tab {
	&get_dns('/adm/dns/domain',\&parse_domain_tab);
	my $fh;
	if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) {
	my @lines = <$fh>;
	&parse_domain_tab(\@lines);
	}
	close($fh);
	$loaded = 1;
	}

	sub domain {
	&load_domain_tab() if (!$loaded);

	my ($name,$what) = @_;
	return if ( !exists($domain{$name}) );

# &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");	if (!$what) {
# &logthis("Domain.tab: $domain ".$domaindescription{$domain} );	return $domain{$name}{'description'};
}	}
	return $domain{$name}{$what};
}	}
close ($fh);
}	}


# ------------------------------------------------------------- Read hosts file	# ------------------------------------------------------------- Read hosts file
{	{
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");	my %hostname;
	my %hostdom;
	my %libserv;
	my $loaded;

	sub parse_hosts_tab {
	my ($file) = @_;
	foreach my $configline (@$file) {
	next if ($configline =~ /^(\#\|\s*$ )/x);
	next if ($configline =~ /^\^/);
	chomp($configline);
	my ($id,$domain,$role,$name)=split(/:/,$configline);
	$name=~s/\s//g;
	if ($id && $domain && $role && $name) {
	$hostname{$id}=$name;
	$hostdom{$id}=$domain;
	if ($role eq 'library') { $libserv{$id}=$name; }
	}
	&logthis("Hosts.tab: $name ".$id );
	}
	}

while (my $configline=<$config>) {	sub load_hosts_tab {
next if ($configline =~ /^(\#\|\s*$)/);	&get_dns('/adm/dns/hosts',\&parse_hosts_tab);
chomp($configline);	open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
my ($id,$domain,$role,$name)=split(/:/,$configline);	my @config = <$config>;
$name=~s/\s//g;	&parse_hosts_tab(\@config);
if ($id && $domain && $role && $name) {	close($config);
$hostname{$id}=$name;	$loaded=1;
$hostdom{$id}=$domain;
if ($role eq 'library') { $libserv{$id}=$name; }
}
}	}
close($config);
# FIXME: dev server don't want this, production servers _do_ want this	# FIXME: dev server don't want this, production servers _do_ want this
#&get_iphost();	#&get_iphost();

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

	my ($lonid) = @_;
	return $hostname{$lonid};
	}

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

	return %hostname;
	}

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

	return exists($libserv{$_[0]});
	}

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

	return %libserv;
	}

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

	my ($domain,$type) = @_;
	my %possible_hosts = ($type eq 'library') ? %libserv
	: %hostname;
	my %result;
	if (ref($domain) eq 'ARRAY') {
	while ( my ($host,$hostname) = each(%possible_hosts)) {
	if (grep(/^\Q$hostdom{$host}\E$/,@$domain)) {
	$result{$host} = $hostname;
	}
	}
	} else {
	while ( my ($host,$hostname) = each(%possible_hosts)) {
	if ($hostdom{$host} eq $domain) {
	$result{$host} = $hostname;
	}
	}
	}
	return %result;
	}

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

	my ($lonid) = @_;
	return $hostdom{$lonid};
	}

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

	my %seen;
	my @uniq = grep(!$seen{$_}++, values(%hostdom));
	return @uniq;
	}
}	}

sub get_iphost {	{
if (%iphost) { return %iphost; }	my %iphost;
my %name_to_ip;	my %name_to_ip;
foreach my $id (keys(%hostname)) {	my %lonid_to_ip;
my $name=$hostname{$id};	sub get_hosts_from_ip {
my $ip;	my ($ip) = @_;
if (!exists($name_to_ip{$name})) {	my %iphosts = &get_iphost();
$ip = gethostbyname($name);	if (ref($iphosts{$ip})) {
if (!$ip \|\| length($ip) ne 4) {	return @{$iphosts{$ip}};
&logthis("Skipping host $id name $name no IP found");	}
next;	return;
	}

	sub get_host_ip {
	my ($lonid) = @_;
	if (exists($lonid_to_ip{$lonid})) {
	return $lonid_to_ip{$lonid};
	}
	my $name=&hostname($lonid);
	my $ip = gethostbyname($name);
	return if (!$ip \|\| length($ip) ne 4);
	$ip=inet_ntoa($ip);
	$name_to_ip{$name} = $ip;
	$lonid_to_ip{$lonid} = $ip;
	return $ip;
	}

	sub get_iphost {
	if (%iphost) { return %iphost; }
	my %hostname = &all_hostnames();
	foreach my $id (keys(%hostname)) {
	my $name=$hostname{$id};
	my $ip;
	if (!exists($name_to_ip{$name})) {
	$ip = gethostbyname($name);
	if (!$ip \|\| length($ip) ne 4) {
	&logthis("Skipping host $id name $name no IP found");
	next;
	}
	$ip=inet_ntoa($ip);
	$name_to_ip{$name} = $ip;
	} else {
	$ip = $name_to_ip{$name};
}	}
$ip=inet_ntoa($ip);	$lonid_to_ip{$id} = $ip;
$name_to_ip{$name} = $ip;	push(@{$iphost{$ip}},$id);
} else {
$ip = $name_to_ip{$name};
}	}
push(@{$iphost{$ip}},$id);	return %iphost;
}	}
return %iphost;
}	}

# ------------------------------------------------------ Read spare server file	# ------------------------------------------------------ Read spare server file
Line 7925 and course level	Line 8169 and course level
plaintext($short) : return value in %prp hash (rolesplain.tab); plain text	plaintext($short) : return value in %prp hash (rolesplain.tab); plain text
explanation of a user role term	explanation of a user role term

	=item *

	get_my_roles($uname,$udom,$types,$roles,$roledoms) : All arguments are
	optional. Returns a hash of a user's roles, with keys set to
	colon-sparated $uname,$udom,and $role, and value set to
	colon-separated start and end times for the role. If no username and
	domain are specified, will default to current user/domain. Types,
	roles, and roledoms are references to arrays, of role statuses
	(active, future or previous), roles (e.g., cc,in, st etc.) and domains
	of the roles which can be used to restrict the list if roles
	reported. If no array ref is provided for types, will default to
	return only active roles.

=back	=back

=head2 User Modification	=head2 User Modification

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

Removed from v.1.828
changed lines
	Added in v.1.857