git.maemo.org Git - pkg-perl/blob - deb-src/libperl-critic-perl/libperl-critic-perl-1.088/t/05_utils.t

   1 #!perl
   2
   3 ##############################################################################
   4 #      $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/05_utils.t $
   5 #     $Date: 2008-06-06 00:48:04 -0500 (Fri, 06 Jun 2008) $
   6 #   $Author: clonezone $
   7 # $Revision: 2416 $
   8 ##############################################################################
   9
  10 use 5.006001;
  11 use strict;
  12 use warnings;
  13
  14 use PPI::Document;
  15
  16 use Test::More tests => 115;
  17
  18 #-----------------------------------------------------------------------------
  19
  20 BEGIN
  21 {
  22     # Needs to be in BEGIN for global vars
  23     use_ok('Perl::Critic::Utils', qw{ :all } );
  24 }
  25
  26 #-----------------------------------------------------------------------------
  27 #  export tests
  28
  29 can_ok('main', 'all_perl_files');
  30 can_ok('main', 'find_keywords');
  31 can_ok('main', 'interpolate');
  32 can_ok('main', 'is_hash_key');
  33 can_ok('main', 'is_method_call');
  34 can_ok('main', 'is_perl_builtin');
  35 can_ok('main', 'is_perl_global');
  36 can_ok('main', 'is_script');
  37 can_ok('main', 'is_subroutine_name');
  38 can_ok('main', 'first_arg');
  39 can_ok('main', 'parse_arg_list');
  40 can_ok('main', 'policy_long_name');
  41 can_ok('main', 'policy_short_name');
  42 can_ok('main', 'precedence_of');
  43 can_ok('main', 'severity_to_number');
  44 can_ok('main', 'shebang_line');
  45 can_ok('main', 'verbosity_to_format');
  46 can_ok('main', 'is_unchecked_call');
  47
  48 is($SPACE, ' ', 'character constants');
  49 is($SEVERITY_LOWEST, 1, 'severity constants');
  50 is($POLICY_NAMESPACE, 'Perl::Critic::Policy', 'Policy namespace');
  51
  52 #-----------------------------------------------------------------------------
  53 #  find_keywords tests
  54
  55 sub count_matches { my $val = shift; return defined $val ? scalar @$val : 0; }
  56 sub make_doc { my $code = shift; return PPI::Document->new( ref $code ? $code : \$code); }
  57
  58 {
  59     my $doc = PPI::Document->new(); #Empty doc
  60     is( count_matches( find_keywords($doc, 'return') ), 0, 'find_keywords, no doc' );
  61
  62     my $code = 'return;';
  63     $doc = make_doc( $code );
  64     is( count_matches( find_keywords($doc, 'return') ), 1, 'find_keywords, find 1');
  65
  66     $code = 'sub foo { }';
  67     $doc = make_doc( $code );
  68     is( count_matches( find_keywords($doc, 'return') ), 0, 'find_keywords, find 0');
  69
  70     $code = 'sub foo { return 1; }';
  71     $doc = make_doc( $code );
  72     is( count_matches( find_keywords($doc, 'return') ), 1, 'find_keywords, find 1');
  73
  74     $code = 'sub foo { return 0 if @_; return 1; }';
  75     $doc = make_doc( $code );
  76     is( count_matches( find_keywords($doc, 'return') ), 2, 'find_keywords, find 2');
  77 }
  78
  79 #-----------------------------------------------------------------------------
  80 #  is_hash_key tests
  81
  82 {
  83    my $code = 'sub foo { return $h1{bar}, $h2->{baz}, $h3->{ nuts() } }';
  84    my $doc = PPI::Document->new(\$code);
  85    my @words = @{$doc->find('PPI::Token::Word')};
  86    my @expect = (
  87       ['sub', undef],
  88       ['foo', undef],
  89       ['return', undef],
  90       ['bar', 1],
  91       ['baz', 1],
  92       ['nuts', undef],
  93    );
  94    is(scalar @words, scalar @expect, 'is_hash_key count');
  95    for my $i (0 .. $#expect)
  96    {
  97       is($words[$i], $expect[$i][0], 'is_hash_key word');
  98       is(is_hash_key($words[$i]), $expect[$i][1], 'is_hash_key boolean');
  99    }
 100 }
 101
 102 #-----------------------------------------------------------------------------
 103 #  is_script tests
 104
 105 my @good = (
 106     "#!perl\n",
 107     "#! perl\n",
 108     "#!/usr/bin/perl -w\n",
 109     "#!C:\\Perl\\bin\\perl\n",
 110     "#!/bin/sh\n",
 111 );
 112
 113 my @bad = (
 114     "package Foo;\n",
 115     "\n#!perl\n",
 116 );
 117
 118 for my $code (@good) {
 119     my $doc = PPI::Document->new(\$code) || die;
 120     $doc->index_locations();
 121     ok(is_script($doc), 'is_script, true');
 122 }
 123
 124 for my $code (@bad) {
 125     my $doc = PPI::Document->new(\$code) || die;
 126     $doc->index_locations();
 127     ok(!is_script($doc), 'is_script, false');
 128 }
 129
 130 #-----------------------------------------------------------------------------
 131 # is_perl_builtin tests
 132
 133 {
 134     is(   is_perl_builtin('print'),  1, 'Is perl builtin function'     );
 135     isnt( is_perl_builtin('foobar'), 1, 'Is not perl builtin function' );
 136
 137     my $code = 'sub print {}';
 138     my $doc = make_doc( $code );
 139     my $sub = $doc->find_first('Statement::Sub');
 140     is( is_perl_builtin($sub), 1, 'Is perl builtin function (PPI)' );
 141
 142     $code = 'sub foobar {}';
 143     $doc = make_doc( $code );
 144     $sub = $doc->find_first('Statement::Sub');
 145     isnt( is_perl_builtin($sub), 1, 'Is not perl builtin function (PPI)' );
 146
 147 }
 148
 149 #-----------------------------------------------------------------------------
 150 # is_perl_global tests
 151
 152 {
 153     is(   is_perl_global('$OSNAME'),  1, '$OSNAME is a perl global var'     );
 154     is(   is_perl_global('*STDOUT'),  1, '*STDOUT is a perl global var'     );
 155     isnt( is_perl_global('%FOOBAR'),  1, '%FOOBAR is a not perl global var' );
 156
 157     my $code = '$OSNAME';
 158     my $doc  = make_doc($code);
 159     my $var  = $doc->find_first('Token::Symbol');
 160     is( is_perl_global($var), 1, '$OSNAME is perl a global var (PPI)' );
 161
 162     $code = '*STDOUT';
 163     $doc  = make_doc($code);
 164     $var  = $doc->find_first('Token::Symbol');
 165     is( is_perl_global($var), 1, '*STDOUT is perl a global var (PPI)' );
 166
 167     $code = '%FOOBAR';
 168     $doc  = make_doc($code);
 169     $var  = $doc->find_first('Token::Symbol');
 170     isnt( is_perl_global($var), 1, '%FOOBAR is not a perl global var (PPI)' );
 171
 172 }
 173
 174 #-----------------------------------------------------------------------------
 175 # precedence_of tests
 176
 177 {
 178
 179     cmp_ok( precedence_of('*'), '<', precedence_of('+'), 'Precedence' );
 180
 181     my $code1 = '8 + 5';
 182     my $doc1  = make_doc($code1);
 183     my $op1   = $doc1->find_first('Token::Operator');
 184
 185     my $code2 = '7 * 5';
 186     my $doc2  = make_doc($code2);
 187     my $op2   = $doc2->find_first('Token::Operator');
 188
 189     cmp_ok( precedence_of($op2), '<', precedence_of($op1), 'Precedence (PPI)' );
 190
 191 }
 192
 193 #-----------------------------------------------------------------------------
 194 # is_subroutine_name tests
 195
 196 {
 197
 198     my $code = 'sub foo {}';
 199     my $doc  = make_doc( $code );
 200     my $word = $doc->find_first( sub { $_[1] eq 'foo' } );
 201     is( is_subroutine_name( $word ), 1, 'Is a subroutine name');
 202
 203     $code = '$bar = foo()';
 204     $doc  = make_doc( $code );
 205     $word = $doc->find_first( sub { $_[1] eq 'foo' } );
 206     isnt( is_subroutine_name( $word ), 1, 'Is not a subroutine name');
 207
 208 }
 209
 210 #-----------------------------------------------------------------------------
 211 # policy_long_name and policy_short_name tests
 212
 213 {
 214     my $short_name = 'Baz::Nuts';
 215     my $long_name  = "${POLICY_NAMESPACE}::$short_name";
 216     is( policy_long_name(  $short_name ), $long_name,  'policy_long_name'  );
 217     is( policy_long_name(  $long_name  ), $long_name,  'policy_long_name'  );
 218     is( policy_short_name( $short_name ), $short_name, 'policy_short_name' );
 219     is( policy_short_name( $long_name  ), $short_name, 'policy_short_name' );
 220 }
 221
 222 #-----------------------------------------------------------------------------
 223 # interpolate() tests
 224
 225 is( interpolate( '\r%l\t%c\n' ), "\r%l\t%c\n", 'Interpolation' );
 226 is( interpolate( 'literal'    ), "literal",    'Interpolation' );
 227
 228
 229 #-----------------------------------------------------------------------------
 230 # Test _is_perl() and shebang_line() subroutines.
 231
 232 {
 233     for ( qw(foo.t foo.pm foo.pl foo.PL) ) {
 234         ok( Perl::Critic::Utils::_is_perl($_), qq{Is perl: '$_'} );
 235     }
 236
 237     for ( qw(foo.doc foo.txt foo.conf foo) ) {
 238         ok( ! Perl::Critic::Utils::_is_perl($_), qq{Is not perl: '$_'} );
 239     }
 240
 241     use File::Temp qw<tempfile>;
 242
 243     my @perl_shebangs = (
 244         '#!perl',
 245         '#!/usr/local/bin/perl',
 246         '#!/usr/local/bin/perl-5.8',
 247         '#!/bin/env perl',
 248         '#!perl ## no critic',
 249         '#!perl ## no critic (foo)',
 250     );
 251
 252     for my $shebang (@perl_shebangs) {
 253         my ($fh, $filename) = tempfile() or die 'Could not open tempfile';
 254         print {$fh} "$shebang\n"; close $fh; # Must close to flush buffer
 255         ok( Perl::Critic::Utils::_is_perl($filename), qq{Is perl: '$shebang'});
 256
 257         my $document = PPI::Document->new(\$shebang);
 258         is(
 259             Perl::Critic::Utils::shebang_line($document),
 260             $shebang,
 261             qq<shebang_line($shebang)>,
 262         );
 263     }
 264
 265     my @not_perl_shebangs = (
 266         'shazbot',
 267         '#!/usr/bin/ruby',
 268         '#!/bin/env python',
 269     );
 270
 271     for my $shebang (@not_perl_shebangs) {
 272         my ($fh, $filename) = tempfile or die 'Could not open tempfile';
 273         print {$fh} "$shebang\n"; close $fh; # Must close to flush buffer
 274         ok( ! Perl::Critic::Utils::_is_perl($filename), qq{Is not perl: '$shebang'});
 275
 276         my $document = PPI::Document->new(\$shebang);
 277         is(
 278             Perl::Critic::Utils::shebang_line($document),
 279             ($shebang eq 'shazbot' ? undef : $shebang),
 280             qq<shebang_line($shebang)>,
 281         );
 282     }
 283 }
 284
 285 #-----------------------------------------------------------------------------
 286 # _is_backup() tests
 287
 288 {
 289     for ( qw( foo.swp foo.bak foo~ ), '#foo#' ) {
 290         ok( Perl::Critic::Utils::_is_backup($_), qq{Is backup: '$_'} );
 291     }
 292
 293     for ( qw( swp.pm Bak ~foo ) ) {
 294         ok( ! Perl::Critic::Utils::_is_backup($_), qq{Is not backup: '$_'} );
 295     }
 296 }
 297
 298 #-----------------------------------------------------------------------------
 299 # first_arg tests
 300
 301 {
 302     my @tests = (
 303         q{eval { some_code() };}   => q{{ some_code() }},
 304         q{eval( {some_code() } );} => q{{some_code() }},
 305         q{eval();}                 => undef,
 306     );
 307
 308     for (my $i = 0; $i < @tests; $i += 2) {
 309         my $code = $tests[$i];
 310         my $expect = $tests[$i+1];
 311         my $doc = PPI::Document->new(\$code);
 312         my $got = first_arg($doc->first_token());
 313         is($got ? "$got" : undef, $expect, 'first_arg - '.$code);
 314     }
 315 }
 316
 317 #-----------------------------------------------------------------------------
 318 # parse_arg_list tests
 319
 320 {
 321     my @tests = (
 322         [ q/foo($bar, 'baz', 1)/ => [ [ q<$bar> ],  [ q<'baz'> ],  [ q<1> ], ] ],
 323         [
 324                 q/foo( { bar => 1 }, { bar => 1 }, 'blah' )/
 325             =>  [
 326                     [ '{ bar => 1 }' ],
 327                     [ '{ bar => 1 }' ],
 328                     [ q<'blah'> ],
 329                 ],
 330         ],
 331         [
 332                 q/foo( { bar() }, {}, 'blah' )/
 333             =>  [
 334                     ' { bar() }',
 335                     [ qw< {} > ],
 336                     [ q<'blah'> ],
 337                 ],
 338         ],
 339     );
 340
 341     foreach my $test (@tests) {
 342         my ($code, $expected) = @{ $test };
 343
 344         my $document = PPI::Document->new( \$code );
 345         my @got = parse_arg_list( $document->first_token() );
 346         is_deeply( \@got, $expected, "parse_arg_list: $code" );
 347     }
 348 }
 349
 350 #-----------------------------------------------------------------------------
 351
 352 {
 353     my $code = 'sub foo{}';
 354     my $doc = PPI::Document->new( \$code );
 355     my $words = $doc->find('PPI::Token::Word');
 356     is(scalar @{$words}, 2, 'count PPI::Token::Words');
 357     is((scalar grep {is_function_call($_)} @{$words}), 0, 'is_function_call');
 358 }
 359
 360 #-----------------------------------------------------------------------------
 361
 362
 363 use Perl::Critic::PolicyFactory;
 364 use Perl::Critic::TestUtils qw(bundled_policy_names);
 365 Perl::Critic::TestUtils::block_perlcriticrc();
 366
 367
 368 my @native_policies = bundled_policy_names();
 369 my $policy_dir = File::Spec->catfile( qw(lib Perl Critic Policy) );
 370 my @found_policies  = all_perl_files( $policy_dir );
 371 is( scalar @found_policies, scalar @native_policies, 'Find all perl code');
 372
 373 #-----------------------------------------------------------------------------
 374 # is_unchecked_call tests
 375 {
 376     my @trials = (
 377                   # just an obvious failure to check the return value
 378                   { code => q( open( $fh, $mode, $filename ); ),
 379                     pass => 1 },
 380                   # check the value with a trailing conditional
 381                   { code => q( open( $fh, $mode, $filename ) or die 'unable to open'; ),
 382                     pass => 0 },
 383                   # assign the return value to a variable (and assume that it's checked later)
 384                   { code => q( my $error = open( $fh, $mode, $filename ); ),
 385                     pass => 0 },
 386                   # the system call is in a conditional
 387                   { code => q( return $EMPTY if not open my $fh, '<', $file; ),
 388                     pass => 0 },
 389                   # open call in list context, checked with 'not'
 390                   { code => q( return $EMPTY if not ( open my $fh, '<', $file ); ),
 391                     pass => 0 },
 392                   # just putting the system call in a list context doesn't mean the return value is checked
 393                   { code => q( ( open my $fh, '<', $file ); ),
 394                     pass => 1 },
 395                  );
 396
 397     foreach my $trial ( @trials ) {
 398         my $doc = make_doc( $trial->{'code'} );
 399         my $statement = $doc->find_first( sub { $_[1] eq 'open' } );
 400         if ( $trial->{'pass'} ) {
 401             ok( is_unchecked_call( $statement ), 'is_unchecked_call returns true' );
 402         } else {
 403             ok( ! is_unchecked_call( $statement ), 'is_unchecked_call returns false' );
 404         }
 405     }
 406 }
 407
 408 #-----------------------------------------------------------------------------
 409
 410 # ensure we run true if this test is loaded by
 411 # t/05_utils.t_without_optional_dependencies.t
 412 1;
 413
 414 # Local Variables:
 415 #   mode: cperl
 416 #   cperl-indent-level: 4
 417 #   fill-column: 78
 418 #   indent-tabs-mode: nil
 419 #   c-indentation-style: bsd
 420 # End:
 421 # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :