[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.410 and 1.426

version 1.410, 2003/09/10 15:53:16 version 1.426, 2003/10/04 02:34:01
Line 76  qw(%perlvar %hostname %homecache %badSer Line 76  qw(%perlvar %hostname %homecache %badSer
    %libserv %pr %prp %metacache %packagetab %titlecache      %libserv %pr %prp %metacache %packagetab %titlecache 
    %courselogs %accesshash %userrolehash $processmarker $dumpcount      %courselogs %accesshash %userrolehash $processmarker $dumpcount 
    %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache      %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache 
    %domaindescription %domain_auth_def %domain_auth_arg_def      %userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def 
    %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir);     %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir);
   
 use IO::Socket;  use IO::Socket;
Line 85  use Apache::Constants qw(:common :http); Line 85  use Apache::Constants qw(:common :http);
 use HTML::LCParser;  use HTML::LCParser;
 use Fcntl qw(:flock);  use Fcntl qw(:flock);
 use Apache::loncoursedata;  use Apache::loncoursedata;
   use Apache::lonlocal;
   use Storable qw(lock_store lock_nstore lock_retrieve);
   use Time::HiRes();
 my $readit;  my $readit;
   
 # --------------------------------------------------------------------- Logging  # --------------------------------------------------------------------- Logging
Line 246  sub critical { Line 248  sub critical {
     return $answer;      return $answer;
 }  }
   
   #
 # -------------- Remove all key from the env that start witha lowercase letter  # -------------- Remove all key from the env that start witha lowercase letter
 #                (Which is alweways a lon-capa value)  #                (Which is always a lon-capa value)
   
 sub cleanenv {  sub cleanenv {
   #    unless (defined(&Apache::exists_config_define("MODPERL2"))) { return; }
   #    unless (&Apache::exists_config_define("MODPERL2")) { return; }
     foreach my $key (keys(%ENV)) {      foreach my $key (keys(%ENV)) {
  if ($key =~ /^[a-z]/) {   if ($key =~ /^[a-z]/) {
     delete($ENV{$key});      delete($ENV{$key});
Line 436  sub spareserver { Line 442  sub spareserver {
     my $lowestserver=$loadpercent > $userloadpercent?      my $lowestserver=$loadpercent > $userloadpercent?
              $loadpercent :  $userloadpercent;               $loadpercent :  $userloadpercent;
     foreach $tryserver (keys %spareid) {      foreach $tryserver (keys %spareid) {
        my $loadans=reply('load',$tryserver);   my $loadans=reply('load',$tryserver);
        my $userloadans=reply('userload',$tryserver);   my $userloadans=reply('userload',$tryserver);
        if ($userloadans !~ /\d/) { $userloadans=0; }   if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
        my $answer=$loadans > $userloadans?      next; #didn't get a number from the server
                   $loadans :  $userloadans;   }
        if (($answer =~ /\d/) && ($answer<$lowestserver)) {   my $answer;
    $spareserver="http://$hostname{$tryserver}";   if ($loadans =~ /\d/) {
            $lowestserver=$answer;      if ($userloadans =~ /\d/) {
        }   #both are numbers, pick the bigger one
    $answer=$loadans > $userloadans?
       $loadans :  $userloadans;
       } else {
    $answer = $loadans;
       }
    } else {
       $answer = $userloadans;
    }
    if (($answer =~ /\d/) && ($answer<$lowestserver)) {
       $spareserver="http://$hostname{$tryserver}";
       $lowestserver=$answer;
    }
     }      }
     return $spareserver;      return $spareserver;
 }  }
Line 568  sub authenticate { Line 586  sub authenticate {
 sub homeserver {  sub homeserver {
     my ($uname,$udom,$ignoreBadCache)=@_;      my ($uname,$udom,$ignoreBadCache)=@_;
     my $index="$uname:$udom";      my $index="$uname:$udom";
     if ($homecache{$index}) {   
         return "$homecache{$index}";       my ($result,$cached)=&is_cached(\%homecache,$index,'home',86400);
     }      if (defined($cached)) { return $result; }
     my $tryserver;      my $tryserver;
     foreach $tryserver (keys %libserv) {      foreach $tryserver (keys %libserv) {
         next if ($ignoreBadCache ne 'true' &&           next if ($ignoreBadCache ne 'true' && 
Line 578  sub homeserver { Line 596  sub homeserver {
  if ($hostdom{$tryserver} eq $udom) {   if ($hostdom{$tryserver} eq $udom) {
            my $answer=reply("home:$udom:$uname",$tryserver);             my $answer=reply("home:$udom:$uname",$tryserver);
            if ($answer eq 'found') {              if ($answer eq 'found') { 
               $homecache{$index}=$tryserver;         return &do_cache(\%homecache,$index,$tryserver,'home');
               return $tryserver;   
            } elsif ($answer eq 'no_host') {             } elsif ($answer eq 'no_host') {
        $badServerCache{$tryserver}=1;         $badServerCache{$tryserver}=1;
            }             }
Line 831  sub getsection { Line 848  sub getsection {
     return '-1';      return '-1';
 }  }
   
   sub devalidate_cache {
       my ($cache,$id) = @_;
       delete $$cache{$id.'.time'};
       delete $$cache{$id};
   }
   
   sub is_cached {
       my ($cache,$id,$name,$time) = @_;
       if (!$time) { $time=300; }
       if (!exists($$cache{$id.'.time'})) {
    &load_cache($cache,$name);
       }
       if (!exists($$cache{$id.'.time'})) {
   # &logthis("Didn't find $id");
    return (undef,undef);
       } else {
    if (time-($$cache{$id.'.time'})>$time) {
   #    &logthis("Devailidating $id");
       &devalidate_cache($cache,$id);
       return (undef,undef);
    }
       }
       return ($$cache{$id},1);
   }
   
   sub do_cache {
       my ($cache,$id,$value,$name) = @_;
       $$cache{$id.'.time'}=time;
       $$cache{$id}=$value;
       &save_cache($cache,$name);
       # do_cache implictly return the set value
       $$cache{$id};
   }
   
   sub save_cache {
       my ($cache,$name)=@_;
   #    my $starttime=&Time::HiRes::time();
   #    &logthis("Saving :$name:");
       eval lock_store($cache,$perlvar{'lonDaemons'}.'/tmp/'.$name.".storable");
       if ($@) { &logthis("lock_store threw a die ".$@); }
   #    &logthis("save_cache took ".(&Time::HiRes::time()-$starttime));
   }
   
   sub load_cache {
       my ($cache,$name)=@_;
   #    my $starttime=&Time::HiRes::time();
   #    &logthis("Before Loading $name size is ".scalar(%$cache));
       my $tmpcache;
       eval {
    $tmpcache=lock_retrieve($perlvar{'lonDaemons'}.'/tmp/'.$name.".storable");
       };
       if ($@) { &logthis("lock_retreive threw a die ".$@); return; }
       if (!%$cache) {
    my $count;
    while (my ($key,$value)=each(%$tmpcache)) { 
       $count++;
       $$cache{$key}=$value;
    }
   # &logthis("Initial load: $count");
       } else {
    my $key;
    my $count;
    while ($key=each(%$tmpcache)) {
       if ($key !~/^(.*)\.time$/) { next; }
       my $name=$1;
       if (exists($$cache{$key})) {
    if ($$tmpcache{$key} >= $$cache{$key}) {
       $$cache{$key}=$$tmpcache{$key};
       $$cache{$name}=$$tmpcache{$name};
    } else {
   #    &logthis("Would have overwritten $name with is set to expire at ".$$cache{$key}." with ".$$tmpcache{$key}." Whew!");
    }
       } else {
    $count++;
    $$cache{$key}=$$tmpcache{$key};
    $$cache{$name}=$$tmpcache{$name};
       }
    }
   # &logthis("Additional load: $count");
       }
   #    &logthis("After Loading $name size is ".scalar(%$cache));
   #    &logthis("load_cache took ".(&Time::HiRes::time()-$starttime));
   }
   
 sub usection {  sub usection {
     my ($udom,$unam,$courseid)=@_;      my ($udom,$unam,$courseid)=@_;
       my $hashid="$udom:$unam:$courseid";
       
       my ($result,$cached)=&is_cached(\%usectioncache,$hashid,'usection');
       if (defined($cached)) { return $result; }
     $courseid=~s/\_/\//g;      $courseid=~s/\_/\//g;
     $courseid=~s/^(\w)/\/$1/;      $courseid=~s/^(\w)/\/$1/;
     foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',      foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',
Line 851  sub usection { Line 956  sub usection {
             if ($end) {              if ($end) {
                 if ($now>$end) { $notactive=1; }                  if ($now>$end) { $notactive=1; }
             }               } 
             unless ($notactive) { return $section; }              unless ($notactive) {
    return &do_cache(\%usectioncache,$hashid,$section,'usection');
       }
         }          }
     }      }
     return '-1';      return &do_cache(\%usectioncache,$hashid,'-1','usection');
 }  }
   
 # ------------------------------------- Read an entry from a user's environment  # ------------------------------------- Read an entry from a user's environment
Line 2170  sub currentdump { Line 2277  sub currentdump {
        return if ($tmp[0] =~ /^(error:|no_such_host)/);         return if ($tmp[0] =~ /^(error:|no_such_host)/);
        my %hash = @tmp;         my %hash = @tmp;
        @tmp=();         @tmp=();
        # Code ripped from lond, essentially.  The only difference         %returnhash = %{&convert_dump_to_currentdump(\%hash)};
        # here is the unescaping done by lonnet::dump().  Conceivably  
        # we might run in to problems with parameter names =~ /^v\./  
        while (my ($key,$value) = each(%hash)) {  
            my ($v,$symb,$param) = split(/:/,$key);  
            next if ($v eq 'version' || $symb eq 'keys');  
            next if (exists($returnhash{$symb}) &&  
                     exists($returnhash{$symb}->{$param}) &&  
                     $returnhash{$symb}->{'v.'.$param} > $v);  
            $returnhash{$symb}->{$param}=$value;  
            $returnhash{$symb}->{'v.'.$param}=$v;  
        }  
        #  
        # Remove all of the keys in the hashes which keep track of  
        # the version of the parameter.  
        while (my ($symb,$param_hash) = each(%returnhash)) {  
            # use a foreach because we are going to delete from the hash.  
            foreach my $key (keys(%$param_hash)) {  
                delete($param_hash->{$key}) if ($key =~ /^v\./);  
            }  
        }  
    } else {     } else {
        my @pairs=split(/\&/,$rep);         my @pairs=split(/\&/,$rep);
        foreach (@pairs) {         foreach (@pairs) {
Line 2203  sub currentdump { Line 2290  sub currentdump {
    return %returnhash;     return %returnhash;
 }  }
   
   sub convert_dump_to_currentdump{
       my %hash = %{shift()};
       my %returnhash;
       # Code ripped from lond, essentially.  The only difference
       # here is the unescaping done by lonnet::dump().  Conceivably
       # we might run in to problems with parameter names =~ /^v\./
       while (my ($key,$value) = each(%hash)) {
           my ($v,$symb,$param) = split(/:/,$key);
           next if ($v eq 'version' || $symb eq 'keys');
           next if (exists($returnhash{$symb}) &&
                    exists($returnhash{$symb}->{$param}) &&
                    $returnhash{$symb}->{'v.'.$param} > $v);
           $returnhash{$symb}->{$param}=$value;
           $returnhash{$symb}->{'v.'.$param}=$v;
       }
       #
       # Remove all of the keys in the hashes which keep track of
       # the version of the parameter.
       while (my ($symb,$param_hash) = each(%returnhash)) {
           # use a foreach because we are going to delete from the hash.
           foreach my $key (keys(%$param_hash)) {
               delete($param_hash->{$key}) if ($key =~ /^v\./);
           }
       }
       return \%returnhash;
   }
   
 # --------------------------------------------------------------- put interface  # --------------------------------------------------------------- put interface
   
 sub put {  sub put {
Line 2590  sub is_on_map { Line 2704  sub is_on_map {
     if ($match) {      if ($match) {
  return (1,$1);   return (1,$1);
     } else {      } else {
  return (0,0);   my ($name,$ext)=($filename=~/^(.+)\.(\w+)$/);
           $ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
          /\&(\Q$name\E\.\d+\.$ext)\:([\d\|]+)\&/;
    return (0,$2,$pathname.'/'.$1);
     }      }
 }  }
   
Line 2720  sub userlog_query { Line 2837  sub userlog_query {
   
 sub plaintext {  sub plaintext {
     my $short=shift;      my $short=shift;
     return $prp{$short};      return &mt($prp{$short});
 }  }
   
 # ----------------------------------------------------------------- Assign Role  # ----------------------------------------------------------------- Assign Role
Line 3248  sub condval { Line 3365  sub condval {
 sub devalidatecourseresdata {  sub devalidatecourseresdata {
     my ($coursenum,$coursedomain)=@_;      my ($coursenum,$coursedomain)=@_;
     my $hashid=$coursenum.':'.$coursedomain;      my $hashid=$coursenum.':'.$coursedomain;
     delete $courseresdatacache{$hashid.'.time'};      &devalidate_cache(\%courseresdatacache,$hashid);
 }  }
   
 # --------------------------------------------------- Course Resourcedata Query  # --------------------------------------------------- Course Resourcedata Query
Line 3257  sub courseresdata { Line 3374  sub courseresdata {
     my ($coursenum,$coursedomain,@which)=@_;      my ($coursenum,$coursedomain,@which)=@_;
     my $coursehom=&homeserver($coursenum,$coursedomain);      my $coursehom=&homeserver($coursenum,$coursedomain);
     my $hashid=$coursenum.':'.$coursedomain;      my $hashid=$coursenum.':'.$coursedomain;
     my $dodump=0;      my ($result,$cached)=&is_cached(\%courseresdatacache,$hashid,'courseres');
     if (!defined($courseresdatacache{$hashid.'.time'})) {      unless (defined($cached)) {
  $dodump=1;  
     } else {  
  if (time-$courseresdatacache{$hashid.'.time'}>300) { $dodump=1; }  
     }  
     if ($dodump) {  
  my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum);   my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum);
    $result=\%dumpreply;
  my ($tmp) = keys(%dumpreply);   my ($tmp) = keys(%dumpreply);
  if ($tmp !~ /^(con_lost|error|no_such_host)/i) {   if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
     $courseresdatacache{$hashid.'.time'}=time;      &do_cache(\%courseresdatacache,$hashid,$result,'courseres');
     $courseresdatacache{$hashid}=\%dumpreply;  
  } elsif ($tmp =~ /^(con_lost|no_such_host)/) {   } elsif ($tmp =~ /^(con_lost|no_such_host)/) {
     return $tmp;      return $tmp;
    } elsif ($tmp =~ /^(error)/) {
       $result=undef;
       &do_cache(\%courseresdatacache,$hashid,$result,'courseres');
  }   }
     }      }
     foreach my $item (@which) {      foreach my $item (@which) {
  if (defined($courseresdatacache{$hashid}->{$item})) {   if (defined($result->{$item})) {
     return $courseresdatacache{$hashid}->{$item};      return $result->{$item};
  }   }
     }      }
     return undef;      return undef;
Line 3443  sub EXT { Line 3558  sub EXT {
   
 # ----------------------------------------------------------- first, check user  # ----------------------------------------------------------- first, check user
     #most student don\'t have any data set, check if there is some data      #most student don\'t have any data set, check if there is some data
             #every thirty minutes  
     if (! &EXT_cache_status($udom,$uname)) {      if (! &EXT_cache_status($udom,$uname)) {
  my %resourcedata=&get('resourcedata',   my $hashid="$udom:$uname";
       [$courselevelr,$courselevelm,$courselevel],   my ($result,$cached)=&is_cached(\%userresdatacache,$hashid,
       $udom,$uname);   'userres');
  my ($tmp)=keys(%resourcedata);   if (!defined($cached)) { 
       my %resourcedata=&get('resourcedata',
     [$courselevelr,$courselevelm,
      $courselevel],$udom,$uname);
       $result=\%resourcedata;
       &do_cache(\%userresdatacache,$hashid,$result,'userres');
    }
    my ($tmp)=keys(%$result);
  if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {   if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {
     if ($resourcedata{$courselevelr}) {      if ($$result{$courselevelr}) {
  return $resourcedata{$courselevelr}; }   return $$result{$courselevelr}; }
     if ($resourcedata{$courselevelm}) {      if ($$result{$courselevelm}) {
  return $resourcedata{$courselevelm}; }   return $$result{$courselevelm}; }
     if ($resourcedata{$courselevel}) {      if ($$result{$courselevel}) {
  return $resourcedata{$courselevel}; }   return $$result{$courselevel}; }
  } else {   } else {
     if ($tmp!~/No such file/) {      if ($tmp!~/No such file/) {
  &logthis("<font color=blue>WARNING:".   &logthis("<font color=blue>WARNING:".
Line 3571  sub add_prefix_and_part { Line 3692  sub add_prefix_and_part {
   
 sub metadata {  sub metadata {
     my ($uri,$what,$liburi,$prefix,$depthcount)=@_;      my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
   
     $uri=&declutter($uri);      $uri=&declutter($uri);
     # if it is a non metadata possible uri return quickly      # if it is a non metadata possible uri return quickly
     if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|)) ||      if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|)) ||
         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|)) {          ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||
    ($uri =~ m|home/[^/]+/public_html/|)) {
  return '';   return '';
     }      }
     my $filename=$uri;      my $filename=$uri;
Line 3764  sub gettitle { Line 3885  sub gettitle {
  unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; }   unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; }
         return &metadata($urlsymb,'title');           return &metadata($urlsymb,'title'); 
     }      }
     if ($titlecache{$symb}) {      my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600);
  if (time < ($titlecache{$symb}[1] + 600)) {      if (defined($cached)) { return $result; }
     return $titlecache{$symb}[0];  
  } else {  
     delete($titlecache{$symb});  
  }  
     }  
     my ($map,$resid,$url)=&decode_symb($symb);      my ($map,$resid,$url)=&decode_symb($symb);
     my $title='';      my $title='';
     my %bighash;      my %bighash;
Line 3782  sub gettitle { Line 3898  sub gettitle {
     }      }
     $title=~s/\&colon\;/\:/gs;      $title=~s/\&colon\;/\:/gs;
     if ($title) {      if ($title) {
         $titlecache{$symb}=[$title,time];          return &do_cache(\%titlecache,$symb,$title,'title');
         return $title;  
     } else {      } else {
  return &metadata($urlsymb,'title');   return &metadata($urlsymb,'title');
     }      }
Line 3863  sub symbclean { Line 3978  sub symbclean {
 # ---------------------------------------------- Split symb to find map and url  # ---------------------------------------------- Split symb to find map and url
   
 sub decode_symb {  sub decode_symb {
     return split(/\_\_\_/,shift);      my ($map,$resid,$url)=split(/\_\_\_/,shift);
       return (&fixversion($map),$resid,&fixversion($url));
   }
   
   sub fixversion {
       my $fn=shift;
       if ($fn=~/^(adm|uploaded|public)/) { return $fn; }
       my ($match,$cond,$versioned)=&is_on_map($fn);
       unless ($match) {
    $fn=$versioned;
       }
       return $fn;
 }  }
   
 # ------------------------------------------------------ Return symb list entry  # ------------------------------------------------------ Return symb list entry
Line 4165  sub unescape { Line 4291  sub unescape {
     return $str;      return $str;
 }  }
   
   sub mod_perl_version {
       if (defined($perlvar{'MODPERL2'})) {
    return 2;
       }
       return 1;
   }
 # ================================================================ Main Program  # ================================================================ Main Program
   
 sub goodbye {  sub goodbye {
    &logthis("Starting Shut down");     &logthis("Starting Shut down");
   #not converted to using infrastruture
      &logthis(sprintf("%-20s is %s",'%homecache',scalar(%homecache)));
      &logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache)));
      &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));
   #converted
      &logthis(sprintf("%-20s is %s",'%titlecache',scalar(%titlecache)));
      &logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache)));
   #1.1 only
      &logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache)));
      &logthis(sprintf("%-20s is %s",'%usectioncache',scalar(%usectioncache)));
    &flushcourselogs();     &flushcourselogs();
    &logthis("Shutting down");     &logthis("Shutting down");
    return DONE;     return DONE;
Removed from v.1.410  
changed lines
  Added in v.1.426

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