view release on metacpan or  search on metacpan

local/lib/perl5/Test/Spec/Mocks.pm  view on Meta::CPAN

    $self;
  }

  # ensures that the expected method is called at least N times
  sub at_least {
    my $self = shift;
    my $n_times = shift;
    if (!defined($n_times) || $n_times !~ /^\A\d+\z/) {
      Carp::croak "Usage: ->at_least(INTEGER)";
    }
    $self->_check_call_count(sub {
      if ($self->_call_count < $n_times) {
        return $self->_times($n_times, "at least $n_times %times");
      }
    });
    $self;
  }

  sub at_least_once {
    my $self = shift;
    return $self->at_least(1);
  }

  # ensures that the expected method is called at most N times
  sub at_most {
    my $self = shift;
    my $n_times = shift;
    if (!defined($n_times) || $n_times !~ /^\A\d+\z/) {
      Carp::croak "Usage: ->at_most(INTEGER)";
    }
    $self->_check_call_count(sub {
      if ($self->_call_count > $n_times) {
        return $self->_times($n_times, "at most $n_times %times");
      }
    });
    $self;
  }

  sub at_most_once {
    my $self = shift;
    return $self->at_most(1);
  }

  sub maybe {
    my $self = shift;
    return $self->at_most_once;
  }

  sub any_number {
    my $self = shift;
    $self->_check_call_count(sub {});
    $self;
  }

  # dummy method for syntactic sugar
  sub times {
    my $self = shift;
    $self;
  }

  sub verify {
    my $self = shift;
    my @msgs = $self->problems;
    die join("\n", @msgs) if @msgs;
    return 1;
  }

  sub problems {
    my $self = shift;
    my @prob;
    if (my $message = $self->_check_call_count->()) {
      push @prob, $self->_times(
        $self->_call_count,
        "expected %s to be called %s, but it was called %d %times\n",
        $self->_method, $message, $self->_call_count,
      );
    }
    for my $message ($self->_check_eq_args) {
      push @prob, $message;
    }
    for my $message ($self->_check_deep_args) {
      push @prob, $message;
    }
    return @prob;
  }

  sub setup {
    my $self = shift;
    if ($Debug) {
      print STDERR "Setting up stub for @{[ $self->_target ]}->@{[ $self->_method ]}\n";
    }

    # both these methods set _replaced_qualified_name and
    # _original_code, which we'll use in teardown()
    if (ref $self->_target) {
      $self->_replace_instance_method;
    }
    else {
      $self->_replace_class_method;
    }
  }

  sub teardown {
    my $self = shift;

    if ($Debug) {
      print STDERR "Tearing down stub for @{[ $self->_target ]}->@{[ $self->_method ]}\n";
    }

    no strict 'refs';
    no warnings 'redefine';

    if ($self->_original_code) {
      *{ $self->_replaced_qualified_name } = $self->_original_code;
    }
    else {
      # avoid nuking aliases (including our _retval) by assigning a blank sub first.
      # this technique stolen from ModPerl::Util::unload_package_pp
      *{ $self->_replaced_qualified_name } = sub {};

      # Simply undefining &foo breaks in some cases by leaving some Perl
      # droppings that cause subsequent calls to this function to die with
      # "Not a CODE reference". It sounds harmless until Perl tries to
      # call this method in an inheritance chain. Using Package::Stash solves
      # that problem.  It actually clones the original glob, leaving out the
      # part being deleted.
      require Package::Stash;
      my $stash = Package::Stash->new($self->_target_class);
      $stash->remove_symbol('&' . $self->_method);
    }

    $self->verify unless $self->_canceled;
  }

  sub _replaced_qualified_name {
    my $self = shift;
    return join("::", $self->_target_class, $self->_method);
  }

  sub _replace_instance_method {
    no strict 'refs';
    no warnings qw(uninitialized);

    my $self = shift;
    my $target = $self->_target;
    my $class = ref($target);
    my $dest = join("::", $class, $self->_method);
    my $original_method = $class->can($self->_method);

    # save to be restored later
    $self->_target_class($class);
    $self->_original_code($original_method);

    $self->_install($dest => sub {
      # Use refaddr() to prevent an overridden equality operator from
      # making two objects appear equal when they are only equivalent.
      if (Scalar::Util::refaddr($_[0]) == Scalar::Util::refaddr($target)) {
        # do extreme late binding here, so calls to returns() after the
        # mock has already been installed will take effect.
        my @args = @_;
        shift @args;
        $self->_called(@args);
        die $self->_exception if $self->_exception;
        return $self->_retval->(@_);
      }
      elsif (!$original_method) {
        # method didn't exist before, mimic Perl's behavior
        Carp::croak sprintf("Can't locate object method \"%s\" " .
                            "via package \"%s\"", $self->_method, $class);
      }
      else {
        # run the original as if we were never here.
        # to that end, use goto to prevent the extra stack frame
        goto $original_method;
      }
    });
  }

  sub _replace_class_method {
    no strict 'refs';

    my $self = shift;
    my $dest = join("::", $self->_target, $self->_method);

    $self->_target_class($self->_target);
    $self->_original_code(defined(&$dest) ? \&$dest : undef);

    $self->_install($dest => sub {
      # do extreme late binding here, so calls to returns() after the
      # mock has already been installed will take effect.
      my @args = @_;
      shift @args;

local/lib/perl5/Test/Spec/Mocks.pm  view on Meta::CPAN

This is just syntactic sugar for C<at_least(1)>.

=item at_most($N)

Configures the mocked method so that it must be called no more than $N times.

=item at_most_once

Configures the mocked method so that it must be called either zero or 1
times.

=item maybe

An alias for L</at_most_once>.

=item any_number

Configures the mocked method so that it can be called zero or more times.

=item times

A syntactic sugar no-op:

  $io->expects('print')->exactly(3)->times;

I<This method is alpha and will probably change in a future release.>

=item with(@arguments) / with_eq(@arguments)

Configures the mocked method so that it must be called with arguments as
specified. The arguments will be compared using the "eq" operator, so it works
for most scalar values with no problem. If you want to check objects here,
they must be the exact same instance or you must overload the "eq" operator to
provide the behavior you desire.

=item with_deep(@arguments)

Similar to C<with_eq> except the arguments are compared using L<Test::Deep>: scalars are
compared by value, arrays and hashes must have the same elements and references
must be blessed into the same class.

    $cache->expects('set')
          ->with_deep($customer_id, { name => $customer_name });

Use L<Test::Deep>'s comparison functions for more flexibility:

    use Test::Deep::NoTest ();
    $s3->expects('put')
       ->with_deep('test-bucket', 'my-doc', Test::Deep::ignore());

=item raises($exception)

Configures the mocked method so that it raises C<$exception> when called.

=back

=head1 OTHER EXPECTATION METHODS

=over 4

=item verify

Allows you to verify manually that the expectation was met. If the expectation
has not been met, the method dies with an error message containing specifics
of the failure.  Returns true otherwise.

=item problems

If the expectation has not been met, returns a list of problem description
strings. Otherwise, returns an empty list.

=back

=head1 KNOWN ISSUES

=over 4

=item Memory leaks

Because of the way the mock objects (C<stubs>, C<stub>, C<expects>, and C<mock>)
are integrated into the Test::Spec runtime they will leak memory. It is
not recommended to use the Test::Spec mocks in any long-running program.

Patches welcome.

=back

=head1 SEE ALSO

There are other less sugary mocking systems for Perl, including
L<Test::MockObject> and L<Test::MockObject::Extends>.

This module is a plugin for L<Test::Spec>.  It is inspired by
L<Mocha|http://mocha.rubyforge.org/>.

The Wikipedia article L<Mock object|http://en.wikipedia.org/wiki/Mock_object>
is very informative.

=head1 AUTHOR

Philip Garrett, <philip.garrett@icainformatics.com>

=head1 COPYRIGHT & LICENSE

Copyright (c) 2011 by Informatics Corporation of America.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut