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

version 1.1172.2.9, 2012/08/27 15:03:52 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 97  use File::MMagic; Line 99  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 108  require Exporter; Line 111  require Exporter;
 our @ISA = qw (Exporter);  our @ISA = qw (Exporter);
 our @EXPORT = qw(%env);  our @EXPORT = qw(%env);
   
 # ------------------------------------ Logging (parameters, docs, slots, roles)  
   # --------------------------------------------------------------------- Logging
 {  {
     my $logid;      my $logid;
     sub write_log {      sub instructor_log {
  my ($context,$hash_name,$storehash,$delflag,$uname,$udom,$cnum,$cdom)=@_;   my ($hash_name,$storehash,$delflag,$uname,$udom,$cnum,$cdom)=@_;
         if ($context eq 'course') {          if (($cnum eq '') || ($cdom eq '')) {
             if (($cnum eq '') || ($cdom eq '')) {              $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
                 $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};              $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
                 $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};  
             }  
         }          }
  $logid++;   $logid++;
         my $now = time();          my $now = time();
  my $id=$now.'00000'.$$.'00000'.$logid;   my $id=$now.'00000'.$$.'00000'.$logid;
         my $logentry = {   return &Apache::lonnet::put('nohist_'.$hash_name,
                          $id => {      { $id => {
                                   'exe_uname' => $env{'user.name'},   'exe_uname' => $env{'user.name'},
                                   'exe_udom'  => $env{'user.domain'},   'exe_udom'  => $env{'user.domain'},
                                   'exe_time'  => $now,   'exe_time'  => $now,
                                   'exe_ip'    => $ENV{'REMOTE_ADDR'},   'exe_ip'    => $ENV{'REMOTE_ADDR'},
                                   'delflag'   => $delflag,   'delflag'   => $delflag,
                                   'logentry'  => $storehash,   'logentry'  => $storehash,
                                   'uname'     => $uname,   'uname'     => $uname,
                                   'udom'      => $udom,   'udom'      => $udom,
                                 }      }
                        };    },$cdom,$cnum);
         return &put('nohist_'.$hash_name,$logentry,$cdom,$cnum);  
     }      }
 }  }
   
Line 1385  sub check_loadbalancing { Line 1386  sub check_loadbalancing {
             $is_balancer = 0;              $is_balancer = 0;
             if ($uname ne '' && $udom ne '') {              if ($uname ne '' && $udom ne '') {
                 if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {                  if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {
                       
                     &appenv({'user.loadbalexempt'     => $lonhost,                      &appenv({'user.loadbalexempt'     => $lonhost,  
                              'user.loadbalcheck.time' => time});                               'user.loadbalcheck.time' => time});
                 }                  }
             }              }
Line 1418  sub get_loadbalancer_targets { Line 1419  sub get_loadbalancer_targets {
                     }                      }
                 }                  }
             } else {              } else {
                 my %servers = &internet_dom_servers($udom);                  my %servers = &dom_servers($udom);
                 my ($remotebalancer,$remotetargets) = &get_lonbalancer_config(\%servers);                  my ($remotebalancer,$remotetargets) = &get_lonbalancer_config(\%servers);
                 if (&hostname($remotebalancer) ne '') {                  if (&hostname($remotebalancer) ne '') {
                     $offloadto = [$remotebalancer];                      $offloadto = [$remotebalancer];
Line 1937  sub get_domain_defaults { Line 1938  sub get_domain_defaults {
     my %domconfig =      my %domconfig =
          &Apache::lonnet::get_dom('configuration',['defaults','quotas',           &Apache::lonnet::get_dom('configuration',['defaults','quotas',
                                   'requestcourses','inststatus',                                    'requestcourses','inststatus',
                                   'coursedefaults','usersessions',                                    'coursedefaults','usersessions'],$domain);
                                   'requestauthor'],$domain);  
     if (ref($domconfig{'defaults'}) eq 'HASH') {      if (ref($domconfig{'defaults'}) eq 'HASH') {
         $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};           $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; 
         $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};          $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};
Line 1957  sub get_domain_defaults { Line 1957  sub get_domain_defaults {
         } else {          } else {
             $domdefaults{'defaultquota'} = $domconfig{'quotas'};              $domdefaults{'defaultquota'} = $domconfig{'quotas'};
         }           } 
         my @usertools = ('aboutme','blog','webdav','portfolio');          my @usertools = ('aboutme','blog','portfolio');
         foreach my $item (@usertools) {          foreach my $item (@usertools) {
             if (ref($domconfig{'quotas'}{$item}) eq 'HASH') {              if (ref($domconfig{'quotas'}{$item}) eq 'HASH') {
                 $domdefaults{$item} = $domconfig{'quotas'}{$item};                  $domdefaults{$item} = $domconfig{'quotas'}{$item};
Line 1969  sub get_domain_defaults { Line 1969  sub get_domain_defaults {
             $domdefaults{$item} = $domconfig{'requestcourses'}{$item};              $domdefaults{$item} = $domconfig{'requestcourses'}{$item};
         }          }
     }      }
     if (ref($domconfig{'requestauthor'}) eq 'HASH') {  
         $domdefaults{'requestauthor'} = $domconfig{'requestauthor'};  
     }  
     if (ref($domconfig{'inststatus'}) eq 'HASH') {      if (ref($domconfig{'inststatus'}) eq 'HASH') {
         foreach my $item ('inststatustypes','inststatusorder') {          foreach my $item ('inststatustypes','inststatusorder') {
             $domdefaults{$item} = $domconfig{'inststatus'}{$item};              $domdefaults{$item} = $domconfig{'inststatus'}{$item};
Line 2588  sub ssi { Line 2585  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 3529  sub userrolelog { Line 3527  sub userrolelog {
   
 sub courserolelog {  sub courserolelog {
     my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,$context)=@_;      my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,$context)=@_;
     if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) {      if (($trole eq 'cc') || ($trole eq 'in') ||
         my $cdom = $1;          ($trole eq 'ep') || ($trole eq 'ad') ||
         my $cnum = $2;          ($trole eq 'ta') || ($trole eq 'st') ||
         my $sec = $3;          ($trole=~/^cr/) || ($trole eq 'gr') ||
         my $namespace = 'rolelog';          ($trole eq 'co')) {
         my %storehash = (          if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) {
                            role    => $trole,              my $cdom = $1;
                            start   => $tstart,              my $cnum = $2;
                            end     => $tend,              my $sec = $3;
                            selfenroll => $selfenroll,              my $namespace = 'rolelog';
                            context    => $context,              my %storehash = (
                         );                                 role    => $trole,
         if ($trole eq 'gr') {                                 start   => $tstart,
             $namespace = 'groupslog';                                 end     => $tend,
             $storehash{'group'} = $sec;                                 selfenroll => $selfenroll,
         } else {                                 context    => $context,
             $storehash{'section'} = $sec;                              );
         }              if ($trole eq 'gr') {
         &write_log('course',$namespace,\%storehash,$delflag,$username,                  $namespace = 'groupslog';
                    $domain,$cnum,$cdom);                  $storehash{'group'} = $sec;
         if (($trole ne 'st') || ($sec ne '')) {              } else {
             &devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum);                  $storehash{'section'} = $sec;
               }
               &instructor_log($namespace,\%storehash,$delflag,$username,$domain,$cnum,$cdom);
               if (($trole ne 'st') || ($sec ne '')) {
                   &devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum);
               }
         }          }
     }      }
     return;      return;
 }  }
   
 sub domainrolelog {  
     my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_;  
     if ($area =~ m{^/($match_domain)/$}) {  
         my $cdom = $1;  
         my $domconfiguser = &Apache::lonnet::get_domainconfiguser($cdom);  
         my $namespace = 'rolelog';  
         my %storehash = (  
                            role    => $trole,  
                            start   => $tstart,  
                            end     => $tend,  
                            context => $context,  
                         );  
         &write_log('domain',$namespace,\%storehash,$delflag,$username,  
                    $domain,$domconfiguser,$cdom);  
     }  
     return;  
   
 }  
   
 sub coauthorrolelog {  
     my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_;  
     if ($area =~ m{^/($match_domain)/($match_username)$}) {  
         my $audom = $1;  
         my $auname = $2;  
         my $namespace = 'rolelog';  
         my %storehash = (  
                            role    => $trole,  
                            start   => $tstart,  
                            end     => $tend,  
                            context => $context,  
                         );  
         &write_log('author',$namespace,\%storehash,$delflag,$username,  
                    $domain,$auname,$audom);  
     }  
     return;  
 }  
   
 sub get_course_adv_roles {  sub get_course_adv_roles {
     my ($cid,$codes) = @_;      my ($cid,$codes) = @_;
     $cid=$env{'request.course.id'} unless (defined($cid));      $cid=$env{'request.course.id'} unless (defined($cid));
Line 3705  sub get_my_roles { Line 3671  sub get_my_roles {
         }          }
         my ($rolecode,$username,$domain,$section,$area);          my ($rolecode,$username,$domain,$section,$area);
         if ($context eq 'userroles') {          if ($context eq 'userroles') {
             ($area,$rolecode) = ($entry =~ /^(.+)_([^_]+)$/);              ($area,$rolecode) = split(/_/,$entry);
             (undef,$domain,$username,$section) = split(/\//,$area);              (undef,$domain,$username,$section) = split(/\//,$area);
         } else {          } else {
             ($role,$username,$domain,$section) = split(/\:/,$entry);              ($role,$username,$domain,$section) = split(/\:/,$entry);
Line 5027  sub delete_env_groupprivs { Line 4993  sub delete_env_groupprivs {
 sub check_adhoc_privs {  sub check_adhoc_privs {
     my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller) = @_;      my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller) = @_;
     my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;      my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;
     my $setprivs;  
     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,$update,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);          &role_status($cckey,$update,$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,$caller);
             $setprivs = 1;  
         }          }
     } else {      } else {
         &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);          &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);
         $setprivs = 1;  
     }      }
     return $setprivs;  
 }  }
   
 sub set_adhoc_privileges {  sub set_adhoc_privileges {
Line 5681  sub usertools_access { Line 5643  sub usertools_access {
                       unofficial => 1,                        unofficial => 1,
                       community  => 1,                        community  => 1,
                  );                   );
     } elsif ($context eq 'requestauthor') {  
         %tools = (  
                       requestauthor => 1,  
                  );  
     } else {      } else {
         %tools = (          %tools = (
                       aboutme   => 1,                        aboutme   => 1,
                       blog      => 1,                        blog      => 1,
                       webdav    => 1,  
                       portfolio => 1,                        portfolio => 1,
                  );                   );
     }      }
Line 5704  sub usertools_access { Line 5661  sub usertools_access {
         if ($action ne 'reload') {          if ($action ne 'reload') {
             if ($context eq 'requestcourses') {              if ($context eq 'requestcourses') {
                 return $env{'environment.canrequest.'.$tool};                  return $env{'environment.canrequest.'.$tool};
             } elsif ($context eq 'requestauthor') {  
                 return $env{'environment.canrequest.author'};  
             } else {              } else {
                 return $env{'environment.availabletools.'.$tool};                  return $env{'environment.availabletools.'.$tool};
             }              }
         }          }
     }      }
   
     my ($toolstatus,$inststatus,$envkey);      my ($toolstatus,$inststatus);
     if ($context eq 'requestauthor') {  
         $envkey = $context;  
     } else {  
         $envkey = $context.'.'.$tool;  
     }  
   
     if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) &&      if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) &&
          ($action ne 'reload')) {           ($action ne 'reload')) {
         $toolstatus = $env{'environment.'.$envkey};          $toolstatus = $env{'environment.'.$context.'.'.$tool};
         $inststatus = $env{'environment.inststatus'};          $inststatus = $env{'environment.inststatus'};
     } else {      } else {
         if (ref($userenvref) eq 'HASH') {          if (ref($userenvref) eq 'HASH') {
             $toolstatus = $userenvref->{$envkey};              $toolstatus = $userenvref->{$context.'.'.$tool};
             $inststatus = $userenvref->{'inststatus'};              $inststatus = $userenvref->{'inststatus'};
         } else {          } else {
             my %userenv = &userenvironment($udom,$uname,$envkey,'inststatus');              my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool,'inststatus');
             $toolstatus = $userenv{$envkey};              $toolstatus = $userenv{$context.'.'.$tool};
             $inststatus = $userenv{'inststatus'};              $inststatus = $userenv{'inststatus'};
         }          }
     }      }
Line 5795  sub usertools_access { Line 5745  sub usertools_access {
             }              }
         }          }
     } else {      } else {
         if (($context eq 'tools') && ($tool ne 'webdav')) {          if ($context eq 'tools') {
             $access = 1;              $access = 1;
         } else {          } else {
             $access = 0;              $access = 0;
Line 7516  sub assignrole { Line 7466  sub assignrole {
                             }                              }
                         }                          }
                     }                      }
                 } elsif ($context eq 'requestauthor') {  
                     if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) &&  
                         ($url eq '/'.$udom.'/') && ($role eq 'au')) {  
                         if ($env{'environment.requestauthor'} eq 'automatic') {  
                             $refused = '';  
                         } else {  
                             my %domdefaults = &get_domain_defaults($udom);  
                             if (ref($domdefaults{'requestauthor'}) eq 'HASH') {  
                                 my $checkbystatus;  
                                 if ($env{'user.adv'}) {  
                                     my $disposition = $domdefaults{'requestauthor'}{'_LC_adv'};  
                                     if ($disposition eq 'automatic') {  
                                         $refused = '';  
                                     } elsif ($disposition eq '') {  
                                         $checkbystatus = 1;  
                                     }  
                                 } else {  
                                     $checkbystatus = 1;  
                                 }  
                                 if ($checkbystatus) {  
                                     if ($env{'environment.inststatus'}) {  
                                         my @inststatuses = split(/,/,$env{'environment.inststatus'});  
                                         foreach my $type (@inststatuses) {  
                                             if (($type ne '') &&  
                                                 ($domdefaults{'requestauthor'}{$type} eq 'automatic')) {  
                                                 $refused = '';  
                                             }  
                                         }  
                                     } elsif ($domdefaults{'requestauthor'}{'default'} eq 'automatic') {  
                                         $refused = '';  
                                     }  
                                 }  
                             }  
                         }  
                     }  
                 }                  }
                 if ($refused) {                  if ($refused) {
                     &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.                      &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.
Line 7601  sub assignrole { Line 7516  sub assignrole {
     if ($answer eq 'ok') {      if ($answer eq 'ok') {
  &userrolelog($role,$uname,$udom,$url,$start,$end);   &userrolelog($role,$uname,$udom,$url,$start,$end);
 # for course roles, perform group memberships changes triggered by role change.  # for course roles, perform group memberships changes triggered by role change.
           &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,$selfenroll,$context);
         unless ($role =~ /^gr/) {          unless ($role =~ /^gr/) {
             &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,              &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,
                                              $origstart,$selfenroll,$context);                                               $origstart,$selfenroll,$context);
         }          }
         if (($role eq 'cc') || ($role eq 'in') ||  
             ($role eq 'ep') || ($role eq 'ad') ||  
             ($role eq 'ta') || ($role eq 'st') ||  
             ($role=~/^cr/) || ($role eq 'gr') ||  
             ($role eq 'co')) {  
             &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,  
                            $selfenroll,$context);  
         } elsif (($role eq 'li') || ($role eq 'dg') || ($role eq 'sc') ||  
                  ($role eq 'au') || ($role eq 'dc')) {  
             &domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,  
                            $context);  
         } elsif (($role eq 'ca') || ($role eq 'aa')) {  
             &coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,  
                              $context);  
         }  
         if ($role eq 'cc') {          if ($role eq 'cc') {
             &autoupdate_coowners($url,$end,$start,$uname,$udom);              &autoupdate_coowners($url,$end,$start,$uname,$udom);
         }          }
Line 9914  sub devalidate_slots_cache { Line 9815  sub devalidate_slots_cache {
     &devalidate_cache_new('allslots',$hashid);      &devalidate_cache_new('allslots',$hashid);
 }  }
   
 sub get_coursechange {  
     my ($cdom,$cnum) = @_;  
     if ($cdom eq '' || $cnum eq '') {  
         return unless ($env{'request.course.id'});  
         $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};  
         $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};  
     }  
     my $hashid=$cdom.'_'.$cnum;  
     my ($change,$cached)=&is_cached_new('crschange',$hashid);  
     if ((defined($cached)) && ($change ne '')) {  
         return $change;  
     } else {  
         my %crshash;  
         %crshash = &get('environment',['internal.contentchange'],$cdom,$cnum);  
         if ($crshash{'internal.contentchange'} eq '') {  
             $change = $env{'course.'.$cdom.'_'.$cnum.'.internal.created'};  
             if ($change eq '') {  
                 %crshash = &get('environment',['internal.created'],$cdom,$cnum);  
                 $change = $crshash{'internal.created'};  
             }  
         } else {  
             $change = $crshash{'internal.contentchange'};  
         }  
         my $cachetime = 600;  
         &do_cache_new('crschange',$hashid,$change,$cachetime);  
     }  
     return $change;  
 }  
   
 sub devalidate_coursechange_cache {  
     my ($cnum,$cdom)=@_;  
     my $hashid=$cnum.':'.$cdom;  
     &devalidate_cache_new('crschange',$hashid);  
 }  
   
 # ------------------------------------------------- Update symbolic store links  # ------------------------------------------------- Update symbolic store links
   
 sub symblist {  sub symblist {
Line 10093  sub deversion { Line 9959  sub deversion {
 sub symbread {  sub symbread {
     my ($thisfn,$donotrecurse)=@_;      my ($thisfn,$donotrecurse)=@_;
     my $cache_str='request.symbread.cached.'.$thisfn;      my $cache_str='request.symbread.cached.'.$thisfn;
     if (defined($env{$cache_str})) {      if (defined($env{$cache_str})) { return $env{$cache_str}; }
         if (($thisfn) || ($env{$cache_str} ne '')) {  
             return $env{$cache_str};  
         }  
     }  
 # no filename provided? try from environment  # no filename provided? try from environment
     unless ($thisfn) {      unless ($thisfn) {
         if ($env{'request.symb'}) {          if ($env{'request.symb'}) {
Removed from v.1.1172.2.9  
changed lines
  Added in v.1.1176

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