[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.425 and 1.430

version 1.425, 2003/10/04 02:27:02 version 1.430, 2003/10/12 22:02:44
Line 86  use HTML::LCParser; Line 86  use HTML::LCParser;
 use Fcntl qw(:flock);  use Fcntl qw(:flock);
 use Apache::loncoursedata;  use Apache::loncoursedata;
 use Apache::lonlocal;  use Apache::lonlocal;
 use Storable qw(lock_store lock_nstore lock_retrieve);  use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw);
 use Time::HiRes();  use Time::HiRes();
 my $readit;  my $readit;
   
Line 586  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 596  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 850  sub getsection { Line 849  sub getsection {
 }  }
   
 sub devalidate_cache {  sub devalidate_cache {
     my ($cache,$id) = @_;      my ($cache,$id,$name) = @_;
     delete $$cache{$id.'.time'};      delete $$cache{$id.'.time'};
     delete $$cache{$id};      delete $$cache{$id};
       my $filename=$perlvar{'lonDaemons'}.'/tmp/'.$name.".db";
       open(DB,"$filename.lock");
       flock(DB,LOCK_EX);
       my %hash;
       if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {
    delete($hash{$id});
    delete($hash{$id.'.time'});
       } else {
    &logthis("Unable to tie hash");
       }
       untie(%hash);
       flock(DB,LOCK_UN);
       close(DB);
 }  }
   
 sub is_cached {  sub is_cached {
     my ($cache,$id,$name,$time) = @_;      my ($cache,$id,$name,$time) = @_;
     if (!$time) { $time=300; }      if (!$time) { $time=300; }
     if (!exists($$cache{$id.'.time'})) {      if (!exists($$cache{$id.'.time'})) {
  &load_cache($cache,$name);   &load_cache_item($cache,$name,$id);
     }      }
     if (!exists($$cache{$id.'.time'})) {      if (!exists($$cache{$id.'.time'})) {
 # &logthis("Didn't find $id");  # &logthis("Didn't find $id");
  return (undef,undef);   return (undef,undef);
     } else {      } else {
  if (time-($$cache{$id.'.time'})>$time) {   if (time-($$cache{$id.'.time'})>$time) {
 #    &logthis("Devailidating $id");  #    &logthis("Devailidating $id - ".time-($$cache{$id.'.time'}));
     &devalidate_cache($cache,$id);      &devalidate_cache($cache,$id,$name);
     return (undef,undef);      return (undef,undef);
  }   }
     }      }
Line 878  sub do_cache { Line 890  sub do_cache {
     my ($cache,$id,$value,$name) = @_;      my ($cache,$id,$value,$name) = @_;
     $$cache{$id.'.time'}=time;      $$cache{$id.'.time'}=time;
     $$cache{$id}=$value;      $$cache{$id}=$value;
     &save_cache($cache,$name);  #    &logthis("Caching $id as :$value:");
       &save_cache_item($cache,$name,$id);
     # do_cache implictly return the set value      # do_cache implictly return the set value
     $$cache{$id};      $$cache{$id};
 }  }
   
 sub save_cache {  sub save_cache {
     my ($cache,$name)=@_;      my ($cache,$name)=@_;
 #    my $starttime=&Time::HiRes::time();      my $starttime=&Time::HiRes::time();
 #    &logthis("Saving :$name:");  #    &logthis("Saving :$name:");
     eval lock_store($cache,$perlvar{'lonDaemons'}.'/tmp/'.$name.".storable");      eval lock_store($cache,$perlvar{'lonDaemons'}.'/tmp/'.$name.".storable");
     if ($@) { &logthis("lock_store threw a die ".$@); }      if ($@) { &logthis("lock_store threw a die ".$@); }
Line 894  sub save_cache { Line 907  sub save_cache {
   
 sub load_cache {  sub load_cache {
     my ($cache,$name)=@_;      my ($cache,$name)=@_;
 #    my $starttime=&Time::HiRes::time();      my $starttime=&Time::HiRes::time();
 #    &logthis("Before Loading $name size is ".scalar(%$cache));  #    &logthis("Before Loading $name size is ".scalar(%$cache));
     my $tmpcache;      my $tmpcache;
     eval {      eval {
Line 933  sub load_cache { Line 946  sub load_cache {
 #    &logthis("load_cache took ".(&Time::HiRes::time()-$starttime));  #    &logthis("load_cache took ".(&Time::HiRes::time()-$starttime));
 }  }
   
   sub save_cache_item {
       my ($cache,$name,$id)=@_;
       my $starttime=&Time::HiRes::time();
    #   &logthis("Saving :$name:$id");
       my %hash;
       my $filename=$perlvar{'lonDaemons'}.'/tmp/'.$name.".db";
       open(DB,"$filename.lock");
       flock(DB,LOCK_EX);
       if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {
    $hash{$id.'.time'}=$$cache{$id.'.time'};
    $hash{$id}=freeze({'item'=>$$cache{$id}});
       } else {
    &logthis("Unable to tie hash");
       }
       untie(%hash);
       flock(DB,LOCK_UN);
       close(DB);
   #    &logthis("save_cache_item $name took ".(&Time::HiRes::time()-$starttime));
   }
   
   sub load_cache_item {
       my ($cache,$name,$id)=@_;
       my $starttime=&Time::HiRes::time();
   #    &logthis("Before Loading $name  for $id size is ".scalar(%$cache));
       my %hash;
       my $filename=$perlvar{'lonDaemons'}.'/tmp/'.$name.".db";
       open(DB,"$filename.lock");
       flock(DB,LOCK_SH);
       if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) {
    if (!%$cache) {
       my $count;
       while (my ($key,$value)=each(%hash)) { 
    $count++;
    if ($key =~ /\.time$/) {
       $$cache{$key}=$value;
    } else {
       my $hashref=thaw($value);
       $$cache{$key}=$hashref->{'item'};
    }
       }
   #    &logthis("Initial load: $count");
    } else {
       my $hashref=thaw($hash{$id});
       $$cache{$id}=$hashref->{'item'};
       $$cache{$id.'.time'}=$hash{$id.'.time'};
    }
       } else {
    &logthis("Unable to tie hash");
       }
       untie(%hash);
       flock(DB,LOCK_UN);
       close(DB);
   #    &logthis("After Loading $name size is ".scalar(%$cache));
   #    &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime));
   }
   
 sub usection {  sub usection {
     my ($udom,$unam,$courseid)=@_;      my ($udom,$unam,$courseid)=@_;
     my $hashid="$udom:$unam:$courseid";      my $hashid="$udom:$unam:$courseid";
Line 2712  sub is_on_map { Line 2781  sub is_on_map {
     }      }
 }  }
   
   # --------------------------------------------------------- Get symb from alias
   
   sub get_symb_from_alias {
       my $symb=shift;
       my ($map,$resid,$url)=&decode_symb($symb);
   # Already is a symb
       if ($url) { return $symb; }
   # Must be an alias
       my $aliassymb='';
       my %bighash;
       if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
                               &GDBM_READER(),0640)) {
           my $rid=$bighash{'mapalias_'.$symb};
    if ($rid) {
       my ($mapid,$resid)=split(/\./,$rid);
       $aliassymb=&encode_symb($bighash{'map_id_'.$mapid},
       $resid,$bighash{'src_'.$rid});
    }
           untie %bighash;
       }
       return $aliassymb;
   }
   
 # ----------------------------------------------------------------- Define Role  # ----------------------------------------------------------------- Define Role
   
 sub definerole {  sub definerole {
Line 3366  sub condval { Line 3458  sub condval {
 sub devalidatecourseresdata {  sub devalidatecourseresdata {
     my ($coursenum,$coursedomain)=@_;      my ($coursenum,$coursedomain)=@_;
     my $hashid=$coursenum.':'.$coursedomain;      my $hashid=$coursenum.':'.$coursedomain;
     &devalidate_cache(\%courseresdatacache,$hashid);      &devalidate_cache(\%courseresdatacache,$hashid,'courseres');
 }  }
   
 # --------------------------------------------------- Course Resourcedata Query  # --------------------------------------------------- Course Resourcedata Query
Line 3430  sub EXT { Line 3522  sub EXT {
     #get real user name/domain, courseid and symb      #get real user name/domain, courseid and symb
     my $courseid;      my $courseid;
     my $publicuser;      my $publicuser;
       if ($symbparm) {
    $symbparm=&get_symb_from_alias($symbparm);
       }
     if (!($uname && $udom)) {      if (!($uname && $udom)) {
       (my $cursymb,$courseid,$udom,$uname,$publicuser)=        (my $cursymb,$courseid,$udom,$uname,$publicuser)=
   &Apache::lonxml::whichuser($symbparm);    &Apache::lonxml::whichuser($symbparm);
Line 3515  sub EXT { Line 3610  sub EXT {
    } elsif ($realm eq 'request') {     } elsif ($realm eq 'request') {
 # ------------------------------------------------------------- request.browser  # ------------------------------------------------------------- request.browser
         if ($space eq 'browser') {          if ($space eq 'browser') {
     return $ENV{'browser.'.$qualifier};      if ($qualifier eq 'textremote') {
    if (&mt('textual_remote_display') eq 'on') {
       return 1;
    } else {
       return 0;
    }
       } else {
    return $ENV{'browser.'.$qualifier};
       }
 # ------------------------------------------------------------ request.filename  # ------------------------------------------------------------ request.filename
         } else {          } else {
             return $ENV{'request.'.$spacequalifierrest};              return $ENV{'request.'.$spacequalifierrest};
Line 3707  sub metadata { Line 3810  sub metadata {
 # Look at timestamp of caching  # Look at timestamp of caching
 # Everything is cached by the main uri, libraries are never directly cached  # Everything is cached by the main uri, libraries are never directly cached
 #  #
     unless (abs($metacache{$uri.':cachedtimestamp'}-time)<600 && !defined($liburi)) {      if (!defined($liburi)) {
    my ($result,$cached)=&is_cached(\%metacache,$uri,'meta');
    if (defined($cached)) { return $result->{':'.$what}; }
       }
       {
 #  #
 # Is this a recursive call for a library?  # Is this a recursive call for a library?
 #  #
    my %lcmetacache;
         if ($liburi) {          if ($liburi) {
     $liburi=&declutter($liburi);      $liburi=&declutter($liburi);
             $filename=$liburi;              $filename=$liburi;
         } else {          } else {
     delete($metacache{$uri.':packages'});      &devalidate_cache(\%metacache,$uri,'meta');
  }   }
         my %metathesekeys=();          my %metathesekeys=();
         unless ($filename=~/\.meta$/) { $filename.='.meta'; }          unless ($filename=~/\.meta$/) { $filename.='.meta'; }
Line 3734  sub metadata { Line 3842  sub metadata {
     if (defined($token->[2]->{'id'})) {       if (defined($token->[2]->{'id'})) { 
  $keyroot.='_'.$token->[2]->{'id'};    $keyroot.='_'.$token->[2]->{'id'}; 
     }      }
     if ($metacache{$uri.':packages'}) {      if ($lcmetacache{':packages'}) {
  $metacache{$uri.':packages'}.=','.$package.$keyroot;   $lcmetacache{':packages'}.=','.$package.$keyroot;
     } else {      } else {
  $metacache{$uri.':packages'}=$package.$keyroot;   $lcmetacache{':packages'}=$package.$keyroot;
     }      }
     foreach (keys %packagetab) {      foreach (keys %packagetab) {
  if ($_=~/^$package\&/) {   if ($_=~/^$package\&/) {
Line 3752  sub metadata { Line 3860  sub metadata {
  $value.=' [Part: '.$part.']';   $value.=' [Part: '.$part.']';
     }      }
     my $unikey='parameter'.$keyroot.'_'.$name;      my $unikey='parameter'.$keyroot.'_'.$name;
     $metacache{$uri.':'.$unikey.'.part'}=$part;      $lcmetacache{':'.$unikey.'.part'}=$part;
     $metathesekeys{$unikey}=1;      $metathesekeys{$unikey}=1;
     unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) {      unless (defined($lcmetacache{':'.$unikey.'.'.$subp})) {
  $metacache{$uri.':'.$unikey.'.'.$subp}=$value;   $lcmetacache{':'.$unikey.'.'.$subp}=$value;
     }      }
     if (defined($metacache{$uri.':'.$unikey.'.default'})) {      if (defined($lcmetacache{':'.$unikey.'.default'})) {
  $metacache{$uri.':'.$unikey}=   $lcmetacache{':'.$unikey}=
     $metacache{$uri.':'.$unikey.'.default'};      $lcmetacache{':'.$unikey.'.default'};
     }      }
  }   }
     }      }
Line 3802  sub metadata { Line 3910  sub metadata {
  }   }
  $metathesekeys{$unikey}=1;   $metathesekeys{$unikey}=1;
  foreach (@{$token->[3]}) {   foreach (@{$token->[3]}) {
     $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};      $lcmetacache{':'.$unikey.'.'.$_}=$token->[2]->{$_};
  }   }
  my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));   my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));
  my $default=$metacache{$uri.':'.$unikey.'.default'};   my $default=$lcmetacache{':'.$unikey.'.default'};
  if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) {   if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) {
  # only ws inside the tag, and not in default, so use default   # only ws inside the tag, and not in default, so use default
  # as value   # as value
     $metacache{$uri.':'.$unikey}=$default;      $lcmetacache{':'.$unikey}=$default;
  } else {   } else {
   # either something interesting inside the tag or default    # either something interesting inside the tag or default
                   # uninteresting                    # uninteresting
     $metacache{$uri.':'.$unikey}=$internaltext;      $lcmetacache{':'.$unikey}=$internaltext;
  }   }
 # end of not-a-package not-a-library import  # end of not-a-package not-a-library import
     }      }
Line 3823  sub metadata { Line 3931  sub metadata {
     }      }
  }   }
 # are there custom rights to evaluate  # are there custom rights to evaluate
  if ($metacache{$uri.':copyright'} eq 'custom') {   if ($lcmetacache{':copyright'} eq 'custom') {
   
     #      #
     # Importing a rights file here      # Importing a rights file here
     #      #
     unless ($depthcount) {      unless ($depthcount) {
  my $location=$metacache{$uri.':customdistributionfile'};   my $location=$lcmetacache{':customdistributionfile'};
  my $dir=$filename;   my $dir=$filename;
  $dir=~s|[^/]*$||;   $dir=~s|[^/]*$||;
  $location=&filelocation($dir,$location);   $location=&filelocation($dir,$location);
Line 3840  sub metadata { Line 3948  sub metadata {
  }   }
     }      }
  }   }
  $metacache{$uri.':keys'}=join(',',keys %metathesekeys);   $lcmetacache{':keys'}=join(',',keys %metathesekeys);
  &metadata_generate_part0(\%metathesekeys,\%metacache,$uri);   &metadata_generate_part0(\%metathesekeys,\%lcmetacache,$uri);
  $metacache{$uri.':allpossiblekeys'}=join(',',keys %metathesekeys);   $lcmetacache{':allpossiblekeys'}=join(',',keys %metathesekeys);
  $metacache{$uri.':cachedtimestamp'}=time;   &do_cache(\%metacache,$uri,\%lcmetacache,'meta');
 # this is the end of "was not already recently cached  # this is the end of "was not already recently cached
     }      }
     return $metacache{$uri.':'.$what};      return $metacache{$uri}->{':'.$what};
 }  }
   
 sub metadata_generate_part0 {  sub metadata_generate_part0 {
Line 3854  sub metadata_generate_part0 { Line 3962  sub metadata_generate_part0 {
     my %allnames;      my %allnames;
     foreach my $metakey (sort keys %$metadata) {      foreach my $metakey (sort keys %$metadata) {
  if ($metakey=~/^parameter\_(.*)/) {   if ($metakey=~/^parameter\_(.*)/) {
   my $part=$$metacache{$uri.':'.$metakey.'.part'};    my $part=$$metacache{':'.$metakey.'.part'};
   my $name=$$metacache{$uri.':'.$metakey.'.name'};    my $name=$$metacache{':'.$metakey.'.name'};
   if (! exists($$metadata{'parameter_0_'.$name.'.name'})) {    if (! exists($$metadata{'parameter_0_'.$name.'.name'})) {
     $allnames{$name}=$part;      $allnames{$name}=$part;
   }    }
Line 3863  sub metadata_generate_part0 { Line 3971  sub metadata_generate_part0 {
     }      }
     foreach my $name (keys(%allnames)) {      foreach my $name (keys(%allnames)) {
       $$metadata{"parameter_0_$name"}=1;        $$metadata{"parameter_0_$name"}=1;
       my $key="$uri:parameter_0_$name";        my $key=":parameter_0_$name";
       $$metacache{"$key.part"}='0';        $$metacache{"$key.part"}='0';
       $$metacache{"$key.name"}=$name;        $$metacache{"$key.name"}=$name;
       $$metacache{"$key.type"}=$$metacache{$uri.':parameter_'.        $$metacache{"$key.type"}=$$metacache{':parameter_'.
    $allnames{$name}.'_'.$name.     $allnames{$name}.'_'.$name.
    '.type'};     '.type'};
       my $olddis=$$metacache{$uri.':parameter_'.$allnames{$name}.'_'.$name.        my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name.
      '.display'};       '.display'};
       my $expr='\\[Part: '.$allnames{$name}.'\\]';        my $expr='\\[Part: '.$allnames{$name}.'\\]';
       $olddis=~s/$expr/\[Part: 0\]/;        $olddis=~s/$expr/\[Part: 0\]/;
Line 3978  sub symbclean { Line 4086  sub symbclean {
   
 # ---------------------------------------------- Split symb to find map and url  # ---------------------------------------------- Split symb to find map and url
   
   sub encode_symb {
       my ($map,$resid,$url)=@_;
       return &symbclean(&declutter($map).'___'.$resid.'___'.&declutter($url));
   }
   
 sub decode_symb {  sub decode_symb {
     my ($map,$resid,$url)=split(/\_\_\_/,shift);      my ($map,$resid,$url)=split(/\_\_\_/,shift);
     return (&fixversion($map),$resid,&fixversion($url));      return (&fixversion($map),$resid,&fixversion($url));
Removed from v.1.425  
changed lines
  Added in v.1.430

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