/lib/Test/Pockito/DefaultMatcher.pm
Perl | 165 lines | 111 code | 53 blank | 1 comment | 12 complexity | f04a400d2d31601e219af9e303448158 MD5 | raw file
Possible License(s): BSD-3-Clause
- package Test::Pockito::DefaultMatcher;
- use strict;
- use warnings;
- use Scalar::Util::Reftype;
- use Exporter 'import';
- =head1 NAME
- Test::Pockito::DefaultMatcher
- =head1 SYNOPSIS
- Default matching for Pockito
- =head1 DESCRIPTION
- Default implementation of matching. If none of the any_* subs are used for matching, then it reverts to a ne op for matching.
- =head1 SUBROUTINES
- =over 1
- =item default_call_match( $package, $method, \@params_found, \@params_expected )
- This is the default matching metchanism for Pockito though you are at will to implement your own. Passing an implementation with this signature overrides the matching sub. The default implementation does not use $package nor $method, but they will be of use if you have multiple, different ways to define parameters as equal.
- =back
- =cut
- our %lookup = ();
- our @EXPORT_OK = qw(is_defined);
- sub default_call_match {
- my $package = shift;
- my $method = shift;
- my $param_found_ref = shift;
- my $param_expected_ref = shift;
- my (@left) = @{$param_found_ref};
- my (@right) = @{$param_expected_ref};
- if ( $#left < $#right ) {
- (@left) = @{$param_expected_ref};
- (@right) = @{$param_found_ref};
- }
- foreach my $y ( 0 .. $#left ) {
- my $l = $left[$y] || 0;
- my $r = $right[$y] || 0;
- if ( exists $lookup{$l} ) {
- return 0 if !&{ $lookup{$l} }($r);
- }
- elsif ( exists $lookup{$r} ) {
- return 0 if !&{ $lookup{$r} }($l);
- }
- elsif ( $l ne $r ) {
- return 0;
- }
- }
- return 1;
- }
- =head1 MATCHERS
- All the following matchers can be exported or refered to by package name. They use Scalar::Util::Reftype under the hood except for is_defined.
- is_defined
- is_scalar
- is_array
- is_hash
- is_code
- is_global
- is_lvalue
- is_regexp
- is_scalar_object
- is_array_object
- is_hash_object
- is_code_object
- is_glob_object
- is_lvalue_object
- is_ref_object
- is_io_object
- is_regexp_object
- With these, one can write:
- $pocket->when( $mock->( is_defined, is_regexp, 1, 2, is_code_object )->...
- to match
- any defined value
- any regular expression ref
- the value 1
- the value 2
- any blessed code ref
- =cut
- our @types =
- qw(scalar array hash code global lvalue regexp scalar_object array_object hash_object code_object glob_object lvalue_object ref_object io_object regexp_object);
- foreach my $type (@types) {
- #Going to hell for this.
- my $sub_name = __PACKAGE__ . "::is_" . $type;
- my $check = sub {
- return reftype(shift)->$type();
- };
- my $wrapper = sub { return $check };
- no strict "refs";
- *$sub_name = $wrapper;
- use strict "refs";
- $lookup{$check} = $check;
- push( @EXPORT_OK, "is_" . $type );
- }
- sub check_is_defined {
- return defined shift;
- }
- sub is_defined {
- return \&check_is_defined;
- }
- $lookup{ \&check_is_defined } = \&check_is_defined;
- =head1 SUPPORT
- exussum@gmail.com
- =head1 AUTHOR
- Spencer Portee
- CPAN ID: EXUSSUM
- exussum@gmail.com
- =head1 SOURCE
- http://bitbucket.org/exussum/pockito/
- =head1 COPYRIGHT
- This program is free software licensed under the...
- The BSD License
- The full text of the license can be found in the
- LICENSE file included with this module.
- =head1 SEE ALSO
- perl(1).
- =cut
- 1;