Commits

Toby Inkster committed 63eeb06

initial version

Comments (0)

Files changed (18)

+use inc::Module::Package 'RDF:tobyink 0.009';
+
+dynamic_config();
+require('MRO::Compat', 0) if $] < 5.010;

lib/Class/Method/ModifiersX/Augment.pm

+package Class::Method::ModifiersX::Augment;
+
+use 5.008;
+use strict;
+use warnings;
+
+BEGIN {
+	$Class::Method::ModifiersX::Augment::AUTHORITY = 'cpan:TOBYINK';
+	$Class::Method::ModifiersX::Augment::VERSION   = '0.001';
+}
+
+use base qw(Exporter);
+our %EXPORT_TAGS = (
+	all => [our @EXPORT_OK = our @EXPORT = qw( augment inner )],
+);
+
+use Class::Method::Modifiers qw( install_modifier );
+
+use if ($] >= 5.010), 'mro';
+use if ($] <  5.010), 'MRO::Compat';
+
+our %INNER_BODY = ();
+our %INNER_ARGS = ();
+
+sub _mk_around
+{
+	my ($into, $code, $name) = @_;
+	unless ($name)
+	{
+		require Carp;
+		Carp::croak("need name");
+	}
+	
+	my $super;
+	my @isa = @{ mro::get_linear_isa($into) };
+	shift @isa;
+	SUPER: foreach my $pkg (@isa)
+	{
+		no strict qw(refs);
+		if (exists &{"${pkg}::${name}"})
+		{
+			$super = $pkg and last SUPER;
+		}
+	}
+	
+	return sub {
+		my $super_body = shift;
+		local $INNER_ARGS{$super} = [ @_ ];
+		local $INNER_BODY{$super} = $code;
+		return $super_body->(@_);
+	};
+}
+
+sub augment
+{
+	my $into = caller(0);
+	my $code = pop;
+	
+	foreach my $name (@_)
+	{
+		my $sub = _mk_around($into, $code, $name);
+		install_modifier($into, 'around', $name, $sub);
+	}
+}
+
+sub inner ()
+{
+	my $pkg = caller;
+	
+	if (my $body = $INNER_BODY{$pkg}) {
+		my @args = @{ $INNER_ARGS{$pkg} };
+		local $INNER_ARGS{$pkg};
+		local $INNER_BODY{$pkg};
+		return $body->(@args);
+	}
+	
+	return;
+}
+
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+Class::Method::ModifiersX::Augment - adds "augment method => sub {...}" support to Class::Method::Modifiers
+
+=head1 SYNOPSIS
+
+   use v5.14;
+   use strict;
+   use Test::More;
+   
+   package Document {
+      use Class::Method::ModifiersX::Augment;
+      sub new       { my ($class, %self) = @_; bless \%self, $class }
+      sub recipient { $_[0]{recipient} }
+      sub as_xml    { sprintf "<document>%s</document>", inner }
+   }
+   
+   package Greeting {
+      BEGIN { our @ISA = 'Document' };
+      use Class::Method::ModifiersX::Augment;
+      augment as_xml => sub {
+         sprintf "<greet>%s</greet>", inner
+      }
+   }
+   
+   package Greeting::English {
+      BEGIN { our @ISA = 'Greeting' };
+      use Class::Method::ModifiersX::Augment;
+      augment as_xml => sub {
+         my $self = shift;
+         sprintf "Hello %s", $self->recipient;
+      }
+   }
+   
+   my $obj = Greeting::English->new(recipient => "World");
+   is(
+      $obj->as_xml,
+      "<document><greet>Hello World</greet></document>",
+   );
+   
+   done_testing();
+
+(Note that the synopsis shows Perl v5.14+ syntax for package declaration,
+but this module and its accompanying Moo and Role::Tiny wrappers support
+Perl v5.8 and above.)
+
+=head1 DESCRIPTION
+
+Class::Method::ModifiersX::Augment extends L<Class::Method::Modifiers>
+with the C<augment> method modifier, allowing you to use this Moose
+abomination for augmenting superclass methods in non-Moose classes.
+
+See L<Moose::Manual::MethodModifiers> for details of how C<augment> and
+its companion function C<inner> work.
+
+This module exports two functions:
+
+=over
+
+=item C<< augment NAME, CODE >>
+
+=item C<< inner >>
+
+=back
+
+If you want to use these with L<Moo> classes, please look at L<MooX::Augment>
+instead.
+
+=head1 CAVEATS
+
+This implementation of C<< augment >> piggybacks onto
+Class::Method::Modifiers' implementation of C<< around >>. As a result,
+when multiple method modifiers are applied to the same method, the order
+in which they are applied might not match Moose.
+
+This has not been thoroughly tested in conjunction with
+L<Class::Method::ModifiersX::Override>. Using them in the same class should
+be safe. Using them to modify the same method will probably break your code.
+The only guarantee we give you is that you get to keep both halves.
+
+C<augment> modifiers do not work in Moo::Role or Role::Tiny roles. (Though
+C<inner> might.)
+
+C<augment>/C<inner> is a crazy idea to begin with, and virtually nobody
+understands it.
+
+=head1 BUGS
+
+If you find any bugs in this module they are almost certainly caused by
+one of the following reasons:
+
+=over
+
+=item * 
+
+You don't understand C<augment>/C<inner> properly, so you have incorrect
+expectations about how this module should behave.
+
+=item * 
+
+I don't understand C<augment>/C<inner> properly, so I have incorrect
+expectations about how this module should behave.
+
+=item * 
+
+Nobody understands C<augment>/C<inner> properly, and the whole idea is
+broken.
+
+=back
+
+Please report any bugs to
+L<http://rt.cpan.org/Dist/Display.html?Queue=Class-Method-ModifiersX-Augment>.
+
+=head1 DEPENDENCIES
+
+L<Class::Method::ModifiersX::Augment> requires Perl 5.008, and the
+L<Class::Method::Modifiers> package (which is available from CPAN).
+
+L<MRO::Compat> is also required for Perl versions earlier than 5.010.
+
+The accompanying module L<MooX::Augment> requires L<Moo> . However, the
+installation scripts for this distribution do not check that this is
+installed. If you use L<MooX::Augment>, it is assumed that you have installed
+its dependencies separately.
+
+=head1 SEE ALSO
+
+L<Moose::Manual::MethodModifiers>,
+L<Class::Method::Modifiers>,
+L<MooX::Augment>.
+
+=head1 AUTHOR
+
+Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
+
+=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/MooX/Augment.pm

+package MooX::Augment;
+
+use 5.008;
+use strict;
+use warnings;
+no warnings qw( once void uninitialized );
+
+BEGIN {
+	$MooX::Augment::AUTHORITY = 'cpan:TOBYINK';
+	$MooX::Augment::VERSION   = '0.001';
+}
+
+sub import
+{
+	goto &_import_class
+		if grep { $_ eq '-class' } @_;
+	goto &_import_role
+		if grep { $_ eq '-role' } @_;
+	
+	require Carp;
+	Carp::confess("MooX::Augment requires an indication of -class or -role; stopped");
+}
+
+sub _import_class
+{
+	my $target = caller;
+	
+	foreach my $fun (qw( augment inner ))
+	{
+		Moo::_install_tracked(
+			$target,
+			$fun,
+			sub {
+				require Class::Method::ModifiersX::Augment;
+				my $orig = Class::Method::ModifiersX::Augment->can($fun);
+				goto $orig;
+			},
+		);
+	}
+}
+
+sub _import_role
+{
+	my $target = caller;
+	my $INFO = \%Role::Tiny::INFO;
+	
+	Moo::Role::_install_tracked(
+		$target,
+		'augment',
+		sub {
+			require Carp;
+			Carp::confess("augment not supported in roles; stopped");
+		},
+	);
+	
+	Moo::_install_tracked(
+		$target,
+		'inner',
+		sub {
+			require Class::Method::ModifiersX::Augment;
+			my $orig = 'Class::Method::ModifiersX::Augment'->can('inner');
+			goto $orig;
+		},
+	);
+}
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+MooX::Augment - adds "augment method => sub {...}" support to Moo
+
+=head1 SYNOPSIS
+
+   use v5.14;
+   use strict;
+   use Test::More;
+   
+   package Document {
+      use Moo;
+      use MooX::Augment -class;
+      has recipient => (is => 'ro');
+      sub as_xml    { sprintf "<document>%s</document>", inner }
+   }
+   
+   package Greeting {
+      use Moo;
+      use MooX::Augment -class;
+      extends qw( Document );
+      augment as_xml => sub {
+         sprintf "<greet>%s</greet>", inner
+      }
+   }
+   
+   package Greeting::English {
+      use Moo;
+      use MooX::Augment -class;
+      extends qw( Greeting );
+      augment as_xml => sub {
+         my $self = shift;
+         sprintf "Hello %s", $self->recipient;
+      }
+   }
+   
+   my $obj = Greeting::English->new(recipient => "World");
+   is(
+      $obj->as_xml,
+      "<document><greet>Hello World</greet></document>",
+   );
+   
+   done_testing();
+
+=head1 DESCRIPTION
+
+MooX::Augment extends L<Moo> with the C<augment> method modifier, allowing
+you to use this Moose abomination for augmenting superclass methods in Moo
+classes.
+
+You need to indicate whether you are using this within a Moo class or a Moo
+role:
+
+   use MooX::Augment -class;
+   use MooX::Augment -role;
+
+Note that Moo roles B<cannot> provide C<augment> method modifiers. Roles
+may import C<inner> though it has not been thoroughly tested and may be of
+limited utility.
+
+See L<Class::Method::ModifiersX::Augment> for further details.
+
+=head1 SEE ALSO
+
+L<Moo>,
+L<Class::Method::ModifiersX::Augment>.
+
+=head1 AUTHOR
+
+Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
+
+=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.
+

meta/changes.pret

+# This file acts as the project's changelog.
+
+`Class-Method-ModifiersX-Augment 0.001 cpan:TOBYINK`
+	issued  2012-11-02;
+	label   "Initial release".
+
+# This file contains general metadata about the project.
+
+@prefix : <http://usefulinc.com/ns/doap#>.
+
+`Class-Method-ModifiersX-Augment`
+	:programming-language "Perl" ;
+	:shortdesc            "adds \"augment method => sub {...}\" support to Class::Method::Modifiers";
+	:homepage             <https://metacpan.org/release/Class-Method-ModifiersX-Augment>;
+	:download-page        <https://metacpan.org/release/Class-Method-ModifiersX-Augment>;
+	:bug-database         <http://rt.cpan.org/Dist/Display.html?Queue=Class-Method-ModifiersX-Augment>;
+	:repository           [ a :HgRepository; :browse <https://bitbucket.org/tobyink/p5-class-method-modifiersx-augment> ];
+	:created              2012-11-02;
+	: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".
+

meta/makefile.pret

+# This file provides instructions for packaging.
+
+`Class-Method-ModifiersX-Augment`
+	perl_version_from m`Class::Method::ModifiersX::Augment`;
+	version_from      m`Class::Method::ModifiersX::Augment`;
+	readme_from       m`Class::Method::ModifiersX::Augment`;
+	test_requires     p`Test::More 0.61`;
+	requires          p`Class::Method::Modifiers`;
+	recommends        p`Moo`;
+	recommends        p`MRO::Compat`;
+.
+
+# This file contains data about the project developers.
+
+@prefix : <http://xmlns.com/foaf/0.1/>.
+
+cpan:TOBYINK
+	:name  "Toby Inkster";
+	:mbox  <mailto:tobyink@cpan.org>.
+
+use Test::More tests => 1;
+BEGIN { use_ok('Class::Method::ModifiersX::Augment') };
+
+use strict;
+use Test::More;
+
+{
+	package Document;
+	use Class::Method::ModifiersX::Augment;
+	sub new       { my ($class, %self) = @_; bless \%self, $class }
+	sub recipient { $_[0]{recipient} }
+	sub as_xml    { sprintf "<document>%s</document>", inner }
+}
+
+{
+	package Greeting;
+	BEGIN { our @ISA = 'Document' };
+	use Class::Method::ModifiersX::Augment;
+	augment as_xml => sub {
+		sprintf "<greet>%s</greet>", inner
+	}
+}
+
+{
+	package Greeting::English;
+	BEGIN { our @ISA = 'Greeting' };
+	use Class::Method::ModifiersX::Augment;
+	augment as_xml => sub {
+		my $self = shift;
+		sprintf "Hello %s", $self->recipient;
+	}
+}
+
+my $obj1 = Document->new(recipient => "World");
+is(
+	$obj1->as_xml,
+	"<document></document>",
+);
+
+my $obj2 = Greeting->new(recipient => "World");
+is(
+	$obj2->as_xml,
+	"<document><greet></greet></document>",
+);
+
+my $obj3 = Greeting::English->new(recipient => "World");
+is(
+	$obj3->as_xml,
+	"<document><greet>Hello World</greet></document>",
+);
+
+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 XT::Util;
+use Test::More;
+use Test::Pod::Coverage;
+
+plan skip_all => __CONFIG__->{skip_all}
+	if __CONFIG__->{skip_all};
+
+if ( __CONFIG__->{modules} )
+{
+	my @modules = @{ __CONFIG__->{modules} };
+	pod_coverage_ok($_, "$_ is covered") for @modules;
+	done_testing(scalar @modules);
+}
+else
+{
+	all_pod_coverage_ok();
+}
+

xt/03meta_uptodate.config

+{"package":"Class-Method-ModifiersX-Augment"}
+

xt/03meta_uptodate.t

+use XT::Util;
+use Test::More tests => 1;
+use Test::RDF::DOAP::Version;
+doap_version_ok(__CONFIG__->{package}, __CONFIG__->{version_from});
+
+use Test::EOL;
+all_perl_files_ok();
+use Test::Tabs;
+all_perl_files_ok();
+use XT::Util;
+use Test::More;
+use Test::HasVersion;
+
+plan skip_all => __CONFIG__->{skip_all}
+	if __CONFIG__->{skip_all};
+
+if ( __CONFIG__->{modules} )
+{
+	my @modules = @{ __CONFIG__->{modules} };
+	pm_version_ok($_, "$_ is covered") for @modules;
+	done_testing(scalar @modules);
+}
+else
+{
+	all_pm_version_ok();
+}
+

xt/synopsis-moo.t

+use v5.14;
+use strict;
+use Test::More;
+
+package Document {
+	use Moo;
+	use MooX::Augment -class;
+	has recipient => (is => 'ro');
+	sub as_xml    { sprintf "<document>%s</document>", inner }
+}
+
+package Greeting {
+	use Moo;
+	use MooX::Augment -class;
+	extends qw( Document );
+	augment as_xml => sub {
+		sprintf "<greet>%s</greet>", inner
+	}
+}
+
+package Greeting::English {
+	use Moo;
+	use MooX::Augment -class;
+	extends qw( Greeting );
+	augment as_xml => sub {
+		my $self = shift;
+		sprintf "Hello %s", $self->recipient;
+	}
+}
+
+my $obj = Greeting::English->new(recipient => "World");
+is(
+	$obj->as_xml,
+	"<document><greet>Hello World</greet></document>",
+);
+
+done_testing();
+use v5.14;
+use strict;
+use Test::More;
+
+package Document {
+	use Class::Method::ModifiersX::Augment;
+	sub new       { my ($class, %self) = @_; bless \%self, $class }
+	sub recipient { $_[0]{recipient} }
+	sub as_xml    { sprintf "<document>%s</document>", inner }
+}
+
+package Greeting {
+	BEGIN { our @ISA = 'Document' };
+	use Class::Method::ModifiersX::Augment;
+	augment as_xml => sub {
+		sprintf "<greet>%s</greet>", inner
+	}
+}
+
+package Greeting::English {
+	BEGIN { our @ISA = 'Greeting' };
+	use Class::Method::ModifiersX::Augment;
+	augment as_xml => sub {
+		my $self = shift;
+		sprintf "Hello %s", $self->recipient;
+	}
+}
+
+my $obj = Greeting::English->new(recipient => "World");
+is(
+	$obj->as_xml,
+	"<document><greet>Hello World</greet></document>",
+);
+
+done_testing();