X-Git-Url: http://wagnertech.de/git?a=blobdiff_plain;f=scripts%2Ffind-use.pl;h=b2a3c0dafeb2447ab1617cac9bb5bcc6b7146111;hb=7bacc2aae8c0bf72a8fe1eaf757890184e6950f8;hp=63bbc0e8efb7025e2d1d9a2eba154a248bc814ad;hpb=1eeb6cbeae04746480b7ffc758be03ce5d9ae033;p=kivitendo-erp.git diff --git a/scripts/find-use.pl b/scripts/find-use.pl old mode 100644 new mode 100755 index 63bbc0e8e..b2a3c0daf --- a/scripts/find-use.pl +++ b/scripts/find-use.pl @@ -1,60 +1,270 @@ -#!/usr/bin/perl -w -=head1 NAME +#!/usr/bin/perl -l -find-use +BEGIN { + use FindBin; -=head1 EXAMPLE + unshift(@INC, $FindBin::Bin . '/../modules/override'); # Use our own versions of various modules (e.g. YAML). + push (@INC, $FindBin::Bin . '/..'); # '.' will be removed from @INC soon. +} - ~/ledgersmb # utils/devel/find-use - 0.000000 : HTML::Entities - 0.000000 : Locale::Maketext::Lexicon - 0.000000 : Module::Build - ... +use strict; +#use warnings; # corelist and find throw tons of warnings +use File::Find; +use Module::CoreList; +use SL::InstallationCheck; +use Term::ANSIColor; +use Getopt::Long; -=head1 EXPLINATION +my (%uselines, %modules, %supplied, %requires); -This util is useful for package builders to identify all the CPAN dependencies we've made. It required Module::CoreList (which is core, but is not yet in any stable -release of perl) to determine if a module is distributed with perl or not. The output reports which version of perl the module is in. If it reports 0.000000, then the -module is not in core perl, and needs to be installed before Lx-Office will operate. +# since the information which classes belong to a cpan distribution is not +# easily obtained, I'll just hard code the bigger ones we use here. the same +# hash will be filled later with information gathered from the source files. +%requires = ( + 'DateTime' => { + 'DateTime::Duration' => 1, + 'DateTime::Infinite' => 1, + }, + 'Rose::DB::Object' => { + 'Rose::DB::Object::ConventionManager' => 1, + 'Rose::DB::Object::Manager' => 1, + 'Rose::DB::Object::Metadata' => 1, + 'Rose::DB::Object::Helpers' => 1, + 'Rose::DB::Object::Util' => 1, + 'Rose::DB::Object::Constants' => 1, + }, + 'Rose::Object' => { + 'Rose::Object::MakeMethods::Generic' => 1, + }, + 'Template' => { + 'Template::Constants' => 1, + 'Template::Exception' => 1, + 'Template::Iterator' => 1, + 'Template::Plugin' => 1, + 'Template::Plugin::Filter' => 1, + 'Template::Plugin::HTML' => 1, + 'Template::Stash' => 1, + }, + 'Devel::REPL' => { + 'namespace::clean' => 1, + }, + 'Email::MIME' => { + 'Email::MIME::Creator' => 1, + }, + 'Test::Harness' => { + 'TAP::Parser' => 1, + 'TAP::Parser::Aggregator' => 1, + }, + 'Archive::Zip' => { + 'Archive::Zip::Member' => 1, + }, + 'HTML::Parser' => { + 'HTML::Entities' => 1, + }, + 'URI' => { + 'URI::Escape' => 1, + }, + 'File::MimeInfo' => { + 'File::MimeInfo::Magic' => 1, + }, +); -=head1 AUTHOR +GetOptions( + 'files-with-match|l' => \ my $l, +); -http://www.ledgersmb.org/ - The LedgerSMB team +chmod($FindBin::Bin . '/..'); -=head1 LICENSE +find(sub { + return unless /(\.p[lm]|console)$/; -Distributed under the terms of the GNU General Public License v2. -=cut + # remember modules shipped with kivitendo + $supplied{modulize($File::Find::name)}++ + if $File::Find::dir =~ m#modules/#; + open my $fh, '<', $_ or warn "can't open $_: $!"; + while (<$fh>) { + chomp; + next if !/^use /; + next if /SL::/; + next if /Support::Files/; # our own test support module + next if /use (warnings|strict|vars|lib|constant|utf8)/; + next if /^use (with|the)/; -use strict; -use warnings; + my ($useline) = m/^use\s+(.*?)$/; -open GREP, "grep -r '^use ' . |"; -use Module::CoreList; + next if $useline =~ /^[\d._]+;/; # skip version requirements + next if !$useline; + + $uselines{$useline} ||= []; + push @{ $uselines{$useline} }, $File::Find::name; + } +}, '.'); + +for my $useline (keys %uselines) { + $useline =~ s/#.*//; # kill comments -my %uselines; -while() { - next if /SL::/; - next if /LX::/; - next if /use warnings/; - next if /use strict/; - next if /use vars/; - chomp; - my ($file, $useline) = m/^([^:]+):use\s(.*?)$/; - $uselines{$useline}||=[]; - push @{$uselines{$useline}}, $file; + # modules can be loaded implicitly with use base qw(Module) or use parent + # 'Module'. catch these: + my ($module, $args) = $useline =~ / + (?: + (?:base|parent) + \s + (?:'|"|qw.) + )? # optional parent block + ([\w:]+) # the module + (.*) # args + /ix; + + # some comments looks very much like use lines + # try to get rid of them + next if $useline =~ /^it like a normal Perl node/; # YAML::Dump comment + next if $useline =~ /^most and offer that in a small/; # YAML + + my $version = Module::CoreList->first_release($module); + $modules{$module} = { status => $supplied{$module} ? 'included' + : $version ? sprintf '%2.6f', $version + : is_required($module) ? 'required' + : is_optional($module) ? 'optional' + : is_developer($module) ? 'developer' + : '!missing', + files => $uselines{$useline}, + }; + + # build requirement tree + for my $file (@{ $uselines{$useline} }) { + next if $file =~ /\.pl$/; + my $orig_module = modulize($file); + $requires{$orig_module} ||= {}; + $requires{$orig_module}{$module}++; + } +} + +# have all documented modules mentioned here +$modules{$_->{name}} ||= { status => 'required' } for @SL::InstallationCheck::required_modules; +$modules{$_->{name}} ||= { status => 'optional' } for @SL::InstallationCheck::optional_modules; +$modules{$_->{name}} ||= { status => 'developer' } for @SL::InstallationCheck::developer_modules; + +# build transitive closure for documented dependencies +my $changed = 1; +while ($changed) { + $changed = 0; + for my $src_module (keys %requires) { + for my $dst_module (keys %{ $requires{$src_module} }) { + if ( $modules{$src_module} + && $modules{$dst_module} + && $modules{$src_module}->{status} =~ /^(required|devel|optional)/ + && $modules{$dst_module}->{status} eq '!missing') { + $modules{$dst_module}->{status} = "required"; # . ", via $src_module"; + $changed = 1; + } + } + } } -my %modules; -foreach my $useline (keys %uselines) { +do { + print sprintf "%8s : %s", color_text($modules{$_}->{status}), $_; + if ($l) { + print " $_" for @{ $modules{$_}->{files} || [] }; + } +} for sort { + $modules{$a}->{status} cmp $modules{$b}->{status} + || $a cmp $b + } keys %modules; + +sub modulize { + for (my ($name) = @_) { + s#^./modules/\w+/##; + s#^./##; + s#.pm$##; + s#/#::#g; + return $_; + } +} - my ($module) = grep { $_ } $useline =~ /(?:base ['"]([a-z:]+)|([a-z:]+)(?:\s|;))/i; - my $version = Module::CoreList->first_release($module); - $modules{$module} = $version||0; +sub is_required { + my ($module) = @_; + grep { $_->{name} eq $module } @SL::InstallationCheck::required_modules; } -foreach my $mod (sort { $modules{$a} == 0 ? -1 : $modules{$b} == 0 ? 1 : 0 or $a cmp $b } keys %modules) { - printf "%2.6f : %s\n", $modules{$mod}, $mod; +sub is_optional { + my ($module) = @_; + grep { $_->{name} eq $module } @SL::InstallationCheck::optional_modules; } +sub is_developer { + my ($module) = @_; + grep { $_->{name} eq $module } @SL::InstallationCheck::developer_modules; +} + +sub color_text { + my ($text) = @_; + return color(get_color($text)) . $text . color('reset'); +} + +sub get_color { + for (@_) { + return 'yellow' if /^5./ && $_ > 5.008; + return 'green' if /^5./; + return 'green' if /^included/; + return 'red' if /^!missing/; + return 'yellow'; + } +} + +1; + +__END__ + +=head1 NAME + +find-use + +=head1 EXAMPLE + + # perl scipts/find-use.pl + !missing : Template::Constants + !missing : DBI + +=head1 EXPLANATION + +This util is useful for package builders to identify all the CPAN dependencies +we have. It requires Module::CoreList (which is core since 5.9) to determine if +a module is distributed with perl or not. The output will be one of the +following: + +=over 4 + +=item VERSION + +If a version string is displayed, the module is core since this version. +Everything up to 5.8 is alright. 5.10 (aka 5.010) is acceptable, but should be +documented. Please do not use 5.12 core modules without adding an explicit +requirement. + +=item included + +This module is included in C. Don't worry about it. + +=item required + +This module is documented in C to be necessary, or is a +dependency of one of these. Everything alright. + +=item !missing + +These modules are neither core, nor included, nor required. This is ok for +developer tools, but should never occur for modules the actual program uses. + +=back + +=head1 AUTHOR + +http://www.ledgersmb.org/ - The LedgerSMB team +Sven Schöling Es.schoeling@linet-services.deE + +=head1 LICENSE + +Distributed under the terms of the GNU General Public License v2. + +=cut