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 }
}
);
my $packages = shift;
my $export_recorder = shift;
+ my %groups;
my %exports;
my %is_removable;
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';
$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;
$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;
};
}
+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;
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;
--- /dev/null
+#!/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' );
+}
+
projects / gitmo/Moose.git / commitdiff