use 5.006;
use strict;
use warnings;
package Sub::Exporter;
{
$Sub::Exporter::VERSION = '0.987';
}
# ABSTRACT: a sophisticated exporter for custom-built routines
use Carp ();
use Data::OptList 0.100 ();
use Params::Util 0.14 (); # _CODELIKE
use Sub::Install 0.92 ();
# Given a potential import name, this returns the group name -- if it's got a
# group prefix.
sub _group_name {
my ($name) = @_;
return if (index q{-:}, (substr $name, 0, 1)) == -1;
return substr $name, 1;
}
# \@groups is a canonicalized opt list of exports and groups this returns
# another canonicalized opt list with groups replaced with relevant exports.
# \%seen is groups we've already expanded and can ignore.
# \%merge is merged options from the group we're descending through.
sub _expand_groups {
my ($class, $config, $groups, $collection, $seen, $merge) = @_;
$seen ||= {};
$merge ||= {};
my @groups = @$groups;
for my $i (reverse 0 .. $#groups) {
if (my $group_name = _group_name($groups[$i][0])) {
my $seen = { %$seen }; # faux-dynamic scoping
splice @groups, $i, 1,
_expand_group($class, $config, $groups[$i], $collection, $seen, $merge);
} else {
# there's nothing to munge in this export's args
next unless my %merge = %$merge;
# we have things to merge in; do so
my $prefix = (delete $merge{-prefix}) || '';
my $suffix = (delete $merge{-suffix}) || '';
if (
Params::Util::_CODELIKE($groups[$i][1]) ## no critic Private
or
Params::Util::_SCALAR0($groups[$i][1]) ## no critic Private
) {
# this entry was build by a group generator
$groups[$i][0] = $prefix . $groups[$i][0] . $suffix;
} else {
my $as
= ref $groups[$i][1]{-as} ? $groups[$i][1]{-as}
: $groups[$i][1]{-as} ? $prefix . $groups[$i][1]{-as} . $suffix
: $prefix . $groups[$i][0] . $suffix;
$groups[$i][1] = { %{ $groups[$i][1] }, %merge, -as => $as };
}
}
}
return \@groups;
}
# \@group is a name/value pair from an opt list.
sub _expand_group {
my ($class, $config, $group, $collection, $seen, $merge) = @_;
$merge ||= {};
my ($group_name, $group_arg) = @$group;
$group_name = _group_name($group_name);
Carp::croak qq(group "$group_name" is not exported by the $class module)
unless exists $config->{groups}{$group_name};
return if $seen->{$group_name}++;
if (ref $group_arg) {
my $prefix = (delete $merge->{-prefix}||'') . ($group_arg->{-prefix}||'');
my $suffix = ($group_arg->{-suffix}||'') . (delete $merge->{-suffix}||'');
$merge = {
%$merge,
%$group_arg,
($prefix ? (-prefix => $prefix) : ()),
($suffix ? (-suffix => $suffix) : ()),
};
}
my $exports = $config->{groups}{$group_name};
if (
Params::Util::_CODELIKE($exports) ## no critic Private
or
Params::Util::_SCALAR0($exports) ## no critic Private
) {
# I'm not very happy with this code for hiding -prefix and -suffix, but
# it's needed, and I'm not sure, offhand, how to make it better.
# -- rjbs, 2006-12-05
my $group_arg = $merge ? { %$merge } : {};
delete $group_arg->{-prefix};
delete $group_arg->{-suffix};
my $group = Params::Util::_CODELIKE($exports) ## no critic Private
? $exports->($class, $group_name, $group_arg, $collection)
: $class->$$exports($group_name, $group_arg, $collection);
Carp::croak qq(group generator "$group_name" did not return a hashref)
if ref $group ne 'HASH';
my $stuff = [ map { [ $_ => $group->{$_} ] } keys %$group ];
return @{
_expand_groups($class, $config, $stuff, $collection, $seen, $merge)
};
} else {
$exports
= Data::OptList::mkopt($exports, "$group_name exports");
return @{
_expand_groups($class, $config, $exports, $collection, $seen, $merge)
};
}
}
sub _mk_collection_builder {
my ($col, $etc) = @_;
my ($config, $import_args, $class, $into) = @$etc;
my %seen;
sub {
my ($collection) = @_;
my ($name, $value) = @$collection;
Carp::croak "collection $name provided multiple times in import"
if $seen{ $name }++;
if (ref(my $hook = $config->{collectors}{$name})) {
my $arg = {
name => $name,
config => $config,
import_args => $import_args,
class => $class,
into => $into,
};
my $error_msg = "collection $name failed validation";
if (Params::Util::_SCALAR0($hook)) { ## no critic Private
Carp::croak $error_msg unless $class->$$hook($value, $arg);
} else {
Carp::croak $error_msg unless $hook->($value, $arg);
}
}
$col->{ $name } = $value;
}
}
# Given a config and pre-canonicalized importer args, remove collections from
# the args and return them.
sub _collect_collections {
my ($config, $import_args, $class, $into) = @_;
my @collections
= map { splice @$import_args, $_, 1 }
grep { exists $config->{collectors}{ $import_args->[$_][0] } }
reverse 0 .. $#$import_args;
unshift @collections, [ INIT => {} ] if $config->{collectors}{INIT};
my $col = {};
my $builder = _mk_collection_builder($col, \@_);
for my $collection (@collections) {
$builder->($collection)
}
return $col;
}
sub setup_exporter {
my ($config) = @_;
Carp::croak 'into and into_level may not both be supplied to exporter'
if exists $config->{into} and exists $config->{into_level};
my $as = delete $config->{as} || 'import';
my $into
= exists $config->{into} ? delete $config->{into}
: exists $config->{into_level} ? caller(delete $config->{into_level})
: caller(0);
my $import = build_exporter($config);
Sub::Install::reinstall_sub({
code => $import,
into => $into,
as => $as,
});
}
sub _key_intersection {
my ($x, $y) = @_;
my %seen = map { $_ => 1 } keys %$x;
my @names = grep { $seen{$_} } keys %$y;
}
# Given the config passed to setup_exporter, which contains sugary opt list
# data, rewrite the opt lists into hashes, catch a few kinds of invalid
# configurations, and set up defaults. Since the config is a reference, it's
# rewritten in place.
my %valid_config_key;
BEGIN {
%valid_config_key =
map { $_ => 1 }
qw(as collectors installer generator exports groups into into_level),
qw(exporter), # deprecated
}
sub _assert_collector_names_ok {
my ($collectors) = @_;
for my $reserved_name (grep { /\A[_A-Z]+\z/ } keys %$collectors) {
Carp::croak "unknown reserved collector name: $reserved_name"
if $reserved_name ne 'INIT';
}
}
sub _rewrite_build_config {
my ($config) = @_;
if (my @keys = grep { not exists $valid_config_key{$_} } keys %$config) {
Carp::croak "unknown options (@keys) passed to Sub::Exporter";
}
Carp::croak q(into and into_level may not both be supplied to exporter)
if exists $config->{into} and exists $config->{into_level};
# XXX: Remove after deprecation period.
if ($config->{exporter}) {
Carp::cluck "'exporter' argument to build_exporter is deprecated. Use 'installer' instead; the semantics are identical.";
$config->{installer} = delete $config->{exporter};
}
Carp::croak q(into and into_level may not both be supplied to exporter)
if exists $config->{into} and exists $config->{into_level};
for (qw(exports collectors)) {
$config->{$_} = Data::OptList::mkopt_hash(
$config->{$_},
$_,
[ 'CODE', 'SCALAR' ],
);
}
_assert_collector_names_ok($config->{collectors});
if (my @names = _key_intersection(@$config{qw(exports collectors)})) {
Carp::croak "names (@names) used in both collections and exports";
}
$config->{groups} = Data::OptList::mkopt_hash(
$config->{groups},
'groups',
[
'HASH', # standard opt list
'ARRAY', # standard opt list
'CODE', # group generator
'SCALAR', # name of group generation method
]
);
# by default, export nothing
$config->{groups}{default} ||= [];
# by default, build an all-inclusive 'all' group
$config->{groups}{all} ||= [ keys %{ $config->{exports} } ];
$config->{generator} ||= \&default_generator;
$config->{installer} ||= \&default_installer;
}
sub build_exporter {
my ($config) = @_;
_rewrite_build_config($config);
my $import = sub {
my ($class) = shift;
# XXX: clean this up -- rjbs, 2006-03-16
my $special = (ref $_[0]) ? shift(@_) : {};
Carp::croak q(into and into_level may not both be supplied to exporter)
if exists $special->{into} and exists $special->{into_level};
if ($special->{exporter}) {
Carp::cluck "'exporter' special import argument is deprecated. Use 'installer' instead; the semantics are identical.";
$special->{installer} = delete $special->{exporter};
}
my $into
= defined $special->{into} ? delete $special->{into}
: defined $special->{into_level} ? caller(delete $special->{into_level})
: defined $config->{into} ? $config->{into}
: defined $config->{into_level} ? caller($config->{into_level})
: caller(0);
my $generator = delete $special->{generator} || $config->{generator};
my $installer = delete $special->{installer} || $config->{installer};
# this builds a AOA, where the inner arrays are [ name => value_ref ]
my $import_args = Data::OptList::mkopt([ @_ ]);
# is this right? defaults first or collectors first? -- rjbs, 2006-06-24
$import_args = [ [ -default => undef ] ] unless @$import_args;
my $collection = _collect_collections($config, $import_args, $class, $into);
my $to_import = _expand_groups($class, $config, $import_args, $collection);
# now, finally $import_arg is really the "to do" list
_do_import(
{
class => $class,
col => $collection,
config => $config,
into => $into,
generator => $generator,
installer => $installer,
},
$to_import,
);
};
return $import;
}
sub _do_import {
my ($arg, $to_import) = @_;
my @todo;
for my $pair (@$to_import) {
my ($name, $import_arg) = @$pair;
my ($generator, $as);
if ($import_arg and Params::Util::_CODELIKE($import_arg)) { ## no critic
# This is the case when a group generator has inserted name/code pairs.
$generator = sub { $import_arg };
$as = $name;
} else {
$import_arg = { $import_arg ? %$import_arg : () };
Carp::croak qq("$name" is not exported by the $arg->{class} module)
unless exists $arg->{config}{exports}{$name};
$generator = $arg->{config}{exports}{$name};
$as = exists $import_arg->{-as} ? (delete $import_arg->{-as}) : $name;
}
my $code = $arg->{generator}->(
{
class => $arg->{class},
name => $name,
arg => $import_arg,
col => $arg->{col},
generator => $generator,
}
);
push @todo, $as, $code;
}
$arg->{installer}->(
{
class => $arg->{class},
into => $arg->{into},
col => $arg->{col},
},
\@todo,
);
}
## Cute idea, possibly for future use: also supply an "unimport" for:
## no Module::Whatever qw(arg arg arg);
# sub _unexport {
# my (undef, undef, undef, undef, undef, $as, $into) = @_;
#
# if (ref $as eq 'SCALAR') {
# undef $$as;
# } elsif (ref $as) {
# Carp::croak "invalid reference type for $as: " . ref $as;
# } else {
# no strict 'refs';
# delete &{$into . '::' . $as};
# }
# }
sub default_generator {
my ($arg) = @_;
my ($class, $name, $generator) = @$arg{qw(class name generator)};
if (not defined $generator) {
my $code = $class->can($name)
or Carp::croak "can't locate exported subroutine $name via $class";
return $code;
}
# I considered making this "$class->$generator(" but it seems that
# overloading precedence would turn an overloaded-as-code generator object
# into a string before code. -- rjbs, 2006-06-11
return $generator->($class, $name, $arg->{arg}, $arg->{col})
if Params::Util::_CODELIKE($generator); ## no critic Private
# This "must" be a scalar reference, to a generator method name.
# -- rjbs, 2006-12-05
return $class->$$generator($name, $arg->{arg}, $arg->{col});
}
sub default_installer {
my ($arg, $to_export) = @_;
for (my $i = 0; $i < @$to_export; $i += 2) {
my ($as, $code) = @$to_export[ $i, $i+1 ];
# Allow as isa ARRAY to push onto an array?
# Allow into isa HASH to install name=>code into hash?
if (ref $as eq 'SCALAR') {
$$as = $code;
} elsif (ref $as) {
Carp::croak "invalid reference type for $as: " . ref $as;
} else {
Sub::Install::reinstall_sub({
code => $code,
into => $arg->{into},
as => $as
});
}
}
}
sub default_exporter {
Carp::cluck "default_exporter is deprecated; call default_installer instead; the semantics are identical";
goto &default_installer;
}
setup_exporter({
exports => [
qw(setup_exporter build_exporter),
_import => sub { build_exporter($_[2]) },
],
groups => {
all => [ qw(setup_exporter build_export) ],
},
collectors => { -setup => \&_setup },
});
sub _setup {
my ($value, $arg) = @_;
if (ref $value eq 'HASH') {
push @{ $arg->{import_args} }, [ _import => { -as => 'import', %$value } ];
return 1;
} elsif (ref $value eq 'ARRAY') {
push @{ $arg->{import_args} },
[ _import => { -as => 'import', exports => $value } ];
return 1;
}
return;
}
"jn8:32"; # <-- magic true value
__END__
=pod
=head1 NAME
Sub::Exporter - a sophisticated exporter for custom-built routines
=head1 VERSION
version 0.987
=head1 SYNOPSIS
Sub::Exporter must be used in two places. First, in an exporting module:
# in the exporting module:
package Text::Tweaker;
use Sub::Exporter -setup => {
exports => [
qw(squish titlecase), # always works the same way
reformat => \&build_reformatter, # generator to build exported function
trim => \&build_trimmer,
indent => \&build_indenter,
],
collectors => [ 'defaults' ],
};
Then, in an importing module:
# in the importing module:
use Text::Tweaker
'squish',
indent => { margin => 5 },
reformat => { width => 79, justify => 'full', -as => 'prettify_text' },
defaults => { eol => 'CRLF' };
With this setup, the importing module ends up with three routines: C,
C, and C. The latter two have been built to the
specifications of the importer -- they are not just copies of the code in the
exporting package.
=head1 DESCRIPTION
B If you're not familiar with Exporter or exporting, read
L first!
=head2 Why Generators?
The biggest benefit of Sub::Exporter over existing exporters (including the
ubiquitous Exporter.pm) is its ability to build new coderefs for export, rather
than to simply export code identical to that found in the exporting package.
If your module's consumers get a routine that works like this:
use Data::Analyze qw(analyze);
my $value = analyze($data, $tolerance, $passes);
and they constantly pass only one or two different set of values for the
non-C<$data> arguments, your code can benefit from Sub::Exporter. By writing a
simple generator, you can let them do this, instead:
use Data::Analyze
analyze => { tolerance => 0.10, passes => 10, -as => analyze10 },
analyze => { tolerance => 0.15, passes => 50, -as => analyze50 };
my $value = analyze10($data);
The package with the generator for that would look something like this:
package Data::Analyze;
use Sub::Exporter -setup => {
exports => [
analyze => \&build_analyzer,
],
};
sub build_analyzer {
my ($class, $name, $arg) = @_;
return sub {
my $data = shift;
my $tolerance = shift || $arg->{tolerance};
my $passes = shift || $arg->{passes};
analyze($data, $tolerance, $passes);
}
}
Your module's user now has to do less work to benefit from it -- and remember,
you're often your own user! Investing in customized subroutines is an
investment in future laziness.
This also avoids a common form of ugliness seen in many modules: package-level
configuration. That is, you might have seen something like the above
implemented like so:
use Data::Analyze qw(analyze);
$Data::Analyze::default_tolerance = 0.10;
$Data::Analyze::default_passes = 10;
This might save time, until you have multiple modules using Data::Analyze.
Because there is only one global configuration, they step on each other's toes
and your code begins to have mysterious errors.
Generators can also allow you to export class methods to be called as
subroutines:
package Data::Methodical;
use Sub::Exporter -setup => { exports => { some_method => \&_curry_class } };
sub _curry_class {
my ($class, $name) = @_;
sub { $class->$name(@_); };
}
Because of the way that exporters and Sub::Exporter work, any package that
inherits from Data::Methodical can inherit its exporter and override its
C. If a user imports C from that package, he'll
receive a subroutine that calls the method on the subclass, rather than on
Data::Methodical itself.
=head2 Other Customizations
Building custom routines with generators isn't the only way that Sub::Exporters
allows the importing code to refine its use of the exported routines. They may
also be renamed to avoid naming collisions.
Consider the following code:
# this program determines to which circle of Hell you will be condemned
use Morality qw(sin virtue); # for calculating viciousness
use Math::Trig qw(:all); # for dealing with circles
The programmer has inadvertently imported two C routines. The solution,
in Exporter.pm-based modules, would be to import only one and then call the
other by its fully-qualified name. Alternately, the importer could write a
routine that did so, or could mess about with typeglobs.
How much easier to write:
# this program determines to which circle of Hell you will be condemned
use Morality qw(virtue), sin => { -as => 'offense' };
use Math::Trig -all => { -prefix => 'trig_' };
and to have at one's disposal C and C -- not to mention
C and C.
=head1 EXPORTER CONFIGURATION
You can configure an exporter for your package by using Sub::Exporter like so:
package Tools;
use Sub::Exporter
-setup => { exports => [ qw(function1 function2 function3) ] };
This is the simplest way to use the exporter, and is basically equivalent to
this:
package Tools;
use base qw(Exporter);
our @EXPORT_OK = qw(function1 function2 function3);
Any basic use of Sub::Exporter will look like this:
package Tools;
use Sub::Exporter -setup => \%config;
The following keys are valid in C<%config>:
exports - a list of routines to provide for exporting; each routine may be
followed by generator
groups - a list of groups to provide for exporting; each must be followed by
either (a) a list of exports, possibly with arguments for each
export, or (b) a generator
collectors - a list of names into which values are collected for use in
routine generation; each name may be followed by a validator
In addition to the basic options above, a few more advanced options may be
passed:
into_level - how far up the caller stack to look for a target (default 0)
into - an explicit target (package) into which to export routines
In other words: Sub::Exporter installs a C routine which, when called,
exports routines to the calling namespace. The C and C
options change where those exported routines are installed.
generator - a callback used to produce the code that will be installed
default: Sub::Exporter::default_generator
installer - a callback used to install the code produced by the generator
default: Sub::Exporter::default_installer
For information on how these callbacks are used, see the documentation for
C> and C>.
=head2 Export Configuration
The C list may be provided as an array reference or a hash reference.
The list is processed in such a way that the following are equivalent:
{ exports => [ qw(foo bar baz), quux => \&quux_generator ] }
{ exports =>
{ foo => undef, bar => undef, baz => undef, quux => \&quux_generator } }
Generators are code that return coderefs. They are called with four
parameters:
$class - the class whose exporter has been called (the exporting class)
$name - the name of the export for which the routine is being build
\%arg - the arguments passed for this export
\%col - the collections for this import
Given the configuration in the L, the following C