[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.921 and 1.925

version 1.921, 2007/10/06 04:32:40 version 1.925, 2007/11/17 02:41:17
Line 513  sub get_env_multiple { Line 513  sub get_env_multiple {
 }  }
   
 # ------------------------------------------ Find out current server userload  # ------------------------------------------ Find out current server userload
 # there is a copy in lond  
 sub userload {  sub userload {
     my $numusers=0;      my $numusers=0;
     {      {
Line 521  sub userload { Line 520  sub userload {
  my $filename;   my $filename;
  my $curtime=time;   my $curtime=time;
  while ($filename=readdir(LONIDS)) {   while ($filename=readdir(LONIDS)) {
     if ($filename eq '.' || $filename eq '..') {next;}      next if ($filename eq '.' || $filename eq '..');
       next if ($filename =~ /publicuser_\d+\.id/);
     my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];      my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
     if ($curtime-$mtime < 1800) { $numusers++; }      if ($curtime-$mtime < 1800) { $numusers++; }
  }   }
Line 1047  sub get_instuser { Line 1047  sub get_instuser {
 }  }
   
 sub inst_rulecheck {  sub inst_rulecheck {
     my ($udom,$uname,$rules) = @_;      my ($udom,$uname,$id,$item,$rules) = @_;
     my %returnhash;      my %returnhash;
     if ($udom ne '') {      if ($udom ne '') {
         if (ref($rules) eq 'ARRAY') {          if (ref($rules) eq 'ARRAY') {
Line 1055  sub inst_rulecheck { Line 1055  sub inst_rulecheck {
             my $rulestr = join(':',@{$rules});              my $rulestr = join(':',@{$rules});
             my $homeserver=&domain($udom,'primary');              my $homeserver=&domain($udom,'primary');
             if (($homeserver ne '') && ($homeserver ne 'no_host')) {              if (($homeserver ne '') && ($homeserver ne 'no_host')) {
                 my $response=&unescape(&reply('instrulecheck:'.&escape($udom).':'.                  my $response;
                                               &escape($uname).':'.$rulestr,                  if ($item eq 'username') {                
                       $response=&unescape(&reply('instrulecheck:'.&escape($udom).
                                                 ':'.&escape($uname).':'.$rulestr,
                                               $homeserver));                                                $homeserver));
                   } elsif ($item eq 'id') {
                       $response=&unescape(&reply('instidrulecheck:'.&escape($udom).
                                                 ':'.&escape($id).':'.$rulestr,
                                                 $homeserver));
                   }
                 if ($response ne 'refused') {                  if ($response ne 'refused') {
                     my @pairs=split(/\&/,$response);                      my @pairs=split(/\&/,$response);
                     foreach my $item (@pairs) {                      foreach my $item (@pairs) {
Line 1074  sub inst_rulecheck { Line 1081  sub inst_rulecheck {
 }  }
   
 sub inst_userrules {  sub inst_userrules {
     my ($udom) = @_;      my ($udom,$check) = @_;
     my (%ruleshash,@ruleorder);      my (%ruleshash,@ruleorder);
     if ($udom ne '') {      if ($udom ne '') {
         my $homeserver=&domain($udom,'primary');          my $homeserver=&domain($udom,'primary');
         if (($homeserver ne '') && ($homeserver ne 'no_host')) {          if (($homeserver ne '') && ($homeserver ne 'no_host')) {
             my $response=&reply('instuserrules:'.&escape($udom),              my $response;
               if ($check eq 'id') {
                   $response=&reply('instidrules:'.&escape($udom),
                                  $homeserver);                                   $homeserver);
               } else {
                   $response=&reply('instuserrules:'.&escape($udom),
                                    $homeserver);
               }
             if (($response ne 'refused') && ($response ne 'error') &&               if (($response ne 'refused') && ($response ne 'error') && 
                   ($response ne 'unknown_cmd') && 
                 ($response ne 'no_such_host')) {                  ($response ne 'no_such_host')) {
                 my ($hashitems,$orderitems) = split(/:/,$response);                  my ($hashitems,$orderitems) = split(/:/,$response);
                 my @pairs=split(/\&/,$hashitems);                  my @pairs=split(/\&/,$hashitems);
Line 2463  sub get_my_roles { Line 2477  sub get_my_roles {
         }          }
         if (ref($roles) eq 'ARRAY') {          if (ref($roles) eq 'ARRAY') {
             if (!grep(/^\Q$role\E$/,@{$roles})) {              if (!grep(/^\Q$role\E$/,@{$roles})) {
                 next;                  if ($role =~ /^cr\//) {
                       if (!grep(/^cr$/,@{$roles})) {
                           next;
                       }
                   } else {
                       next;
                   }
             }              }
         }          }
  $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;   $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
Line 2621  sub get_domain_roles { Line 2641  sub get_domain_roles {
     if (undef($enddate) || $enddate eq '') {      if (undef($enddate) || $enddate eq '') {
         $enddate = '.';          $enddate = '.';
     }      }
     my $rolelist = join(':',@{$roles});      my $rolelist;
       if (ref($roles) eq 'ARRAY') {
           $rolelist = join(':',@{$roles});
       }
     my %personnel = ();      my %personnel = ();
   
     my %servers = &get_servers($dom,'library');      my %servers = &get_servers($dom,'library');
Line 6778  sub metadata { Line 6801  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 =~ /^~/) ||          ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) ) {
  ($uri =~ m|home/$match_username/public_html/|)) {   return undef;
       }
       if (($uri =~ /^~/ || $uri =~ m{home/$match_username/public_html/}) 
    && &Apache::lonxml::get_state('target') =~ /^(|meta)$/) {
  return undef;   return undef;
     }      }
     my $filename=$uri;      my $filename=$uri;
Line 6800  sub metadata { Line 6826  sub metadata {
 # if (! exists($metacache{$uri})) {  # if (! exists($metacache{$uri})) {
 #    $metacache{$uri}={};  #    $metacache{$uri}={};
 # }  # }
    my $cachetime = 60*60;
         if ($liburi) {          if ($liburi) {
     $liburi=&declutter($liburi);      $liburi=&declutter($liburi);
             $filename=$liburi;              $filename=$liburi;
Line 6810  sub metadata { Line 6837  sub metadata {
         my %metathesekeys=();          my %metathesekeys=();
         unless ($filename=~/\.meta$/) { $filename.='.meta'; }          unless ($filename=~/\.meta$/) { $filename.='.meta'; }
  my $metastring;   my $metastring;
  if ($uri !~ m -^(editupload)/-) {   if ($uri =~ /^~/ || $uri =~ m{home/$match_username/public_html/}) {
       $metastring = 
    &Apache::lonnet::ssi_body(&hreflocation('','/'.$uri),
     ('grade_target' => 'meta'));
       $cachetime = 1; # only want this cached in the child not long term
    } elsif ($uri !~ m -^(editupload)/-) {
     my $file=&filelocation('',&clutter($filename));      my $file=&filelocation('',&clutter($filename));
     #push(@{$metaentry{$uri.'.file'}},$file);      #push(@{$metaentry{$uri.'.file'}},$file);
     $metastring=&getfile($file);      $metastring=&getfile($file);
Line 6977  sub metadata { Line 7009  sub metadata {
  $metaentry{':keys'} = join(',',keys(%metathesekeys));   $metaentry{':keys'} = join(',',keys(%metathesekeys));
  &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);   &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
  $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);   $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
  &do_cache_new('meta',$uri,\%metaentry,60*60);   &do_cache_new('meta',$uri,\%metaentry,$cachetime);
 # this is the end of "was not already recently cached  # this is the end of "was not already recently cached
     }      }
     return $metaentry{':'.$what};      return $metaentry{':'.$what};
Removed from v.1.921  
changed lines
  Added in v.1.925

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