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