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 =item -B
  30
  31 If set, print the dependencies in a format suitable for cutting and
  32 pasting directly into a Build.PL (i.e. Module::Build)
  33
  34 =item -M
  35
  36 If set, print the dependencies in a format suitable for cutting and
  37 pasting directly into a Makefile.PL (i.e. Module::Install)
  38
  39 =item -Z
  40
  41 If set, print the dependencies in a format suitable for cutting and
  42 pasting directly into a dist.ini (i.e. Dist::Zilla).  Although, if
  43 you're using Dist::Zilla, you probably have it configured to be
  44 auto-discovering deps, and it will find the same deps as this script.
  45
  46 =back
  47
  48 =head1 AUTHOR
  49
  50 Robert Buels, rbuels@cpan.org
  51
  52 =cut
  53
  54 use strict;
  55 use warnings;
  56
  57 use File::Find;
  58 use Getopt::Std;
  59 use IO::String;
  60 use List::MoreUtils qw/ first_value all /;
  61 use Module::CoreList;
  62 use Pod::Strip;
  63 use Pod::Usage;
  64
  65 use Data::Dump 'dump';
  66 use Hash::Merge;
  67
  68 my %opt;
  69 getopts('iBMZ', \%opt) or pod2usage();
  70
  71 -d './lib' or -d './bin' or -d './scripts' or die "run this script from the root dir of a distribution\n";
  72
  73 my @paths = @ARGV;
  74
  75 @paths = qw( t lib scripts bin cgi-bin Bio )
  76    unless @paths;
  77
  78 # expand any dirs into the perl files they contain
  79 my @perl_files = map {
  80     if( -d ) {
  81         my @f;
  82         find( sub { push @f, $File::Find::name if is_perl_file($_) },
  83               $_,
  84             );
  85         @f
  86     } elsif( -e ) {
  87         if( is_perl_file($_) ) {
  88             $_
  89         } else {
  90             warn "WARNING: skipping user-specified file $_, since it is not a perl file.\n";
  91             ()
  92         }
  93     } else {
  94         ()
  95     }
  96 } @paths;
  97
  98 my %perl_files = map { $_ => 1 } @perl_files;
  99
 100 my %deps;
 101 my $merger = Hash::Merge->new('RETAINMENT_PRECEDENT');
 102 for my $file ( @perl_files ) {
 103     my $deps = find_deps( $file );
 104     %deps = %{ $merger->merge( \%deps, $deps ) };
 105 }
 106
 107 # classify the deps
 108 my %classified;
 109 for my $modname ( keys %deps ) {
 110     if( all { m|^(./)?t/| } @{$deps{$modname}} ) {
 111         $classified{build_requires}{$modname} = $deps{$modname};
 112     }
 113     else {
 114         $classified{requires}{$modname} = $deps{$modname};
 115     }
 116 }
 117
 118 # decide which format to print in
 119 if( $opt{B} ) {
 120     for ( values %classified ) {
 121         $_ = 0 for values %$_;
 122     }
 123     print dump \%classified;
 124 } elsif( $opt{M} ) {
 125     print "requires      '$_' => 0;\n"
 126       for sort { lc $a cmp lc $b } keys %{$classified{requires}};
 127     print "test_requires '$_' => 0;\n"
 128       for sort { lc $a cmp lc $b } keys %{$classified{build_requires}};
 129 } elsif( $opt{Z} ) {
 130     print "[Prereqs]\n";
 131     print "$_  =  0\n"
 132       for sort { lc $a cmp lc $b } keys %{$classified{requires}};
 133
 134     print "\n[Prereqs / TestRequires]\n";
 135     print "$_  =  0\n"
 136       for sort { lc $a cmp lc $b } keys %{$classified{build_requires}};
 137
 138 } else {
 139     print dump \%classified;
 140 }
 141
 142 exit;
 143
 144 ################## helpers #####################
 145
 146 sub modfile {
 147     my $modname = shift;
 148     my $modfile = "$modname.pm";
 149     $modfile =~ s|::|/|g;
 150     return first_value {
 151         $_ =~ /$modfile$/;
 152     } @perl_files;
 153 }
 154
 155 sub namespace_parent {
 156     my $modname = shift;
 157     $modname =~ s/(?:::)?[^:]+$//;
 158     return $modname;
 159 }
 160
 161 sub find_deps {
 162     my ( $file ) = @_;
 163
 164     my $nopod;
 165     { open my $p, '<', $file or die "$! reading $file\n";
 166       local $/;
 167       my $code = <$p>;
 168       my $strip = Pod::Strip->new;
 169       $strip->output_string(\$nopod);
 170       $strip->parse_string_document( $code );
 171     }
 172     my $f = IO::String->new( \$nopod );
 173
 174     my %deps;
 175     while( my $depline = <$f> ) {
 176         $depline =~ s/#.+//; #remove comments
 177         next unless $depline =~ /^\s*(use|require|extends|with)\s+.+;/;
 178         next unless $depline && $depline =~ /\S/;
 179
 180         my @toks = $depline =~ /([\w:]{3,})/ig
 181             or die 'cannot parse: '.$depline;
 182
 183         #warn "    adding to $k->{name}\n";
 184         shift @toks;
 185         if( @toks ) {
 186             if ( $toks[0] eq 'base' ) {
 187                 shift @toks;
 188                 shift @toks if $toks[0] eq 'qw';
 189             } else {
 190                 @toks = ($toks[0]);
 191             }
 192         }
 193
 194       MODNAME:
 195         foreach my $modname (@toks) {
 196
 197             chomp $depline;
 198             #warn "'$depline' goes to $modname\n";
 199
 200             #skip if the module is in the distribution
 201             my $modfile = modfile($modname);
 202             next if !$opt{i} && $modfile && -f $modfile;
 203
 204             #skip if the module is in core before 5.6
 205             my $rl = Module::CoreList->first_release($modname);
 206             next if $rl && $rl <= 5.006;
 207
 208             #skip if the module is actually defined in a parent file
 209             my $p = $modname;
 210             while( $p = namespace_parent($p) ) {
 211                 my $p_modfile = modfile($p);
 212                 #warn  "checking $p / $p_modfile\n";
 213
 214                 next unless $p_modfile && -f $p_modfile;
 215
 216                 open my $p, '<', $p_modfile or die "$! opening $p_modfile\n";
 217                 while( <$p> ) {
 218                     next MODNAME if /^\s*package\s+$p\b/;
 219                 }
 220             }
 221
 222             push @{$deps{$modname} ||= []}, $file;
 223         }
 224     }
 225
 226     return \%deps;
 227 }
 228
 229 sub is_perl_file {
 230     local $_ = shift;
 231     return -f && ( -x || /\.(pm|t|pl)$/ );
 232 }