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 *
 153
 154 C<< ref => $func >>
 155
 156 Specifies the function used in the generated code to test the reference type of scalars.
 157 Defaults to C<'ref'>.
 158 You may also want to use L<Scalar::Util/reftype>.
 159
 160 =item *
 161
 162 C<< wrong_ref => $code >>
 163
 164 The code executed when a reference of incorrect type is encountered.
 165 The result of this snippet is also the result of the generated code, hence it defaults to C<'undef'>.
 166 It's a good place to C<croak> or C<die> too.
 167
 168 =item *
 169
 170 C<< sub => $bool >>
 171
 172 Encloses the code into a C<sub { }> block.
 173 Default is true.
 174
 175 =item *
 176
 177 C<< compile => $bool >>
 178
 179 Makes L</wrap> compile the code generated and return the resulting code reference.
 180 Be careful that in this case C<ref> must be a fully qualified function name.
 181 Defaults to true, but turned off when C<sub> is false.
 182
 183 =back
 184
 185 For example, this allows you to recall into C<CORE::grep> and C<CORE::map> by using the C<\&@> prototype :
 186
 187     my $grep = wrap { 'CORE::grep' => '\&@' };
 188     # the prototypes are intentionally different
 189     sub mygrep (&@) { $grep->(@_) }
 190
 191 =cut
 192
 193 sub _wrap {
 194  my ($name, $proto, $i, $args, $coderefs, $opts) = @_;
 195
 196  while ($proto =~ s/(\\?)(\[[^\]]+\]|[^\];])//) {
 197   my ($ref, $sigil) = ($1, $2);
 198   $sigil = $1 if $sigil =~ /^\[([^\]]+)\]/;
 199
 200   my $cur = "\$_[$i]";
 201
 202   if ($ref) {
 203    if (length $sigil > 1) {
 204     my $code     = "my \$r = $opts->{ref}($cur); ";
 205     my @branches = map {
 206      my $subcall = _wrap(
 207       $name, $proto, ($i + 1), $args . "$_\{$cur}, ", $coderefs, $opts
 208      );
 209      "if (\$r eq '$reftypes{$_}') { $subcall }";
 210     } split //, $sigil;
 211     $code .= join ' els', @branches, "e { $opts->{wrong_ref} }";
 212     return $code;
 213    } else {
 214     $args .= "$sigil\{$cur}, ";
 215    }
 216   } elsif ($sigil =~ /[\@\%]/) {
 217    $args .= '@_[' . $i . '..$#_]';
 218   } elsif ($sigil =~ /\&/) {
 219    my %h = do { my $c; map { $_ => $c++ } @$coderefs };
 220    my $j;
 221    if (exists $h{$i}) {
 222     $j = int $h{$i};
 223    } else {
 224     push @$coderefs, $i;
 225     $j = $#{$coderefs};
 226    }
 227    $args .= "sub{&{\$c[$j]}}, ";
 228   } elsif ($sigil eq '_') {
 229    $args .= "((\@_ > $i) ? $cur : \$_), ";
 230   } else {
 231    $args .= "$cur, ";
 232   }
 233  } continue {
 234   ++$i;
 235  }
 236
 237  $args =~ s/,\s*$//;
 238
 239  return "$name($args)";
 240 }
 241
 242 sub _check_name {
 243  my ($name) = @_;
 244  croak 'No subroutine specified' unless $name;
 245
 246  my $proto;
 247  my $r = ref $name;
 248  if (!$r) {
 249   $proto = prototype $name;
 250  } elsif ($r eq 'HASH') {
 251   croak 'Forced prototype hash reference must contain exactly one key/value pair' unless keys %$name == 1;
 252   ($name, $proto) = %$name;
 253  } else {
 254   croak 'Unhandled ' . $r . ' reference as first argument';
 255  }
 256
 257  $name =~ s/^\s+//;
 258  $name =~ s/[\s\$\@\%\*\&;].*//;
 259
 260  return $name, $proto;
 261 }
 262
 263 sub wrap {
 264  my ($name, $proto) = _check_name shift;
 265  croak 'Optional arguments must be passed as key => value pairs' if @_ % 2;
 266  my %opts = @_;
 267
 268  $opts{ref}     ||= 'ref';
 269  $opts{sub}       = 1       unless defined $opts{sub};
 270  $opts{compile}   = 1       if     not defined $opts{compile} and $opts{sub};
 271  $opts{wrong_ref} = 'undef' unless defined $opts{wrong_ref};
 272
 273  my @coderefs;
 274  my $call;
 275  if (defined $proto) {
 276   $call = _wrap $name, $proto, 0, '', \@coderefs, \%opts;
 277  } else {
 278   $call = _wrap $name, '', 0, '@_';
 279  }
 280
 281  if (@coderefs) {
 282   my $decls = @coderefs > 1 ? 'my @c = @_[' . join(', ', @coderefs) . ']; '
 283                             : 'my @c = ($_[' . $coderefs[0] . ']); ';
 284   $call = $decls . $call;
 285  }
 286
 287  $call = "{ $call }";
 288  $call = "sub $call" if $opts{sub};
 289
 290  if ($opts{compile}) {
 291   my $err;
 292   {
 293    local $@;
 294    $call = eval $call;
 295    $err  = $@;
 296   }
 297   croak _clean_msg $err if $err;
 298  }
 299
 300  return $call;
 301 }
 302
 303 =head2 C<recall>
 304
 305     my @res = recall($name, @args);
 306     my @res = recall({ $name => $proto }, @args);
 307
 308 Calls the function C<$name> with the prototyped argument list C<@args>.
 309 That is, C<@args> should be what C<@_> is when you call a subroutine with C<$name> as prototype.
 310 You can still force the prototype by passing C<< { $name => $proto } >> as the first argument.
 311
 312     my $a = [ ];
 313     recall { 'CORE::push' => '\@$' }, $a, 1, 2, 3; # $a just contains 1
 314
 315 It's implemented in terms of L</wrap>, and hence calls C<eval> at each run.
 316 If you plan to recall several times, consider using L</wrap> instead.
 317
 318 =cut
 319
 320 sub recall;
 321
 322 BEGIN {
 323  my $safe_wrap = sub {
 324   my $name = shift;
 325
 326   my ($wrap, $err);
 327   {
 328    local $@;
 329    $wrap = eval { wrap $name };
 330    $err  = $@;
 331   }
 332
 333   $wrap, $err;
 334  };
 335
 336  if ("$]" == 5.008) {
 337   # goto tends to crash a lot on perl 5.8.0
 338   *recall = sub {
 339    my ($wrap, $err) = $safe_wrap->(shift);
 340    croak _clean_msg $err if $err;
 341    $wrap->(@_)
 342   }
 343  } else {
 344   *recall = sub {
 345    my ($wrap, $err) = $safe_wrap->(shift);
 346    croak _clean_msg $err if $err;
 347    goto $wrap;
 348   }
 349  }
 350 }
 351
 352 =head1 EXPORT
 353
 354 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.
 355
 356 =cut
 357
 358 use base qw<Exporter>;
 359
 360 use vars qw<@EXPORT @EXPORT_OK %EXPORT_TAGS>;
 361
 362 @EXPORT             = ();
 363 %EXPORT_TAGS        = (
 364  'funcs' =>  [ qw<flatten wrap recall> ]
 365 );
 366 @EXPORT_OK          = map { @$_ } values %EXPORT_TAGS;
 367 $EXPORT_TAGS{'all'} = [ @EXPORT_OK ];
 368
 369 =head1 DEPENDENCIES
 370
 371 L<Carp>, L<Exporter> (core modules since perl 5), L<Scalar::Util> (since 5.7.3).
 372
 373 =head1 AUTHOR
 374
 375 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 376
 377 You can contact me by mail or on C<irc.perl.org> (vincent).
 378
 379 =head1 BUGS
 380
 381 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>.
 382 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 383
 384 =head1 SUPPORT
 385
 386 You can find documentation for this module with the perldoc command.
 387
 388     perldoc Sub::Prototype::Util
 389
 390 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Sub-Prototype-Util>.
 391
 392 =head1 COPYRIGHT & LICENSE
 393
 394 Copyright 2008,2009,2010,2011 Vincent Pit, all rights reserved.
 395
 396 This program is free software; you can redistribute it and/or modify it
 397 under the same terms as Perl itself.
 398
 399 =cut
 400
 401 1; # End of Sub::Prototype::Util