File Coverage

blib/lib/Sub/Defer.pm

Criterion	Covered	Total	%
statement	110	110	100.0
branch	52	54	100.0
condition	49	63	77.7
subroutine	23	23	100.0
pod	5	5	100.0
total	239	255	94.5

package Sub::Defer;
use strict;
use warnings;

our $VERSION = '2.006008';
$VERSION =~ tr/_//d;

use Exporter ();
BEGIN { *import = \&Exporter::import }
use Scalar::Util qw(weaken);
use Carp qw(croak);

our @EXPORT = qw(defer_sub undefer_sub undefer_all);
our @EXPORT_OK = qw(undefer_package defer_info);

sub _getglob { no strict 'refs'; \*{$_[0]} }

BEGIN {
  my $no_subname;
  *_subname
    = defined &Sub::Util::set_subname ? \&Sub::Util::set_subname
    : defined &Sub::Name::subname     ? \&Sub::Name::subname
    : (eval { require Sub::Util } && defined &Sub::Util::set_subname) ? \&Sub::Util::set_subname
    : (eval { require Sub::Name } && defined &Sub::Name::subname    ) ? \&Sub::Name::subname
    : ($no_subname = 1, sub { $_[1] });
  *_CAN_SUBNAME = $no_subname ? sub(){0} : sub(){1};
}

sub _name_coderef {
  shift if @_ > 2; # three args is (target, name, sub)
  _CAN_SUBNAME ? _subname(@_) : $_[1];
}

sub _install_coderef {
  my ($glob, $code) = (_getglob($_[0]), _name_coderef(@_));
  no warnings 'redefine';
  if (*{$glob}{CODE}) {
    *{$glob} = $code;
  }
  # perl will sometimes warn about mismatched prototypes coming from the
  # inheritance cache, so disable them if we aren't redefining a sub
  else {
    no warnings 'prototype';
    *{$glob} = $code;
  }
}

# We are dealing with three subs.  The first is the generator sub.  It is
# provided by the user, so we cannot modify it.  When called, it generates the
# undeferred sub.  This is also created, so it also cannot be modified.  These
# are wrapped in a third sub.  The deferred sub is generated by us, and when
# called it uses the generator sub to create the undeferred sub.  If it is a
# named sub, it is installed in the symbol table, usually overwriting the
# deferred sub.  From then on, the deferred sub will goto the undeferred sub
# if it is called.
#
# In %DEFERRED we store array refs with information about these subs.  The key
# is the stringified subref.  We have a CLONE method to fix this up in the
# case of threading to deal with changing refaddrs.  The arrayrefs contain:
#
# 0. fully qualified sub name (or undef)
# 1. generator sub
# 2. options (attributes)
# 3. scalar ref to undeferred sub (inner reference weakened)
# 4. deferred sub (deferred only)
# 5. info arrayref for undeferred sub (deferred only, after undefer)
#
# The deferred sub contains a strong reference to its info arrayref, and the
# undeferred.

our %DEFERRED;

sub undefer_sub {
  my ($deferred) = @_;
  my $info = $DEFERRED{$deferred} or return $deferred;
  my ($target, $maker, $options, $undeferred_ref, $deferred_sub) = @$info;

  if (!(
    $deferred_sub && $deferred eq $deferred_sub
    || ${$undeferred_ref} && $deferred eq ${$undeferred_ref}
  )) {
    return $deferred;
  }

  return ${$undeferred_ref}
    if ${$undeferred_ref};
  ${$undeferred_ref} = my $made = $maker->();

  # make sure the method slot has not changed since deferral time
  if (defined($target) && $deferred eq *{_getglob($target)}{CODE}||'') {
    no warnings 'redefine';

    # I believe $maker already evals with the right package/name, so that
    # _install_coderef calls are not necessary --ribasushi
    *{_getglob($target)} = $made;
  }
  my $undefer_info = [ $target, $maker, $options, $undeferred_ref ];
  $info->[5] = $DEFERRED{$made} = $undefer_info;
  weaken ${$undefer_info->[3]};

  return $made;
}

sub undefer_all {
  undefer_sub($_) for keys %DEFERRED;
  return;
}

sub undefer_package {
  my $package = shift;
  undefer_sub($_)
    for grep {
      my $name = $DEFERRED{$_} && $DEFERRED{$_}[0];
      $name && $name =~ /^${package}::[^:]+$/
    } keys %DEFERRED;
  return;
}

sub defer_info {
  my ($deferred) = @_;
  my $info = $DEFERRED{$deferred||''} or return undef;

  my ($target, $maker, $options, $undeferred_ref, $deferred_sub) = @$info;
  if (!(
    $deferred_sub && $deferred eq $deferred_sub
    || ${$undeferred_ref} && $deferred eq ${$undeferred_ref}
  )) {
    delete $DEFERRED{$deferred};
    return undef;
  }
  [
    $target, $maker, $options,
    ( $undeferred_ref && $$undeferred_ref ? $$undeferred_ref : ()),
  ];
}

sub defer_sub {
  my ($target, $maker, $options) = @_;
  my $package;
  my $subname;
  ($package, $subname) = $target =~ /^(.*)::([^:]+)$/
    or croak "$target is not a fully qualified sub name!"
    if $target;
  $package ||= $options && $options->{package} || caller;
  my @attributes = @{$options && $options->{attributes} || []};
  if (@attributes) {
    /\A\w+(?:\(.*\))?\z/s || croak "invalid attribute $_"
      for @attributes;
  }
  my $deferred;
  my $undeferred;
  my $deferred_info = [ $target, $maker, $options, \$undeferred ];
  if (@attributes || $target && !_CAN_SUBNAME) {
    my $code
      =  q[#line ].(__LINE__+2).q[ "].__FILE__.qq["\n]
      . qq[package $package;\n]
      . ($target ? "sub $subname" : '+sub') . join('', map " :$_", @attributes)
      . q[ {
        package Sub::Defer;
        # uncoverable subroutine
        # uncoverable statement
        $undeferred ||= undefer_sub($deferred_info->[4]);
        goto &$undeferred; # uncoverable statement
        $undeferred; # fake lvalue return
      }]."\n"
      . ($target ? "\\&$subname" : '');
    my $e;
    $deferred = do {
      no warnings qw(redefine closure);
      local $@;
      eval $code or $e = $@; # uncoverable branch true
    };
    die $e if defined $e; # uncoverable branch true
  }
  else {
    # duplicated from above
    $deferred = sub {
      $undeferred ||= undefer_sub($deferred_info->[4]);
      goto &$undeferred;
    };
    _install_coderef($target, $deferred)
      if $target;
  }
  weaken($deferred_info->[4] = $deferred);
  weaken($DEFERRED{$deferred} = $deferred_info);
  return $deferred;
}

sub CLONE {
  %DEFERRED = map {
    defined $_ ? (
        $_->[4] ? ($_->[4] => $_)
      : ($_->[3] && ${$_->[3]}) ? (${$_->[3]} => $_)
      : ()
    ) : ()
  } values %DEFERRED;
}

1;
__END__