| 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 | |