view release on metacpan or  search on metacpan

t/lib/Test/Resub.pm  view on Meta::CPAN

package Test::Resub;

use strict;
use warnings;

use base qw(Exporter);
our @EXPORT = qw(resub bulk_resub);

our $VERSION = 2.02;

use Carp qw(croak);
use Storable qw(dclone);
use Scalar::Util qw(weaken);

sub default_replacement_sub { sub {} }
sub set_prototype(&$) {
	if (_implements('Scalar::Util','set_prototype')) {
		goto \&Scalar::Util::set_prototype;
	} else {
		my $code = shift;
		my $proto = shift;
		$proto = defined $proto ? "($proto)" : '';
		local $@;
		return eval "sub $proto { goto \$code }";
	}
}

sub resub {
	my ($name, $code, %args) = @_;
	die "give me a fully qualified function name: $name ain't good enough\n"
		unless $name =~ /::/;
	return __PACKAGE__->new(
    %args,
    name => $name,
    code => $code,
  );
}

sub bulk_resub {
	my ($target, $data, %args) = @_;
	my %rs;
	foreach (keys %$data) {
		$rs{$_} = resub "$target\::$_", $data->{$_}, %args;
	}
	return %rs;
}

sub _validate_params_lameley {
	my ($class, %args) = @_;

	my %known =
		map { $_ => 1 }
		qw(name code create call capture deep_copy);

	my %bad =
		map { $_ => $args{$_} }
		grep { ! $known{$_} }
		keys %args;

	if (scalar keys %bad) {
		my $bad = join ', ', map { "$_ => $bad{$_}" } keys %bad;
    croak "$class->new - not sure how to handle unknown arg '$bad'\n";
  }

	croak "don't know how to handle 'call  => $args{call}'"
		if exists $args{call} && ! in($args{call}, qw(optional required forbidden));

	return (
		deep_copy => 1,
		call => 'required',
		%args,
	);
}

sub new {
	my $class = shift;

	# lame adaptor for old-style users of Test::Resub (are there any?)
	my %args = ref($_[0]) eq 'HASH' ? %{$_[0]} : @_;

	# I'm not gonna lie, this really is stupidly ugly
	%args = $class->_validate_params_lameley(%args);

	croak "I return a highly useful object, gotta call me in non-void context!\n"
		unless defined wantarray;

	my $name = $args{name};
	(my $sane = $name) =~ s{->}{::}g;
	$sane =~ s{[^\w:]}{}g;
	croak "bad method name: $args{name} (expected: $sane)" if $args{name} ne $sane;

	my $code = $args{code} || $class->default_replacement_sub;

	my ($orig_code, $autovivified) = $class->_get_orig_code(%args);

	my ($package, $sub) = $args{name} =~ m{^(.*)::(.*?)$};

	my $self = bless {
		%args,
		target_package => $package,
		target_sub => $sub,
		orig_code => $orig_code,
		called => 0,
		args => [],
		autovivified => $autovivified,
		stashed_variables => _save_variables($args{name}),
		deep_copy => $args{deep_copy},
	}, $class;

	weaken(my $weak_self = $self);
	my $wrapper_for_code = set_prototype(sub {
		$weak_self->{called}++;
		$weak_self->{was_called} = 1;
		push @{$weak_self->{args}}, ($weak_self->{deep_copy}
			? do {
				local $Storable::Deparse = 1;
				local $Storable::Eval = 1;
				dclone(\@_);
			}
			: [@_]);

		# Are you debugging? Here's where we call the original code in its original context.
		return $code->(@_);
	}, prototype(\&{$self->{name}}));

	$self->swap_out($wrapper_for_code);
	_restore_variables($self->{name}, $self->{stashed_variables});

	return $self;
}

sub _context {
	my ($class) = @_;
	my $wantarray = (caller(1))[5];
	my $context = $wantarray
		? 'list'
		: defined $wantarray
			? 'scalar'
			: 'void';
	return $context;
}

sub _save_variables {
  my ($varname) = @_;
  no strict 'refs';
  return {
    scalar => $$varname,
    array => \@$varname,
    hash => \%$varname,
  };
}

sub _restore_variables {
  my ($varname, $data) = @_;
  no strict 'refs';
	no warnings 'uninitialized';
  $$varname = $data->{scalar};
  @$varname = @{$data->{array}};
  %$varname = %{$data->{hash}};
}

sub _implements {
	my ($package, $sub) = @_;

	local $@;
	my %stash = eval "\%$package\::";
	croak "finding $package\'s stash: $@\n" if $@;

	return exists $stash{$sub} && *{$stash{$sub}}{CODE} && *{$stash{$sub}}{NAME} eq $sub;
}