maintenance/find_mod_deps.pl

   1 #!/usr/bin/perl
   2
   3 =head1 NAME
   4
   5 find_mod_deps.pl - inspect B<only hard-coded> dependencies of sets of perl files
   6
   7 =head1 DESCRIPTION
   8
   9 Inspects the hard-coded dependencies of a set of perl files and prints
  10 a summary of which modules they use (by default not including
  11 inter-dependencies between the modules being inspected).
  12
  13 =head1 USAGE
  14
  15 find_mod_deps.pl [options]  [ path ... ]
  16
  17 If given any paths, inspects only the files in those paths.  Defaults
  18 to inspecting all perl files in the current directory.
  19
  20 =head2 Options
  21
  22 =over 4
  23
  24 =item -i
  25
  26 If set, also print internal dependencies, i.e. the inter-dependencies
  27 between the files we are inspecting.
  28
  29 =back
  30
  31 =head1 AUTHOR
  32
  33 Robert Buels, rbuels@cpan.org
  34
  35 =cut
  36
  37 use strict;
  38 use warnings;
  39
  40 use File::Find;
  41 use Getopt::Std;
  42 use IO::String;
  43 use List::MoreUtils qw/ first_value all /;
  44 use Module::CoreList;
  45 use Pod::Strip;
  46 use Pod::Usage;
  47
  48 use Data::Dump 'dump';
  49 use Hash::Merge;
  50
  51 my %opt;
  52 getopts('i', \%opt) or pod2usage();
  53
  54 -d './lib' or -d './bin' or -d './scripts' or die "run this script from the root dir of a distribution\n";
  55
  56 my @paths = @ARGV;
  57
  58 @paths = qw( t lib scripts bin cgi-bin Bio )
  59    unless @paths;
  60
  61 # expand any dirs into the perl files they contain
  62 my @perl_files = map {
  63     if( -d ) {
  64         my @f;
  65         find( sub { push @f, $File::Find::name if is_perl_file($_) },
  66               $_,
  67             );
  68         @f
  69     } else {
  70         if( is_perl_file($_) ) {
  71             $_
  72         } else {
  73             warn "WARNING: skipping user-specified file $_, since it is not a perl file.\n";
  74             ()
  75         }
  76     }
  77 } @paths;
  78
  79 my %perl_files = map { $_ => 1 } @perl_files;
  80
  81 my %deps;
  82 my $merger = Hash::Merge->new('RETAINMENT_PRECEDENT');
  83 for my $file ( @perl_files ) {
  84     my $deps = find_deps( $file );
  85     %deps = %{ $merger->merge( \%deps, $deps ) };
  86 }
  87
  88 # classify the deps
  89 my %classified;
  90 for my $modname ( keys %deps ) {
  91     if( all { m|^(./)?t/| } @{$deps{$modname}} ) {
  92         $classified{build_requires}{$modname} = $deps{$modname};
  93     }
  94     else {
  95         $classified{requires}{$modname} = $deps{$modname};
  96     }
  97 }
  98
  99 print dump \%classified;
 100 exit;
 101
 102 sub modfile {
 103     my $modname = shift;
 104     my $modfile = "$modname.pm";
 105     $modfile =~ s|::|/|g;
 106     return first_value {
 107         $_ =~ /$modfile$/;
 108     } @perl_files;
 109 }
 110
 111 sub namespace_parent {
 112     my $modname = shift;
 113     $modname =~ s/(?:::)?[^:]+$//;
 114     return $modname;
 115 }
 116
 117 sub find_deps {
 118     my ( $file ) = @_;
 119
 120     my $nopod;
 121     { open my $p, '<', $file or die "$! reading $file\n";
 122       local $/;
 123       my $code = <$p>;
 124       my $strip = Pod::Strip->new;
 125       $strip->output_string(\$nopod);
 126       $strip->parse_string_document( $code );
 127     }
 128     my $f = IO::String->new( \$nopod );
 129
 130     my %deps;
 131     while( my $depline = <$f> ) {
 132         $depline =~ s/#.+//; #remove comments
 133         next unless $depline =~ /^\s*(use|require|extends|with)\s+.+;/;
 134         next unless $depline && $depline =~ /\S/;
 135
 136         my @toks = $depline =~ /([\w:]{3,})/ig
 137             or die 'cannot parse: '.$depline;
 138
 139         #warn "    adding to $k->{name}\n";
 140         shift @toks;
 141         if( @toks ) {
 142             if ( $toks[0] eq 'base' ) {
 143                 shift @toks;
 144                 shift @toks if $toks[0] eq 'qw';
 145             } else {
 146                 @toks = ($toks[0]);
 147             }
 148         }
 149
 150       MODNAME:
 151         foreach my $modname (@toks) {
 152
 153             chomp $depline;
 154             #warn "'$depline' goes to $modname\n";
 155
 156             #skip if the module is in the distribution
 157             my $modfile = modfile($modname);
 158             next if !$opt{i} && $modfile && -f $modfile;
 159
 160             #skip if the module is in core before 5.6
 161             my $rl = Module::CoreList->first_release($modname);
 162             next if $rl && $rl <= 5.006;
 163
 164             #skip if the module is actually defined in a parent file
 165             my $p = $modname;
 166             while( $p = namespace_parent($p) ) {
 167                 my $p_modfile = modfile($p);
 168                 #warn  "checking $p / $p_modfile\n";
 169
 170                 next unless $p_modfile && -f $p_modfile;
 171
 172                 open my $p, '<', $p_modfile or die "$! opening $p_modfile\n";
 173                 while( <$p> ) {
 174                     next MODNAME if /^\s*package\s+$p\b/;
 175                 }
 176             }
 177
 178             push @{$deps{$modname} ||= []}, $file;
 179         }
 180     }
 181
 182     return \%deps;
 183 }
 184
 185 sub is_perl_file {
 186     local $_ = shift;
 187     return -f && ( -x || /\.(pm|t|pl)$/ );
 188 }