File Coverage

blib/lib/Filter/Cleanup.pm

Criterion	Covered	Total	%
statement	40	64	62.5
branch	4	10	40.0
condition	3	7	42.8
subroutine	10	10	100.0
pod	1	1	100.0
total	58	92	63.0

package Filter::Cleanup;

our $VERSION = '0.02';

use Carp;
use Filter::Util::Call;
use PPI;
use PPI::Document;
use PPI::Document::Fragment;

use constant READ_BYTES => 999_999;

sub import {
    my ($class, %args) = @_;
    my $debug = $args{debug} || 0;
    my $pad   = $args{pad}   || 0;

    my $self = bless {}, $class;
    $self->{dbg} = $debug;
    $self->{pad} = $pad;

    filter_add($self);
    return $self;
}

sub filter {
    my $self   = shift;
    my $status = filter_read(READ_BYTES);
    my $source = $_;

    $source = _transform($source);

    if ($self->{dbg} && $source ne $_) {
        my @lines = split /\n/, $_;
        if (@lines) {
            warn sprintf("\n=(%s) expansion\n", __PACKAGE__);

            for (my $i = $self->{pad}; $i <= ($self->{pad} +  $#lines); ++$i) {
                warn sprintf('%3d. %s', $i + 1, $lines[$i - $self->{pad}]), "\n";
            }

            warn "=cut\n\n";
        }
    }

    $_ = $source;
    return $status;
}

sub _transform {
    my $source = shift;
    my $pdom   = PPI::Document->new(\$source);

    my $wanted = sub {
       my ($node, $element) = @_;
       $element->isa('PPI::Token::Word') && $element->content eq 'cleanup';
    };

    if (my $cleanup = $pdom->find_first($wanted)) {
        # Get entire statement
        my $statement = $cleanup->statement;

        # Get code block
        my $block = $cleanup->snext_sibling;

        # Remove from tree
        $cleanup->remove(), $block->remove();

        # Collect rest of statement's lexical scope
        my @sibs;
        my $node = $statement;
        while (ref $node) {
            $node = $node->next_sibling;
            push @sibs, $node if $node;
        }

        # Remove rest of the scope from the tree
        foreach my $node (@sibs) {
            $node->remove();
        }

        # Generate code
        my $template = '{use Symbol;my($g,$e)=(gensym)x2;$g=eval{%s};$e=$@;%sif($e){use Carp;croak $e}else{$g}}';
        my $code = sprintf($template, join('', map {$_->content} @sibs), $block->content);

        # Replace $statement with new code
        my $fragment = PPI::Document::Fragment->new(\$code);

        foreach my $child ($fragment->children) {
            $statement->insert_before($child);
        }

        $statement->remove;
        return _transform($pdom->content);
    }

    return $pdom->content;
}

1;

__END__