File Coverage

lib/Sub/Signatures.pm

Criterion	Covered	Total	%
statement	30	47	63.8
branch	15	24	62.5
condition			n/a
subroutine	10	10	100.0
pod	0	3	0.0
total	55	84	65.4

package Sub::Signatures;
$REVISION = '$Id: Signatures.pm,v 1.3 2004/12/05 21:19:33 ovid Exp $';
$VERSION  = '0.21';

use 5.006;
use strict;
use warnings;
use Filter::Simple;

my $CALLPACK;
my %SIG;

my %METHODS;

sub import {
    my $class = shift;
    my %props = map { $_ => 1 } @_;
    ($CALLPACK) = caller;
    $METHODS{$CALLPACK} = exists $props{methods} ? 1 : 0;
    if ( $ENV{SS_DEBUG} ) {
        require Data::Dumper;
        Data::Dumper->import;
        $Data::Dumper::Indent = 1;
    }
}

my $signature = sub {
    my ( $subname, $parameters ) = @_;
    if ( 'fallback' eq $parameters ) {
        return ( "_${subname}_fallback", '', 0 );
    }
    else {
        my @args =
          map { /\s*(\S*)\s*(\$\w+)/; [ $1 || 'SCALAR', $2 ] }
          split /(?:,|=>)/ => $parameters;
        my $count = @args;
        $parameters = join ', ' => map { $_->[1] } @args;
        return ( "__${subname}_$count", $parameters, scalar @args );
    }
};

my $make_subs = sub {
    while ( my ( $pack, $subs ) = each %SIG ) {
        while ( my ( $sub, $counts ) = each %$subs ) {
            my @build =
              sort { $a->[1] cmp $b->[1] }
              map { [ $_ => $counts->{$_} ] } keys %$counts;
            foreach my $item (@build) {
                my ( $count, $target ) = @$item;
                next if 0 <= index +( $subs->{$sub}{body} || '' ), $target;
                next if 'body' eq $count;
                $subs->{$sub}{body} ||= '';
                $subs->{$sub}{body} .= $target =~ /_fallback$/
                  ? "    goto \&$target;\n"
                  : "    goto \&$target if $count == \@_;\n";
            }
        }
    }
    print Dumper(%SIG) if $ENV{SS_DEBUG};
};

my $install_subs = sub {
    while ( my ( $pack, $subs ) = each %SIG ) {
        foreach my $sub ( keys %$subs ) {
            my $body = $subs->{$sub}{body};
            my $type = $METHODS{$pack} ? 'method' : 'sub';
            unless ( $body =~ /_fallback;/ ) {
                $body .= <<"                END_BODY";
    # if we got to here, there was no $type to dispatch to
    require Carp;
    shift if 'method' eq '$type';
    my \$types = join ', ' => map { ref \$_ || 'SCALAR' } \@_;
    Carp::croak "Could not find a $type matching your signature: $sub(\$types)";
                END_BODY
            }
            no warnings 'redefine';
            my $installed_sub = "package $pack;\nsub $sub {\n$body}";
            eval $installed_sub;
            warn
"Installing &${pack}::$sub\n----------\n$installed_sub\n----------\n"
              if !$@ && $ENV{SS_DEBUG};
            die
"Failed to install &${pack}::$sub\n----------\n$installed_sub\n----------\nReason:  $@"
              if $@;
        }
    }
};

# each regex can capture itself!
my $sub_name_re   = qr/([_[:alpha:]][[:word:]]*)/;
my $parameters_re = qr/\(([^)]+)\)/;
FILTER {
    warn "Calling package:  $CALLPACK ****" if $ENV{SS_DEBUG};
    while (/(sub\s+$sub_name_re?\s*$parameters_re[^{]*\{)/) {
        my ( $sub_with_sig, $oldname, $parameters ) = ( $1, $2, $3 );

        # the following line doesn't work.  For some reason, using prototypes
        # with this module causes an infinite while loop here.
        # I'm probably overlooking something really obvious.
        # next if $parameters =~ /^\s*[\\\$@%*;\[\]]*\s*$/; # ignore prototypes

        my ( $newname, $newparams, $count );
        if ($oldname) {

            # named sub
            ( $newname, $newparams, $count ) =
              $signature->( $oldname, $parameters );
            if (   exists $SIG{$CALLPACK}{$oldname}
                && exists $SIG{$CALLPACK}{$oldname}{$count} )
            {
                my $args = $newname;
                $args =~ s/^_\w+_//;
                $args =~ s/_/, /g;

                # how do I get the line number?
                die "$oldname($args) redefined in package '$CALLPACK'";
            }
            $SIG{$CALLPACK}{$oldname}{$count} = $newname;
        }
        else {

            # anonymous sub
            $newname   = '';
            $newparams = $parameters;
        }
        if ($newparams) {
            s/\Q$sub_with_sig\E/sub $newname \{ my ($newparams) = \@_;/;
        }
        else {
            s/\Q$sub_with_sig\E/sub $newname \{/;
        }
    }
    $make_subs->();
    $install_subs->();
    print $_ if $ENV{SS_DEBUG};
};

1;

__END__