File Coverage

blib/lib/Memoize.pm

Criterion	Covered	Total	%
statement	162	171	94.7
branch	73	82	89.0
condition	23	29	79.3
subroutine	19	20	95.0
pod	2	3	66.6
total	279	305	91.4

# -*- 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.13';

use Carp;
use Config;                     # Dammit.

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

my %memotable;
my @CONTEXT_TAGS = qw(MERGE TIE MEMORY FAULT HASH);
my %IS_CACHE_TAG = map {($_ => 1)} @CONTEXT_TAGS;

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

# Raise an error if the user tries to specify one of thesepackage 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 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 $proto = prototype $cref;
  $proto = defined $proto ? "($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 $info;
  my $wrapper =
      $Config{usethreads}
        ? eval "sub $proto { &_memoizer(\$info, \@_); }"
        : eval "sub $proto { unshift \@_, \$info; goto &_memoizer; }";

  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 =~ /::/;
    no strict;
    no warnings 'redefine';
    *{$install_name} = $wrapper; # Install memoized version
  }

  # These will be the caches
  my %caches;
  for my $context (qw(SCALAR LIST)) {
    # suppress subsequent 'uninitialized value' warnings
    my $fullopt = $options{"${context}_CACHE"} ||= '';
    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");
      }
      $caches{$context} = $cache;
    } elsif ($cache_opt eq '' ||  $IS_CACHE_TAG{$cache_opt}) {
      # default is that we make up an in-memory hash
      $caches{$context} = {};
      # (this might get tied later, or MERGEd away)
    } else {
      croak "Unrecognized option to `${context}_CACHE': `$cache_opt' should be one of (@CONTEXT_TAGS)";
    }
  }

  # 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{MERGED} = 1;
    $caches{SCALAR} = $caches{LIST};
  } elsif ($options{LIST_CACHE} eq 'MERGE') {
    $options{MERGED} = 1;
    $caches{LIST} = $caches{SCALAR};
  }

  # 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{"${context}_CACHE"}); # Croaks on failure
    }
  }

  $info =
  {
    N => $normalizer,
    U => $cref,
    NAME => $install_name,
    S => $caches{SCALAR},
    L => $caches{LIST},
    MERGED => $options{MERGED},
  };

  $memotable{$wrapper} = {
    INFO    => $info,
    WRAPPER => $wrapper, # cannot be in $info because $wrapper captures $info
  };

  $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, $fullopt) = @_;

  # We already checked to make sure that this works.
  my ($shortopt, $module, @args) = ref $fullopt ? @$fullopt : $fullopt;

  return unless defined $shortopt && $shortopt eq 'TIE';
  carp("TIE option to memoize() is deprecated; use HASH instead")
      if warnings::enabled('all');

  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;
  require $modulefile;
  my $rc = (tie %$hash => $module, @args);
  unless ($rc) {
    croak "Couldn't tie memoize hash to `$module': $!";
  }
  1;
}

sub flush_cache {
  my $func = _make_cref($_[0], scalar caller);
  my $info = $memotable{$func}{INFO};
  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 = ();
    }
  }
}

# This is the function that manages the memo tables.
sub _memoizer {
  my $info = shift;

  my $normalizer = $info->{N};
  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) {
    my $cache = $info->{L};
    _crap_out($info->{NAME}, 'list') unless $cache;
    if (exists $cache->{$argstr}) {
      return @{$cache->{$argstr}};
    } else {
      my @q = &{$info->{U}};
      $cache->{$argstr} = \@q;
      @q;
    }
  } else {
    my $cache = $info->{S};
    _crap_out($info->{NAME}, 'scalar') unless $cache;
    if (exists $cache->{$argstr}) {
      return $info->{MERGED}
        ? $cache->{$argstr}[0] : $cache->{$argstr};
    } else {
      my $val = &{$info->{U}};
      # Scalars are considered to be lists; store appropriately
      if ($info->{MERGED}) {
	$cache->{$argstr} = [$val];
      } else {
	$cache->{$argstr} = $val;
      }
      $val;
    }
  }
}

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}{INFO};
  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";
  }
}

1;

__END__