--- loncom/lonnet/perl/lonnet.pm 2009/03/01 01:12:23 1.988
+++ loncom/lonnet/perl/lonnet.pm 2009/03/21 21:43:46 1.992
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.988 2009/03/01 01:12:23 raeburn Exp $
+# $Id: lonnet.pm,v 1.992 2009/03/21 21:43:46 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -74,9 +74,7 @@ use strict;
use LWP::UserAgent();
use HTTP::Date;
use Image::Magick;
-use IO::Socket;
-# use Date::Parse;
use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
$_64bit %env %protocol);
@@ -1005,27 +1003,34 @@ 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);
- if ($rep =~ /^(con_lost|error|no_such_host|refused)/) {
- &logthis("get_dom failed - $rep returned from $uhome in domain: $udom");
- return (\%returnhash,\@order);
- }
- 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));
- }
+ my %domdefs = &Apache::lonnet::get_domain_defaults($udom);
+ if ((ref($domdefs{'inststatustypes'}) eq 'HASH') &&
+ (ref($domdefs{'inststatusorder'}) eq 'ARRAY')) {
+ %returnhash = %{$domdefs{'inststatustypes'}};
+ @order = @{$domdefs{'inststatusorder'}};
} else {
- &logthis("get_dom failed - no primary domain server for $udom");
+ if (defined(&domain($udom,'primary'))) {
+ my $uhome=&domain($udom,'primary');
+ my $rep=&reply("inst_usertypes:$udom",$uhome);
+ if ($rep =~ /^(con_lost|error|no_such_host|refused)/) {
+ &logthis("get_dom failed - $rep returned from $uhome in domain: $udom");
+ return (\%returnhash,\@order);
+ }
+ 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);
}
@@ -1262,7 +1267,8 @@ sub get_domain_defaults {
}
my %domdefaults;
my %domconfig =
- &Apache::lonnet::get_dom('configuration',['defaults','quotas'],$domain);
+ &Apache::lonnet::get_dom('configuration',['defaults','quotas',
+ 'requestcourses','inststatus'],$domain);
if (ref($domconfig{'defaults'}) eq 'HASH') {
$domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};
$domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};
@@ -1292,6 +1298,11 @@ sub get_domain_defaults {
$domdefaults{$item} = $domconfig{'requestcourses'}{$item};
}
}
+ if (ref($domconfig{'inststatus'}) eq 'HASH') {
+ foreach my $item ('inststatustypes','inststatusorder') {
+ $domdefaults{$item} = $domconfig{'inststatus'}{$item};
+ }
+ }
&Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults,
$cachetime);
return %domdefaults;
@@ -5902,7 +5913,21 @@ sub modifyuser {
if ($email=~/\@/) { $names{'permanentemail'} = $email; }
}
if ($uid) { $names{'id'} = $uid; }
- if (defined($inststatus)) { $names{'inststatus'} = $inststatus; }
+ if (defined($inststatus)) {
+ $names{'inststatus'} = '';
+ my ($usertypes,$typesorder) = &retrieve_inst_usertypes($udom);
+ if (ref($usertypes) eq 'HASH') {
+ my @okstatuses;
+ foreach my $item (split(/:/,$inststatus)) {
+ if (defined($usertypes->{$item})) {
+ push(@okstatuses,$item);
+ }
+ }
+ if (@okstatuses) {
+ $names{'inststatus'} = join(':', map { &escape($_); } @okstatuses);
+ }
+ }
+ }
my $reply = &put('environment', \%names, $udom,$uname);
if ($reply ne 'ok') { return 'error: '.$reply; }
my $sqlresult = &update_allusers_table($uname,$udom,\%names);
@@ -5924,7 +5949,7 @@ sub modifyuser {
sub modifystudent {
my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
$end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid,
- $selfenroll,$context)=@_;
+ $selfenroll,$context,$inststatus)=@_;
if (!$cid) {
unless ($cid=$env{'request.course.id'}) {
return 'not_in_class';
@@ -5933,7 +5958,7 @@ sub modifystudent {
# --------------------------------------------------------------- Make the user
my $reply=&modifyuser
($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,
- $desiredhome,$email);
+ $desiredhome,$email,$inststatus);
unless ($reply eq 'ok') { return $reply; }
# This will cause &modify_student_enrollment to get the uid from the
# students environment
@@ -9021,23 +9046,31 @@ sub get_dns {
return %iphost;
}
-}
-#
-# Given a DNS returns the loncapa host name for that DNS
-#
-sub host_from_dns {
- my ($dns) = @_;
- my @hosts;
- my $ip;
-
- $ip = gethostbyname($dns); # Initial translation to IP is in net order.
- if (length($ip) == 4) {
- $ip = &IO::Socket::inet_ntoa($ip);
- @hosts = get_hosts_from_ip($ip);
- return $hosts[0];
+ #
+ # Given a DNS returns the loncapa host name for that DNS
+ #
+ sub host_from_dns {
+ my ($dns) = @_;
+ my @hosts;
+ my $ip;
+
+ if (defined($name_to_ip{$dns})) {
+ $ip = $name_to_ip{$dns};
+ }
+ if (!$ip) {
+ $ip = gethostbyname($dns); # Initial translation to IP is in net order.
+ if (length($ip) == 4) {
+ $ip = &IO::Socket::inet_ntoa($ip);
+ }
+ }
+ if ($ip) {
+ @hosts = get_hosts_from_ip($ip);
+ return $hosts[0];
+ }
+ return undef;
}
- return undef;
+
}
BEGIN {