scripts/find-use.pl

   1 #!/usr/bin/perl -l
   2 use strict;
   3 #use warnings; # corelist and find throw tons of warnings
   4 use File::Find;
   5 use Module::CoreList;
   6 use SL::InstallationCheck;
   7 use Term::ANSIColor;
   8 use Getopt::Long;
   9
  10 my (%uselines, %modules, %supplied, %requires);
  11
  12 # since the information which classes belong to a cpan distribution is not
  13 # easily obtained, I'll just hard code the bigger ones we use here. the same
  14 # hash will be filled later with information gathered from the source files.
  15 %requires = (
  16   'DateTime' => {
  17     'DateTime::Duration'                 => 1,
  18     'DateTime::Infinite'                 => 1,
  19   },
  20   'Rose::DB::Object' => {
  21    'Rose::DB::Object::ConventionManager' => 1,
  22    'Rose::DB::Object::Manager'           => 1,
  23    'Rose::DB::Object::Metadata'          => 1,
  24   },
  25   'Rose::Object' => {
  26     'Rose::Object::MakeMethods::Generic' => 1,
  27   },
  28   'Template' => {
  29     'Template::Constants'                => 1,
  30     'Template::Exception'                => 1,
  31     'Template::Iterator'                 => 1,
  32     'Template::Plugin'                   => 1,
  33     'Template::Plugin::Filter'           => 1,
  34     'Template::Plugin::HTML'             => 1,
  35   },
  36   'Devel::REPL' => {
  37     'namespace::clean'                   => 1,
  38   }
  39 );
  40
  41 GetOptions(
  42   'files-with-match|l' => \ my $l,
  43 );
  44
  45 find(sub {
  46   return unless /(\.p[lm]|console)$/;
  47
  48   # remember modules shipped with Lx-Office
  49   $supplied{modulize($File::Find::name)}++
  50     if $File::Find::dir =~ m#modules/#;
  51
  52   open my $fh, '<', $_ or warn "can't open $_: $!";
  53   while (<$fh>) {
  54     chomp;
  55     next if !/^use /;
  56     next if /SL::/;
  57     next if /Support::Files/; # our own test support module
  58     next if /use (warnings|strict|vars|lib|constant|utf8)/;
  59
  60     my ($useline) = m/^use\s+(.*?)$/;
  61
  62     next if  $useline =~ /^[\d._]+;/; # skip version requirements
  63     next if !$useline;
  64
  65     $uselines{$useline} ||= [];
  66     push @{ $uselines{$useline} }, $File::Find::name;
  67   }
  68 }, '.');
  69
  70 for my $useline (keys %uselines) {
  71   $useline =~ s/#.*//; # kill comments
  72
  73   # modules can be loaded implicitly with use base qw(Module) or use parent
  74   # 'Module'. catch these:
  75   my ($module, $args) = $useline =~ /
  76     (?:
  77       (?:base|parent)
  78       \s
  79       (?:'|"|qw.)
  80     )?                 # optional parent block
  81     ([\w:]+)           # the module
  82     (.*)               # args
  83   /ix;
  84
  85   # some comments looks very much like use lines
  86   # try to get rid of them
  87   next if $useline =~ /^it like a normal Perl node/;   # YAML::Dump comment
  88   next if $useline =~ /^most and offer that in a small/; # YAML
  89
  90   my $version = Module::CoreList->first_release($module);
  91   $modules{$module} = { status => $supplied{$module}     ? 'included'
  92                                 : $version               ? sprintf '%2.6f', $version
  93                                 : is_required($module)   ? 'required'
  94                                 : is_optional($module)   ? 'optional'
  95                                 : is_developer($module)  ? 'developer'
  96                                 : '!missing',
  97                         files  => $uselines{$useline},
  98                       };
  99
 100   # build requirement tree
 101   for my $file (@{ $uselines{$useline} }) {
 102     next if $file =~ /\.pl$/;
 103     my $orig_module = modulize($file);
 104     $requires{$orig_module} ||= {};
 105     $requires{$orig_module}{$module}++;
 106   }
 107 }
 108
 109 # build transitive closure for documented dependancies
 110 my $changed = 1;
 111 while ($changed) {
 112   $changed = 0;
 113   for my $src_module (keys %requires) {
 114     for my $dst_module (keys %{ $requires{$src_module} }) {
 115       if (   $modules{$src_module}
 116           && $modules{$dst_module}
 117           && $modules{$src_module}->{status} =~ /^(required|devel|optional)/
 118           && $modules{$dst_module}->{status} eq '!missing') {
 119         $modules{$dst_module}->{status} = "required"; # . ", via $src_module";
 120         $changed = 1;
 121       }
 122     }
 123   }
 124 }
 125
 126 do {
 127   print sprintf "%8s : %s", color_text($modules{$_}->{status}), $_;
 128   if ($l) {
 129     print " $_" for @{ $modules{$_}->{files} || [] };
 130   }
 131 } for sort {
 132        $modules{$a}->{status} cmp $modules{$b}->{status}
 133     ||                    $a  cmp $b
 134   } keys %modules;
 135
 136 sub modulize {
 137   for (my ($name) = @_) {
 138     s#^./modules/\w+/##;
 139     s#^./##;
 140     s#.pm$##;
 141     s#/#::#g;
 142     return $_;
 143   }
 144 }
 145
 146 sub is_required {
 147   my ($module) = @_;
 148   grep { $_->{name} eq $module } @SL::InstallationCheck::required_modules;
 149 }
 150
 151 sub is_optional {
 152   my ($module) = @_;
 153   grep { $_->{name} eq $module } @SL::InstallationCheck::optional_modules;
 154 }
 155
 156 sub is_developer {
 157   my ($module) = @_;
 158   grep { $_->{name} eq $module } @SL::InstallationCheck::developer_modules;
 159 }
 160
 161 sub color_text {
 162   my ($text) = @_;
 163   return color(get_color($text)) . $text . color('reset');
 164 }
 165
 166 sub get_color {
 167   for (@_) {
 168     return 'yellow' if /^5./ && $_ > 5.008;
 169     return 'green'  if /^5./;
 170     return 'green'  if /^included/;
 171     return 'red'    if /^!missing/;
 172     return 'yellow';
 173   }
 174 }
 175
 176 1;
 177
 178 __END__
 179
 180 =head1 NAME
 181
 182 find-use
 183
 184 =head1 EXAMPLE
 185
 186  # perl scipts/find-use.pl
 187  !missing : Perl::Tags
 188  !missing : Template::Constants
 189  !missing : DBI
 190
 191 =head1 EXPLANATION
 192
 193 This util is useful for package builders to identify all the CPAN dependencies
 194 we have. It requires Module::CoreList (which is core since 5.9) to determine if
 195 a module is distributed with perl or not.  The output will be one of the
 196 following:
 197
 198 =over 4
 199
 200 =item VERSION
 201
 202 If a version string is displayed, the module is core since this version.
 203 Everything up to 5.8 is alright. 5.10 (aka 5.010) is acceptable, but should be
 204 documented. Please do not use 5.12 core modules without adding an explicit
 205 requirement.
 206
 207 =item included
 208
 209 This module is included in C<modules/*>. Don't worry about it.
 210
 211 =item required
 212
 213 This module is documented in C<SL:InstallationCheck> to be necessary, or is a
 214 dependancy of one of these. Everything alright.
 215
 216 =item !missing
 217
 218 These modules are neither core, nor included, nor required. This is ok for
 219 developer tools, but should never occur for modules the actual program uses.
 220
 221 =back
 222
 223 =head1 AUTHOR
 224
 225 http://www.ledgersmb.org/ - The LedgerSMB team
 226 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
 227
 228 =head1 LICENSE
 229
 230 Distributed under the terms of the GNU General Public License v2.
 231
 232 =cut
 233
 234