--- loncom/lonnet/perl/lonnet.pm 2010/05/22 13:50:19 1.1056.2.4
+++ loncom/lonnet/perl/lonnet.pm 2010/05/21 12:11:17 1.1064
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.1056.2.4 2010/05/22 13:50:19 raeburn Exp $
+# $Id: lonnet.pm,v 1.1064 2010/05/21 12:11:17 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -665,30 +665,6 @@ sub userload {
return $userloadpercent;
}
-# ------------------------------------------ Fight off request when overloaded
-
-sub overloaderror {
- my ($r,$checkserver)=@_;
- unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; }
- my $loadavg;
- if ($checkserver eq $perlvar{'lonHostID'}) {
- open(my $loadfile,'/proc/loadavg');
- $loadavg=<$loadfile>;
- $loadavg =~ s/\s.*//g;
- $loadavg = 100*$loadavg/$perlvar{'lonLoadLim'};
- close($loadfile);
- } else {
- $loadavg=&reply('load',$checkserver);
- }
- my $overload=$loadavg-100;
- if ($overload>0) {
- $r->err_headers_out->{'Retry-After'}=$overload;
- $r->log_error('Overload of '.$overload.' on '.$checkserver);
- return 413;
- }
- return '';
-}
-
# ------------------------------ Find server with least workload from spare.tab
sub spareserver {
@@ -3207,7 +3183,7 @@ sub get_domain_roles {
return %personnel;
}
-# ----------------------------------------------------------- Check out an item
+# ----------------------------------------------------------- Interval timing
sub get_first_access {
my ($type,$argsymb)=@_;
@@ -3243,91 +3219,6 @@ sub set_first_access {
return 'already_set';
}
-sub checkout {
- my ($symb,$tuname,$tudom,$tcrsid)=@_;
- my $now=time;
- my $lonhost=$perlvar{'lonHostID'};
- my $infostr=&escape(
- 'CHECKOUTTOKEN&'.
- $tuname.'&'.
- $tudom.'&'.
- $tcrsid.'&'.
- $symb.'&'.
- $now.'&'.$ENV{'REMOTE_ADDR'});
- my $token=&reply('tmpput:'.$infostr,$lonhost);
- if ($token=~/^error\:/) {
- &logthis("WARNING: ".
- "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
- "");
- return '';
- }
-
- $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/;
- $token=~tr/a-z/A-Z/;
-
- my %infohash=('resource.0.outtoken' => $token,
- 'resource.0.checkouttime' => $now,
- 'resource.0.outremote' => $ENV{'REMOTE_ADDR'});
-
- unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
- return '';
- } else {
- &logthis("WARNING: ".
- "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
- "");
- }
-
- if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
- &escape('Checkout '.$infostr.' - '.
- $token)) ne 'ok') {
- return '';
- } else {
- &logthis("WARNING: ".
- "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
- "");
- }
- return $token;
-}
-
-# ------------------------------------------------------------ Check in an item
-
-sub checkin {
- my $token=shift;
- my $now=time;
- my ($ta,$tb,$lonhost)=split(/\*/,$token);
- $lonhost=~tr/A-Z/a-z/;
- my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb;
- $dtoken=~s/\W/\_/g;
- my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
- split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
-
- unless (($tuname) && ($tudom)) {
- &logthis('Check in '.$token.' ('.$dtoken.') failed');
- return '';
- }
-
- unless (&allowed('mgr',$tcrsid)) {
- &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '.
- $env{'user.name'}.' - '.$env{'user.domain'});
- return '';
- }
-
- my %infohash=('resource.0.intoken' => $token,
- 'resource.0.checkintime' => $now,
- 'resource.0.inremote' => $ENV{'REMOTE_ADDR'});
-
- unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
- return '';
- }
-
- if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
- &escape('Checkin - '.$token)) ne 'ok') {
- return '';
- }
-
- return ($symb,$tuname,$tudom,$tcrsid);
-}
-
# --------------------------------------------- Set Expire Date for Spreadsheet
sub expirespread {
@@ -4033,7 +3924,7 @@ sub set_userprivs {
my $adv=0;
my %grouproles = ();
if (keys(%{$allgroups}) > 0) {
- my @groupkeys;
+ my @groupkeys;
foreach my $role (keys(%{$allroles})) {
push(@groupkeys,$role);
}
@@ -4056,7 +3947,7 @@ sub set_userprivs {
foreach my $group (keys(%{$$allgroups{$area}})) {
my $spec = $trole.'.'.$extendedarea;
$grouproles{$spec.'.'.$area.'/'.$group} =
- $$allgroups{$area}{$group};
+ $$allgroups{$area}{$group};
}
}
}
@@ -4109,7 +4000,7 @@ sub role_status {
my %userroles = (
'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend
);
- @rolecodes = ('cm');
+ @rolecodes = ('cm');
my $spec=$$role.'.'.$$where;
my ($tdummy,$tdomain,$trest)=split(/\//,$$where);
if ($$role =~ /^cr\//) {
@@ -4126,7 +4017,7 @@ sub role_status {
my %course_roles = &get_my_roles($env{'user.name'},$env{'user.domain'},'userroles',['active'],['cc','co','in','ta','ep','ad','st','cr'],[$tdomain],1);
if (keys(%course_roles) > 0) {
my ($tnum) = ($trest =~ /^($match_courseid)/);
- if ($tdomain ne '' && $tnum ne '') {
+ if ($tdomain ne '' && $tnum ne '') {
foreach my $key (keys(%course_roles)) {
if ($key =~ /^\Q$tnum\E:\Q$tdomain\E:([^:]+):?([^:]*)/) {
my $crsrole = $1;
@@ -5606,6 +5497,8 @@ sub metadata_query {
my @server_list = (defined($server_array) ? @$server_array
: keys(%libserv) );
for my $server (@server_list) {
+#SD remove this
+&logthis("Querying server:$server");
unless ($custom or $customshow) {
my $reply=&reply("querysend:".&escape($query),$server);
$rhash{$server}=$reply;
@@ -5857,8 +5750,8 @@ sub auto_validate_instcode {
$homeserver = &domain($cdom,'primary');
}
}
- $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'.
- &escape($instcode).':'.&escape($owner),$homeserver));
+ my $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'.
+ &escape($instcode).':'.&escape($owner),$homeserver));
my ($outcome,$description) = map { &unescape($_); } split('&',$response,2);
return ($outcome,$description);
}
@@ -6647,8 +6540,9 @@ sub modifyuser {
#
# If name, email and/or uid are blank (e.g., because an uploaded file
# of users did not contain them), do not overwrite existing values
-# unless field is in $candelete array ref.
+# unless field is in $candelete array ref.
#
+
my @fields = ('firstname','middlename','lastname','generation',
'permanentemail','id');
my %newvalues;
@@ -6661,7 +6555,7 @@ sub modifyuser {
$names{$field} = $middle;
} elsif ($field eq 'lastname') {
$names{$field} = $last;
- } elsif ($field eq 'generation') {
+ } elsif ($field eq 'generation') {
$names{$field} = $gene;
} elsif ($field eq 'permanentemail') {
$names{$field} = $email;
@@ -6671,7 +6565,6 @@ sub modifyuser {
}
}
}
-
if ($first) { $names{'firstname'} = $first; }
if (defined($middle)) { $names{'middlename'} = $middle; }
if ($last) { $names{'lastname'} = $last; }
@@ -9813,6 +9706,12 @@ sub get_dns {
return %libserv;
}
+ sub unique_library {
+ #2x reverse removes all hostnames that appear more than once
+ my %unique = reverse &all_library();
+ return reverse %unique;
+ }
+
sub get_servers {
&load_hosts_tab() if (!$loaded);
@@ -9836,6 +9735,11 @@ sub get_dns {
return %result;
}
+ sub get_unique_servers {
+ my %unique = reverse &get_servers(@_);
+ return reverse %unique;
+ }
+
sub host_domain {
&load_hosts_tab() if (!$loaded);
@@ -10404,7 +10308,7 @@ modifyuser($udom,$uname,$uid,$umode,$upa
will update user information (firstname,middlename,lastname,generation,
permanentemail), and if forceid is true, student/employee ID also.
A user's institutional affiliation(s) can also be updated.
-User information fields will not be overwritten with empty entries
+User information fields will not be overwritten with empty entries
unless the field is included in the $candelete array reference.
This array is included when a single user is modified via "Manage Users",
or when Autoupdate.pl is run by cron in a domain.