|
Line 0
Link Here
|
| 0 |
- |
1 |
#!/usr/bin/perl |
|
|
2 |
|
| 3 |
# Copyright 2012 BibLibre |
| 4 |
# |
| 5 |
# This file is part of Koha. |
| 6 |
# |
| 7 |
# Koha is free software; you can redistribute it and/or modify it under the |
| 8 |
# terms of the GNU General Public License as published by the Free Software |
| 9 |
# Foundation; either version 2 of the License, or (at your option) any later |
| 10 |
# version. |
| 11 |
# |
| 12 |
# Koha is distributed in the hope that it will be useful, but WITHOUT ANY |
| 13 |
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR |
| 14 |
# A PARTICULAR PURPOSE. See the GNU General Public License for more details. |
| 15 |
# |
| 16 |
# You should have received a copy of the GNU General Public License along |
| 17 |
# with Koha; if not, write to the Free Software Foundation, Inc., |
| 18 |
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. |
| 19 |
|
| 20 |
# This script tends to detect if Koha scripts use subroutines that are not |
| 21 |
# correctly exported by modules. This can happen when we have circular |
| 22 |
# dependencies between modules. |
| 23 |
# This script does mainly two things: |
| 24 |
# - It rebuilds the hierarchy of Koha Perl modules and replace all the code |
| 25 |
# within subroutines by tests (using Test::More). For each subroutine called |
| 26 |
# in a subroutine, a test is done on if the called subroutine is defined. |
| 27 |
# If it's defined, then it's called (Tested subroutines are only those |
| 28 |
# available in Koha Perl modules, not external modules subroutines). |
| 29 |
# It does almost the same work with Koha Perl scripts, replacing all the |
| 30 |
# code by tests and calling the subroutines if defined. |
| 31 |
# - Launch prove on all created Perl scripts. |
| 32 |
# This results in a summary where failed tests are subroutines that are not |
| 33 |
# exported, but called without the module name prepended. |
| 34 |
# |
| 35 |
# This script is NOT perfect (and it can't be, because of Perl complexity) and |
| 36 |
# it can return 'false positives'. But it can permit to detect some problems |
| 37 |
# earlier when, for example, a patch introduces a circular dependency by adding |
| 38 |
# a 'use' in a module. |
| 39 |
|
| 40 |
use Modern::Perl; |
| 41 |
use PPI; |
| 42 |
|
| 43 |
use Data::Dumper; |
| 44 |
|
| 45 |
use File::Basename; |
| 46 |
use File::Path; |
| 47 |
use File::Find; |
| 48 |
use List::MoreUtils qw/uniq/; |
| 49 |
use Getopt::Long; |
| 50 |
use Cwd qw/abs_path/; |
| 51 |
|
| 52 |
my $src_path_default = abs_path(dirname($0)."/.."); |
| 53 |
|
| 54 |
sub usage { |
| 55 |
return <<USAGE; |
| 56 |
Usage: |
| 57 |
perl $0 --src-path /path/to/src --dest-path /path/to/dir_to_create [-v] [-h] |
| 58 |
|
| 59 |
--src-path|-s PATH Path where Koha lives (source tree root). |
| 60 |
Defaults to $src_path_default |
| 61 |
--dest-path|-d PATH Where you want to build the hierarchy of tests |
| 62 |
scripts and modules. Leave empty to use a temporary |
| 63 |
directory (will be removed automatically) |
| 64 |
--verbose|-v Print some progress informations |
| 65 |
--help|-h Print this help message |
| 66 |
|
| 67 |
This script tends to detect if Koha scripts use subroutines that are not |
| 68 |
correctly exported by modules. This can happen when we have circular |
| 69 |
dependencies between modules. |
| 70 |
For more information, open the file with a text editor and read the 2nd |
| 71 |
paragraph of comments. |
| 72 |
USAGE |
| 73 |
} |
| 74 |
|
| 75 |
my $src_path; |
| 76 |
my $dest_path; |
| 77 |
my $verbose = 0; |
| 78 |
my $help = 0; |
| 79 |
|
| 80 |
my $options_ok = GetOptions( |
| 81 |
'src-path=s' => \$src_path, |
| 82 |
'dest-path=s' => \$dest_path, |
| 83 |
'verbose' => \$verbose, |
| 84 |
'help' => \$help |
| 85 |
); |
| 86 |
|
| 87 |
if ($help) { |
| 88 |
print usage(); |
| 89 |
exit 0; |
| 90 |
} |
| 91 |
|
| 92 |
if (!$src_path) { |
| 93 |
$src_path = $src_path_default; |
| 94 |
} |
| 95 |
if (!$dest_path) { |
| 96 |
require File::Temp; |
| 97 |
$dest_path = File::Temp::tempdir(CLEANUP => 1); |
| 98 |
} |
| 99 |
|
| 100 |
if (!$options_ok or !$src_path or !$dest_path) { |
| 101 |
die usage(); |
| 102 |
} |
| 103 |
|
| 104 |
|
| 105 |
# Avoid overwriting the sources |
| 106 |
if (abs_path($src_path) eq abs_path($dest_path)) { |
| 107 |
die "You cannot choose the same path for --src-path and --dest-path"; |
| 108 |
} |
| 109 |
|
| 110 |
# Remove trailing slash |
| 111 |
$src_path =~ s|/$||; |
| 112 |
$dest_path =~ s|/$||; |
| 113 |
|
| 114 |
# Global hash that will contain list of per-modules subroutines |
| 115 |
my $routines; |
| 116 |
|
| 117 |
# We don't want to test these subroutines |
| 118 |
my @routines_blacklist = qw(new next fetch import delete param); |
| 119 |
# These subroutines causes many fails if CAS or LDAP are disabled because they |
| 120 |
# are not imported in this case |
| 121 |
push @routines_blacklist, qw( |
| 122 |
check_api_auth_cas |
| 123 |
checkpw_cas |
| 124 |
login_cas |
| 125 |
logout_cas |
| 126 |
login_cas_url |
| 127 |
checkpw_ldap |
| 128 |
); |
| 129 |
|
| 130 |
# Build list of modules |
| 131 |
my @modules; |
| 132 |
find( sub { |
| 133 |
return $File::Find::prune = 1 if ($_ =~ /^$dest_path$/); |
| 134 |
return $File::Find::prune = 1 if ($_ =~ /^t$/); |
| 135 |
return $File::Find::prune = 1 if ($_ =~ /^blib$/); |
| 136 |
return unless $_ =~ m/\.pm$/; |
| 137 |
my $file = $File::Find::name; |
| 138 |
$file =~ s#^$src_path##; |
| 139 |
$file =~ s#^/##; |
| 140 |
push @modules, $file; |
| 141 |
}, $src_path ); |
| 142 |
@modules = sort @modules; |
| 143 |
|
| 144 |
# Search subroutines declared in each module |
| 145 |
for my $module ( @modules ) { |
| 146 |
say "Loading $module..." if $verbose; |
| 147 |
my $document = PPI::Document->new("$src_path/$module") or die( "Unable to open file $src_path/$module" ); |
| 148 |
my $sub_nodes = $document->find( |
| 149 |
sub { |
| 150 |
$_[1]->isa('PPI::Statement::Sub') and $_[1]->name |
| 151 |
and not $_[1]->isa('PPI::Statement::Scheduled') |
| 152 |
} |
| 153 |
); |
| 154 |
next unless $sub_nodes; |
| 155 |
my @sub_names = map { $_ ? $_->name : () } @$sub_nodes; |
| 156 |
$routines->{$module} = \@sub_names; |
| 157 |
} |
| 158 |
|
| 159 |
|
| 160 |
# Transform each module so that each subroutines will only contain tests |
| 161 |
# (no 'real' code inside) and save them in $dest_path |
| 162 |
for my $module ( @modules ) { |
| 163 |
my $document = PPI::Document->new("$src_path/$module") or die( "Unable to open file $src_path/$module" ); |
| 164 |
my $includes = $document->find('PPI::Statement::Include') || []; |
| 165 |
my @include_module_names; |
| 166 |
for my $include ( @$includes ) { |
| 167 |
next unless $include; |
| 168 |
my $words = $include->find('PPI::Token::Word') || []; |
| 169 |
for my $w ( @$words ) { |
| 170 |
push @include_module_names, $w |
| 171 |
if $w->content =~ /^C4|^Koha/; |
| 172 |
} |
| 173 |
} |
| 174 |
if ( scalar ( @$includes ) ) { |
| 175 |
my $first_include = @$includes[0]; |
| 176 |
$first_include->add_element( PPI::Document->new( \";use Test::More;" ) ); |
| 177 |
} |
| 178 |
|
| 179 |
my @list_of_subroutines; |
| 180 |
while ( my ( $mod, $sub ) = each %$routines ) { |
| 181 |
push @list_of_subroutines, @$sub |
| 182 |
if scalar( |
| 183 |
grep { |
| 184 |
$mod =~ s/\//::/; |
| 185 |
$mod =~ s/.pm//; |
| 186 |
$mod eq $_ |
| 187 |
} @include_module_names |
| 188 |
); |
| 189 |
} |
| 190 |
|
| 191 |
my $sub_nodes = $document->find( |
| 192 |
sub { |
| 193 |
$_[1]->isa('PPI::Statement::Sub') and $_[1]->name |
| 194 |
and not $_[1]->isa('PPI::Statement::Scheduled') |
| 195 |
} |
| 196 |
); |
| 197 |
$sub_nodes = [] unless $sub_nodes; |
| 198 |
|
| 199 |
my $directory = dirname( "$dest_path/$module" ); |
| 200 |
mkpath $directory; |
| 201 |
|
| 202 |
for my $node ( @$sub_nodes ) { |
| 203 |
next unless $node; |
| 204 |
my $sub_node = $node->block; |
| 205 |
|
| 206 |
my $word_nodes = $sub_node->find( sub { |
| 207 |
($_[1]->isa('PPI::Token::Word') and not $_[1]->method_call) |
| 208 |
or $_[1]->isa('PPI::Statement::Include') |
| 209 |
} ); |
| 210 |
next unless $word_nodes; |
| 211 |
my $content; |
| 212 |
for my $wn ( @$word_nodes ) { |
| 213 |
if ($wn->isa('PPI::Statement::Include')) { |
| 214 |
$content .= "\n" . $wn->content . "\n"; |
| 215 |
} else { |
| 216 |
next if ( scalar( grep {$wn->content eq $_} @routines_blacklist ) );; |
| 217 |
my $ps = $wn->sprevious_sibling; |
| 218 |
my $ns = $wn->snext_sibling; |
| 219 |
next if ref $ns eq 'PPI::Token::Operator' |
| 220 |
and $ns->content eq '->'; |
| 221 |
next if ref $ps eq 'PPI::Token::Operator' |
| 222 |
and $ps->content eq '->'; |
| 223 |
unless ( scalar( grep {$wn->content eq $_} @list_of_subroutines ) ) { |
| 224 |
next; |
| 225 |
} |
| 226 |
next if ref $ns eq 'PPI::Token::Operator' |
| 227 |
and $ns->content eq '=>'; |
| 228 |
if (ref $wn->parent eq 'PPI::Statement::Expression' |
| 229 |
and ref $wn->parent->parent eq 'PPI::Structure::Subscript') { |
| 230 |
next; |
| 231 |
} |
| 232 |
next if $wn->content eq $node->name; # Avoid Deep recursion |
| 233 |
|
| 234 |
my $call = $wn->content; |
| 235 |
$content .= qq{ |
| 236 |
ok(defined &$call, "In $module: &$call"); |
| 237 |
if (defined &$call) {&$call;} |
| 238 |
} |
| 239 |
} |
| 240 |
} |
| 241 |
|
| 242 |
for my $child ( $sub_node->children ) { |
| 243 |
$child->remove; |
| 244 |
} |
| 245 |
my $new_code = PPI::Token->new(); |
| 246 |
$new_code->set_content($content); |
| 247 |
$sub_node->add_element($new_code); |
| 248 |
|
| 249 |
} |
| 250 |
|
| 251 |
# Save the file |
| 252 |
say "Saving module $dest_path/$module" if $verbose; |
| 253 |
$document->save("$dest_path/$module"); |
| 254 |
} |
| 255 |
|
| 256 |
# Build list of scripts |
| 257 |
my @scripts; |
| 258 |
find( sub { |
| 259 |
return $File::Find::prune = 1 if ($_ =~ /^t$/); |
| 260 |
return $File::Find::prune = 1 if ($_ =~ /^$dest_path$/); |
| 261 |
return unless $_ =~ m/\.pl$/; |
| 262 |
my $file = $File::Find::name; |
| 263 |
$file =~ s#^$src_path##; |
| 264 |
$file =~ s#^/##; |
| 265 |
push @scripts, $file; |
| 266 |
}, $src_path ); |
| 267 |
@scripts = sort @scripts; |
| 268 |
|
| 269 |
# Transform each script so that they will only contain tests |
| 270 |
# (no 'real' code inside) and save them in $dest_path |
| 271 |
my @scripts_to_run = (); |
| 272 |
for my $script ( @scripts ) { |
| 273 |
my $document = PPI::Document->new("$src_path/$script"); |
| 274 |
unless ($document) { |
| 275 |
# Failed to parse |
| 276 |
my $src = qq{ |
| 277 |
use Test::More; |
| 278 |
ok(0, "Failed to parse script $script"); |
| 279 |
}; |
| 280 |
my $new_document = PPI::Document->new(\$src); |
| 281 |
say "Saving script $dest_path/$script" if $verbose; |
| 282 |
$new_document->save("$dest_path/$script"); |
| 283 |
push @scripts_to_run, $script; |
| 284 |
next; |
| 285 |
} |
| 286 |
|
| 287 |
my $run_this_script = 1; |
| 288 |
$run_this_script = 0 if $script =~ (m|^misc/kohalib.pl$|); |
| 289 |
|
| 290 |
my $sub_nodes = $document->find( |
| 291 |
sub { |
| 292 |
$_[1]->isa('PPI::Statement::Sub') and $_[1]->name |
| 293 |
} |
| 294 |
); |
| 295 |
$sub_nodes = [] unless $sub_nodes; |
| 296 |
|
| 297 |
my $directory = dirname( "$dest_path/$script" ); |
| 298 |
mkpath $directory; |
| 299 |
|
| 300 |
my $includes = $document->find( 'PPI::Statement::Include' ) || []; |
| 301 |
foreach my $include (@$includes) { |
| 302 |
$include->add_element(PPI::Document->new(\";")); |
| 303 |
} |
| 304 |
my $new_document = PPI::Document->new($includes); |
| 305 |
$new_document->add_element( PPI::Document->new( \"use Test::More;" ) ); |
| 306 |
|
| 307 |
my @include_module_names; |
| 308 |
for my $include ( @$includes ) { |
| 309 |
next unless $include; |
| 310 |
my $words = $include->find('PPI::Token::Word'); |
| 311 |
for my $w ( @$words ) { |
| 312 |
if ($w->content =~ /^Test::More$/) { |
| 313 |
$run_this_script = 0; |
| 314 |
} |
| 315 |
push @include_module_names, $w |
| 316 |
if $w->content =~ /^C4|^Koha/; |
| 317 |
} |
| 318 |
} |
| 319 |
|
| 320 |
my @list_of_subroutines; |
| 321 |
while ( my ( $mod, $sub ) = each %$routines ) { |
| 322 |
push @list_of_subroutines, @$sub |
| 323 |
if scalar( |
| 324 |
grep { |
| 325 |
$mod =~ s/\//::/; |
| 326 |
$mod =~ s/.pm//; |
| 327 |
$mod eq $_ |
| 328 |
} @include_module_names |
| 329 |
); |
| 330 |
} |
| 331 |
|
| 332 |
my $words = $document->find( sub { |
| 333 |
$_[1]->isa('PPI::Token::Word') |
| 334 |
and (not $_[1]->method_call) |
| 335 |
} ) || []; |
| 336 |
my @subroutines; |
| 337 |
for my $wn ( @$words ) { |
| 338 |
next if not $wn; |
| 339 |
next if ( scalar( grep {$wn->content eq $_} @routines_blacklist ) ); |
| 340 |
my $ns = $wn->snext_sibling; |
| 341 |
my $ps = $wn->sprevious_sibling; |
| 342 |
next if ref $ns eq 'PPI::Token::Operator' |
| 343 |
and $ns->content eq '->'; |
| 344 |
next if ref $ps eq 'PPI::Token::Operator' |
| 345 |
and $ps eq '->'; |
| 346 |
unless ( scalar( grep {$wn->content eq $_} @list_of_subroutines ) ) { |
| 347 |
next; |
| 348 |
} |
| 349 |
next if ref $ns eq 'PPI::Token::Operator' |
| 350 |
and $ns->content eq '=>'; |
| 351 |
if (ref $wn->parent eq 'PPI::Statement::Expression' |
| 352 |
and ref $wn->parent->parent eq 'PPI::Structure::Subscript') { |
| 353 |
next; |
| 354 |
} |
| 355 |
push @subroutines, $wn->content; |
| 356 |
} |
| 357 |
@subroutines = uniq @subroutines; |
| 358 |
|
| 359 |
my @elements; |
| 360 |
for ( @subroutines ) { |
| 361 |
my $src = qq { |
| 362 |
ok (defined &$_, "In $script: &$_"); |
| 363 |
if (defined &$_){&$_} |
| 364 |
}; |
| 365 |
push @elements, PPI::Document->new( \$src ); |
| 366 |
} |
| 367 |
# For scripts that have no tests |
| 368 |
push @elements, PPI::Document->new( \"ok(1);" ); |
| 369 |
push @elements, PPI::Document->new( \"done_testing;" ); |
| 370 |
$new_document->add_element( $_ ) for @elements; |
| 371 |
|
| 372 |
# Save the file |
| 373 |
say "Saving script $dest_path/$script" if $verbose; |
| 374 |
$new_document->save("$dest_path/$script"); |
| 375 |
push @scripts_to_run, $script if ($run_this_script); |
| 376 |
} |
| 377 |
|
| 378 |
|
| 379 |
system("cp $src_path/C4/Context.pm $dest_path/C4/Context.pm"); |
| 380 |
system("echo '1;' > $dest_path/misc/kohalib.pl"); |
| 381 |
|
| 382 |
my @includedirs = ( |
| 383 |
$dest_path, |
| 384 |
"$dest_path/installer", |
| 385 |
"$dest_path/C4/SIP", |
| 386 |
"$dest_path/misc/translator" |
| 387 |
); |
| 388 |
my $includes_param = join(' ', map { "-I$_" } @includedirs); |
| 389 |
my $scripts_param = join(' ', map { "$dest_path/$_" } @scripts_to_run); |
| 390 |
|
| 391 |
system("prove $includes_param $scripts_param"); |
| 392 |
|