From 2c4bb1d90037d3197921232bdf12f3b54df5acc4 Mon Sep 17 00:00:00 2001 From: Julian Maurice Date: Thu, 14 Jun 2012 11:53:47 +0200 Subject: [PATCH] Bug 8244: New script xt/find-undefined-subroutines.pl This script tends to detect if Koha scripts use subroutines that are not correctly exported by modules. This can happen when we have circular dependencies between modules. This script does mainly two things: - It rebuilds the hierarchy of Koha Perl modules and replace all the code within subroutines by tests (using Test::More). For each subroutine called in a subroutine, a test is done on if the called subroutine is defined. If it's defined, then it's called (Tested subroutines are only those available in Koha Perl modules, not external modules subroutines). It does almost the same work with Koha Perl scripts, replacing all the code by tests and calling the subroutines if defined. - Launch prove on all created Perl scripts. This results in a summary where failed tests are subroutines that are not exported, but called without the module name prepended. --- xt/find-undefined-subroutines.pl | 392 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 392 insertions(+) create mode 100755 xt/find-undefined-subroutines.pl diff --git a/xt/find-undefined-subroutines.pl b/xt/find-undefined-subroutines.pl new file mode 100755 index 0000000..e96a327 --- /dev/null +++ b/xt/find-undefined-subroutines.pl @@ -0,0 +1,392 @@ +#!/usr/bin/perl + +# Copyright 2012 BibLibre +# +# This file is part of Koha. +# +# Koha is free software; you can redistribute it and/or modify it under the +# terms of the GNU General Public License as published by the Free Software +# Foundation; either version 2 of the License, or (at your option) any later +# version. +# +# Koha is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR +# A PARTICULAR PURPOSE. See the GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License along +# with Koha; if not, write to the Free Software Foundation, Inc., +# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +# This script tends to detect if Koha scripts use subroutines that are not +# correctly exported by modules. This can happen when we have circular +# dependencies between modules. +# This script does mainly two things: +# - It rebuilds the hierarchy of Koha Perl modules and replace all the code +# within subroutines by tests (using Test::More). For each subroutine called +# in a subroutine, a test is done on if the called subroutine is defined. +# If it's defined, then it's called (Tested subroutines are only those +# available in Koha Perl modules, not external modules subroutines). +# It does almost the same work with Koha Perl scripts, replacing all the +# code by tests and calling the subroutines if defined. +# - Launch prove on all created Perl scripts. +# This results in a summary where failed tests are subroutines that are not +# exported, but called without the module name prepended. +# +# This script is NOT perfect (and it can't be, because of Perl complexity) and +# it can return 'false positives'. But it can permit to detect some problems +# earlier when, for example, a patch introduces a circular dependency by adding +# a 'use' in a module. + +use Modern::Perl; +use PPI; + +use Data::Dumper; + +use File::Basename; +use File::Path; +use File::Find; +use List::MoreUtils qw/uniq/; +use Getopt::Long; +use Cwd qw/abs_path/; + +my $src_path_default = abs_path(dirname($0)."/.."); + +sub usage { + return < \$src_path, + 'dest-path=s' => \$dest_path, + 'verbose' => \$verbose, + 'help' => \$help +); + +if ($help) { + print usage(); + exit 0; +} + +if (!$src_path) { + $src_path = $src_path_default; +} +if (!$dest_path) { + require File::Temp; + $dest_path = File::Temp::tempdir(CLEANUP => 1); +} + +if (!$options_ok or !$src_path or !$dest_path) { + die usage(); +} + + +# Avoid overwriting the sources +if (abs_path($src_path) eq abs_path($dest_path)) { + die "You cannot choose the same path for --src-path and --dest-path"; +} + +# Remove trailing slash +$src_path =~ s|/$||; +$dest_path =~ s|/$||; + +# Global hash that will contain list of per-modules subroutines +my $routines; + +# We don't want to test these subroutines +my @routines_blacklist = qw(new next fetch import delete param); +# These subroutines causes many fails if CAS or LDAP are disabled because they +# are not imported in this case +push @routines_blacklist, qw( + check_api_auth_cas + checkpw_cas + login_cas + logout_cas + login_cas_url + checkpw_ldap +); + +# Build list of modules +my @modules; +find( sub { + return $File::Find::prune = 1 if ($_ =~ /^$dest_path$/); + return $File::Find::prune = 1 if ($_ =~ /^t$/); + return $File::Find::prune = 1 if ($_ =~ /^blib$/); + return unless $_ =~ m/\.pm$/; + my $file = $File::Find::name; + $file =~ s#^$src_path##; + $file =~ s#^/##; + push @modules, $file; +}, $src_path ); +@modules = sort @modules; + +# Search subroutines declared in each module +for my $module ( @modules ) { + say "Loading $module..." if $verbose; + my $document = PPI::Document->new("$src_path/$module") or die( "Unable to open file $src_path/$module" ); + my $sub_nodes = $document->find( + sub { + $_[1]->isa('PPI::Statement::Sub') and $_[1]->name + and not $_[1]->isa('PPI::Statement::Scheduled') + } + ); + next unless $sub_nodes; + my @sub_names = map { $_ ? $_->name : () } @$sub_nodes; + $routines->{$module} = \@sub_names; +} + + +# Transform each module so that each subroutines will only contain tests +# (no 'real' code inside) and save them in $dest_path +for my $module ( @modules ) { + my $document = PPI::Document->new("$src_path/$module") or die( "Unable to open file $src_path/$module" ); + my $includes = $document->find('PPI::Statement::Include') || []; + my @include_module_names; + for my $include ( @$includes ) { + next unless $include; + my $words = $include->find('PPI::Token::Word') || []; + for my $w ( @$words ) { + push @include_module_names, $w + if $w->content =~ /^C4|^Koha/; + } + } + if ( scalar ( @$includes ) ) { + my $first_include = @$includes[0]; + $first_include->add_element( PPI::Document->new( \";use Test::More;" ) ); + } + + my @list_of_subroutines; + while ( my ( $mod, $sub ) = each %$routines ) { + push @list_of_subroutines, @$sub + if scalar( + grep { + $mod =~ s/\//::/; + $mod =~ s/.pm//; + $mod eq $_ + } @include_module_names + ); + } + + my $sub_nodes = $document->find( + sub { + $_[1]->isa('PPI::Statement::Sub') and $_[1]->name + and not $_[1]->isa('PPI::Statement::Scheduled') + } + ); + $sub_nodes = [] unless $sub_nodes; + + my $directory = dirname( "$dest_path/$module" ); + mkpath $directory; + + for my $node ( @$sub_nodes ) { + next unless $node; + my $sub_node = $node->block; + + my $word_nodes = $sub_node->find( sub { + ($_[1]->isa('PPI::Token::Word') and not $_[1]->method_call) + or $_[1]->isa('PPI::Statement::Include') + } ); + next unless $word_nodes; + my $content; + for my $wn ( @$word_nodes ) { + if ($wn->isa('PPI::Statement::Include')) { + $content .= "\n" . $wn->content . "\n"; + } else { + next if ( scalar( grep {$wn->content eq $_} @routines_blacklist ) );; + my $ps = $wn->sprevious_sibling; + my $ns = $wn->snext_sibling; + next if ref $ns eq 'PPI::Token::Operator' + and $ns->content eq '->'; + next if ref $ps eq 'PPI::Token::Operator' + and $ps->content eq '->'; + unless ( scalar( grep {$wn->content eq $_} @list_of_subroutines ) ) { + next; + } + next if ref $ns eq 'PPI::Token::Operator' + and $ns->content eq '=>'; + if (ref $wn->parent eq 'PPI::Statement::Expression' + and ref $wn->parent->parent eq 'PPI::Structure::Subscript') { + next; + } + next if $wn->content eq $node->name; # Avoid Deep recursion + + my $call = $wn->content; + $content .= qq{ + ok(defined &$call, "In $module: &$call"); + if (defined &$call) {&$call;} + } + } + } + + for my $child ( $sub_node->children ) { + $child->remove; + } + my $new_code = PPI::Token->new(); + $new_code->set_content($content); + $sub_node->add_element($new_code); + + } + + # Save the file + say "Saving module $dest_path/$module" if $verbose; + $document->save("$dest_path/$module"); +} + +# Build list of scripts +my @scripts; +find( sub { + return $File::Find::prune = 1 if ($_ =~ /^t$/); + return $File::Find::prune = 1 if ($_ =~ /^$dest_path$/); + return unless $_ =~ m/\.pl$/; + my $file = $File::Find::name; + $file =~ s#^$src_path##; + $file =~ s#^/##; + push @scripts, $file; +}, $src_path ); +@scripts = sort @scripts; + +# Transform each script so that they will only contain tests +# (no 'real' code inside) and save them in $dest_path +my @scripts_to_run = (); +for my $script ( @scripts ) { + my $document = PPI::Document->new("$src_path/$script"); + unless ($document) { + # Failed to parse + my $src = qq{ + use Test::More; + ok(0, "Failed to parse script $script"); + }; + my $new_document = PPI::Document->new(\$src); + say "Saving script $dest_path/$script" if $verbose; + $new_document->save("$dest_path/$script"); + push @scripts_to_run, $script; + next; + } + + my $run_this_script = 1; + $run_this_script = 0 if $script =~ (m|^misc/kohalib.pl$|); + + my $sub_nodes = $document->find( + sub { + $_[1]->isa('PPI::Statement::Sub') and $_[1]->name + } + ); + $sub_nodes = [] unless $sub_nodes; + + my $directory = dirname( "$dest_path/$script" ); + mkpath $directory; + + my $includes = $document->find( 'PPI::Statement::Include' ) || []; + foreach my $include (@$includes) { + $include->add_element(PPI::Document->new(\";")); + } + my $new_document = PPI::Document->new($includes); + $new_document->add_element( PPI::Document->new( \"use Test::More;" ) ); + + my @include_module_names; + for my $include ( @$includes ) { + next unless $include; + my $words = $include->find('PPI::Token::Word'); + for my $w ( @$words ) { + if ($w->content =~ /^Test::More$/) { + $run_this_script = 0; + } + push @include_module_names, $w + if $w->content =~ /^C4|^Koha/; + } + } + + my @list_of_subroutines; + while ( my ( $mod, $sub ) = each %$routines ) { + push @list_of_subroutines, @$sub + if scalar( + grep { + $mod =~ s/\//::/; + $mod =~ s/.pm//; + $mod eq $_ + } @include_module_names + ); + } + + my $words = $document->find( sub { + $_[1]->isa('PPI::Token::Word') + and (not $_[1]->method_call) + } ) || []; + my @subroutines; + for my $wn ( @$words ) { + next if not $wn; + next if ( scalar( grep {$wn->content eq $_} @routines_blacklist ) ); + my $ns = $wn->snext_sibling; + my $ps = $wn->sprevious_sibling; + next if ref $ns eq 'PPI::Token::Operator' + and $ns->content eq '->'; + next if ref $ps eq 'PPI::Token::Operator' + and $ps eq '->'; + unless ( scalar( grep {$wn->content eq $_} @list_of_subroutines ) ) { + next; + } + next if ref $ns eq 'PPI::Token::Operator' + and $ns->content eq '=>'; + if (ref $wn->parent eq 'PPI::Statement::Expression' + and ref $wn->parent->parent eq 'PPI::Structure::Subscript') { + next; + } + push @subroutines, $wn->content; + } + @subroutines = uniq @subroutines; + + my @elements; + for ( @subroutines ) { + my $src = qq { + ok (defined &$_, "In $script: &$_"); + if (defined &$_){&$_} + }; + push @elements, PPI::Document->new( \$src ); + } + # For scripts that have no tests + push @elements, PPI::Document->new( \"ok(1);" ); + push @elements, PPI::Document->new( \"done_testing;" ); + $new_document->add_element( $_ ) for @elements; + + # Save the file + say "Saving script $dest_path/$script" if $verbose; + $new_document->save("$dest_path/$script"); + push @scripts_to_run, $script if ($run_this_script); +} + + +system("cp $src_path/C4/Context.pm $dest_path/C4/Context.pm"); +system("echo '1;' > $dest_path/misc/kohalib.pl"); + +my @includedirs = ( + $dest_path, + "$dest_path/installer", + "$dest_path/C4/SIP", + "$dest_path/misc/translator" +); +my $includes_param = join(' ', map { "-I$_" } @includedirs); +my $scripts_param = join(' ', map { "$dest_path/$_" } @scripts_to_run); + +system("prove $includes_param $scripts_param"); + -- 1.7.10