# prereqs
requires 'Scalar::Util' => $win32 ? '1.17' : '1.18';
requires 'Carp';
-requires 'Class::MOP' => '0.64';
-requires 'Sub::Exporter' => '0.972';
+requires 'Class::MOP' => '0.64';
+requires 'List::MoreUtils';
+requires 'Sub::Exporter' => '0.972';
# only used by oose.pm, not Moose.pm :P
requires 'Filter::Simple' => '0';
use Scalar::Util 'blessed';
use Carp 'confess', 'croak', 'cluck';
-use Sub::Exporter;
+use Moose::Exporter;
use Class::MOP 0.64;
use Moose::Util::TypeConstraints;
use Moose::Util ();
-{
- my $CALLER;
-
- my %exports = (
- extends => sub {
- my $class = $CALLER;
- return Class::MOP::subname('Moose::extends' => sub (@) {
- croak "Must derive at least one class" unless @_;
-
- my @supers = @_;
- foreach my $super (@supers) {
- Class::MOP::load_class($super);
- croak "You cannot inherit from a Moose Role ($super)"
- if $super->can('meta') &&
- blessed $super->meta &&
- $super->meta->isa('Moose::Meta::Role')
- }
-
-
-
- # this checks the metaclass to make sure
- # it is correct, sometimes it can get out
- # of sync when the classes are being built
- my $meta = $class->meta->_fix_metaclass_incompatability(@supers);
- $meta->superclasses(@supers);
- });
- },
- with => sub {
- my $class = $CALLER;
- return Class::MOP::subname('Moose::with' => sub (@) {
- Moose::Util::apply_all_roles($class->meta, @_)
- });
- },
- has => sub {
- my $class = $CALLER;
- return Class::MOP::subname('Moose::has' => sub ($;%) {
- my $name = shift;
- croak 'Usage: has \'name\' => ( key => value, ... )' if @_ == 1;
- my %options = @_;
- my $attrs = ( ref($name) eq 'ARRAY' ) ? $name : [ ($name) ];
- $class->meta->add_attribute( $_, %options ) for @$attrs;
- });
- },
- before => sub {
- my $class = $CALLER;
- return Class::MOP::subname('Moose::before' => sub (@&) {
- Moose::Util::add_method_modifier($class, 'before', \@_);
- });
- },
- after => sub {
- my $class = $CALLER;
- return Class::MOP::subname('Moose::after' => sub (@&) {
- Moose::Util::add_method_modifier($class, 'after', \@_);
- });
- },
- around => sub {
- my $class = $CALLER;
- return Class::MOP::subname('Moose::around' => sub (@&) {
- Moose::Util::add_method_modifier($class, 'around', \@_);
- });
- },
- super => sub {
- return Class::MOP::subname('Moose::super' => sub {
- return unless our $SUPER_BODY; $SUPER_BODY->(our @SUPER_ARGS)
- });
- },
- override => sub {
- my $class = $CALLER;
- return Class::MOP::subname('Moose::override' => sub ($&) {
- my ( $name, $method ) = @_;
- $class->meta->add_override_method_modifier( $name => $method );
- });
- },
- inner => sub {
- return Class::MOP::subname('Moose::inner' => sub {
- my $pkg = caller();
- our ( %INNER_BODY, %INNER_ARGS );
-
- if ( my $body = $INNER_BODY{$pkg} ) {
- my @args = @{ $INNER_ARGS{$pkg} };
- local $INNER_ARGS{$pkg};
- local $INNER_BODY{$pkg};
- return $body->(@args);
- } else {
- return;
- }
- });
- },
- augment => sub {
- my $class = $CALLER;
- return Class::MOP::subname('Moose::augment' => sub (@&) {
- my ( $name, $method ) = @_;
- $class->meta->add_augment_method_modifier( $name => $method );
- });
- },
- make_immutable => sub {
- my $class = $CALLER;
- return Class::MOP::subname('Moose::make_immutable' => sub {
- cluck "The make_immutable keyword has been deprecated, " .
- "please go back to __PACKAGE__->meta->make_immutable\n";
- $class->meta->make_immutable(@_);
- });
- },
- confess => sub {
- return \&Carp::confess;
- },
- blessed => sub {
- return \&Scalar::Util::blessed;
- },
- );
-
- my $exporter = Sub::Exporter::build_exporter(
- {
- exports => \%exports,
- groups => { default => [':all'] }
- }
- );
-
- # 1 extra level because it's called by import so there's a layer of indirection
- sub _get_caller{
- my $offset = 1;
- return
- (ref $_[1] && defined $_[1]->{into})
- ? $_[1]->{into}
- : (ref $_[1] && defined $_[1]->{into_level})
- ? caller($offset + $_[1]->{into_level})
- : caller($offset);
- }
-
- sub import {
- $CALLER = _get_caller(@_);
+sub extends {
+ my $class = shift;
- # this works because both pragmas set $^H (see perldoc perlvar)
- # which affects the current compilation - i.e. the file who use'd
- # us - which is why we don't need to do anything special to make
- # it affect that file rather than this one (which is already compiled)
+ croak "Must derive at least one class" unless @_;
- strict->import;
- warnings->import;
+ my @supers = @_;
+ foreach my $super (@supers) {
+ Class::MOP::load_class($super);
+ croak "You cannot inherit from a Moose Role ($super)"
+ if $super->can('meta') &&
+ blessed $super->meta &&
+ $super->meta->isa('Moose::Meta::Role')
+ }
- # we should never export to main
- if ($CALLER eq 'main') {
- warn qq{Moose does not export its sugar to the 'main' package.\n};
- return;
- }
- init_meta( $CALLER, 'Moose::Object' );
- goto $exporter;
- }
-
- # NOTE:
- # This is for special use by
- # some modules and stuff, I
- # dont know if it is sane enough
- # to document actually.
- # - SL
- sub __CURRY_EXPORTS_FOR_CLASS__ {
- $CALLER = shift;
- ($CALLER ne 'Moose')
- || croak "_import_into must be called a function, not a method";
- ($CALLER->can('meta') && $CALLER->meta->isa('Class::MOP::Class'))
- || croak "Cannot call _import_into on a package ($CALLER) without a metaclass";
- return map { $_ => $exports{$_}->() } (@_ ? @_ : keys %exports);
- }
+ # this checks the metaclass to make sure
+ # it is correct, sometimes it can get out
+ # of sync when the classes are being built
+ my $meta = $class->meta->_fix_metaclass_incompatability(@supers);
+ $meta->superclasses(@supers);
+}
- sub unimport {
- my $class = _get_caller(@_);
+sub with {
+ my $class = shift;
+ Moose::Util::apply_all_roles($class->meta, @_);
+}
- _remove_keywords(
- source => __PACKAGE__,
- package => $class,
- keywords => [ keys %exports ],
- );
- }
+sub has {
+ my $class = shift;
+ my $name = shift;
+ croak 'Usage: has \'name\' => ( key => value, ... )' if @_ == 1;
+ my %options = @_;
+ my $attrs = ( ref($name) eq 'ARRAY' ) ? $name : [ ($name) ];
+ $class->meta->add_attribute( $_, %options ) for @$attrs;
+}
+sub before {
+ my $class = shift;
+ Moose::Util::add_method_modifier($class, 'before', \@_);
}
-sub _remove_keywords {
- my ( %args ) = @_;
+sub after {
+ my $class = shift;
+ Moose::Util::add_method_modifier($class, 'after', \@_);
+}
- my $source = $args{source};
- my $package = $args{package};
+sub around {
+ my $class = shift;
+ Moose::Util::add_method_modifier($class, 'around', \@_);
+}
- no strict 'refs';
+sub super {
+ return unless our $SUPER_BODY; $SUPER_BODY->(our @SUPER_ARGS);
+}
- # loop through the keywords ...
- foreach my $name ( @{ $args{keywords} } ) {
+sub override {
+ my $class = shift;
+ my ( $name, $method ) = @_;
+ $class->meta->add_override_method_modifier( $name => $method );
+}
- # if we find one ...
- if ( defined &{ $package . '::' . $name } ) {
- my $keyword = \&{ $package . '::' . $name };
+sub inner {
+ my $pkg = caller();
+ our ( %INNER_BODY, %INNER_ARGS );
+
+ if ( my $body = $INNER_BODY{$pkg} ) {
+ my @args = @{ $INNER_ARGS{$pkg} };
+ local $INNER_ARGS{$pkg};
+ local $INNER_BODY{$pkg};
+ return $body->(@args);
+ } else {
+ return;
+ }
+}
- # make sure it is from us
- my ($pkg_name) = Class::MOP::get_code_info($keyword);
- next if $pkg_name ne $source;
+sub augment {
+ my $class = shift;
+ my ( $name, $method ) = @_;
+ $class->meta->add_augment_method_modifier( $name => $method );
+}
- # and if it is from us, then undef the slot
- delete ${ $package . '::' }{$name};
- }
- }
+sub make_immutable {
+ my $class = shift;
+ cluck "The make_immutable keyword has been deprecated, " .
+ "please go back to __PACKAGE__->meta->make_immutable\n";
+ $class->meta->make_immutable(@_);
}
+my $exporter = Moose::Exporter->build_import_methods(
+ with_caller => [
+ qw( extends with has before after around override augment make_immutable )
+ ],
+ as_is => [
+ qw( super inner ),
+ \&Carp::confess,
+ \&Scalar::Util::blessed,
+ ],
+);
+
sub init_meta {
- my ( $class, $base_class, $metaclass ) = @_;
- $base_class = 'Moose::Object' unless defined $base_class;
- $metaclass = 'Moose::Meta::Class' unless defined $metaclass;
+ # This used to be called as a function. This hack preserves
+ # backwards compatibility.
+ if ( $_[0] ne __PACKAGE__ ) {
+ return __PACKAGE__->init_meta(
+ for_class => $_[0],
+ base_class => $_[1],
+ metaclass => $_[2],
+ );
+ }
+
+ shift;
+ my %args = @_;
+
+ my $class = $args{for_class}
+ or confess "Cannot call init_meta without specifying a for_class";
+ my $base_class = $args{base_class} || 'Moose::Object';
+ my $metaclass = $args{metaclass} || 'Moose::Meta::Class';
confess
"The Metaclass $metaclass must be a subclass of Moose::Meta::Class."
$meta->superclasses($base_class)
unless $meta->superclasses();
+
return $meta;
}
+# This may be used in some older MooseX extensions.
+sub _get_caller {
+ goto &Moose::Exporter::_get_caller;
+}
+
## make 'em all immutable
$_->meta->make_immutable(
=head1 EXTENDING AND EMBEDDING MOOSE
-Moose also offers some options for extending or embedding it into your own
-framework. The basic premise is to have something that sets up your class'
-metaclass and export the moose declarators (C<has>, C<with>, C<extends>,...).
-Here is an example:
+Moose also offers some options for extending or embedding it into your
+own framework. There are several things you might want to do as part
+of such a framework. First, you probably want to export Moose's sugar
+functions (C<has>, C<extends>, etc) for users of the
+framework. Second, you may want to provide additional sugar of your
+own. Third, you may want to provide your own object base class instead
+of L<Moose::Object>, and/or your own metaclass class instead of
+L<Moose::Meta::Class>.
- package MyFramework;
- use Moose;
+The exporting needs can be asily satisfied by using
+L<Moose::Exporter>, which is what C<Moose.pm> itself uses for
+exporting. L<Moose::Exporter> lets you "export like Moose".
+
+If you define an C<init_meta> method in a module that uses
+L<Moose::Exporter>, then this method will be called I<before>
+C<Moose.pm>'s own C<init_meta>. This gives you a chance to provide an
+alternate object base class or metaclass class.
+
+Here is a simple example:
- sub import {
- my $CALLER = caller();
+ package MyFramework;
- strict->import;
- warnings->import;
+ use strict;
+ use warnings;
- # we should never export to main
- return if $CALLER eq 'main';
- Moose::init_meta( $CALLER, 'MyFramework::Base' );
- Moose->import({into => $CALLER});
+ use Moose (); # no need to get Moose's exports
+ use Moose::Exporter;
- # Do my custom framework stuff
+ Moose::Exporter->build_import_methods( also => 'Moose' );
- return 1;
+ sub init_meta {
+ shift;
+ return Moose->init_meta( @_, base_class => 'MyFramework::Base' );
}
-=head2 B<import>
+In this example, any class that includes C<use MyFramework> will get
+all of C<Moose.pm>'s sugar functions, and will have their superclass
+set to C<MyFramework::Base>.
-Moose's C<import> method supports the L<Sub::Exporter> form of C<{into =E<gt> $pkg}>
-and C<{into_level =E<gt> 1}>
+Additionally, that class can include C<no MyFramework> to unimport
-=head2 B<init_meta ($class, $baseclass, $metaclass)>
+=head2 B<< Moose->init_meta(for_class => $class, base_class => $baseclass, metaclass => $metaclass) >>
-Moose does some boot strapping: it creates a metaclass object for your class,
-and then injects a C<meta> accessor into your class to retrieve it. Then it
-sets your baseclass to Moose::Object or the value you pass in unless you already
-have one. This is all done via C<init_meta> which takes the name of your class
-and optionally a baseclass and a metaclass as arguments.
+The C<init_meta> method sets up the metaclass object for the class
+specified by C<for_class>. It also injects a a C<meta> accessor into
+the class so you can get at this object. It also sets the class's
+superclass to C<base_class>, with L<Moose::Object> as the default.
+
+You can specify an alternate metaclass with the C<metaclass> parameter.
For more detail on this topic, see L<Moose::Cookbook::Extending::Recipe2>.
+This method used to be documented as a function which accepted
+positional parameters. This calling style will still work for
+backwards compatibility.
+
+=head2 B<import>
+
+Moose's C<import> method supports the L<Sub::Exporter> form of C<{into =E<gt> $pkg}>
+and C<{into_level =E<gt> 1}>.
+
+B<NOTE>: Doing this is more or less deprecated. Use L<Moose::Exporter>
+instead, which lets you stack multiple C<Moose.pm>-alike modules
+sanely. It handles getting the exported functions into the right place
+for you.
+
=head1 CAVEATS
=over 4
package MyApp::UseMyBase;
use Moose ();
+ use Moose::Exporter;
- sub import {
- my $caller = caller();
+ Moose::Exporter->build_import_methods( also => 'Moose' );
- return if $caller eq 'main';
-
- Moose::init_meta( $caller,
- 'MyApp::Object',
- );
-
- Moose->import( { into => $caller }, @_ );
- }
-
- sub unimport {
- my $caller = caller();
-
- Moose->unimport( { into => $caller }, @_ );
+ sub init_meta {
+ shift;
+ Moose->init_meta( @_, base_class => 'MyApp::Object' );
}
=head1 DESCRIPTION
output every time a new object is created, but you can surely think of
some more interesting things to do with your own base class.
+This all works because of the magic of L<Moose::Exporter>. When we
+call C<< Moose::Exporter->build_import_methods( also => 'Moose' ) >>
+it builds an C<import> and C<unimport> method for you. The C<< also =>
+'Moose' >> bit says that we want to export everything that Moose does.
+
+The C<import> method that gets created will call our C<init_meta>
+method, passing it C<< for_caller => $caller >> as its arguments. The
+C<$caller> is set to the class that actually imported us in the first
+place.
+
+See the L<Moose::Exporter> docs for more details on its API.
+
+=head1 USING MyApp::UseMyBase
+
+To actually use our new base class, we simply use C<MyApp::UseMyBase>
+I<instead> of C<Moose>. We get all the Moose sugar plus our new base
+class.
+
+ package Foo;
+
+ use MyApp::UseMyBase;
+
+ has 'size' => ( is => 'rw' );
+
+ no MyApp::UseMyBase;
+
=head1 AUTHOR
Dave Rolsky E<lt>autarch@urth.orgE<gt>
use strict;
use warnings;
- our @EXPORT = qw( has_table );
-
- use base 'Exporter';
- use Class::MOP;
use Moose ();
+ use Moose::Exporter;
- sub import {
- my $caller = caller();
-
- return if $caller eq 'main';
-
- Moose::init_meta(
- $caller,
- undef, # object base class
- 'MyApp::Meta::Class',
- );
-
- Moose->import( { into => $caller }, @_ );
-
- __PACKAGE__->export_to_level( 1, @_ );
- }
-
- sub unimport {
- my $caller = caller();
-
- Moose::_remove_keywords(
- source => __PACKAGE__,
- package => $caller,
- keywords => \@EXPORT,
- );
+ Moose::Exporter->build_import_methods(
+ with_caller => ['has_table'],
+ also => 'Moose',
+ );
- Moose->unimport( { into_level => 1 } );
+ sub init_meta {
+ shift;
+ Moose->init_meta( @_, metaclass => 'MyApp::Meta::Class' );
}
sub has_table {
- my $caller = caller();
-
+ my $caller = shift;
$caller->meta()->table(shift);
}
=head1 DESCRIPTION
-The code above shows what it takes to provide an import-based
-interface just like C<Moose.pm>. This recipe builds on
+This recipe expands on the use of L<Moose::Exporter> we saw in
L<Moose::Cookbook::Extending::Recipe1>. Instead of providing our own
object base class, we provide our own metaclass class, and we also
export a sugar subroutine C<has_table()>.
Moose> with C<use MyApp::Mooseish>. Similarly, C<no Moose> is now
replaced with C<no MyApp::Mooseish>.
-=head1 WARNING
+The C<with_caller> parameter specifies a list of functions that should
+be wrapped before exporting. The wrapper simply ensures that the
+importing package name is the first argument to the function, so we
+can do C<S<my $caller = shift;>>.
-This recipe covers a fairly undocumented and ugly part of Moose, and
-the techniques described here may be deprecated in a future
-release. If this happens, there will be plenty of warning, as a number
-of C<MooseX> modules on CPAN already use these techniques.
+See the L<Moose::Exporter> docs for more details on its API.
-=head1 HOW IT IS USED
+=head1 USING MyApp::Mooseish
The purpose of all this code is to provide a Moose-like
interface. Here's what it would look like in actual use:
has_table 'User';
- has 'username';
- has 'password';
+ has 'username' => ( is => 'ro' );
+ has 'password' => ( is => 'ro' );
sub login { ... }
All of the normal Moose sugar (C<has()>, C<with()>, etc) is available
when you C<use MyApp::Mooseish>.
-=head1 DISSECTION
-
-The first bit of magic is the call to C<Moose::init_meta()>. What this
-does is create a metaclass for the specified class. Normally, this is
-called by C<Moose.pm> in its own C<import()> method. However, we can
-call it first in order to provide an alternate metaclass class. We
-could also provide an alternate base object class to replace
-C<Moose::Object> (see L<Moose::Cookbook::Extending::Recipe1> for an
-example).
-
-The C<Moose::init_meta()> call takes three parameters. The first is
-the class for which we are initializing a metaclass object. The second
-is the base object, which is L<Moose::Object> by default. The third
-argument is the metaclass class, which is C<Moose::Meta::Class> by
-default.
-
-The next bit of magic is this:
-
- Moose->import( { into => $caller } );
-
-This use of "into" is actually part of the C<Sub::Exporter> API, which
-C<Moose.pm> uses internally to export things like C<has()> and
-C<extends()>.
-
-Finally, we call C<< __PACKAGE__->export_to_level() >>. This method
-actually comes from C<Exporter>.
-
-This is all a bit fragile since it doesn't stack terribly well. You
-can basically only have one Moose-alike module. This may be fixed in
-the still-notional C<MooseX::Exporter> module someday.
-
-The C<unimport()> subroutine calls the C<_remove_keywords> function
-from Moose. This function removes only the keywords exported by
-this module. More precisely, C<_remove_keywords> removes from the
-C<package> package the keywords given by the C<keywords> argument
-that were created in the C<source> package. This functionality may
-be deprecated if L<Sub::Exporter> begins providing it.
-
-Finally, we have our C<has_table()> subroutine. This provides a bit of
-sugar that looks a lot like C<has()>.
-
=head1 AUTHOR
Dave Rolsky E<lt>autarch@urth.orgE<gt>
--- /dev/null
+package Moose::Exporter;
+
+use strict;
+use warnings;
+
+use Class::MOP;
+use List::MoreUtils qw( uniq );
+use Sub::Exporter;
+
+
+my %EXPORT_SPEC;
+
+sub build_import_methods {
+ my $class = shift;
+ my %args = @_;
+
+ my $exporting_package = caller();
+
+ $EXPORT_SPEC{$exporting_package} = \%args;
+
+ my @exports_from = $class->_follow_also( $exporting_package );
+
+ my $exports
+ = $class->_process_exports( $exporting_package, @exports_from );
+
+ my $exporter = Sub::Exporter::build_exporter(
+ {
+ exports => $exports,
+ groups => { default => [':all'] }
+ }
+ );
+
+ my $import = $class->_make_import_sub( $exporter, \@exports_from );
+
+ my $unimport = $class->_make_unimport_sub( \@exports_from, [ keys %{$exports} ] );
+
+ no strict 'refs';
+ *{ $exporting_package . '::import' } = $import;
+ *{ $exporting_package . '::unimport' } = $unimport;
+}
+
+{
+ my %seen;
+
+ sub _follow_also {
+ my $class = shift;
+ my $exporting_package = shift;
+
+ %seen = ( $exporting_package => 1 );
+
+ return uniq( _follow_also_real($exporting_package) );
+ }
+
+ sub _follow_also_real {
+ my $exporting_package = shift;
+
+ die "Package in also ($exporting_package) does not seem to use MooseX::Exporter"
+ unless exists $EXPORT_SPEC{$exporting_package};
+
+ my $also = $EXPORT_SPEC{$exporting_package}{also};
+
+ return unless defined $also;
+
+ my @also = ref $also ? @{$also} : $also;
+
+ for my $package (@also)
+ {
+ die "Circular reference in also parameter to MooseX::Exporter between $exporting_package and $package"
+ if $seen{$package};
+
+ $seen{$package} = 1;
+ }
+
+ return @also, map { _follow_also_real($_) } @also;
+ }
+}
+
+sub _process_exports {
+ my $class = shift;
+ my @packages = @_;
+
+ my %exports;
+
+ for my $package (@packages) {
+ my $args = $EXPORT_SPEC{$package}
+ or die "The $package package does not use Moose::Exporter\n";
+
+ for my $name ( @{ $args->{with_caller} } ) {
+ my $sub = do {
+ no strict 'refs';
+ \&{ $package . '::' . $name };
+ };
+
+ $exports{$name} = $class->_make_wrapped_sub(
+ $package,
+ $name,
+ $sub
+ );
+ }
+
+ for my $name ( @{ $args->{as_is} } ) {
+ my $sub;
+
+ if ( ref $name ) {
+ $sub = $name;
+ $name = ( Class::MOP::get_code_info($name) )[1];
+ }
+ else {
+ $sub = do {
+ no strict 'refs';
+ \&{ $package . '::' . $name };
+ };
+ }
+
+ $exports{$name} = sub {$sub};
+ }
+ }
+
+ return \%exports;
+}
+
+{
+ # This variable gets closed over in each export _generator_. Then
+ # in the generator we grab the value and close over it _again_ in
+ # the real export, so it gets captured each time the generator
+ # runs.
+ #
+ # In the meantime, we arrange for the import method we generate to
+ # set this variable to the caller each time it is called.
+ #
+ # This is all a bit confusing, but it works.
+ my $CALLER;
+
+ sub _make_wrapped_sub {
+ my $class = shift;
+ my $exporting_package = shift;
+ my $name = shift;
+ my $sub = shift;
+
+ # We need to set the package at import time, so that when
+ # package Foo imports has(), we capture "Foo" as the
+ # package. This lets other packages call Foo::has() and get
+ # the right package. This is done for backwards compatibility
+ # with existing production code, not because this is a good
+ # idea ;)
+ return sub {
+ my $caller = $CALLER;
+ Class::MOP::subname( $exporting_package . '::'
+ . $name => sub { $sub->( $caller, @_ ) } );
+ };
+ }
+
+ sub _make_import_sub {
+ shift;
+ my $exporter = shift;
+ my $exports_from = shift;
+
+ return sub {
+
+ # It's important to leave @_ as-is for the benefit of
+ # Sub::Exporter.
+ my $class = $_[0];
+
+ $CALLER = Moose::Exporter::_get_caller(@_);
+
+ # this works because both pragmas set $^H (see perldoc
+ # perlvar) which affects the current compilation -
+ # i.e. the file who use'd us - which is why we don't need
+ # to do anything special to make it affect that file
+ # rather than this one (which is already compiled)
+
+ strict->import;
+ warnings->import;
+
+ # we should never export to main
+ if ( $CALLER eq 'main' ) {
+ warn
+ qq{$class does not export its sugar to the 'main' package.\n};
+ return;
+ }
+
+ for my $c (grep { $_->can('init_meta') } $class, @{$exports_from} ) {
+
+ $c->init_meta( for_class => $CALLER );
+ }
+
+ goto $exporter;
+ };
+ }
+}
+
+sub _get_caller {
+ # 1 extra level because it's called by import so there's a layer
+ # of indirection
+ my $offset = 1;
+
+ return
+ ( ref $_[1] && defined $_[1]->{into} ) ? $_[1]->{into}
+ : ( ref $_[1] && defined $_[1]->{into_level} )
+ ? caller( $offset + $_[1]->{into_level} )
+ : caller($offset);
+}
+
+sub _make_unimport_sub {
+ shift;
+ my $sources = shift;
+ my $keywords = shift;
+
+ return sub {
+ my $class = shift;
+ my $caller = scalar caller();
+ Moose::Exporter->_remove_keywords(
+ $caller,
+ [ $class, @{$sources} ],
+ $keywords
+ );
+ };
+}
+
+sub _remove_keywords {
+ shift;
+ my $package = shift;
+ my $sources = shift;
+ my $keywords = shift;
+
+ my %sources = map { $_ => 1 } @{$sources};
+
+ no strict 'refs';
+
+ # loop through the keywords ...
+ foreach my $name ( @{$keywords} ) {
+
+ # if we find one ...
+ if ( defined &{ $package . '::' . $name } ) {
+ my $keyword = \&{ $package . '::' . $name };
+
+ # make sure it is from us
+ my ($pkg_name) = Class::MOP::get_code_info($keyword);
+ next unless $sources{$pkg_name};
+
+ # and if it is from us, then undef the slot
+ delete ${ $package . '::' }{$name};
+ }
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Moose::Exporter - make an import() and unimport() just like Moose.pm
+
+=head1 SYNOPSIS
+
+ package MyApp::Moose;
+
+ use strict;
+ use warnings;
+
+ use Moose ();
+ use Moose::Exporter;
+
+ Moose::Exporter->build_export_methods(
+ export => [ 'sugar1', 'sugar2', \&Some::Random::thing ],
+ init_meta_args => { metaclass_class => 'MyApp::Meta::Class' ],
+ );
+
+ # then later ...
+ package MyApp::User;
+
+ use MyApp::Moose;
+
+ has 'name';
+ sugar1 'do your thing';
+ thing;
+
+ no MyApp::Moose;
+
+=head1 DESCRIPTION
+
+This module encapsulates the logic to export sugar functions like
+C<Moose.pm>. It does this by building custom C<import> and C<unimport>
+methods for your module, based on a spec your provide.
+
+It also lets your "stack" Moose-alike modules so you can export
+Moose's sugar as well as your own, along with sugar from any random
+C<MooseX> module, as long as they all use C<Moose::Exporter>.
+
+=head1 METHODS
+
+This module provides exactly one public method:
+
+=head2 Moose::Exporter->build_import_methods(...)
+
+When you call this method, C<Moose::Exporter> build custom C<import>
+and C<unimport> methods for your module. The import method will export
+the functions you specify, and you can also tell it to export
+functions exported by some other module (like C<Moose.pm>).
+
+The C<unimport> method cleans the callers namespace of all the
+exported functions.
+
+This method accepts the following parameters:
+
+=over 4
+
+=item * with_caller => [ ... ]
+
+This a list of function I<names only> to be exported wrapped and then
+exported. The wrapper will pass the name of the calling package as the
+first argument to the function. Many sugar functions need to know
+their caller so they can get the calling package's metaclass object.
+
+=item * as_is => [ ... ]
+
+This a list of function names or sub references to be exported
+as-is. You can identify a subroutine by reference, which is handy to
+re-export some other module's functions directly by reference
+(C<\&Some::Package::function>).
+
+=item * also => $name or \@names
+
+This is a list of modules which contain functions that the caller
+wants to export. These modules must also use C<Moose::Exporter>. The
+most common use case will be to export the functions from C<Moose.pm>.
+
+C<Moose::Exporter> also makes sure all these functions get removed
+when C<unimport> is called.
+
+=back
+
+=head1 IMPORTING AND init_meta
+
+If you want to set an alternative base object class or metaclass
+class, simply define an C<init_meta> method in your class. The
+C<import> method that C<Moose::Exporter> generates for you will call
+this method (if it exists). It will always pass the caller to this
+method via the C<for_class> parameter.
+
+Most of the time, your C<init_meta> method will probably just call C<<
+Moose->init_meta >> to do the real work:
+
+ sub init_meta {
+ shift; # our class name
+ return Moose->init_meta( @_, metaclass => 'My::Metaclass' );
+ }
+
+=head1 AUTHOR
+
+Dave Rolsky E<lt>autarch@urth.orgE<gt>
+
+This is largely a reworking of code in Moose.pm originally written by
+Stevan Little and others.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2008 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
use Moose::Meta::Role;
use Moose::Util::TypeConstraints;
-{
- my ( $CALLER, %METAS );
+sub extends {
+ croak "Roles do not currently support 'extends'";
+}
- sub _find_meta {
- my $role = $CALLER;
+sub with {
+ Moose::Util::apply_all_roles( shift->meta(), @_ );
+}
- return $METAS{$role} if exists $METAS{$role};
+sub requires {
+ my $meta = shift->meta();
+ croak "Must specify at least one method" unless @_;
+ $meta->add_required_methods(@_);
+}
- # make a subtype for each Moose class
- role_type $role unless find_type_constraint($role);
+sub excludes {
+ my $meta = shift->meta();
+ croak "Must specify at least one role" unless @_;
+ $meta->add_excluded_roles(@_);
+}
- my $meta;
- if ($role->can('meta')) {
- $meta = $role->meta();
- (blessed($meta) && $meta->isa('Moose::Meta::Role'))
- || confess "You already have a &meta function, but it does not return a Moose::Meta::Role";
- }
- else {
- $meta = Moose::Meta::Role->initialize($role);
- $meta->alias_method('meta' => sub { $meta });
- }
+sub has {
+ my $meta = shift->meta();
+ my $name = shift;
+ croak 'Usage: has \'name\' => ( key => value, ... )' if @_ == 1;
+ my %options = @_;
+ my $attrs = ( ref($name) eq 'ARRAY' ) ? $name : [ ($name) ];
+ $meta->add_attribute( $_, %options ) for @$attrs;
+}
- return $METAS{$role} = $meta;
+sub before {
+ my $meta = shift->meta();
+ my $code = pop @_;
+
+ for (@_) {
+ croak "Moose::Role do not currently support "
+ . ref($_)
+ . " references for before method modifiers"
+ if ref $_;
+ $meta->add_before_method_modifier( $_, $code );
}
+}
+sub after {
+ my $meta = shift->meta();
- my %exports = (
- extends => sub {
- my $meta = _find_meta();
- return Class::MOP::subname('Moose::Role::extends' => sub {
- croak "Roles do not currently support 'extends'"
- });
- },
- with => sub {
- my $meta = _find_meta();
- return Class::MOP::subname('Moose::Role::with' => sub (@) {
- Moose::Util::apply_all_roles($meta, @_)
- });
- },
- requires => sub {
- my $meta = _find_meta();
- return Class::MOP::subname('Moose::Role::requires' => sub (@) {
- croak "Must specify at least one method" unless @_;
- $meta->add_required_methods(@_);
- });
- },
- excludes => sub {
- my $meta = _find_meta();
- return Class::MOP::subname('Moose::Role::excludes' => sub (@) {
- croak "Must specify at least one role" unless @_;
- $meta->add_excluded_roles(@_);
- });
- },
- has => sub {
- my $meta = _find_meta();
- return Class::MOP::subname('Moose::Role::has' => sub ($;%) {
- my $name = shift;
- croak 'Usage: has \'name\' => ( key => value, ... )' if @_ == 1;
- my %options = @_;
- my $attrs = ( ref($name) eq 'ARRAY' ) ? $name : [ ($name) ];
- $meta->add_attribute( $_, %options ) for @$attrs;
- });
- },
- before => sub {
- my $meta = _find_meta();
- return Class::MOP::subname('Moose::Role::before' => sub (@&) {
- my $code = pop @_;
- do {
- croak "Moose::Role do not currently support "
- . ref($_)
- . " references for before method modifiers"
- if ref $_;
- $meta->add_before_method_modifier($_, $code)
- } for @_;
- });
- },
- after => sub {
- my $meta = _find_meta();
- return Class::MOP::subname('Moose::Role::after' => sub (@&) {
- my $code = pop @_;
- do {
- croak "Moose::Role do not currently support "
- . ref($_)
- . " references for after method modifiers"
- if ref $_;
- $meta->add_after_method_modifier($_, $code)
- } for @_;
- });
- },
- around => sub {
- my $meta = _find_meta();
- return Class::MOP::subname('Moose::Role::around' => sub (@&) {
- my $code = pop @_;
- do {
- croak "Moose::Role do not currently support "
- . ref($_)
- . " references for around method modifiers"
- if ref $_;
- $meta->add_around_method_modifier($_, $code)
- } for @_;
- });
- },
- # see Moose.pm for discussion
- super => sub {
- return Class::MOP::subname('Moose::Role::super' => sub {
- return unless $Moose::SUPER_BODY; $Moose::SUPER_BODY->(@Moose::SUPER_ARGS)
- });
- },
- override => sub {
- my $meta = _find_meta();
- return Class::MOP::subname('Moose::Role::override' => sub ($&) {
- my ($name, $code) = @_;
- $meta->add_override_method_modifier($name, $code);
- });
- },
- inner => sub {
- my $meta = _find_meta();
- return Class::MOP::subname('Moose::Role::inner' => sub {
- croak "Moose::Role cannot support 'inner'";
- });
- },
- augment => sub {
- my $meta = _find_meta();
- return Class::MOP::subname('Moose::Role::augment' => sub {
- croak "Moose::Role cannot support 'augment'";
- });
- },
- confess => sub {
- return \&Carp::confess;
- },
- blessed => sub {
- return \&Scalar::Util::blessed;
- }
- );
+ my $code = pop @_;
+ for (@_) {
+ croak "Moose::Role do not currently support "
+ . ref($_)
+ . " references for after method modifiers"
+ if ref $_;
+ $meta->add_after_method_modifier( $_, $code );
+ }
+}
- my $exporter = Sub::Exporter::build_exporter({
- exports => \%exports,
- groups => {
- default => [':all']
- }
- });
+sub around {
+ my $meta = shift->meta();
+ my $code = pop @_;
+ for (@_) {
+ croak "Moose::Role do not currently support "
+ . ref($_)
+ . " references for around method modifiers"
+ if ref $_;
+ $meta->add_around_method_modifier( $_, $code );
+ }
+}
+
+# see Moose.pm for discussion
+sub super {
+ return unless $Moose::SUPER_BODY;
+ $Moose::SUPER_BODY->(@Moose::SUPER_ARGS);
+}
- sub import {
- $CALLER =
- ref $_[1] && defined $_[1]->{into} ? $_[1]->{into}
- : ref $_[1]
- && defined $_[1]->{into_level} ? caller( $_[1]->{into_level} )
- : caller();
+sub override {
+ my $meta = shift->meta();
+ my ( $name, $code ) = @_;
+ $meta->add_override_method_modifier( $name, $code );
+}
- # this works because both pragmas set $^H (see perldoc perlvar)
- # which affects the current compilation - i.e. the file who use'd
- # us - which is why we don't need to do anything special to make
- # it affect that file rather than this one (which is already compiled)
+sub inner {
+ croak "Moose::Role cannot support 'inner'";
+}
- strict->import;
- warnings->import;
+sub augment {
+ croak "Moose::Role cannot support 'augment'";
+}
- # we should never export to main
- return if $CALLER eq 'main';
+my $exporter = Moose::Exporter->build_import_methods(
+ with_caller => [
+ qw( with requires excludes has before after around override make_immutable )
+ ],
+ as_is => [
+ qw( extends super inner augment ),
+ \&Carp::confess,
+ \&Scalar::Util::blessed,
+ ],
+);
- goto $exporter;
- };
+{
+ my %METAS;
- sub unimport {
- no strict 'refs';
- my $class = Moose::_get_caller(@_);
+ sub init_meta {
+ shift;
+ my %args = @_;
- # loop through the exports ...
- foreach my $name ( keys %exports ) {
+ my $role = $args{for_class}
+ or confess
+ "Cannot call init_meta without specifying a for_class";
- # if we find one ...
- if ( defined &{ $class . '::' . $name } ) {
- my $keyword = \&{ $class . '::' . $name };
+ return $METAS{$role} if exists $METAS{$role};
- # make sure it is from Moose::Role
- my ($pkg_name) = Class::MOP::get_code_info($keyword);
- next if $pkg_name ne 'Moose::Role';
+ # make a subtype for each Moose class
+ role_type $role unless find_type_constraint($role);
- # and if it is from Moose::Role then undef the slot
- delete ${ $class . '::' }{$name};
- }
+ my $meta;
+ if ($role->can('meta')) {
+ $meta = $role->meta();
+ (blessed($meta) && $meta->isa('Moose::Meta::Role'))
+ || confess "You already have a &meta function, but it does not return a Moose::Meta::Role";
}
+ else {
+ $meta = Moose::Meta::Role->initialize($role);
+ $meta->alias_method('meta' => sub { $meta });
+ }
+
+ return $METAS{$role} = $meta;
}
}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+
+BEGIN {
+ unless ( eval 'use Test::Warn; 1' ) {
+ plan skip_all => 'These tests require Test::Warn';
+ }
+ else {
+ plan tests => 4;
+ }
+}
+
+{
+ package MyApp::Base;
+ use Moose;
+
+ extends 'Moose::Object';
+
+ before 'new' => sub { warn "Making a new " . $_[0] };
+
+ no Moose;
+}
+
+{
+ package MyApp::UseMyBase;
+ use Moose ();
+ use Moose::Exporter;
+
+ Moose::Exporter->build_import_methods( also => 'Moose' );
+
+ sub init_meta {
+ shift;
+ Moose->init_meta( @_, base_class => 'MyApp::Base' );
+ }
+}
+
+{
+ package Foo;
+
+ MyApp::UseMyBase->import;
+
+ has( 'size' => ( is => 'rw' ) );
+}
+
+ok( Foo->isa('MyApp::Base'),
+ 'Foo isa MyApp::Base' );
+
+ok( Foo->can('size'),
+ 'Foo has a size method' );
+
+my $foo;
+warning_is( sub { $foo = Foo->new( size => 2 ) },
+ 'Making a new Foo',
+ 'got expected warning when calling Foo->new' );
+
+is( $foo->size(), 2, '$foo->size is 2' );
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 3;
+
+
+{
+ package MyApp::Meta::Class;
+ use Moose;
+
+ extends 'Moose::Meta::Class';
+
+ has 'table' => ( is => 'rw' );
+
+ no Moose;
+
+ package MyApp::Mooseish;
+
+ use strict;
+ use warnings;
+
+ use Moose ();
+ use Moose::Exporter;
+
+ Moose::Exporter->build_import_methods(
+ with_caller => ['has_table'],
+ also => 'Moose',
+ );
+
+ sub init_meta {
+ shift;
+ Moose->init_meta( @_, metaclass => 'MyApp::Meta::Class' );
+ }
+
+ sub has_table {
+ my $caller = shift;
+ $caller->meta()->table(shift);
+ }
+}
+
+{
+ package MyApp::User;
+
+ MyApp::Mooseish->import;
+
+ has_table( 'User' );
+
+ has( 'username' => ( is => 'ro' ) );
+ has( 'password' => ( is => 'ro' ) );
+
+ sub login { }
+}
+
+isa_ok( MyApp::User->meta, 'MyApp::Meta::Class' );
+is( MyApp::User->meta->table, 'User',
+ 'MyApp::User->meta->table returns User' );
+ok( MyApp::User->can('username'),
+ 'MyApp::User has username method' );
BEGIN {
eval "use Test::Output;";
plan skip_all => "Test::Output is required for this test" if $@;
- plan tests => 1;
+ plan tests => 2;
}
stderr_is( sub { package main; eval 'use Moose' },
"Moose does not export its sugar to the 'main' package.\n",
'Moose warns when loaded from the main package' );
+
+stderr_is( sub { package main; eval 'use Moose::Role' },
+ "Moose::Role does not export its sugar to the 'main' package.\n",
+ 'Moose::Role warns when loaded from the main package' );
use strict;
use warnings;
-use Test::More tests => 37;
+use Test::More tests => 36;
use Test::Exception;
-BEGIN {
- use_ok('Moose::Role');
-}
-
=pod
NOTE:
use strict;
use warnings;
-use Test::More tests => 87;
+use Test::More tests => 86;
use Test::Exception;
-BEGIN {
- use_ok('Moose::Role');
-}
-
{
package FooRole;
use Moose::Role;
#!/usr/bin/env perl
use strict;
use warnings;
-use Test::More tests => 7;
+use Test::More tests => 6;
# this test script ensures that my idiom of:
# role: sub BUILD, after BUILD
# continues to work to run code after object initialization, whether the class
# has a BUILD method or not
-BEGIN {
- use_ok('Moose::Role');
-}
-
my @CALLS;
do {
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+
+BEGIN {
+ unless ( eval 'use Test::Warn; 1' ) {
+ plan skip_all => 'These tests require Test::Warn';
+ }
+ else {
+ plan tests => 40;
+ }
+}
+
+
+{
+ package HasOwnImmutable;
+
+ use Moose;
+
+ no Moose;
+
+ ::warning_is( sub { eval q[sub make_immutable { return 'foo' }] },
+ '',
+ 'no warning when defining our own make_immutable sub' );
+}
+
+{
+ is( HasOwnImmutable->make_immutable(), 'foo',
+ 'HasOwnImmutable->make_immutable does not get overwritten' );
+}
+
+{
+ package MooseX::Empty;
+
+ use Moose ();
+ Moose::Exporter->build_import_methods( also => 'Moose' );
+}
+
+{
+ package WantsMoose;
+
+ MooseX::Empty->import();
+
+ sub foo { 1 }
+
+ ::can_ok( 'WantsMoose', 'has' );
+ ::can_ok( 'WantsMoose', 'with' );
+ ::can_ok( 'WantsMoose', 'foo' );
+
+ MooseX::Empty->unimport();
+}
+
+{
+ # Note: it's important that these methods be out of scope _now_,
+ # after unimport was called. We tried a
+ # namespace::clean(0.08)-based solution, but had to abandon it
+ # because it cleans the namespace _later_ (when the file scope
+ # ends).
+ ok( ! WantsMoose->can('has'), 'WantsMoose::has() has been cleaned' );
+ ok( ! WantsMoose->can('with'), 'WantsMoose::with() has been cleaned' );
+ can_ok( 'WantsMoose', 'foo' );
+
+ # This makes sure that Moose->init_meta() happens properly
+ isa_ok( WantsMoose->meta(), 'Moose::Meta::Class' );
+ isa_ok( WantsMoose->new(), 'Moose::Object' );
+
+}
+
+{
+ package MooseX::Sugar;
+
+ use Moose ();
+
+ sub wrapped1 {
+ my $caller = shift;
+ return $caller . ' called wrapped1';
+ }
+
+ Moose::Exporter->build_import_methods(
+ with_caller => ['wrapped1'],
+ also => 'Moose',
+ );
+}
+
+{
+ package WantsSugar;
+
+ MooseX::Sugar->import();
+
+ sub foo { 1 }
+
+ ::can_ok( 'WantsSugar', 'has' );
+ ::can_ok( 'WantsSugar', 'with' );
+ ::can_ok( 'WantsSugar', 'wrapped1' );
+ ::can_ok( 'WantsSugar', 'foo' );
+ ::is( wrapped1(), 'WantsSugar called wrapped1',
+ 'wrapped1 identifies the caller correctly' );
+
+ MooseX::Sugar->unimport();
+}
+
+{
+ ok( ! WantsSugar->can('has'), 'WantsSugar::has() has been cleaned' );
+ ok( ! WantsSugar->can('with'), 'WantsSugar::with() has been cleaned' );
+ ok( ! WantsSugar->can('wrapped1'), 'WantsSugar::wrapped1() has been cleaned' );
+ can_ok( 'WantsSugar', 'foo' );
+}
+
+{
+ package MooseX::MoreSugar;
+
+ use Moose ();
+
+ sub wrapped2 {
+ my $caller = shift;
+ return $caller . ' called wrapped2';
+ }
+
+ sub as_is1 {
+ return 'as_is1';
+ }
+
+ Moose::Exporter->build_import_methods(
+ with_caller => ['wrapped2'],
+ as_is => ['as_is1'],
+ also => 'MooseX::Sugar',
+ );
+}
+
+{
+ package WantsMoreSugar;
+
+ MooseX::MoreSugar->import();
+
+ sub foo { 1 }
+
+ ::can_ok( 'WantsMoreSugar', 'has' );
+ ::can_ok( 'WantsMoreSugar', 'with' );
+ ::can_ok( 'WantsMoreSugar', 'wrapped1' );
+ ::can_ok( 'WantsMoreSugar', 'wrapped2' );
+ ::can_ok( 'WantsMoreSugar', 'as_is1' );
+ ::can_ok( 'WantsMoreSugar', 'foo' );
+ ::is( wrapped1(), 'WantsMoreSugar called wrapped1',
+ 'wrapped1 identifies the caller correctly' );
+ ::is( wrapped2(), 'WantsMoreSugar called wrapped2',
+ 'wrapped2 identifies the caller correctly' );
+ ::is( as_is1(), 'as_is1',
+ 'as_is1 works as expected' );
+
+ MooseX::MoreSugar->unimport();
+}
+
+{
+ ok( ! WantsMoreSugar->can('has'), 'WantsMoreSugar::has() has been cleaned' );
+ ok( ! WantsMoreSugar->can('with'), 'WantsMoreSugar::with() has been cleaned' );
+ ok( ! WantsMoreSugar->can('wrapped1'), 'WantsMoreSugar::wrapped1() has been cleaned' );
+ ok( ! WantsMoreSugar->can('wrapped2'), 'WantsMoreSugar::wrapped2() has been cleaned' );
+ ok( ! WantsMoreSugar->can('as_is1'), 'WantsMoreSugar::as_is1() has been cleaned' );
+ can_ok( 'WantsMoreSugar', 'foo' );
+}
+
+{
+ package My::Metaclass;
+ use Moose;
+ BEGIN { extends 'Moose::Meta::Class' }
+
+ package My::Object;
+ use Moose;
+ BEGIN { extends 'Moose::Object' }
+
+ package HasInitMeta;
+
+ use Moose ();
+
+ sub init_meta {
+ shift;
+ return Moose->init_meta( @_,
+ metaclass => 'My::Metaclass',
+ base_class => 'My::Object',
+ );
+ }
+
+ Moose::Exporter->build_import_methods( also => 'Moose' );
+}
+
+{
+ package NewMeta;
+
+ HasInitMeta->import();
+}
+
+{
+ isa_ok( NewMeta->meta(), 'My::Metaclass' );
+ isa_ok( NewMeta->new(), 'My::Object' );
+}
+
+{
+ package MooseX::CircularAlso;
+
+ use Moose ();
+
+ ::dies_ok(
+ sub {
+ Moose::Exporter->build_import_methods(
+ also => [ 'Moose', 'MooseX::CircularAlso' ],
+ );
+ },
+ 'a circular reference in also dies with an error'
+ );
+
+ ::like(
+ $@,
+ qr/\QCircular reference in also parameter to MooseX::Exporter between MooseX::CircularAlso and MooseX::CircularAlso/,
+ 'got the expected error from circular reference in also'
+ );
+}
+
+{
+ package MooseX::CircularAlso;
+
+ use Moose ();
+
+ ::dies_ok(
+ sub {
+ Moose::Exporter->build_import_methods(
+ also => [ 'NoSuchThing' ],
+ );
+ },
+ 'a package which does not use Moose::Exporter in also dies with an error'
+ );
+
+ ::like(
+ $@,
+ qr/\QPackage in also (NoSuchThing) does not seem to use MooseX::Exporter/,
+ 'got the expected error from a reference in also to a package which does not use Moose::Exporter'
+ );
+}
eval "use Test::Pod::Coverage 1.04";
plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@;
-all_pod_coverage_ok( { trustme => [ qr/intialize_body/ ] } );
+# This is a stripped down version of all_pod_coverage_ok which lets us
+# vary the trustme parameter per module.
+my @modules = all_modules();
+plan tests => scalar @modules;
+
+my %trustme = (
+ 'Moose' => ['make_immutable'],
+ 'Moose::Meta::Method::Constructor' =>
+ [qw( initialize_body intialize_body)],
+ 'Moose::Meta::Method::Destructor' => ['initialize_body'],
+ 'Moose::Role' => [
+ qw( after around augment before extends has inner make_immutable override super with )
+ ],
+);
+
+for my $module ( sort @modules ) {
+ my $trustme = [];
+ if ( $trustme{$module} ) {
+ my $methods = join '|', @{ $trustme{$module} };
+ $trustme = [qr/$methods/];
+ }
+
+ pod_coverage_ok(
+ $module, { trustme => $trustme },
+ "Pod coverage for $module"
+ );
+}
projects / gitmo/Moose.git / commitdiff