[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.426 and 1.433

version 1.426, 2003/10/04 02:34:01 version 1.433, 2003/10/27 21:59:34
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 274  sub transfer_profile_to_env { Line 274  sub transfer_profile_to_env {
  $idf->close();   $idf->close();
     }      }
     my $envi;      my $envi;
       my %Remove;
     for ($envi=0;$envi<=$#profile;$envi++) {      for ($envi=0;$envi<=$#profile;$envi++) {
  chomp($profile[$envi]);   chomp($profile[$envi]);
  my ($envname,$envvalue)=split(/=/,$profile[$envi]);   my ($envname,$envvalue)=split(/=/,$profile[$envi]);
  $ENV{$envname} = $envvalue;   $ENV{$envname} = $envvalue;
           if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
               if ($time < time-300) {
                   $Remove{$key}++;
               }
           }
       }
       foreach my $expired_key (keys(%Remove)) {
           &delenv($expired_key);
     }      }
     $ENV{'user.environment'} = "$lonidsdir/$handle.id";      $ENV{'user.environment'} = "$lonidsdir/$handle.id";
 }  }
Line 849  sub getsection { Line 858  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 877  sub do_cache { Line 899  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 893  sub save_cache { Line 916  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 932  sub load_cache { Line 955  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 2711  sub is_on_map { Line 2790  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 3365  sub condval { Line 3467  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 3429  sub EXT { Line 3531  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 3514  sub EXT { Line 3619  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 3706  sub metadata { Line 3819  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 3733  sub metadata { Line 3851  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\&/) {   my $part=$keyroot;
    $part=~s/^\_//;
    if ($_=~/^\Q$package\E\&/ || 
       $_=~/^\Q$package\E_0\&/) {
     my ($pack,$name,$subp)=split(/\&/,$_);      my ($pack,$name,$subp)=split(/\&/,$_);
     # ignore package.tab specified default values      # ignore package.tab specified default values
                             # here &package_tab_default() will fetch those                              # here &package_tab_default() will fetch those
     if ($subp eq 'default') { next; }      if ($subp eq 'default') { next; }
     my $value=$packagetab{$_};      my $value=$packagetab{$_};
     my $part=$keyroot;      my $unikey;
     $part=~s/^\_//;      if ($pack =~ /_0$/) {
    $unikey='parameter_0_'.$name;
    $part=0;
       } else {
    $unikey='parameter'.$keyroot.'_'.$name;
       }
     if ($subp eq 'display') {      if ($subp eq 'display') {
  $value.=' [Part: '.$part.']';   $value.=' [Part: '.$part.']';
     }      }
     my $unikey='parameter'.$keyroot.'_'.$name;      $lcmetacache{':'.$unikey.'.part'}=$part;
     $metacache{$uri.':'.$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 3801  sub metadata { Line 3926  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 3822  sub metadata { Line 3947  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 3839  sub metadata { Line 3964  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 3853  sub metadata_generate_part0 { Line 3978  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 3862  sub metadata_generate_part0 { Line 3987  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 3928  sub symblist { Line 4053  sub symblist {
   
 sub symbverify {  sub symbverify {
     my ($symb,$thisfn)=@_;      my ($symb,$thisfn)=@_;
     $thisfn=&declutter($thisfn);      $thisfn=&symbclean(&declutter($thisfn));
 # direct jump to resource in page or to a sequence - will construct own symbs  # direct jump to resource in page or to a sequence - will construct own symbs
     if ($thisfn=~/\.(page|sequence)$/) { return 1; }      if ($thisfn=~/\.(page|sequence)$/) { return 1; }
 # check URL part  # check URL part
     my ($map,$resid,$url)=&decode_symb($symb);      my ($map,$resid,$url)=&decode_symb($symb);
     unless (&symbclean($url) eq &symbclean($thisfn)) { return 0; }      unless ($url eq $thisfn) { return 0; }
   
     $symb=&symbclean($symb);      $symb=&symbclean($symb);
   
     my %bighash;      my %bighash;
     my $okay=0;      my $okay=0;
   
     if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',      if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
                             &GDBM_READER(),0640)) {                              &GDBM_READER(),0640)) {
         my $ids=$bighash{'ids_'.&clutter($thisfn)};          my $ids=$bighash{'ids_'.&clutter($thisfn)};
Line 3977  sub symbclean { Line 4103  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.426  
changed lines
  Added in v.1.433

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