Initial Commit
This commit is contained in:
Riley Schneider
354
database/perl/lib/Sub/Exporter/Util.pm
Normal file
354
database/perl/lib/Sub/Exporter/Util.pm
Normal file
@@ -0,0 +1,354 @@
|
||||
use strict;
|
||||
use warnings;
|
||||
package Sub::Exporter::Util;
|
||||
{
|
||||
$Sub::Exporter::Util::VERSION = '0.987';
|
||||
}
|
||||
# ABSTRACT: utilities to make Sub::Exporter easier
|
||||
|
||||
use Data::OptList ();
|
||||
use Params::Util ();
|
||||
|
||||
|
||||
sub curry_method {
|
||||
my $override_name = shift;
|
||||
sub {
|
||||
my ($class, $name) = @_;
|
||||
$name = $override_name if defined $override_name;
|
||||
sub { $class->$name(@_); };
|
||||
}
|
||||
}
|
||||
|
||||
BEGIN { *curry_class = \&curry_method; }
|
||||
|
||||
|
||||
sub curry_chain {
|
||||
# In the future, we can make \%arg an optional prepend, like the "special"
|
||||
# args to the default Sub::Exporter-generated import routine.
|
||||
my (@opt_list) = @_;
|
||||
|
||||
my $pairs = Data::OptList::mkopt(\@opt_list, 'args', 'ARRAY');
|
||||
|
||||
sub {
|
||||
my ($class) = @_;
|
||||
|
||||
sub {
|
||||
my $next = $class;
|
||||
|
||||
for my $i (0 .. $#$pairs) {
|
||||
my $pair = $pairs->[ $i ];
|
||||
|
||||
unless (Params::Util::_INVOCANT($next)) { ## no critic Private
|
||||
my $str = defined $next ? "'$next'" : 'undef';
|
||||
Carp::croak("can't call $pair->[0] on non-invocant $str")
|
||||
}
|
||||
|
||||
my ($method, $args) = @$pair;
|
||||
|
||||
if ($i == $#$pairs) {
|
||||
return $next->$method($args ? @$args : ());
|
||||
} else {
|
||||
$next = $next->$method($args ? @$args : ());
|
||||
}
|
||||
}
|
||||
};
|
||||
}
|
||||
}
|
||||
|
||||
# =head2 name_map
|
||||
#
|
||||
# This utility returns an list to be used in specify export generators. For
|
||||
# example, the following:
|
||||
#
|
||||
# exports => {
|
||||
# name_map(
|
||||
# '_?_gen' => [ qw(fee fie) ],
|
||||
# '_make_?' => [ qw(foo bar) ],
|
||||
# ),
|
||||
# }
|
||||
#
|
||||
# is equivalent to:
|
||||
#
|
||||
# exports => {
|
||||
# name_map(
|
||||
# fee => \'_fee_gen',
|
||||
# fie => \'_fie_gen',
|
||||
# foo => \'_make_foo',
|
||||
# bar => \'_make_bar',
|
||||
# ),
|
||||
# }
|
||||
#
|
||||
# This can save a lot of typing, when providing many exports with similarly-named
|
||||
# generators.
|
||||
#
|
||||
# =cut
|
||||
#
|
||||
# sub name_map {
|
||||
# my (%groups) = @_;
|
||||
#
|
||||
# my %map;
|
||||
#
|
||||
# while (my ($template, $names) = each %groups) {
|
||||
# for my $name (@$names) {
|
||||
# (my $export = $template) =~ s/\?/$name/
|
||||
# or Carp::croak 'no ? found in name_map template';
|
||||
#
|
||||
# $map{ $name } = \$export;
|
||||
# }
|
||||
# }
|
||||
#
|
||||
# return %map;
|
||||
# }
|
||||
|
||||
|
||||
sub merge_col {
|
||||
my (%groups) = @_;
|
||||
|
||||
my %merged;
|
||||
|
||||
while (my ($default_name, $group) = each %groups) {
|
||||
while (my ($export_name, $gen) = each %$group) {
|
||||
$merged{$export_name} = sub {
|
||||
my ($class, $name, $arg, $col) = @_;
|
||||
|
||||
my $merged_arg = exists $col->{$default_name}
|
||||
? { %{ $col->{$default_name} }, %$arg }
|
||||
: $arg;
|
||||
|
||||
if (Params::Util::_CODELIKE($gen)) { ## no critic Private
|
||||
$gen->($class, $name, $merged_arg, $col);
|
||||
} else {
|
||||
$class->$$gen($name, $merged_arg, $col);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return %merged;
|
||||
}
|
||||
|
||||
|
||||
sub __mixin_class_for {
|
||||
my ($class, $mix_into) = @_;
|
||||
require Package::Generator;
|
||||
my $mixin_class = Package::Generator->new_package({
|
||||
base => "$class\:\:__mixin__",
|
||||
});
|
||||
|
||||
## no critic (ProhibitNoStrict)
|
||||
no strict 'refs';
|
||||
if (ref $mix_into) {
|
||||
unshift @{"$mixin_class" . "::ISA"}, ref $mix_into;
|
||||
} else {
|
||||
unshift @{"$mix_into" . "::ISA"}, $mixin_class;
|
||||
}
|
||||
return $mixin_class;
|
||||
}
|
||||
|
||||
sub mixin_installer {
|
||||
sub {
|
||||
my ($arg, $to_export) = @_;
|
||||
|
||||
my $mixin_class = __mixin_class_for($arg->{class}, $arg->{into});
|
||||
bless $arg->{into} => $mixin_class if ref $arg->{into};
|
||||
|
||||
Sub::Exporter::default_installer(
|
||||
{ %$arg, into => $mixin_class },
|
||||
$to_export,
|
||||
);
|
||||
};
|
||||
}
|
||||
|
||||
sub mixin_exporter {
|
||||
Carp::cluck "mixin_exporter is deprecated; use mixin_installer instead; it behaves identically";
|
||||
return mixin_installer;
|
||||
}
|
||||
|
||||
|
||||
sub like {
|
||||
sub {
|
||||
my ($value, $arg) = @_;
|
||||
Carp::croak "no regex supplied to regex group generator" unless $value;
|
||||
|
||||
# Oh, qr//, how you bother me! See the p5p thread from around now about
|
||||
# fixing this problem... too bad it won't help me. -- rjbs, 2006-04-25
|
||||
my @values = eval { $value->isa('Regexp') } ? ($value, undef)
|
||||
: @$value;
|
||||
|
||||
while (my ($re, $opt) = splice @values, 0, 2) {
|
||||
Carp::croak "given pattern for regex group generater is not a Regexp"
|
||||
unless eval { $re->isa('Regexp') };
|
||||
my @exports = keys %{ $arg->{config}->{exports} };
|
||||
my @matching = grep { $_ =~ $re } @exports;
|
||||
|
||||
my %merge = $opt ? %$opt : ();
|
||||
my $prefix = (delete $merge{-prefix}) || '';
|
||||
my $suffix = (delete $merge{-suffix}) || '';
|
||||
|
||||
for my $name (@matching) {
|
||||
my $as = $prefix . $name . $suffix;
|
||||
push @{ $arg->{import_args} }, [ $name => { %merge, -as => $as } ];
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
}
|
||||
}
|
||||
|
||||
use Sub::Exporter -setup => {
|
||||
exports => [ qw(
|
||||
like
|
||||
name_map
|
||||
merge_col
|
||||
curry_method curry_class
|
||||
curry_chain
|
||||
mixin_installer mixin_exporter
|
||||
) ]
|
||||
};
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Sub::Exporter::Util - utilities to make Sub::Exporter easier
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.987
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides a number of utility functions for performing common or
|
||||
useful operations when setting up a Sub::Exporter configuration. All of the
|
||||
utilities may be exported, but none are by default.
|
||||
|
||||
=head1 THE UTILITIES
|
||||
|
||||
=head2 curry_method
|
||||
|
||||
exports => {
|
||||
some_method => curry_method,
|
||||
}
|
||||
|
||||
This utility returns a generator which will produce an invocant-curried version
|
||||
of a method. In other words, it will export a method call with the exporting
|
||||
class built in as the invocant.
|
||||
|
||||
A module importing the code some the above example might do this:
|
||||
|
||||
use Some::Module qw(some_method);
|
||||
|
||||
my $x = some_method;
|
||||
|
||||
This would be equivalent to:
|
||||
|
||||
use Some::Module;
|
||||
|
||||
my $x = Some::Module->some_method;
|
||||
|
||||
If Some::Module is subclassed and the subclass's import method is called to
|
||||
import C<some_method>, the subclass will be curried in as the invocant.
|
||||
|
||||
If an argument is provided for C<curry_method> it is used as the name of the
|
||||
curried method to export. This means you could export a Widget constructor
|
||||
like this:
|
||||
|
||||
exports => { widget => curry_method('new') }
|
||||
|
||||
This utility may also be called as C<curry_class>, for backwards compatibility.
|
||||
|
||||
=head2 curry_chain
|
||||
|
||||
C<curry_chain> behaves like C<L</curry_method>>, but is meant for generating
|
||||
exports that will call several methods in succession.
|
||||
|
||||
exports => {
|
||||
reticulate => curry_chain(
|
||||
new => gather_data => analyze => [ detail => 100 ] => 'results'
|
||||
),
|
||||
}
|
||||
|
||||
If imported from Spliner, calling the C<reticulate> routine will be equivalent
|
||||
to:
|
||||
|
||||
Spliner->new->gather_data->analyze(detail => 100)->results;
|
||||
|
||||
If any method returns something on which methods may not be called, the routine
|
||||
croaks.
|
||||
|
||||
The arguments to C<curry_chain> form an optlist. The names are methods to be
|
||||
called and the arguments, if given, are arrayrefs to be dereferenced and passed
|
||||
as arguments to those methods. C<curry_chain> returns a generator like those
|
||||
expected by Sub::Exporter.
|
||||
|
||||
B<Achtung!> at present, there is no way to pass arguments from the generated
|
||||
routine to the method calls. This will probably be solved in future revisions
|
||||
by allowing the opt list's values to be subroutines that will be called with
|
||||
the generated routine's stack.
|
||||
|
||||
=head2 merge_col
|
||||
|
||||
exports => {
|
||||
merge_col(defaults => {
|
||||
twiddle => \'_twiddle_gen',
|
||||
tweak => \&_tweak_gen,
|
||||
}),
|
||||
}
|
||||
|
||||
This utility wraps the given generator in one that will merge the named
|
||||
collection into its args before calling it. This means that you can support a
|
||||
"default" collector in multiple exports without writing the code each time.
|
||||
|
||||
You can specify as many pairs of collection names and generators as you like.
|
||||
|
||||
=head2 mixin_installer
|
||||
|
||||
use Sub::Exporter -setup => {
|
||||
installer => Sub::Exporter::Util::mixin_installer,
|
||||
exports => [ qw(foo bar baz) ],
|
||||
};
|
||||
|
||||
This utility returns an installer that will install into a superclass and
|
||||
adjust the ISA importing class to include the newly generated superclass.
|
||||
|
||||
If the target of importing is an object, the hierarchy is reversed: the new
|
||||
class will be ISA the object's class, and the object will be reblessed.
|
||||
|
||||
B<Prerequisites>: This utility requires that Package::Generator be installed.
|
||||
|
||||
=head2 like
|
||||
|
||||
It's a collector that adds imports for anything like given regex.
|
||||
|
||||
If you provide this configuration:
|
||||
|
||||
exports => [ qw(igrep imap islurp exhausted) ],
|
||||
collectors => { -like => Sub::Exporter::Util::like },
|
||||
|
||||
A user may import from your module like this:
|
||||
|
||||
use Your::Iterator -like => qr/^i/; # imports igre, imap, islurp
|
||||
|
||||
or
|
||||
|
||||
use Your::Iterator -like => [ qr/^i/ => { -prefix => 'your_' } ];
|
||||
|
||||
The group-like prefix and suffix arguments are respected; other arguments are
|
||||
passed on to the generators for matching exports.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Ricardo Signes <rjbs@cpan.org>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2007 by Ricardo Signes.
|
||||
|
||||
This is free software; you can redistribute it and/or modify it under
|
||||
the same terms as the Perl 5 programming language system itself.
|
||||
|
||||
=cut
|
||||
Reference in New Issue
Block a user