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

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

Return to bug 8244