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