[BACK]Return to lonnet.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom / lonnet / perl

Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.1056.2.9 and 1.1063

version 1.1056.2.9, 2010/11/11 20:56:04 version 1.1063, 2010/05/20 18:11:18
Line 665  sub userload { Line 665  sub userload {
     return $userloadpercent;      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  # ------------------------------ Find server with least workload from spare.tab
   
 sub spareserver {  sub spareserver {
Line 1577  sub getsection { Line 1553  sub getsection {
     # If there is a role which has expired, return it.      # If there is a role which has expired, return it.
     #      #
     $courseid = &courseid_to_courseurl($courseid);      $courseid = &courseid_to_courseurl($courseid);
     my $extra = &freeze_escape({'skipcheck' => 1});      my %roleshash = &dump('roles',$udom,$unam,$courseid);
     my %roleshash = &dump('roles',$udom,$unam,$courseid,undef,$extra);  
     foreach my $key (keys(%roleshash)) {      foreach my $key (keys(%roleshash)) {
         next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/);          next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/);
         my $section=$1;          my $section=$1;
Line 2880  sub get_my_roles { Line 2855  sub get_my_roles {
     unless (defined($uname)) { $uname=$env{'user.name'}; }      unless (defined($uname)) { $uname=$env{'user.name'}; }
     unless (defined($udom)) { $udom=$env{'user.domain'}; }      unless (defined($udom)) { $udom=$env{'user.domain'}; }
     my (%dumphash,%nothide);      my (%dumphash,%nothide);
     if ($context eq 'userroles') {      if ($context eq 'userroles') { 
         my $extra = &freeze_escape({'skipcheck' => 1});          %dumphash = &dump('roles',$udom,$uname);
         %dumphash = &dump('roles',$udom,$uname,'.',undef,$extra);  
     } else {      } else {
         %dumphash=          %dumphash=
             &dump('nohist_userroles',$udom,$uname);              &dump('nohist_userroles',$udom,$uname);
Line 3061  sub courseiddump { Line 3035  sub courseiddump {
     my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,      my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
         $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,          $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
         $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,          $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,
         $cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner)=@_;          $cloneonly,$createdbefore,$createdafter,$creationcontext)=@_;
     my $as_hash = 1;      my $as_hash = 1;
     my %returnhash;      my %returnhash;
     if (!$domfilter) { $domfilter=''; }      if (!$domfilter) { $domfilter=''; }
Line 3083  sub courseiddump { Line 3057  sub courseiddump {
                          $showhidden.':'.$caller.':'.&escape($cloner).':'.                           $showhidden.':'.$caller.':'.&escape($cloner).':'.
                          &escape($cc_clone).':'.$cloneonly.':'.                           &escape($cc_clone).':'.$cloneonly.':'.
                          &escape($createdbefore).':'.&escape($createdafter).':'.                           &escape($createdbefore).':'.&escape($createdafter).':'.
                          &escape($creationcontext).':'.$domcloner,                           &escape($creationcontext),$tryserver);
                          $tryserver);  
                 my @pairs=split(/\&/,$rep);                  my @pairs=split(/\&/,$rep);
                 foreach my $item (@pairs) {                  foreach my $item (@pairs) {
                     my ($key,$value)=split(/\=/,$item,2);                      my ($key,$value)=split(/\=/,$item,2);
Line 3210  sub get_domain_roles { Line 3183  sub get_domain_roles {
     return %personnel;      return %personnel;
 }  }
   
 # ----------------------------------------------------------- Check out an item  # ----------------------------------------------------------- Interval timing 
   
 sub get_first_access {  sub get_first_access {
     my ($type,$argsymb)=@_;      my ($type,$argsymb)=@_;
Line 3246  sub set_first_access { Line 3219  sub set_first_access {
     return 'already_set';      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  # --------------------------------------------- Set Expire Date for Spreadsheet
   
 sub expirespread {  sub expirespread {
Line 4031  sub standard_roleprivs { Line 3919  sub standard_roleprivs {
 }  }
   
 sub set_userprivs {  sub set_userprivs {
     my ($userroles,$allroles,$allgroups,$groups_roles) = @_;       my ($userroles,$allroles,$allgroups) = @_; 
     my $author=0;      my $author=0;
     my $adv=0;      my $adv=0;
     my %grouproles = ();      my %grouproles = ();
     if (keys(%{$allgroups}) > 0) {      if (keys(%{$allgroups}) > 0) {
         my @groupkeys;  
         foreach my $role (keys(%{$allroles})) {          foreach my $role (keys(%{$allroles})) {
             push(@groupkeys,$role);              my ($trole,$area,$sec,$extendedarea);
         }              if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) {
         if (ref($groups_roles) eq 'HASH') {                  $trole = $1;
             foreach my $key (keys(%{$groups_roles})) {                  $area = $2;
                 unless (grep(/^\Q$key\E$/,@groupkeys)) {                  $sec = $3;
                     push(@groupkeys,$key);                  $extendedarea = $area.$sec;
                 }                  if (exists($$allgroups{$area})) {
             }                      foreach my $group (keys(%{$$allgroups{$area}})) {
         }                          my $spec = $trole.'.'.$extendedarea;
         if (@groupkeys > 0) {                          $grouproles{$spec.'.'.$area.'/'.$group} = 
             foreach my $role (@groupkeys) {                                                  $$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};  
                         }  
                     }                      }
                 }                  }
             }              }
Line 4107  sub role_status { Line 3982  sub role_status {
                 if ($$tstart<$now) {                  if ($$tstart<$now) {
                     if ($$tstart && $$tstart>$refresh) {                      if ($$tstart && $$tstart>$refresh) {
                         if (($$where ne '') && ($$role ne '')) {                          if (($$where ne '') && ($$role ne '')) {
                             my (%allroles,%allgroups,$group_privs,                              my (%allroles,%allgroups,$group_privs);
                                 %groups_roles,@rolecodes);  
                             my %userroles = (                              my %userroles = (
                                 'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend                                  'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend
                             );                              );
                             @rolecodes = ('cm');  
                             my $spec=$$role.'.'.$$where;                              my $spec=$$role.'.'.$$where;
                             my ($tdummy,$tdomain,$trest)=split(/\//,$$where);                              my ($tdummy,$tdomain,$trest)=split(/\//,$$where);
                             if ($$role =~ /^cr\//) {                              if ($$role =~ /^cr\//) {
                                 &custom_roleprivs(\%allroles,$$role,$tdomain,$trest,$spec,$$where);                                  &custom_roleprivs(\%allroles,$$role,$tdomain,$trest,$spec,$$where);
                                 push(@rolecodes,'cr');  
                             } elsif ($$role eq 'gr') {                              } elsif ($$role eq 'gr') {
                                 push(@rolecodes,$$role);  
                                 my %rolehash = &get('roles',[$$where.'_'.$$role],$env{'user.domain'},                                  my %rolehash = &get('roles',[$$where.'_'.$$role],$env{'user.domain'},
                                                     $env{'user.name'});                                                      $env{'user.name'});
                                 my ($trole) = split('_',$rolehash{$$where.'_'.$$role},2);                                  my ($trole) = split('_',$rolehash{$$where.'_'.$$role},1);
                                 (undef,my $group_privs) = split(/\//,$trole);                                  (undef,my $group_privs) = split(/\//,$trole);
                                 $group_privs = &unescape($group_privs);                                  $group_privs = &unescape($group_privs);
                                 &group_roleprivs(\%allgroups,$$where,$group_privs,$$tend,$$tstart);                                  &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 {                              } else {
                                 push(@rolecodes,$$role);  
                                 &standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where);                                  &standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where);
                             }                              }
                             my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups,\%groups_roles);                              my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups);
                             &appenv(\%userroles,\@rolecodes);                              &appenv(\%userroles,[$$role,'cm']);
                             &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);                              &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);
                         }                          }
                     }                      }
Line 4177  sub role_status { Line 4020  sub role_status {
 }  }
   
 sub check_adhoc_privs {  sub check_adhoc_privs {
     my ($cdom,$cnum,$then,$refresh,$now,$checkrole,$caller) = @_;      my ($cdom,$cnum,$then,$refresh,$now,$checkrole) = @_;
     my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;      my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;
     if ($env{$cckey}) {      if ($env{$cckey}) {
         my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);          my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);
         &role_status($cckey,$then,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);          &role_status($cckey,$then,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);
         unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) {          unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) {
             &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);              &set_adhoc_privileges($cdom,$cnum,$checkrole);
         }          }
     } else {      } else {
         &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);          &set_adhoc_privileges($cdom,$cnum,$checkrole);
     }      }
 }  }
   
 sub set_adhoc_privileges {  sub set_adhoc_privileges {
 # role can be cc or ca  # role can be cc or ca
     my ($dcdom,$pickedcourse,$role,$caller) = @_;      my ($dcdom,$pickedcourse,$role) = @_;
     my $area = '/'.$dcdom.'/'.$pickedcourse;      my $area = '/'.$dcdom.'/'.$pickedcourse;
     my $spec = $role.'.'.$area;      my $spec = $role.'.'.$area;
     my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'},      my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'},
Line 4202  sub set_adhoc_privileges { Line 4045  sub set_adhoc_privileges {
     my ($author,$adv)= &set_userprivs(\%userroles,\%ccrole);      my ($author,$adv)= &set_userprivs(\%userroles,\%ccrole);
     &appenv(\%userroles,[$role,'cm']);      &appenv(\%userroles,[$role,'cm']);
     &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);      &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);
     unless ($caller eq 'constructaccess' && $env{'request.course.id'}) {      &appenv( {'request.role'        => $spec,
         &appenv( {'request.role'        => $spec,                'request.role.domain' => $dcdom,
                   'request.role.domain' => $dcdom,                'request.course.sec'  => ''
                   'request.course.sec'  => ''               }
                  }             );
                );      my $tadv=0;
         my $tadv=0;      if (&allowed('adv') eq 'F') { $tadv=1; }
         if (&allowed('adv') eq 'F') { $tadv=1; }      &appenv({'request.role.adv'    => $tadv});
         &appenv({'request.role.adv'    => $tadv});  
     }  
 }  }
   
 # --------------------------------------------------------------- get interface  # --------------------------------------------------------------- get interface
Line 4260  sub del { Line 4101  sub del {
 # -------------------------------------------------------------- dump interface  # -------------------------------------------------------------- dump interface
   
 sub dump {  sub dump {
     my ($namespace,$udomain,$uname,$regexp,$range,$extra)=@_;      my ($namespace,$udomain,$uname,$regexp,$range)=@_;
     if (!$udomain) { $udomain=$env{'user.domain'}; }      if (!$udomain) { $udomain=$env{'user.domain'}; }
     if (!$uname) { $uname=$env{'user.name'}; }      if (!$uname) { $uname=$env{'user.name'}; }
     my $uhome=&homeserver($uname,$udomain);      my $uhome=&homeserver($uname,$udomain);
Line 4269  sub dump { Line 4110  sub dump {
     } else {      } else {
  $regexp='.';   $regexp='.';
     }      }
     my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range:$extra",$uhome);      my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
     my @pairs=split(/\&/,$rep);      my @pairs=split(/\&/,$rep);
     my %returnhash=();      my %returnhash=();
     foreach my $item (@pairs) {      foreach my $item (@pairs) {
Line 4945  sub is_course_owner { Line 4786  sub is_course_owner {
   
 sub is_advanced_user {  sub is_advanced_user {
     my ($udom,$uname) = @_;      my ($udom,$uname) = @_;
     if ($udom ne '' && $uname ne '') {  
         if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {  
             return $env{'user.adv'};    
         }  
     }  
     my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1);      my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1);
     my %allroles;      my %allroles;
     my $is_adv;      my $is_adv;
Line 5616  sub metadata_query { Line 5452  sub metadata_query {
     my @server_list = (defined($server_array) ? @$server_array      my @server_list = (defined($server_array) ? @$server_array
                                               : keys(%libserv) );                                                : keys(%libserv) );
     for my $server (@server_list) {      for my $server (@server_list) {
   #SD remove this
   &logthis("Querying server:$server");
  unless ($custom or $customshow) {   unless ($custom or $customshow) {
     my $reply=&reply("querysend:".&escape($query),$server);      my $reply=&reply("querysend:".&escape($query),$server);
     $rhash{$server}=$reply;      $rhash{$server}=$reply;
Line 5672  sub update_allusers_table { Line 5510  sub update_allusers_table {
                'generation='.&escape($names->{'generation'}).'%%'.                 'generation='.&escape($names->{'generation'}).'%%'.
                'permanentemail='.&escape($names->{'permanentemail'}).'%%'.                 'permanentemail='.&escape($names->{'permanentemail'}).'%%'.
                'id='.&escape($names->{'id'}),$homeserver);                 'id='.&escape($names->{'id'}),$homeserver);
     return;      my $reply = &get_query_reply($queryid);
       return $reply;
 }  }
   
 # ------- Request retrieval of institutional classlists for course(s)  # ------- Request retrieval of institutional classlists for course(s)
Line 5866  sub auto_validate_instcode { Line 5705  sub auto_validate_instcode {
             $homeserver = &domain($cdom,'primary');              $homeserver = &domain($cdom,'primary');
         }          }
     }      }
     $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'.      my $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'.
                         &escape($instcode).':'.&escape($owner),$homeserver));                             &escape($instcode).':'.&escape($owner),$homeserver));
     my ($outcome,$description) = map { &unescape($_); } split('&',$response,2);      my ($outcome,$description) = map { &unescape($_); } split('&',$response,2);
     return ($outcome,$description);      return ($outcome,$description);
 }  }
Line 6235  sub get_users_groups { Line 6074  sub get_users_groups {
     } else {        } else {  
         $grouplist = '';          $grouplist = '';
         my $courseurl = &courseid_to_courseurl($courseid);          my $courseurl = &courseid_to_courseurl($courseid);
         my $extra = &freeze_escape({'skipcheck' => 1});          my %roleshash = &dump('roles',$udom,$uname,$courseurl);
         my %roleshash = &dump('roles',$udom,$uname,$courseurl,undef,$extra);  
         my $access_end = $env{'course.'.$courseid.          my $access_end = $env{'course.'.$courseid.
                               '.default_enrollment_end_date'};                                '.default_enrollment_end_date'};
         my $now = time;          my $now = time;
Line 6596  sub modifyuser { Line 6434  sub modifyuser {
              ' by '.$env{'user.name'}.' at '.$env{'user.domain'}.               ' by '.$env{'user.name'}.' at '.$env{'user.domain'}.
              ' in domain '.$env{'request.role.domain'});               ' in domain '.$env{'request.role.domain'});
     my $uhome=&homeserver($uname,$udom,'true');      my $uhome=&homeserver($uname,$udom,'true');
     my $newuser;  
     if ($uhome eq 'no_host') {  
         $newuser = 1;  
     }  
 # ----------------------------------------------------------------- Create User  # ----------------------------------------------------------------- Create User
     if (($uhome eq 'no_host') &&       if (($uhome eq 'no_host') && 
  (($umode && $upass) || ($umode eq 'localauth'))) {   (($umode && $upass) || ($umode eq 'localauth'))) {
Line 6652  sub modifyuser { Line 6486  sub modifyuser {
    ['firstname','middlename','lastname','generation','id',     ['firstname','middlename','lastname','generation','id',
                     'permanentemail','inststatus'],                      'permanentemail','inststatus'],
    $udom,$uname);     $udom,$uname);
     my (%names,%oldnames);      my %names;
     if ($tmp[0] =~ m/^error:.*/) {       if ($tmp[0] =~ m/^error:.*/) { 
         %names=();           %names=(); 
     } else {      } else {
         %names = @tmp;          %names = @tmp;
         %oldnames = %names;  
     }      }
 #  #
 # If name, email and/or uid are blank (e.g., because an uploaded file  # 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  # 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',      my @fields = ('firstname','middlename','lastname','generation',
                   'permanentemail','id');                    'permanentemail','id');
     my %newvalues;      my %newvalues;
Line 6676  sub modifyuser { Line 6510  sub modifyuser {
                     $names{$field} = $middle;                      $names{$field} = $middle;
                 } elsif ($field eq 'lastname') {                  } elsif ($field eq 'lastname') {
                     $names{$field} = $last;                      $names{$field} = $last;
                 } elsif ($field eq 'generation') {                  } elsif ($field eq 'generation') { 
                     $names{$field} = $gene;                      $names{$field} = $gene;
                 } elsif ($field eq 'permanentemail') {                  } elsif ($field eq 'permanentemail') {
                     $names{$field} = $email;                      $names{$field} = $email;
Line 6686  sub modifyuser { Line 6520  sub modifyuser {
             }              }
         }          }
     }      }
   
     if ($first)  { $names{'firstname'}  = $first; }      if ($first)  { $names{'firstname'}  = $first; }
     if (defined($middle)) { $names{'middlename'} = $middle; }      if (defined($middle)) { $names{'middlename'} = $middle; }
     if ($last)   { $names{'lastname'}   = $last; }      if ($last)   { $names{'lastname'}   = $last; }
Line 6711  sub modifyuser { Line 6544  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.', '.                   $umode.', '.$first.', '.$middle.', '.
          $last.', '.$gene.', '.$email.', '.$inststatus;           $last.', '.$gene.', '.$email.', '.$inststatus;
     if ($env{'user.name'} ne '' && $env{'user.domain'}) {      if ($env{'user.name'} ne '' && $env{'user.domain'}) {
Line 6719  sub modifyuser { Line 6556  sub modifyuser {
     } else {      } else {
         $logmsg .= ' during self creation';          $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;  
     }  
     if ($names{'permanentemail'} ne $oldnames{'permanentemail'}) {  
         &Apache::lonnet::devalidate_cache_new('emailscache',$uname.':'.$udom);  
     }  
     my $sqlresult = &update_allusers_table($uname,$udom,\%names);  
     &devalidate_cache_new('namescache',$uname.':'.$udom);  
     $logmsg = 'Success modifying user '.$logmsg;  
     &logthis($logmsg);      &logthis($logmsg);
     return 'ok';      return 'ok';
 }  }
Line 9850  sub get_dns { Line 9661  sub get_dns {
  return %libserv;   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 {      sub get_servers {
  &load_hosts_tab() if (!$loaded);   &load_hosts_tab() if (!$loaded);
   
Line 9873  sub get_dns { Line 9690  sub get_dns {
  return %result;   return %result;
     }      }
   
       sub get_unique_servers {
           my %unique = reverse &get_servers(@_);
    return reverse %unique;
       }
   
     sub host_domain {      sub host_domain {
  &load_hosts_tab() if (!$loaded);   &load_hosts_tab() if (!$loaded);
   
Line 10441  modifyuser($udom,$uname,$uid,$umode,$upa Line 10263  modifyuser($udom,$uname,$uid,$umode,$upa
 will update user information (firstname,middlename,lastname,generation,  will update user information (firstname,middlename,lastname,generation,
 permanentemail), and if forceid is true, student/employee ID also.  permanentemail), and if forceid is true, student/employee ID also.
 A user's institutional affiliation(s) can also be updated.  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.  unless the field is included in the $candelete array reference.
 This array is included when a single user is modified via "Manage Users",  This array is included when a single user is modified via "Manage Users",
 or when Autoupdate.pl is run by cron in a domain.  or when Autoupdate.pl is run by cron in a domain.
Removed from v.1.1056.2.9  
changed lines
  Added in v.1.1063

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>