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