File Coverage

blib/lib/Memoize.pm
Criterion Covered Total %
statement 142 150 94.6
branch 70 80 87.5
condition 22 27 81.4
subroutine 21 22 95.4
pod 2 3 66.6
total 257 282 91.1


line stmt bran cond sub pod time code
1             # -*- mode: perl; perl-indent-level: 2; -*-
2             # vim: ts=8 sw=2 sts=2 noexpandtab
3              
4             # Memoize.pm
5             #
6             # Copyright 1998, 1999, 2000, 2001, 2012 M. J. Dominus.
7             # You may copy and distribute this program under the
8             # same terms as Perl itself.
9              
10 16     16   73768 use strict; use warnings;
  16     16   123  
  16         391  
  16         68  
  16         24  
  16         646  
11              
12             package Memoize;
13             our $VERSION = '1.15';
14              
15 16     16   71 use Carp;
  16         27  
  16         1611  
16 16     16   94 use Scalar::Util 1.11 (); # for set_prototype
  16         534  
  16         858  
17              
18 16     16   78 BEGIN { require Exporter; *import = \&Exporter::import }
  16         8588  
19             our @EXPORT = qw(memoize);
20             our @EXPORT_OK = qw(unmemoize flush_cache);
21              
22             my %memotable;
23              
24             sub CLONE {
25 0     0   0 my @info = values %memotable;
26 0         0 %memotable = map +($_->{WRAPPER} => $_), @info;
27             }
28              
29             sub memoize {
30 72     72 0 497989 my $fn = shift;
31 72         207 my %options = @_;
32              
33 72 100 100     433 unless (defined($fn) &&
      66        
34             (ref $fn eq 'CODE' || ref $fn eq '')) {
35 3         268 croak "Usage: memoize 'functionname'|coderef {OPTIONS}";
36             }
37              
38 69         171 my $uppack = caller; # TCL me Elmo!
39 69 100       148 my $name = (ref $fn ? undef : $fn);
40 69         146 my $cref = _make_cref($fn, $uppack);
41              
42 68         115 my $normalizer = $options{NORMALIZER};
43 68 100 100     218 if (defined $normalizer && ! ref $normalizer) {
44 5         8 $normalizer = _make_cref($normalizer, $uppack);
45             }
46              
47             my $install_name = exists $options{INSTALL}
48             ? $options{INSTALL} # use given name (or, if undef: do not install)
49 68 100       140 : $name; # no INSTALL option provided: default to original name if possible
50              
51 68 100       130 if (defined $install_name) {
52 41 100       148 $install_name = $uppack . '::' . $install_name
53             unless $install_name =~ /::/;
54             }
55              
56             # convert LIST_CACHE => MERGE to SCALAR_CACHE => MERGE
57             # to ensure TIE/HASH will always be checked by _check_suitable
58 68 100 100     229 if (($options{LIST_CACHE} || '') eq 'MERGE') {
59 6         12 $options{LIST_CACHE} = $options{SCALAR_CACHE};
60 6         12 $options{SCALAR_CACHE} = 'MERGE';
61             }
62              
63             # These will be the caches
64 68         93 my %caches;
65 68         131 for my $context (qw(LIST SCALAR)) { # SCALAR_CACHE must be last, to process MERGE
66 128   100     379 my $fullopt = $options{"${context}_CACHE"} ||= 'MEMORY';
67 128 100       309 my ($cache_opt, @cache_opt_args) = ref $fullopt ? @$fullopt : $fullopt;
68 128 100 100     376 if ($cache_opt eq 'FAULT') { # no cache
    100          
    100          
    100          
    100          
69 18         46 $caches{$context} = undef;
70             } elsif ($cache_opt eq 'HASH') { # user-supplied hash
71 18         29 my $cache = $cache_opt_args[0];
72 18         66 _check_suitable($context, ref tied %$cache);
73 16         49 $caches{$context} = $cache;
74             } elsif ($cache_opt eq 'TIE') {
75 8 100       619 carp("TIE option to memoize() is deprecated; use HASH instead")
76             if warnings::enabled('all');
77 8   50     107 my $module = shift(@cache_opt_args) || '';
78 8         25 _check_suitable($context, $module);
79 5         13 my $hash = $caches{$context} = {};
80 5         22 (my $modulefile = $module . '.pm') =~ s{::}{/}g;
81 5         317 require $modulefile;
82 4 50       78 tie(%$hash, $module, @cache_opt_args)
83             or croak "Couldn't tie memoize hash to `$module': $!";
84             } elsif ($cache_opt eq 'MEMORY') {
85 72         199 $caches{$context} = {};
86             } elsif ($cache_opt eq 'MERGE' and not ref $fullopt) { # ['MERGE'] was never supported
87 8 50       18 die "cannot MERGE $context\_CACHE" if $context ne 'SCALAR'; # should never happen
88 8 50       16 die 'bad cache setup order' if not exists $caches{LIST}; # should never happen
89 8         11 $options{MERGED} = 1;
90 8         19 $caches{SCALAR} = $caches{LIST};
91             } else {
92 4         343 croak "Unrecognized option to `${context}_CACHE': `$cache_opt' should be one of (MERGE TIE MEMORY FAULT HASH)";
93             }
94             }
95              
96 58         202 my $wrapper = _wrap($install_name, $cref, $normalizer, $options{MERGED}, \%caches);
97              
98 58 100       221 if (defined $install_name) {
99 16     16   103 no strict;
  16         24  
  16         444  
100 16     16   110 no warnings 'redefine';
  16         38  
  16         6194  
101 41         57 *{$install_name} = $wrapper;
  41         167  
102             }
103              
104             $memotable{$wrapper} = {
105             L => $caches{LIST},
106             S => $caches{SCALAR},
107 58         313 U => $cref,
108             NAME => $install_name,
109             WRAPPER => $wrapper,
110             };
111              
112 58         208 $wrapper # Return just memoized version
113             }
114              
115             sub flush_cache {
116 2     2 1 6 my $func = _make_cref($_[0], scalar caller);
117 2         5 my $info = $memotable{$func};
118 2 50       4 die "$func not memoized" unless defined $info;
119 2         5 for my $context (qw(S L)) {
120 4         5 my $cache = $info->{$context};
121 4 50 33     10 if (tied %$cache && ! (tied %$cache)->can('CLEAR')) {
122 0 0       0 my $funcname = defined($info->{NAME}) ?
123             "function $info->{NAME}" : "anonymous function $func";
124 0         0 my $context = {S => 'scalar', L => 'list'}->{$context};
125 0         0 croak "Tied cache hash for $context-context $funcname does not support flushing";
126             } else {
127 4         9 %$cache = ();
128             }
129             }
130             }
131              
132             sub _wrap {
133 58     58   195 my ($name, $orig, $normalizer, $merged, $caches) = @_;
134 58         133 my ($cache_L, $cache_S) = @$caches{qw(LIST SCALAR)};
135 58         81 undef $caches; # keep the pad from keeping the hash alive forever
136             Scalar::Util::set_prototype(sub {
137 325     325   23034728 my $argstr = do {
138 16     16   102 no warnings 'uninitialized';
  16         28  
  16         1944  
139 325 100       903 defined $normalizer
    100          
140             ? ( wantarray ? ( &$normalizer )[0] : &$normalizer )
141             . '' # coerce undef to string while the warning is off
142             : join chr(28), @_;
143             };
144              
145 325 100       1435 if (wantarray) {
146 48 100       108 _crap_out($name, 'list') unless $cache_L;
147             exists $cache_L->{$argstr} ? (
148 19         75 @{$cache_L->{$argstr}}
149 44 100       73 ) : do {
150 16     16   101 my @q = do { no warnings 'recursion'; &$orig };
  16         33  
  16         1475  
  25         30  
  25         53  
151 25         110 $cache_L->{$argstr} = \@q;
152 25         199 @q;
153             };
154             } else {
155 277 100       594 _crap_out($name, 'scalar') unless $cache_S;
156             exists $cache_S->{$argstr} ? (
157             $merged ? $cache_S->{$argstr}[0] : $cache_S->{$argstr}
158 273 100       994 ) : do {
    100          
159 16     16   103 my $val = do { no warnings 'recursion'; &$orig };
  16         32  
  16         2865  
  164         275  
  164         328  
160 164 100       558 $cache_S->{$argstr} = $merged ? [$val] : $val;
161 164         364 $val;
162             };
163             }
164 58         616 }, prototype $orig);
165             }
166              
167             sub unmemoize {
168 23     23 1 3517 my $f = shift;
169 23         38 my $uppack = caller;
170 23         48 my $cref = _make_cref($f, $uppack);
171              
172 23 100       65 unless (exists $memotable{$cref}) {
173 2         230 croak "Could not unmemoize function `$f', because it was not memoized to begin with";
174             }
175              
176 21         36 my $tabent = $memotable{$cref};
177 21 50       44 unless (defined $tabent) {
178 0         0 croak "Could not figure out how to unmemoize function `$f'";
179             }
180 21         32 my $name = $tabent->{NAME};
181 21 100       46 if (defined $name) {
182 16     16   132 no strict;
  16         39  
  16         443  
183 16     16   84 no warnings 'redefine';
  16         38  
  16         2225  
184 15         24 *{$name} = $tabent->{U}; # Replace with original function
  15         39  
185             }
186 21         58 delete $memotable{$cref};
187              
188 21         206 $tabent->{U};
189             }
190              
191             sub _make_cref {
192 99     99   137 my $fn = shift;
193 99         123 my $uppack = shift;
194 99         146 my $cref;
195             my $name;
196              
197 99 100       248 if (ref $fn eq 'CODE') {
    50          
198 32         50 $cref = $fn;
199             } elsif (! ref $fn) {
200 67 100       180 if ($fn =~ /::/) {
201 1         2 $name = $fn;
202             } else {
203 66         125 $name = $uppack . '::' . $fn;
204             }
205 16     16   104 no strict;
  16         41  
  16         4945  
206 67 100 66     347 if (defined $name and !defined(&$name)) {
207 1         195 croak "Cannot operate on nonexistent function `$fn'";
208             }
209             # $cref = \&$name;
210 66         97 $cref = *{$name}{CODE};
  66         166  
211             } else {
212 0         0 my $parent = (caller(1))[3]; # Function that called _make_cref
213 0         0 croak "Usage: argument 1 to `$parent' must be a function name or reference.\n";
214             }
215 98 50       198 our $DEBUG and warn "${name}($fn) => $cref in _make_cref\n";
216 98         176 $cref;
217             }
218              
219             sub _crap_out {
220 8     8   16 my ($funcname, $context) = @_;
221 8 100       15 if (defined $funcname) {
222 2         248 croak "Function `$funcname' called in forbidden $context context; faulting";
223             } else {
224 6         471 croak "Anonymous function called in forbidden $context context; faulting";
225             }
226             }
227              
228             # Raise an error if the user tries to specify one of these packages as a
229             # tie for LIST_CACHE
230             my %scalar_only = map {($_ => 1)} qw(DB_File GDBM_File SDBM_File ODBM_File), map +($_, "Memoize::$_"), qw(AnyDBM_File NDBM_File);
231             sub _check_suitable {
232 26     26   51 my ($context, $package) = @_;
233             croak "You can't use $package for LIST_CACHE because it can only store scalars"
234 26 100 100     673 if $context eq 'LIST' and $scalar_only{$package};
235             }
236              
237             1;
238              
239             __END__