/usr/share/perl5/Test/Object.pm is in libtest-object-perl 0.07-2.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 | package Test::Object;
=pod
=head1 NAME
Test::Object - Thoroughly testing objects via registered handlers
=head1 SYNOPSIS
###################################################################
# In your test module, register test handlers again class names #
###################################################################
package My::ModuleTester;
use Test::More;
use Test::Object;
# Foo::Bar is a subclass of Foo
Test::Object->register(
class => 'Foo',
tests => 5,
code => \&foo_ok,
);
Test::Object->register(
class => 'Foo::Bar',
# No fixed number of tests
code => \&foobar_ok,
);
sub foo_ok {
my $object = shift;
ok( $object->foo, '->foo returns true' );
}
sub foobar_ok {
my $object = shift;
is( $object->foo, 'bar', '->foo returns "bar"' );
}
1;
###################################################################
# In test script, test object against all registered classes #
###################################################################
#!/usr/bin/perl -w
use Test::More 'no_plan';
use Test::Object;
use My::ModuleTester;
my $object = Foo::Bar->new;
isa_ok( $object, 'Foo::Bar' );
object_ok( $object );
=head1 DESCRIPTION
In situations where you have deep trees of classes, there is a common
situation in which you test a module 4 or 5 subclasses down, which should
follow the correct behaviour of not just the subclass, but of all the
parent classes.
This should be done to ensure that the implementation of a subclass has
not somehow "broken" the object's behaviour in a more general sense.
C<Test::Object> is a testing package designed to allow you to easily test
what you believe is a valid object against the expected behaviour of B<all>
of the classes in its inheritance tree in one single call.
To do this, you "register" tests (in the form of CODE or function
references) with C<Test::Object>, with each test associated with a
particular class.
When you call C<object_ok> in your test script, C<Test::Object> will check
the object against all registered tests. For each class that your object
responds to C<$object-E<gt>isa($class)> for, the appropriate testing
function will be called.
Doing it this way allows adapter objects and other things that respond
to C<isa> differently that the default to still be tested against the
classes that it is advertising itself as correctly.
This also means that more than one test might be "counted" for each call
to C<object_ok>. You should account for this correctly in your expected
test count.
=cut
use 5.005;
use strict;
use Carp ();
use Exporter ();
use Test::More ();
use Scalar::Util ();
use Test::Object::Test ();
use vars qw{$VERSION @ISA @EXPORT};
BEGIN {
$VERSION = '0.07';
@ISA = 'Exporter';
@EXPORT = 'object_ok';
}
#####################################################################
# Registration and Planning
my @TESTS = ();
sub register {
my $class = shift;
push @TESTS, Test::Object::Test->new( @_ );
}
#####################################################################
# Testing Functions
sub object_ok {
my $object = Scalar::Util::blessed($_[0]) ? shift
: Carp::croak("Did not provide an object to object_ok");
# Iterate over the tests and run any we ->isa
foreach my $test ( @TESTS ) {
$test->run( $object ) if $object->isa( $test->class );
}
1;
}
1;
=pod
=head1 SUPPORT
Bugs should be submitted via the CPAN bug tracker, located at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Object>
For other issues, contact the author.
=head1 AUTHOR
Adam Kennedy E<lt>cpan@ali.asE<gt>
=head1 SEE ALSO
L<http://ali.as/>, L<Test::More>, L<Test::Builder::Tester>, L<Test::Class>
=head1 COPYRIGHT
Copyright 2005, 2006 Adam Kennedy. All rights reserved.
This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.
The full text of the license can be found in the
LICENSE file included with this module.
=cut
|