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