Commit | Line | Data |
---|---|---|
17e638fe IZ |
1 | use strict; |
2 | package Tie::Memoize; | |
3 | use Tie::Hash; | |
4 | our @ISA = 'Tie::ExtraHash'; | |
78e0e8f4 | 5 | our $VERSION = '1.0'; |
17e638fe IZ |
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 | ||
bce51722 | 54 | Tie::Memoize - add data to hash when needed |
17e638fe IZ |
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 |