From: Shawn M Moore Date: Thu, 25 Jun 2009 20:07:35 +0000 (-0400) Subject: Apply josh's Moose::Exporter improvements so we have with_meta X-Git-Tag: 0.84~19 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=45975bce3e76402068c8d9c28e0649c905aa0320;p=gitmo%2FMoose.git Apply josh's Moose::Exporter improvements so we have with_meta --- diff --git a/lib/Moose/Exporter.pm b/lib/Moose/Exporter.pm old mode 100644 new mode 100755 index 8151e6d..a464b81 --- a/lib/Moose/Exporter.pm +++ b/lib/Moose/Exporter.pm @@ -38,14 +38,14 @@ sub build_import_methods { my $export_recorder = {}; - my ( $exports, $is_removable ) + my ( $exports, $is_removable, $groups ) = $class->_make_sub_exporter_params( [ @exports_from, $exporting_package ], $export_recorder ); my $exporter = Sub::Exporter::build_exporter( { exports => $exports, - groups => { default => [':all'] } + groups => { default => [':all'], %$groups } } ); @@ -107,6 +107,7 @@ sub _make_sub_exporter_params { my $packages = shift; my $export_recorder = shift; + my %groups; my %exports; my %is_removable; @@ -114,6 +115,15 @@ sub _make_sub_exporter_params { my $args = $EXPORT_SPEC{$package} or die "The $package package does not use Moose::Exporter\n"; + # one group for each 'also' package + $groups{$package} = [ + @{ $args->{with_caller} || [] }, + @{ $args->{with_meta} || [] }, + @{ $args->{as_is} || [] }, + map ":$_", + keys %{ $args->{groups} || {} } + ]; + for my $name ( @{ $args->{with_caller} } ) { my $sub = do { no strict 'refs'; @@ -131,6 +141,23 @@ sub _make_sub_exporter_params { $is_removable{$name} = 1; } + for my $name ( @{ $args->{with_meta} } ) { + my $sub = do { + no strict 'refs'; + \&{ $package . '::' . $name }; + }; + + my $fq_name = $package . '::' . $name; + + $exports{$name} = $class->_make_wrapped_sub_with_meta( + $fq_name, + $sub, + $export_recorder, + ); + + $is_removable{$name} = 1; + } + for my $name ( @{ $args->{as_is} } ) { my $sub; @@ -165,9 +192,26 @@ sub _make_sub_exporter_params { $exports{$name} = sub {$sub}; } + + for my $name ( keys %{ $args->{groups} } ) { + my $group = $args->{groups}{$name}; + + if (ref $group eq 'CODE') { + $groups{$name} = $class->_make_wrapped_group( + $package, + $group, + $export_recorder, + \%exports, + \%is_removable + ); + } + elsif (ref $group eq 'ARRAY') { + $groups{$name} = $group; + } + } } - return ( \%exports, \%is_removable ); + return ( \%exports, \%is_removable, \%groups ); } our $CALLER; @@ -197,6 +241,76 @@ sub _make_wrapped_sub { }; } +sub _make_wrapped_sub_with_meta { + my $self = shift; + my $fq_name = shift; + my $sub = shift; + my $export_recorder = shift; + + return sub { + my $caller = $CALLER; + + my $wrapper = $self->_late_curry_wrapper($sub, $fq_name, + sub { Class::MOP::class_of(shift) } => $caller); + + my $sub = subname($fq_name => $wrapper); + + $export_recorder->{$sub} = 1; + + return $sub; + }; +} + +sub _make_wrapped_group { + my $class = shift; + my $package = shift; # package calling use Moose::Exporter + my $sub = shift; + my $export_recorder = shift; + my $keywords = shift; + my $is_removable = shift; + + return sub { + my $caller = $CALLER; # package calling use PackageUsingMooseExporter -group => {args} + + # there are plenty of ways to deal with telling the code which + # package it lives in. the last arg (collector hashref) is + # otherwise unused, so we'll stick the original package in + # there and act like 'with_caller' by putting the calling + # package name as the first arg + $_[0] = $caller; + $_[3]{from} = $package; + + my $named_code = $sub->(@_); + $named_code ||= { }; + + # send invalid return value error up to Sub::Exporter + unless (ref $named_code eq 'HASH') { + return $named_code; + } + + for my $name (keys %$named_code) { + my $code = $named_code->{$name}; + + my $fq_name = $package . '::' . $name; + my $wrapper = $class->_curry_wrapper( + $code, + $fq_name, + $caller + ); + + my $sub = subname( $fq_name => $wrapper ); + $named_code->{$name} = $sub; + + # mark each coderef as ours + $keywords->{$name} = 1; + $is_removable->{$name} = 1; + $export_recorder->{$sub} = 1; + } + + return $named_code; + }; +} + sub _curry_wrapper { my $class = shift; my $sub = shift; @@ -212,6 +326,27 @@ sub _curry_wrapper { return $wrapper; } +sub _late_curry_wrapper { + my $class = shift; + my $sub = shift; + my $fq_name = shift; + my $extra = shift; + my @ex_args = @_; + + my $wrapper = sub { + # resolve curried arguments at runtime via this closure + my @curry = ( $extra->( @ex_args ) ); + return $sub->(@curry, @_); + }; + + if (my $proto = prototype $sub) { + # XXX - Perl's prototype sucks. Use & to make set_prototype + # ignore the fact that we're passing "private variables" + &Scalar::Util::set_prototype($wrapper, $proto); + } + return $wrapper; +} + sub _make_import_sub { shift; my $exporting_package = shift; diff --git a/t/010_basics/022_moose_exporter_groups.t b/t/010_basics/022_moose_exporter_groups.t new file mode 100755 index 0000000..11b901f --- /dev/null +++ b/t/010_basics/022_moose_exporter_groups.t @@ -0,0 +1,166 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 45; +use Test::Exception; + +{ + package ExGroups1; + use Moose::Exporter; + use Moose (); + + Moose::Exporter->setup_import_methods( + also => ['Moose'], + with_meta => ['with_meta1'], + with_caller => ['default_export1'], + as_is => ['default_export2'], + groups => { all_group => [':all'], + just_one => ['default_export1'] } + ); + + sub default_export1 { 1 } + sub default_export2 { 2 } + + sub with_meta1 (&) { + my ($meta, $code) = @_; + return $meta; + } +} + +{ + package UseAllGroup; + + ExGroups1->import(':all_group'); + + ::can_ok( __PACKAGE__, 'with_meta1' ); + ::can_ok( __PACKAGE__, 'default_export1' ); + ::can_ok( __PACKAGE__, 'default_export2' ); + ::can_ok( __PACKAGE__, 'has' ); + + my $meta; + eval q/$meta = with_meta1 { return 'coderef'; }/; + ::is($@, '', 'calling with_meta1 with prototype is not an error'); + ::isa_ok( $meta, 'Moose::Meta::Class', 'with_meta first argument' ); + ::is( prototype( __PACKAGE__->can('with_meta1') ), + prototype( ExGroups1->can('with_meta1') ), + 'using correct prototype on with_meta function' ); + + ExGroups1->unimport(); + + ::ok( ! __PACKAGE__->can('with_meta1'), __PACKAGE__.'::with_meta1() has been cleaned' ); + ::ok( ! __PACKAGE__->can('default_export1'), __PACKAGE__.'::default_export1() has been cleaned' ); + ::ok( ! __PACKAGE__->can('default_export2'), __PACKAGE__.'::default_export2() has been cleaned' ); + ::ok( ! __PACKAGE__->can('has'), __PACKAGE__.'::has() has been cleaned' ); +} + +{ + package UseJustOne; + + ExGroups1->import(':just_one'); + + ::can_ok( __PACKAGE__, 'default_export1' ); + ::ok( ! __PACKAGE__->can('default_export2'), __PACKAGE__.'::default_export2() was not imported' ); + ::ok( ! __PACKAGE__->can('has'), __PACKAGE__.'::has() was not imported' ); + + ExGroups1->unimport(); + + ::ok( ! __PACKAGE__->can('default_export1'), __PACKAGE__.'::default_export1() has been cleared' ); +} + +{ + package ExGroups2; + use Moose::Exporter; + + Moose::Exporter->setup_import_methods( + also => ['ExGroups1'], + as_is => ['exgroups2_as_is'], + with_caller => ['exgroups2_with_caller'], + groups => { default => ['exgroups2_as_is'], + code_group => \&generate_group, + parent1 => [qw(:ExGroups1 :code_group)], + parent2 => [qw(:all)] } + ); + + sub exgroups2_as_is { 3 } + + sub generate_group { + my ($caller, $group_name, $args, $context) = @_; + + ::is($group_name, 'code_group', 'original name is passed to group code'); + ::is($args->{install_as}, $caller . '_code', 'group code arguments match caller'); + ::is($context->{from}, __PACKAGE__, 'defined package name is passed to group code'); + + return { $args->{install_as} => \&exported_by_group }; + } + + sub exported_by_group (&) { + my ($caller, $coderef) = @_; + return $caller; + } +} + +{ + package UseDefault; + + ExGroups2->import; + + ::can_ok( __PACKAGE__, 'exgroups2_as_is' ); + ::ok( ! __PACKAGE__->can('exgroups2_with_caller'), '"default" group is no longer "all"' ); +} + +{ + package UseCodeGroup; + + ExGroups2->import(':code_group', { install_as => (my $export_name = __PACKAGE__.'_code') }); + + ::can_ok( __PACKAGE__, $export_name ); + ::ok( &UseCodeGroup_code() eq __PACKAGE__, 'code group exports act like "with_caller" subs' ); + ::lives_ok(sub { UseCodeCodeGroup_code { return 'code block'; } }, 'code group exports keep their prototypes'); + + ::ok( ! __PACKAGE__->can('exgroups2_as_is'), 'code group will not automatically export any symbols' ); + + ExGroups2->unimport; + + ::ok( ! __PACKAGE__->can($export_name), + 'dynamically-named '. __PACKAGE__."::$export_name() has been cleared" ); +} + +{ + package UseParent1; + + ExGroups2->import(':parent1', { install_as => (my $export_name = __PACKAGE__.'_code') }); + + ::can_ok( __PACKAGE__, $export_name ); + ::can_ok( __PACKAGE__, 'default_export1' ); + ::can_ok( __PACKAGE__, 'default_export2' ); + ::can_ok( __PACKAGE__, 'has' ); + + ExGroups2->unimport; + + ::ok( ! __PACKAGE__->can($export_name), __PACKAGE__."::$export_name() has been cleared" ); + ::ok( ! __PACKAGE__->can('default_export1'), __PACKAGE__.'::default_export1() has been cleaned' ); + ::ok( ! __PACKAGE__->can('default_export2'), __PACKAGE__.'::default_export2() has been cleaned' ); + ::ok( ! __PACKAGE__->can('has'), __PACKAGE__.'::has() has been cleaned' ); +} + +{ + package UseParent2; + + ExGroups2->import(':parent2', { install_as => (my $export_name = __PACKAGE__.'_code') }); + + ::ok( ! __PACKAGE__->can($export_name), '"all" group will not call code groups' ); + ::can_ok( __PACKAGE__, 'exgroups2_as_is' ); + ::can_ok( __PACKAGE__, 'exgroups2_with_caller' ); + ::can_ok( __PACKAGE__, 'default_export1' ); + ::can_ok( __PACKAGE__, 'has' ); + + ExGroups2->unimport; + + ::ok( ! __PACKAGE__->can('exgroups2_as_is'), __PACKAGE__.'::exgroups2_as_is() has been cleaned' ); + ::ok( ! __PACKAGE__->can('exgroups2_with_caller'), __PACKAGE__.'::exgroups2_with_caller() has been cleaned' ); + ::ok( ! __PACKAGE__->can('default_export1'), __PACKAGE__.'::default_export1() has been cleaned' ); + ::ok( ! __PACKAGE__->can('has'), __PACKAGE__.'::has() has been cleaned' ); +} +