--- loncom/lonnet/perl/lonnet.pm 2010/05/21 22:09:48 1.1056.2.3
+++ loncom/lonnet/perl/lonnet.pm 2010/06/04 00:14:15 1.1070
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.1056.2.3 2010/05/21 22:09:48 raeburn Exp $
+# $Id: lonnet.pm,v 1.1070 2010/06/04 00:14:15 www 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;
@@ -5857,8 +5748,8 @@ sub auto_validate_instcode {
$homeserver = &domain($cdom,'primary');
}
}
- my $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'.
- &escape($instcode).':'.&escape($owner),$homeserver));
+ $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'.
+ &escape($instcode).':'.&escape($owner),$homeserver));
my ($outcome,$description) = map { &unescape($_); } split('&',$response,2);
return ($outcome,$description);
}
@@ -6647,8 +6538,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 +6553,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 +6563,6 @@ sub modifyuser {
}
}
}
-
if ($first) { $names{'firstname'} = $first; }
if (defined($middle)) { $names{'middlename'} = $middle; }
if ($last) { $names{'lastname'} = $last; }
@@ -8240,6 +8131,7 @@ sub add_prefix_and_part {
# ---------------------------------------------------------------- Get metadata
my %metaentry;
+my %importedpartids;
sub metadata {
my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
$uri=&declutter($uri);
@@ -8266,6 +8158,10 @@ sub metadata {
if (defined($cached)) { return $result->{':'.$what}; }
}
{
+# Imported parts would go here
+ my %importedids=();
+ my @origfileimportpartids=();
+ my $importedparts=0;
#
# Is this a recursive call for a library?
#
@@ -8349,27 +8245,55 @@ sub metadata {
# This is not a package - some other kind of start tag
#
my $entry=$token->[1];
- my $unikey;
- if ($entry eq 'import') {
- $unikey='';
- } else {
- $unikey=$entry;
- }
- $unikey.=&add_prefix_and_part($prefix,$token->[2]->{'part'});
-
- if (defined($token->[2]->{'id'})) {
- $unikey.='_'.$token->[2]->{'id'};
- }
+ my $unikey='';
if ($entry eq 'import') {
#
# Importing a library here
#
+ my $location=$parser->get_text('/import');
+ my $dir=$filename;
+ $dir=~s|[^/]*$||;
+ $location=&filelocation($dir,$location);
+
+ my $importmode=$token->[2]->{'importmode'};
+ if ($importmode eq 'problem') {
+# Import as problem/response
+ $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});
+ } elsif ($importmode eq 'part') {
+# Import as part(s)
+ $importedparts=1;
+# We need to get the original file and the imported file to get the part order correct
+# Good news: we do not need to worry about nested libraries, since parts cannot be nested
+# Load and inspect original file
+ if ($#origfileimportpartids<0) {
+ undef(%importedpartids);
+ my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);
+ my $origfile=&getfile($origfilelocation);
+ @origfileimportpartids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
+ }
+
+# Load and inspect imported file
+ my $impfile=&getfile($location);
+ my @impfilepartids=($impfile=~/]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
+ if ($#impfilepartids>=0) {
+# This problem had parts
+ $importedpartids{$token->[2]->{'id'}}=join(',',@impfilepartids);
+ } else {
+# Importing by turning a single problem into a problem part
+# It gets the import-tags ID as part-ID
+ $unikey=&add_prefix_and_part($prefix,$token->[2]->{'id'});
+ $importedpartids{$token->[2]->{'id'}}=$token->[2]->{'id'};
+ }
+ } else {
+# Normal import
+ $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});
+ if (defined($token->[2]->{'id'})) {
+ $unikey.='_'.$token->[2]->{'id'};
+ }
+ }
+
if ($depthcount<20) {
- my $location=$parser->get_text('/import');
- my $dir=$filename;
- $dir=~s|[^/]*$||;
- $location=&filelocation($dir,$location);
my $metadata =
&metadata($uri,'keys', $location,$unikey,
$depthcount+1);
@@ -8377,9 +8301,16 @@ sub metadata {
$metaentry{':'.$meta}=$metaentry{':'.$meta};
$metathesekeys{$meta}=1;
}
- }
- } else {
+ }
+ } else {
+#
+# Not importing, some other kind of non-package, non-library start tag
+#
+ $unikey=$entry.&add_prefix_and_part($prefix,$token->[2]->{'part'});
+ if (defined($token->[2]->{'id'})) {
+ $unikey.='_'.$token->[2]->{'id'};
+ }
if (defined($token->[2]->{'name'})) {
$unikey.='_'.$token->[2]->{'name'};
}
@@ -8453,6 +8384,22 @@ sub metadata {
grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));
$metaentry{':packages'} = join(',',@uniq_packages);
+ if ($importedparts) {
+# We had imported parts and need to rebuild partorder
+ $metaentry{':partorder'}='';
+ $metathesekeys{'partorder'}=1;
+ for (my $index=0;$index<$#origfileimportpartids;$index+=2) {
+ if ($origfileimportpartids[$index] eq 'part') {
+# original part, part of the problem
+ $metaentry{':partorder'}.=','.$origfileimportpartids[$index+1];
+ } else {
+# we have imported parts at this position
+ $metaentry{':partorder'}.=','.$importedpartids{$origfileimportpartids[$index+1]};
+ }
+ }
+ $metaentry{':partorder'}=~s/^\,//;
+ }
+
$metaentry{':keys'} = join(',',keys(%metathesekeys));
&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
@@ -9813,6 +9760,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 +9789,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 +10362,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.