File Coverage

File:blib/lib/Sub/Prototype/Util.pm
Coverage:100.0%

linestmtbrancondsubpodtimecode
1package Sub::Prototype::Util;
2
3
6
6
6
162
22
9
use 5.006;
4
5
6
6
6
21
12
34
use strict;
6
6
6
6
22
9
23
use warnings;
7
8
6
6
6
24
10
36
use Carp qw/croak/;
9
6
6
6
26
9
31
use Scalar::Util qw/reftype/;
10
11 - 19
=head1 NAME

Sub::Prototype::Util - Prototype-related utility routines.

=head1 VERSION

Version 0.09

=cut
20
21
6
6
6
27
7
28
use vars qw/$VERSION/;
22
23$VERSION = '0.09';
24
25 - 46
=head1 SYNOPSIS

    use Sub::Prototype::Util qw/flatten wrap recall/;

    my @a = qw/a b c/;
    my @args = ( \@a, 1, { d => 2 }, undef, 3 );

    my @flat = flatten '\@$;$', @args; # ('a', 'b', 'c', 1, { d => 2 })
    recall 'CORE::push', @args; # @a contains 'a', 'b', 'c', 1, { d => 2 }, undef, 3
    my $splice = wrap 'CORE::splice';
    my @b = $splice->(\@a, 4, 2); # @a is now ('a', 'b', 'c', 1, 3) and @b is ({ d => 2 }, undef)

=head1 DESCRIPTION

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.

They all handle C<5.10>'s C<_> prototype.

=head1 FUNCTIONS

=cut
47
48my %sigils = qw/SCALAR $ ARRAY @ HASH % GLOB * CODE &/;
49my %reftypes = reverse %sigils;
50
51sub _check_ref {
52
16
35
 my ($a, $p) = @_;
53
16
22
 my $r;
54
16
85
 if (!defined $a || !defined($r = reftype $a)) { # not defined or plain scalar
55
2
8
  croak 'Got ' . ((defined $a) ? 'a plain scalar' : 'undef')
56               . ' where a reference was expected';
57 }
58
14
113
 croak 'Unexpected ' . $r . ' reference' unless exists $sigils{$r}
59                                            and $p =~ /\Q$sigils{$r}\E/;
60
12
25
 return $r;
61}
62
63sub _clean_msg {
64
9
17
 my ($msg) = @_;
65
9
101
 $msg =~ s/(?:\s+called)?\s+at\s+.*$//s;
66
9
27
 return $msg;
67}
68
69 - 75
=head2 C<flatten $proto, @args>

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.
It croaks if the arguments can't possibly match the required prototype, e.g. when a reference type is wrong or when not enough elements were provided.

=cut
76
77sub flatten {
78
27
1
321
 my $proto = shift;
79
27
59
 return @_ unless defined $proto;
80
26
32
 my @args;
81
26
105
 while ($proto =~ /(\\?)(\[[^\]]+\]|[^\];])/g) {
82
39
75
  my $p = $2;
83
39
98
  if ($1) {
84
16
26
   my $a = shift;
85
16
29
   my $r = _check_ref $a, $p;
86
12
63
   push @args, $r eq 'SCALAR'
87               ? $$a
88               : ($r eq 'ARRAY'
89                  ? @$a
90                  : ($r eq 'HASH'
91                     ? %$a
92                     : ($r eq 'GLOB'
93                        ? *$a
94                        : &$a # _check_ref ensures this must be a code ref
95                       )
96                    )
97                 );
98  } elsif ($p =~ /[\@\%]/) {
99
6
12
   push @args, @_;
100
6
8
   last;
101  } else {
102
17
36
   croak 'Not enough arguments to match this prototype' unless @_;
103
16
49
   push @args, shift;
104  }
105 }
106
21
87
 return @args;
107}
108
109 - 158
=head2 C<wrap $name, %opts>

Generates a wrapper that calls the function C<$name> with a prototyped argument list.
That is, the wrapper's arguments should be what C<@_> is when you define a subroutine with the same prototype as C<$name>.

    my $a = [ 0 .. 2 ];
    my $push = wrap 'CORE::push';
    $push->($a, 3, 4); # returns 3 + 2 = 5 and $a now contains 0 .. 4

You can 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.

    my $push = wrap { 'CORE::push' => '\@$' }; # only pushes 1 arg

Others arguments are seen as key / value pairs that are meant to tune the code generated by L</wrap>.
Valid keys are :

=over 4

=item C<< ref => $func >>

Specifies the function used in the generated code to test the reference type of scalars.
Defaults to C<'ref'>.
You may also want to use C<Scalar::Util::reftype>.

=item C<< wrong_ref => $code >>

The code executed when a reference of incorrect type is encountered.
The result of this snippet is also the result of the generated code, hence it defaults to C<'undef'>.
It's a good place to C<croak> or C<die> too.

=item C<< sub => $bool >>

Encloses the code into a C<sub { }> block.
Default is true.

=item C<< compile => $bool >>

Makes L</wrap> compile the code generated and return the resulting code reference.
Be careful that in this case C<ref> must be a fully qualified function name.
Defaults to true, but turned off when C<sub> is false.

=back

For example, this allows you to recall into C<CORE::grep> and C<CORE::map> by using the C<\&@> prototype :

    my $grep = wrap { 'CORE::grep' => '\&@' };
    sub mygrep (&@) { $grep->(@_) } # the prototypes are intentionally different

=cut
159
160sub _wrap {
161
38
97
 my ($name, $proto, $i, $args, $cr, $opts) = @_;
162
38
139
 while ($proto =~ s/(\\?)(\[[^\]]+\]|[^\];])//) {
163
45
100
  my ($ref, $p) = ($1, $2);
164
45
102
  $p = $1 if $p =~ /^\[([^\]]+)\]/;
165
45
72
  my $cur = '$_[' . $i . ']';
166
45
126
  if ($ref) {
167
17
30
   if (length $p > 1) {
168
14
50
    return 'my $r = ' . $opts->{ref} . '(' . $cur . '); '
169           . join ' els',
170              map( {
171
7
22
               "if (\$r eq '" . $reftypes{$_} ."') { "
172               . _wrap($name, $proto, ($i + 1),
173                              $args . $_ . '{' . $cur . '}, ',
174                              $cr, $opts)
175               . ' }'
176              } split //, $p),
177              'e { ' . $opts->{wrong_ref} . ' }'
178   } else {
179
10
21
    $args .= $p . '{' . $cur . '}, ';
180   }
181  } elsif ($p =~ /[\@\%]/) {
182
8
12
   $args .= '@_[' . $i . '..$#_]';
183  } elsif ($p =~ /\&/) {
184
9
9
9
13
13
10
16
30
   my %h = do { my $c; map { $_ => $c++ } @$cr };
185
9
13
   my $j;
186
9
19
   if (not exists $h{$i}) {
187
3
8
    push @$cr, $i;
188
3
3
4
7
    $j = $#{$cr};
189   } else {
190
6
8
    $j = int $h{$i};
191   }
192
9
21
   $args .= 'sub{&{$c[' . $j . ']}}, ';
193  } elsif ($p eq '_') {
194
3
7
   $args .= '((@_ > ' . $i . ') ? ' . $cur . ' : $_), ';
195  } else {
196
8
13
   $args .= $cur . ', ';
197  }
198
38
113
  ++$i;
199 }
200
31
73
 $args =~ s/,\s*$//;
201
31
100
 return $name . '(' . $args . ')';
202}
203
204sub _check_name {
205
37
56
 my $name = $_[0];
206
37
81
 croak 'No subroutine specified' unless $name;
207
33
41
 my $proto;
208
33
45
 my $r = ref $name;
209
33
73
 if (!$r) {
210
20
63
  $proto = prototype $name;
211 } elsif ($r eq 'HASH') {
212
7
23
  croak 'Forced prototype hash reference must contain exactly one key/value pair' unless keys %$name == 1;
213
5
15
  ($name, $proto) = %$name;
214 } else {
215
6
18
  croak 'Unhandled ' . $r . ' reference as first argument';
216 }
217
25
55
 $name =~ s/^\s+//;
218
25
44
 $name =~ s/[\s\$\@\%\*\&;].*//;
219
25
59
 return $name, $proto;
220}
221
222sub wrap {
223
37
1
230
 my ($name, $proto) = _check_name shift;
224
25
73
 croak 'Optional arguments must be passed as key => value pairs' if @_ % 2;
225
24
47
 my %opts = @_;
226
24
62
 $opts{ref} ||= 'ref';
227
24
59
 $opts{sub} = 1 if not defined $opts{sub};
228
24
106
 $opts{compile} = 1 if not defined $opts{compile} and $opts{sub};
229
24
58
 $opts{wrong_ref} = 'undef' if not defined $opts{wrong_ref};
230
24
27
 my @cr;
231
24
30
 my $call;
232
24
44
 if (defined $proto) {
233
19
43
  $call = _wrap $name, $proto, 0, '', \@cr, \%opts;
234 } else {
235
5
12
  $call = _wrap $name, '', 0, '@_';
236 }
237
24
56
 if (@cr) {
238
3
11
  $call = 'my @c; '
239
2
4
        . join('', map { 'push @c, $_[' . $_ . ']; ' } @cr)
240        . $call
241 }
242
24
40
 $call = '{ ' . $call . ' }';
243
24
62
 $call = 'sub ' . $call if $opts{sub};
244
24
52
 if ($opts{compile}) {
245
19
900
  $call = eval $call;
246
19
65
  croak _clean_msg $@ if $@;
247 }
248
22
61
 return $call;
249}
250
251 - 263
=head2 C<recall $name, @args>

Calls the function C<$name> with the prototyped argument list C<@args>.
That is, C<@args> should be what C<@_> is when you call a subroutine with C<$name> as prototype.
You can still force the prototype by passing C<< { $name => $proto } >> as the first argument.

    my $a = [ ];
    recall { 'CORE::push' => '\@$' }, $a, 1, 2, 3; # $a just contains 1

It's implemented in terms of L</wrap>, and hence calls C<eval> at each run.
If you plan to recall several times, consider using L</wrap> instead.

=cut
264
265sub recall {
266
20
20
1
300
42
 my $wrap = eval { wrap shift };
267
20
47
 croak _clean_msg $@ if $@;
268
13
36
 return $wrap->(@_);
269}
270
271 - 275
=head1 EXPORT

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.

=cut
276
277
6
6
6
30
12
27
use base qw/Exporter/;
278
279
6
6
6
26
10
16
use vars qw/@EXPORT @EXPORT_OK %EXPORT_TAGS/;
280
281@EXPORT = ();
282%EXPORT_TAGS = (
283 'funcs' => [ qw/flatten wrap recall/ ]
284);
285@EXPORT_OK = map { @$_ } values %EXPORT_TAGS;
286$EXPORT_TAGS{'all'} = [ @EXPORT_OK ];
287
288 - 318
=head1 DEPENDENCIES

L<Carp>, L<Exporter> (core modules since perl 5), L<Scalar::Util> (since 5.7.3).

=head1 AUTHOR

Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.

You can contact me by mail or on C<irc.perl.org> (vincent).

=head1 BUGS

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.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Sub::Prototype::Util

Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Sub-Prototype-Util>.

=head1 COPYRIGHT & LICENSE

Copyright 2008-2009 Vincent Pit, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut
319
3201; # End of Sub::Prototype::Util