--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/05_utils.t $
+# $Date: 2008-06-06 00:48:04 -0500 (Fri, 06 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2416 $
+##############################################################################
+
+use 5.006001;
+use strict;
+use warnings;
+
+use PPI::Document;
+
+use Test::More tests => 115;
+
+#-----------------------------------------------------------------------------
+
+BEGIN
+{
+ # Needs to be in BEGIN for global vars
+ use_ok('Perl::Critic::Utils', qw{ :all } );
+}
+
+#-----------------------------------------------------------------------------
+# export tests
+
+can_ok('main', 'all_perl_files');
+can_ok('main', 'find_keywords');
+can_ok('main', 'interpolate');
+can_ok('main', 'is_hash_key');
+can_ok('main', 'is_method_call');
+can_ok('main', 'is_perl_builtin');
+can_ok('main', 'is_perl_global');
+can_ok('main', 'is_script');
+can_ok('main', 'is_subroutine_name');
+can_ok('main', 'first_arg');
+can_ok('main', 'parse_arg_list');
+can_ok('main', 'policy_long_name');
+can_ok('main', 'policy_short_name');
+can_ok('main', 'precedence_of');
+can_ok('main', 'severity_to_number');
+can_ok('main', 'shebang_line');
+can_ok('main', 'verbosity_to_format');
+can_ok('main', 'is_unchecked_call');
+
+is($SPACE, ' ', 'character constants');
+is($SEVERITY_LOWEST, 1, 'severity constants');
+is($POLICY_NAMESPACE, 'Perl::Critic::Policy', 'Policy namespace');
+
+#-----------------------------------------------------------------------------
+# find_keywords tests
+
+sub count_matches { my $val = shift; return defined $val ? scalar @$val : 0; }
+sub make_doc { my $code = shift; return PPI::Document->new( ref $code ? $code : \$code); }
+
+{
+ my $doc = PPI::Document->new(); #Empty doc
+ is( count_matches( find_keywords($doc, 'return') ), 0, 'find_keywords, no doc' );
+
+ my $code = 'return;';
+ $doc = make_doc( $code );
+ is( count_matches( find_keywords($doc, 'return') ), 1, 'find_keywords, find 1');
+
+ $code = 'sub foo { }';
+ $doc = make_doc( $code );
+ is( count_matches( find_keywords($doc, 'return') ), 0, 'find_keywords, find 0');
+
+ $code = 'sub foo { return 1; }';
+ $doc = make_doc( $code );
+ is( count_matches( find_keywords($doc, 'return') ), 1, 'find_keywords, find 1');
+
+ $code = 'sub foo { return 0 if @_; return 1; }';
+ $doc = make_doc( $code );
+ is( count_matches( find_keywords($doc, 'return') ), 2, 'find_keywords, find 2');
+}
+
+#-----------------------------------------------------------------------------
+# is_hash_key tests
+
+{
+ my $code = 'sub foo { return $h1{bar}, $h2->{baz}, $h3->{ nuts() } }';
+ my $doc = PPI::Document->new(\$code);
+ my @words = @{$doc->find('PPI::Token::Word')};
+ my @expect = (
+ ['sub', undef],
+ ['foo', undef],
+ ['return', undef],
+ ['bar', 1],
+ ['baz', 1],
+ ['nuts', undef],
+ );
+ is(scalar @words, scalar @expect, 'is_hash_key count');
+ for my $i (0 .. $#expect)
+ {
+ is($words[$i], $expect[$i][0], 'is_hash_key word');
+ is(is_hash_key($words[$i]), $expect[$i][1], 'is_hash_key boolean');
+ }
+}
+
+#-----------------------------------------------------------------------------
+# is_script tests
+
+my @good = (
+ "#!perl\n",
+ "#! perl\n",
+ "#!/usr/bin/perl -w\n",
+ "#!C:\\Perl\\bin\\perl\n",
+ "#!/bin/sh\n",
+);
+
+my @bad = (
+ "package Foo;\n",
+ "\n#!perl\n",
+);
+
+for my $code (@good) {
+ my $doc = PPI::Document->new(\$code) || die;
+ $doc->index_locations();
+ ok(is_script($doc), 'is_script, true');
+}
+
+for my $code (@bad) {
+ my $doc = PPI::Document->new(\$code) || die;
+ $doc->index_locations();
+ ok(!is_script($doc), 'is_script, false');
+}
+
+#-----------------------------------------------------------------------------
+# is_perl_builtin tests
+
+{
+ is( is_perl_builtin('print'), 1, 'Is perl builtin function' );
+ isnt( is_perl_builtin('foobar'), 1, 'Is not perl builtin function' );
+
+ my $code = 'sub print {}';
+ my $doc = make_doc( $code );
+ my $sub = $doc->find_first('Statement::Sub');
+ is( is_perl_builtin($sub), 1, 'Is perl builtin function (PPI)' );
+
+ $code = 'sub foobar {}';
+ $doc = make_doc( $code );
+ $sub = $doc->find_first('Statement::Sub');
+ isnt( is_perl_builtin($sub), 1, 'Is not perl builtin function (PPI)' );
+
+}
+
+#-----------------------------------------------------------------------------
+# is_perl_global tests
+
+{
+ is( is_perl_global('$OSNAME'), 1, '$OSNAME is a perl global var' );
+ is( is_perl_global('*STDOUT'), 1, '*STDOUT is a perl global var' );
+ isnt( is_perl_global('%FOOBAR'), 1, '%FOOBAR is a not perl global var' );
+
+ my $code = '$OSNAME';
+ my $doc = make_doc($code);
+ my $var = $doc->find_first('Token::Symbol');
+ is( is_perl_global($var), 1, '$OSNAME is perl a global var (PPI)' );
+
+ $code = '*STDOUT';
+ $doc = make_doc($code);
+ $var = $doc->find_first('Token::Symbol');
+ is( is_perl_global($var), 1, '*STDOUT is perl a global var (PPI)' );
+
+ $code = '%FOOBAR';
+ $doc = make_doc($code);
+ $var = $doc->find_first('Token::Symbol');
+ isnt( is_perl_global($var), 1, '%FOOBAR is not a perl global var (PPI)' );
+
+}
+
+#-----------------------------------------------------------------------------
+# precedence_of tests
+
+{
+
+ cmp_ok( precedence_of('*'), '<', precedence_of('+'), 'Precedence' );
+
+ my $code1 = '8 + 5';
+ my $doc1 = make_doc($code1);
+ my $op1 = $doc1->find_first('Token::Operator');
+
+ my $code2 = '7 * 5';
+ my $doc2 = make_doc($code2);
+ my $op2 = $doc2->find_first('Token::Operator');
+
+ cmp_ok( precedence_of($op2), '<', precedence_of($op1), 'Precedence (PPI)' );
+
+}
+
+#-----------------------------------------------------------------------------
+# is_subroutine_name tests
+
+{
+
+ my $code = 'sub foo {}';
+ my $doc = make_doc( $code );
+ my $word = $doc->find_first( sub { $_[1] eq 'foo' } );
+ is( is_subroutine_name( $word ), 1, 'Is a subroutine name');
+
+ $code = '$bar = foo()';
+ $doc = make_doc( $code );
+ $word = $doc->find_first( sub { $_[1] eq 'foo' } );
+ isnt( is_subroutine_name( $word ), 1, 'Is not a subroutine name');
+
+}
+
+#-----------------------------------------------------------------------------
+# policy_long_name and policy_short_name tests
+
+{
+ my $short_name = 'Baz::Nuts';
+ my $long_name = "${POLICY_NAMESPACE}::$short_name";
+ is( policy_long_name( $short_name ), $long_name, 'policy_long_name' );
+ is( policy_long_name( $long_name ), $long_name, 'policy_long_name' );
+ is( policy_short_name( $short_name ), $short_name, 'policy_short_name' );
+ is( policy_short_name( $long_name ), $short_name, 'policy_short_name' );
+}
+
+#-----------------------------------------------------------------------------
+# interpolate() tests
+
+is( interpolate( '\r%l\t%c\n' ), "\r%l\t%c\n", 'Interpolation' );
+is( interpolate( 'literal' ), "literal", 'Interpolation' );
+
+
+#-----------------------------------------------------------------------------
+# Test _is_perl() and shebang_line() subroutines.
+
+{
+ for ( qw(foo.t foo.pm foo.pl foo.PL) ) {
+ ok( Perl::Critic::Utils::_is_perl($_), qq{Is perl: '$_'} );
+ }
+
+ for ( qw(foo.doc foo.txt foo.conf foo) ) {
+ ok( ! Perl::Critic::Utils::_is_perl($_), qq{Is not perl: '$_'} );
+ }
+
+ use File::Temp qw<tempfile>;
+
+ my @perl_shebangs = (
+ '#!perl',
+ '#!/usr/local/bin/perl',
+ '#!/usr/local/bin/perl-5.8',
+ '#!/bin/env perl',
+ '#!perl ## no critic',
+ '#!perl ## no critic (foo)',
+ );
+
+ for my $shebang (@perl_shebangs) {
+ my ($fh, $filename) = tempfile() or die 'Could not open tempfile';
+ print {$fh} "$shebang\n"; close $fh; # Must close to flush buffer
+ ok( Perl::Critic::Utils::_is_perl($filename), qq{Is perl: '$shebang'});
+
+ my $document = PPI::Document->new(\$shebang);
+ is(
+ Perl::Critic::Utils::shebang_line($document),
+ $shebang,
+ qq<shebang_line($shebang)>,
+ );
+ }
+
+ my @not_perl_shebangs = (
+ 'shazbot',
+ '#!/usr/bin/ruby',
+ '#!/bin/env python',
+ );
+
+ for my $shebang (@not_perl_shebangs) {
+ my ($fh, $filename) = tempfile or die 'Could not open tempfile';
+ print {$fh} "$shebang\n"; close $fh; # Must close to flush buffer
+ ok( ! Perl::Critic::Utils::_is_perl($filename), qq{Is not perl: '$shebang'});
+
+ my $document = PPI::Document->new(\$shebang);
+ is(
+ Perl::Critic::Utils::shebang_line($document),
+ ($shebang eq 'shazbot' ? undef : $shebang),
+ qq<shebang_line($shebang)>,
+ );
+ }
+}
+
+#-----------------------------------------------------------------------------
+# _is_backup() tests
+
+{
+ for ( qw( foo.swp foo.bak foo~ ), '#foo#' ) {
+ ok( Perl::Critic::Utils::_is_backup($_), qq{Is backup: '$_'} );
+ }
+
+ for ( qw( swp.pm Bak ~foo ) ) {
+ ok( ! Perl::Critic::Utils::_is_backup($_), qq{Is not backup: '$_'} );
+ }
+}
+
+#-----------------------------------------------------------------------------
+# first_arg tests
+
+{
+ my @tests = (
+ q{eval { some_code() };} => q{{ some_code() }},
+ q{eval( {some_code() } );} => q{{some_code() }},
+ q{eval();} => undef,
+ );
+
+ for (my $i = 0; $i < @tests; $i += 2) {
+ my $code = $tests[$i];
+ my $expect = $tests[$i+1];
+ my $doc = PPI::Document->new(\$code);
+ my $got = first_arg($doc->first_token());
+ is($got ? "$got" : undef, $expect, 'first_arg - '.$code);
+ }
+}
+
+#-----------------------------------------------------------------------------
+# parse_arg_list tests
+
+{
+ my @tests = (
+ [ q/foo($bar, 'baz', 1)/ => [ [ q<$bar> ], [ q<'baz'> ], [ q<1> ], ] ],
+ [
+ q/foo( { bar => 1 }, { bar => 1 }, 'blah' )/
+ => [
+ [ '{ bar => 1 }' ],
+ [ '{ bar => 1 }' ],
+ [ q<'blah'> ],
+ ],
+ ],
+ [
+ q/foo( { bar() }, {}, 'blah' )/
+ => [
+ ' { bar() }',
+ [ qw< {} > ],
+ [ q<'blah'> ],
+ ],
+ ],
+ );
+
+ foreach my $test (@tests) {
+ my ($code, $expected) = @{ $test };
+
+ my $document = PPI::Document->new( \$code );
+ my @got = parse_arg_list( $document->first_token() );
+ is_deeply( \@got, $expected, "parse_arg_list: $code" );
+ }
+}
+
+#-----------------------------------------------------------------------------
+
+{
+ my $code = 'sub foo{}';
+ my $doc = PPI::Document->new( \$code );
+ my $words = $doc->find('PPI::Token::Word');
+ is(scalar @{$words}, 2, 'count PPI::Token::Words');
+ is((scalar grep {is_function_call($_)} @{$words}), 0, 'is_function_call');
+}
+
+#-----------------------------------------------------------------------------
+
+
+use Perl::Critic::PolicyFactory;
+use Perl::Critic::TestUtils qw(bundled_policy_names);
+Perl::Critic::TestUtils::block_perlcriticrc();
+
+
+my @native_policies = bundled_policy_names();
+my $policy_dir = File::Spec->catfile( qw(lib Perl Critic Policy) );
+my @found_policies = all_perl_files( $policy_dir );
+is( scalar @found_policies, scalar @native_policies, 'Find all perl code');
+
+#-----------------------------------------------------------------------------
+# is_unchecked_call tests
+{
+ my @trials = (
+ # just an obvious failure to check the return value
+ { code => q( open( $fh, $mode, $filename ); ),
+ pass => 1 },
+ # check the value with a trailing conditional
+ { code => q( open( $fh, $mode, $filename ) or die 'unable to open'; ),
+ pass => 0 },
+ # assign the return value to a variable (and assume that it's checked later)
+ { code => q( my $error = open( $fh, $mode, $filename ); ),
+ pass => 0 },
+ # the system call is in a conditional
+ { code => q( return $EMPTY if not open my $fh, '<', $file; ),
+ pass => 0 },
+ # open call in list context, checked with 'not'
+ { code => q( return $EMPTY if not ( open my $fh, '<', $file ); ),
+ pass => 0 },
+ # just putting the system call in a list context doesn't mean the return value is checked
+ { code => q( ( open my $fh, '<', $file ); ),
+ pass => 1 },
+ );
+
+ foreach my $trial ( @trials ) {
+ my $doc = make_doc( $trial->{'code'} );
+ my $statement = $doc->find_first( sub { $_[1] eq 'open' } );
+ if ( $trial->{'pass'} ) {
+ ok( is_unchecked_call( $statement ), 'is_unchecked_call returns true' );
+ } else {
+ ok( ! is_unchecked_call( $statement ), 'is_unchecked_call returns false' );
+ }
+ }
+}
+
+#-----------------------------------------------------------------------------
+
+# ensure we run true if this test is loaded by
+# t/05_utils.t_without_optional_dependencies.t
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
projects / dh-make-perl / blobdiff