File Coverage

blib/lib/OOP/Perlish/Class/UnitTests/Class.pm

Criterion	Covered	Total	%
statement	164	164	100.0
branch	1	2	50.0
condition			n/a
subroutine	44	44	100.0
pod	0	19	0.0
total	209	229	91.2

#!/usr/bin/perl
use warnings;
use strict;
{
    package OOP::Perlish::Class::UnitTests::Class;
    use warnings;
    use strict;
    use OOP::Perlish::Class::UnitTests::Base;
    use base qw(OOP::Perlish::Class::UnitTests::Base);
    use Test::More;

    sub setup : Test(setup)
    {
        my ($self) = @_;
        undef $@;
    }

    sub class_assignment : Test(1)
    {
        my ($self) = @_;

        my $f = OOP::Perlish::Class::UnitTests::Foo->new();
        $f->foo("Hello foo!");
        is($f->foo(), 'Hello foo!', 'Class assignment');
    }

    sub multiple_classes : Test(2)
    {
        my ($self) = @_;

        my $f = OOP::Perlish::Class::UnitTests::Foo->new();
        $f->foo("Hello foo!");

        my $b = OOP::Perlish::Class::UnitTests::Bar->new();
        $b->foo("Goodbye Ralph!");
        is($f->foo(), 'Hello foo!', 'Multiple classes');
        is($b->foo(), 'Goodbye Ralph!', 'Multiple classes');
    }

    sub multiple_instances : Test(2)
    {
        my ($self) = @_;

        my $f = OOP::Perlish::Class::UnitTests::Foo->new();
        $f->foo("Hello foo!");

        my $ff = OOP::Perlish::Class::UnitTests::Foo->new();
        $ff->foo("foo is the fooyist!");
        is($f->foo(), 'Hello foo!', 'Multiple instances');
        is($ff->foo(), 'foo is the fooyist!', 'Multiple instances');
    }

    sub inheritance : Test(2)
    {
        my ($self) = @_;

        my $fb = OOP::Perlish::Class::UnitTests::Bar::Bar->new( bar => { dodad => 'bars are great' }, foo => 'Ralph is pretty good too' );

        is($fb->foo(), 'Ralph is pretty good too', 'inheritance, we have foo');
        is($fb->bar()->{dodad}, 'bars are great', 'inheritance, we have bar');
    }

    sub overload_uniqueness : Test(4)
    {
        my ($self) = @_;

        my $bfb = OOP::Perlish::Class::UnitTests::Baz::Foo::Bar->new( bar => 'bar', foo => 'foo');
        my $bfbo = OOP::Perlish::Class::UnitTests::Baz::Foo::Bar::Overload->new( bar => 'Bar overloaded!' );

        is($bfb->foo(), 'foo', 'Multiple inheritance with overloading, non-overloaded foo');
        is($bfb->bar(), 'bar', 'Multiple inheritance with overloading, non-overloaded bar');
        is($bfb->baz(), 'baz', 'Multiple inheritance with overloading, non-overloaded baz');

        is($bfbo->bar(), 'Bar overloaded!', 'Multiple inheritance with overloading, overloaded bar');
    }

    sub overload_uniqueness_reverse : Test(4)
    {
        my ($self) = @_;

        my $bfbo = OOP::Perlish::Class::UnitTests::Baz::Foo::Bar::Overload->new( bar => 'Bar overloaded!' );
        my $bfb = OOP::Perlish::Class::UnitTests::Baz::Foo::Bar->new( bar => 'bar', foo => 'foo');

        is($bfb->foo(), 'foo', 'Multiple inheritance with overloading, non-overloaded foo');
        is($bfb->bar(), 'bar', 'Multiple inheritance with overloading, non-overloaded bar');
        is($bfb->baz(), 'baz', 'Multiple inheritance with overloading, non-overloaded baz');

        is($bfbo->bar(), 'Bar overloaded!', 'Multiple inheritance with overloading, overloaded bar');
    }

    sub multiple_inheritance : Test(3)
    {
        my ($self) = @_;

        my $bfb = OOP::Perlish::Class::UnitTests::Baz::Foo::Bar->new( bar => 'bar', foo => 'foo');
        is($bfb->foo(), 'foo', 'Multiple inheritance, foo');
        is($bfb->bar(), 'bar', 'Multiple inheritance, bar');
        is($bfb->baz(), 'baz', 'Multiple inheritance, baz');
    }


    sub value_set_derived : Test(2)
    {
        my ($self) = @_;

        my $fred = OOP::Perlish::Class::UnitTests::Fred->new( bar => 'set this' );
        ok( $fred->can('find'), 'Inherited from non-derived class' );
        is($fred->bar(), 'set this', 'Value set on accessor still valid on derivded-class' );
    }

    sub valid_defaults : Test(6)
    {
        my ($self) = @_;

        my $obj;

        eval {
            $obj = OOP::Perlish::Class::UnitTests::TestValidDefaults->new();
        };
        ok( ! "$@", 'did not croak on instantiation' );

        is( $obj->scalar(), 'test', 'scalar default' );
        is( ($obj->array())[0], 'test', 'array default' );
        is( { ($obj->hash()) }->{key}, 'test', 'hash default' );
        is( $obj->code()->(), 'test', 'code default' );
        ok( UNIVERSAL::isa($obj->object(), 'IO::File'), 'object default' );
    }

    sub invalid_defaults
    {
        my ($self, $type) = @_;
        my $classname = 'OOP::Perlish::Class::UnitTests::TestInvalidDefault' . ucfirst(lc($type));

        my $obj;

        eval {
            $obj = $classname->new();
        };
        ok( "$@", 'did croak on instantiation' );
        ok( "$@" =~ m/\Q$type\E/i, 'we saw the error we wanted' );
        ok( "$@" =~ m#\QOOP::Perlish::Class::Accessor#gsim, 'we died from OOP::Perlish::Class::Accessor' ) || diag("$@");
        ok( ! $obj, 'did not initialize' )
    }

    sub invalid_defaults_scalar : Test(4)
    {
        my ($self) = @_;
        $self->invalid_defaults('scalar');
    }

    sub invalid_defaults_array : Test(4)
    {
        my ($self) = @_;
        $self->invalid_defaults('array');
    }

    sub invalid_defaults_hash : Test(4)
    {
        my ($self) = @_;
        $self->invalid_defaults('hash');
    }

    sub invalid_defaults_code : Test(4)
    {
        my ($self) = @_;
        $self->invalid_defaults('code');
    }

    sub invalid_defaults_object : Test(4)
    {
        my ($self) = @_;
        $self->invalid_defaults('object');
    }

    sub method_overload_of_accessor : Test(1)
    {
        my ($self) = @_;

        my $obj = OOP::Perlish::Class::UnitTests::TestAccessorOverloadingWithMethod->new( fud => 'bar' );
        is( $obj->fud(), 'method, not accessor', 'we can successfully overload an accessor with a method' );
    }

    sub method_overload_of_accessor_is_still_required : Test(2)
    {
        my ($self) = @_;
        eval {
            my $obj = OOP::Perlish::Class::UnitTests::TestAccessorOverloadingWithMethod->new();
        };

        ok( "$@", 'We died, presumably because of the missing required' );
        ok( "$@" =~ m/Missing required/, 'Yep, missing required' );
    }

    sub accessor_required : Test(2)
    {
        my ($self) = @_;
        eval {
            my $obj = OOP::Perlish::Class::UnitTests::TestRequired->new();
        };

        ok( "$@", 'We died, presumably because of the missing required' );
        ok( "$@" =~ m/Missing required/, 'Yep, missing required' );
    }

}
1;

=head1 NAME

=head1 VERSION

=head1 SYNOPSIS

=head1 METHODS

=head1 AUTHOR

Jamie Beverly, C<<  >>

=head1 BUGS

Please report any bugs or feature requests to C,
or through
the web interface at
L.  I will be
notified, and then you'll
automatically be notified of progress on your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc OOP::Perlish::Class


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L

=item * AnnoCPAN: Annotated CPAN documentation

L

=item * CPAN Ratings

L

=item * Search CPAN

L

=back


=head1 ACKNOWLEDGEMENTS

=head1 COPYRIGHT & LICENSE

Copyright 2009 Jamie Beverly

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.

=cut