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