view release on metacpan or  search on metacpan

lib/Test/MockModule.pm  view on Meta::CPAN

				: $orig_method;
			$meta->add_method($name, $arg);
		} else {
			TRACE("Removing mocked $sub_name from meta (was inherited or absent)");
			if ($meta->can('remove_method')) {
				$meta->remove_method($name);
			} else {
				# Mouse::Meta::Class has no remove_method; purge the
				# internal methods cache entry directly so that
				# get_method() no longer finds the mocked entry.
				delete $meta->{methods}{$name};
			}
			# remove_method does not always clear the symbol table.
			# When the layer captured a symbol-table orig (e.g. an earlier
			# layer pushed via the symbol table while meta was immutable,
			# then make_mutable purged the cached meta entry), restore that
			# coderef so the method continues to resolve. When orig is
			# undef the slot is cleared, so direct calls fall through to
			# AUTOLOAD/parent.
			_replace_sub($sub_name, $entry->{orig});
		}
	} else {
		# Either the layer was a symbol-table push, or meta became immutable
		# between mock and unmock. Fall back to the captured orig coderef.
		_replace_sub($sub_name, $entry->{orig});
	}
}

sub noop {
    my $self = shift;

    croak "noop is not allowed in strict mode. Please use define or redefine" if $self->_strict_mode();

    $self->_mock($_,1) for @_;

    return;
}

sub mock_all {
	my ($self, %opts) = @_;

	croak "mock_all is not allowed in strict mode. Please use redefine" if $self->_strict_mode();

	my $package = $self->{_package};

	my @subs;
	{
		no strict 'refs'; ## no critic (TestingAndDebugging::ProhibitNoStrict)
		@subs = sort grep {
			defined &{"${package}::$_"}
		} keys %{"${package}::"};
	}

	my $make_handler = exists $opts{handler}
		? sub { $opts{handler} }
		: $opts{noop}
			? sub { sub { 1 } }
			: sub { my $n = shift; sub { croak "$n was not mocked" } };

	# Skip special Perl subs that should never be blindly mocked:
	# - Phase blocks (BEGIN, END, INIT, CHECK, UNITCHECK) run at compile/exit time
	# - DESTROY is called during object cleanup
	# - AUTOLOAD handles missing method dispatch
	# - import handles use/import semantics
	# - Overload subs start with '(' (e.g. '(""', '(+', '(==')
	my %_skip = map { $_ => 1 } qw(
		import DESTROY BEGIN END INIT CHECK UNITCHECK AUTOLOAD
	);

	my @to_mock;
	for my $name (@subs) {
		next if $_skip{$name};
		next if $name =~ /^\(/;  # overload subs
		next if $self->{_mocked}{$name};
		push @to_mock, $name, $make_handler->("${package}::${name}");
	}

	return $self->_mock(@to_mock) if @to_mock;
	return $self;
}

sub original {
	my ($self, $name) = @_;

	carp 'Please provide a valid function name' unless _valid_subname($name);

	unless ($self->{_mocked}{$name}) {
		# GH #42: when not mocked, return the actual sub instead of warning
		my $sub_name = _full_name($self, $name);
		return \&$sub_name if defined &{$sub_name};
		return $self->{_package}->super($name);
	}
	return defined $self->{_orig}{$name} ? $self->{_orig}{$name} : $self->{_package}->super($name);
}

# Class-method counterpart to $mock->original(). Takes strings, returns
# the truly-original coderef from the per-package registry (or the live
# sub if not mocked). Lets user closures reach the original sub without
# capturing $mock -- the closure-capture pattern that drives the GH #83
# DESTROY-leak under `distinct => 1` mode.
sub original_for {
	my ($class, $package, $name) = @_;
	croak "Invalid package name " . (defined $package ? $package : 'undef')
		unless _valid_package($package);
	croak 'Please provide a valid function name'
		unless _valid_subname($name);

	my $sub_name = "${package}::${name}";
	my $stack = $mock_subs{$sub_name};
	if ($stack && @$stack) {
		# Bottom-of-stack orig is the truly-original. May be undef when
		# the sub was created via define() -- that is expected. Falling
		# through to \&$sub_name would hand back the active mock (an
		# infinite-recursion footgun for closures wrapping their orig).
		return $stack->[0]{orig};
	}
	no strict 'refs'; ## no critic (TestingAndDebugging::ProhibitNoStrict)
	return \&$sub_name if defined &{$sub_name};
	return;
}

sub unmock {
	my ( $self, @names ) = @_;

	carp 'Nothing to unmock' unless @names;
	for my $name (@names) {
		croak "Invalid subroutine name: $name" unless _valid_subname($name);