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