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} = { status => $supplied{$module}     ? 'included'
  83                                 : $version               ? sprintf '%2.6f', $version
  84                                 : is_documented($module) ? 'required'
  85                                 : '!missing',
  86                         files  => $uselines{$useline},
  87                       };
  88
  89   # build requirement tree
  90   for my $file (@{ $uselines{$useline} }) {
  91     next if $file =~ /\.pl$/;
  92     my $orig_module = modulize($file);
  93     $requires{$orig_module} ||= {};
  94     $requires{$orig_module}{$module}++;
  95   }
  96 }
  97
  98 # build transitive closure for documented dependancies
  99 my $changed = 1;
 100 while ($changed) {
 101   $changed = 0;
 102   for my $src_module (keys %requires) {
 103     for my $dst_module (keys %{ $requires{$src_module} }) {
 104       if (   $modules{$src_module}
 105           && $modules{$dst_module}
 106           && $modules{$src_module}->{status} =~ /^required/
 107           && $modules{$dst_module}->{status} eq '!missing') {
 108         $modules{$dst_module}->{status} = "required"; # . ", via $src_module";
 109         $changed = 1;
 110       }
 111     }
 112   }
 113 }
 114
 115 print sprintf "%8s : %s (%s)", color_text($modules{$_}->{status}), $_, join(' ', @{ $modules{$_}->{files} || [] })
 116   for sort {
 117        $modules{$a}->{status} cmp $modules{$b}->{status}
 118     ||                    $a  cmp $b
 119   } keys %modules;
 120
 121 sub modulize {
 122   for (my ($name) = @_) {
 123     s#^./modules/\w+/##;
 124     s#^./##;
 125     s#.pm$##;
 126     s#/#::#g;
 127     return $_;
 128   }
 129 }
 130
 131 sub is_documented {
 132   my ($module) = @_;
 133   grep { $_->{name} eq $module } @SL::InstallationCheck::required_modules;
 134 }
 135
 136 sub color_text {
 137   my ($text) = @_;
 138   return color(get_color($text)) . $text . color('reset');
 139 }
 140
 141 sub get_color {
 142   for (@_) {
 143     return 'yellow' if /^5./ && $_ > 5.008;
 144     return 'green'  if /^5./;
 145     return 'green'  if /^included/;
 146     return 'red'    if /^!missing/;
 147     return 'yellow';
 148   }
 149 }
 150
 151 1;
 152
 153 __END__
 154
 155 =head1 NAME
 156
 157 find-use
 158
 159 =head1 EXAMPLE
 160
 161  # perl scipts/find-use.pl
 162  !missing : Perl::Tags
 163  !missing : Template::Constants
 164  !missing : DBI
 165
 166 =head1 EXPLANATION
 167
 168 This util is useful for package builders to identify all the CPAN dependencies
 169 we have. It requires Module::CoreList (which is core since 5.9) to determine if
 170 a module is distributed with perl or not.  The output will be one of the
 171 following:
 172
 173 =over 4
 174
 175 =item VERSION
 176
 177 If a version string is displayed, the module is core since this version.
 178 Everything up to 5.8 is alright. 5.10 (aka 5.010) is acceptable, but should be
 179 documented. Please do not use 5.12 core modules without adding an explicit
 180 requirement.
 181
 182 =item included
 183
 184 This module is included in C<modules/*>. Don't worry about it.
 185
 186 =item required
 187
 188 This module is documented in C<SL:InstallationCheck> to be necessary, or is a
 189 dependancy of one of these. Everything alright.
 190
 191 =item !missing
 192
 193 These modules are neither core, nor included, nor required. This is ok for
 194 developer tools, but should never occur for modules the actual program uses.
 195
 196 =back
 197
 198 =head1 AUTHOR
 199
 200 http://www.ledgersmb.org/ - The LedgerSMB team
 201 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
 202
 203 =head1 LICENSE
 204
 205 Distributed under the terms of the GNU General Public License v2.
 206
 207 =cut
 208
 209