Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
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 …
#!/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__
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.