[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.1172.2.4

version 1.1168, 2012/05/18 15:31:40 version 1.1172.2.4, 2012/05/30 16:57:06
Line 97  use File::MMagic; Line 97  use File::MMagic;
 use LONCAPA qw(:DEFAULT :match);  use LONCAPA qw(:DEFAULT :match);
 use LONCAPA::Configuration;  use LONCAPA::Configuration;
 use LONCAPA::lonmetadata;  use LONCAPA::lonmetadata;
 use LONCAPA::Lond;  
   
 use File::Copy;  use File::Copy;
   
Line 1237  sub check_loadbalancing { Line 1236  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 1263  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 1379  sub check_loadbalancing { Line 1378  sub check_loadbalancing {
             }              }
         }          }
     }      }
       if (($otherserver ne '') && (grep(/^\Q$otherserver\E$/,@hosts))) {
           $is_balancer = 0;
       }
     return ($is_balancer,$otherserver);      return ($is_balancer,$otherserver);
 }  }
   
 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 2572  sub ssi {
     }      }
   
     $request->header(Cookie => $ENV{'HTTP_COOKIE'});      $request->header(Cookie => $ENV{'HTTP_COOKIE'});
     my $response=$ua->request($request);      my $response= $ua->request($request);
   
     if (wantarray) {      if (wantarray) {
  return ($response->content, $response);   return ($response->content, $response);
     } else {      } else {
Line 3490  sub statslog { Line 3493  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 3962  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 4606  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 10763  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 11682  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.1172.2.4

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