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

# -*- mode: perl; perl-indent-level: 2; -*-
# vim: ts=8 sw=2 sts=2 noexpandtab

# Memoize.pm
#
# Copyright 1998, 1999, 2000, 2001, 2012 M. J. Dominus.
# You may copy and distribute this program under the
# same terms as Perl itself.

use strict; use warnings;

package Memoize;
our $VERSION = '1.17';

use Carp;
use Scalar::Util 1.11 (); # for set_prototype

BEGIN { require Exporter; *import = \&Exporter::import }
our @EXPORT = qw(memoize);
our @EXPORT_OK = qw(unmemoize flush_cache);

my %memotable;

sub CLONE {
  my @info = values %memotable;
  %memotable = map +($_->{WRAPPER} => $_), @info;
}

sub memoize {
  my $fn = shift;
  my %options = @_;

  unless (defined($fn) &&
	  (ref $fn eq 'CODE' || ref $fn eq '')) {
    croak "Usage: memoize 'functionname'|coderef {OPTIONS}";
  }

  my $uppack = caller;		# TCL me Elmo!
  my $name = (ref $fn ? undef : $fn);
  my $cref = _make_cref($fn, $uppack);

  my $normalizer = $options{NORMALIZER};
  if (defined $normalizer  && ! ref $normalizer) {
    $normalizer = _make_cref($normalizer, $uppack);
  }

  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 =~ /::/;
  }

  # 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(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];
      _check_suitable($context, ref tied %$cache);
      $caches{$context} = $cache;
    } 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} = {};
    } 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 (MERGE TIE MEMORY FAULT HASH)";
    }
  }

  my $wrapper = _wrap($install_name, $cref, $normalizer, $options{MERGED}, \%caches);

  if (defined $install_name) {
    no strict;
    no warnings 'redefine';
    *{$install_name} = $wrapper;
  }

  $memotable{$wrapper} = {
    L => $caches{LIST},
    S => $caches{SCALAR},
    U => $cref,
    NAME => $install_name,
    WRAPPER => $wrapper,
  };

  $wrapper			# Return just memoized version
}

sub flush_cache {
  my $func = _make_cref($_[0], scalar caller);
  my $info = $memotable{$func};
  die "$func not memoized" unless defined $info;
  for my $context (qw(S L)) {
    my $cache = $info->{$context};
    if (tied %$cache && ! (tied %$cache)->can('CLEAR')) {
      my $funcname = defined($info->{NAME}) ?
          "function $info->{NAME}" : "anonymous function $func";
      my $context = {S => 'scalar', L => 'list'}->{$context};
      croak "Tied cache hash for $context-context $funcname does not support flushing";
    } else {
      %$cache = ();
    }
  }
}

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 {
      _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;
      };
    }
  }, prototype $orig);
}

sub unmemoize {
  my $f = shift;
  my $uppack = caller;
  my $cref = _make_cref($f, $uppack);

  unless (exists $memotable{$cref}) {
    croak "Could not unmemoize function `$f', because it was not memoized to begin with";
  }

  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;
    no warnings 'redefine';
    *{$name} = $tabent->{U}; # Replace with original function
  }
  delete $memotable{$cref};

  $tabent->{U};
}

sub _make_cref {
  my $fn = shift;
  my $uppack = shift;
  my $cref;
  my $name;

  if (ref $fn eq 'CODE') {
    $cref = $fn;
  } elsif (! ref $fn) {
    if ($fn =~ /::/) {
      $name = $fn;
    } else {
      $name = $uppack . '::' . $fn;
    }
    no strict;
    if (defined $name and !defined(&$name)) {
      croak "Cannot operate on nonexistent function `$fn'";
    }
#    $cref = \&$name;
    $cref = *{$name}{CODE};
  } else {
    my $parent = (caller(1))[3]; # Function that called _make_cref
    croak "Usage: argument 1 to `$parent' must be a function name or reference.\n";
  }
  our $DEBUG and warn "${name}($fn) => $cref in _make_cref\n";
  $cref;
}

sub _crap_out {
  my ($funcname, $context) = @_;
  if (defined $funcname) {
    croak "Function `$funcname' called in forbidden $context context; faulting";
  } else {
    croak "Anonymous function called in forbidden $context context; faulting";
  }
}

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