lib/Sub/Prototype/Util.pm

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