File Coverage

blib/lib/Test/Struct.pm

Criterion	Covered	Total	%
statement	97	138	70.2
branch	23	66	34.8
condition	16	37	43.2
subroutine	18	22	81.8
pod	1	3	33.3
total	155	266	58.2

package Test::Struct;
use strict;
use warnings;
require overload;
require Exporter;
use vars qw(@ISA @EXPORT_OK @EXPORT $VERSION);
use Scalar::Util qw(refaddr reftype blessed isweak readonly tainted);
use List::Util qw(max min);
use Data::Dumper;
use Test::Builder;
use Test::More;

my $Test = Test::Builder->new;
@ISA = qw(Exporter);
@EXPORT_OK = ('deep_eq');
@EXPORT = ('deep_eq');

$VERSION = '0.01';

BEGIN {
    # no-op regex if we can't find DDS
    eval "sub regex { return }"
        unless eval "use Data::Dump::Streamer qw(regex); 1"
}

sub import {
    my($self) = shift;
    my $pack = caller;

    my (@plan,@import);
    my $i=0;
    while ($i<@_) {
        my $arg=$_[$i++];
        if ($arg=~/^(no_plan|skip_all)$/) {
            push @plan,$arg;
        } elsif($arg eq 'tests') {
            push @plan,$arg,$_[$i++];
        } elsif($arg eq 'import') {
            push @import,@{$_[$i++]};
        } else {
            push @import,$arg;
        }
    }
    $Test->exported_to($pack);
    $Test->plan(@plan);
    $self->export_to_level(1, $self,@import);
}

# private utility subs
sub _qquote {
    return defined $_[0] ? Data::Dumper::qquote($_[0]) : 'undef';
}

sub _safe {
    return defined $_[0] ? $_[0] : 'undef';
}

sub _msg {
    my $msg=shift;
    my $noqquote;
    if (@_>2) { $noqquote=pop; }
    return "$msg: ".
            join " ne ",
            map { $noqquote ? _safe($_)
                            : _qquote($_) } @_
}
sub _a { my $str=shift; $str=~s/\$o/\$got/g; $str }
sub _b { my $str=shift; $str=~s/\$o/\$expected/g; $str }

sub _subscr {
    my ($v,$script)=@_;
    if ($v=~/^\$\{.*\}$/ or $v=~/\w$/) {
        $v.="->".$script;
    } else {
        $v.=$script
    }
    return $v
 }



sub _bool_ne {
    my ($t1,$t2,$name,$n,$error)=@_;
    my $nok = !$t1 != !$t2;
    if ($nok) {
        push @$error,"at "._a($n)
               .($t1 ? ' not expecting ' : ' expecting ')
               ."$name.";
    }
    return $nok;
}

sub _ne {
    my ($t1,$t2,$name,$n,$error)=@_;
    my $nok = $t1 ne $t2;
    if ($nok) {
        push @$error,"at "._a($n)
                    ." expecting $name "._qquote($t2)
                    ." but got "._qquote($t1).".";
    }
    return $nok;
}


# main worker sub
sub deep_ne_list {
    my ($o1,$o2,$n,$state)=@_;
    $state||={};
    $n||='$o';

    my @error;

    # make sure they are both defined
    _bool_ne(defined($o1),defined($o2),"defined value",$n,\@error)
        and return @error;

    return if !defined($o1); # return if they are undef

    my $ra1=refaddr \$_[0];
    my $ra2=refaddr \$_[1];

    return if $state->{sv_seen1}{$ra1} &&
              $state->{sv_seen2}{$ra2} &&
              $state->{sv_seen1}{$ra1} eq
              $state->{sv_seen2}{$ra2};

    my $t1=($state->{sv_seen1}{$ra1}||=$n);
    my $t2=($state->{sv_seen2}{$ra2}||=$n);


    if ($t1 ne $t2) {
        if ($t1 eq $n) {
            return "expected to have seen "._a($n)
                  ." before at "._a($t2).".";
        } elsif ($t2 eq $n) {
            return "not expected to have seen "._a($n)
                  ." before at "._a($t1).".";
        } else {
            return "expected to have seen "._a($n)
                  ." before at ".a_($t2)
                  ." but saw it in "._a($t1)
                  ." instead.";
        }
     }


    _bool_ne(readonly($_[0]),readonly($_[1]),"a readonly value",$n,\@error);
    _bool_ne(tainted($_[0]),tainted($_[1]),"a tainted value",$n,\@error);
    _bool_ne(!!ref($o1),!!ref($o2),"value isa reference",$n,\@error)
        and return @error;


    if (!ref($o1)) {
        _ne($o1,$o2,"value of",$n,\@error);
        return @error;
    }

    #################################################################
    # We are dealing with a ref.
    $ra1=refaddr($o1);
    $ra2=refaddr($o2);
    return if $state->{rv_seen1}{$ra1} &&
              $state->{rv_seen2}{$ra2} &&
              $state->{rv_seen1}{$ra1} eq
              $state->{rv_seen2}{$ra2};

    $t1=($state->{rv_seen1}{$ra1}||=$n);
    $t2=($state->{rv_seen2}{$ra2}||=$n);

    if ($t1 ne $t2) {
        if ($t1 eq $n) {
            return "expected to have seen reference in "._a($n)
                  ." before at "._a($t2).".";
        } elsif ($t2 eq $n) {
            return "not expected to have seen reference in "._a($n)
                  ." before at "._a($t1).".";
        } else {
            return "expected to have seen reference in "._a($n)
                  ." before at ".a_($t2)." but saw it in "._a($t1)
                  ." instead."
        }
    }


    $t1=blessed($o1);
    $t2=blessed($o2);

    _bool_ne(defined($t1),defined($t2),"a blessed ref",$n,\@error);
    _ne($t1,$t2," object of class ",$n,\@error)
        if defined $t1;
    _bool_ne(isweak($_[0]),isweak($_[1]),"weak ref",$n,\@error);

    my $rt=reftype($o1);
    $t2=reftype($o2);

    # Can't procede further if they are different reftypes
    # No point in comparing arrays to hashes.
    _ne($rt,$t2,"reftype",$n,\@error)
        and return @error;


    if ($rt eq 'ARRAY') {
        my $min=min(0+@$o1,0+@$o2);
        _ne(0+@$o1,0+@$o2,"element count of","\@{".$n."}",\@error);
        for my $idx (0..$min-1) {
            push @error, deep_ne_list($o1->[$idx],$o2->[$idx],
                          $n."->[$idx]",$state);
        }
    } elsif ($rt eq 'HASH') {
        # Its a hash. get a list of all the keys in both
        # hashes, and then cycle through them checking
        # for equivelence.
        my %dupe;
        my @all=grep !$dupe{$_}++,keys %$o1,keys %$o2;
        foreach my $key (@all) {

            _bool_ne(exists($o1->{$key}),exists($o2->{$key}),
                     "key "._qquote($key),"%{".$n."}",\@error)
                and next;
            push @error,deep_ne_list($o1->{$key},$o2->{$key},
                          _subscr($n,"{"._qquote($key)."}"),$state);
        }
    } elsif ($rt eq 'REF' or $rt eq 'SCALAR') {
        $t1=regex($_[0]);
        $t2=regex($_[1]);
        _bool_ne($t1,$t2,"regex",$n,\@error);
        if($t1 && $t2) {
            _ne($t1,$t2,"pattern",$n,\@error);
        } else {
            push @error, deep_ne_list($$o1,$$o2,"\${".$n."}",$state);
        }
    } else {
        die "Whoah nelly! This is just a prototype. Can't handle reftype '$rt'";
    }
    return @error;
}

sub deep_eq($$;$) {
    my $name;
    # strip off the name if there is one
    $name = pop @_ if @_==3;
    my @errors=deep_ne_list(@_);
    local $Test::Builder::Level=2;
    ok(!@errors,$name);
    diag(join "\n",@errors) if @errors;
    return !@errors;
}


1;
__END__