View | Details | Raw Unified | Return to bug 8244
Collapse All | Expand All

(-)a/xt/find-undefined-subroutines.pl (-1 / +369 lines)
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

Return to bug 8244