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