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', 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<wrap $name, %opts>
  96
  97 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>.
  98
  99     my $a = [ 0 .. 2 ];
 100     my $push = wrap 'CORE::push', compile => 1;
 101     $push->($a, 3, 4); # returns 3 + 2 = 5 and $a now contains 0 .. 4
 102
 103 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.
 104
 105     my $push = wrap { 'CORE::push' => '\@$' }, compile => 1; # only pushes 1 arg
 106
 107 Others arguments are seen as key / value pairs that are meant to tune the code generated by L</wrap>. Valid keys are :
 108
 109 =over 4
 110
 111 =item C<< ref => $func >>
 112
 113 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>.
 114
 115 =item C<< wrong_ref => $code >>
 116
 117 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.
 118
 119 =item C<< sub => $bool >>
 120
 121 Encloses the code into a C<sub { }> block. Default is true.
 122
 123 =item C<< compile => $bool >>
 124
 125 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.
 126
 127 =back
 128
 129 For example, this allows you to recall into C<CORE::grep> and C<CORE::map> by using the C<\&@> prototype :
 130
 131     my $grep = wrap { 'CORE::grep' => '\&@' }, compile => 1;
 132     sub mygrep (&@) { $grep->(@_) } # the prototypes are intentionally different
 133
 134 =cut
 135
 136 sub _wrap {
 137  my ($name, $proto, $i, $args, $cr, $opts) = @_;
 138  if ($proto =~ /(\\?)(\[[^\]]+\]|[^\];])(.*)/g) {
 139   my ($ref, $p) = ($1, $2);
 140   $proto = $3;
 141   $p = $1 if $p =~ /^\[([^\]]+)\]/;
 142   my $cur = '$_[' . $i . ']';
 143   if ($ref) {
 144    if (length $p > 1) {
 145     return 'my $r = ' . $opts->{ref} . '(' . $cur . '); '
 146            . join ' els',
 147               map( {
 148                "if (\$r eq '" . $reftypes{$_} ."') { "
 149                . _wrap($name, $proto, ($i + 1),
 150                               $args . $_ . '{' . $cur . '}, ',
 151                               $cr, $opts)
 152                . ' }'
 153               } split //, $p),
 154               'e { ' . $opts->{wrong_ref} . ' }'
 155    } else {
 156     $args .= $p . '{' . $cur . '}, ';
 157    }
 158   } elsif ($p =~ /[\@\%]/) {
 159    $args .= '@_[' . $i . '..$#_]';
 160   } elsif ($p =~ /\&/) {
 161    my %h = do { my $c; map { $_ => $c++ } @$cr };
 162    my $j;
 163    if (not exists $h{$i}) {
 164     push @$cr, $i;
 165     $j = $#{$cr};
 166    } else {
 167     $j = int $h{$i};
 168    }
 169    $args .= 'sub{&{$c[' . $j . ']}}, ';
 170   } elsif ($p eq '_') {
 171    $args .= '((@_ > ' . $i . ') ? ' . $cur . ' : $_), ';
 172   } else {
 173    $args .= $cur . ', ';
 174   }
 175   return _wrap($name, $proto, ($i + 1), $args, $cr, $opts);
 176  } else {
 177   $args =~ s/,\s*$//;
 178   return $name . '(' . $args . ')';
 179  }
 180 }
 181
 182 sub _check_name {
 183  my $name = $_[0];
 184  croak 'No subroutine specified' unless $name;
 185  my $proto;
 186  my $r = ref $name;
 187  if (!$r) {
 188   $proto = prototype $name;
 189  } elsif ($r eq 'HASH') {
 190   croak 'Forced prototype hash reference must contain exactly one key/value pair' unless keys %$name == 1;
 191   ($name, $proto) = %$name;
 192  } else {
 193   croak 'Unhandled ' . $r . ' reference as first argument';
 194  }
 195  $name =~ s/^\s+//;
 196  $name =~ s/[\s\$\@\%\*\&;].*//;
 197  return $name, $proto;
 198 }
 199
 200 sub wrap {
 201  my ($name, $proto) = _check_name shift;
 202  croak 'Optional arguments must be passed as key => value pairs' if @_ % 2;
 203  my %opts = @_;
 204  $opts{ref}     ||= 'ref';
 205  $opts{sub}       = 1       if not exists $opts{sub} or $opts{compile};
 206  $opts{wrong_ref} = 'undef' if not defined $opts{wrong_ref};
 207  my @cr;
 208  my $call;
 209  if (defined $proto) {
 210   $call = _wrap $name, $proto, 0, '', \@cr, \%opts;
 211  } else {
 212   $call = _wrap $name, '', 0, '@_';
 213  }
 214  if (@cr) {
 215   $call = 'my @c; '
 216         . join('', map { 'push @c, $_[' . $_ . ']; ' } @cr)
 217         . $call
 218  }
 219  $call = '{ ' . $call . ' }';
 220  $call = 'sub ' . $call if $opts{sub};
 221  if ($opts{compile}) {
 222   $call = eval $call;
 223   croak $@ if $@;
 224  }
 225  return $call;
 226 }
 227
 228 =head2 C<recall $name, @args>
 229
 230 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.
 231
 232     my $a = [ ];
 233     recall { 'CORE::push' => '\@$' }, $a, 1, 2, 3; # $a just contains 1
 234
 235 It's implemented in terms of L</wrap>, and hence calls C<eval> at each run.
 236 If you plan to recall several times, consider using L</wrap> instead.
 237
 238 =cut
 239
 240 sub recall {
 241  my $wrap = eval { wrap shift, compile => 1 };
 242  croak $@ if $@;
 243  return $wrap->(@_);
 244 }
 245
 246 =head1 EXPORT
 247
 248 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.
 249
 250 =cut
 251
 252 use base qw/Exporter/;
 253
 254 use vars qw/@EXPORT @EXPORT_OK %EXPORT_TAGS/;
 255
 256 @EXPORT             = ();
 257 %EXPORT_TAGS        = (
 258  'funcs' =>  [ qw/flatten wrap recall/ ]
 259 );
 260 @EXPORT_OK          = map { @$_ } values %EXPORT_TAGS;
 261 $EXPORT_TAGS{'all'} = [ @EXPORT_OK ];
 262
 263 =head1 DEPENDENCIES
 264
 265 L<Carp>, L<Exporter> (core modules since perl 5), L<Scalar::Util> (since 5.7.3).
 266
 267 =head1 AUTHOR
 268
 269 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 270
 271 You can contact me by mail or on C<irc.perl.org> (vincent).
 272
 273 =head1 BUGS
 274
 275 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.
 276
 277 =head1 SUPPORT
 278
 279 You can find documentation for this module with the perldoc command.
 280
 281     perldoc Sub::Prototype::Util
 282
 283 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Sub-Prototype-Util>.
 284
 285 =head1 COPYRIGHT & LICENSE
 286
 287 Copyright 2008 Vincent Pit, all rights reserved.
 288
 289 This program is free software; you can redistribute it and/or modify it
 290 under the same terms as Perl itself.
 291
 292 =cut
 293
 294 1; # End of Sub::Prototype::Util