Reformat, correct docs, for legibility
[bioperl-live.git] / maintenance / find_mod_deps.pl
blob721a49144aecd8dd380f2bfb50dff51d268cfe3f
1 #!/usr/bin/perl
3 =head1 NAME
5 find_mod_deps.pl - inspect B<only hard-coded> dependencies of sets of perl files
7 =head1 DESCRIPTION
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).
13 =head1 USAGE
15 find_mod_deps.pl [options] [ path ... ]
17 If given any paths, inspects only the files in those paths. Defaults
18 to inspecting all perl files in the current directory.
20 =head2 Options
22 =over 4
24 =item -i
26 If set, also print internal dependencies, i.e. the inter-dependencies
27 between the files we are inspecting.
29 =item -B
31 If set, print the dependencies in a format suitable for cutting and
32 pasting directly into a Build.PL (i.e. Module::Build)
34 =item -M
36 If set, print the dependencies in a format suitable for cutting and
37 pasting directly into a Makefile.PL (i.e. Module::Install)
39 =item -Z
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.
46 =back
48 =head1 AUTHOR
50 Robert Buels, rbuels@cpan.org
52 =cut
54 use strict;
55 use warnings;
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;
65 use Data::Dump 'dump';
66 use Hash::Merge;
68 my %opt;
69 getopts('iBMZ', \%opt) or pod2usage();
71 -d './lib' or -d './bin' or -d './scripts' or die "run this script from the root dir of a distribution\n";
73 my @paths = @ARGV;
75 @paths = qw( t lib scripts bin cgi-bin Bio )
76 unless @paths;
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 $_,
86 } elsif( -e ) {
87 if( is_perl_file($_) ) {
89 } else {
90 warn "WARNING: skipping user-specified file $_, since it is not a perl file.\n";
93 } else {
96 } @paths;
98 my %perl_files = map { $_ => 1 } @perl_files;
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 ) };
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};
113 else {
114 $classified{requires}{$modname} = $deps{$modname};
118 # decide which format to print in
119 if( $opt{B} ) {
120 for ( values %classified ) {
121 $_ = 0 for values %$_;
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}};
134 print "\n[Prereqs / TestRequires]\n";
135 print "$_ = 0\n"
136 for sort { lc $a cmp lc $b } keys %{$classified{build_requires}};
138 } else {
139 print dump \%classified;
142 exit;
144 ################## helpers #####################
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;
155 sub namespace_parent {
156 my $modname = shift;
157 $modname =~ s/(?:::)?[^:]+$//;
158 return $modname;
161 sub find_deps {
162 my ( $file ) = @_;
164 my $nopod;
165 { open my $p, '<', $file or die "Could not read file '$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 );
172 my $f = IO::String->new( \$nopod );
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/;
180 my @toks = $depline =~ /([\w:]{3,})/ig
181 or die 'cannot parse: '.$depline;
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]);
194 MODNAME:
195 foreach my $modname (@toks) {
197 chomp $depline;
198 #warn "'$depline' goes to $modname\n";
200 #skip if the module is in the distribution
201 my $modfile = modfile($modname);
202 next if !$opt{i} && $modfile && -f $modfile;
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;
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";
214 next unless $p_modfile && -f $p_modfile;
216 open my $p, '<', $p_modfile or die "Could not read file '$p_modfile': $!\n";
217 while( <$p> ) {
218 next MODNAME if /^\s*package\s+$p\b/;
222 push @{$deps{$modname} ||= []}, $file;
226 return \%deps;
229 sub is_perl_file {
230 local $_ = shift;
231 return -f && ( -x || /\.(pm|t|pl)$/ );