lib/Sub/Prototype/Util.pm

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