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