diff options
author | Norbert Preining <norbert@preining.info> | 2024-03-15 03:06:35 +0000 |
---|---|---|
committer | Norbert Preining <norbert@preining.info> | 2024-03-15 03:06:35 +0000 |
commit | 12679ab7d3c2a210f4123163671b532b8b55d5f9 (patch) | |
tree | 0060d13467186ad977f4e73488ee20dd6c0017ab /systems/texlive/tlnet/tlpkg/tlperl/lib/Memoize.pm | |
parent | 62170822e034fdd3f81de7274835d0d3b0467100 (diff) |
CTAN sync 202403150306
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/lib/Memoize.pm')
-rw-r--r-- | systems/texlive/tlnet/tlpkg/tlperl/lib/Memoize.pm | 401 |
1 files changed, 141 insertions, 260 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Memoize.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Memoize.pm index f4e6522d48..845e0b0695 100644 --- a/systems/texlive/tlnet/tlpkg/tlperl/lib/Memoize.pm +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Memoize.pm @@ -1,207 +1,120 @@ # -*- mode: perl; perl-indent-level: 2; -*- +# vim: ts=8 sw=2 sts=2 noexpandtab + # Memoize.pm # -# Transparent memoization of idempotent functions -# # Copyright 1998, 1999, 2000, 2001, 2012 M. J. Dominus. # You may copy and distribute this program under the -# same terms as Perl itself. If in doubt, -# write to mjd-perl-memoize+@plover.com for a license. - -package Memoize; -$VERSION = '1.03_01'; - -# Compile-time constants -sub SCALAR () { 0 } -sub LIST () { 1 } +# same terms as Perl itself. +use strict; use warnings; -# -# Usage memoize(functionname/ref, -# { NORMALIZER => coderef, INSTALL => name, -# LIST_CACHE => descriptor, SCALAR_CACHE => descriptor } -# +package Memoize; +our $VERSION = '1.16'; use Carp; -use Exporter; -use vars qw($DEBUG); -use Config; # Dammit. -@ISA = qw(Exporter); -@EXPORT = qw(memoize); -@EXPORT_OK = qw(unmemoize flush_cache); -use strict; +use Scalar::Util 1.11 (); # for set_prototype -my %memotable; -my %revmemotable; -my @CONTEXT_TAGS = qw(MERGE TIE MEMORY FAULT HASH); -my %IS_CACHE_TAG = map {($_ => 1)} @CONTEXT_TAGS; +BEGIN { require Exporter; *import = \&Exporter::import } +our @EXPORT = qw(memoize); +our @EXPORT_OK = qw(unmemoize flush_cache); -# Raise an error if the user tries to specify one of thesepackage as a -# tie for LIST_CACHE +my %memotable; -my %scalar_only = map {($_ => 1)} qw(DB_File GDBM_File SDBM_File ODBM_File NDBM_File); +sub CLONE { + my @info = values %memotable; + %memotable = map +($_->{WRAPPER} => $_), @info; +} sub memoize { my $fn = shift; my %options = @_; - my $options = \%options; - + unless (defined($fn) && (ref $fn eq 'CODE' || ref $fn eq '')) { croak "Usage: memoize 'functionname'|coderef {OPTIONS}"; } my $uppack = caller; # TCL me Elmo! - my $cref; # Code reference to original function my $name = (ref $fn ? undef : $fn); - - # Convert function names to code references - $cref = &_make_cref($fn, $uppack); - - # Locate function prototype, if any - my $proto = prototype $cref; - if (defined $proto) { $proto = "($proto)" } - else { $proto = "" } - - # I would like to get rid of the eval, but there seems not to be any - # other way to set the prototype properly. The switch here for - # 'usethreads' works around a bug in threadperl having to do with - # magic goto. It would be better to fix the bug and use the magic - # goto version everywhere. - my $wrapper = - $Config{usethreads} - ? eval "sub $proto { &_memoizer(\$cref, \@_); }" - : eval "sub $proto { unshift \@_, \$cref; goto &_memoizer; }"; + my $cref = _make_cref($fn, $uppack); my $normalizer = $options{NORMALIZER}; if (defined $normalizer && ! ref $normalizer) { $normalizer = _make_cref($normalizer, $uppack); } - - my $install_name; - if (defined $options->{INSTALL}) { - # INSTALL => name - $install_name = $options->{INSTALL}; - } elsif (! exists $options->{INSTALL}) { - # No INSTALL option provided; use original name if possible - $install_name = $name; - } else { - # INSTALL => undef means don't install - } + + my $install_name = exists $options{INSTALL} + ? $options{INSTALL} # use given name (or, if undef: do not install) + : $name; # no INSTALL option provided: default to original name if possible if (defined $install_name) { $install_name = $uppack . '::' . $install_name unless $install_name =~ /::/; - no strict; - local($^W) = 0; # ``Subroutine $install_name redefined at ...'' - *{$install_name} = $wrapper; # Install memoized version } - $revmemotable{$wrapper} = "" . $cref; # Turn code ref into hash key + # convert LIST_CACHE => MERGE to SCALAR_CACHE => MERGE + # to ensure TIE/HASH will always be checked by _check_suitable + if (($options{LIST_CACHE} || '') eq 'MERGE') { + $options{LIST_CACHE} = $options{SCALAR_CACHE}; + $options{SCALAR_CACHE} = 'MERGE'; + } # These will be the caches my %caches; - for my $context (qw(SCALAR LIST)) { - # suppress subsequent 'uninitialized value' warnings - $options{"${context}_CACHE"} ||= ''; - - my $cache_opt = $options{"${context}_CACHE"}; - my @cache_opt_args; - if (ref $cache_opt) { - @cache_opt_args = @$cache_opt; - $cache_opt = shift @cache_opt_args; - } + for my $context (qw(LIST SCALAR)) { # SCALAR_CACHE must be last, to process MERGE + my $fullopt = $options{"${context}_CACHE"} ||= 'MEMORY'; + my ($cache_opt, @cache_opt_args) = ref $fullopt ? @$fullopt : $fullopt; if ($cache_opt eq 'FAULT') { # no cache $caches{$context} = undef; } elsif ($cache_opt eq 'HASH') { # user-supplied hash my $cache = $cache_opt_args[0]; - my $package = ref(tied %$cache); - if ($context eq 'LIST' && $scalar_only{$package}) { - croak("You can't use $package for LIST_CACHE because it can only store scalars"); - } + _check_suitable($context, ref tied %$cache); $caches{$context} = $cache; - } elsif ($cache_opt eq '' || $IS_CACHE_TAG{$cache_opt}) { - # default is that we make up an in-memory hash + } elsif ($cache_opt eq 'TIE') { + carp("TIE option to memoize() is deprecated; use HASH instead") + if warnings::enabled('all'); + my $module = shift(@cache_opt_args) || ''; + _check_suitable($context, $module); + my $hash = $caches{$context} = {}; + (my $modulefile = $module . '.pm') =~ s{::}{/}g; + require $modulefile; + tie(%$hash, $module, @cache_opt_args) + or croak "Couldn't tie memoize hash to `$module': $!"; + } elsif ($cache_opt eq 'MEMORY') { $caches{$context} = {}; - # (this might get tied later, or MERGEd away) + } elsif ($cache_opt eq 'MERGE' and not ref $fullopt) { # ['MERGE'] was never supported + die "cannot MERGE $context\_CACHE" if $context ne 'SCALAR'; # should never happen + die 'bad cache setup order' if not exists $caches{LIST}; # should never happen + $options{MERGED} = 1; + $caches{SCALAR} = $caches{LIST}; } else { - croak "Unrecognized option to `${context}_CACHE': `$cache_opt' should be one of (@CONTEXT_TAGS); aborting"; + croak "Unrecognized option to `${context}_CACHE': `$cache_opt' should be one of (MERGE TIE MEMORY FAULT HASH)"; } } - # Perhaps I should check here that you didn't supply *both* merge - # options. But if you did, it does do something reasonable: They - # both get merged to the same in-memory hash. - if ($options{SCALAR_CACHE} eq 'MERGE' || $options{LIST_CACHE} eq 'MERGE') { - $options{MERGED} = 1; - $caches{SCALAR} = $caches{LIST}; - } + my $wrapper = _wrap($install_name, $cref, $normalizer, $options{MERGED}, \%caches); - # Now deal with the TIE options - { - my $context; - foreach $context (qw(SCALAR LIST)) { - # If the relevant option wasn't `TIE', this call does nothing. - _my_tie($context, $caches{$context}, $options); # Croaks on failure - } + if (defined $install_name) { + no strict; + no warnings 'redefine'; + *{$install_name} = $wrapper; } - - # We should put some more stuff in here eventually. - # We've been saying that for serveral versions now. - # And you know what? More stuff keeps going in! - $memotable{$cref} = - { - O => $options, # Short keys here for things we need to access frequently - N => $normalizer, + + $memotable{$wrapper} = { + L => $caches{LIST}, + S => $caches{SCALAR}, U => $cref, - MEMOIZED => $wrapper, - PACKAGE => $uppack, NAME => $install_name, - S => $caches{SCALAR}, - L => $caches{LIST}, + WRAPPER => $wrapper, }; $wrapper # Return just memoized version } -# This function tries to load a tied hash class and tie the hash to it. -sub _my_tie { - my ($context, $hash, $options) = @_; - my $fullopt = $options->{"${context}_CACHE"}; - - # We already checked to make sure that this works. - my $shortopt = (ref $fullopt) ? $fullopt->[0] : $fullopt; - - return unless defined $shortopt && $shortopt eq 'TIE'; - carp("TIE option to memoize() is deprecated; use HASH instead") - if $^W; - - my @args = ref $fullopt ? @$fullopt : (); - shift @args; - my $module = shift @args; - if ($context eq 'LIST' && $scalar_only{$module}) { - croak("You can't use $module for LIST_CACHE because it can only store scalars"); - } - my $modulefile = $module . '.pm'; - $modulefile =~ s{::}{/}g; - eval { - local @INC = @INC; - pop @INC if $INC[-1] eq '.'; - require $modulefile - }; - if ($@) { - croak "Memoize: Couldn't load hash tie module `$module': $@; aborting"; - } - my $rc = (tie %$hash => $module, @args); - unless ($rc) { - croak "Memoize: Couldn't tie hash to `$module': $!; aborting"; - } - 1; -} - sub flush_cache { my $func = _make_cref($_[0], scalar caller); - my $info = $memotable{$revmemotable{$func}}; + my $info = $memotable{$func}; die "$func not memoized" unless defined $info; for my $context (qw(S L)) { my $cache = $info->{$context}; @@ -216,58 +129,39 @@ sub flush_cache { } } -# This is the function that manages the memo tables. -sub _memoizer { - my $orig = shift; # stringized version of ref to original func. - my $info = $memotable{$orig}; - my $normalizer = $info->{N}; - - my $argstr; - my $context = (wantarray() ? LIST : SCALAR); - - if (defined $normalizer) { - no strict; - if ($context == SCALAR) { - $argstr = &{$normalizer}(@_); - } elsif ($context == LIST) { - ($argstr) = &{$normalizer}(@_); - } else { - croak "Internal error \#41; context was neither LIST nor SCALAR\n"; - } - } else { # Default normalizer - local $^W = 0; - $argstr = join chr(28),@_; - } - - if ($context == SCALAR) { - my $cache = $info->{S}; - _crap_out($info->{NAME}, 'scalar') unless $cache; - if (exists $cache->{$argstr}) { - return $info->{O}{MERGED} - ? $cache->{$argstr}[0] : $cache->{$argstr}; - } else { - my $val = &{$info->{U}}(@_); - # Scalars are considered to be lists; store appropriately - if ($info->{O}{MERGED}) { - $cache->{$argstr} = [$val]; - } else { - $cache->{$argstr} = $val; - } - $val; - } - } elsif ($context == LIST) { - my $cache = $info->{L}; - _crap_out($info->{NAME}, 'list') unless $cache; - if (exists $cache->{$argstr}) { - return @{$cache->{$argstr}}; +sub _wrap { + my ($name, $orig, $normalizer, $merged, $caches) = @_; + my ($cache_L, $cache_S) = @$caches{qw(LIST SCALAR)}; + undef $caches; # keep the pad from keeping the hash alive forever + Scalar::Util::set_prototype(sub { + my $argstr = do { + no warnings 'uninitialized'; + defined $normalizer + ? ( wantarray ? ( $normalizer->( @_ ) )[0] : $normalizer->( @_ ) ) + . '' # coerce undef to string while the warning is off + : join chr(28), @_; + }; + + if (wantarray) { + _crap_out($name, 'list') unless $cache_L; + exists $cache_L->{$argstr} ? ( + @{$cache_L->{$argstr}} + ) : do { + my @q = do { no warnings 'recursion'; &$orig }; + $cache_L->{$argstr} = \@q; + @q; + }; } else { - my @q = &{$info->{U}}(@_); - $cache->{$argstr} = \@q; - @q; + _crap_out($name, 'scalar') unless $cache_S; + exists $cache_S->{$argstr} ? ( + $merged ? $cache_S->{$argstr}[0] : $cache_S->{$argstr} + ) : do { + my $val = do { no warnings 'recursion'; &$orig }; + $cache_S->{$argstr} = $merged ? [$val] : $val; + $val; + }; } - } else { - croak "Internal error \#42; context was neither LIST nor SCALAR\n"; - } + }, prototype $orig); } sub unmemoize { @@ -275,35 +169,21 @@ sub unmemoize { my $uppack = caller; my $cref = _make_cref($f, $uppack); - unless (exists $revmemotable{$cref}) { + unless (exists $memotable{$cref}) { croak "Could not unmemoize function `$f', because it was not memoized to begin with"; } - - my $tabent = $memotable{$revmemotable{$cref}}; + + my $tabent = $memotable{$cref}; unless (defined $tabent) { croak "Could not figure out how to unmemoize function `$f'"; } my $name = $tabent->{NAME}; if (defined $name) { no strict; - local($^W) = 0; # ``Subroutine $install_name redefined at ...'' + no warnings 'redefine'; *{$name} = $tabent->{U}; # Replace with original function } - undef $memotable{$revmemotable{$cref}}; - undef $revmemotable{$cref}; - - # This removes the last reference to the (possibly tied) memo tables - # my ($old_function, $memotabs) = @{$tabent}{'U','S','L'}; - # undef $tabent; - -# # Untie the memo tables if they were tied. -# my $i; -# for $i (0,1) { -# if (tied %{$memotabs->[$i]}) { -# warn "Untying hash #$i\n"; -# untie %{$memotabs->[$i]}; -# } -# } + delete $memotable{$cref}; $tabent->{U}; } @@ -332,7 +212,7 @@ sub _make_cref { my $parent = (caller(1))[3]; # Function that called _make_cref croak "Usage: argument 1 to `$parent' must be a function name or reference.\n"; } - $DEBUG and warn "${name}($fn) => $cref in _make_cref\n"; + our $DEBUG and warn "${name}($fn) => $cref in _make_cref\n"; $cref; } @@ -345,11 +225,20 @@ sub _crap_out { } } -1; - +# Raise an error if the user tries to specify one of these packages as a +# tie for LIST_CACHE +my %scalar_only = map {($_ => 1)} qw(DB_File GDBM_File SDBM_File ODBM_File), map +($_, "Memoize::$_"), qw(AnyDBM_File NDBM_File); +sub _check_suitable { + my ($context, $package) = @_; + croak "You can't use $package for LIST_CACHE because it can only store scalars" + if $context eq 'LIST' and $scalar_only{$package}; +} +1; +__END__ +=pod =head1 NAME @@ -357,7 +246,6 @@ Memoize - Make functions faster by trading space for time =head1 SYNOPSIS - # This is the documentation for Memoize 1.03 use Memoize; memoize('slow_function'); slow_function(arguments); # Is faster than it was before @@ -384,12 +272,14 @@ Options include: =head1 DESCRIPTION -`Memoizing' a function makes it faster by trading space for time. It +I<Memoizing> a function makes it faster by trading space for time. It does this by caching the return values of the function in a table. If you call the function again with the same arguments, C<memoize> jumps in and gives you the value out of the table, instead of letting the function compute the value all over again. +=head1 EXAMPLE + Here is an extreme example. Consider the Fibonacci sequence, defined by the following function: @@ -412,14 +302,14 @@ run---fib(14) makes 1,200 extra recursive calls to itself, to compute and recompute things that it already computed. This function is a good candidate for memoization. If you memoize the -`fib' function above, it will compute fib(14) exactly once, the first +C<fib> function above, it will compute fib(14) exactly once, the first time it needs to, and then save the result in a table. Then if you ask for fib(14) again, it gives you the result out of the table. While computing fib(14), instead of computing fib(12) twice, it does it once; the second time it needs the value it gets it from the table. It doesn't compute fib(11) four times; it computes it once, getting it from the table the next three times. Instead of making 1,200 -recursive calls to `fib', it makes 15. This makes the function about +recursive calls to C<fib>, it makes 15. This makes the function about 150 times faster. You could do the memoization yourself, by rewriting the function, like @@ -446,8 +336,8 @@ This makes it easy to turn memoizing on and off. Here's an even simpler example: I wrote a simple ray tracer; the program would look in a certain direction, figure out what it was -looking at, and then convert the `color' value (typically a string -like `red') of that object to a red, green, and blue pixel value, like +looking at, and then convert the C<color> value (typically a string +like C<red>) of that object to a red, green, and blue pixel value, like this: for ($direction = 0; $direction < 300; $direction++) { @@ -718,7 +608,7 @@ should abort the program. The error message is one of =item C<MERGE> C<MERGE> normally means that the memoized function does not -distinguish between list and sclar context, and that return values in +distinguish between list and scalar context, and that return values in both contexts should be stored together. Both C<LIST_CACHE =E<gt> MERGE> and C<SCALAR_CACHE =E<gt> MERGE> mean the same thing. @@ -740,7 +630,7 @@ if C<complicated> is memoized: $z = complicated(142); The first call will cache the result, say 37, in the scalar cache; the -second will cach the list C<(37)> in the list cache. The third call +second will cache the list C<(37)> in the list cache. The third call doesn't call the real C<complicated> function; it gets the value 37 from the scalar cache. @@ -749,9 +639,11 @@ storing its return value is a waste of space. Specifying C<LIST_CACHE =E<gt> MERGE> will make C<memoize> use the same cache for scalar and list context return values, so that the second call uses the scalar cache that was populated by the first call. C<complicated> ends up -being called only once, and both subsequent calls return C<3> from the +being called only once, and both subsequent calls return C<37> from the cache, regardless of the calling context. +=back + =head3 List values in scalar context Consider this function: @@ -783,7 +675,8 @@ stored in the same disk file; this saves you from having to deal with two disk files instead of one. You can use a normalizer function to keep the two sets of return values separate. For example: - tie my %cache => 'MLDBM', 'DB_File', $filename, ...; + local $MLDBM::UseDB = 'DB_File'; + tie my %cache => 'MLDBM', $filename, ...; memoize 'myfunc', NORMALIZER => 'n', @@ -801,8 +694,6 @@ This normalizer function will store scalar context return values in the disk file under keys that begin with C<S:>, and list context return values under keys that begin with C<L:>. -=back - =head1 OTHER FACILITIES =head2 C<unmemoize> @@ -877,7 +768,7 @@ Do not memoize a function with side effects. } This function accepts two arguments, adds them, and prints their sum. -Its return value is the numuber of characters it printed, but you +Its return value is the number of characters it printed, but you probably didn't care about that. But C<Memoize> doesn't understand that. If you memoize this function, you will get the result you expect the first time you ask it to print the sum of 2 and 3, but @@ -984,8 +875,8 @@ function (or when your program exits): tie my %cache => 'Memoize::Storable', $filename, 'nstore'; memoize 'function', SCALAR_CACHE => [HASH => \%cache]; -Include the `nstore' option to have the C<Storable> database written -in `network order'. (See L<Storable> for more details about this.) +Include the C<nstore> option to have the C<Storable> database written +in I<network order>. (See L<Storable> for more details about this.) The C<flush_cache()> function will raise a run-time error unless the tied package provides a C<CLEAR> method. @@ -1016,38 +907,17 @@ C<f()> (C<f> called with no arguments) will not be memoized. If this is a big problem, you can supply a normalizer function that prepends C<"x"> to every key. -=head1 MAILING LIST - -To join a very low-traffic mailing list for announcements about -C<Memoize>, send an empty note to C<mjd-perl-memoize-request@plover.com>. - -=head1 AUTHOR +=head1 SEE ALSO -Mark-Jason Dominus (C<mjd-perl-memoize+@plover.com>), Plover Systems co. - -See the C<Memoize.pm> Page at http://perl.plover.com/Memoize/ -for news and upgrades. Near this page, at -http://perl.plover.com/MiniMemoize/ there is an article about +At L<https://perl.plover.com/MiniMemoize/> there is an article about memoization and about the internals of Memoize that appeared in The -Perl Journal, issue #13. (This article is also included in the -Memoize distribution as `article.html'.) +Perl Journal, issue #13. -The author's book I<Higher-Order Perl> (2005, ISBN 1558607013, published +Mark-Jason Dominus's book I<Higher-Order Perl> (2005, ISBN 1558607013, +published by Morgan Kaufmann) discusses memoization (and many other topics) in tremendous detail. It is available on-line for free. -For more information, visit http://hop.perl.plover.com/ . - -To join a mailing list for announcements about C<Memoize>, send an -empty message to C<mjd-perl-memoize-request@plover.com>. This mailing -list is for announcements only and has extremely low traffic---fewer than -two messages per year. - -=head1 COPYRIGHT AND LICENSE - -Copyright 1998, 1999, 2000, 2001, 2012 by Mark Jason Dominus - -This library is free software; you may redistribute it and/or modify -it under the same terms as Perl itself. +For more information, visit L<https://hop.perl.plover.com/>. =head1 THANK YOU @@ -1074,4 +944,15 @@ Special thanks to Jarkko Hietaniemi, the 5.8.0 pumpking, for including this module in the core and for his patient and helpful guidance during the integration process. +=head1 AUTHOR + +Mark Jason Dominus + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2012 by Mark Jason Dominus. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + =cut |