home *** CD-ROM | disk | FTP | other *** search
/ PC World 2003 March / PCWorld_2003-03_cd.bin / Software / Topware / activeperl / ActivePerl / Perl / lib / Tie / Memoize.pm < prev    next >
Encoding:
Text File  |  2002-06-19  |  4.3 KB  |  129 lines
  1. use strict;
  2. package Tie::Memoize;
  3. use Tie::Hash;
  4. our @ISA = 'Tie::ExtraHash';
  5. our $VERSION = '1.0';
  6.  
  7. our $exists_token = \undef;
  8.  
  9. sub croak {require Carp; goto &Carp::croak}
  10.  
  11. # Format: [0: STORAGE, 1: EXISTS-CACHE, 2: FETCH_function;
  12. #       3: EXISTS_function, 4: DATA, 5: EXISTS_different ]
  13.  
  14. sub FETCH {
  15.   my ($h,$key) = ($_[0][0], $_[1]);
  16.   my $res = $h->{$key};
  17.   return $res if defined $res;    # Shortcut if accessible
  18.   return $res if exists $h->{$key}; # Accessible, but undef
  19.   my $cache = $_[0][1]{$key};
  20.   return if defined $cache and not $cache; # Known to not exist
  21.   my @res = $_[0][2]->($key, $_[0][4]);    # Autoload
  22.   $_[0][1]{$key} = 0, return unless @res; # Cache non-existence
  23.   delete $_[0][1]{$key};    # Clear existence cache, not needed any more
  24.   $_[0][0]{$key} = $res[0];    # Store data and return
  25. }
  26.  
  27. sub EXISTS   {
  28.   my ($a,$key) = (shift, shift);
  29.   return 1 if exists $a->[0]{$key}; # Have data
  30.   my $cache = $a->[1]{$key};
  31.   return $cache if defined $cache; # Existence cache
  32.   my @res = $a->[3]($key,$a->[4]);
  33.   $_[0][1]{$key} = 0, return unless @res; # Cache non-existence
  34.   # Now we know it exists
  35.   return ($_[0][1]{$key} = 1) if $a->[5]; # Only existence reported
  36.   # Now know the value
  37.   $_[0][0]{$key} = $res[0];    # Store data
  38.   return 1
  39. }
  40.  
  41. sub TIEHASH  {
  42.   croak 'syntax: tie %hash, \'Tie::AutoLoad\', \&fetch_subr' if @_ < 2;
  43.   croak 'syntax: tie %hash, \'Tie::AutoLoad\', \&fetch_subr, $data, \&exists_subr, \%data_cache, \%existence_cache' if @_ > 6;
  44.   push @_, undef if @_ < 3;    # Data
  45.   push @_, $_[1] if @_ < 4;    # exists
  46.   push @_, {} while @_ < 6;    # initial value and caches
  47.   bless [ @_[4,5,1,3,2], $_[1] ne $_[3]], $_[0]
  48. }
  49.  
  50. 1;
  51.  
  52. =head1 NAME
  53.  
  54. Tie::Memoize - add data to hash when needed
  55.  
  56. =head1 SYNOPSIS
  57.  
  58.   require Tie::Memoize;
  59.   tie %hash, 'Tie::Memoize',
  60.       \&fetch,            # The rest is optional
  61.       $DATA, \&exists,
  62.       {%ini_value}, {%ini_existence};
  63.  
  64. =head1 DESCRIPTION
  65.  
  66. This package allows a tied hash to autoload its values on the first access,
  67. and to use the cached value on the following accesses.
  68.  
  69. Only read-accesses (via fetching the value or C<exists>) result in calls to
  70. the functions; the modify-accesses are performed as on a normal hash.
  71.  
  72. The required arguments during C<tie> are the hash, the package, and
  73. the reference to the C<FETCH>ing function.  The optional arguments are
  74. an arbitrary scalar $data, the reference to the C<EXISTS> function,
  75. and initial values of the hash and of the existence cache.
  76.  
  77. Both the C<FETCH>ing function and the C<EXISTS> functions have the
  78. same signature: the arguments are C<$key, $data>; $data is the same
  79. value as given as argument during tie()ing.  Both functions should
  80. return an empty list if the value does not exist.  If C<EXISTS>
  81. function is different from the C<FETCH>ing function, it should return
  82. a TRUE value on success.  The C<FETCH>ing function should return the
  83. intended value if the key is valid.
  84.  
  85. =head1 Inheriting from B<Tie::Memoize>
  86.  
  87. The structure of the tied() data is an array reference with elements
  88.  
  89.   0:  cache of known values
  90.   1:  cache of known existence of keys
  91.   2:  FETCH  function
  92.   3:  EXISTS function
  93.   4:  $data
  94.  
  95. The rest is for internal usage of this package.  In particular, if
  96. TIEHASH is overwritten, it should call SUPER::TIEHASH.
  97.  
  98. =head1 EXAMPLE
  99.  
  100.   sub slurp {
  101.     my ($key, $dir) = shift;
  102.     open my $h, '<', "$dir/$key" or return;
  103.     local $/; <$h>            # slurp it all
  104.   }
  105.   sub exists { my ($key, $dir) = shift; return -f "$dir/$key" }
  106.  
  107.   tie %hash, 'Tie::Memoize', \&slurp, $directory, \&exists,
  108.       { fake_file1 => $content1, fake_file2 => $content2 },
  109.       { pretend_does_not_exists => 0, known_to_exist => 1 };
  110.  
  111. This example treats the slightly modified contents of $directory as a
  112. hash.  The modifications are that the keys F<fake_file1> and
  113. F<fake_file2> fetch values $content1 and $content2, and
  114. F<pretend_does_not_exists> will never be accessed.  Additionally, the
  115. existence of F<known_to_exist> is never checked (so if it does not
  116. exists when its content is needed, the user of %hash may be confused).
  117.  
  118. =head1 BUGS
  119.  
  120. FIRSTKEY and NEXTKEY methods go through the keys which were already read,
  121. not all the possible keys of the hash.
  122.  
  123. =head1 AUTHOR
  124.  
  125. Ilya Zakharevich L<mailto:perl-module-hash-memoize@ilyaz.org>.
  126.  
  127. =cut
  128.  
  129.