File Coverage

blib/lib/Sub/Compose.pm

Criterion	Covered	Total	%
statement	67	68	98.5
branch	13	14	92.8
condition			n/a
subroutine	11	11	100.0
pod	2	2	100.0
total	93	95	97.8

package Sub::Compose;

$VERSION = '0.01';

use strict;

use Data::Dump::Streamer ();
use Sub::Name qw( subname );

sub import {
    my $pkg = caller;

    for (@_) {
        no strict 'refs';
        if ( $_ eq 'compose' ) {
            *{ "${pkg}::compose" } = \&compose;
            next;
        }
        if ( $_ eq 'chain' ) {
            *{ "${pkg}::chain" } = \&chain;
            next;
        }
    }

    return;
}

sub chain {
    my (@subs) = @_;

    return subname chainer => sub {
        foreach my $sub ( @subs ) {
            @_ = $sub->( @_ );
        }

        return @_;
    };
}

sub compose {
    my @subs = @_;

    #{my $i;print map { $i++ . ":$_\n" } Data::Dump::Streamer::Dump( @subs )->Out;}

    my @code = do {
        grep {
            !/^;/
        } Data::Dump::Streamer::Dump( @subs )->Out;
    };

    #{my $i;print map { $i++ . " -> $_\n" } @code;}

    my %deparsed;
    my @vars;
    my @deparsed;
    foreach my $i ( 0 .. $#code ) {
        my @lines = split /\n/, $code[$i];

        my ($name) = $lines[0] =~ m{^ \$ (\S+) \s* = \s* (?:sub|\$)}x;

        unless ( $name ) {
            push @vars, @lines;
            next;
        }

        if ( @lines == 1 ) {
            my ($ref) = $lines[0] =~ m{ \$ (\S+) ; $}x;
            ($deparsed{ $name } = $deparsed{ $ref }) =~ s/END_SUB_\d+/END_SUB_$i/g;
        }
        else {
            shift @lines; pop @lines;

            local $_;
            my $seen_return;
            for (@lines) {
                if (/return /) {
                    s/return /\@_ = /g;
                    $_ .= "goto END_SUB_$i;";
                    $seen_return++;
                }
            }
            $lines[-1] = "\@_ = $lines[-1]" unless $seen_return;
            push @lines, "END_SUB_$i:;\n";
            $deparsed{ $name } = join "\n", @lines;
        }
        push @deparsed, $deparsed{ $name };
    }

    my $sub = eval "{ @vars; sub { @deparsed; return wantarray ? \@_ : \$_[0] } }";
    die $@ if $@;
    return subname composer => $sub;
}

1;
__END__