| 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 | sub usage { | 
            
              | 53 |     return <<USAGE; | 
            
              | 54 | Usage: | 
            
              | 55 |     perl $0 --src-path /path/to/src --dest-path /path/to/dir_to_create | 
            
              | 56 |  | 
            
              | 57 |     --src-path|-s PATH      Path where Koha lives (source tree root) | 
            
              | 58 |     --dest-path|-d PATH     Where you want to build the hierarchy of tests | 
            
              | 59 |                             scripts and modules | 
            
              | 60 |     --verbose|-v            Print some progress informations | 
            
              | 61 |  | 
            
              | 62 |     This script tends to detect if Koha scripts use subroutines that are not | 
            
              | 63 |     correctly exported by modules. This can happen when we have circular | 
            
              | 64 |     dependencies between modules. | 
            
              | 65 |     For more information, open the file with a text editor and read the 2nd | 
            
              | 66 |     paragraph of comments. | 
            
              | 67 | USAGE | 
            
              | 68 | } | 
            
              | 69 |  | 
            
              | 70 | my $src_path; | 
            
              | 71 | my $dest_path; | 
            
              | 72 | my $verbose = 0; | 
            
              | 73 |  | 
            
              | 74 | my $options_ok = GetOptions( | 
            
              | 75 |     'src-path=s' => \$src_path, | 
            
              | 76 |     'dest-path=s' => \$dest_path, | 
            
              | 77 |     'verbose' => \$verbose | 
            
              | 78 | ); | 
            
              | 79 |  | 
            
              | 80 | if (!$options_ok or !$src_path or !$dest_path) { | 
            
              | 81 |     die usage(); | 
            
              | 82 | } | 
            
              | 83 |  | 
            
              | 84 | # Avoid overwriting the sources | 
            
              | 85 | if (abs_path($src_path) eq abs_path($dest_path)) { | 
            
              | 86 |     die "You cannot choose the same path for --src-path and --dest-path"; | 
            
              | 87 | } | 
            
              | 88 |  | 
            
              | 89 | # Remove trailing slash | 
            
              | 90 | $src_path =~ s|/$||; | 
            
              | 91 | $dest_path =~ s|/$||; | 
            
              | 92 |  | 
            
              | 93 | # Global hash that will contain list of per-modules subroutines | 
            
              | 94 | my $routines; | 
            
              | 95 |  | 
            
              | 96 | # We don't want to test these subroutines | 
            
              | 97 | my @routines_blacklist = qw(new next fetch import delete param); | 
            
              | 98 | # These subroutines causes many fails if CAS or LDAP are disabled because they | 
            
              | 99 | # are not imported in this case | 
            
              | 100 | push @routines_blacklist, qw( | 
            
              | 101 |     check_api_auth_cas | 
            
              | 102 |     checkpw_cas | 
            
              | 103 |     login_cas | 
            
              | 104 |     logout_cas | 
            
              | 105 |     login_cas_url | 
            
              | 106 |     checkpw_ldap | 
            
              | 107 | ); | 
            
              | 108 |  | 
            
              | 109 | # Build list of modules | 
            
              | 110 | my @modules; | 
            
              | 111 | find( sub { | 
            
              | 112 |     return $File::Find::prune = 1 if ($_ =~ /^$dest_path$/); | 
            
              | 113 |     return $File::Find::prune = 1 if ($_ =~ /^t$/); | 
            
              | 114 |     return $File::Find::prune = 1 if ($_ =~ /^blib$/); | 
            
              | 115 |     return unless $_ =~ m/\.pm$/; | 
            
              | 116 |     my $file = $File::Find::name; | 
            
              | 117 |     $file =~ s#\.\/##; | 
            
              | 118 |     push @modules, $file; | 
            
              | 119 | }, $src_path ); | 
            
              | 120 | @modules = sort @modules; | 
            
              | 121 |  | 
            
              | 122 | # Search subroutines declared in each module | 
            
              | 123 | for my $module ( @modules ) { | 
            
              | 124 |     say "Loading $module..." if $verbose; | 
            
              | 125 |     my $document = PPI::Document->new($module) or die( "Unable to open file $module" ); | 
            
              | 126 |     my $sub_nodes = $document->find( | 
            
              | 127 |           sub { | 
            
              | 128 |               $_[1]->isa('PPI::Statement::Sub') and $_[1]->name | 
            
              | 129 |               and not $_[1]->isa('PPI::Statement::Scheduled') | 
            
              | 130 |           } | 
            
              | 131 |     ); | 
            
              | 132 |     next unless $sub_nodes; | 
            
              | 133 |     my @sub_names = map { $_ ? $_->name : () } @$sub_nodes; | 
            
              | 134 |     $routines->{$module} = \@sub_names; | 
            
              | 135 | } | 
            
              | 136 |  | 
            
              | 137 |  | 
            
              | 138 | # Transform each module so that each subroutines will only contain tests | 
            
              | 139 | # (no 'real' code inside) and save them in $dest_path | 
            
              | 140 | for my $module ( @modules ) { | 
            
              | 141 |     my $document = PPI::Document->new($module) or die( "Unable to open file $module" ); | 
            
              | 142 |     my $includes = $document->find('PPI::Statement::Include') || []; | 
            
              | 143 |     my @include_module_names; | 
            
              | 144 |     for my $include ( @$includes ) { | 
            
              | 145 |         next unless $include; | 
            
              | 146 |         my $words = $include->find('PPI::Token::Word') || []; | 
            
              | 147 |         for my $w ( @$words ) { | 
            
              | 148 |             push @include_module_names, $w | 
            
              | 149 |                 if $w->content =~ /^C4|^Koha/; | 
            
              | 150 |         } | 
            
              | 151 |     } | 
            
              | 152 |     if ( scalar ( @$includes ) ) { | 
            
              | 153 |         my $first_include = @$includes[0]; | 
            
              | 154 |         $first_include->add_element( PPI::Document->new( \";use Test::More;" ) ); | 
            
              | 155 |     } | 
            
              | 156 |  | 
            
              | 157 |     my @list_of_subroutines; | 
            
              | 158 |     while ( my ( $mod, $sub ) = each %$routines ) { | 
            
              | 159 |         push @list_of_subroutines, @$sub | 
            
              | 160 |             if scalar( | 
            
              | 161 |                 grep { | 
            
              | 162 |                     $mod =~ s/\//::/; | 
            
              | 163 |                     $mod =~ s/.pm//; | 
            
              | 164 |                     $mod eq $_ | 
            
              | 165 |                 } @include_module_names | 
            
              | 166 |             ); | 
            
              | 167 |     } | 
            
              | 168 |  | 
            
              | 169 |     my $sub_nodes = $document->find( | 
            
              | 170 |           sub { | 
            
              | 171 |               $_[1]->isa('PPI::Statement::Sub') and $_[1]->name | 
            
              | 172 |               and not $_[1]->isa('PPI::Statement::Scheduled') | 
            
              | 173 |           } | 
            
              | 174 |     ); | 
            
              | 175 |     $sub_nodes = [] unless $sub_nodes; | 
            
              | 176 |  | 
            
              | 177 |     my $directory = dirname( "$dest_path/$module" ); | 
            
              | 178 |     mkpath $directory; | 
            
              | 179 |  | 
            
              | 180 |     for my $node ( @$sub_nodes ) { | 
            
              | 181 |         next unless $node; | 
            
              | 182 |         my $sub_node = $node->block; | 
            
              | 183 |  | 
            
              | 184 |         my $word_nodes = $sub_node->find( sub { | 
            
              | 185 |             ($_[1]->isa('PPI::Token::Word') and not $_[1]->method_call) | 
            
              | 186 |             or $_[1]->isa('PPI::Statement::Include') | 
            
              | 187 |         } ); | 
            
              | 188 |         next unless $word_nodes; | 
            
              | 189 |         my $content; | 
            
              | 190 |         for my $wn ( @$word_nodes ) { | 
            
              | 191 |             if ($wn->isa('PPI::Statement::Include')) { | 
            
              | 192 |                 $content .= "\n" . $wn->content . "\n"; | 
            
              | 193 |             } else { | 
            
              | 194 |                 next if ( scalar( grep {$wn->content eq $_} @routines_blacklist ) );; | 
            
              | 195 |                 my $ps = $wn->sprevious_sibling; | 
            
              | 196 |                 my $ns = $wn->snext_sibling; | 
            
              | 197 |                 next if ref $ns eq 'PPI::Token::Operator' | 
            
              | 198 |                     and $ns->content eq '->'; | 
            
              | 199 |                 next if ref $ps eq 'PPI::Token::Operator' | 
            
              | 200 |                     and $ps->content eq '->'; | 
            
              | 201 |                 unless ( scalar( grep {$wn->content eq $_} @list_of_subroutines ) ) { | 
            
              | 202 |                     next; | 
            
              | 203 |                 } | 
            
              | 204 |                 next if ref $ns eq 'PPI::Token::Operator' | 
            
              | 205 |                     and $ns->content eq '=>'; | 
            
              | 206 |                 if (ref $wn->parent eq 'PPI::Statement::Expression' | 
            
              | 207 |                   and ref $wn->parent->parent eq 'PPI::Structure::Subscript') { | 
            
              | 208 |                     next; | 
            
              | 209 |                 } | 
            
              | 210 |                 next if $wn->content eq $node->name; # Avoid Deep recursion | 
            
              | 211 |  | 
            
              | 212 |                 my $call = $wn->content; | 
            
              | 213 |                 $content .= qq{ | 
            
              | 214 |                     ok(defined &$call, "In $module: &$call"); | 
            
              | 215 |                     if (defined &$call) {&$call;} | 
            
              | 216 |                 } | 
            
              | 217 |             } | 
            
              | 218 |         } | 
            
              | 219 |  | 
            
              | 220 |         for my $child ( $sub_node->children ) { | 
            
              | 221 |             $child->remove; | 
            
              | 222 |         } | 
            
              | 223 |         my $new_code = PPI::Token->new(); | 
            
              | 224 |         $new_code->set_content($content); | 
            
              | 225 |         $sub_node->add_element($new_code); | 
            
              | 226 |  | 
            
              | 227 |     } | 
            
              | 228 |  | 
            
              | 229 |     # Save the file | 
            
              | 230 |     say "Saving module $dest_path/$module" if $verbose; | 
            
              | 231 |     $document->save("$dest_path/$module"); | 
            
              | 232 | } | 
            
              | 233 |  | 
            
              | 234 | # Build list of scripts | 
            
              | 235 | my @scripts; | 
            
              | 236 | find( sub { | 
            
              | 237 |     return $File::Find::prune = 1 if ($_ =~ /^t$/); | 
            
              | 238 |     return $File::Find::prune = 1 if ($_ =~ /^$dest_path$/); | 
            
              | 239 |     return unless $_ =~ m/\.pl$/; | 
            
              | 240 |     my $file = $File::Find::name; | 
            
              | 241 |     $file =~ s#\.\/##; | 
            
              | 242 |     push @scripts, $file; | 
            
              | 243 | }, $src_path ); | 
            
              | 244 | @scripts = sort @scripts; | 
            
              | 245 |  | 
            
              | 246 | # Transform each script so that they will only contain tests | 
            
              | 247 | # (no 'real' code inside) and save them in $dest_path | 
            
              | 248 | my @scripts_to_run = (); | 
            
              | 249 | for my $script ( @scripts ) { | 
            
              | 250 |     my $document = PPI::Document->new($script); | 
            
              | 251 |     unless ($document) { | 
            
              | 252 |         # Failed to parse | 
            
              | 253 |         my $src = qq{ | 
            
              | 254 |             use Test::More; | 
            
              | 255 |             ok(0, "Failed to parse script $script"); | 
            
              | 256 |         }; | 
            
              | 257 |         my $new_document = PPI::Document->new(\$src); | 
            
              | 258 |         say "Saving script $dest_path/$script" if $verbose; | 
            
              | 259 |         $new_document->save("$dest_path/$script"); | 
            
              | 260 |         push @scripts_to_run, $script; | 
            
              | 261 |         next; | 
            
              | 262 |     } | 
            
              | 263 |  | 
            
              | 264 |     my $run_this_script = 1; | 
            
              | 265 |     $run_this_script = 0 if $script =~ (m|^misc/kohalib.pl$|); | 
            
              | 266 |  | 
            
              | 267 |     my $sub_nodes = $document->find( | 
            
              | 268 |           sub { | 
            
              | 269 |               $_[1]->isa('PPI::Statement::Sub') and $_[1]->name | 
            
              | 270 |           } | 
            
              | 271 |     ); | 
            
              | 272 |     $sub_nodes = [] unless $sub_nodes; | 
            
              | 273 |  | 
            
              | 274 |     my $directory = dirname( "$dest_path/$script" ); | 
            
              | 275 |     mkpath $directory; | 
            
              | 276 |  | 
            
              | 277 |     my $includes = $document->find( 'PPI::Statement::Include' ) || []; | 
            
              | 278 |     foreach my $include (@$includes) { | 
            
              | 279 |         $include->add_element(PPI::Document->new(\";")); | 
            
              | 280 |     } | 
            
              | 281 |     my $new_document = PPI::Document->new($includes); | 
            
              | 282 |     $new_document->add_element( PPI::Document->new( \"use Test::More;" ) ); | 
            
              | 283 |  | 
            
              | 284 |     my @include_module_names; | 
            
              | 285 |     for my $include ( @$includes ) { | 
            
              | 286 |         next unless $include; | 
            
              | 287 |         my $words = $include->find('PPI::Token::Word'); | 
            
              | 288 |         for my $w ( @$words ) { | 
            
              | 289 |             if ($w->content =~ /^Test::More$/) { | 
            
              | 290 |                 $run_this_script = 0; | 
            
              | 291 |             } | 
            
              | 292 |             push @include_module_names, $w | 
            
              | 293 |                 if $w->content =~ /^C4|^Koha/; | 
            
              | 294 |         } | 
            
              | 295 |     } | 
            
              | 296 |  | 
            
              | 297 |     my @list_of_subroutines; | 
            
              | 298 |     while ( my ( $mod, $sub ) = each %$routines ) { | 
            
              | 299 |         push @list_of_subroutines, @$sub | 
            
              | 300 |             if scalar( | 
            
              | 301 |                 grep { | 
            
              | 302 |                     $mod =~ s/\//::/; | 
            
              | 303 |                     $mod =~ s/.pm//; | 
            
              | 304 |                     $mod eq $_ | 
            
              | 305 |                 } @include_module_names | 
            
              | 306 |             ); | 
            
              | 307 |     } | 
            
              | 308 |  | 
            
              | 309 |     my $words = $document->find( sub { | 
            
              | 310 |         $_[1]->isa('PPI::Token::Word') | 
            
              | 311 |         and (not $_[1]->method_call) | 
            
              | 312 |     } ) || []; | 
            
              | 313 |     my @subroutines; | 
            
              | 314 |     for my $wn ( @$words ) { | 
            
              | 315 |         next if not $wn; | 
            
              | 316 |         next if ( scalar( grep {$wn->content eq $_} @routines_blacklist ) ); | 
            
              | 317 |         my $ns = $wn->snext_sibling; | 
            
              | 318 |         my $ps = $wn->sprevious_sibling; | 
            
              | 319 |         next if ref $ns eq 'PPI::Token::Operator' | 
            
              | 320 |             and $ns->content eq '->'; | 
            
              | 321 |         next if ref $ps eq 'PPI::Token::Operator' | 
            
              | 322 |             and $ps eq '->'; | 
            
              | 323 |         unless ( scalar( grep {$wn->content eq $_} @list_of_subroutines ) ) { | 
            
              | 324 |             next; | 
            
              | 325 |         } | 
            
              | 326 |         next if ref $ns eq 'PPI::Token::Operator' | 
            
              | 327 |             and $ns->content eq '=>'; | 
            
              | 328 |         if (ref $wn->parent eq 'PPI::Statement::Expression' | 
            
              | 329 |           and ref $wn->parent->parent eq 'PPI::Structure::Subscript') { | 
            
              | 330 |             next; | 
            
              | 331 |         } | 
            
              | 332 |         push @subroutines, $wn->content; | 
            
              | 333 |     } | 
            
              | 334 |     @subroutines = uniq @subroutines; | 
            
              | 335 |  | 
            
              | 336 |     my @elements; | 
            
              | 337 |     for ( @subroutines ) { | 
            
              | 338 |         my $src = qq { | 
            
              | 339 |                 ok (defined &$_, "In $script: &$_"); | 
            
              | 340 |                 if (defined &$_){&$_} | 
            
              | 341 |             }; | 
            
              | 342 |         push @elements, PPI::Document->new( \$src ); | 
            
              | 343 |     } | 
            
              | 344 |     # For scripts that have no tests | 
            
              | 345 |     push @elements, PPI::Document->new( \"ok(1);" ); | 
            
              | 346 |     push @elements, PPI::Document->new( \"done_testing;" ); | 
            
              | 347 |     $new_document->add_element( $_ ) for @elements; | 
            
              | 348 |  | 
            
              | 349 |     # Save the file | 
            
              | 350 |     say "Saving script $dest_path/$script" if $verbose; | 
            
              | 351 |     $new_document->save("$dest_path/$script"); | 
            
              | 352 |     push @scripts_to_run, $script if ($run_this_script); | 
            
              | 353 | } | 
            
              | 354 |  | 
            
              | 355 |  | 
            
              | 356 | system("cp C4/Context.pm $dest_path/C4/Context.pm"); | 
            
              | 357 | system("echo '1;' > $dest_path/misc/kohalib.pl"); | 
            
              | 358 |  | 
            
              | 359 | my @includedirs = ( | 
            
              | 360 |     $dest_path, | 
            
              | 361 |     "$dest_path/installer", | 
            
              | 362 |     "$dest_path/C4/SIP", | 
            
              | 363 |     "$dest_path/misc/translator" | 
            
              | 364 | ); | 
            
              | 365 | my $includes_param = join(' ', map { "-I$_" } @includedirs); | 
            
              | 366 | my $scripts_param = join(' ', map { "$dest_path/$_" } @scripts_to_run); | 
            
              | 367 |  | 
            
              | 368 | system("prove --trap $includes_param $scripts_param"); | 
            
              | 369 |  |