--- loncom/lonnet/perl/lonnet.pm	2010/08/20 20:47:18	1.1056.2.6
+++ loncom/lonnet/perl/lonnet.pm	2010/03/26 00:47:25	1.1060
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.1056.2.6 2010/08/20 20:47:18 raeburn Exp $
+# $Id: lonnet.pm,v 1.1060 2010/03/26 00:47:25 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -3059,7 +3059,7 @@ sub courseiddump {
     my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
         $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
         $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,
-        $cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner)=@_;
+        $cloneonly,$createdbefore,$createdafter,$creationcontext)=@_;
     my $as_hash = 1;
     my %returnhash;
     if (!$domfilter) { $domfilter=''; }
@@ -3081,8 +3081,7 @@ sub courseiddump {
                          $showhidden.':'.$caller.':'.&escape($cloner).':'.
                          &escape($cc_clone).':'.$cloneonly.':'.
                          &escape($createdbefore).':'.&escape($createdafter).':'.
-                         &escape($creationcontext).':'.$domcloner,
-                         $tryserver);
+                         &escape($creationcontext),$tryserver);
                 my @pairs=split(/\&/,$rep);
                 foreach my $item (@pairs) {
                     my ($key,$value)=split(/\=/,$item,2);
@@ -3208,7 +3207,7 @@ sub get_domain_roles {
     return %personnel;
 }
 
-# ----------------------------------------------------------- Check out an item
+# ----------------------------------------------------------- Interval timing 
 
 sub get_first_access {
     my ($type,$argsymb)=@_;
@@ -3244,91 +3243,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("<font color=\"blue\">WARNING: ".
-                "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
-                 "</font>");
-        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("<font color=\"blue\">WARNING: ".
-                "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
-                 "</font>");
-    }    
-
-    if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
-                         &escape('Checkout '.$infostr.' - '.
-                                                 $token)) ne 'ok') {
-	return '';
-    } else {
-        &logthis("<font color=\"blue\">WARNING: ".
-                "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
-                 "</font>");
-    }
-    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 {
@@ -4029,36 +3943,23 @@ sub standard_roleprivs {
 }
 
 sub set_userprivs {
-    my ($userroles,$allroles,$allgroups,$groups_roles) = @_; 
+    my ($userroles,$allroles,$allgroups) = @_; 
     my $author=0;
     my $adv=0;
     my %grouproles = ();
     if (keys(%{$allgroups}) > 0) {
-        my @groupkeys;
         foreach my $role (keys(%{$allroles})) {
-            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};
-                        }
+            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};
                     }
                 }
             }
@@ -4105,58 +4006,26 @@ sub role_status {
                 if ($$tstart<$now) {
                     if ($$tstart && $$tstart>$refresh) {
                         if (($$where ne '') && ($$role ne '')) {
-                            my (%allroles,%allgroups,$group_privs,
-                                %groups_roles,@rolecodes);
+                            my (%allroles,%allgroups,$group_privs);
                             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},2);
+                                my $trole = split('_',$rolehash{$$where.'_'.$$role},1);
                                 (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,\%groups_roles);
-                            &appenv(\%userroles,\@rolecodes);
+                            my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups);
+                            &appenv(\%userroles,[$$role,'cm']);
                             &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);
                         }
                     }
@@ -5663,7 +5532,8 @@ sub update_allusers_table {
                'generation='.&escape($names->{'generation'}).'%%'.
                'permanentemail='.&escape($names->{'permanentemail'}).'%%'.
                'id='.&escape($names->{'id'}),$homeserver);
-    return;
+    my $reply = &get_query_reply($queryid);
+    return $reply;
 }
 
 # ------- Request retrieval of institutional classlists for course(s)
@@ -5857,8 +5727,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);
 }
@@ -6586,10 +6456,6 @@ sub modifyuser {
              ' by '.$env{'user.name'}.' at '.$env{'user.domain'}.
              ' in domain '.$env{'request.role.domain'});
     my $uhome=&homeserver($uname,$udom,'true');
-    my $newuser;
-    if ($uhome eq 'no_host') {
-        $newuser = 1;
-    }
 # ----------------------------------------------------------------- Create User
     if (($uhome eq 'no_host') && 
 	(($umode && $upass) || ($umode eq 'localauth'))) {
@@ -6642,18 +6508,18 @@ sub modifyuser {
 		   ['firstname','middlename','lastname','generation','id',
                     'permanentemail','inststatus'],
 		   $udom,$uname);
-    my (%names,%oldnames);
+    my %names;
     if ($tmp[0] =~ m/^error:.*/) { 
         %names=(); 
     } else {
         %names = @tmp;
-        %oldnames = %names;
     }
 #
 # 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;
@@ -6666,7 +6532,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;
@@ -6676,7 +6542,6 @@ sub modifyuser {
             }
         }
     }
-
     if ($first)  { $names{'firstname'}  = $first; }
     if (defined($middle)) { $names{'middlename'} = $middle; }
     if ($last)   { $names{'lastname'}   = $last; }
@@ -6701,7 +6566,11 @@ sub modifyuser {
             }
         }
     }
-    my $logmsg = $udom.', '.$uname.', '.$uid.', '.
+    my $reply = &put('environment', \%names, $udom,$uname);
+    if ($reply ne 'ok') { return 'error: '.$reply; }
+    my $sqlresult = &update_allusers_table($uname,$udom,\%names);
+    &devalidate_cache_new('namescache',$uname.':'.$udom);
+    my $logmsg = 'Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
                  $umode.', '.$first.', '.$middle.', '.
 	         $last.', '.$gene.', '.$email.', '.$inststatus;
     if ($env{'user.name'} ne '' && $env{'user.domain'}) {
@@ -6709,29 +6578,6 @@ sub modifyuser {
     } else {
         $logmsg .= ' during self creation';
     }
-    my $changed;
-    if ($newuser) {
-        $changed = 1;
-    } else {
-        foreach my $field (@fields) {
-            if ($names{$field} ne $oldnames{$field}) {
-                $changed = 1;
-                last;
-            }
-        }
-    }
-    unless ($changed) {
-        $logmsg = 'No changes in user information needed for: '.$logmsg;
-        &logthis($logmsg);
-        return 'ok';
-    }
-    my $reply = &put('environment', \%names, $udom,$uname);
-    if ($reply ne 'ok') {
-        return 'error: '.$reply;
-    }
-    my $sqlresult = &update_allusers_table($uname,$udom,\%names);
-    &devalidate_cache_new('namescache',$uname.':'.$udom);
-    $logmsg = 'Success modifying user '.$logmsg;
     &logthis($logmsg);
     return 'ok';
 }
@@ -10428,7 +10274,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.