File Coverage

blib/lib/Perl/Stripper.pm

Criterion	Covered	Total	%
statement	88	93	94.6
branch	40	54	74.0
condition	8	12	66.6
subroutine	10	10	100.0
pod	1	1	100.0
total	147	170	86.4

package Perl::Stripper;

our $DATE = '2017-07-11'; # DATE
our $VERSION = '0.10'; # VERSION

use 5.010001;
use Log::ger;

use PPI;
use Moo;
use experimental 'smartmatch';

has maintain_linum      => (is => 'rw', default => sub { 1 });
has strip_comment       => (is => 'rw', default => sub { 1 });
has strip_pod           => (is => 'rw', default => sub { 1 });
has strip_ws            => (is => 'rw', default => sub { 1 });
has strip_log           => (is => 'rw', default => sub { 0 });
has stripped_log_levels => (is => 'rw', default => sub { [qw/debug trace/] });

sub _strip_el_content {
    my ($self, $el) = @_;

    my $ct;
    if ($self->maintain_linum) {
        $ct = $el->content;
        my $num_nl = () = $ct =~ /\R/g;
        $ct = "\n" x $num_nl;
    } else {
        $ct = "";
    }
    $el->set_content($ct);
}

sub _strip_node_content {
    my ($self, $node) = @_;

    my $ct;
    if ($self->maintain_linum) {
        $ct = $node->content;
        my $num_nl = () = $ct =~ /\R/g;
        $ct = "\n" x $num_nl;
    } else {
        $ct = "";
    }
    $node->prune(sub{1});
    $node->add_element(PPI::Token::Whitespace->new($ct)) if $ct;
}

sub strip {
    my ($self, $perl) = @_;

    my @ll   = @{ $self->stripped_log_levels };
    my @llf  = map {$_."f"} @ll;
    my @isll = map {"is_$_"} @ll;

    my $doc = PPI::Document->new(\$perl);
    my $res = $doc->find(
        sub {
            my ($top, $el) = @_;

            if ($self->strip_comment && $el->isa('PPI::Token::Comment')) {
                # don't strip shebang line
                if ($el->content =~ /^#!/) {
                    my $loc = $el->location;
                    return if $loc->[0] == 1 && $loc->[1] == 1;
                }
                if (ref($self->strip_comment) eq 'CODE') {
                    $self->strip_comment->($el);
                } else {
                    $self->_strip_el_content($el);
                }
            }

            if ($self->strip_pod && $el->isa('PPI::Token::Pod')) {
                if (ref($self->strip_pod) eq 'CODE') {
                    $self->strip_pod->($el);
                } else {
                    $self->_strip_el_content($el);
                }
            }

            if ($self->strip_log) {
                my $match;
                if ($el->isa('PPI::Statement')) {
                    # matching '$log->trace(...);'
                    my $c0 = $el->child(0);
                    if ($c0->content eq '$log') {
                        my $c1 = $c0->snext_sibling;
                        if ($c1->content eq '->') {
                            my $c2 = $c1->snext_sibling;
                            my $c2c = $c2->content;
                            if ($c2c ~~ @ll || $c2c ~~ @llf) {
                                $match++;
                            }
                        }
                    }
                }
                if ($el->isa('PPI::Statement')) {
                    # matching 'log_trace(...);'
                    my $c0 = $el->child(0);
                    if (grep { $c0->content eq "log_$_" } @ll) {
                        $match++;
                    }
                }
                if ($el->isa('PPI::Statement::Compound')) {
                    # matching 'if ($log->is_trace) { ... }' or 'if (log_is_trace()) { ... }'
                    my $c0 = $el->child(0);
                    if ($c0->content eq 'if') {
                        my $cond = $c0->snext_sibling;
                        if ($cond->isa('PPI::Structure::Condition')) {
                            my $expr = $cond->child(0);
                            if ($expr->isa('PPI::Statement::Expression')) {
                                my $c0 = $expr->child(0);
                                if ($c0->content eq '$log') {
                                    my $c1 = $c0->snext_sibling;
                                    if ($c1->content eq '->') {
                                        my $c2 = $c1->snext_sibling;
                                        my $c2c = $c2->content;
                                        if ($c2c ~~ @isll) {
                                            $match++;
                                        }
                                    }
                                } elsif (grep {$c0->content eq "log_is_$_"} @ll) {
                                    $match++;
                                }
                            }
                        }
                    }
                }

                if ($match) {
                    if (ref($self->strip_log) eq 'CODE') {
                        $self->strip_log->($el);
                    } else {
                        $self->_strip_node_content($el);
                    }
                }
            }

            0;
        }
    );
    die "BUG: find() dies: $@!" unless defined($res);

    $doc->serialize;
}

1;
# ABSTRACT: Yet another PPI-based Perl source code stripper

__END__