[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.1058 and 1.1065

version 1.1058, 2010/03/21 21:05:51 version 1.1065, 2010/05/22 00:55:08
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 3943  sub standard_roleprivs { Line 3919  sub standard_roleprivs {
 }  }
   
 sub set_userprivs {  sub set_userprivs {
     my ($userroles,$allroles,$allgroups) = @_;       my ($userroles,$allroles,$allgroups,$groups_roles) = @_; 
     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})) {
             my ($trole,$area,$sec,$extendedarea);              push(@groupkeys,$role);
             if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) {          }
                 $trole = $1;          if (ref($groups_roles) eq 'HASH') {
                 $area = $2;              foreach my $key (keys(%{$groups_roles})) {
                 $sec = $3;                  unless (grep(/^\Q$key\E$/,@groupkeys)) {
                 $extendedarea = $area.$sec;                      push(@groupkeys,$key);
                 if (exists($$allgroups{$area})) {                  }
                     foreach my $group (keys(%{$$allgroups{$area}})) {              }
                         my $spec = $trole.'.'.$extendedarea;          }
                         $grouproles{$spec.'.'.$area.'/'.$group} =           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};                                                  $$allgroups{$area}{$group};
                           }
                     }                      }
                 }                  }
             }              }
Line 4006  sub role_status { Line 3995  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},1);                                  my ($trole) = split('_',$rolehash{$$where.'_'.$$role},2);
                                 (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);                              my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups,\%groups_roles);
                             &appenv(\%userroles,[$$role,'cm']);                              &appenv(\%userroles,\@rolecodes);
                             &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 4539  sub get_portfolio_access { Line 4560  sub get_portfolio_access {
                 my (%allgroups,%allroles);                   my (%allgroups,%allroles); 
                 my ($start,$end,$role,$sec,$group);                  my ($start,$end,$role,$sec,$group);
                 foreach my $envkey (%env) {                  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;                           my $cid = $2.'_'.$3; 
                         if ($1 eq 'gr') {                          if ($1 eq 'gr') {
                             $group = $4;                              $group = $4;
Line 5476  sub metadata_query { Line 5497  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 5727  sub auto_validate_instcode { Line 5750  sub auto_validate_instcode {
             $homeserver = &domain($cdom,'primary');              $homeserver = &domain($cdom,'primary');
         }          }
     }      }
     my $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'.      $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 6234  sub assignrole { Line 6257  sub assignrole {
                     if ($role eq 'cc' || $role eq 'co') {                      if ($role eq 'cc' || $role eq 'co') {
                         %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));                          %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
                         if (($role eq 'cc') && ($cnum !~ /^$match_community$/)) {                          if (($role eq 'cc') && ($cnum !~ /^$match_community$/)) {
   
                             if ($env{'request.role'} eq 'cc./'.$cdom.'/'.$cnum) {                              if ($env{'request.role'} eq 'cc./'.$cdom.'/'.$cnum) {
                                 if ($crsenv{'internal.courseowner'} eq                                   if ($crsenv{'internal.courseowner'} eq 
                                     $env{'user.name'}.':'.$env{'user.domain'}) {                                      $env{'user.name'}.':'.$env{'user.domain'}) {
Line 6443  sub modifyuser { Line 6465  sub modifyuser {
         $forceid, $desiredhome, $email, $inststatus, $candelete)=@_;          $forceid, $desiredhome, $email, $inststatus, $candelete)=@_;
     $udom= &LONCAPA::clean_domain($udom);      $udom= &LONCAPA::clean_domain($udom);
     $uname=&LONCAPA::clean_username($uname);      $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.', '.      &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
              $umode.', '.$first.', '.$middle.', '.               $umode.', '.$first.', '.$middle.', '.
      $last.', '.$gene.'(forceid: '.$forceid.'; candelete: '.$candelete.')'.       $last.', '.$gene.'(forceid: '.$forceid.'; candelete: '.$showcandelete.')'.
              (defined($desiredhome) ? ' desiredhome = '.$desiredhome :               (defined($desiredhome) ? ' desiredhome = '.$desiredhome :
                                      ' desiredhome not specified').                                        ' desiredhome not specified'). 
              ' by '.$env{'user.name'}.' at '.$env{'user.domain'}.               ' by '.$env{'user.name'}.' at '.$env{'user.domain'}.
Line 9678  sub get_dns { Line 9706  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 9701  sub get_dns { Line 9735  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);
   
Removed from v.1.1058  
changed lines
  Added in v.1.1065

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