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.04
  16
  17 =cut
  18
  19 use vars qw/$VERSION/;
  20
  21 $VERSION = '0.04';
  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 =cut
 102
 103 sub recall {
 104  my $name = shift;
 105  croak 'Wrong subroutine name' unless $name;
 106  $name =~ s/^\s+//;
 107  $name =~ s/[\s\$\@\%\*\&;].*//;
 108  my $proto = prototype $name;
 109  my @args;
 110  my @cr;
 111  if (defined $proto) {
 112   my $i = 0;
 113   while ($proto =~ /(\\?)(\[[^\]]+\]|[^\];])/g) {
 114    my $p = $2;
 115    if ($1) {
 116     my $r = _check_ref $_[$i], $p;
 117     push @args, join '', $sigils{$r}, '{$_[', $i, ']}';
 118    } elsif ($p =~ /[\@\%]/) {
 119     push @args, join '', '@_[', $i, '..', (@_ - 1), ']';
 120     last;
 121    } elsif ($p =~ /\&/) {
 122     push @cr, $_[$i];
 123     push @args, 'sub{&{$cr[' . $#cr . ']}}';
 124    } elsif ($p eq '_' && $i >= @_) {
 125     push @args, '$_';
 126    } else {
 127     push @args, '$_[' . $i . ']';
 128    }
 129    ++$i;
 130   }
 131  } else {
 132   @args = map '$_[' . $_ . ']', 0 .. @_ - 1;
 133  }
 134  my @ret = eval $name . '(' . join(',', @args) . ');';
 135  croak $@ if $@;
 136  return @ret;
 137 }
 138
 139 =head1 EXPORT
 140
 141 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.
 142
 143 =cut
 144
 145 use base qw/Exporter/;
 146
 147 use vars qw/@EXPORT @EXPORT_OK %EXPORT_TAGS/;
 148
 149 @EXPORT             = ();
 150 %EXPORT_TAGS        = (
 151  'funcs' =>  [ qw/flatten recall/ ]
 152 );
 153 @EXPORT_OK          = map { @$_ } values %EXPORT_TAGS;
 154 $EXPORT_TAGS{'all'} = [ @EXPORT_OK ];
 155
 156 =head1 DEPENDENCIES
 157
 158 L<Carp>, L<Exporter> (core modules since perl 5), L<Scalar::Util> (since 5.7.3).
 159
 160 =head1 AUTHOR
 161
 162 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 163
 164 You can contact me by mail or on #perl @ FreeNode (vincent or Prof_Vince).
 165
 166 =head1 BUGS
 167
 168 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.
 169
 170 =head1 SUPPORT
 171
 172 You can find documentation for this module with the perldoc command.
 173
 174     perldoc Sub::Prototype::Util
 175
 176 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Sub-Prototype-Util>.
 177
 178 =head1 COPYRIGHT & LICENSE
 179
 180 Copyright 2008 Vincent Pit, all rights reserved.
 181
 182 This program is free software; you can redistribute it and/or modify it
 183 under the same terms as Perl itself.
 184
 185 =cut
 186
 187 1; # End of Sub::Prototype::Util