Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Multiple improvements #62

Merged
merged 1 commit into from
Apr 26, 2024
Merged

Multiple improvements #62

Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
64 changes: 36 additions & 28 deletions lib/Test/MockModule.pm
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -19,7 +19,7 @@ sub import {
} elsif ( $arg eq 'nostrict' ) {
$^H{'Test::MockModule/STRICT_MODE'} = 0;
} else {
warn "Test::MockModule unknown import option '$arg'";
carp "Test::MockModule unknown import option '$arg'";
}
}
return;
Expand All @@ -38,13 +38,12 @@ sub _strict_mode {

my %mocked;
sub new {
my $class = shift;
my ($package, %args) = @_;
my ($class, $package, %args) = @_;
if ($package && (my $existing = $mocked{$package})) {
return $existing;
}

croak "Cannot mock $package" if $package && $package eq $class;
croak "Cannot mock $package" if $package && $class && $package eq $class;
unless (_valid_package($package)) {
$package = 'undef' unless defined $package;
croak "Invalid package name $package";
Expand Down Expand Up @@ -77,9 +76,10 @@ sub get_package {
}

sub redefine {
my ($self, @mocks) = (shift, @_);
my ($self, @mocks) = (@_);

while ( my ($name, $value) = splice @mocks, 0, 2 ) {
my @mocks_copy = @mocks;
while ( my ($name, $value) = splice @mocks_copy, 0, 2 ) {
my $sub_name = $self->_full_name($name);
my $coderef = *{$sub_name}{'CODE'};
next if 'CODE' eq ref $coderef;
Expand All @@ -94,13 +94,14 @@ sub redefine {
}
}

return $self->_mock(@_);
return $self->_mock(@mocks);
}

sub define {
my ($self, @mocks) = (shift, @_);
my ($self, @mocks) = @_;

while ( my ($name, $value) = splice @mocks, 0, 2 ) {
my @mocks_copy = @mocks;
while ( my ($name, $value) = splice @mocks_copy, 0, 2 ) {
my $sub_name = $self->_full_name($name);
my $coderef = *{$sub_name}{'CODE'};

Expand All @@ -109,13 +110,13 @@ sub define {
}
}

return $self->_mock(@_);
return $self->_mock(@mocks);
}

sub mock {
my ($self, @mocks) = (shift, @_);
my ($self, @mocks) = @_;

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

return $self->_mock(@mocks);
}
Expand Down Expand Up @@ -153,25 +154,27 @@ sub _mock {
sub noop {
my $self = shift;

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

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

return;
}

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

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

return carp _full_name($self, $name) . " is not mocked"
unless $self->{_mocked}{$name};
return defined $self->{_orig}{$name} ? $self->{_orig}{$name} : $self->{_package}->super($name);
}
sub unmock {
my $self = shift;
my ( $self, @names ) = @_;

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

my $sub_name = _full_name($self, $name);
Expand All @@ -190,37 +193,42 @@ sub unmock {

sub unmock_all {
my $self = shift;
foreach (keys %{$self->{_mocked}}) {
$self->unmock($_);
foreach my $name (keys %{$self->{_mocked}}) {
$self->unmock($name);
}

return;
}

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

return unless _valid_subname($name);

return $self->{_mocked}{$name};
}

sub _full_name {
my ($self, $sub_name) = @_;
sprintf "%s::%s", $self->{_package}, $sub_name;
return sprintf( "%s::%s", $self->{_package}, $sub_name );
}

sub _valid_package {
defined($_[0]) && $_[0] =~ /^[a-z_]\w*(?:::\w+)*$/i;
my $name = shift;
return unless defined $name && length $name;
return $name =~ /^[a-z_]\w*(?:::\w+)*$/i;
}

sub _valid_subname {
$_[0] =~ /^[a-z_]\w*$/i;
my $name = shift;
return unless defined $name && length $name;
return $name =~ /^[a-z_]\w*$/i;
}

sub _replace_sub {
my ($sub_name, $coderef) = @_;

no warnings 'redefine';
no warnings 'prototype';
no warnings qw< redefine prototype >;

if (defined $coderef) {
*{$sub_name} = $coderef;
Expand All @@ -240,7 +248,7 @@ sub _replace_sub {
undef *$sub_name;

# restore everything except the code slot
return unless keys %slot;
return unless scalar keys %slot;
foreach (keys %slot) {
*$sub_name = $slot{$_};
}
Expand Down
Loading