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