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