--- loncom/lonnet/perl/lonnet.pm 2007/02/23 15:49:23 1.836
+++ loncom/lonnet/perl/lonnet.pm 2007/03/02 23:17:40 1.838
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.836 2007/02/23 15:49:23 www Exp $
+# $Id: lonnet.pm,v 1.838 2007/03/02 23:17:40 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -35,7 +35,7 @@ use HTTP::Headers;
use HTTP::Date;
# use Date::Parse;
use vars
-qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom
+qw(%perlvar %badServerCache %iphost %spareid %hostdom
%libserv %pr %prp $memcache %packagetab
%courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf
@@ -149,7 +149,7 @@ sub logperm {
# -------------------------------------------------- Non-critical communication
sub subreply {
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
# process exit and the master server picking up the listen on the AF_UNIX
@@ -189,7 +189,7 @@ sub subreply {
sub reply {
my ($cmd,$server)=@_;
- unless (defined($hostname{$server})) { return 'no_such_host'; }
+ unless (defined(&hostname($server))) { return 'no_such_host'; }
my $answer=subreply($cmd,$server);
if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
&logthis("<font color=\"blue\">WARNING:".
@@ -224,7 +224,7 @@ sub reconlonc {
sub critical {
my ($cmd,$server)=@_;
- unless ($hostname{$server}) {
+ unless (&hostname($server)) {
&logthis("<font color=\"blue\">WARNING:".
" Critical message to unknown server ($server)</font>");
return 'no_such_host';
@@ -517,7 +517,7 @@ sub spareserver {
}
if (!$want_server_name) {
- $spare_server="http://$hostname{$spare_server}";
+ $spare_server="http://".&hostname($spare_server);
}
return $spare_server;
}
@@ -766,6 +766,30 @@ sub put_dom {
}
}
+sub retrieve_inst_usertypes {
+ my ($udom) = @_;
+ my (%returnhash,@order);
+ if (exists($domain_primary{$udom})) {
+ my $uhome=$domain_primary{$udom};
+ 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
sub assign_access_key {
@@ -2271,7 +2295,7 @@ sub checkin {
my $now=time;
my ($ta,$tb,$lonhost)=split(/\*/,$token);
$lonhost=~tr/A-Z/a-z/;
- my $dtoken=$ta.'_'.$hostname{$lonhost}.'_'.$tb;
+ my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb;
$dtoken=~s/\W/\_/g;
my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
@@ -2940,7 +2964,7 @@ sub custom_roleprivs {
my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;
my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
my $homsvr=homeserver($rauthor,$rdomain);
- if ($hostname{$homsvr} ne '') {
+ if (&hostname($homsvr) ne '') {
my ($rdummy,$roledef)=
&get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);
if (($rdummy ne 'con_lost') && ($roledef ne '')) {
@@ -4171,7 +4195,7 @@ sub log_query {
my ($uname,$udom,$query,%filters)=@_;
my $uhome=&homeserver($uname,$udom);
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 $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command,
$uhome);
@@ -4203,7 +4227,7 @@ sub fetch_enrollment_query {
} else {
$homeserver = &homeserver($cnum,$dom);
}
- my $host=$hostname{$homeserver};
+ my $host=&hostname($homeserver);
my $cmd = '';
foreach my $affiliate (keys %{$affiliatesref}) {
$cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
@@ -4394,7 +4418,7 @@ sub auto_photochoice {
sub auto_photoupdate {
my ($affiliatesref,$dom,$cnum,$photo) = @_;
my $homeserver = &homeserver($cnum,$dom);
- my $host=$hostname{$homeserver};
+ my $host=&hostname($homeserver);
my $cmd = '';
my $maxtries = 1;
foreach my $affiliate (keys(%{$affiliatesref})) {
@@ -7262,7 +7286,7 @@ sub repcopy_userfile {
if (-e $transferfile) { return 'ok'; }
my $request;
$uri=~s/^\///;
- $request=new HTTP::Request('GET','http://'.$hostname{&homeserver($cnum,$cdom)}.'/raw/'.$uri);
+ $request=new HTTP::Request('GET','http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri);
my $response=$ua->request($request,$transferfile);
# did it work?
if ($response->is_error()) {
@@ -7285,7 +7309,7 @@ sub tokenwrapper {
if ($udom && $uname && $file) {
$file=~s|(\?\.*)*$||;
&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.
'&tokenissued='.$perlvar{'lonHostID'};
} else {
@@ -7300,7 +7324,7 @@ sub tokenwrapper {
sub getuploaded {
my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
$uri=~s/^\///;
- $uri = 'http://'.$hostname{ &homeserver($cnum,$cdom)}.'/raw/'.$uri;
+ $uri = 'http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri;
my $ua=new LWP::UserAgent;
my $request=new HTTP::Request($reqtype,$uri);
my $response=$ua->request($request);
@@ -7390,8 +7414,9 @@ sub hreflocation {
}
sub current_machine_domains {
- my $hostname=$hostname{$perlvar{'lonHostID'}};
+ my $hostname=&hostname($perlvar{'lonHostID'});
my @domains;
+ my %hostname = &all_hostnames();
while( my($id, $name) = each(%hostname)) {
# &logthis("-$id-$name-$hostname-");
if ($hostname eq $name) {
@@ -7402,8 +7427,9 @@ sub current_machine_domains {
}
sub current_machine_ids {
- my $hostname=$hostname{$perlvar{'lonHostID'}};
+ my $hostname=&hostname($perlvar{'lonHostID'});
my @ids;
+ my %hostname = &all_hostnames();
while( my($id, $name) = each(%hostname)) {
# &logthis("-$id-$name-$hostname-");
if ($hostname eq $name) {
@@ -7581,6 +7607,7 @@ BEGIN {
# ------------------------------------------------------------- Read hosts file
{
+ my %hostname;
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
while (my $configline=<$config>) {
@@ -7597,11 +7624,20 @@ BEGIN {
close($config);
# FIXME: dev server don't want this, production servers _do_ want this
#&get_iphost();
+
+ sub hostname {
+ my ($lonid) = @_;
+ return $hostname{$lonid};
+ }
+ sub all_hostnames {
+ return %hostname;
+ }
}
sub get_iphost {
if (%iphost) { return %iphost; }
my %name_to_ip;
+ my %hostname = &all_hostnames();
foreach my $id (keys(%hostname)) {
my $name=$hostname{$id};
my $ip;