[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.1168 and 1.1176

version 1.1168, 2012/05/18 15:31:40 version 1.1176, 2012/05/30 20:29:45
Line 75  use LWP::UserAgent(); Line 75  use LWP::UserAgent();
 use HTTP::Date;  use HTTP::Date;
 use Image::Magick;  use Image::Magick;
   
   use Encode;
   
 use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir  use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
             $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease              $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease
             %managerstab);              %managerstab);
Line 1237  sub check_loadbalancing { Line 1239  sub check_loadbalancing {
     my ($is_balancer,$dom_in_use,$homeintdom,$rule_in_effect,      my ($is_balancer,$dom_in_use,$homeintdom,$rule_in_effect,
         $offloadto,$otherserver);          $offloadto,$otherserver);
     my $lonhost = $perlvar{'lonHostID'};      my $lonhost = $perlvar{'lonHostID'};
       my @hosts = &current_machine_ids();
     my $uprimary_id = &Apache::lonnet::domain($udom,'primary');      my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
     my $uintdom = &Apache::lonnet::internet_dom($uprimary_id);      my $uintdom = &Apache::lonnet::internet_dom($uprimary_id);
     my $intdom = &Apache::lonnet::internet_dom($lonhost);      my $intdom = &Apache::lonnet::internet_dom($lonhost);
Line 1263  sub check_loadbalancing { Line 1266  sub check_loadbalancing {
         my $currtargets = $result->{'targets'};          my $currtargets = $result->{'targets'};
         my $currrules = $result->{'rules'};          my $currrules = $result->{'rules'};
         if ($currbalancer ne '') {          if ($currbalancer ne '') {
             my @hosts = &current_machine_ids();  
             if (grep(/^\Q$currbalancer\E$/,@hosts)) {              if (grep(/^\Q$currbalancer\E$/,@hosts)) {
                 $is_balancer = 1;                  $is_balancer = 1;
             }              }
Line 1351  sub check_loadbalancing { Line 1353  sub check_loadbalancing {
             $offloadto = &this_host_spares($dom_in_use);              $offloadto = &this_host_spares($dom_in_use);
         }          }
     }      }
     my $lowest_load = 30000;      if ($is_balancer) {
     if (ref($offloadto) eq 'HASH') {          my $lowest_load = 30000;
         if (ref($offloadto->{'primary'}) eq 'ARRAY') {          if (ref($offloadto) eq 'HASH') {
             foreach my $try_server (@{$offloadto->{'primary'}}) {              if (ref($offloadto->{'primary'}) eq 'ARRAY') {
                 ($otherserver,$lowest_load) =                  foreach my $try_server (@{$offloadto->{'primary'}}) {
                     &compare_server_load($try_server,$otherserver,$lowest_load);                      ($otherserver,$lowest_load) =
                           &compare_server_load($try_server,$otherserver,$lowest_load);
                   }
             }              }
         }              my $found_server = ($otherserver ne '' && $lowest_load < 100);
         my $found_server = ($otherserver ne '' && $lowest_load < 100);  
   
         if (!$found_server) {              if (!$found_server) {
             if (ref($offloadto->{'default'}) eq 'ARRAY') {                  if (ref($offloadto->{'default'}) eq 'ARRAY') {
                 foreach my $try_server (@{$offloadto->{'default'}}) {                      foreach my $try_server (@{$offloadto->{'default'}}) {
                           ($otherserver,$lowest_load) =
                               &compare_server_load($try_server,$otherserver,$lowest_load);
                       }
                   }
               }
           } elsif (ref($offloadto) eq 'ARRAY') {
               if (@{$offloadto} == 1) {
                   $otherserver = $offloadto->[0];
               } elsif (@{$offloadto} > 1) {
                   foreach my $try_server (@{$offloadto}) {
                     ($otherserver,$lowest_load) =                      ($otherserver,$lowest_load) =
                         &compare_server_load($try_server,$otherserver,$lowest_load);                          &compare_server_load($try_server,$otherserver,$lowest_load);
                 }                  }
             }              }
         }          }
     } elsif (ref($offloadto) eq 'ARRAY') {          if (($otherserver ne '') && (grep(/^\Q$otherserver\E$/,@hosts))) {
         if (@{$offloadto} == 1) {              $is_balancer = 0;
             $otherserver = $offloadto->[0];              if ($uname ne '' && $udom ne '') {
         } elsif (@{$offloadto} > 1) {                  if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {
             foreach my $try_server (@{$offloadto}) {                      
                 ($otherserver,$lowest_load) =                      &appenv({'user.loadbalexempt'     => $lonhost,  
                     &compare_server_load($try_server,$otherserver,$lowest_load);                               'user.loadbalcheck.time' => time});
                   }
             }              }
         }          }
     }      }
Line 1385  sub check_loadbalancing { Line 1399  sub check_loadbalancing {
 sub get_loadbalancer_targets {  sub get_loadbalancer_targets {
     my ($rule_in_effect,$currtargets,$uname,$udom) = @_;      my ($rule_in_effect,$currtargets,$uname,$udom) = @_;
     my $offloadto;      my $offloadto;
     if ($rule_in_effect eq '') {      if ($rule_in_effect eq 'none') {
           return [$perlvar{'lonHostID'}];
       } elsif ($rule_in_effect eq '') {
         $offloadto = $currtargets;          $offloadto = $currtargets;
     } else {      } else {
         if ($rule_in_effect eq 'homeserver') {          if ($rule_in_effect eq 'homeserver') {
Line 2568  sub ssi { Line 2584  sub ssi {
     }      }
   
     $request->header(Cookie => $ENV{'HTTP_COOKIE'});      $request->header(Cookie => $ENV{'HTTP_COOKIE'});
     my $response=$ua->request($request);      my $response= $ua->request($request);
       my $content = Encode::decode_utf8($response->content);
     if (wantarray) {      if (wantarray) {
  return ($response->content, $response);   return ($content, $response);
     } else {      } else {
  return $response->content;   return $content;
     }      }
 }  }
   
Line 3490  sub statslog { Line 3506  sub statslog {
       
 sub userrolelog {  sub userrolelog {
     my ($trole,$username,$domain,$area,$tstart,$tend)=@_;      my ($trole,$username,$domain,$area,$tstart,$tend)=@_;
     if (($trole=~/^ca/) || ($trole=~/^aa/) ||      if ( $trole =~ /^(ca|aa|in|cc|ep|cr|ta|co)/ ) {
         ($trole=~/^in/) || ($trole=~/^cc/) ||  
         ($trole=~/^ep/) || ($trole=~/^cr/) ||  
         ($trole=~/^ta/) || ($trole=~/^co/)) {  
        my (undef,$rudom,$runame,$rsec)=split(/\//,$area);         my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
        $userrolehash         $userrolehash
          {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}           {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
                     =$tend.':'.$tstart;                      =$tend.':'.$tstart;
     }      }
     if (($env{'request.role'} =~ /dc\./) &&      if ($env{'request.role'} =~ /dc\./ && $trole =~ /^(au|in|cc|ep|cr|ta|co)/) {
  (($trole=~/^au/) || ($trole=~/^in/) ||  
  ($trole=~/^cc/) || ($trole=~/^ep/) ||  
  ($trole=~/^cr/) || ($trole=~/^ta/) ||  
          ($trole=~/^co/))) {  
        $userrolehash         $userrolehash
          {$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'}           {$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'}
                     =$tend.':'.$tstart;                      =$tend.':'.$tstart;
     }      }
     if (($trole=~/^dc/) || ($trole=~/^ad/) ||      if ($trole =~ /^(dc|ad|li|au|dg|sc)/ ) {
         ($trole=~/^li/) || ($trole=~/^li/) ||  
         ($trole=~/^au/) || ($trole=~/^dg/) ||  
         ($trole=~/^sc/)) {  
        my (undef,$rudom,$runame,$rsec)=split(/\//,$area);         my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
        $domainrolehash         $domainrolehash
          {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}           {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
Line 3969  my $cachedtime=(); Line 3975  my $cachedtime=();
 sub load_all_first_access {  sub load_all_first_access {
     my ($uname,$udom)=@_;      my ($uname,$udom)=@_;
     if (($cachedkey eq $uname.':'.$udom) &&      if (($cachedkey eq $uname.':'.$udom) &&
         (abs($cachedtime-time)<5)) {          (abs($cachedtime-time)<5) && (!$env{'form.markaccess'})) {
         return;          return;
     }      }
     $cachedtime=time;      $cachedtime=time;
Line 4613  sub update_released_required { Line 4619  sub update_released_required {
   
 sub privileged {  sub privileged {
     my ($username,$domain)=@_;      my ($username,$domain)=@_;
     my $rolesdump=&reply("dump:$domain:$username:roles",  
  &homeserver($username,$domain));      my %rolesdump = &dump("roles", $domain, $username) or return 0;
     if (($rolesdump eq 'con_lost') || ($rolesdump eq '') ||       my $now = time;
         ($rolesdump =~ /^error:/)) {  
         return 0;      for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys %rolesdump}) {
     }              my ($trole, $tend, $tstart) = split(/_/, $role);
     my $now=time;              if (($trole eq 'dc') || ($trole eq 'su')) {
     if ($rolesdump ne '') {                  return 1 unless ($tend && $tend < $now) 
         foreach my $entry (split(/&/,$rolesdump)) {                      or ($tstart && $tstart > $now);
     if ($entry!~/^rolesdef_/) {              }
  my ($area,$role)=split(/=/,$entry);  
  $area=~s/\_\w\w$//;  
  my ($trole,$tend,$tstart)=split(/_/,$role);  
  if (($trole eq 'dc') || ($trole eq 'su')) {  
     my $active=1;  
     if ($tend) {  
  if ($tend<$now) { $active=0; }  
     }  
     if ($tstart) {  
  if ($tstart>$now) { $active=0; }  
     }  
     if ($active) { return 1; }  
  }  
     }  
  }   }
     }  
     return 0;      return 0;
 }  }
   
 # -------------------------------------------------------- Get user privileges  # -------------------------------------------------------- Get user privileges
   
 sub rolesinit {  sub rolesinit {
     my ($domain,$username,$authhost)=@_;      my ($domain, $username) = @_;
     my $now=time;      my %userroles = ('user.login.time' => time);
     my %userroles = ('user.login.time' => $now);      my %rolesdump = &dump("roles", $domain, $username) or return \%userroles;
     my $rolesdump=reply("dump:$domain:$username:roles",$authhost);  
     if (($rolesdump eq 'con_lost') || ($rolesdump eq '') ||       # firstaccess and timerinterval are related to timed maps/resources. 
         ($rolesdump =~ /^error:/)) {      # also, blocking can be triggered by an activating timer
         return \%userroles;      # it's saved in the user's %env.
     }      my %firstaccess = &dump('firstaccesstimes', $domain, $username);
     my %firstaccess = &dump('firstaccesstimes',$domain,$username);      my %timerinterval = &dump('timerinterval', $domain, $username);
     my %timerinterval = &dump('timerinterval',$domain,$username);      my (%coursetimerstarts, %firstaccchk, %firstaccenv, %coursetimerintervals,
     my (%coursetimerstarts,%firstaccchk,%firstaccenv,          %timerintchk, %timerintenv);
         %coursetimerintervals,%timerintchk,%timerintenv);  
     foreach my $key (keys(%firstaccess)) {      foreach my $key (keys(%firstaccess)) {
         my ($cid,$rest) = split(/\0/,$key);          my ($cid, $rest) = split(/\0/, $key);
         $coursetimerstarts{$cid}{$rest} = $firstaccess{$key};          $coursetimerstarts{$cid}{$rest} = $firstaccess{$key};
     }      }
   
     foreach my $key (keys(%timerinterval)) {      foreach my $key (keys(%timerinterval)) {
         my ($cid,$rest) = split(/\0/,$key);          my ($cid,$rest) = split(/\0/,$key);
         $coursetimerintervals{$cid}{$rest} = $timerinterval{$key};          $coursetimerintervals{$cid}{$rest} = $timerinterval{$key};
     }      }
   
     my %allroles=();      my %allroles=();
     my %allgroups=();      my %allgroups=();
   
     if ($rolesdump ne '') {      for my $area (grep { ! /^rolesdef_/ } keys %rolesdump) {
         foreach my $entry (split(/&/,$rolesdump)) {          my $role = $rolesdump{$area};
   if ($entry!~/^rolesdef_/) {          $area =~ s/\_\w\w$//;
             my ($area,$role)=split(/=/,$entry);  
     $area=~s/\_\w\w$//;          my ($trole, $tend, $tstart, $group_privs);
             my ($trole,$tend,$tstart,$group_privs);  
     if ($role=~/^cr/) {          if ($role =~ /^cr/) {
 # Custom role, defined by a user           # Custom role, defined by a user 
 # e.g., user.role.cr/msu/smith/mynewrole          # e.g., user.role.cr/msu/smith/mynewrole
  if ($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|) {              if ($role =~ m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|) {
     ($trole,my $trest)=($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|);                  $trole = $1;
     ($tend,$tstart)=split('_',$trest);                  ($tend, $tstart) = split('_', $2);
  } else {              } else {
     $trole=$role;                  $trole = $role;
  }              }
             } elsif ($role =~ m|^gr/|) {          } elsif ($role =~ m|^gr/|) {
 # Role of member in a group, defined within a course/community          # Role of member in a group, defined within a course/community
 # e.g., user.role.gr/msu/04935610a19ee4a5fmsul1/leopards          # e.g., user.role.gr/msu/04935610a19ee4a5fmsul1/leopards
                 ($trole,$tend,$tstart) = split(/_/,$role);              ($trole, $tend, $tstart) = split(/_/, $role);
                 next if ($tstart eq '-1');              next if $tstart eq '-1';
                 ($trole,$group_privs) = split(/\//,$trole);              ($trole, $group_privs) = split(/\//, $trole);
                 $group_privs = &unescape($group_privs);              $group_privs = &unescape($group_privs);
     } else {          } else {
 # Just a normal role, defined in roles.tab          # Just a normal role, defined in roles.tab
  ($trole,$tend,$tstart)=split(/_/,$role);              ($trole, $tend, $tstart) = split(/_/,$role);
     }          }
     my %new_role = &set_arearole($trole,$area,$tstart,$tend,$domain,  
  $username);          my %new_role = &set_arearole($trole,$area,$tstart,$tend,$domain,
     @userroles{keys(%new_role)} = @new_role{keys(%new_role)};                   $username);
             if (($tend!=0) && ($tend<$now)) { $trole=''; }          @userroles{keys(%new_role)} = @new_role{keys(%new_role)};
             if (($tstart!=0) && ($tstart>$now)) { $trole=''; }  
             if (($area ne '') && ($trole ne '')) {          # role expired or not available yet?
  my $spec=$trole.'.'.$area;          $trole = '' if ($tend != 0 && $tend < $userroles{'user.login.time'}) or 
  my ($tdummy,$tdomain,$trest)=split(/\//,$area);              ($tstart != 0 && $tstart > $userroles{'user.login.time'});
  if ($trole =~ /^cr\//) {  
 # Custom role, defined by a user          next if $area eq '' or $trole eq '';
                     &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);  
                 } elsif ($trole eq 'gr') {          my $spec = "$trole.$area";
 # Role of a member in a group, defined within a course/community          my ($tdummy, $tdomain, $trest) = split(/\//, $area);
                     &group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart);  
  } else {          if ($trole =~ /^cr\//) {
 # Normal role, defined in roles.tab          # Custom role, defined by a user
                     &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);              &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
  }          } elsif ($trole eq 'gr') {
                 if ($trole ne 'gr') {          # Role of a member in a group, defined within a course/community
                     my $cid = $tdomain.'_'.$trest;              &group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart);
                     unless ($firstaccchk{$cid}) {              next;
                         if (ref($coursetimerstarts{$cid}) eq 'HASH') {          } else {
                             foreach my $item (keys(%{$coursetimerstarts{$cid}})) {          # Normal role, defined in roles.tab
                                 $firstaccenv{'course.'.$cid.'.firstaccess.'.$item} =               &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
                                     $coursetimerstarts{$cid}{$item};           }
                             }  
                         }          my $cid = $tdomain.'_'.$trest;
                         $firstaccchk{$cid} = 1;          unless ($firstaccchk{$cid}) {
                     }              if (ref($coursetimerstarts{$cid}) eq 'HASH') {
                     unless ($timerintchk{$cid}) {                  foreach my $item (keys(%{$coursetimerstarts{$cid}})) {
                         if (ref($coursetimerintervals{$cid}) eq 'HASH') {                      $firstaccenv{'course.'.$cid.'.firstaccess.'.$item} = 
                             foreach my $item (keys(%{$coursetimerintervals{$cid}})) {                          $coursetimerstarts{$cid}{$item}; 
                                 $timerintenv{'course.'.$cid.'.timerinterval.'.$item} =  
                                    $coursetimerintervals{$cid}{$item};  
                             }  
                         }  
                         $timerintchk{$cid} = 1;  
                     }  
                 }                  }
             }              }
           }              $firstaccchk{$cid} = 1;
           }
           unless ($timerintchk{$cid}) {
               if (ref($coursetimerintervals{$cid}) eq 'HASH') {
                   foreach my $item (keys(%{$coursetimerintervals{$cid}})) {
                       $timerintenv{'course.'.$cid.'.timerinterval.'.$item} =
                          $coursetimerintervals{$cid}{$item};
                   }
               }
               $timerintchk{$cid} = 1;
         }          }
         my ($author,$adv) = &set_userprivs(\%userroles,\%allroles,\%allgroups);  
         $userroles{'user.adv'}    = $adv;  
  $userroles{'user.author'} = $author;  
         $env{'user.adv'}=$adv;  
     }      }
   
       @userroles{'user.author', 'user.adv'} = &set_userprivs(\%userroles,
           \%allroles, \%allgroups);
       $env{'user.adv'} = $userroles{'user.adv'};
   
     return (\%userroles,\%firstaccenv,\%timerintenv);      return (\%userroles,\%firstaccenv,\%timerintenv);
 }  }
   
Line 10778  sub declutter { Line 10776  sub declutter {
     $thisfn=~s|^adm/wrapper/||;      $thisfn=~s|^adm/wrapper/||;
     $thisfn=~s|^adm/coursedocs/showdoc/||;      $thisfn=~s|^adm/coursedocs/showdoc/||;
     $thisfn=~s/^res\///;      $thisfn=~s/^res\///;
       $thisfn=~s/^priv\///;
     unless (($thisfn =~ /^ext/) || ($thisfn =~ /\.(page|sequence)___\d+___ext/)) {      unless (($thisfn =~ /^ext/) || ($thisfn =~ /\.(page|sequence)___\d+___ext/)) {
         $thisfn=~s/\?.+$//;          $thisfn=~s/\?.+$//;
     }      }
Line 11696  B<idput($udom,%ids)>: store away a list Line 11695  B<idput($udom,%ids)>: store away a list
   
 =item *  =item *
 X<rolesinit()>  X<rolesinit()>
 B<rolesinit($udom,$username,$authhost)>: get user privileges  B<rolesinit($udom,$username)>: get user privileges.
   returns user role, first access and timer interval hashes
   
   =item *
   X<privileged()>
   B<privileged($username,$domain)>: returns a true if user has a
   privileged and active role (i.e. su or dc), false otherwise.
   
 =item *  =item *
 X<getsection()>  X<getsection()>
Removed from v.1.1168  
changed lines
  Added in v.1.1176

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