File Coverage

blib/lib/Perl/ImportReport.pm

Criterion	Covered	Total	%
statement	123	134	91.7
branch	34	44	77.2
condition	9	14	64.2
subroutine	11	12	91.6
pod	3	3	100.0
total	180	207	86.9

package Perl::ImportReport;

use strict;
use warnings;

use PPI       ();
use PPI::Util ();

$Perl::ImportReport::VERSION = '0.1';

sub new {
    my $ppi = PPI::Util::_Document( $_[1] ) || return;

    return bless {
        'ppi_document'  => $ppi,
        'import_report' => undef,
      },
      $_[0];
}

sub get_ppi_document {
    return $_[0]->{'ppi_document'};
}
*Document = *get_ppi_document;    # to match Perl::MinimumVersion

sub get_import_report {
    my $iro = shift;

    # restart fresh
    $iro->{'import_report'} = undef;

    # Create a map of all PPI::Statement::Package's so we can determine what package a given PPI::Statement::Include is in
    my %pkg = ( 0 => [ { 'namespace' => 'main', 'column_number' => 0 } ] );
    my $pkg_nodes = $iro->{'ppi_document'}->find(
        sub {
            if ( $_[1]->isa('PPI::Statement::Package') ) {
                if ( my $ns = $_[1]->namespace() ) {
                    my $line_no = $_[1]->line_number();
                    $pkg{$line_no} = [] if !exists $pkg{$line_no};

                    push @{ $pkg{$line_no} },
                      {
                        'namespace'     => $ns,
                        'column_number' => $_[1]->column_number(),
                      };
                    return 1;
                }
            }
            return;
        }
    );

    $iro->{'import_report'}{'number_of_includes'} = 0;
    if ( $iro->{'ppi_document'}->find_any('PPI::Statement::Include') ) {
        my $inc_nodes = $iro->{'ppi_document'}->find(
            sub {
                if ( $_[1]->isa('PPI::Statement::Include') && !$_[1]->pragma && $_[1]->module && $_[1]->type eq 'use' ) {
                    return 1;
                }
                return;
            }
        );

        return $iro->{'import_report'} if ref($inc_nodes) ne 'ARRAY';

        my @incs;
        for my $ppi_inc ( @{$inc_nodes} ) {

            my $parent_package;
            for my $line_num ( sort { $a <=> $b } keys %pkg ) {
                if ( $line_num <= $ppi_inc->line_number() ) {
                    if ( $line_num == $ppi_inc->line_number() ) {
                        for my $ns_hr ( @{ $pkg{$line_num} } ) {
                            if ( $ns_hr->{'column_number'} < $ppi_inc->column_number() ) {
                                $parent_package = $ns_hr->{'namespace'};
                            }
                        }
                    }
                    else {
                        $parent_package = $pkg{$line_num}->[-1]{'namespace'};
                    }
                }
            }

            my %import_data = (
                'raw_perl'       => "$ppi_inc",
                'module'         => $ppi_inc->module(),
                'module_version' => $ppi_inc->module_version(),
                'arguments'      => [ $ppi_inc->arguments() ],
                'line_number'    => $ppi_inc->line_number(),
                'in_package'     => $parent_package,
                'exporter'       => {},
            );

            my $module = $ppi_inc->module();
            if ( !defined $ppi_inc->arguments() ) {
                eval "require $module;";    # TODO: ? PPI $module instead so as not to run code  ?...
                no strict 'refs';
                $import_data{'exporter'}{'EXPORT'}{'error'} = $@;
                $import_data{'exporter'}{'EXPORT'}{'count'} = @{"$module\::EXPORT"};
                @{ $import_data{'exporter'}{'EXPORT'}{'data'} } = @{"$module\::EXPORT"};

                $import_data{'symbol_list'} = \@{"$module\::EXPORT"};
                push @{ $iro->{'import_report'}{'imports'} }, \%import_data;
                $iro->{'import_report'}{'number_of_includes'}++;
            }
            else {
                my $list = join( '', map { $_->content() } $ppi_inc->arguments() );

                if ( $list !~ m/^\s*\(/ ) {
                    $list = "($list)";
                }

                my @list = do { no strict; eval $list };
                my @expanded = @list;

                if (@list) {

                    # If any of the entries in an import list begins with !, : or / then the list is treated
                    # as a series of specifications which either add to or delete from the list of names to
                    # import. They are processed left to right. Specifications are in the form:
                    #     [!]name         This name only
                    #     [!]:DEFAULT     All names in @EXPORT
                    #     [!]:tag         All names in $EXPORT_TAGS{tag} anonymous list
                    #     [!]/pattern/    All names in @EXPORT and @EXPORT_OK which match

                    # TODO: @list contains only qr()
                    if ( grep m{^[!:/]}, @list ) {
                        eval "require $module;";
                        no strict 'refs';

                        $import_data{'exporter'}{'EXPORT_OK'}{'error'} = $@;
                        @{ $import_data{'exporter'}{'EXPORT_OK'}{'data'} } = @{"$module\::EXPORT_OK"};

                        $import_data{'exporter'}{'EXPORT_TAGS'}{'error'} = $@;
                        $import_data{'exporter'}{'EXPORT_TAGS'}{'data'}  = \%{"$module\::EXPORT_TAGS"};    # TOOD: ? copy ?

                        @expanded = ();

                        for my $ent (@list) {
                            my $symbol = $ent;
                            my $remove = 0;
                            if ( $ent =~ m/^\!(.*)/ ) {
                                $remove = 1;
                                $symbol = $1;
                            }

                            my @symbols;

                            if ( substr( $symbol, 0, 1 ) eq ':' ) {
                                if ( exists ${"$module\::EXPORT_TAGS"}{$symbol} ) {
                                    @symbols = @{ ${"$module\::EXPORT_TAGS"}{$symbol} };
                                }
                                else {
                                    my $copy = $symbol;
                                    $copy =~ s/^://;
                                    if ( exists ${"$module\::EXPORT_TAGS"}{$copy} ) {
                                        @symbols = @{ ${"$module\::EXPORT_TAGS"}{$copy} };
                                    }
                                }

                            }
                            elsif ( ref($symbol) eq 'Regexp' || substr( $symbol, 0, 1 ) eq '/' ) {
                                my $qr = $symbol;
                                if ( ref($symbol) ne 'Regexp' ) {
                                    my $copy = $symbol;
                                    $copy =~ s{^\/}{};
                                    $copy =~ s{\/$}{};
                                    $qr = qr($copy);
                                }

                                @symbols = grep $qr, @{"$module\::EXPORT_OK"};
                                push @symbols, map { $_ =~ $qr ? @{ ${"$module\::EXPORT_TAGS"}{$_} } : () } keys %{"$module\::EXPORT_TAGS"};
                            }
                            else {
                                @symbols = ($symbol);
                            }

                            # TODO: normalize sigil-prefixed names in some sensical manner
                            if ($remove) {
                                my %remove;
                                @remove{@symbols} = ();
                                @expanded = map { exists $remove{$_} ? () : ($_) } @expanded;
                            }
                            else {
                                push @expanded, @symbols;
                            }
                        }
                    }

                    $import_data{'symbol_list'} = \@expanded;
                    push @{ $iro->{'import_report'}{'imports'} }, \%import_data;
                    $iro->{'import_report'}{'number_of_includes'}++;
                }
            }
        }
    }

    return $iro->{'import_report'};
}

1;

__END__