Traverse a tree and put together a dependency graph (using GraphViz2) based on use/require statements and the first namespace in module files. Take into account script files with no extension and ignore possible Perl in certain files. Detects a Perl file by trying to construct a PPI::Document using that file. Replaces "::" in package names with …

turbo-hipster.pl

#!/usr/bin/env perl

use 5.014;
use strict;
use warnings;

use File::Basename qw(basename);
use File::Find;
use GraphViz2;
use Log::Handler;
use Module::Extract::Namespaces;
use Module::CoreList;
use Path::Class;
use PPI;

run(\@ARGV);

sub run {
    my $argv = shift;

    my ($top, $core_version) = @$argv;

    -d $top or die "Need top directory\n";
    $top = dir($top)->resolve;

    unless (defined $core_version) {
        $core_version = $];
    }

    unless (exists $Module::CoreList::version{$core_version}) {
        die "Version '$core_version' not known to 'Module::CoreList'\n";
    }

    my $ignore = {
        (
            map {$_ => undef} qw(
                Apache
                Apache::Constants
                Apache::Cookie
                Apache::DBI
                Apache::Registry
                Apache::Request
                Apache::Session::DBI
                Apache::Session::MySQL
                Apache::SizeLimit
                Apache::URI
                Business::PayPal::API::ExpressCheckout
                Business::PayPal::API::RecurringPayments
                Class::Accessor
                Class::Accessor::Fast
                Config::Any
                Config::Any::YAML
                Data::GUID
                Date::Manip
                DBI
                Email::MIME::Creator
                Email::Send
                Error
                File::chdir
                Geo::IP
                HTML::TreeBuilder
                HTTP::Request
                JSON
                List::MoreUtils
                Log::Common
                LWP
                LWP::UserAgent
                Params::Validate
                SOAP::Lite
                Template
                Template::Stash
                URI
                URI::Escape
                URI::QueryParam
                XML::Simple
                YAML

            )

        ),
        %{ $Module::CoreList::version{$core_version} }
    };

    my $filename_filter_pattern = qr{
        [.]
        (?:
            (?: conf (?:[.]prod)? )|
            components |
            css        |
            default    |
            eps        |
            feature    |
            gitignore  |
            html?      |
            js         |
            lock       |
            markdown   |
            notempty   |
            rake       |
            rb         |
            rvmrc      |
            sh         |
            sql        |
            stt        |
            svg        |
            tt?        |
            tpl        |
            txt        |
            yml
        )
        \z
    }ix;

    my %component_filter = map {$_ => undef} qw(
        Gemfile
        .git
        html
        Rakefile
        shtml
        RELEASE
        wrapper
    );

    my $filter = sub {
        $_[0] =~ $filename_filter_pattern or
        grep exists($component_filter{$_}), $_[0]->components or
        (not -f $_[0])
    };

    my $ns_filter = sub { not grep $_[0] eq $_, qw(name of main script file) };

    my $logger = Log::Handler->new;
    $logger->add(
        screen =>
        {
            maxlevel       => 'debug',
            message_layout => '%m',
            minlevel       => 'error',
        }
    );

    my $graph = GraphViz2->new(
        edge   => {color => 'grey', weight => 16},
        global => {directed => 1},
        graph  => {rankdir => 'LR', splines => 'ortho', sep => 0.5, pack => 1, concentrate => 1},
        logger => $logger,
        node   => {shape => 'record', fontname => 'Helvetica', fontsize => 12},
    );

    find({
        no_chdir => 1,
        wanted => sub{ use_extractor(
                sub { $graph->add_edge(from => $_[0], to => $_[1]) },
                $top,
                file($File::Find::name)->resolve,
                $filter,
                $ns_filter,
                $ignore,
            )
        }
    }, $top);

    my $format = 'pdf';

    $graph->run(
        format => $format,
        output_file => sprintf('%s.%s', basename($top), $format),
    );

    return;
}

sub use_statement_finder {
    my $el = $_[1];
    return unless $el->isa('PPI::Statement::Include');

    my $type = $el->type;
    return unless defined $type;
    return ($type eq 'use') or ($type eq 'require');
}


sub use_extractor {
    my (
        $graph,
        $top,
        $source_file,
        $filter,
        $ns_filter,
        $ignore,
    ) = @_;

    return if $filter->($source_file);

    my $perl = eval {
        PPI::Document->new("$source_file", readonly => 1)
    } or return;

    my $modules = $perl->find(\&use_statement_finder)
        or return;

    # adapted from Module::Extract::Use to include
    # things like C<require '/path/to/my/file;> are
    # also taken into account

    my %seen;
    my @modules =
        grep { $_ and (not exists $ignore->{$_}) and (not $seen{$_}++) }
        map  { $_->pragma || $_->module || $_->content || '' }
    @$modules;

    my $ns = Module::Extract::Namespaces->from_file("$source_file");
    unless (defined $ns) {
        ($ns = $source_file) =~ s{\A\Q$top/}{};
        return if $ns_filter->($ns);
    }

    my $ns_node_label = join("\n", split /::/, $ns);
    for my $used (@modules) {
        my $used_node_label = join("\n", split /::/, $used);
        $graph->($ns_node_label => $used_node_label);
    }

    return;
}

__END__