1#!perl
2
3## There's too much use of source code in strings.
4## no critic (RequireInterpolationOfMetachars)
5
6use 5.006001;
7use strict;
8use warnings;
9
10use English qw< -no_match_vars >;
11use Carp qw< confess >;
12
13use File::Temp qw< >;
14use PPI::Document qw< >;
15use PPI::Document::File qw< >;
16
17use Perl::Critic::PolicyFactory;
18use Perl::Critic::TestUtils qw(bundled_policy_names);
19use Perl::Critic::Utils;
20
21use Test::More tests => 156;
22
23our $VERSION = '1.140';
24
25use Perl::Critic::TestUtils;
26Perl::Critic::TestUtils::assert_version( $VERSION );
27
28test_export();
29test_find_keywords();
30test_is_assignment_operator();
31test_is_hash_key();
32test_is_script();
33test_is_script_with_PL_files();
34test_is_perl_builtin();
35test_is_perl_global();
36test_precedence_of();
37test_is_subroutine_name();
38test_policy_long_name_and_policy_short_name();
39test_interpolate();
40test_is_perl_and_shebang_line();
41test_is_backup();
42test_first_arg();
43test_parse_arg_list();
44test_is_function_call();
45test_find_bundled_policies();
46test_is_unchecked_call();
47
48#-----------------------------------------------------------------------------
49
50sub test_export {
51    can_ok('main', 'all_perl_files');
52    can_ok('main', 'find_keywords');
53    can_ok('main', 'interpolate');
54    can_ok('main', 'is_hash_key');
55    can_ok('main', 'is_method_call');
56    can_ok('main', 'is_perl_builtin');
57    can_ok('main', 'is_perl_global');
58    can_ok('main', 'is_script');
59    can_ok('main', 'is_subroutine_name');
60    can_ok('main', 'first_arg');
61    can_ok('main', 'parse_arg_list');
62    can_ok('main', 'policy_long_name');
63    can_ok('main', 'policy_short_name');
64    can_ok('main', 'precedence_of');
65    can_ok('main', 'severity_to_number');
66    can_ok('main', 'shebang_line');
67    can_ok('main', 'verbosity_to_format');
68    can_ok('main', 'is_unchecked_call');
69
70    is($SPACE, q< >, 'character constants');
71    is($SEVERITY_LOWEST, 1, 'severity constants');
72    is($POLICY_NAMESPACE, 'Perl::Critic::Policy', 'Policy namespace');
73
74    return;
75}
76
77#-----------------------------------------------------------------------------
78
79sub count_matches { my $val = shift; return defined $val ? scalar @{$val} : 0; }
80sub make_doc {
81    my $code = shift;
82    return
83        Perl::Critic::Document->new('-source' => ref $code ? $code : \$code);
84}
85
86sub test_find_keywords {
87    my $doc = PPI::Document->new(); #Empty doc
88    is( count_matches( find_keywords($doc, 'return') ), 0, 'find_keywords, no doc' );
89
90    my $code = 'return;';
91    $doc = make_doc( $code );
92    is( count_matches( find_keywords($doc, 'return') ), 1, 'find_keywords, find 1');
93
94    $code = 'sub foo { }';
95    $doc = make_doc( $code );
96    is( count_matches( find_keywords($doc, 'return') ), 0, 'find_keywords, find 0');
97
98    $code = 'sub foo { return 1; }';
99    $doc = make_doc( $code );
100    is( count_matches( find_keywords($doc, 'return') ), 1, 'find_keywords, find 1');
101
102    $code = 'sub foo { return 0 if @_; return 1; }';
103    $doc = make_doc( $code );
104    is( count_matches( find_keywords($doc, 'return') ), 2, 'find_keywords, find 2');
105
106    return;
107}
108
109#-----------------------------------------------------------------------------
110
111sub test_is_assignment_operator {
112    for ( qw( = **= += -= .= *= /= %= x= &= |= ^= <<= >>= &&= ||= //= ) ) {
113        is( is_assignment_operator($_), 1, "$_ is an assignment operator" );
114    }
115
116    for ( qw( == != =~ >= <= + - * / % x bogus= ) ) {
117        is( !!is_assignment_operator($_), q{}, "$_ is not an assignment operator" );
118    }
119
120    return;
121}
122
123#-----------------------------------------------------------------------------
124
125sub test_is_hash_key {
126    my $code = 'sub foo { return $h1{bar}, $h2->{baz}, $h3->{ nuts() } }';
127    my $doc = PPI::Document->new(\$code);
128    my @words = @{$doc->find('PPI::Token::Word')};
129    my @expect = (
130        ['sub', undef],
131        ['foo', undef],
132        ['return', undef],
133        ['bar', 1],
134        ['baz', 1],
135        ['nuts', undef],
136    );
137    is(scalar @words, scalar @expect, 'is_hash_key count');
138
139    for my $i (0 .. $#expect) {
140        is($words[$i], $expect[$i][0], 'is_hash_key word');
141        is( !!is_hash_key($words[$i]), !!$expect[$i][1], 'is_hash_key boolean' );
142    }
143
144    return;
145}
146
147#-----------------------------------------------------------------------------
148
149sub test_is_script {
150    my @good = (
151        "#!perl\n",
152        "#! perl\n",
153        "#!/usr/bin/perl -w\n",
154        "#!C:\\Perl\\bin\\perl\n",
155        "#!/bin/sh\n",
156    );
157
158    my @bad = (
159        "package Foo;\n",
160        "\n#!perl\n",
161    );
162
163    no warnings qw< deprecated >;   ## no critic (TestingAndDebugging::ProhibitNoWarnings)
164
165    for my $code (@good) {
166        my $doc = PPI::Document->new(\$code) or confess;
167        $doc->index_locations();
168        ok(is_script($doc), 'is_script, true');
169    }
170
171    for my $code (@bad) {
172        my $doc = PPI::Document->new(\$code) or confess;
173        $doc->index_locations();
174        ok(!is_script($doc), 'is_script, false');
175    }
176
177    return;
178}
179
180#-----------------------------------------------------------------------------
181
182sub test_is_script_with_PL_files { ## no critic (NamingConventions::Capitalization)
183
184    # Testing for .PL files (e.g. Makefile.PL, Build.PL)
185    # See http://rt.cpan.org/Ticket/Display.html?id=20481
186    my $temp_file = File::Temp->new(SUFFIX => '.PL');
187
188    # The file must have content, or PPI will barf...
189    print {$temp_file} "some code\n";
190    # Just to flush the buffer.
191    close $temp_file or confess "Couldn't close $temp_file: $OS_ERROR";
192
193    my $doc = PPI::Document::File->new($temp_file->filename());
194
195    no warnings qw< deprecated >;   ## no critic (TestingAndDebugging::ProhibitNoWarnings)
196    ok(is_script($doc), 'is_script, false for .PL files');
197
198    return;
199}
200
201#-----------------------------------------------------------------------------
202
203sub test_is_perl_builtin {
204    ok(  is_perl_builtin('print'),  'Is perl builtin function'     );
205    ok( !is_perl_builtin('foobar'), 'Is not perl builtin function' );
206
207    my $code = 'sub print {}';
208    my $doc = make_doc( $code );
209    my $sub = $doc->find_first('Statement::Sub');
210    ok( is_perl_builtin($sub), 'Is perl builtin function (PPI)' );
211
212    $code = 'sub foobar {}';
213    $doc = make_doc( $code );
214    $sub = $doc->find_first('Statement::Sub');
215    ok( !is_perl_builtin($sub), 'Is not perl builtin function (PPI)' );
216
217    return;
218}
219
220#-----------------------------------------------------------------------------
221
222sub test_is_perl_global {
223    ok(  is_perl_global('$OSNAME'), '$OSNAME is a perl global var'     );
224    ok(  is_perl_global('*STDOUT'), '*STDOUT is a perl global var'     );
225    ok( !is_perl_global('%FOOBAR'), '%FOOBAR is a not perl global var' );
226
227    my $code = '$OSNAME';
228    my $doc  = make_doc($code);
229    my $var  = $doc->find_first('Token::Symbol');
230    ok( is_perl_global($var), '$OSNAME is perl a global var (PPI)' );
231
232    $code = '*STDOUT';
233    $doc  = make_doc($code);
234    $var  = $doc->find_first('Token::Symbol');
235    ok( is_perl_global($var), '*STDOUT is perl a global var (PPI)' );
236
237    $code = '%FOOBAR';
238    $doc  = make_doc($code);
239    $var  = $doc->find_first('Token::Symbol');
240    ok( !is_perl_global($var), '%FOOBAR is not a perl global var (PPI)' );
241
242    $code = q[$\\];
243    $doc  = make_doc($code);
244    $var  = $doc->find_first('Token::Symbol');
245    ok( is_perl_global($var), "$code is a perl global var (PPI)" );
246
247    return;
248}
249
250#-----------------------------------------------------------------------------
251
252sub test_precedence_of {
253    cmp_ok( precedence_of(q<*>), q[<], precedence_of(q<+>), 'Precedence' );
254
255    my $code1 = '8 + 5';
256    my $doc1  = make_doc($code1);
257    my $op1   = $doc1->find_first('Token::Operator');
258
259    my $code2 = '7 * 5';
260    my $doc2  = make_doc($code2);
261    my $op2   = $doc2->find_first('Token::Operator');
262
263    cmp_ok( precedence_of($op2), '<', precedence_of($op1), 'Precedence (PPI)' );
264
265    return;
266}
267
268#-----------------------------------------------------------------------------
269
270sub test_is_subroutine_name {
271    my $code = 'sub foo {}';
272    my $doc  = make_doc( $code );
273    my $word = $doc->find_first( sub { $_[1] eq 'foo' } );
274    ok( is_subroutine_name( $word ), 'Is a subroutine name');
275
276    $code = '$bar = foo()';
277    $doc  = make_doc( $code );
278    $word = $doc->find_first( sub { $_[1] eq 'foo' } );
279    ok( !is_subroutine_name( $word ), 'Is not a subroutine name');
280
281    return;
282}
283
284#-----------------------------------------------------------------------------
285
286sub test_policy_long_name_and_policy_short_name {
287    my $short_name = 'Baz::Nuts';
288    my $long_name  = "${POLICY_NAMESPACE}::$short_name";
289    is( policy_long_name(  $short_name ), $long_name,  'policy_long_name'  );
290    is( policy_long_name(  $long_name  ), $long_name,  'policy_long_name'  );
291    is( policy_short_name( $short_name ), $short_name, 'policy_short_name' );
292    is( policy_short_name( $long_name  ), $short_name, 'policy_short_name' );
293
294    return;
295}
296
297#-----------------------------------------------------------------------------
298
299sub test_interpolate {
300    is( interpolate( '\r%l\t%c\n' ), "\r%l\t%c\n", 'Interpolation' );
301    is( interpolate( 'literal'    ), 'literal',    'Interpolation' );
302
303    return;
304}
305
306#-----------------------------------------------------------------------------
307
308sub test_is_perl_and_shebang_line {
309    for ( qw(foo.t foo.pm foo.pl foo.PL foo.psgi) ) {
310        ok( Perl::Critic::Utils::_is_perl($_), qq{Is perl: '$_'} );
311    }
312
313    for ( qw(foo.doc foo.txt foo.conf foo foo.pl.exe foo_pl) ) {
314        ok( ! Perl::Critic::Utils::_is_perl($_), qq{Is not perl: '$_'} );
315    }
316
317    my @perl_shebangs = (
318        '#!perl',
319        '#!/usr/local/bin/perl',
320        '#!/usr/local/bin/perl-5.8',
321        '#!/bin/env perl',
322        '#!perl ## no critic',
323        '#!perl ## no critic (foo)',
324    );
325
326    for my $shebang (@perl_shebangs) {
327        my $temp_file =
328            File::Temp->new( TEMPLATE => 'Perl-Critic.05_utils.t.XXXXX' );
329        my $filename = $temp_file->filename();
330        print {$temp_file} "$shebang\n";
331        # Must close to flush buffer
332        close $temp_file or confess "Couldn't close $temp_file: $OS_ERROR";
333
334        ok( Perl::Critic::Utils::_is_perl($filename), qq{Is perl: '$shebang'} );
335
336        my $document = PPI::Document->new(\$shebang);
337        is(
338            Perl::Critic::Utils::shebang_line($document),
339            $shebang,
340            qq<shebang_line($shebang)>,
341        );
342    }
343
344    my @not_perl_shebangs = (
345        'shazbot',
346        '#!/usr/bin/ruby',
347        '#!/bin/env python',
348    );
349
350    for my $shebang (@not_perl_shebangs) {
351        my $temp_file =
352            File::Temp->new( TEMPLATE => 'Perl-Critic.05_utils.t.XXXXX' );
353        my $filename = $temp_file->filename();
354        print {$temp_file} "$shebang\n";
355        # Must close to flush buffer
356        close $temp_file or confess "Couldn't close $temp_file: $OS_ERROR";
357
358        ok( ! Perl::Critic::Utils::_is_perl($filename), qq{Is not perl: '$shebang'} );
359
360        my $document = PPI::Document->new(\$shebang);
361        is(
362            Perl::Critic::Utils::shebang_line($document),
363            ($shebang eq 'shazbot' ? undef : $shebang),
364            qq<shebang_line($shebang)>,
365        );
366    }
367
368    return;
369}
370
371#-----------------------------------------------------------------------------
372
373sub test_is_backup {
374    for ( qw( foo.swp foo.bak foo~ ), '#foo#' ) {
375        ok( Perl::Critic::Utils::_is_backup($_), qq{Is backup: '$_'} );
376    }
377
378    for ( qw( swp.pm Bak ~foo ) ) {
379        ok( ! Perl::Critic::Utils::_is_backup($_), qq{Is not backup: '$_'} );
380    }
381
382    return;
383}
384
385#-----------------------------------------------------------------------------
386
387sub test_first_arg {
388    my @tests = (
389        q{eval { some_code() };}   => q{{ some_code() }},
390        q{eval( {some_code() } );} => q{{some_code() }},
391        q{eval();}                 => undef,
392    );
393
394    for (my $i = 0; $i < @tests; $i += 2) { ## no critic (ProhibitCStyleForLoops)
395        my $code = $tests[$i];
396        my $expect = $tests[$i+1];
397        my $doc = PPI::Document->new(\$code);
398        my $got = first_arg($doc->first_token());
399        is($got ? "$got" : undef, $expect, 'first_arg - '.$code);
400    }
401
402    return;
403}
404
405#-----------------------------------------------------------------------------
406
407sub test_parse_arg_list {
408    my @tests = (
409        [ q/foo($bar, 'baz', 1)/ => [ [ q<$bar> ],  [ q<'baz'> ],  [ q<1> ], ] ],
410        [
411                q/foo( { bar => 1 }, { bar => 1 }, 'blah' )/
412            =>  [
413                    [ '{ bar => 1 }' ],
414                    [ '{ bar => 1 }' ],
415                    [ q<'blah'> ],
416                ],
417        ],
418        [
419                q/foo( { bar() }, {}, 'blah' )/
420            =>  [
421                    [ '{ bar() }' ],
422                    [ qw< {} > ],
423                    [ q<'blah'> ],
424                ],
425        ],
426    );
427
428    foreach my $test (@tests) {
429        my ($code, $expected) = @{ $test };
430
431        my $document = PPI::Document->new( \$code );
432        my @got = parse_arg_list( $document->first_token() );
433        is_deeply( \@got, $expected, "parse_arg_list: $code" );
434    }
435
436    return;
437}
438
439#-----------------------------------------------------------------------------
440
441sub test_is_function_call {
442    my $code = 'sub foo{}';
443    my $doc = PPI::Document->new( \$code );
444    my $words = $doc->find('PPI::Token::Word');
445    is(scalar @{$words}, 2, 'count PPI::Token::Words');
446    is((scalar grep {is_function_call($_)} @{$words}), 0, 'is_function_call');
447
448    return;
449}
450
451#-----------------------------------------------------------------------------
452
453sub test_find_bundled_policies {
454    Perl::Critic::TestUtils::block_perlcriticrc();
455
456    my @native_policies = bundled_policy_names();
457    my $policy_dir = File::Spec->catfile( qw(lib Perl Critic Policy) );
458    my @found_policies  = all_perl_files( $policy_dir );
459    is( scalar @found_policies, scalar @native_policies, 'Find all perl code');
460
461    return;
462}
463
464#-----------------------------------------------------------------------------
465sub test_is_unchecked_call {
466    my @trials = (
467        # just an obvious failure to check the return value
468        {
469            code => q[ open( $fh, $mode, $filename ); ],
470            pass => 1,
471        },
472        # check the value with a trailing conditional
473        {
474            code => q[ open( $fh, $mode, $filename ) or confess 'unable to open'; ],
475            pass => 0,
476        },
477        # assign the return value to a variable (and assume that it's checked later)
478        {
479            code => q[ my $error = open( $fh, $mode, $filename ); ],
480            pass => 0,
481        },
482        # the system call is in a conditional
483        {
484            code => q[ return $EMPTY if not open my $fh, '<', $file; ],
485            pass => 0,
486        },
487        # open call in list context, checked with 'not'
488        {
489            code => q[ return $EMPTY if not ( open my $fh, '<', $file ); ],
490            pass => 0,
491        },
492        # just putting the system call in a list context doesn't mean the return value is checked
493        {
494            code => q[ ( open my $fh, '<', $file ); ],
495            pass => 1,
496        },
497
498        # Check Fatal.
499        {
500            code => q[ use Fatal qw< open >; open( $fh, $mode, $filename ); ],
501            pass => 0,
502        },
503        {
504            code => q[ use Fatal qw< open >; ( open my $fh, '<', $file ); ],
505            pass => 0,
506        },
507
508        # Check Fatal::Exception.
509        {
510            code => q[ use Fatal::Exception 'Exception::System' => qw< open close >; open( $fh, $mode, $filename ); ],
511            pass => 0,
512        },
513        {
514            code => q[ use Fatal::Exception 'Exception::System' => qw< open close >; ( open my $fh, '<', $file ); ],
515            pass => 0,
516        },
517
518        # Check autodie.
519        {
520            code => q[ use autodie; open( $fh, $mode, $filename ); ],
521            pass => 0,
522        },
523        {
524            code => q[ use autodie qw< :io >; open( $fh, $mode, $filename ); ],
525            pass => 0,
526        },
527        {
528            code => q[ use autodie qw< :system >; ( open my $fh, '<', $file ); ],
529            pass => 1,
530        },
531        {
532            code => q[ use autodie qw< :system :file >; ( open my $fh, '<', $file ); ],
533            pass => 0,
534        },
535    );
536
537    foreach my $trial ( @trials ) {
538        my $code = $trial->{'code'};
539        my $doc = make_doc( $code );
540        my $statement = $doc->find_first( sub { $_[1] eq 'open' } );
541        if ( $trial->{'pass'} ) {
542            ok( is_unchecked_call( $statement ), qq<is_unchecked_call returns true for "$code".> );
543        } else {
544            ok( ! is_unchecked_call( $statement ), qq<is_unchecked_call returns false for "$code".> );
545        }
546    }
547
548    return;
549}
550
551# Local Variables:
552#   mode: cperl
553#   cperl-indent-level: 4
554#   fill-column: 78
555#   indent-tabs-mode: nil
556#   c-indentation-style: bsd
557# End:
558# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
559