view release on metacpan or  search on metacpan

inc/Test/More.pm  view on Meta::CPAN

    my $tb = Test::More->builder;

    return $tb->isnt_eq(@_);
}

*isn't = \&isnt;

#line 411

sub like ($$;$) {
    my $tb = Test::More->builder;

    return $tb->like(@_);
}

#line 426

sub unlike ($$;$) {
    my $tb = Test::More->builder;

    return $tb->unlike(@_);
}

#line 471

sub cmp_ok($$$;$) {
    my $tb = Test::More->builder;

    return $tb->cmp_ok(@_);
}

#line 506

sub can_ok ($@) {
    my( $proto, @methods ) = @_;
    my $class = ref $proto || $proto;
    my $tb = Test::More->builder;

    unless($class) {
        my $ok = $tb->ok( 0, "->can(...)" );
        $tb->diag('    can_ok() called with empty class or reference');
        return $ok;
    }

    unless(@methods) {
        my $ok = $tb->ok( 0, "$class->can(...)" );
        $tb->diag('    can_ok() called with no methods');
        return $ok;
    }

    my @nok = ();
    foreach my $method (@methods) {
        $tb->_try( sub { $proto->can($method) } ) or push @nok, $method;
    }

    my $name = (@methods == 1) ? "$class->can('$methods[0]')" :
                                 "$class->can(...)"           ;

    my $ok = $tb->ok( !@nok, $name );

    $tb->diag( map "    $class->can('$_') failed\n", @nok );

    return $ok;
}

#line 572

sub isa_ok ($$;$) {
    my( $object, $class, $obj_name ) = @_;
    my $tb = Test::More->builder;

    my $diag;

    if( !defined $object ) {
        $obj_name = 'The thing' unless defined $obj_name;
        $diag = "$obj_name isn't defined";
    }
    else {
        my $whatami = ref $object ? 'object' : 'class';
        # We can't use UNIVERSAL::isa because we want to honor isa() overrides
        my( $rslt, $error ) = $tb->_try( sub { $object->isa($class) } );
        if($error) {
            if( $error =~ /^Can't call method "isa" on unblessed reference/ ) {
                # Its an unblessed reference
                $obj_name = 'The reference' unless defined $obj_name;
                if( !UNIVERSAL::isa( $object, $class ) ) {
                    my $ref = ref $object;
                    $diag = "$obj_name isn't a '$class' it's a '$ref'";
                }
            }
            elsif( $error =~ /Can't call method "isa" without a package/ ) {
                # It's something that can't even be a class
                $obj_name = 'The thing' unless defined $obj_name;
                $diag = "$obj_name isn't a class or reference";
            }
            else {
                die <<WHOA;
WHOA! I tried to call ->isa on your $whatami and got some weird error.
Here's the error.
$error
WHOA
            }
        }
        else {
            $obj_name = "The $whatami" unless defined $obj_name;
            if( !$rslt ) {
                my $ref = ref $object;
                $diag = "$obj_name isn't a '$class' it's a '$ref'";
            }
        }
    }

    my $name = "$obj_name isa $class";
    my $ok;
    if($diag) {
        $ok = $tb->ok( 0, $name );
        $tb->diag("    $diag\n");
    }
    else {
        $ok = $tb->ok( 1, $name );
    }