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.02
  16
  17 =cut
  18
  19 our $VERSION = '0.02';
  20
  21 =head1 SYNOPSIS
  22
  23     use Sub::Prototype::Util qw/flatten recall/;
  24
  25     my @a = qw/a b c/;
  26     my @args = ( \@a, 1, { d => 2 }, undef, 3 );
  27
  28     my @flat = flatten '\@$;$', @args; # ('a', 'b', 'c', 1, { d => 2 })
  29     recall 'CORE::push', @args; # @a contains 'a', 'b', 'c', 1, { d => 2 }, undef, 3
  30
  31 =head1 DESCRIPTION
  32
  33 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.
  34
  35 They all handle C<5.10>'s C<_> prototype.
  36
  37 =head1 FUNCTIONS
  38
  39 =cut
  40
  41 my %sigils = qw/SCALAR $ ARRAY @ HASH % GLOB * CODE &/;
  42
  43 sub _check_ref {
  44  my ($a, $p) = @_;
  45  my $r;
  46  if (!defined $a || !defined($r = reftype $a)) { # not defined or plain scalar
  47   croak 'Got ' . ((defined $a) ? 'a plain scalar' : 'undef')
  48                . ' where a reference was expected';
  49  }
  50  croak 'Unexpected ' . $r . ' reference' unless exists $sigils{$r}
  51                                             and $p =~ /\Q$sigils{$r}\E/;
  52  return $r;
  53 }
  54
  55 =head2 C<flatten $proto, @args>
  56
  57 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.
  58
  59 =cut
  60
  61 sub flatten {
  62  my $proto = shift;
  63  return @_ unless defined $proto;
  64  my @args;
  65  while ($proto =~ /(\\?)(\[[^\]]+\]|[^\];])/g) {
  66   my $p = $2;
  67   if ($1) {
  68    my $a = shift;
  69    my $r = _check_ref $a, $p;
  70    my %deref = (
  71     SCALAR => sub { push @args, $$a },
  72     ARRAY  => sub { push @args, @$a },
  73     HASH   => sub { push @args, %$a },
  74     GLOB   => sub { push @args, *$a },
  75     CODE   => sub { push @args, &$a }
  76    );
  77    $deref{$r}->();
  78   } elsif ($p =~ /[\@\%]/) {
  79    push @args, @_;
  80    last;
  81   } elsif ($p eq '_') {
  82    push @args, $_;
  83   } else {
  84    push @args, shift;
  85   }
  86  }
  87  return @args;
  88 }
  89
  90 =head2 C<recall $name, @args>
  91
  92 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,
  93
  94     my $a = [ ];
  95     recall 'CORE::push', $a, 1, 2, 3;
  96
  97 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.
  98
  99 =cut
 100
 101 sub recall {
 102  my ($name, @a) = @_;
 103  croak 'Wrong subroutine name' unless $name;
 104  $name =~ s/^\s+//;
 105  $name =~ s/[\s\$\@\%\*\&;].*//;
 106  my $proto = prototype $name;
 107  my @args;
 108  if (defined $proto) {
 109   my $i = 0;
 110   while ($proto =~ /(\\?)(\[[^\]]+\]|[^\];])/g) {
 111    my $p = $2;
 112    if ($1) {
 113     my $r = _check_ref $a[$i], $p;
 114     push @args, join '', $sigils{$r}, '{$a[', $i, ']}';
 115    } elsif ($p =~ /[\@\%]/) {
 116     push @args, join '', '@a[', $i, '..', (@a - 1), ']';
 117     last;
 118    } elsif ($p =~ /\&/) {
 119     push @args, 'sub{&{$a[' . $i . ']}}';
 120    } elsif ($p eq '_') {
 121     push @args, '$_';
 122    } else {
 123     push @args, '$a[' . $i . ']';
 124    }
 125    ++$i;
 126   }
 127  } else {
 128   @args = map '$a[' . $_ . ']', 0 .. @a - 1;
 129  }
 130  my @ret = eval $name . '(' . join(',', @args) . ');';
 131  croak $@ if $@;
 132  return @ret;
 133 }
 134
 135 =head1 EXPORT
 136
 137 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.
 138
 139 =cut
 140
 141 use base qw/Exporter/;
 142
 143 our @EXPORT         = ();
 144 our %EXPORT_TAGS    = (
 145  'funcs' =>  [ qw/flatten recall/ ]
 146 );
 147 our @EXPORT_OK      = map { @$_ } values %EXPORT_TAGS;
 148 $EXPORT_TAGS{'all'} = [ @EXPORT_OK ];
 149
 150 =head1 DEPENDENCIES
 151
 152 L<Carp>, L<Exporter> (core modules since perl 5), L<Scalar::Util> (since 5.7.3).
 153
 154 =head1 AUTHOR
 155
 156 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 157
 158 You can contact me by mail or on #perl @ FreeNode (vincent or Prof_Vince).
 159
 160 =head1 BUGS
 161
 162 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.
 163
 164 =head1 SUPPORT
 165
 166 You can find documentation for this module with the perldoc command.
 167
 168     perldoc Sub::Prototype::Util
 169
 170 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Sub-Prototype-Util>.
 171
 172 =head1 COPYRIGHT & LICENSE
 173
 174 Copyright 2008 Vincent Pit, all rights reserved.
 175
 176 This program is free software; you can redistribute it and/or modify it
 177 under the same terms as Perl itself.
 178
 179 =cut
 180
 181 1; # End of Sub::Prototype::Util