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