scripts/find-use.pl

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