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:[email protected]>.
|
---|
126 |
|
---|
127 | =cut
|
---|
128 |
|
---|