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