File Coverage

blib/lib/Devel/Examine/Subs/Preprocessor.pm

Criterion	Covered	Total	%
statement	146	146	100.0
branch	58	64	90.6
condition	4	6	66.6
subroutine	21	21	100.0
pod	4	6	66.6
total	233	243	95.8

package Devel::Examine::Subs::Preprocessor;
use 5.008;
use strict;
use warnings;

our $VERSION = '1.69';

use Carp;
use Data::Dumper;
use Symbol qw(delete_package);

BEGIN {

    # we need to do some trickery for DTS due to circular referencing,
    # which broke CPAN installs.

    eval {
        require Devel::Trace::Subs;
    };

    eval {
        import Devel::Trace::Subs qw(trace);
    };

    if (! defined &trace){
        *trace = sub {};
    }
};

sub new {

    trace() if $ENV{TRACE};

    my $self = {};
    bless $self, shift;

    my $struct = shift;

    $self->{pre_procs} = $self->_dt;

    return $self;
}
sub _dt {

    trace() if $ENV{TRACE};

    my $self = shift;

    my $dt = {
        module => \&module,
        inject => \&inject,
        remove => \&remove,
        replace => \&replace,
        _test_bad => \&test_bad,
    };

    return $dt;
}
sub exists {

    trace() if $ENV{TRACE};

    my $self = shift;
    my $string = shift;

    if (exists $self->{pre_procs}{$string}){
        return 1;
    }
    else {
        return 0;
    }
}
sub module {

    trace() if $ENV{TRACE};

    return sub {
        trace() if $ENV{TRACE};

        no strict 'refs';

        my $p = shift;

        if (! $p->{module} or $p->{module} eq '') {
            return [];
        }

        (my $module_file = $p->{module}) =~ s|::|/|g;
        $module_file .= '.pm';

        my $module_is_loaded = 0;

        if (! $INC{$module_file}){
            eval {
                require "$module_file";
            };

            if ($@) {
                die "Problem loading $p->{module}: $@";
            }
        }
        else {
            $module_is_loaded = 1;
        }

        my $namespace = "$p->{module}::";

        my @subs;

        for my $sub (keys %$namespace){
            if (defined &{$namespace . $sub}){
                push @subs, $sub;
            }
        }

        if (! $module_is_loaded){
            delete_package($p->{module});
            delete $INC{$module_file};
        }

        return \@subs;
    };
}
sub inject {

    trace() if $ENV{TRACE};

    return sub {

        trace() if $ENV{TRACE};

        my $p = shift;

        my @file_contents = @{ $p->{file_contents} };

        # after line number

        my $rw = File::Edit::Portable->new;

        if (defined $p->{line_num}){

            # inject after line number

            $rw->splice(
                file => $p->{file},
                line => $p->{line_num},
                insert => $p->{code},
                copy => $p->{copy},
            );
        }
        elsif ($p->{inject_use}){

            # inject a use statement

            my $use = qr/use\s+\w+/;

            my $index;

            ($index) = grep {
                $file_contents[$_] =~ $use
            } 0..$#file_contents;

            if (!$index) {
                ($index) = grep {
                    $file_contents[$_] =~ /^package\s+\w+/
                } 0..$#file_contents;
                $index++;
            }

            if ($index) {
                $rw->splice(
                    file => $p->{file},
                    line => $index,
                    insert => $p->{inject_use},
                    copy => $p->{copy},
                );
            }
        }
        elsif ($p->{inject_after_sub_def}){

            # inject code after sub definition

            my $code = $p->{inject_after_sub_def};

            my @new_file;

            my $single_line = qr/
                sub\s+\w+\s*(?:\(.*?\)\s+)?\{\s*(?!\s*[\S])
                |
                sub\s+\{\s*(?!\s*[\S])
                /x;

            my $multi_line = qr/sub\s+\w+\s*(?![\S])/;

            my $is_multi = 0;

            my $i = -1;

            for my $e (@file_contents){

                $i++;

                my $indent = '';

                my $count = $i;
                $count++;

                while ($count < @file_contents){
                    if ($file_contents[$count] =~ /^(\s*)\S/){
                        $indent = $1;
                        last;
                    }
                    else {
                        $count++;
                    }
                }

                push @new_file, $e;

                if ($e =~ $single_line) {
                    for (@$code){
                        push @new_file, $indent . $_;
                    }
                }
                elsif ($e =~ $multi_line) {
                    if ($file_contents[$count] =~ /\s*\{\s*(?!\s*[\S])/) {
                        $is_multi = 1;
                        next;
                    }
                }

                if ($is_multi) {
                    for (@$code) {
                        push @new_file, $indent . $_;
                    }
                    $is_multi = 0;
                }
            }
            $p->{write_file_contents} = \@new_file;
        }
    }
}
sub replace {

    trace() if $ENV{TRACE};

    return sub {

        trace() if $ENV{TRACE};

        my $p = shift;
        my $exec = $p->{exec};
        my $limit = defined $p->{limit} ? $p->{limit} : -1;

        my @file = @{ $p->{file_contents} };

        if (! $exec || ref $exec ne 'CODE'){
            confess "\nDES::replace() requires 'exec => \$cref param\n";
        }

        my $lines_changed;

        for (@file){
            my $changed = $exec->($_);
            if ($changed){
                $lines_changed++;
                $limit--;
                last if $limit == 0;
            }
        }

        $p->{write_file_contents} = \@file;
        return $lines_changed;
    }
}
sub remove {

    trace() if $ENV{TRACE};

    return sub {

        trace() if $ENV{TRACE};

        my $p = shift;
        my @file = @{ $p->{file_contents}};

        my $delete = $p->{delete};

        for my $find (@$delete){
            while (my ($index) = grep { $file[$_] =~ $find } 0..$#file){
                splice @file, $index, 1;
            }
        }
        $p->{write_file_contents} = \@file;
    }
}
sub _vim_placeholder {1;}
1;
__END__