File Coverage

blib/lib/classes/Test.pm

Criterion	Covered	Total	%
statement	24	42	57.1
branch			n/a
condition	0	54	0.0
subroutine	8	17	47.0
pod	9	9	100.0
total	41	122	33.6

package classes::Test;

# $Id: Test.pm 147 2008-03-08 16:04:33Z rmuhle $

# these two are just really brain dead
# when using more advanced perl stuff
no strict;
no warnings;

use Scalar::Util 'blessed';

use base 'Exporter';
our @EXPORT_OK = qw(
    can_new
    can_set_get
    has_decl
    has_class_const
    has_mixins
    has_mixins_hash
    is_classes
    is_throwable
    is_classes_exc
    has_tree
);

our %EXPORT_TAGS = ( 'all' => [qw(
    can_new
    can_set_get
    has_decl
    has_class_const
    has_mixins
    has_mixins_hash
    is_classes
    is_throwable
    is_classes_exc
 )]);

use Test::Builder;
use Test::More;
my $t = Test::Builder->new();

sub can_new (*) {
    my $this = blessed $_[0] || $_[0];
    return $t->ok(
           $this->can('new'),
         "'$this' has new constructor method"
    ) ||
    $t->diag(
    "     '$this' missing new constructor"
    );
}

sub can_set_get (*) {
    my $this = blessed $_[0] || $_[0];
    return $t->ok(
           $this->can('set')
        && $this->can('get')
        , "'$this' can set, get"
    ) ||
    $t->diag("     '$this' missing set, get");
}

# should have a DECL hash ref package variable and method
sub has_decl (*) {
    my $this = blessed $_[0] || $_[0];
    return $t->ok(
        $this->can('DECL') &&
        defined ${$this.'::DECL'},
        "'$this' has DECL"
    )
    || $t->diag("    '$this' does not have a DECL declaration");
}

sub has_class_const (*) {
    my $this = blessed $_[0] || $_[0];
    return $t->ok(
        $this->can('CLASS') &&
        defined ${$this.'::CLASS'},
        "'$this' has CLASS constant"
    )
    || $t->diag("    '$this' does not have a CLASS constant");
}

sub has_mixins (*) {
    my $this = blessed $_[0] || $_[0];
    no strict 'refs';
    return $t->ok(
        $this->can('MIXIN') &&
        scalar %{${$this.'::MIXIN'}},
        "'$this' has MIXINs"
    )
    || $t->diag("    '$this' does not have a CLASS constant");
}

sub has_mixins_hash (*) {
    my $this = blessed $_[0] || $_[0];
    no strict 'refs';
    return $t->ok(
        $this->can('MIXIN') &&
        ref ${$this.'::MIXIN'} eq 'HASH',
        "'$this' has MIXIN hash defined"
    )
    || $t->diag("    '$this' does not have a MIXIN hash");
}

sub is_classes (*) {
    my $this = blessed $_[0] || $_[0];
    return $t->ok(
         can_new($this) &&
         has_class_const($this) &&
         has_decl($this),
        "'$this' is a classes class"
    )
    || $t->diag("    '$this' does not look like a classes class");
}

sub is_throwable (*) {
    my $this = blessed $_[0] || $_[0];
    return $t->ok(
        $this->can('throw') &&
        $this->can('rethrow') &&
        $this->can('send') &&
        $this->can('catch') &&
        $this->can('caught') &&
        $this->can('capture'),
        "'$this' fulfills the classes::Throwable interface"
    )
    || $t->diag("    '$this' does not fulfill the classes::Throwable interface");
}

sub is_classes_exc (*) {
    my $this = blessed $_[0] || $_[0];
    return $t->ok(
         is_classes($this) &&
         $this->can('as_string') &&
         like( $this->new->as_string, qr/^$this/,
            'as_string matches' ) &&
        is_throwable($this),
        "'$this' is a classes::Exception class"
    )
    || $t->diag("    '$this' does not look like a classes::Exception class");
}

1;

__END__