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