[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.1082 and 1.1089

version 1.1082, 2010/08/20 18:17:04 version 1.1089, 2010/10/01 16:37:35
Line 727  sub userload { Line 727  sub userload {
 # ------------------------------ Find server with least workload from spare.tab  # ------------------------------ Find server with least workload from spare.tab
   
 sub spareserver {  sub spareserver {
     my ($loadpercent,$userloadpercent,$want_server_name) = @_;      my ($loadpercent,$userloadpercent,$want_server_name,$udom) = @_;
     my $spare_server;      my $spare_server;
     if ($userloadpercent !~ /\d/) { $userloadpercent=0; }      if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
     my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent       my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent 
                                                      :  $userloadpercent;                                                       :  $userloadpercent;
           my ($uint_dom,$remotesessions);
       if (($udom ne '') && (&domain($udom) ne '')) {
           my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
           $uint_dom = &Apache::lonnet::internet_dom($uprimary_id);
           my %udomdefaults = &Apache::lonnet::get_domain_defaults($udom);
           $remotesessions = $udomdefaults{'remotesessions'};
       }
     foreach my $try_server (@{ $spareid{'primary'} }) {      foreach my $try_server (@{ $spareid{'primary'} }) {
           if ($uint_dom) {
                next unless (&spare_can_host($udom,$uint_dom,$remotesessions,
                                             $try_server));
           }
  ($spare_server, $lowest_load) =   ($spare_server, $lowest_load) =
     &compare_server_load($try_server, $spare_server, $lowest_load);      &compare_server_load($try_server, $spare_server, $lowest_load);
     }      }
Line 742  sub spareserver { Line 752  sub spareserver {
   
     if (!$found_server) {      if (!$found_server) {
  foreach my $try_server (@{ $spareid{'default'} }) {   foreach my $try_server (@{ $spareid{'default'} }) {
               if ($uint_dom) {
                   next unless (&spare_can_host($udom,$uint_dom,$remotesessions,
                                                $try_server));
               }
     ($spare_server, $lowest_load) =      ($spare_server, $lowest_load) =
  &compare_server_load($try_server, $spare_server, $lowest_load);   &compare_server_load($try_server, $spare_server, $lowest_load);
  }   }
Line 754  sub spareserver { Line 768  sub spareserver {
         }          }
         if (defined($spare_server)) {          if (defined($spare_server)) {
             my $hostname = &hostname($spare_server);              my $hostname = &hostname($spare_server);
             if (defined($hostname)) {                if (defined($hostname)) {
         $spare_server = $protocol.'://'.$hostname;          $spare_server = $protocol.'://'.$hostname;
             }              }
         }          }
Line 990  sub can_host_session { Line 1004  sub can_host_session {
     return $canhost;      return $canhost;
 }  }
   
   sub spare_can_host {
       my ($udom,$uint_dom,$remotesessions,$try_server)=@_;
       my $canhost=1;
       my @intdoms;
       my $internet_names = &Apache::lonnet::get_internet_names($try_server);
       if (ref($internet_names) eq 'ARRAY') {
           @intdoms = @{$internet_names};
       }
       unless (grep(/^\Q$uint_dom\E$/,@intdoms)) {
           my $serverhomeID = &Apache::lonnet::get_server_homeID($try_server);
           my $serverhomedom = &Apache::lonnet::host_domain($serverhomeID);
           my %defdomdefaults = &Apache::lonnet::get_domain_defaults($serverhomedom);
           my $remoterev = &Apache::lonnet::get_server_loncaparev(undef,$try_server);
           $canhost = &can_host_session($udom,$try_server,$remoterev,
                                        $remotesessions,
                                        $defdomdefaults{'hostedsessions'});
       }
       return $canhost;
   }
   
 # ---------------------- Find the homebase for a user from domain's lib servers  # ---------------------- Find the homebase for a user from domain's lib servers
   
 my %homecache;  my %homecache;
Line 1699  sub getsection { Line 1733  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 %roleshash = &dump('roles',$udom,$unam,$courseid);      my $extra = &freeze_escape({'skipcheck' => 1});
       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 3001  sub get_my_roles { Line 3036  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') {
         %dumphash = &dump('roles',$udom,$uname);          my $extra = &freeze_escape({'skipcheck' => 1});
           %dumphash = &dump('roles',$udom,$uname,'.',undef,$extra);
     } else {      } else {
         %dumphash=          %dumphash=
             &dump('nohist_userroles',$udom,$uname);              &dump('nohist_userroles',$udom,$uname);
Line 3981  sub rolesinit { Line 4017  sub rolesinit {
     my ($domain,$username,$authhost)=@_;      my ($domain,$username,$authhost)=@_;
     my $now=time;      my $now=time;
     my %userroles = ('user.login.time' => $now);      my %userroles = ('user.login.time' => $now);
     my $extra = &freeze_escape({'clientcheckrole' => 1});      my $extra = &freeze_escape({'skipcheck' => 1});
     my $rolesdump=reply("dump:$domain:$username:roles:.::$extra",$authhost);      my $rolesdump=reply("dump:$domain:$username:roles:.::$extra",$authhost);
     if (($rolesdump eq 'con_lost') || ($rolesdump eq '') ||       if (($rolesdump eq 'con_lost') || ($rolesdump eq '') || 
         ($rolesdump =~ /^error:/)) {          ($rolesdump =~ /^error:/)) {
Line 4251  sub role_status { Line 4287  sub role_status {
 }  }
   
 sub check_adhoc_privs {  sub check_adhoc_privs {
     my ($cdom,$cnum,$then,$refresh,$now,$checkrole) = @_;      my ($cdom,$cnum,$then,$refresh,$now,$checkrole,$caller) = @_;
     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);              &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);
         }          }
     } else {      } else {
         &set_adhoc_privileges($cdom,$cnum,$checkrole);          &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);
     }      }
 }  }
   
 sub set_adhoc_privileges {  sub set_adhoc_privileges {
 # role can be cc or ca  # role can be cc or ca
     my ($dcdom,$pickedcourse,$role) = @_;      my ($dcdom,$pickedcourse,$role,$caller) = @_;
     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 4276  sub set_adhoc_privileges { Line 4312  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);
     &appenv( {'request.role'        => $spec,      unless ($caller eq 'constructaccess' && $env{'request.course.id'}) {
               'request.role.domain' => $dcdom,          &appenv( {'request.role'        => $spec,
               'request.course.sec'  => ''                    'request.role.domain' => $dcdom,
              }                    'request.course.sec'  => ''
            );                   }
     my $tadv=0;                 );
     if (&allowed('adv') eq 'F') { $tadv=1; }          my $tadv=0;
     &appenv({'request.role.adv'    => $tadv});          if (&allowed('adv') eq 'F') { $tadv=1; }
           &appenv({'request.role.adv'    => $tadv});
       }
 }  }
   
 # --------------------------------------------------------------- get interface  # --------------------------------------------------------------- get interface
Line 4332  sub del { Line 4370  sub del {
 # -------------------------------------------------------------- dump interface  # -------------------------------------------------------------- dump interface
   
 sub dump {  sub dump {
     my ($namespace,$udomain,$uname,$regexp,$range)=@_;      my ($namespace,$udomain,$uname,$regexp,$range,$extra)=@_;
     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 4341  sub dump { Line 4379  sub dump {
     } else {      } else {
  $regexp='.';   $regexp='.';
     }      }
     my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);      my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range:$extra",$uhome);
     my @pairs=split(/\&/,$rep);      my @pairs=split(/\&/,$rep);
     my %returnhash=();      my %returnhash=();
     foreach my $item (@pairs) {      foreach my $item (@pairs) {
Line 4886  sub is_portfolio_file { Line 4924  sub is_portfolio_file {
 }  }
   
 sub usertools_access {  sub usertools_access {
     my ($uname,$udom,$tool,$action,$context) = @_;      my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref)=@_;
     my ($access,%tools);      my ($access,%tools);
     if ($context eq '') {      if ($context eq '') {
         $context = 'tools';          $context = 'tools';
Line 4928  sub usertools_access { Line 4966  sub usertools_access {
         $toolstatus = $env{'environment.'.$context.'.'.$tool};          $toolstatus = $env{'environment.'.$context.'.'.$tool};
         $inststatus = $env{'environment.inststatus'};          $inststatus = $env{'environment.inststatus'};
     } else {      } else {
         my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool,'inststatus');          if (ref($userenvref) eq 'HASH') {
         $toolstatus = $userenv{$context.'.'.$tool};              $toolstatus = $userenvref->{$context.'.'.$tool};
         $inststatus = $userenv{'inststatus'};              $inststatus = $userenvref->{'inststatus'};
           } else {
               my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool,'inststatus');
               $toolstatus = $userenv{$context.'.'.$tool};
               $inststatus = $userenv{'inststatus'};
           }
     }      }
   
     if ($toolstatus ne '') {      if ($toolstatus ne '') {
Line 4942  sub usertools_access { Line 4985  sub usertools_access {
         return $access;          return $access;
     }      }
   
     my $is_adv = &is_advanced_user($udom,$uname);      my ($is_adv,%domdef);
     my %domdef = &get_domain_defaults($udom);      if (ref($is_advref) eq 'HASH') {
           $is_adv = $is_advref->{'is_adv'};
       } else {
           $is_adv = &is_advanced_user($udom,$uname);
       }
       if (ref($domdefref) eq 'HASH') {
           %domdef = %{$domdefref};
       } else {
           %domdef = &get_domain_defaults($udom);
       }
     if (ref($domdef{$tool}) eq 'HASH') {      if (ref($domdef{$tool}) eq 'HASH') {
         if ($is_adv) {          if ($is_adv) {
             if ($domdef{$tool}{'_LC_adv'} ne '') {              if ($domdef{$tool}{'_LC_adv'} ne '') {
Line 5017  sub is_course_owner { Line 5069  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 6302  sub get_users_groups { Line 6359  sub get_users_groups {
     } else {        } else {  
         $grouplist = '';          $grouplist = '';
         my $courseurl = &courseid_to_courseurl($courseid);          my $courseurl = &courseid_to_courseurl($courseid);
         my %roleshash = &dump('roles',$udom,$uname,$courseurl);          my $extra = &freeze_escape({'skipcheck' => 1});
           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 6805  sub modifyuser { Line 6863  sub modifyuser {
     if ($reply ne 'ok') {       if ($reply ne 'ok') { 
         return 'error: '.$reply;          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);      my $sqlresult = &update_allusers_table($uname,$udom,\%names);
     &devalidate_cache_new('namescache',$uname.':'.$udom);      &devalidate_cache_new('namescache',$uname.':'.$udom);
     $logmsg = 'Success modifying user '.$logmsg;      $logmsg = 'Success modifying user '.$logmsg;
Line 8348  sub metadata { Line 8409  sub metadata {
     if (($uri eq '') ||       if (($uri eq '') || 
  (($uri =~ m|^/*adm/|) &&    (($uri =~ m|^/*adm/|) && 
      ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||       ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||
         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) ) {          ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^\*uploaded\/.+\.sequence$/) ) {
  return undef;   return undef;
     }      }
     if (($uri =~ /^~/ || $uri =~ m{home/$match_username/public_html/})       if (($uri =~ /^~/ || $uri =~ m{home/$match_username/public_html/}) 
Removed from v.1.1082  
changed lines
  Added in v.1.1089

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