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 recall wrap/;
  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', compile => 1;
  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    my %deref = (
  76     SCALAR => sub { push @args, $$a },
  77     ARRAY  => sub { push @args, @$a },
  78     HASH   => sub { push @args, %$a },
  79     GLOB   => sub { push @args, *$a },
  80     CODE   => sub { push @args, &$a }
  81    );
  82    $deref{$r}->();
  83   } elsif ($p =~ /[\@\%]/) {
  84    push @args, @_;
  85    last;
  86   } elsif ($p eq '_' && @_ == 0) {
  87    push @args, $_;
  88   } else {
  89    push @args, shift;
  90   }
  91  }
  92  return @args;
  93 }
  94
  95 =head2 C<recall $name, @args>
  96
  97 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>. For example,
  98
  99     my $a = [ ];
 100     recall 'CORE::push', $a, 1, 2, 3;
 101
 102 will call C<push @$a, 1, 2, 3> and so fill the arrayref C<$a> with C<1, 2, 3>. This is especially needed for core functions because you can't C<goto> into them.
 103
 104 You can also 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.
 105
 106     recall { 'CORE::push' => '\@$' }, $a, 1, 2, 3; # will only push 1
 107
 108 This allows you to recall into C<CORE::grep> and C<CORE::map> by using the C<\&@> prototype :
 109
 110     sub mygrep (&@) { recall { 'CORE::grep' => '\&@' }, @_ } # the prototypes are intentionally different
 111
 112 =cut
 113
 114 sub _check_name {
 115  my $name = $_[0];
 116  croak 'No subroutine specified' unless $name;
 117  my $proto;
 118  my $r = ref $name;
 119  if (!$r) {
 120   $proto = prototype $name;
 121  } elsif ($r eq 'HASH') {
 122   croak 'Forced prototype hash reference must contain exactly one key/value pair' unless keys %$name == 1;
 123   ($name, $proto) = %$name;
 124  } else {
 125   croak 'Unhandled ' . $r . ' reference as first argument';
 126  }
 127  $name =~ s/^\s+//;
 128  $name =~ s/[\s\$\@\%\*\&;].*//;
 129  return $name, $proto;
 130 }
 131
 132 sub recall {
 133  my ($name, $proto) = _check_name shift;
 134  my $call = $name . '(';
 135  my @cr;
 136  if (defined $proto) {
 137   my $i = 0;
 138   while ($proto =~ /(\\?)(\[[^\]]+\]|[^\];])/g) {
 139    my $p = $2;
 140    if ($1) {
 141     my $r = _check_ref $_[$i], $p;
 142     $call .= $sigils{$r} . '{$_[' . $i . ']},';
 143    } elsif ($p =~ /[\@\%]/) {
 144     $call .= '@_[' . $i . '..' . (@_ - 1) . ']';
 145     last;
 146    } elsif ($p =~ /\&/) {
 147     push @cr, $_[$i];
 148     $call .= 'sub{&{$cr[' . $#cr . ']}},';
 149    } elsif ($p eq '_' && $i >= @_) {
 150     $call .= '$_,';
 151    } else {
 152     $call .= '$_[' . $i . '],';
 153    }
 154    ++$i;
 155   }
 156   $call =~ s/,$//;
 157  } else {
 158   $call .= join ',', map '$_[' . $_ . ']', 0 .. @_ - 1;
 159  }
 160  $call .= ');';
 161  my @ret = eval $call;
 162  croak $@ if $@;
 163  return @ret;
 164 }
 165
 166 =head2 C<wrap $name, %opts>
 167
 168 Generates a wrapper that does the same thing as L</recall>, but specialized for a given function. This wrapper can be compiled once for all to avoid calling C<eval> at each run (like L</recall> does). You can still force the prototype by passing C<< { $name => $proto } >> as the first argument. Others arguments are seen as key / value pairs and tune the code generated by L</wrap>. Valid keys are :
 169
 170 =over 4
 171
 172 =item C<< ref => $func >>
 173
 174 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>.
 175
 176 =item C<< wrong_ref => $code >>
 177
 178 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.
 179
 180 =item C<< sub => $bool >>
 181
 182 Encloses the code into a C<sub { }> block. Default is true.
 183
 184 =item C<< compile => $bool >>
 185
 186 Makes L</wrap> compile the code generated and return the resulting code reference. Implies C<< sub => 1 >>. Be careful that in this case C<ref> must be a fully qualified function name. Defaults to false.
 187
 188 =back
 189
 190 This is how you make your own C<push> that pushes into array references :
 191
 192     my @a = (0 .. 2);
 193     my $push = wrap 'CORE::push', compile => 1;
 194     $push->(\@a, 3 .. 7); # returns 3 + 5 = 8, and @a now contains 0 .. 7
 195
 196 =cut
 197
 198 sub _wrap {
 199  my ($name, $proto, $i, $args, $cr, $opts) = @_;
 200  if ($proto =~ /(\\?)(\[[^\]]+\]|[^\];])(.*)/g) {
 201   my ($ref, $p) = ($1, $2);
 202   $proto = $3;
 203   $p = $1 if $p =~ /^\[([^\]]+)\]/;
 204   my $cur = '$_[' . $i . ']';
 205   if ($ref) {
 206    if (length $p > 1) {
 207     return 'my $r = ' . $opts->{ref} . '(' . $cur . '); '
 208            . join ' els',
 209               map( {
 210                "if (\$r eq '" . $reftypes{$_} ."') { "
 211                . _wrap($name, $proto, ($i + 1),
 212                               $args . $_ . '{' . $cur . '}, ',
 213                               $cr, $opts)
 214                . ' }'
 215               } split //, $p),
 216               'e { ' . $opts->{wrong_ref} . ' }'
 217    } else {
 218     $args .= $p . '{' . $cur . '}, ';
 219    }
 220   } elsif ($p =~ /[\@\%]/) {
 221    $args .= '@_[' . $i . '..$#_]';
 222   } elsif ($p =~ /\&/) {
 223    my %h = do { my $c; map { $_ => $c++ } @$cr };
 224    my $j;
 225    if (not exists $h{$i}) {
 226     push @$cr, $i;
 227     $j = $#{$cr};
 228    } else {
 229     $j = int $h{$i};
 230    }
 231    $args .= 'sub{&{$c[' . $j . ']}}, ';
 232   } elsif ($p eq '_') {
 233    $args .= '((@_ > ' . $i . ') ? ' . $cur . ' : $_), ';
 234   } else {
 235    $args .= $cur . ', ';
 236   }
 237   return _wrap($name, $proto, ($i + 1), $args, $cr, $opts);
 238  } else {
 239   $args =~ s/,\s*$//;
 240   return $name . '(' . $args . ')';
 241  }
 242 }
 243
 244 sub wrap {
 245  my ($name, $proto) = _check_name shift;
 246  croak 'Optional arguments must be passed as key => value pairs' if @_ % 2;
 247  my %opts = @_;
 248  $opts{ref}     ||= 'ref';
 249  $opts{sub}       = 1       if not exists $opts{sub} or $opts{compile};
 250  $opts{wrong_ref} = 'undef' if not defined $opts{wrong_ref};
 251  my @cr;
 252  my $call;
 253  if (defined $proto) {
 254   $call = _wrap $name, $proto, 0, '', \@cr, \%opts;
 255  } else {
 256   $call = _wrap $name, '', 0, '@_';
 257  }
 258  if (@cr) {
 259   $call = 'my @c; '
 260         . join('', map { 'push @c, $_[' . $_ . ']; ' } @cr)
 261         . $call
 262  }
 263  $call = '{ ' . $call . ' }';
 264  $call = 'sub ' . $call if $opts{sub};
 265  if ($opts{compile}) {
 266   $call = eval $call;
 267   croak $@ if $@;
 268  }
 269  return $call;
 270 }
 271
 272 =head1 EXPORT
 273
 274 The functions L</flatten>, L</recall> and L</wrap> are only exported on request, either by providing their name or by the C<':funcs'> and C<':all'> tags.
 275
 276 =cut
 277
 278 use base qw/Exporter/;
 279
 280 use vars qw/@EXPORT @EXPORT_OK %EXPORT_TAGS/;
 281
 282 @EXPORT             = ();
 283 %EXPORT_TAGS        = (
 284  'funcs' =>  [ qw/flatten recall wrap/ ]
 285 );
 286 @EXPORT_OK          = map { @$_ } values %EXPORT_TAGS;
 287 $EXPORT_TAGS{'all'} = [ @EXPORT_OK ];
 288
 289 =head1 DEPENDENCIES
 290
 291 L<Carp>, L<Exporter> (core modules since perl 5), L<Scalar::Util> (since 5.7.3).
 292
 293 =head1 AUTHOR
 294
 295 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 296
 297 You can contact me by mail or on C<irc.perl.org> (vincent).
 298
 299 =head1 BUGS
 300
 301 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.
 302
 303 =head1 SUPPORT
 304
 305 You can find documentation for this module with the perldoc command.
 306
 307     perldoc Sub::Prototype::Util
 308
 309 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Sub-Prototype-Util>.
 310
 311 =head1 COPYRIGHT & LICENSE
 312
 313 Copyright 2008 Vincent Pit, all rights reserved.
 314
 315 This program is free software; you can redistribute it and/or modify it
 316 under the same terms as Perl itself.
 317
 318 =cut
 319
 320 1; # End of Sub::Prototype::Util