lib/Sub/Prototype/Util.pm

   1 package Sub::Prototype::Util;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Carp qw/croak/;
   7 use Scalar::Util qw/reftype/;
   8
   9 =head1 NAME
  10
  11 Sub::Prototype::Util - Prototype-related utility routines.
  12
  13 =head1 VERSION
  14
  15 Version 0.08
  16
  17 =cut
  18
  19 use vars qw/$VERSION/;
  20
  21 $VERSION = '0.08';
  22
  23 =head1 SYNOPSIS
  24
  25     use Sub::Prototype::Util qw/flatten wrap recall/;
  26
  27     my @a = qw/a b c/;
  28     my @args = ( \@a, 1, { d => 2 }, undef, 3 );
  29
  30     my @flat = flatten '\@$;$', @args; # ('a', 'b', 'c', 1, { d => 2 })
  31     recall 'CORE::push', @args; # @a contains 'a', 'b', 'c', 1, { d => 2 }, undef, 3
  32     my $splice = wrap 'CORE::splice';
  33     my @b = $splice->(\@a, 4, 2); # @a is now ('a', 'b', 'c', 1, 3) and @b is ({ d => 2 }, undef)
  34
  35 =head1 DESCRIPTION
  36
  37 Prototypes are evil, but sometimes you just have to bear with them, especially when messing with core functions. This module provides several utilities aimed at facilitating "overloading" of prototyped functions.
  38
  39 They all handle C<5.10>'s C<_> prototype.
  40
  41 =head1 FUNCTIONS
  42
  43 =cut
  44
  45 my %sigils = qw/SCALAR $ ARRAY @ HASH % GLOB * CODE &/;
  46 my %reftypes = reverse %sigils;
  47
  48 sub _check_ref {
  49  my ($a, $p) = @_;
  50  my $r;
  51  if (!defined $a || !defined($r = reftype $a)) { # not defined or plain scalar
  52   croak 'Got ' . ((defined $a) ? 'a plain scalar' : 'undef')
  53                . ' where a reference was expected';
  54  }
  55  croak 'Unexpected ' . $r . ' reference' unless exists $sigils{$r}
  56                                             and $p =~ /\Q$sigils{$r}\E/;
  57  return $r;
  58 }
  59
  60 =head2 C<flatten $proto, @args>
  61
  62 Flattens the array C<@args> according to the prototype C<$proto>. When C<@args> is what C<@_> is after calling a subroutine with prototype C<$proto>, C<flatten> returns the list of what C<@_> would have been if there were no prototype.
  63
  64 =cut
  65
  66 sub flatten {
  67  my $proto = shift;
  68  return @_ unless defined $proto;
  69  my @args;
  70  while ($proto =~ /(\\?)(\[[^\]]+\]|[^\];])/g) {
  71   my $p = $2;
  72   if ($1) {
  73    my $a = shift;
  74    my $r = _check_ref $a, $p;
  75    push @args, $r eq 'SCALAR'
  76                ? $$a
  77                : ($r eq 'ARRAY'
  78                   ? @$a
  79                   : ($r eq 'HASH'
  80                      ? %$a
  81                      : ($r eq 'GLOB'
  82                         ? *$a
  83                         : &$a # _check_ref ensures this must be a code ref
  84                        )
  85                     )
  86                  );
  87   } elsif ($p =~ /[\@\%]/) {
  88    push @args, @_;
  89    last;
  90   } elsif ($p eq '_' && @_ == 0) {
  91    push @args, $_;
  92   } else {
  93    push @args, shift;
  94   }
  95  }
  96  return @args;
  97 }
  98
  99 =head2 C<wrap $name, %opts>
 100
 101 Generates a wrapper that calls the function C<$name> with a prototyped argument list. That is, the wrapper's arguments should be what C<@_> is when you define a subroutine with the same prototype as C<$name>.
 102
 103     my $a = [ 0 .. 2 ];
 104     my $push = wrap 'CORE::push';
 105     $push->($a, 3, 4); # returns 3 + 2 = 5 and $a now contains 0 .. 4
 106
 107 You can force the use of a specific prototype. In this case, C<$name> must be a hash reference that holds exactly one key / value pair, the key being the function name and the value the prototpye that should be used to call it.
 108
 109     my $push = wrap { 'CORE::push' => '\@$' }; # only pushes 1 arg
 110
 111 Others arguments are seen as key / value pairs that are meant to tune the code generated by L</wrap>. Valid keys are :
 112
 113 =over 4
 114
 115 =item C<< ref => $func >>
 116
 117 Specifies the function used in the generated code to test the reference type of scalars. Defaults to C<'ref'>. You may also want to use C<Scalar::Util::reftype>.
 118
 119 =item C<< wrong_ref => $code >>
 120
 121 The code executed when a reference of incorrect type is encountered. The result of this snippet is also the result of the generated code, hence it defaults to C<'undef'>. It's a good place to C<croak> or C<die> too.
 122
 123 =item C<< sub => $bool >>
 124
 125 Encloses the code into a C<sub { }> block. Default is true.
 126
 127 =item C<< compile => $bool >>
 128
 129 Makes L</wrap> compile the code generated and return the resulting code reference. Be careful that in this case C<ref> must be a fully qualified function name. Defaults to true, but turned off when C<sub> is false.
 130
 131 =back
 132
 133 For example, this allows you to recall into C<CORE::grep> and C<CORE::map> by using the C<\&@> prototype :
 134
 135     my $grep = wrap { 'CORE::grep' => '\&@' };
 136     sub mygrep (&@) { $grep->(@_) } # the prototypes are intentionally different
 137
 138 =cut
 139
 140 sub _wrap {
 141  my ($name, $proto, $i, $args, $cr, $opts) = @_;
 142  if ($proto =~ /(\\?)(\[[^\]]+\]|[^\];])(.*)/g) {
 143   my ($ref, $p) = ($1, $2);
 144   $proto = $3;
 145   $p = $1 if $p =~ /^\[([^\]]+)\]/;
 146   my $cur = '$_[' . $i . ']';
 147   if ($ref) {
 148    if (length $p > 1) {
 149     return 'my $r = ' . $opts->{ref} . '(' . $cur . '); '
 150            . join ' els',
 151               map( {
 152                "if (\$r eq '" . $reftypes{$_} ."') { "
 153                . _wrap($name, $proto, ($i + 1),
 154                               $args . $_ . '{' . $cur . '}, ',
 155                               $cr, $opts)
 156                . ' }'
 157               } split //, $p),
 158               'e { ' . $opts->{wrong_ref} . ' }'
 159    } else {
 160     $args .= $p . '{' . $cur . '}, ';
 161    }
 162   } elsif ($p =~ /[\@\%]/) {
 163    $args .= '@_[' . $i . '..$#_]';
 164   } elsif ($p =~ /\&/) {
 165    my %h = do { my $c; map { $_ => $c++ } @$cr };
 166    my $j;
 167    if (not exists $h{$i}) {
 168     push @$cr, $i;
 169     $j = $#{$cr};
 170    } else {
 171     $j = int $h{$i};
 172    }
 173    $args .= 'sub{&{$c[' . $j . ']}}, ';
 174   } elsif ($p eq '_') {
 175    $args .= '((@_ > ' . $i . ') ? ' . $cur . ' : $_), ';
 176   } else {
 177    $args .= $cur . ', ';
 178   }
 179   return _wrap($name, $proto, ($i + 1), $args, $cr, $opts);
 180  } else {
 181   $args =~ s/,\s*$//;
 182   return $name . '(' . $args . ')';
 183  }
 184 }
 185
 186 sub _check_name {
 187  my $name = $_[0];
 188  croak 'No subroutine specified' unless $name;
 189  my $proto;
 190  my $r = ref $name;
 191  if (!$r) {
 192   $proto = prototype $name;
 193  } elsif ($r eq 'HASH') {
 194   croak 'Forced prototype hash reference must contain exactly one key/value pair' unless keys %$name == 1;
 195   ($name, $proto) = %$name;
 196  } else {
 197   croak 'Unhandled ' . $r . ' reference as first argument';
 198  }
 199  $name =~ s/^\s+//;
 200  $name =~ s/[\s\$\@\%\*\&;].*//;
 201  return $name, $proto;
 202 }
 203
 204 sub wrap {
 205  my ($name, $proto) = _check_name shift;
 206  croak 'Optional arguments must be passed as key => value pairs' if @_ % 2;
 207  my %opts = @_;
 208  $opts{ref}     ||= 'ref';
 209  $opts{sub}       = 1       if not defined $opts{sub};
 210  $opts{compile}   = 1       if not defined $opts{compile} and $opts{sub};
 211  $opts{wrong_ref} = 'undef' if not defined $opts{wrong_ref};
 212  my @cr;
 213  my $call;
 214  if (defined $proto) {
 215   $call = _wrap $name, $proto, 0, '', \@cr, \%opts;
 216  } else {
 217   $call = _wrap $name, '', 0, '@_';
 218  }
 219  if (@cr) {
 220   $call = 'my @c; '
 221         . join('', map { 'push @c, $_[' . $_ . ']; ' } @cr)
 222         . $call
 223  }
 224  $call = '{ ' . $call . ' }';
 225  $call = 'sub ' . $call if $opts{sub};
 226  if ($opts{compile}) {
 227   $call = eval $call;
 228   croak $@ if $@;
 229  }
 230  return $call;
 231 }
 232
 233 =head2 C<recall $name, @args>
 234
 235 Calls the function C<$name> with the prototyped argument list C<@args>. That is, C<@args> should be what C<@_> is when you define a subroutine with the same prototype as C<$name>. You can still force the prototype by passing C<< { $name => $proto } >> as the first argument.
 236
 237     my $a = [ ];
 238     recall { 'CORE::push' => '\@$' }, $a, 1, 2, 3; # $a just contains 1
 239
 240 It's implemented in terms of L</wrap>, and hence calls C<eval> at each run.
 241 If you plan to recall several times, consider using L</wrap> instead.
 242
 243 =cut
 244
 245 sub recall {
 246  my $wrap = eval { wrap shift };
 247  croak $@ if $@;
 248  return $wrap->(@_);
 249 }
 250
 251 =head1 EXPORT
 252
 253 The functions L</flatten>, L</wrap> and L</recall> are only exported on request, either by providing their name or by the C<':funcs'> and C<':all'> tags.
 254
 255 =cut
 256
 257 use base qw/Exporter/;
 258
 259 use vars qw/@EXPORT @EXPORT_OK %EXPORT_TAGS/;
 260
 261 @EXPORT             = ();
 262 %EXPORT_TAGS        = (
 263  'funcs' =>  [ qw/flatten wrap recall/ ]
 264 );
 265 @EXPORT_OK          = map { @$_ } values %EXPORT_TAGS;
 266 $EXPORT_TAGS{'all'} = [ @EXPORT_OK ];
 267
 268 =head1 DEPENDENCIES
 269
 270 L<Carp>, L<Exporter> (core modules since perl 5), L<Scalar::Util> (since 5.7.3).
 271
 272 =head1 AUTHOR
 273
 274 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 275
 276 You can contact me by mail or on C<irc.perl.org> (vincent).
 277
 278 =head1 BUGS
 279
 280 Please report any bugs or feature requests to C<bug-sub-prototype-util at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Sub-Prototype-Util>.  I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 281
 282 =head1 SUPPORT
 283
 284 You can find documentation for this module with the perldoc command.
 285
 286     perldoc Sub::Prototype::Util
 287
 288 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Sub-Prototype-Util>.
 289
 290 =head1 COPYRIGHT & LICENSE
 291
 292 Copyright 2008 Vincent Pit, all rights reserved.
 293
 294 This program is free software; you can redistribute it and/or modify it
 295 under the same terms as Perl itself.
 296
 297 =cut
 298
 299 1; # End of Sub::Prototype::Util