#!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 :