use 5.006;
our $VERSION = 0.04;
our @EXPORT = qw( diag note );
our @EXPORT_OK;
build_refute is => sub {
my ($got, $exp) = @_;
if (defined $got xor defined $exp) {
return "unexpected ". to_scalar($got, 0);
};
return '' if !defined $got or $got eq $exp;
return sprintf "Got: %s\nExpected: %s"
, to_scalar($got, 0), to_scalar($exp, 0);
}, args => 2, export => 1;
build_refute isnt => sub {
my ($got, $exp) = @_;
return if defined $got xor defined $exp;
return "Unexpected: ".to_scalar($got)
if !defined $got or $got eq $exp;
}, args => 2, export => 1;
build_refute ok => sub {
my $got = shift;
return !$got;
}, args => 1, export => 1;
build_refute use_ok => sub {
my ($mod, @arg) = @_;
my $caller = caller(1);
eval "package $caller; use $mod \@arg; 1" and return '';
return "Failed to use $mod: ".($@ || "(unknown error)");
}, list => 1, export => 1;
build_refute require_ok => sub {
my ($mod, @arg) = @_;
my $caller = caller(1);
eval "package $caller; require $mod; 1" and return '';
return "Failed to require $mod: ".($@ || "(unknown error)");
}, args => 1, export => 1;
my %compare;
$compare{$_} = eval "sub { return \$_[0] $_ \$_[1]; }"
for qw( < <= == != >= > lt le eq ne ge gt );
my %numeric;
$numeric{$_}++ for qw( < <= == != >= > );
build_refute cmp_ok => sub {
my ($x, $op, $y) = @_;
my $fun = $compare{$op};
croak "cmp_ok(): Comparison '$op' not implemented"
unless $fun;
my @missing;
if ($numeric{$op}) {
push @missing, '1 '.to_scalar($x).' is not numeric'
unless looks_like_number $x or blessed $x;
push @missing, '2 '.to_scalar($y).' is not numeric'
unless looks_like_number $y or blessed $y;
} else {
push @missing, '1 is undefined' unless defined $x;
push @missing, '2 is undefined' unless defined $y;
};
return "cmp_ok '$op': argument ". join ", ", @missing
if @missing;
return '' if $fun->($x, $y);
return "$x\nis not '$op'\n$y";
}, args => 3, export => 1;
build_refute like => sub {
_like_unlike( $_[0], $_[1], 0 );
}, args => 2, export => 1;
build_refute unlike => sub {
_like_unlike( $_[0], $_[1], 1 );
}, args => 2, export => 1;
sub _like_unlike {
my ($str, $reg, $reverse) = @_;
$reg = qr#^(?:$reg)$# unless ref $reg eq 'Regexp';
return 'unexpected undef' if !defined $str;
return '' if $str =~ $reg xor $reverse;
return "$str\n".($reverse ? "unexpectedly matches" : "doesn't match")."\n$reg";
};
build_refute can_ok => sub {
my $class = shift;
croak ("can_ok(): no methods to check!")
unless @_;
return 'undefined' unless defined $class;
return 'Not an object: '.to_scalar($class)
unless UNIVERSAL::can( $class, "can" );
my @missing = grep { !$class->can($_) } @_;
return @missing && (to_scalar($class, 0)." has no methods ".join ", ", @missing);
}, list => 1, export => 1;
build_refute isa_ok => \&_isa_ok, args => 2, export => 1;
build_refute new_ok => sub {
my ($class, $args, $target) = @_;
croak ("new_ok(): at least one argument must be present")
unless defined $class;
croak ("new_ok(): too many arguments")
if @_ > 3;
$args ||= [];
$class = ref $class || $class;
$target ||= $class;
return "Not a class: ".to_scalar($class, 0)
unless UNIVERSAL::can( $class, "can" );
return "Class has no 'new' method: ".to_scalar( $class, 0 )
unless $class->can( "new" );
return _isa_ok( $class->new( @$args ), $target );
}, list => 1, export => 1;
sub _isa_ok {
my ($obj, $class) = @_;
croak 'isa_ok(): No class supplied to check against'
unless defined $class;
return "undef is not a $class" unless defined $obj;
$class = ref $class || $class;
if (
(UNIVERSAL::can( $obj, "isa" ) && !$obj->isa( $class ))
|| !UNIVERSAL::isa( $obj, $class )
) {
return to_scalar( $obj, 0 ) ." is not a $class"
};
return '';
};
build_refute contract_is => sub {
my ($c, $sig) = @_;
my $got = $c->get_sign;
return $got ne $sig && <<"EOF".$c->get_tap;
Unexpected subcontract signature.
Got: $got
Expected: $sig
Execution log:
EOF
}, args => 2, export => 1;
sub diag (@) {
current_contract->diag(@_);
};
sub note (@) {
current_contract->note(@_);
};
push @EXPORT_OK, qw(deep_diff);
build_refute is_deeply => sub {
my $diff = deep_diff( shift, shift );
return unless $diff;
return "Structures differ (got != expected):\n$diff";
}, export => 1, args => 2;
sub deep_diff {
my ($old, $new, $known, $path) = @_;
$known ||= {};
$path ||= '&';
if (ref $old ne ref $new or (defined $old xor defined $new)) {
return join "!=", to_scalar($old), to_scalar($new);
};
return '' unless defined $old;
if (!ref $old) {
return $old ne $new && join "!=", to_scalar($old), to_scalar($new),
};
if (my $new_path = $known->{refaddr $new}) {
my $old_path = $known->{-refaddr($old)};
return to_scalar($old)."!=$new_path" unless $old_path;
return $old_path ne $new_path && "$old_path!=$new_path";
};
$known->{-refaddr($old)} = $path;
$known->{refaddr $new} = $path;
if (UNIVERSAL::isa( $old , 'ARRAY') ) {
my @diff;
for (my $i = 0; $i < @$old || $i < @$new; $i++ ) {
my $off = deep_diff( $old->[$i], $new->[$i], $known, $path."[$i]" );
push @diff, "$i:$off" if $off;
};
return @diff ? _array2str( \@diff, ref $old ) : '';
};
if (UNIVERSAL::isa( $old, 'HASH') ) {
my ($both_k, $old_k, $new_k) = _both_keys( $old, $new );
my %diff;
$diff{$_} = to_scalar( $old->{$_} )."!=(none)" for @$old_k;
$diff{$_} = "(none)!=".to_scalar( $new->{$_} ) for @$new_k;
foreach (@$both_k) {
my $off = deep_diff( $old->{$_}, $new->{$_}, $known, $path."{$_}" );
$diff{$_} = $off if $off;
};
return %diff ? _hash2str( \%diff, ref $old ) : '';
};
$old = to_scalar($old);
$new = to_scalar($new);
return $old ne $new && join "!=", $old, $new;
};
sub _hash2str {
my ($hash, $type) = @_;
$type = '' if $type eq 'HASH';
return $type.'{'
. join(", ", map { to_scalar($_, 0).":$hash->{$_}" } sort keys %$hash)
."}";
};
sub _array2str {
my ($array, $type) = @_;
$type = '' if $type eq 'ARRAY';
return "$type\[".join(", ", @$array)."]";
};
sub _both_keys {
my ($old, $new) = @_;
my %uniq;
$uniq{$_}++ for keys %$new;
$uniq{$_}-- for keys %$old;
my (@o_k, @n_k, @b_k);
foreach (sort keys %uniq) {
if (!$uniq{$_}) {
push @b_k, $_;
}
elsif ( $uniq{$_} < 0 ) {
push @o_k, $_;
}
else {
push @n_k, $_;
};
};
return (\@b_k, \@o_k, \@n_k);
};
1;