local-lib5/lib/perl5/Sub/Exporter/Util.pm

   1 use strict;
   2 use warnings;
   3
   4 package Sub::Exporter::Util;
   5
   6 use Data::OptList ();
   7 use Params::Util ();
   8
   9 =head1 NAME
  10
  11 Sub::Exporter::Util - utilities to make Sub::Exporter easier
  12
  13 =head1 VERSION
  14
  15 version 0.982
  16
  17 =cut
  18
  19 our $VERSION = '0.982';
  20
  21 =head1 DESCRIPTION
  22
  23 This module provides a number of utility functions for performing common or
  24 useful operations when setting up a Sub::Exporter configuration.  All of the
  25 utilites may be exported, but none are by default.
  26
  27 =head1 THE UTILITIES
  28
  29 =head2 curry_method
  30
  31   exports => {
  32     some_method => curry_method,
  33   }
  34
  35 This utility returns a generator which will produce an invocant-curried version
  36 of a method.  In other words, it will export a method call with the exporting
  37 class built in as the invocant.
  38
  39 A module importing the code some the above example might do this:
  40
  41   use Some::Module qw(some_method);
  42
  43   my $x = some_method;
  44
  45 This would be equivalent to:
  46
  47   use Some::Module;
  48
  49   my $x = Some::Module->some_method;
  50
  51 If Some::Module is subclassed and the subclass's import method is called to
  52 import C<some_method>, the subclass will be curried in as the invocant.
  53
  54 If an argument is provided for C<curry_method> it is used as the name of the
  55 curried method to export.  This means you could export a Widget constructor
  56 like this:
  57
  58   exports => { widget => curry_method('new') }
  59
  60 This utility may also be called as C<curry_class>, for backwards compatibility.
  61
  62 =cut
  63
  64 sub curry_method {
  65   my $override_name = shift;
  66   sub {
  67     my ($class, $name) = @_;
  68     $name = $override_name if defined $override_name;
  69     sub { $class->$name(@_); };
  70   }
  71 }
  72
  73 BEGIN { *curry_class = \&curry_method; }
  74
  75 =head2 curry_chain
  76
  77 C<curry_chain> behaves like C<L</curry_method>>, but is meant for generating
  78 exports that will call several methods in succession.
  79
  80   exports => {
  81     reticulate => curry_chain([
  82       new => gather_data => analyze => [ detail => 100 ] => results
  83     ]),
  84   }
  85
  86 If imported from Spliner, calling the C<reticulate> routine will be equivalent
  87 to:
  88
  89   Splinter->new->gather_data->analyze(detail => 100)->results;
  90
  91 If any method returns something on which methods may not be called, the routine
  92 croaks.
  93
  94 The arguments to C<curry_chain> form an optlist.  The names are methods to be
  95 called and the arguments, if given, are arrayrefs to be dereferenced and passed
  96 as arguments to those methods.  C<curry_chain> returns a generator like those
  97 expected by Sub::Exporter.
  98
  99 B<Achtung!> at present, there is no way to pass arguments from the generated
 100 routine to the method calls.  This will probably be solved in future revisions
 101 by allowing the opt list's values to be subroutines that will be called with
 102 the generated routine's stack.
 103
 104 =cut
 105
 106 sub curry_chain {
 107   # In the future, we can make \%arg an optional prepend, like the "special"
 108   # args to the default Sub::Exporter-generated import routine.
 109   my (@opt_list) = @_;
 110
 111   my $pairs = Data::OptList::mkopt(\@opt_list, 'args', 'ARRAY');
 112
 113   sub {
 114     my ($class) = @_;
 115
 116     sub {
 117       my $next = $class;
 118
 119       for my $i (0 .. $#$pairs) {
 120         my $pair = $pairs->[ $i ];
 121
 122         unless (Params::Util::_INVOCANT($next)) { ## no critic Private
 123           my $str = defined $next ? "'$next'" : 'undef';
 124           Carp::croak("can't call $pair->[0] on non-invocant $str")
 125         }
 126
 127         my ($method, $args) = @$pair;
 128
 129         if ($i == $#$pairs) {
 130           return $next->$method($args ? @$args : ());
 131         } else {
 132           $next = $next->$method($args ? @$args : ());
 133         }
 134       }
 135     };
 136   }
 137 }
 138
 139 # =head2 name_map
 140 #
 141 # This utility returns an list to be used in specify export generators.  For
 142 # example, the following:
 143 #
 144 #   exports => {
 145 #     name_map(
 146 #       '_?_gen'  => [ qw(fee fie) ],
 147 #       '_make_?' => [ qw(foo bar) ],
 148 #     ),
 149 #   }
 150 #
 151 # is equivalent to:
 152 #
 153 #   exports => {
 154 #     name_map(
 155 #       fee => \'_fee_gen',
 156 #       fie => \'_fie_gen',
 157 #       foo => \'_make_foo',
 158 #       bar => \'_make_bar',
 159 #     ),
 160 #   }
 161 #
 162 # This can save a lot of typing, when providing many exports with similarly-named
 163 # generators.
 164 #
 165 # =cut
 166 #
 167 # sub name_map {
 168 #   my (%groups) = @_;
 169 #
 170 #   my %map;
 171 #
 172 #   while (my ($template, $names) = each %groups) {
 173 #     for my $name (@$names) {
 174 #       (my $export = $template) =~ s/\?/$name/
 175 #         or Carp::croak 'no ? found in name_map template';
 176 #
 177 #       $map{ $name } = \$export;
 178 #     }
 179 #   }
 180 #
 181 #   return %map;
 182 # }
 183
 184 =head2 merge_col
 185
 186   exports => {
 187     merge_col(defaults => {
 188       twiddle => \'_twiddle_gen',
 189       tweak   => \&_tweak_gen,
 190     }),
 191   }
 192
 193 This utility wraps the given generator in one that will merge the named
 194 collection into its args before calling it.  This means that you can support a
 195 "default" collector in multipe exports without writing the code each time.
 196
 197 You can specify as many pairs of collection names and generators as you like.
 198
 199 =cut
 200
 201 sub merge_col {
 202   my (%groups) = @_;
 203
 204   my %merged;
 205
 206   while (my ($default_name, $group) = each %groups) {
 207     while (my ($export_name, $gen) = each %$group) {
 208       $merged{$export_name} = sub {
 209         my ($class, $name, $arg, $col) = @_;
 210
 211         my $merged_arg = exists $col->{$default_name}
 212                        ? { %{ $col->{$default_name} }, %$arg }
 213                        : $arg;
 214
 215         if (Params::Util::_CODELIKE($gen)) { ## no critic Private
 216           $gen->($class, $name, $merged_arg, $col);
 217         } else {
 218           $class->$$gen($name, $merged_arg, $col);
 219         }
 220       }
 221     }
 222   }
 223
 224   return %merged;
 225 }
 226
 227 =head2 mixin_installer
 228
 229   use Sub::Exporter -setup => {
 230     installer => Sub::Exporter::Util::mixin_installer,
 231     exports   => [ qw(foo bar baz) ],
 232   };
 233
 234 This utility returns an installer that will install into a superclass and
 235 adjust the ISA importing class to include the newly generated superclass.
 236
 237 If the target of importing is an object, the hierarchy is reversed: the new
 238 class will be ISA the object's class, and the object will be reblessed.
 239
 240 B<Prerequisites>: This utility requires that Package::Generator be installed.
 241
 242 =cut
 243
 244 sub __mixin_class_for {
 245   my ($class, $mix_into) = @_;
 246   require Package::Generator;
 247   my $mixin_class = Package::Generator->new_package({
 248     base => "$class\:\:__mixin__",
 249   });
 250
 251   ## no critic (ProhibitNoStrict)
 252   no strict 'refs';
 253   if (ref $mix_into) {
 254     unshift @{"$mixin_class" . "::ISA"}, ref $mix_into;
 255   } else {
 256     unshift @{"$mix_into" . "::ISA"}, $mixin_class;
 257   }
 258   return $mixin_class;
 259 }
 260
 261 sub mixin_installer {
 262   sub {
 263     my ($arg, $to_export) = @_;
 264
 265     my $mixin_class = __mixin_class_for($arg->{class}, $arg->{into});
 266     bless $arg->{into} => $mixin_class if ref $arg->{into};
 267
 268     Sub::Exporter::default_installer(
 269       { %$arg, into => $mixin_class },
 270       $to_export,
 271     );
 272   };
 273 }
 274
 275 sub mixin_exporter {
 276   Carp::cluck "mixin_exporter is deprecated; use mixin_installer instead; it behaves identically";
 277   return mixin_installer;
 278 }
 279
 280 =head2 like
 281
 282 It's a collector that adds imports for anything like given regex.
 283
 284 If you provide this configuration:
 285
 286   exports    => [ qw(igrep imap islurp exhausted) ],
 287   collectors => { -like => Sub::Exporter::Util::like },
 288
 289 A user may import from your module like this:
 290
 291   use Your::Iterator -like => qr/^i/; # imports igre, imap, islurp
 292
 293 or
 294
 295   use Your::Iterator -like => [ qr/^i/ => { -prefix => 'your_' } ];
 296
 297 The group-like prefix and suffix arguments are respected; other arguments are
 298 passed on to the generators for matching exports.
 299
 300 =cut
 301
 302 sub like {
 303   sub {
 304     my ($value, $arg) = @_;
 305     Carp::croak "no regex supplied to regex group generator" unless $value;
 306
 307     # Oh, qr//, how you bother me!  See the p5p thread from around now about
 308     # fixing this problem... too bad it won't help me. -- rjbs, 2006-04-25
 309     my @values = eval { $value->isa('Regexp') } ? ($value, undef)
 310                :                                  @$value;
 311
 312     while (my ($re, $opt) = splice @values, 0, 2) {
 313       Carp::croak "given pattern for regex group generater is not a Regexp"
 314         unless eval { $re->isa('Regexp') };
 315       my @exports  = keys %{ $arg->{config}->{exports} };
 316       my @matching = grep { $_ =~ $re } @exports;
 317
 318       my %merge = $opt ? %$opt : ();
 319       my $prefix = (delete $merge{-prefix}) || '';
 320       my $suffix = (delete $merge{-suffix}) || '';
 321
 322       for my $name (@matching) {
 323         my $as = $prefix . $name . $suffix;
 324         push @{ $arg->{import_args} }, [ $name => { %merge, -as => $as } ];
 325       }
 326     }
 327
 328     1;
 329   }
 330 }
 331
 332 use Sub::Exporter -setup => {
 333   exports => [ qw(
 334     like
 335     name_map
 336     merge_col
 337     curry_method curry_class
 338     curry_chain
 339     mixin_installer mixin_exporter
 340   ) ]
 341 };
 342
 343 =head1 AUTHOR
 344
 345 Ricardo SIGNES, C<< <rjbs@cpan.org> >>
 346
 347 =head1 BUGS
 348
 349 Please report any bugs or feature requests through the web interface at
 350 L<http://rt.cpan.org>. I will be notified, and then you'll automatically be
 351 notified of progress on your bug as I make changes.
 352
 353 =head1 COPYRIGHT
 354
 355 Copyright 2006-2007, Ricardo SIGNES.  This program is free software;  you can
 356 redistribute it and/or modify it under the same terms as Perl itself.
 357
 358 =cut
 359
 360 1;