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

    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)

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

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

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

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

    perldoc Sub::Prototype::Util

package Sub::Prototype::Util;

use 5.006;

use strict;
use warnings;

use Carp qw/croak/;
use Scalar::Util qw/reftype/;

use vars qw/$VERSION/;

$VERSION = '0.09';

my %sigils = qw/SCALAR $ ARRAY @ HASH % GLOB * CODE &/;
my %reftypes = reverse %sigils;

sub _check_ref {
 my ($a, $p) = @_;
 my $r;
 if (!defined $a || !defined($r = reftype $a)) { # not defined or plain scalar
  croak 'Got ' . ((defined $a) ? 'a plain scalar' : 'undef')
               . ' where a reference was expected';
 }
 croak 'Unexpected ' . $r . ' reference' unless exists $sigils{$r}
                                            and $p =~ /\Q$sigils{$r}\E/;
 return $r;
}

sub _clean_msg {
 my ($msg) = @_;
 $msg =~ s/(?:\s+called)?\s+at\s+.*$//s;
 return $msg;
}

sub flatten {
 my $proto = shift;
 return @_ unless defined $proto;
 my @args; 
 while ($proto =~ /(\\?)(\[[^\]]+\]|[^\];])/g) {
  my $p = $2;
  if ($1) {
   my $a = shift;
   my $r = _check_ref $a, $p;
   push @args, $r eq 'SCALAR'
               ? $$a
               : ($r eq 'ARRAY'
                  ? @$a
                  : ($r eq 'HASH'
                     ? %$a
                     : ($r eq 'GLOB'
                        ? *$a
                        : &$a # _check_ref ensures this must be a code ref
                       )
                    )
                 );
  } elsif ($p =~ /[\@\%]/) {
   push @args, @_;
   last;
  } else {
   croak 'Not enough arguments to match this prototype' unless @_;
   push @args, shift;
  }
 }
 return @args;
}

sub _wrap {
 my ($name, $proto, $i, $args, $cr, $opts) = @_;
 while ($proto =~ s/(\\?)(\[[^\]]+\]|[^\];])//) {
  my ($ref, $p) = ($1, $2);
  $p = $1 if $p =~ /^\[([^\]]+)\]/;
  my $cur = '$_[' . $i . ']';
  if ($ref) {
   if (length $p > 1) {
    return 'my $r = ' . $opts->{ref} . '(' . $cur . '); ' 
           . join ' els',
              map( {
               "if (\$r eq '" . $reftypes{$_} ."') { "
               . _wrap($name, $proto, ($i + 1),
                              $args . $_ . '{' . $cur . '}, ',
                              $cr, $opts)
               . ' }'
              } split //, $p),
              'e { ' . $opts->{wrong_ref} . ' }'
   } else {
    $args .= $p . '{' . $cur . '}, ';
   }
  } elsif ($p =~ /[\@\%]/) {
   $args .= '@_[' . $i . '..$#_]';
  } elsif ($p =~ /\&/) {
   my %h = do { my $c; map { $_ => $c++ } @$cr };
   my $j;
   if (not exists $h{$i}) {
    push @$cr, $i;
    $j = $#{$cr};
   } else {
    $j = int $h{$i};
   }
   $args .= 'sub{&{$c[' . $j . ']}}, ';
  } elsif ($p eq '_') {
   $args .= '((@_ > ' . $i . ') ? ' . $cur . ' : $_), ';
  } else {
   $args .= $cur . ', ';
  }
  ++$i;
 }
 $args =~ s/,\s*$//;
 return $name . '(' . $args . ')';
}

sub _check_name {
 my $name = $_[0];
 croak 'No subroutine specified' unless $name;
 my $proto;
 my $r = ref $name;
 if (!$r) {
  $proto = prototype $name;
 } elsif ($r eq 'HASH') {
  croak 'Forced prototype hash reference must contain exactly one key/value pair' unless keys %$name == 1;
  ($name, $proto) = %$name;
 } else {
  croak 'Unhandled ' . $r . ' reference as first argument';
 }
 $name =~ s/^\s+//;
 $name =~ s/[\s\$\@\%\*\&;].*//;
 return $name, $proto;
}

sub wrap {
 my ($name, $proto) = _check_name shift;
 croak 'Optional arguments must be passed as key => value pairs' if @_ % 2;
 my %opts = @_;
 $opts{ref}     ||= 'ref';
 $opts{sub}       = 1       if not defined $opts{sub};
 $opts{compile}   = 1       if not defined $opts{compile} and $opts{sub};
 $opts{wrong_ref} = 'undef' if not defined $opts{wrong_ref};
 my @cr;
 my $call;
 if (defined $proto) {
  $call = _wrap $name, $proto, 0, '', \@cr, \%opts;
 } else {
  $call = _wrap $name, '', 0, '@_';
 }
 if (@cr) {
  $call = 'my @c; '
        . join('', map { 'push @c, $_[' . $_ . ']; ' } @cr)
        . $call
 }
 $call = '{ ' . $call . ' }';
 $call = 'sub ' . $call if $opts{sub};
 if ($opts{compile}) {
  $call = eval $call;
  croak _clean_msg $@ if $@;
 }
 return $call;
}

sub recall {
 my $wrap = eval { wrap shift };
 croak _clean_msg $@ if $@;
 return $wrap->(@_);
}

use base qw/Exporter/;

use vars qw/@EXPORT @EXPORT_OK %EXPORT_TAGS/;

@EXPORT             = ();
%EXPORT_TAGS        = (
 'funcs' =>  [ qw/flatten wrap recall/ ]
);
@EXPORT_OK          = map { @$_ } values %EXPORT_TAGS;
$EXPORT_TAGS{'all'} = [ @EXPORT_OK ];

1; # End of Sub::Prototype::Util