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.05
  16
  17 =cut
  18
  19 use vars qw/$VERSION/;
  20
  21 $VERSION = '0.05';
  22
  23 =head1 SYNOPSIS
  24
  25     use Sub::Prototype::Util qw/flatten 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
  33 =head1 DESCRIPTION
  34
  35 Prototypes are evil, but sometimes you just have to bear with them, especially when messing with core functions. This module provides several utilities aimed at facilitating "overloading" of prototyped functions.
  36
  37 They all handle C<5.10>'s C<_> prototype.
  38
  39 =head1 FUNCTIONS
  40
  41 =cut
  42
  43 my %sigils = qw/SCALAR $ ARRAY @ HASH % GLOB * CODE &/;
  44
  45 sub _check_ref {
  46  my ($a, $p) = @_;
  47  my $r;
  48  if (!defined $a || !defined($r = reftype $a)) { # not defined or plain scalar
  49   croak 'Got ' . ((defined $a) ? 'a plain scalar' : 'undef')
  50                . ' where a reference was expected';
  51  }
  52  croak 'Unexpected ' . $r . ' reference' unless exists $sigils{$r}
  53                                             and $p =~ /\Q$sigils{$r}\E/;
  54  return $r;
  55 }
  56
  57 =head2 C<flatten $proto, @args>
  58
  59 Flattens the array C<@args> according to the prototype C<$proto>. 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.
  60
  61 =cut
  62
  63 sub flatten {
  64  my $proto = shift;
  65  return @_ unless defined $proto;
  66  my @args;
  67  while ($proto =~ /(\\?)(\[[^\]]+\]|[^\];])/g) {
  68   my $p = $2;
  69   if ($1) {
  70    my $a = shift;
  71    my $r = _check_ref $a, $p;
  72    my %deref = (
  73     SCALAR => sub { push @args, $$a },
  74     ARRAY  => sub { push @args, @$a },
  75     HASH   => sub { push @args, %$a },
  76     GLOB   => sub { push @args, *$a },
  77     CODE   => sub { push @args, &$a }
  78    );
  79    $deref{$r}->();
  80   } elsif ($p =~ /[\@\%]/) {
  81    push @args, @_;
  82    last;
  83   } elsif ($p eq '_' && @_ == 0) {
  84    push @args, $_;
  85   } else {
  86    push @args, shift;
  87   }
  88  }
  89  return @args;
  90 }
  91
  92 =head2 C<recall $name, @args>
  93
  94 Calls the function C<$name> with the prototyped argument list C<@args>. That is, C<@args> should be what C<@_> is when you define a subroutine with the same prototype as C<$name>. For example,
  95
  96     my $a = [ ];
  97     recall 'CORE::push', $a, 1, 2, 3;
  98
  99 will call C<push @$a, 1, 2, 3> and so fill the arrayref C<$a> with C<1, 2, 3>. This is especially needed for core functions because you can't C<goto> into them.
 100
 101 You can also force the use of a specific prototype. 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.
 102
 103     recall { 'CORE::push' => '\@$' }, $a, 1, 2, 3; # will only push 1
 104
 105 This allows you to recall into C<CORE::grep> and C<CORE::map> by using the C<\&@> prototype :
 106
 107     sub mygrep (&@) { recall { 'CORE::grep' => '\&@' }, @_ } # the prototypes are intentionally different
 108
 109 =cut
 110
 111 sub recall {
 112  my $name = shift;
 113  croak 'No subroutine specified' unless $name;
 114  my $proto;
 115  my $r = ref $name;
 116  if ($r eq 'HASH') {
 117   croak 'Forced prototype hash reference must contain exactly one key/value pair' unless keys %$name == 1;
 118   ($name, $proto) = %$name;
 119  } elsif (length $r) {
 120   croak 'Unhandled ' . $r . ' reference as first argument';
 121  }
 122  $name =~ s/^\s+//;
 123  $name =~ s/[\s\$\@\%\*\&;].*//;
 124  $proto = prototype $name unless $proto;
 125  my $call = $name . '(';
 126  my @cr;
 127  if (defined $proto) {
 128   my $i = 0;
 129   while ($proto =~ /(\\?)(\[[^\]]+\]|[^\];])/g) {
 130    my $p = $2;
 131    if ($1) {
 132     my $r = _check_ref $_[$i], $p;
 133     $call .= $sigils{$r} . '{$_[' . $i . ']},';
 134    } elsif ($p =~ /[\@\%]/) {
 135     $call .= '@_[' . $i . '..' . (@_ - 1) . ']';
 136     last;
 137    } elsif ($p =~ /\&/) {
 138     push @cr, $_[$i];
 139     $call .= 'sub{&{$cr[' . $#cr . ']}},';
 140    } elsif ($p eq '_' && $i >= @_) {
 141     $call .= '$_,';
 142    } else {
 143     $call .= '$_[' . $i . '],';
 144    }
 145    ++$i;
 146   }
 147   $call =~ s/,$//;
 148  } else {
 149   $call .= join ',', map '$_[' . $_ . ']', 0 .. @_ - 1;
 150  }
 151  $call .= ');';
 152  my @ret = eval $call;
 153  croak $@ if $@;
 154  return @ret;
 155 }
 156
 157 =head1 EXPORT
 158
 159 The functions L</flatten> and L</recall> are only exported on request, either by providing their name or by the C<':funcs'> and C<':all'> tags.
 160
 161 =cut
 162
 163 use base qw/Exporter/;
 164
 165 use vars qw/@EXPORT @EXPORT_OK %EXPORT_TAGS/;
 166
 167 @EXPORT             = ();
 168 %EXPORT_TAGS        = (
 169  'funcs' =>  [ qw/flatten recall/ ]
 170 );
 171 @EXPORT_OK          = map { @$_ } values %EXPORT_TAGS;
 172 $EXPORT_TAGS{'all'} = [ @EXPORT_OK ];
 173
 174 =head1 DEPENDENCIES
 175
 176 L<Carp>, L<Exporter> (core modules since perl 5), L<Scalar::Util> (since 5.7.3).
 177
 178 =head1 AUTHOR
 179
 180 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 181
 182 You can contact me by mail or on #perl @ FreeNode (vincent or Prof_Vince).
 183
 184 =head1 BUGS
 185
 186 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>.  I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 187
 188 =head1 SUPPORT
 189
 190 You can find documentation for this module with the perldoc command.
 191
 192     perldoc Sub::Prototype::Util
 193
 194 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Sub-Prototype-Util>.
 195
 196 =head1 COPYRIGHT & LICENSE
 197
 198 Copyright 2008 Vincent Pit, all rights reserved.
 199
 200 This program is free software; you can redistribute it and/or modify it
 201 under the same terms as Perl itself.
 202
 203 =cut
 204
 205 1; # End of Sub::Prototype::Util