#!/usr/bin/perl
# $Id: basic.t,v 1.13 2003/12/11 14:27:17 nothingmuch Exp $
### these sets of tests are not a model for a efficiency (code or programmer), but rather for clarity.
### when editing, please keep in mind that it must be absolutely clear what's going on, to ease debugging when we've forgotten what's going on.
### make sure to use lexical scoping to isolate tests from each other - you should not carry garbage around
### make sure you are coherent regarding the order of things
### make sure you comment, clearly and loudly, wherever something may look like it's doing something that it's not
### thanks,
### yuval, nothingmuch@woobling.org
use strict;
use warnings;
use Object::Meta::Plugin;
use Object::Meta::Plugin::Host;
use lib "t/lib";
use OMPTest;
our $VERSION = 0.02;
$| = 1; # nicer to pipes
$\ = "\n"; # less to type?
my @test = ( # a series of test subs, which return true for success, 0 otherwise
sub { # 1 test that we can create new instances
Object::Meta::Plugin::Host->new() && Object::Meta::Plugin::Useful::Generic->new() && 1; # throwaway # useful makes no replacements, alles gtt
},
sub { # 2 tests that things can plug
my $host = Object::Meta::Plugin::Host->new() or return undef;
my @plugins = sort (qw/OMPTest::Plugin::Selfish OMPTest::Plugin::Nice::One OMPTest::Plugin::Nice::Two OMPTest::Plugin::Upset::One OMPTest::Plugin::Upset::Two/);
$host->plug($_->new()) or return undef for @plugins;
# make sure everything is listed
my $i = 0; ref $_ ne $plugins[$i++] and return undef for (sort keys %{ $host->plugins });
return 1; # if we made it to here everything plugged in ok
},
sub { # 3 basic plugin functionality, order matters
# initialize a new set of things
my $o = OMPTest::Object::Thingy->new();
my $host = Object::Meta::Plugin::Host->new();
$host->plug($_->new()) for (qw/
OMPTest::Plugin::Nice::One
OMPTest::Plugin::Nice::Two
/);
my @steps = (
qr/Nice::Two::foo$/,
qr/Nice::Two::bar$/,
qr/Nice::One::gorch$/,
);
my $m = 'foo'; (@steps && $_ =~ (shift @steps)) or return undef foreach (@{$host->$m($o, $host->$m())}); return not @steps;
},
sub { # 4 registering of methods is order sensitive, make sure theres a difference between this test and the previous one
# initialize a new set of things
my $o = OMPTest::Object::Thingy->new();
my $host = Object::Meta::Plugin::Host->new();
#### FIRST TWO THEN ONE
$host->plug($_->new()) for (qw/
OMPTest::Plugin::Nice::Two
OMPTest::Plugin::Nice::One
/);
my @steps = (
qr/Nice::One::foo$/,
qr/Nice::One::gorch$/,
);
my $m = 'foo'; (@steps && $_ =~ (shift @steps)) or return undef foreach (@{$host->$m($o, $host->$m())}); return not @steps;
},
sub { # 5 super method, as well as the more complex lack of thereof
my $o = OMPTest::Object::Thingy->new();
my $host = Object::Meta::Plugin::Host->new();
$host->plug($_->new()) for (qw/
OMPTest::Plugin::Nice::One
OMPTest::Plugin::Selfish
OMPTest::Plugin::Nice::Two
/);
my @steps = (
qr/Nice::Two::foo$/,
qr/Nice::Two::bar$/,
qr/Selfish::gorch$/,
qr/Selfish::bar$/,
qr/Nice::One::ding$/,
);
my $m = 'foo'; (@steps && $_ =~ (shift @steps)) or return undef foreach (@{$host->$m($o, $host->$m())}); return not @steps;
},
sub { # 6 offsets
my $o = OMPTest::Object::Thingy->new();
my $host = Object::Meta::Plugin::Host->new();
$host->plug($_->new()) for (qw/
OMPTest::Plugin::Nice::One
OMPTest::Plugin::Upset::Two
OMPTest::Plugin::Upset::One
OMPTest::Plugin::Nice::Two
/);
my @steps = (
qr/Nice::Two::foo$/,
qr/Nice::Two::bar$/,
qr/Upset::One::gorch$/,
qr/Upset::Two::bar$/,
qr/Upset::One::bar$/,
qr/Nice::One::gorch$/,
);
my $m = 'foo'; (@steps && $_ =~ (shift @steps)) or return undef foreach (@{$host->$m($o, $host->$m())}); return not @steps;
},
sub { # 7 offsets
my $o = OMPTest::Object::Thingy->new();
my $host = Object::Meta::Plugin::Host->new();
$host->plug($_->new()) for (qw/
OMPTest::Plugin::Nice::One
OMPTest::Plugin::Upset::Picky::AnotherGorch
OMPTest::Plugin::Upset::Picky
/);
my @steps = (
qr/Upset::Picky::AnotherGorch::gorch$/,
qr/Nice::One::gorch$/,
qw/Plugin::Upset::Picky::bar$/,
);
### THE FOLLOWING CALL IS ON bar, NOT foo!!!
my $m = 'bar'; (@steps && $_ =~ (shift @steps)) or return undef foreach (@{$host->$m($o, $host->$m())}); return not @steps;
},
sub { # 8 'specific' method
my $o = OMPTest::Object::Thingy->new();
my $host = Object::Meta::Plugin::Host->new();
$host->plug($_->new()) for (qw/
OMPTest::Plugin::Nice::One
OMPTest::Plugin::Upset::Picky::AnotherGorch
OMPTest::Plugin::Upset::Picky
/);
my @steps = (
qr/Upset::Picky::AnotherGorch::gorch$/,
qr/Nice::One::gorch$/,
qw/Plugin::Upset::Picky::foo$/,
);
my $m = 'foo'; (@steps && $_ =~ (shift @steps)) or return undef foreach (@{$host->$m($o, $host->$m())}); return not @steps;
},
sub { # 9 unplugging
my $o = OMPTest::Object::Thingy->new();
my $host = Object::Meta::Plugin::Host->new();
$host->plug($_->new()) for (qw/
OMPTest::Plugin::Upset::One
OMPTest::Plugin::Nice::One
OMPTest::Plugin::Selfish
OMPTest::Plugin::Nice::Two
OMPTest::Plugin::Selfish
OMPTest::Plugin::Upset::Two
/);
$host->unplug(grep { not /OMPTest::Plugin::Nice/ } keys %{ $host->plugins } ); # unplug anything which isn't nice
return undef if grep { not /OMPTest::Plugin::Nice/ } keys %{ $host->plugins };
my @steps = (
qr/Nice::Two::foo$/,
qr/Nice::Two::bar$/,
qr/Nice::One::gorch$/,
);
my $m = 'foo'; (@steps && $_ =~ (shift @steps)) or return undef foreach (@{$host->$m($o, $host->$m())}); return not @steps;
},
sub { # 10 multiplicity
my $o = OMPTest::Object::Thingy->new();
my $host = Object::Meta::Plugin::Host->new();
$host->plug($_->new()) for (qw/
OMPTest::Plugin::Nice::Two
OMPTest::Plugin::Nice::One
/);
$host->plug($_) for ((OMPTest::Plugin::Upset::One->new) x 2);
my @steps = (
qr/Upset::One::bar$/,
qr/Upset::One::gorch$/,
qr/Nice::Two::bar$/,
qr/Upset::One::gorch$/,
qr/Upset::One::bar$/,
qr/Nice::One::gorch$/,
);
### test that multiple instances of the same plugin work
### THE FOLLOWING CALL IS ON bar, NOT foo!!!
my $m = 'bar'; (@steps && $_ =~ (shift @steps)) or return undef foreach (@{$host->$m($o, $host->$m())}); return not @steps;
},
sub { # 11 multpiplicity + unplug
my $o = OMPTest::Object::Thingy->new();
my $host = Object::Meta::Plugin::Host->new();
my $p = OMPTest::Plugin::Upset::One->new();
$host->plug($_) for (($p) x 2, (map { $_->new() } qw/
OMPTest::Plugin::Nice::One
OMPTest::Plugin::Nice::Two
/), $p);
$host->unplug($p); # unplug it out once, it should disappear once.
my @steps = (
qr/Nice::Two::foo$/,
qr/Nice::Two::bar$/,
qr/Nice::One::gorch$/,
);
my $m = 'foo'; (@steps && $_ =~ (shift @steps)) or return undef foreach (@{$host->$m($o, $host->$m())}); return not @steps;
},
sub { # 12 hosts as plugins
my $o = OMPTest::Object::Thingy->new();
my $host = Object::Meta::Plugin::Host->new();
my $one = OMPTest::Host::Plugin->new();
my $two = OMPTest::Host::Plugin->new();
$one->plug($_->new()) for (qw/
OMPTest::Plugin::Nice::One
/);
$two->plug($_->new()) for (qw/
OMPTest::Plugin::Funny
OMPTest::Plugin::Upset::Two
OMPTest::Plugin::Upset::One
OMPTest::Plugin::Nice::Two
/);
$host->plug($_) for ($one, $two);
my @steps = (
qr/Nice::Two::foo$/,
qr/Nice::Two::bar$/,
qr/Upset::One::gorch$/,
qr/Upset::Two::bar$/,
qr/Upset::One::bar$/,
qr/Funny::gorch$/,
qr/Nice::One::ding$/,
);
my $m = 'foo'; (@steps && $_ =~ (shift @steps)) or return undef foreach (@{$ host->$m($o, $host->$m()) }); return not @steps;
},
sub { # 13 hosts as plugins
my $o = OMPTest::Object::Thingy->new();
my $host = Object::Meta::Plugin::Host->new();
my $one = OMPTest::Host::Plugin->new();
my $two = OMPTest::Host::Plugin->new();
$one->plug($_->new()) for (qw/
OMPTest::Plugin::Nice::One
/);
$two->plug($_->new()) for (qw/
OMPTest::Plugin::Serious
OMPTest::Plugin::Upset::Two
OMPTest::Plugin::Upset::One
OMPTest::Plugin::Nice::Two
/);
$host->plug($_) for ($one, $two);
my @steps = (
qr/Nice::Two::foo$/,
qr/Nice::Two::bar$/,
qr/Upset::One::gorch$/,
qr/Upset::Two::bar$/,
qr/Upset::One::bar$/,
qr/Serious::gorch$/,
qr/Nice::One::ding$/,
);
my $m = 'foo'; (@steps && $_ =~ (shift @steps)) or return undef foreach (@{$ host->$m($o, $host->$m()) }); return not @steps;
},
sub { # 14 hosts as plugins
my $o = OMPTest::Object::Thingy->new();
my $host = Object::Meta::Plugin::Host->new();
my $one = Object::Meta::Plugin::Host->new();
my $two = Object::Meta::Plugin::Host->new();
$one->plug($_->new()) for (qw/
OMPTest::Plugin::Nice::One
OMPTest::Plugin::MetaPlugin
/);
$two->plug($_->new()) for (qw/
OMPTest::Plugin::Funny
OMPTest::Plugin::Upset::Two
OMPTest::Plugin::Upset::One
OMPTest::Plugin::Nice::Two
OMPTest::Plugin::MetaPlugin
/);
$host->plug($_) for ($one, $two);
my @steps = (
qr/Nice::Two::foo$/,
qr/Nice::Two::bar$/,
qr/Upset::One::gorch$/,
qr/Upset::Two::bar$/,
qr/Upset::One::bar$/,
qr/Funny::gorch$/,
qr/Nice::One::ding$/,
);
my $m = 'foo'; (@steps && $_ =~ (shift @steps)) or return undef foreach (@{$host->$m($o, $host->$m())}); return not @steps;
},
sub { # 15 hosts as plugins
my $o = OMPTest::Object::Thingy->new();
my $host = Object::Meta::Plugin::Host->new();
my $one = Object::Meta::Plugin::Host->new();
my $two = Object::Meta::Plugin::Host->new();
$one->plug($_->new()) for (qw/
OMPTest::Plugin::Nice::One
OMPTest::Plugin::MetaPlugin
/);
$two->plug($_->new()) for (qw/
OMPTest::Plugin::Serious
OMPTest::Plugin::Upset::Two
OMPTest::Plugin::Upset::One
OMPTest::Plugin::Nice::Two
OMPTest::Plugin::MetaPlugin
/);
$host->plug($_) for ($one, $two);
my @steps = (
qr/Nice::Two::foo$/,
qr/Nice::Two::bar$/,
qr/Upset::One::gorch$/,
qr/Upset::Two::bar$/,
qr/Upset::One::bar$/,
qr/Serious::gorch$/,
qr/Nice::One::ding$/,
);
my $m = 'foo'; (@steps && $_ =~ (shift @steps)) or return undef foreach (@{$host->$m($o, $host->$m())}); return not @steps;
},
sub { # 16 unregistering - make sure that ExportLists unmerge correctly
my $host = Object::Meta::Plugin::Host->new();
my $plugin = OMPTest::Plugin::Nice::One->new();
$host->plug($plugin);
$host->unregister(Object::Meta::Plugin::ExportList->new($plugin, qw/gorch ding/));
my @foo;
@foo = qw/foo/; return undef if grep { @foo or return undef; not $_ eq shift @foo } $host->plugins->{$plugin}->list(); return undef if @foo;
@foo = qw/foo/; return undef if grep { @foo or return undef; not $_ eq shift @foo } keys %{ $host->methods }; return undef if @foo;
return 1;
},
sub { # 17 registering - make sure that ExportLists merge correctly
my $host = Object::Meta::Plugin::Host->new();
my $plugin = OMPTest::Plugin::Nice::One->new();
$host->plug($plugin);
$host->unregister(Object::Meta::Plugin::ExportList->new($plugin, qw/gorch ding/));
$host->register(Object::Meta::Plugin::ExportList->new($plugin, qw/foo gorch ding/));
my @foo;
@foo = sort qw/ding foo gorch/; return undef if grep { @foo or return undef; not $_ eq shift @foo } sort $host->plugins->{$plugin}->list(); return undef if @foo;
@foo = sort qw/ding foo gorch/; return undef if grep { @foo or return undef; not $_ eq shift @foo } sort keys %{ $host->methods }; return undef if @foo;
return 1;
},
sub { # 18 overloaded context shim
my $o = OMPTest::Object::Thingy->new();
my $host = Object::Meta::Plugin::Host->new();
my $p = OMPTest::Plugin::Nosey->new();
$p->{what} = "bar";
$host->plug($p);
my @steps = (
qr/Nosey::foo$/,
qr/Nosey::bar$/,
);
my $m = 'foo'; (@steps && $_ =~ (shift @steps)) or return undef foreach (@{$host->$m($o, $host->$m())}); return not @steps;
},
sub { # 19 overloaded context shim
my $o = OMPTest::Object::Thingy->new();
my $host = Object::Meta::Plugin::Host->new();
my $p = OMPTest::Plugin::Nosey->new();
$p->{what} = "gorch";
$host->plug($p);
my @steps = (
qr/Nosey::foo$/,
qr/Nosey::gorch$/,
);
my $m = 'foo'; (@steps && $_ =~ (shift @steps)) or return undef foreach (@{$host->$m($o, $host->$m())}); return not @steps;
},
sub { # 20 tied context shim
my $o = OMPTest::Object::Thingy->new();
my $host = Object::Meta::Plugin::Host->new();
my $p = OMPTest::Plugin::Tricky->new();
push @$p, "bar";
$host->plug($p);
my @steps = (
qr/Tricky::foo$/,
qr/Tricky::bar$/,
);
my $m = 'foo'; (@steps && $_ =~ (shift @steps)) or return undef foreach (@{$host->$m($o, $host->$m())}); return not @steps;
},
sub { # 21 tied context shim
my $o = OMPTest::Object::Thingy->new();
my $host = Object::Meta::Plugin::Host->new();
my $p = OMPTest::Plugin::Tricky->new();
push @$p, "gorch";
$host->plug($p);
my @steps = (
qr/Tricky::foo$/,
qr/Tricky::gorch$/,
);
my $m = 'foo'; (@steps && $_ =~ (shift @steps)) or return undef foreach (@{$host->$m($o, $host->$m())}); return not @steps;
},
sub { # 22 tied context shim over tied structure
my $o = OMPTest::Object::Thingy->new();
my $host = Object::Meta::Plugin::Host->new();
my $p = OMPTest::Plugin::Wicked->new();
push @$p, "bar";
$host->plug($p);
my @steps = (
qr/Wicked::foo$/,
qr/Wicked::bar$/,
);
my $m = 'foo'; (@steps && $_ =~ (shift @steps)) or return undef foreach (@{$host->$m($o, $host->$m())}); return not @steps;
},
sub { # 23 tied context shim over tied structure
my $o = OMPTest::Object::Thingy->new();
my $host = Object::Meta::Plugin::Host->new();
my $p = OMPTest::Plugin::Wicked->new();
push @$p, "gorch";
$host->plug($p);
my @steps = (
qr/Wicked::foo$/,
qr/Wicked::gorch$/,
);
my $m = 'foo'; (@steps && $_ =~ (shift @steps)) or return undef foreach (@{$host->$m($o, $host->$m())}); return not @steps;
},sub { # 24 'standard' (explicit access via $self->self) context shim
my $o = OMPTest::Object::Thingy->new();
my $host = Object::Meta::Plugin::Host->new();
my $p = OMPTest::Plugin::Explicit->new();
$p->{what} = "bar";
$host->plug($p);
my @steps = (
qr/Explicit::foo$/,
qr/Explicit::bar$/,
);
my $m = 'foo'; (@steps && $_ =~ (shift @steps)) or return undef foreach (@{$host->$m($o, $host->$m())}); return not @steps;
},
sub { # 25 'standard' (explicit access via $self->self) context shim
my $o = OMPTest::Object::Thingy->new();
my $host = Object::Meta::Plugin::Host->new();
my $p = OMPTest::Plugin::Explicit->new();
$p->{what} = "gorch";
$host->plug($p);
my @steps = (
qr/Explicit::foo$/,
qr/Explicit::gorch$/,
);
my $m = 'foo'; (@steps && $_ =~ (shift @steps)) or return undef foreach (@{$host->$m($o, $host->$m())}); return not @steps;
},
sub { # 26 summary - actually retests stuff that was already done, but just in case
my $o = OMPTest::Object::Thingy->new();
my $host = Object::Meta::Plugin::Host->new();
$host->plug($_->new()) for (qw/
OMPTest::Plugin::Nice::One
OMPTest::Plugin::Selfish
OMPTest::Plugin::Upset::Two
OMPTest::Plugin::Upset::One
OMPTest::Plugin::Nice::Two
/);
my @steps = (
qr/Nice::Two::foo$/,
qr/Nice::Two::bar$/,
qr/Upset::One::gorch$/,
qr/Upset::Two::bar$/,
qr/Upset::One::bar$/,
qr/Selfish::gorch$/,
qr/Selfish::bar$/,
qr/Nice::One::ding$/,
);
my $m = 'foo'; (@steps && $_ =~ (shift @steps)) or return undef foreach (@{$host->$m($o, $host->$m())}); return not @steps;
},
);
print "1..", scalar @test; # the number of tests we have
my $i = 0; # a counter
my $t = times();
foreach (@test) { my $e; print (($e = &$_) ? "ok " . ++$i . ( ($e ne "1") ? " # Skipped: $e" : "") : "not ok " . ++$i) } # test away
print "# tests took ", times() - $t, " cpu time";
exit;
1; # keep your mother happy
__END__
=pod
=head1 NAME
t/basic.t - Test suite to make sure L<Object::Meta::Plugin> can perform the bare minimum we expect it to.
=head1 DESCRIPTION
This test suite uses various test plugins under a host several times. The plugins behave in certain ways, meant to exploit the various context modes and so forth of the host.
=head1 TESTS
=over 4
=item 1
This test ensures that the objects L<Object::Meta::Plugin::Host> and L<Object::Meta::Plugin::Useful> (a useful plugin base class) can be instantiated.
=item 2
This test tries to plug all the plugins it knows without doing anything special with them afterwords, except for looking if they're there..
=item 3
This test ensures that the super method of the context object works as expected, by using plugins which use these methods.
=item 4
This test ensures that the super method of the context object, as well as the lack of thereof do not change the behavior of the calls when they shouldn't be doing so.
=item 5
This test ensures that the context object will shortcut method calls when appropriate, to the plugin it's context it represents.
=item 6
This test ensures that the C<next>, C<prev> & C<offset> methods of the context object works, and that the offset context generator also works as expected.
=item 7
This test ensures that the C<offset> method of the context object works, and iterates a whole method stack to test it.
=item 8
This test ensures that the C<specific> method of the host object works, and iterates a whole method stack to test it.
=item 9
This test ensures that unplugging works properly (functionality and cleanup).
=item 10
This test plugs two copies of the same plugin in, and makes sure that the two copies are differentiated.
=item 11
This test ensures that two copies of the same plugin will both be expunged when the plugin is unplugged.
=item 12
This test creates plugins from hosts, and makes sure that the various context are still applicable. Moreover, it provides a means for checking that Host.pm's implementation is correct in both cases - normally, and as a plugin.
=item 13
Does the same as C<12> but without using C<$self->super->super>. Lets the autoloader see to that.
=item 14
This test also creates plugins from hosts, but it's done not with a subclass of L<Object::Meta::Plugin::Host>, but rather with a plugin that provides the necessary functionality from within, and not from without.
=item 15
Does the same as C<14> but without using C<$self->super->super>. Lets the autoloader see to that.
=item 16
This test plugs a plugin, and unregisters specific methods. Then it makes sure that the correct values changed.
=item 17
This test plugs a plugin, then unregisters some methods. It then plugs methods back, and makes sure the values are correct.
=item 18
This test ensures that overloaded access to the plugin's internals via the default style shim works.
=item 19
Same as C<18>
=item 20
This test ensures that tied access to the plugin's internals via the default style shim works.
=item 21
Same as C<20>
=item 22
This test ensures that tied access to the plugin's internals via the default style shim works, even when the internals are tied themselves.
=item 23
Same as C<22>
=item 24
This test ensures that the explicit access to the plugin's internals via the explicit style shim works.
=item 25
Same as C<24>.
=item 26
This test is some of the aspects of the previous tests combined. It makes use of all of the plugins, at one point or another. It tests offsets, super, but not host-as-plugin.
=back
=head1 TODO
=over 4
Nothing right now.
=head1 COPYRIGHT & LICENSE
Copyright 2003 Yuval Kogman. All rights reserved.
This program is free software; you can redistribute it
and/or modify it under the same terms as Perl itself.
=head1 AUTHOR
Yuval Kogman <nothingmuch@woobling.org>
=head1 SEE ALSO
L<t/error_handling.t>, L<t/extremes.t>, L<t/greedy.t>.
=cut