Commits

Toby Inkster committed 6af1afd

initial version

Comments (0)

Files changed (15)

+use inc::Module::Package 'RDF 0.009';
+

lib/MooseX/ABCD.pm

+package MooseX::ABCD;
+
+BEGIN {
+	$MooseX::ABCD::AUTHORITY = 'cpan:TOBYINK';
+	$MooseX::ABCD::VERSION   = '0.001';
+}
+
+use Moose 2.00 ();
+use MooseX::ABC 0.06 ();
+use Moose::Exporter;
+
+sub requires
+{
+	shift->add_required_method(@_);
+}
+ 
+Moose::Exporter->setup_import_methods(
+	with_meta => [qw(requires)],
+);
+ 
+sub init_meta
+{
+	my ($package, %options) = @_;
+
+	Carp::confess("Can't make a role into an abstract base class")
+		if Class::MOP::class_of($options{for_class})->isa('Moose::Meta::Role');
+
+	Moose::Util::MetaRole::apply_metaroles(
+		for             => $options{for_class},
+		class_metaroles => { class => ['MooseX::ABCD::Trait::Class'] },
+	);
+	Moose::Util::MetaRole::apply_base_class_roles(
+		for   => $options{for_class},
+		roles => ['MooseX::ABC::Role::Object'],
+	);
+
+	Class::MOP::class_of($options{for_class})->is_abstract(1);
+	return Class::MOP::class_of($options{for_class});
+}
+  
+1;
+
+__END__
+
+=head1 NAME
+
+MooseX::ABCD - MooseX::ABC, but checking required methods on make_immutable
+
+=head1 SYNOPSIS
+
+	{
+		package Shape;
+		use Moose;
+		use MooseX::ABCD;
+		requires 'draw';
+		__PACKAGE__->meta->make_immutable;
+	}
+	
+	{
+		package Circle;
+		use Moose;
+		extends 'Shape';
+		sub draw {
+			...;
+		}
+		__PACKAGE__->meta->make_immutable;
+	}
+	
+	my $shape  = Shape->new;   # dies
+	my $circle = Circle->new;  # succeeds
+	
+	{
+		package Square;
+		use Moose;
+		extends 'Shape';
+		__PACKAGE__->meta->make_immutable;
+		# ^^^ dies, draw is unimplemented
+	}
+
+=head1 DESCRIPTION
+
+What does ABCD stand for? Hmmm... maybe "abstract base classes deferred"?
+or "abstract base classes declare-compatible"? (This module works with
+MooseX::Declare, whereas MooseX::ABC does not!)
+
+Anyway, whatever ABCD does or does not stand for, this is what MooseX::ABCD
+does: it works just like MooseX::ABC, the checks that derived classes
+implement all abstract methods happen when the class is made immutable,
+not when inheritance is set up.
+
+Why? It works better with MooseX::Declare this way.
+
+=head2 Functions
+
+This module exports one function to your namespace:
+
+=over
+
+=item C<requires>
+
+Works like C<requires> in Moose roles, but for classes.
+
+=back
+
+=begin private
+
+=item C<init_meta> 
+
+=end private
+
+=head1 BUGS
+
+Please report any bugs to
+L<http://rt.cpan.org/Dist/Display.html?Queue=MooseX-ABCD>.
+
+=head1 SEE ALSO
+
+L<MooseX::ABC>, L<MooseX::AbstractMethod>.
+
+=head1 AUTHOR
+
+Toby Inkster E<lt>tobyink@cpan.orgE<gt>, though most of the code is stolen
+from Jesse Luehrs. (But don't blame him is something goes wrong. For that
+matter, don't blame me either - take a look at the disclaimer of warranties.)
+
+=head1 COPYRIGHT AND LICENCE
+
+This software is copyright (c) 2012 by Toby Inkster.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=head1 DISCLAIMER OF WARRANTIES
+
+THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
+WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
+MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+

lib/MooseX/ABCD/Trait/Class.pm

+package MooseX::ABCD::Trait::Class;
+
+BEGIN {
+	$MooseX::ABCD::Trait::Class::AUTHORITY = 'cpan:TOBYINK';
+	$MooseX::ABCD::Trait::Class::VERSION   = '0.001';
+}
+
+use Moose::Role;
+ 
+has is_abstract => (
+	is      => 'rw',
+	isa     => 'Bool',
+	default => 0,
+);
+ 
+has required_methods => (
+	traits     => ['Array'],
+	is         => 'ro',
+	isa        => 'ArrayRef[Str]',
+	default    => sub { [] },
+	auto_deref => 1,
+	handles    => {
+		add_required_method  => 'push',
+		has_required_methods => 'count',
+	},
+);
+ 
+before make_immutable => sub
+{
+	my $self = shift;
+	return if $self->is_abstract;
+	my @supers = $self->linearized_isa;
+	shift @supers;
+	
+	for my $superclass (@supers)
+	{
+		my $super_meta = Class::MOP::class_of($superclass);
+		
+		next unless $super_meta->meta->can('does_role')
+			&& $super_meta->meta->does_role('MooseX::ABCD::Trait::Class');
+		next unless $super_meta->is_abstract;
+		
+		for my $method ($super_meta->required_methods)
+		{
+			if (!$self->find_method_by_name($method))
+			{
+				my $classname = $self->name;
+				$self->throw_error(
+					"$superclass requires $classname to implement $method"
+				);
+			}
+		}
+	}
+};
+ 
+around _immutable_options => sub
+{
+	my $orig = shift;
+	my $self = shift;
+	my @options = $self->$orig(@_);
+	my $constructor = $self->find_method_by_name('new');
+	
+	if ($self->is_abstract)
+	{
+		push @options, inline_constructor => 0;
+	}
+	# we know that the base class has at least our base class role applied,
+	# so it's safe to replace it if there is only one wrapper.
+	elsif ($constructor->isa('Class::MOP::Method::Wrapped')
+	&& $constructor->get_original_method == Class::MOP::class_of('Moose::Object')->get_method('new'))
+	{
+		push @options, replace_constructor => 1;
+	}
+	# if our parent has been inlined and we are not abstract, then it's
+	# safe to inline ourselves
+	elsif ($constructor->isa('Moose::Meta::Method::Constructor'))
+	{
+		push @options, replace_constructor => 1;
+	}
+	
+	return @options;
+};
+ 
+no Moose::Role ;;; "Yeah, baby, yeah!"

meta/changes.pret

+# This file acts as the project's changelog.
+
+`MooseX-ABCD 0.001 cpan:TOBYINK`
+	issued  2012-08-21;
+	label   "Initial release".
+
+# This file contains general metadata about the project.
+
+@prefix : <http://usefulinc.com/ns/doap#>.
+
+`MooseX-ABCD`
+	:programming-language "Perl" ;
+	:shortdesc            "MooseX::ABC, but checking required methods on make_immutable";
+	:homepage             <https://metacpan.org/release/MooseX-ABCD>;
+	:download-page        <https://metacpan.org/release/MooseX-ABCD>;
+	:bug-database         <http://rt.cpan.org/Dist/Display.html?Queue=MooseX-ABCD>;
+	:repository           [ a :HgRepository; :browse <https://bitbucket.org/tobyink/p5-moosex-abcd> ];
+	:created              2012-08-21;
+	:license              <http://dev.perl.org/licenses/>;
+	:maintainer           cpan:TOBYINK;
+	:developer            cpan:TOBYINK.
+
+<http://dev.perl.org/licenses/>
+	dc:title  "the same terms as the perl 5 programming language system itself".
+
+cpan:TOBYINK
+	foaf:name  "Toby Inkster";
+	foaf:mbox  <mailto:tobyink@cpan.org>.
+

meta/makefile.pret

+# This file provides instructions for packaging.
+
+`MooseX-ABCD`
+	perl_version_from m`MooseX::ABCD`;
+	version_from      m`MooseX::ABCD`;
+	readme_from       m`MooseX::ABCD`;
+	test_requires     p`Test::More 0.61`  .
+
+use Test::More tests => 1;
+use Moose;
+BEGIN { use_ok('MooseX::ABCD') };
+

t/abstract-subclass.t

+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use Test::Fatal;
+
+{
+    package Foo;
+    use Moose;
+    use MooseX::ABCD;
+
+    requires 'foo';
+    requires 'bar';
+    __PACKAGE__->meta->make_immutable;
+}
+
+{
+    package Foo::Sub;
+    use Moose;
+    use MooseX::ABCD;
+    extends 'Foo';
+
+    requires 'baz';
+
+    sub bar { 'BAR' }
+    __PACKAGE__->meta->make_immutable;
+}
+
+{
+    package Foo::Sub::Sub;
+    use Moose;
+    extends 'Foo::Sub';
+
+    sub foo { 'FOO' }
+    sub baz { 'BAZ' }
+    __PACKAGE__->meta->make_immutable;
+}
+
+like(
+    exception { Foo->new },
+    qr/Foo is abstract, it cannot be instantiated/,
+    "can't create Foo objects"
+);
+like(
+    exception { Foo::Sub->new },
+    qr/Foo::Sub is abstract, it cannot be instantiated/,
+    "can't create Foo::Sub objects"
+);
+
+my $foo = Foo::Sub::Sub->new;
+is($foo->foo, 'FOO', 'successfully created a Foo::Sub::Sub object');
+
+done_testing;
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use Test::Fatal;
+
+{
+    package Foo;
+    use Moose;
+    use MooseX::ABCD;
+
+    requires 'bar', 'baz';
+    __PACKAGE__->meta->make_immutable;
+}
+
+{
+    package Foo::Sub1;
+    use Moose;
+    ::is(::exception { extends 'Foo' }, undef,
+        "extending works when the requires are fulfilled");
+    sub bar { }
+    sub baz { }
+    __PACKAGE__->meta->make_immutable;
+}
+
+{
+    package Foo::Sub2;
+    use Moose;
+    extends 'Foo';
+    sub bar { }
+    ::like(
+        ::exception { __PACKAGE__->meta->make_immutable },
+        qr/Foo requires Foo::Sub2 to implement baz/,
+        "extending fails with the correct error when requires are not fulfilled"
+    );
+}
+
+{
+    package Foo::Sub::Sub;
+    use Moose;
+    ::is(::exception { extends 'Foo::Sub1' }, undef,
+        "extending twice works");
+    __PACKAGE__->meta->make_immutable;
+}
+
+{
+    my $foosub;
+    is(exception { $foosub = Foo::Sub1->new }, undef,
+       "instantiating concrete subclasses works");
+    isa_ok($foosub, 'Foo', 'inheritance is correct');
+}
+
+{
+    my $foosubsub;
+    is(exception { $foosubsub = Foo::Sub::Sub->new }, undef,
+       "instantiating deeper concrete subclasses works");
+    isa_ok($foosubsub, 'Foo', 'inheritance is correct');
+    isa_ok($foosubsub, 'Foo::Sub1', 'inheritance is correct');
+}
+
+like(exception { Foo->new }, qr/Foo is abstract, it cannot be instantiated/,
+     "instantiating abstract classes fails");
+
+done_testing;

t/custom-constructor.t

+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+
+our $custom_constructor_called = 0;
+
+{
+    package Foo;
+    use Moose;
+    use MooseX::ABCD;
+
+    requires 'bar', 'baz';
+    __PACKAGE__->meta->make_immutable;
+}
+
+{
+    package Foo::Sub;
+    use Moose;
+    extends 'Foo';
+
+    sub bar { }
+    sub baz { }
+    sub new { $::custom_constructor_called++; shift->SUPER::new(@_) }
+    __PACKAGE__->meta->make_immutable;
+}
+
+my $foosub = Foo::Sub->new;
+ok($custom_constructor_called, 'custom constructor was called');
+
+done_testing;
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use Test::Fatal;
+
+{
+    package Foo;
+    use Moose;
+    use MooseX::ABCD;
+
+    requires 'bar', 'baz';
+
+    __PACKAGE__->meta->make_immutable;
+}
+
+{
+    package Foo::Sub1;
+    use Moose;
+    ::is(::exception { extends 'Foo' }, undef,
+        "extending works when the requires are fulfilled");
+    sub bar { }
+    sub baz { }
+
+    __PACKAGE__->meta->make_immutable;
+}
+
+{
+    package Foo::Sub2;
+    use Moose;
+    extends 'Foo';
+    sub bar { }
+    ::like(
+        ::exception { __PACKAGE__->meta->make_immutable },
+        qr/Foo requires Foo::Sub2 to implement baz/,
+        "extending fails with the correct error when requires are not fulfilled",
+    );
+}
+
+{
+    package Foo::Sub::Sub;
+    use Moose;
+    ::is(::exception { extends 'Foo::Sub1' }, undef,
+        "extending twice works");
+
+    __PACKAGE__->meta->make_immutable;
+}
+
+{
+    my $foosub;
+    is(exception { $foosub = Foo::Sub1->new }, undef,
+       "instantiating concrete subclasses works");
+    isa_ok($foosub, 'Foo', 'inheritance is correct');
+}
+
+{
+    my $foosubsub;
+    is(exception { $foosubsub = Foo::Sub::Sub->new }, undef,
+       "instantiating deeper concrete subclasses works");
+    isa_ok($foosubsub, 'Foo', 'inheritance is correct');
+    isa_ok($foosubsub, 'Foo::Sub1', 'inheritance is correct');
+}
+
+like(exception { Foo->new }, qr/Foo is abstract, it cannot be instantiated/,
+     "instantiating abstract classes fails");
+
+done_testing;
+use Test::More;
+eval "use Test::Pod 1.00";
+plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+all_pod_files_ok();
+

xt/02pod_coverage.t

+use Test::More;
+use Test::Pod::Coverage;
+
+my @modules = qw(MooseX::ABCD);
+pod_coverage_ok($_, "$_ is covered") for @modules;
+done_testing(scalar @modules);
+

xt/03meta_uptodate.t

+use Test::More tests => 1;
+use Test::RDF::DOAP::Version;
+doap_version_ok('MooseX-ABCD', 'MooseX::ABCD');
+
+use Test::EOL;
+all_perl_files_ok();