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