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