t/lib/OMPTest.pm - metacpan.org

#!/usr/bin/perl
# $Id: OMPTest.pm,v 1.10 2003/12/11 14:27:18 nothingmuch Exp $

use strict;
use warnings;

package OMPTest;

sub new {
	my $pkg = shift;
	my $name = shift;
	
	bless {
		name => $name,
		result => undef,
		error => undef,
	}
}

our $AUTOLOAD;
sub AUTOLOAD {
	my $self = shift;
	$AUTOLOAD =~ s/.*:://;
	$self->{$AUTOLOAD} = shift if @_;
	$self->{$AUTOLOAD};
}

package OMPTest::WhoAmI;

use strict;
use warnings;

sub whoami {
	my @path = split('::',((caller(1))[3]));
	my $subname = pop @path;
	my $subref = \ %main::;
	
	foreach my $sym (@path){
		$subref = $subref->{$sym . "::"};
	}
	
	return \&{ $subref->{$subname} };
}

package OMPTest::Plugin::Generic; # base class

use strict;
use warnings;

use base qw/Object::Meta::Plugin::Useful::Generic OMPTest::WhoAmI/;

sub new {
	my $pkg = shift;
	my $self = $pkg->SUPER::new();
	$self->export(@_);
	$self;
}

package OMPTest::Host::Plugin;

use strict;
use warnings;

use base qw/Object::Meta::Plugin::Useful::Meta OMPTest::WhoAmI/;

package OMPTest::Plugin::Selfish; # actually it's just closed minded

use strict;
use warnings;

use base 'OMPTest::Plugin::Generic';

sub new { $_[0]->SUPER::new(qw/foo bar gorch/) };

sub foo {
	my $self = shift;
	return $self->whoami() unless @_;
	my $obj = shift;
	$obj->add();
	return $self->can($_) ? $self->$_($obj) : [] for ('bar');
}

sub bar { ### returns
	my $self = shift;
	return $self->whoami() unless @_;
	my $obj = shift;
	$obj->add();
	
	my $m = 'ding';
	my $r = $self->super->can($m);
	return [] unless ($r && ($self->whoami() == shift));
	
	return $self->super->$m($obj,$r);
}

sub gorch {
	my $self = shift;
	return $self->whoami() unless @_;
	my $obj = shift;
	$obj->add();
	my $m = 'private';
	my $r = $self->can($m);
	return [] unless ($r && ($self->whoami() == shift));
	return $self->$m($obj,$r);
}

sub private {
	my $self = shift;
	return $self->whoami() unless @_;
	my $obj = shift;
	
	my $m = 'bar';
	my $r = $self->can($m);
	return [] unless ($r && ($self->whoami() == shift));
	return $self->$m($obj, $self->$r());
}

package OMPTest::Plugin::Upset::One; # to test offsets

use strict;
use warnings;

use base 'OMPTest::Plugin::Generic';

sub new { $_[0]->SUPER::new(qw/gorch bar/) };

sub gorch {
	my $self = shift;
	return $self->whoami() unless @_;
	my $obj = shift;
	$obj->add();
	
	my $m = 'bar';
	my $r = $self->next->can($m);
	return [] unless ($r && ($self->whoami() == shift));
	return $self->next->$m($obj, $self->$r());
}

sub bar {
	my $self = shift;
	return $self->whoami() unless @_;
	my $obj = shift;
	$obj->add();
	
	my $m = 'gorch';
	my $r = $self->next->can($m);
	return [] unless ($r && ($self->whoami() == shift));
	return $self->next->$m($obj, $self->$r());
}

package OMPTest::Plugin::Upset::Two;

use strict;
use warnings;

use base 'OMPTest::Plugin::Generic';

sub new { $_[0]->SUPER::new(qw/bar foo/) };

sub foo {
	my $self = shift;
	return $self->whoami() unless @_;
	my $obj = shift;
	$obj->add();
	
	my $m = 'foo';
	my $r = $self->prev->can($m);
	return [] unless ($r && ($self->whoami() == shift));
	return $self->prev->$m($obj, $self->$r());
}

sub bar {
	my $self = shift;
	return $self->whoami() unless @_;
	my $obj = shift;
	$obj->add();
	
	my $m = 'bar';
	my $r = $self->prev->can($m);
	return [] unless ($r && ($self->whoami() == shift));
	return $self->prev->$m($obj, $self->$r());
}

package OMPTest::Plugin::Upset::Picky;

use strict;
use warnings;

use base 'OMPTest::Plugin::Generic';

sub new { $_[0]->SUPER::new(qw/bar foo gorch/) };

sub foo {
	my $self = shift;
	return $self->whoami() unless @_;
	my $obj = shift;
	
	return [] unless ($self->whoami() == shift);
	
	my $m = 'gorch';
	
	foreach my $plugin (reverse @{ $self->super->stack($m) }){
		next if $plugin == $self->self;
		
		my $r = $self->super->specific($plugin)->can($m) or return [];
		$self->super->specific($plugin)->$m($obj, $self->$r());
	}
	
	$obj->add();
}

sub bar { # returns
	my $self = shift;
	return $self->whoami() unless @_;
	my $obj = shift;
	
	return [] unless ($self->whoami() == shift);
	
	my $m = 'gorch';
	
	for (my $i = 1; $i <= $#{ $self->super->stack($m) }; $i++){
		my $r = $self->offset($i)->can($m) or return [];
		$self->offset($i)->$m($obj, $self->$r());
	}
	
	$obj->add();
}

sub gorch {} # never called

package OMPTest::Plugin::Upset::Picky::AnotherGorch;

use strict;
use warnings;

use base 'OMPTest::Plugin::Generic';

sub new { $_[0]->SUPER::new(qw/gorch/) };

sub gorch { ### returns
	my $self = shift;
	return $self->whoami() unless @_;
	my $obj = shift;
	$obj->add();
}

package OMPTest::Plugin::Nice::One;

use strict;
use warnings;

use base 'OMPTest::Plugin::Generic';

sub new { $_[0]->SUPER::new(qw/foo gorch ding/) }

sub foo {
	my $self = shift;
	return $self->whoami() unless @_;
	my $obj = shift;
	$obj->add();

	my $m = 'gorch';
	my $r = $self->super->can($m);
	return [] unless ($r && ($self->whoami() == shift));
	return $self->super->$m($obj, $self->$r());
}

sub gorch { ### returns
	my $self = shift;
	return $self->whoami() unless @_;
	my $obj = shift;
	$obj->add();
}

sub ding { ### returns
	my $self = shift;
	return $self->whoami() unless @_;
	my $obj = shift;
	$obj->add();
}

package OMPTest::Plugin::Nice::Two;

use strict;
use warnings;

use base 'OMPTest::Plugin::Generic';

sub new { $_[0]->SUPER::new(qw/foo bar/) }

sub foo {
	my $self = shift;
	return $self->whoami() unless @_;
	my $obj = shift;
	$obj->add();
	my $m = 'bar';
	my $r = $self->super->can($m);
	return [] unless ($r && ($self->whoami() == shift));
	return $self->super->$m($obj, $self->$r());
}

sub bar { #### nothing returns, also relies on gorch to be defined by someone
	my $self = shift;
	return $self->whoami() unless @_;
	my $obj = shift;
	$obj->add();
	my $m = 'gorch';
	my $r = $self->super->can($m);
	return [] unless ($r && ($self->whoami() == shift));
	return $self->super->$m($obj, $self->$r());
}

package OMPTest::Plugin::Funny; # used within a plugged host, to bail into a higherlevel host

use strict;
use warnings;

use base 'OMPTest::Plugin::Generic';

sub new { $_[0]->SUPER::new(qw/gorch/) };

sub gorch {
	my $self = shift;
	return $self->whoami() unless @_;
	my $obj = shift;
	$obj->add();
	my $m = 'ding';
	my $r = $self->super->super->can($m); # note double super
	return [] unless ($r && ($self->whoami() == shift));
	return $self->super->super->$m($obj, $self->$r());
}

package OMPTest::Plugin::Serious; # like funny only without supersuper

use strict;
use warnings;

use base 'OMPTest::Plugin::Generic';

sub new { $_[0]->SUPER::new(qw/gorch/) };

sub gorch {
	my $self = shift;
	return $self->whoami() unless @_;
	my $obj = shift;
	$obj->add();
	my $m = 'ding';
	my $r = $self->super->can($m); # note double super
	return [] unless ($r && ($self->whoami() == shift));
	return $self->super->$m($obj, $self->$r());
}

package OMPTest::Plugin::MetaPlugin;

use strict;
use warnings;

use base 'OMPTest::Plugin::Generic';

sub new { $_[0]->SUPER::new(qw/init exports whoami/) };

sub init {
	my $self = shift;
	
	if ($self->can("super")){
		unshift @_, $self->super; &init;
	} else {
		$self->SUPER::init(@_);
	}
}

sub exports { # if $self->can(super) return self->super->methods, whatever. Otherwise, export self as a plugin.
	my $self = shift;
	
	if ($self->can("super")){ # plugged in
		keys %{ $self->super->methods }
	} else {
		$self->SUPER::exports(@_);
	}
}

package OMPTest::Plugin::Nosey;

use strict;
use warnings;

use base 'OMPTest::Plugin::Generic';

sub new { $_[0]->SUPER::new(qw/foo bar gorch/) };

sub foo {
	my $self = shift;
	return $self->whoami() unless @_;
	my $obj = shift;
	
	return [] unless join(" ", sort keys %$self) eq join(" ", sort 'what', keys %{ OMPTest::Plugin::Generic->new() } );# methods have no whitespace, so i was sloppy
	
	$obj->add();
	my $m = $self->{what} or return [] if exists $self->{what};
	my $r = $self->super->can($m);
	return [] unless ($r && ($self->whoami() == shift));
	return $self->super->$m($obj, $self->$r());
}

sub bar {
	my $self = shift;
	return $self->whoami() unless @_;
	my $obj = shift;
	return [] unless ($self->whoami() == shift);
	$obj->add($obj);
}

sub gorch {
	my $self = shift;
	return $self->whoami() unless @_;
	my $obj = shift;
	return [] unless ($self->whoami() == shift);
	$obj->add($obj)
}

package OMPTest::Plugin::Tricky;

use strict;
use warnings;

use base "OMPTest::Plugin::Generic";

use Scalar::Util qw(reftype);

sub new { my $pkg = shift; bless [ $pkg->SUPER::new(qw/foo bar gorch/) ], $pkg; } # has-a, not is-a
sub exports {
	my $self = shift;
	$self = $self->[0] if (reftype($self) eq 'ARRAY');
	$self->SUPER::exports(@_);
}

sub foo {
	my $self = shift;
	return $self->whoami() unless @_;
	my $obj = shift;
	$obj->add();
	
	my $m = pop @$self or return [];
	my $r = $self->super->can($m);
	return [] unless ($r && ($self->whoami() == shift));
	return $self->super->$m($obj, $self->$r());
}

sub bar {
	my $self = shift;
	return $self->whoami() unless @_;
	my $obj = shift;
	return [] unless ($self->whoami() == shift);
	$obj->add($obj);
}

sub gorch {
	my $self = shift;
	return $self->whoami() unless @_;
	my $obj = shift;
	return [] unless ($self->whoami() == shift);
	$obj->add($obj)
}

package OMPTest::Plugin::Wicked; # i didn't know what else to name it

use strict;
use warnings;
use warnings::register;

use base 'OMPTest::Plugin::Generic';

use Tie::RefHash;
use Scalar::Util qw(reftype);

sub new {
	my $pkg = shift;
	my $self = bless [ ], $pkg;
	tie @$self, __PACKAGE__."::Tie";
	@$self = ($pkg->SUPER::new(qw/foo bar gorch/));
	$self;
}

sub init {
	my $self = shift;
	my $x = $self->SUPER::init(@_);
	$x->info->style('force-implicit') unless (@_);
	$x;
}

sub exports {
	my $self = shift;
	$self = $self->[0] if (reftype($self) eq 'ARRAY');
	$self->SUPER::exports(@_);
}

sub foo {
	my $self = shift;
	return $self->whoami() unless @_;
	my $obj = shift;
	$obj->add();
	
	my $m = pop @$self or return [];
	my $r = $self->super->can($m);
	return [] unless ($r && ($self->whoami() == shift));
	return $self->super->$m($obj, $self->$r());
}

sub bar {
	my $self = shift;
	return $self->whoami() unless @_;
	my $obj = shift;
	return [] unless ($self->whoami() == shift);
	$obj->add($obj);
}

sub gorch {
	my $self = shift;
	return $self->whoami() unless @_;
	my $obj = shift;
	return [] unless ($self->whoami() == shift);
	$obj->add($obj)
}

package OMPTest::Plugin::Wicked::Tie;

use strict;
use warnings;

use base 'Tie::Array';

sub TIEARRAY { bless [], shift };
sub FETCH { $_[0][$_[1]] };
sub FETCHSIZE { scalar @{ $_[0] } };
sub EXISTS { exists ${ $_[0] }[$_[1]] };
sub STORE { $_[0][$_[1]] = $_[2] };
sub STORESIZE { $#{$_[0]} = $_[1]-1 };
sub DELETE { delete ${ $_[0] }[$_[1]] };

package OMPTest::Plugin::Explicit;

use base 'OMPTest::Plugin::Generic';

sub new { $_[0]->SUPER::new(qw/foo bar gorch/) };
sub init {
	my $self = shift;
	my $x = $self->SUPER::init();
	$x->info->style('explicit') unless (@_);
	$x;
}

sub foo {
	my $self = shift;
	return $self->whoami() unless @_;
	my $obj = shift;
		
	$obj->add();
	my $m = $self->self->{what} or return [] if exists $self->self->{what};
	my $r = $self->super->can($m);
	return [] unless ($r && ($self->whoami() == shift));
	return $self->super->$m($obj, $self->$r());
}

sub bar {
	my $self = shift;
	return $self->whoami() unless @_;
	my $obj = shift;
	return [] unless ($self->whoami() == shift);
	$obj->add($obj);
}

sub gorch {
	my $self = shift;
	return $self->whoami() unless @_;
	my $obj = shift;
	return [] unless ($self->whoami() == shift);
	$obj->add($obj)
}

package OMPTest::Plugin::Classless;

use strict;
use warnings;

sub init {
	Object::Meta::Plugin::ExportList->new(grep { !/Class::Classless::CALLSTATE=ARRAY\(0x[0-9a-f]+\)/ } @_);
}

sub exports {
	qw/foo bar/;
}

sub foo {
	my $self = shift;
	return $self->whoami() unless @_;
	my $obj = pop; # pop is because Class::Classless adds a CALLSTATE object
	$obj->add();
	return $self->can($_) ? $self->$_($obj) : [] for ('bar');
}

sub bar {
	my $self = shift;
	return $self->whoami() unless @_;
	my $obj = pop;
	$obj->add();
}

package OMPTest::Object::Thingy; # records who used it

use strict;
use warnings;

sub new {
	my $pkg = shift;
	bless [], $pkg;
}

sub add {
	push @{ $_[0] }, join("::", (caller(1))[0,3]);
	return $_[0];
}

package OMPTest::Plugin::Weird::Stringified;

use base 'OMPTest::Plugin::Wicked';
use overload '""' => sub { "foo" };

sub foo {
	my $self = shift;
	"$self";
}

package OMPTest::Plugin::Naughty::Nextport;

use base 'OMPTest::Plugin::Generic';

sub new { $_[0]->SUPER::new(qw/next/) };

sub next {}

package OMPTest::Plugin::Naughty::Empty;

sub new { bless {}, shift }

package OMPTest::Plugin::Naughty::Undefs;

sub new { bless {}, shift}
sub init { undef };

package OMPTest::Plugin::Naughty::Crap;

sub new { bless {}, shift}
sub init { bless {}, 'NotReallyAnExportList' };

package OMPTest::Plugin::Naughty::Exports;

sub new { bless {}, shift }
sub exports { qw/method_i_have method_i_dont_have/ };
sub init { Object::Meta::Plugin::ExportList->new($_[0]) };
sub method_i_have {}

package OMPTest::Plugin::Noughty::OffsetDontHave;

use base 'OMPTest::Plugin::Generic';

sub new { $_[0]->SUPER::new(qw/foo/) };

sub foo {
	my $self = shift;
	$self->next->ding();
}

package OMPTest::Plugin::Noughty::Overloaded;

use strict;
use warnings;
use warnings::register;

use base 'OMPTest::Plugin::Generic';
use overload '@{}' => sub {}, 'fallback' => 1;

1; # Keep your mother happy.

__END__

=pod

=head1 NAME

OMPtest - A group of packages that help the testing process.

=head1 SYNOPSIS

	#

=head1 DESCRIPTION

Just a heap of plugin implementations, and that sort of stuff.

This is actually quite a useful source of example code. Most (hopefully all) of the features of L<Object::Meta::Plugin> (the distribution, not the class) are exploited.

=head1 Classes

=over 4

=item OMPTest::Plugin::Generic

A base class for most of the plugin implementations found herein.

=item OMPTest::Plugin::Selfish

A plugin which will not use super, and thus get it's own methods, even if they're not first in the host.

=item OMPTest::Plugin::Upset

These plugins will use the various methods which cause other plugins to be called explicitly. That's C<offset>, C<next>, C<prev>, and C<specific>.

=item OMPTest::Plugin::Nice

These plugins respect the presence of others, and do everything via C<super>.

=item OMPTest::Plugin::Funny

This plugin is used to bail out of a plugged in host, by calling C<$self->super->super>.

=item OMPTest::Plugin::Serious

This plugin takes the place of C<OMPTest::Plugin::Funny>, but lets AUTOLOADER take care of going up a host.

=item OMPTest::Plugin::MetaPlugin

This plugin is used to make a host also serve as a plugin.

=item OMPTest::Plugin::Nosey

This plugin looks inside it's structures, to make sure it doesn't look like a shim.

=item OMPTest::Plugin::Tricky

This plugin is like nosey, but isn't a hash - it's an array. It tests the tied access implementation.

=item OMPTest::Plugin::Wicked

This is like tricky, but it's structure is also tied, thus achieving two layers of tying.

=item OMPTest::Plugin::Explicit

This plugin uses C<$self->self> to access it's structures.

=item OMPTest::Plugin::Classless

This plugin is used to test the various classless implementations, as found in L<t/extremes.t>

=item OMPTest::Object::Thingy

This is used to track method calls, and to later test that expected results happened. It does this with C<caller>

=item OMPTest::Plugin::Weird::Stringified

This plugin is tied, and overloads some operators in it's class.

=item OMPTest::Plugin::Naughty

These plugins do bad things, and should be caught.

=back

=head1 CAVEATS

None or many.

=head1 BUGS

=over 4

=item *

Documentation of the various elements is insufficient. This could be useful for a learn-by-example process.

=back

=head1 TODO

=over 4

=item *

Have all the methods test what they're going to call with C<can>. This way the various C<can> implementations are tested to be working properly. Moreover, the code refs can be passed down, and the next in line will check whether it is the same thing as what it should be. This can also prevent cases of dubious test deaths.

=item *

Make the tests verbose.

=back

=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/basic.t>, L<t/error_handling.t>.

=cut
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)