--- loncom/lonnet/perl/lonnet.pm 2010/03/08 14:28:50 1.1053
+++ 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.1053 2010/03/08 14:28:50 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 {
@@ -3019,6 +2995,7 @@ sub getannounce {
sub courseidput {
my ($domain,$storehash,$coursehome,$caller) = @_;
+ return unless (ref($storehash) eq 'HASH');
my $outcome;
if ($caller eq 'timeonly') {
my $cids = '';
@@ -3103,6 +3080,49 @@ sub courseiddump {
return %returnhash;
}
+sub courselastaccess {
+ my ($cdom,$cnum,$hostidref) = @_;
+ my %returnhash;
+ if ($cdom && $cnum) {
+ my $chome = &homeserver($cnum,$cdom);
+ if ($chome ne 'no_host') {
+ my $rep = &reply('courselastaccess:'.$cdom.':'.$cnum,$chome);
+ &extract_lastaccess(\%returnhash,$rep);
+ }
+ } else {
+ if (!$cdom) { $cdom=''; }
+ my %libserv = &all_library();
+ foreach my $tryserver (keys(%libserv)) {
+ if (ref($hostidref) eq 'ARRAY') {
+ next unless (grep(/^\Q$tryserver\E$/,@{$hostidref}));
+ }
+ if (($cdom eq '') || (&host_domain($tryserver) eq $cdom)) {
+ my $rep = &reply('courselastaccess:'.&host_domain($tryserver).':',$tryserver);
+ &extract_lastaccess(\%returnhash,$rep);
+ }
+ }
+ }
+ return %returnhash;
+}
+
+sub extract_lastaccess {
+ my ($returnhash,$rep) = @_;
+ if (ref($returnhash) eq 'HASH') {
+ unless ($rep eq 'unknown_command' || $rep eq 'no_such_host' ||
+ $rep eq 'con_lost' || $rep eq 'rejected' || $rep eq 'refused' ||
+ $rep eq '') {
+ my @pairs=split(/\&/,$rep);
+ foreach my $item (@pairs) {
+ my ($key,$value)=split(/\=/,$item,2);
+ $key = &unescape($key);
+ next if ($key =~ /^error: 2 /);
+ $returnhash->{$key} = &thaw_unescape($value);
+ }
+ }
+ }
+ return;
+}
+
# ---------------------------------------------------------- DC e-mail
sub dcmailput {
@@ -3163,7 +3183,7 @@ sub get_domain_roles {
return %personnel;
}
-# ----------------------------------------------------------- Check out an item
+# ----------------------------------------------------------- Interval timing
sub get_first_access {
my ($type,$argsymb)=@_;
@@ -3199,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 {
@@ -3984,23 +3919,36 @@ sub standard_roleprivs {
}
sub set_userprivs {
- my ($userroles,$allroles,$allgroups) = @_;
+ my ($userroles,$allroles,$allgroups,$groups_roles) = @_;
my $author=0;
my $adv=0;
my %grouproles = ();
if (keys(%{$allgroups}) > 0) {
+ my @groupkeys;
foreach my $role (keys(%{$allroles})) {
- my ($trole,$area,$sec,$extendedarea);
- if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) {
- $trole = $1;
- $area = $2;
- $sec = $3;
- $extendedarea = $area.$sec;
- if (exists($$allgroups{$area})) {
- foreach my $group (keys(%{$$allgroups{$area}})) {
- my $spec = $trole.'.'.$extendedarea;
- $grouproles{$spec.'.'.$area.'/'.$group} =
+ push(@groupkeys,$role);
+ }
+ if (ref($groups_roles) eq 'HASH') {
+ foreach my $key (keys(%{$groups_roles})) {
+ unless (grep(/^\Q$key\E$/,@groupkeys)) {
+ push(@groupkeys,$key);
+ }
+ }
+ }
+ if (@groupkeys > 0) {
+ foreach my $role (@groupkeys) {
+ my ($trole,$area,$sec,$extendedarea);
+ if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) {
+ $trole = $1;
+ $area = $2;
+ $sec = $3;
+ $extendedarea = $area.$sec;
+ if (exists($$allgroups{$area})) {
+ foreach my $group (keys(%{$$allgroups{$area}})) {
+ my $spec = $trole.'.'.$extendedarea;
+ $grouproles{$spec.'.'.$area.'/'.$group} =
$$allgroups{$area}{$group};
+ }
}
}
}
@@ -4047,26 +3995,58 @@ sub role_status {
if ($$tstart<$now) {
if ($$tstart && $$tstart>$refresh) {
if (($$where ne '') && ($$role ne '')) {
- my (%allroles,%allgroups,$group_privs);
+ my (%allroles,%allgroups,$group_privs,
+ %groups_roles,@rolecodes);
my %userroles = (
'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend
);
+ @rolecodes = ('cm');
my $spec=$$role.'.'.$$where;
my ($tdummy,$tdomain,$trest)=split(/\//,$$where);
if ($$role =~ /^cr\//) {
&custom_roleprivs(\%allroles,$$role,$tdomain,$trest,$spec,$$where);
+ push(@rolecodes,'cr');
} elsif ($$role eq 'gr') {
+ push(@rolecodes,$$role);
my %rolehash = &get('roles',[$$where.'_'.$$role],$env{'user.domain'},
$env{'user.name'});
- my $trole = split('_',$rolehash{$$where.'_'.$$role},1);
+ my ($trole) = split('_',$rolehash{$$where.'_'.$$role},2);
(undef,my $group_privs) = split(/\//,$trole);
$group_privs = &unescape($group_privs);
&group_roleprivs(\%allgroups,$$where,$group_privs,$$tend,$$tstart);
+ 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 '') {
+ foreach my $key (keys(%course_roles)) {
+ if ($key =~ /^\Q$tnum\E:\Q$tdomain\E:([^:]+):?([^:]*)/) {
+ my $crsrole = $1;
+ my $crssec = $2;
+ if ($crsrole =~ /^cr/) {
+ unless (grep(/^cr$/,@rolecodes)) {
+ push(@rolecodes,'cr');
+ }
+ } else {
+ unless(grep(/^\Q$crsrole\E$/,@rolecodes)) {
+ push(@rolecodes,$crsrole);
+ }
+ }
+ my $rolekey = $crsrole.'./'.$tdomain.'/'.$tnum;
+ if ($crssec ne '') {
+ $rolekey .= '/'.$crssec;
+ }
+ $rolekey .= './';
+ $groups_roles{$rolekey} = \@rolecodes;
+ }
+ }
+ }
+ }
} else {
+ push(@rolecodes,$$role);
&standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where);
}
- my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups);
- &appenv(\%userroles,[$$role,'cm']);
+ my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups,\%groups_roles);
+ &appenv(\%userroles,\@rolecodes);
&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);
}
}
@@ -4580,7 +4560,7 @@ sub get_portfolio_access {
my (%allgroups,%allroles);
my ($start,$end,$role,$sec,$group);
foreach my $envkey (%env) {
- if ($envkey =~ m-^user\.role\.(gr|cc|in|ta|ep|st)\./($match_domain)/($match_courseid)/?([^/]*)$-) {
+ if ($envkey =~ m-^user\.role\.(gr|cc|co|in|ta|ep|ad|st)\./($match_domain)/($match_courseid)/?([^/]*)$-) {
my $cid = $2.'_'.$3;
if ($1 eq 'gr') {
$group = $4;
@@ -5517,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;
@@ -6374,12 +6356,12 @@ sub autoupdate_coowners {
my %coursehash = &coursedescription($cdom.'_'.$cnum);
my $instcode = $coursehash{'internal.coursecode'};
if ($instcode ne '') {
- unless ($coursehash{'internal.courseowner'} eq $uname.':'.$udom) {
- my ($result,$desc) = &auto_validate_instcode($cnum,$cdom,$instcode,$uname.':'.$udom);
- if ($result eq 'valid') {
+ if (($start && $start <= $now) && ($end == 0) || ($end > $now)) {
+ unless ($coursehash{'internal.courseowner'} eq $uname.':'.$udom) {
my ($delcoowners,@newcoowners,$putresult,$delresult,$coowners);
- if (($end == 0) || ($end > $now)) {
- if ($coursehash{'internal.co-owners'}) {
+ my ($result,$desc) = &auto_validate_instcode($cnum,$cdom,$instcode,$uname.':'.$udom);
+ if ($result eq 'valid') {
+ if ($coursehash{'internal.co-owners'}) {
foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {
push(@newcoowners,$coowner);
}
@@ -6480,12 +6462,18 @@ sub modifyuser {
my ($udom, $uname, $uid,
$umode, $upass, $first,
$middle, $last, $gene,
- $forceid, $desiredhome, $email, $inststatus)=@_;
+ $forceid, $desiredhome, $email, $inststatus, $candelete)=@_;
$udom= &LONCAPA::clean_domain($udom);
$uname=&LONCAPA::clean_username($uname);
+ my $showcandelete = 'none';
+ if (ref($candelete) eq 'ARRAY') {
+ if (@{$candelete} > 0) {
+ $showcandelete = join(', ',@{$candelete});
+ }
+ }
&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
$umode.', '.$first.', '.$middle.', '.
- $last.', '.$gene.'(forceid: '.$forceid.')'.
+ $last.', '.$gene.'(forceid: '.$forceid.'; candelete: '.$showcandelete.')'.
(defined($desiredhome) ? ' desiredhome = '.$desiredhome :
' desiredhome not specified').
' by '.$env{'user.name'}.' at '.$env{'user.domain'}.
@@ -6550,9 +6538,33 @@ sub modifyuser {
%names = @tmp;
}
#
-# Make sure to not trash student environment if instructor does not bother
-# to supply name and email information
-#
+# 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.
+#
+
+ my @fields = ('firstname','middlename','lastname','generation',
+ 'permanentemail','id');
+ my %newvalues;
+ if (ref($candelete) eq 'ARRAY') {
+ foreach my $field (@fields) {
+ if (grep(/^\Q$field\E$/,@{$candelete})) {
+ if ($field eq 'firstname') {
+ $names{$field} = $first;
+ } elsif ($field eq 'middlename') {
+ $names{$field} = $middle;
+ } elsif ($field eq 'lastname') {
+ $names{$field} = $last;
+ } elsif ($field eq 'generation') {
+ $names{$field} = $gene;
+ } elsif ($field eq 'permanentemail') {
+ $names{$field} = $email;
+ } elsif ($field eq 'id') {
+ $names{$field} = $uid;
+ }
+ }
+ }
+ }
if ($first) { $names{'firstname'} = $first; }
if (defined($middle)) { $names{'middlename'} = $middle; }
if ($last) { $names{'lastname'} = $last; }
@@ -6829,8 +6841,13 @@ ENDINITMAP
}
# ----------------------------------------------------------- Write preferences
&writecoursepref($udom.'_'.$uname,
- ('description' => $description,
- 'url' => $topurl));
+ ('description' => $description,
+ 'url' => $topurl,
+ 'internal.creator' => $env{'user.name'}.':'.
+ $env{'user.domain'},
+ 'internal.created' => $now,
+ 'internal.creationcontext' => $context)
+ );
return '/'.$udom.'/'.$uname;
}
@@ -9689,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);
@@ -9712,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);
@@ -10274,9 +10302,16 @@ modifyuserauth($udom,$uname,$umode,$upas
=item *
-modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,
- $forceid,$desiredhome,$email,$inststatus) :
-modify user
+modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last, $gene,
+ $forceid,$desiredhome,$email,$inststatus,$candelete) :
+
+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
+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.
=item *