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