File Coverage

blib/lib/Test/Unit/Assert.pm

Criterion	Covered	Total	%
statement	215	232	92.6
branch	100	116	86.2
condition	49	64	76.5
subroutine	35	37	94.5
pod	7	14	50.0
total	406	463	87.6

package Test::Unit::Assert;
BEGIN {
  $Test::Unit::Assert::VERSION = '0.25_1325'; # added by dist-tools/SetVersion.pl
}


use strict;

use Test::Unit::Debug qw(debug);
use Test::Unit::Failure;
use Test::Unit::Error;
use Test::Unit::Exception;

use Test::Unit::Assertion::CodeRef;

use Error qw/:try/;
use Carp;

sub assert {
    my $self = shift;
    my $assertion = $self->normalize_assertion(shift);
    $self->do_assertion($assertion, (caller($Error::Depth))[0 .. 2], @_);
}

sub normalize_assertion {
    my $self      = shift;
    my $assertion = shift;

    if (!ref($assertion) || ref($assertion) =~ 'ARRAY') {
        debug((defined $assertion ? $assertion : '_undef_') .
              " normalized as boolean\n");
        require Test::Unit::Assertion::Boolean;
        return Test::Unit::Assertion::Boolean->new($assertion);
    }

    # If we're this far, we must have a reference.

    if (eval {$assertion->isa('Regexp')}) {
        debug("$assertion normalized as Regexp\n");
        require Test::Unit::Assertion::Regexp;
        return Test::Unit::Assertion::Regexp->new($assertion);
    }

    if (ref($assertion) eq 'CODE') {
        debug("$assertion normalized as coderef\n");
        require Test::Unit::Assertion::CodeRef;
        return Test::Unit::Assertion::CodeRef->new($assertion);
    }

#   if (ref($assertion) eq 'SCALAR') {
#       debug("$assertion normalized as scalar ref\n");
#       require Test::Unit::Assertion::Scalar;
#       return Test::Unit::Assertion::Scalar->new($assertion);
#   }

    if (ref($assertion) !~ /^(GLOB|LVALUE|REF|SCALAR)$/) {
        debug("$assertion already an object\n");
        require Test::Unit::Assertion::Boolean;
        return $assertion->can('do_assertion') ? $assertion :
            Test::Unit::Assertion::Boolean->new($assertion);
    }
    else {
        die "Don't know how to normalize $assertion (ref ", ref($assertion), ")\n";
    }
}

sub assert_raises {
    my $self = shift;
    require Test::Unit::Assertion::Exception;
    my $assertion = Test::Unit::Assertion::Exception->new(shift);
    my ($asserter, $file, $line) = caller($Error::Depth);
    my $exception =
      $self->do_assertion($assertion, (caller($Error::Depth))[0 .. 2], @_);
}

sub do_assertion {
    my $self      = shift;
    my $assertion = shift;
    my $asserter  = shift;
    my $file      = shift;
    my $line      = shift;
    debug("Asserting [$assertion] from $asserter in $file line $line\n");
    my @args = @_;
    try { $assertion->do_assertion(@args) }
    catch Test::Unit::Exception with {
        my $e = shift;
        debug("  Caught $e, rethrowing from $asserter, $file line $line\n");
        $e->throw_new(-package => $asserter,
                      -file    => $file,
                      -line    => $line,
                      -object  => $self);
    }
}

sub multi_assert {
    my $self = shift;
    my ($assertion, @argsets) = @_;
    my ($asserter, $file, $line) = caller($Error::Depth);
    foreach my $argset (@argsets) {
        try {
            $self->assert($assertion, @$argset);
        }
        catch Test::Unit::Exception with {
            my $e = shift;
            debug("  Caught $e, rethrowing from $asserter, $file line $line\n");
            $e->throw_new(-package => $asserter,
                          -file    => $file,
                          -line    => $line,
                          -object  => $self);
        }
    }
}

sub is_numeric {
    my $str = shift;
    local $^W;

    if (defined $str && $str =~ /^0x[A-Fa-f0-9]/) {
	# This is harsh but anything else risks brushing a problem
	# under the carpet.  Best to make the caller to review the
	# situation and maintain the test code.
	die "Testing '$str' for is_numeric is ambiguous.  It may give different results on various platform combinations - this is a liability for testing so we barfed";
    }

    return defined $str && ! ($str == 0 && $str !~ /^\s*[+-]?0(e0)?\s*$/i);
}

# First argument determines the comparison type.
sub assert_equals {
    my $self = shift;
    my($asserter, $file, $line) = caller($Error::Depth);
    my @args = @_;
    try {
        if (! defined($args[0]) and ! defined($args[1])) {
            # pass
        }
        elsif (defined($args[0]) xor defined($args[1])) {
            $self->fail('one arg was not defined');
        }
        elsif (is_numeric($args[0])) {
            $self->assert_num_equals(@args);
        }
        elsif (eval {ref($args[0]) && $args[0]->isa('UNIVERSAL')}) {
            require overload;
            if (overload::Method($args[0], '==')) {
                $self->assert_num_equals(@args);
            }
            else {
                $self->assert_str_equals(@args);
            }
        }
        else {
            $self->assert_str_equals(@args);
        }
    }
    catch Test::Unit::Exception with {
        my $e = shift;
        $e->throw_new(-package => $asserter,
                      -file    => $file,
                      -line    => $line,
                      -object  => $self);
    }
}

sub ok { # To make porting from Test easier
    my $self = shift;
    my @args = @_;
    local $Error::Depth = $Error::Depth + 1;
    if (@args == 1) {
	$self->assert($args[0]); # boolean assertion
    }
    elsif (@args >= 2 && @args <= 3) {
	if (ref($args[0]) eq 'CODE') {
	    my $code     = shift @args;
            my $expected = shift @args;
	    $self->assert_equals($expected, $code->(), @args);
	}
	elsif (eval {$args[1]->isa('Regexp')}) {
	    my $got = shift @args;
	    my $re  = shift @args;
	    $self->assert($re, $got, @args);
	}
	else {
	    my $got 	 = shift @args;
	    my $expected = shift @args;
            $self->assert_equals($expected, $got, @args);
	}
    }
    else {
	$self->error('ok() called with wrong number of args');
    }
}

sub assert_not_equals {
    my $self = shift;
    my($asserter,$file,$line) = caller($Error::Depth);
    my @args = @_;
    try {
        if (! defined($args[0]) && ! defined($args[1])) {
            my $first  = shift @args;
            my $second = shift @args;
            $self->fail(@args ? join('', @args) : 'both args were undefined');
        }
        elsif (defined($args[0]) xor defined($args[1])) {
            # succeed
        }
        elsif (is_numeric($args[0])) {
            $self->assert_num_not_equals(@args);
        }
        elsif (eval {ref($args[0]) && $args[0]->isa('UNIVERSAL')}) {
            require overload;
            if (overload::Method($args[0], '==')) {
                $self->assert_num_not_equals(@args);
            }
            else {
                $self->assert_str_not_equals(@args);
            }
        }
        else {
            $self->assert_str_not_equals(@args);
        }
    }
    catch Test::Unit::Exception with {
        my $e = shift;
        $e->throw_new(-package => $asserter,
                      -file    => $file,
                      -line    => $line,
                      -object  => $self,);
    };
}

# Shamelessly pinched from Test::More and adapted to Test::Unit.
our %Seen_Refs = ();
our @Data_Stack;
my $DNE = bless [], 'Does::Not::Exist';
sub assert_deep_equals {
    my $self = shift;
    my $this = shift;
    my $that = shift;

    local $Error::Depth = $Error::Depth + 1;

    if (! ref $this || ! ref $that) {
        Test::Unit::Failure->throw(
            -text => @_ ? join('', @_)
                        : 'Both arguments were not references'
        );
    }

    local @Data_Stack = ();
    local %Seen_Refs = ();
    if (! $self->_deep_check($this, $that)) {
        Test::Unit::Failure->throw(
            -text => @_ ? join('', @_)
                        : $self->_format_stack(@Data_Stack)
        );
    }
}

sub _deep_check {
    my $self = shift;
    my ($e1, $e2) = @_;

    if ( ! defined $e1 || ! defined $e2 ) {
        return 1 if !defined $e1 && !defined $e2;
        push @Data_Stack, { vals => [$e1, $e2] };
        return 0;
    }

    return 0 if ( (defined $e1 && $e1 eq $DNE)
                  || (defined $e2 && $e2 eq $DNE ));

    return 1 if $e1 eq $e2;
    if ( ref $e1 && ref $e2 ) {
        my $e2_ref = "$e2";
        return 1 if defined $Seen_Refs{$e1} && $Seen_Refs{$e1} eq $e2_ref;
        $Seen_Refs{$e1} = $e2_ref;
    }

    if (UNIVERSAL::isa($e1, 'ARRAY') and UNIVERSAL::isa($e2, 'ARRAY')) {
        return $self->_eq_array($e1, $e2);
    }
    elsif (UNIVERSAL::isa($e1, 'HASH') and UNIVERSAL::isa($e2, 'HASH')) {
        return $self->_eq_hash($e1, $e2);
    }
    elsif (UNIVERSAL::isa($e1, 'REF') and UNIVERSAL::isa($e2, 'REF')) {
        push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
        my $ok = $self->_deep_check($$e1, $$e2);
        pop @Data_Stack if $ok;
        return $ok;
    }
    elsif (UNIVERSAL::isa($e1, 'SCALAR') and UNIVERSAL::isa($e2, 'SCALAR')) {
        push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
        return $self->_deep_check($$e1, $$e2);
    }
    else {
        push @Data_Stack, { vals => [$e1, $e2] };
        return 0;
    }
}

sub _eq_array  {
    my $self = shift;
    my($a1, $a2) = @_;
    return 1 if $a1 eq $a2;

    my $ok = 1;
    my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
    for (0..$max) {
        my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
        my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];

        push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] };
        $ok = $self->_deep_check($e1,$e2);
        pop @Data_Stack if $ok;

        last unless $ok;
    }
    return $ok;
}

sub _eq_hash {
    my $self = shift;
    my($a1, $a2) = @_;
    return 1 if $a1 eq $a2;

    my $ok = 1;
    my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
    foreach my $k (keys %$bigger) {
        my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
        my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;

        push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] };
        $ok = $self->_deep_check($e1, $e2);
        pop @Data_Stack if $ok;

        last unless $ok;
    }

    return $ok;
}

sub _format_stack {
    my $self = shift;
    my @Stack = @_;

    my $var = '$FOO';
    my $did_arrow = 0;
    foreach my $entry (@Stack) {
        my $type = $entry->{type} || '';
        my $idx  = $entry->{'idx'};
        if( $type eq 'HASH' ) {
            $var .= "->" unless $did_arrow++;
            $var .= "{$idx}";
        }
        elsif( $type eq 'ARRAY' ) {
            $var .= "->" unless $did_arrow++;
            $var .= "[$idx]";
        }
        elsif( $type eq 'REF' ) {
            $var = "\${$var}";
        }
    }

    my @vals = @{$Stack[-1]{vals}}[0,1];

    my @vars = ();
    ($vars[0] = $var) =~ s/\$FOO/  \$a/;
    ($vars[1] = $var) =~ s/\$FOO/  \$b/;

    my $out = "Structures begin differing at:\n";
    foreach my $idx (0..$#vals) {
        my $val = $vals[$idx];
        $vals[$idx] = !defined $val ? 'undef' :
                      $val eq $DNE  ? "Does not exist"
                                    : "'$val'";
    }

    $out .= "$vars[0] = $vals[0]\n";
    $out .= "$vars[1] = $vals[1]\n";

    return $out;
}

{
    my %assert_subs = (
        str_equals => sub {
            my $str1 = shift;
            my $str2 = shift;
            defined $str1 or
              Test::Unit::Failure->throw(
                  -text => @_ ? join('',@_) :
                    "expected value was undef; should be using assert_null?"
              );
            defined $str2 or
              Test::Unit::Failure->throw(
                  -text => @_ ? join('',@_) : "expected '$str1', got undef"
              );
            $str1 eq $str2 or
              Test::Unit::Failure->throw(
                  -text => @_ ? join('',@_) : "expected '$str1', got '$str2'"
              );
        },
        str_not_equals => sub {
            my $str1 = shift;
            my $str2 = shift;
            defined $str1 or
              Test::Unit::Failure->throw(
                  -text => @_ ? join('',@_) :
                    "expected value was undef; should be using assert_not_null?"
              );
            defined $str2 or
              Test::Unit::Failure->throw(
                  -text => @_ ? join('',@_) :
                    "expected a string ne '$str1', got undef"
              );
            $str1 ne $str2 or
              Test::Unit::Failure->throw(
                  -text => @_ ? join('',@_) : "'$str1' and '$str2' should differ"
              );
        },
        num_equals => sub {
            my $num1 = shift;
            my $num2 = shift;
            defined $num1 or
              Test::Unit::Failure->throw(
                  -text => @_ ? join('',@_) :
                    "expected value was undef; should be using assert_null?"
              );
            defined $num2 or
              Test::Unit::Failure->throw(
                  -text => @_ ? join('',@_) : "expected '$num1', got undef"
              );
            # silence `Argument "" isn't numeric in numeric eq (==)' warnings
            local $^W;
            $num1 == $num2 or
              Test::Unit::Failure->throw(
                  -text => @_ ? join('', @_) : "expected $num1, got $num2"
              );
        },
        num_not_equals => sub {
            my $num1 = shift;
            my $num2 = shift;
            defined $num1 or
              Test::Unit::Failure->throw(
                  -text => @_ ? join('',@_) :
                    "expected value was undef; should be using assert_not_null?"
              );
            defined $num2 or
              Test::Unit::Failure->throw(
                  -text => @_ ? join('',@_) :
                    "expected a number != '$num1', got undef"
              );
            # silence `Argument "" isn't numeric in numeric ne (!=)' warnings
            local $^W;
            $num1 != $num2 or
              Test::Unit::Failure->throw(
                  -text => @_ ? join('', @_) : "$num1 and $num2 should differ"
              );
        },
        matches => sub {
            my $regexp = shift;
            eval { $regexp->isa('Regexp') } or
              Test::Unit::Error->throw(
                  -text => "arg 1 to assert_matches() must be a regexp"
              );
            my $string = shift;
            $string =~ $regexp or
              Test::Unit::Failure->throw
                  (-text => @_ ? join('', @_) :
                     "$string didn't match /$regexp/");
        },
        does_not_match => sub {
            my $regexp = shift;
            eval { $regexp->isa('Regexp') } or
              Test::Unit::Error->throw(
                  -text => "arg 1 to assert_does_not_match() must be a regexp"
              );
            my $string = shift;
            $string !~ $regexp or
              Test::Unit::Failure->throw
                  (-text => @_ ? join('', @_) :
                     "$string matched /$regexp/");
        },
        null       => sub {
            my $arg = shift;
            !defined($arg) or
              Test::Unit::Failure->throw
                  (-text => @_ ? join('',@_) : "$arg is defined");
        },
        not_null   => sub {
            my $arg = shift;
            defined($arg) or
              Test::Unit::Failure->throw
                  (-text => @_ ? join('', @_) : " unexpected");
        },
        isa   => sub {
            my $class = shift;
            my $obj = shift;
            defined $class or
              Test::Unit::Error->throw(
                  -text => @_ ? join('',@_) :
                    "expected classname was undef; should be using assert_null?"
              );
	    ref($class) eq "" or
	      Test::Unit::Error->throw
		  (-text => @_ ? join('',@_) : "expected classname was a reference; args swapped?");
            defined $obj or
              Test::Unit::Failure->throw(
                  -text => @_ ? join('',@_) : "expected class '$class', got undef"
              );
	    ref($obj) ne "" or
	      Test::Unit::Failure->throw
		  (-text => @_ ? join('',@_) : "expected class '$class', got non-reference");
	    ref($obj) !~ /^(SCALAR|ARRAY|HASH|CODE|REF|GLOB|LVALUE|Regexp)$/ or
              Test::Unit::Failure->throw(
                  -text => @_ ? join('',@_) : "expected class '$class', got unblessed reference"
              );
            $obj->isa($class) or
              Test::Unit::Failure->throw(
                  -text => @_ ? join('',@_) : "expected object of class '$class', got '".ref($obj)."'"
              );
        },
        can   => sub {
            my $method = shift;
            my $obj = shift;
            defined $method or
              Test::Unit::Error->throw(
                  -text => @_ ? join('',@_) :
                    "expected method name was undef; should be using assert_null?"
              );
	    ref($method) eq "" or
	      Test::Unit::Error->throw
		  (-text => @_ ? join ('',@_) : "expected method name was a reference; args swapped?");
            defined $obj or
              Test::Unit::Failure->throw(
                  -text => @_ ? join('',@_) : "expected object that can '$method', got undef"
              );
            (ref($obj) && ref($obj) !~ /^(SCALAR|ARRAY|HASH|CODE|REF|GLOB|LVALUE|Regexp)$/) or
              Test::Unit::Failure->throw(
                  -text => @_ ? join('',@_) : "expected object that can '$method', got non-object"
              );
            $obj->can($method) or
              Test::Unit::Failure->throw(
                  -text => @_ ? join('',@_) : "expected object that can '$method', but it cannot"
              );
        },
    );
    foreach my $type (keys %assert_subs) {
        my $assertion = Test::Unit::Assertion::CodeRef->new($assert_subs{$type});
        no strict 'refs';
        *{"Test::Unit::Assert::assert_$type"} =
            sub {
                local $Error::Depth = $Error::Depth + 3;
                my $self = shift;
                $assertion->do_assertion(@_);
            };
    }
}

sub fail {
    my $self = shift;
    debug(ref($self) . "::fail() called\n");
    my($asserter,$file,$line) = caller($Error::Depth);
    my $message = join '', @_;
    Test::Unit::Failure->throw(-text => $message,
			       -object => $self,
			       -file => $file,
			       -line => $line);
}

sub error {
    my $self = shift;
    debug(ref($self) . "::error() called\n");
    my($asserter,$file,$line) = caller($Error::Depth);
    my $message = join '', @_;
    Test::Unit::Error->throw(-text => $message,
                             -object => $self,
                             -file => $file,
                             -line => $line);
}

sub quell_backtrace {
    my $self = shift;
    carp "quell_backtrace deprecated";
}

sub get_backtrace_on_fail {
    my $self = shift;
    carp "get_backtrace_on_fail deprecated";
}



1;
__END__