#!perl

## There's too much use of source code in strings.
## no critic (RequireInterpolationOfMetachars)

use 5.010001;
use strict;
use warnings;

use English qw< -no_match_vars >;
use Carp qw< confess >;
use List::SomeUtils qw(any);

use File::Temp qw< >;
use PPI::Document qw< >;
use PPI::Document::File qw< >;

use Perl::Critic::PolicyFactory;
use Perl::Critic::TestUtils qw(bundled_policy_names);
use Perl::Critic::Utils;

use Test::More tests => 186;

our $VERSION = '1.156';

use Perl::Critic::TestUtils;
Perl::Critic::TestUtils::assert_version( $VERSION );

test_export();
test_find_keywords();
test_is_assignment_operator();
test_is_hash_key();
test_is_script();
test_is_script_with_PL_files();
test_is_perl_builtin();
test_is_perl_bareword();
test_is_perl_global();
test_precedence_of();
test_is_subroutine_name();
test_policy_long_name_and_policy_short_name();
test_interpolate();
test_is_perl_and_shebang_line();
test_is_backup();
test_first_arg();
test_parse_arg_list();
test_is_function_call();
test_find_bundled_policies();
test_is_unchecked_call();

#-----------------------------------------------------------------------------

sub test_export {
    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_bareword');
    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, q< >, 'character constants');
    is($SEVERITY_LOWEST, 1, 'severity constants');
    is($POLICY_NAMESPACE, 'Perl::Critic::Policy', 'Policy namespace');

    return;
}

#-----------------------------------------------------------------------------

sub count_matches { my $val = shift; return defined $val ? scalar @{$val} : 0; }
sub make_doc {
    my $code = shift;
    return
        Perl::Critic::Document->new('-source' => ref $code ? $code : \$code);
}

sub test_find_keywords {
    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');

    return;
}

#-----------------------------------------------------------------------------

sub test_is_assignment_operator {
    for ( qw( = **= += -= .= *= /= %= x= &= |= ^= <<= >>= &&= ||= //= ) ) {
        is( is_assignment_operator($_), 1, "$_ is an assignment operator" );
    }

    for ( qw( == != =~ >= <= + - * / % x bogus= ) ) {
        is( !!is_assignment_operator($_), q{}, "$_ is not an assignment operator" );
    }

    return;
}

#-----------------------------------------------------------------------------

sub test_is_hash_key {
    my $code = <<'PERL';
sub foo {
    return
        $h1{bar},
        $h2->{baz},
        $h3->{ nuts() },
        @h4{a, b(), c},
        $h5{ my_fun @args }
    ;
}
my %h6 = ( d => e, f, g )'
PERL

    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],
        ['a', 1],
        ['b', undef],
        ['c', 1],
        ['my_fun', undef],
        ['my', undef],
        ['d', 1],
        ['e', undef],
        ['f', undef],
        ['g', 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: ' . $words[$i] );
    }

    return;
}

#-----------------------------------------------------------------------------

sub test_is_script {
    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",
    );

    no warnings qw< deprecated >;   ## no critic (TestingAndDebugging::ProhibitNoWarnings)

    for my $code (@good) {
        my $doc = PPI::Document->new(\$code) or confess;
        $doc->index_locations();
        ok(is_script($doc), 'is_script, true');
    }

    for my $code (@bad) {
        my $doc = PPI::Document->new(\$code) or confess;
        $doc->index_locations();
        ok(!is_script($doc), 'is_script, false');
    }

    return;
}

#-----------------------------------------------------------------------------

sub test_is_script_with_PL_files { ## no critic (NamingConventions::Capitalization)

    # Testing for .PL files (e.g. Makefile.PL, Build.PL)
    # See http://rt.cpan.org/Ticket/Display.html?id=20481
    my $temp_file = File::Temp->new(SUFFIX => '.PL');

    # The file must have content, or PPI will barf...
    print {$temp_file} "some code\n";
    # Just to flush the buffer.
    close $temp_file or confess "Couldn't close $temp_file: $OS_ERROR";

    my $doc = PPI::Document::File->new($temp_file->filename());

    no warnings qw< deprecated >;   ## no critic (TestingAndDebugging::ProhibitNoWarnings)
    ok(is_script($doc), 'is_script, false for .PL files');

    return;
}

#-----------------------------------------------------------------------------

sub test_is_perl_builtin {
    ok(  is_perl_builtin('print'),  'Is perl builtin function'     );
    ok( !is_perl_builtin('foobar'), 'Is not perl builtin function' );

    my $code = 'sub print {}';
    my $doc = make_doc( $code );
    my $sub = $doc->find_first('Statement::Sub');
    ok( is_perl_builtin($sub), 'Is perl builtin function (PPI)' );

    $code = 'sub foobar {}';
    $doc = make_doc( $code );
    $sub = $doc->find_first('Statement::Sub');
    ok( !is_perl_builtin($sub), 'Is not perl builtin function (PPI)' );

    $code = 'my sub print {}';
    $doc = make_doc( $code );
    $sub = $doc->find_first('Statement::Sub');
    ok( is_perl_builtin($sub), 'Is perl builtin function (PPI, lexical subroutines)' );

    $code = 'my sub foobar {}';
    $doc = make_doc( $code );
    $sub = $doc->find_first('Statement::Sub');
    ok( !is_perl_builtin($sub), 'Is not perl builtin function (PPI, lexical subroutines)' );

    return;
}

#-----------------------------------------------------------------------------

sub test_is_perl_bareword {
    ok(  is_perl_bareword('if'),     'Is perl bareword'       );
    ok(  is_perl_bareword('import'), 'Is perl extra bareword' );
    ok( !is_perl_bareword('foobar'), 'Is not perl bareword'   );

    my $code = 'sub if {}';
    my $doc = make_doc( $code );
    my $sub = $doc->find_first('Statement::Sub');
    ok( is_perl_bareword($sub), 'Is perl bareword (PPI)' );

    $code = 'sub import {}';
    $doc = make_doc( $code );
    $sub = $doc->find_first('Statement::Sub');
    ok( is_perl_bareword($sub), 'Is perl extra bareword (PPI)' );

    $code = 'sub foobar {}';
    $doc = make_doc( $code );
    $sub = $doc->find_first('Statement::Sub');
    ok( !is_perl_bareword($sub), 'Is not perl bareword (PPI)' );

    $code = 'my sub if {}';
    $doc = make_doc( $code );
    $sub = $doc->find_first('Statement::Sub');
    ok( is_perl_bareword($sub), 'Is perl bareword (PPI, lexical subroutines)' );

    $code = 'my sub import {}';
    $doc = make_doc( $code );
    $sub = $doc->find_first('Statement::Sub');
    ok( is_perl_bareword($sub), 'Is perl extra bareword (PPI, lexical subroutines)' );

    $code = 'my sub foobar {}';
    $doc = make_doc( $code );
    $sub = $doc->find_first('Statement::Sub');
    ok( !is_perl_bareword($sub), 'Is not perl bareword (PPI, lexical subroutines)' );

    return;
}

#-----------------------------------------------------------------------------

sub test_is_perl_global {
    ok(  is_perl_global('$OSNAME'), '$OSNAME is a perl global var'     );
    ok(  is_perl_global('*STDOUT'), '*STDOUT is a perl global var'     );
    ok( !is_perl_global('%FOOBAR'), '%FOOBAR is a not perl global var' );

    my $code = '$OSNAME';
    my $doc  = make_doc($code);
    my $var  = $doc->find_first('Token::Symbol');
    ok( is_perl_global($var), '$OSNAME is perl a global var (PPI)' );

    $code = '*STDOUT';
    $doc  = make_doc($code);
    $var  = $doc->find_first('Token::Symbol');
    ok( is_perl_global($var), '*STDOUT is perl a global var (PPI)' );

    $code = '%FOOBAR';
    $doc  = make_doc($code);
    $var  = $doc->find_first('Token::Symbol');
    ok( !is_perl_global($var), '%FOOBAR is not a perl global var (PPI)' );

    $code = q[$\\];
    $doc  = make_doc($code);
    $var  = $doc->find_first('Token::Symbol');
    ok( is_perl_global($var), "$code is a perl global var (PPI)" );

    return;
}

#-----------------------------------------------------------------------------

sub test_precedence_of {
    cmp_ok( precedence_of(q<*>), q[<], precedence_of(q<+>), '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)' );

    return;
}

#-----------------------------------------------------------------------------

sub test_is_subroutine_name {
    my $code = 'sub foo {}';
    my $doc  = make_doc( $code );
    my $word = $doc->find_first( sub { $_[1] eq 'foo' } );
    ok( is_subroutine_name( $word ), 'Is a subroutine name');

    $code = '$bar = foo()';
    $doc  = make_doc( $code );
    $word = $doc->find_first( sub { $_[1] eq 'foo' } );
    ok( !is_subroutine_name( $word ), 'Is not a subroutine name');

    return;
}

#-----------------------------------------------------------------------------

sub test_policy_long_name_and_policy_short_name {
    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' );

    return;
}

#-----------------------------------------------------------------------------

sub test_interpolate {
    is( interpolate( '\r%l\t%c\n' ), "\r%l\t%c\n", 'Interpolation' );
    is( interpolate( 'literal'    ), 'literal',    'Interpolation' );

    return;
}

#-----------------------------------------------------------------------------

sub test_is_perl_and_shebang_line {
    for ( qw(foo.t foo.pm foo.pl foo.PL foo.psgi) ) {
        ok( Perl::Critic::Utils::_is_perl($_), qq{Is perl: '$_'} );
    }

    for ( qw(foo.doc foo.txt foo.conf foo foo.pl.exe foo_pl) ) {
        ok( ! Perl::Critic::Utils::_is_perl($_), qq{Is not perl: '$_'} );
    }

    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 $temp_file =
            File::Temp->new( TEMPLATE => 'Perl-Critic.05_utils.t.XXXXX' );
        my $filename = $temp_file->filename();
        print {$temp_file} "$shebang\n";
        # Must close to flush buffer
        close $temp_file or confess "Couldn't close $temp_file: $OS_ERROR";

        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 $temp_file =
            File::Temp->new( TEMPLATE => 'Perl-Critic.05_utils.t.XXXXX' );
        my $filename = $temp_file->filename();
        print {$temp_file} "$shebang\n";
        # Must close to flush buffer
        close $temp_file or confess "Couldn't close $temp_file: $OS_ERROR";

        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)>,
        );
    }

    return;
}

#-----------------------------------------------------------------------------

sub test_is_backup {
    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: '$_'} );
    }

    return;
}

#-----------------------------------------------------------------------------

sub test_first_arg {
    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) { ## no critic (ProhibitCStyleForLoops)
        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);
    }

    return;
}

#-----------------------------------------------------------------------------

sub test_parse_arg_list {
    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" );
    }

    return;
}

#-----------------------------------------------------------------------------

sub test_is_function_call {
    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');
    ok(!(any {is_function_call($_)} @{$words}), 'is_function_call');

    return;
}

#-----------------------------------------------------------------------------

sub test_find_bundled_policies {
    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');

    return;
}

#-----------------------------------------------------------------------------
sub test_is_unchecked_call {
    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 confess '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,
        },

        # Check Fatal.
        {
            code => q[ use Fatal qw< open >; open( $fh, $mode, $filename ); ],
            pass => 0,
        },
        {
            code => q[ use Fatal qw< open >; ( open my $fh, '<', $file ); ],
            pass => 0,
        },

        # Check Fatal::Exception.
        {
            code => q[ use Fatal::Exception 'Exception::System' => qw< open close >; open( $fh, $mode, $filename ); ],
            pass => 0,
        },
        {
            code => q[ use Fatal::Exception 'Exception::System' => qw< open close >; ( open my $fh, '<', $file ); ],
            pass => 0,
        },

        # Check autodie.
        {
            code => q[ use autodie; open( $fh, $mode, $filename ); ],
            pass => 0,
        },
        {
            code => q[ use autodie qw< :io >; open( $fh, $mode, $filename ); ],
            pass => 0,
        },
        {
            code => q[ use autodie qw< :system >; ( open my $fh, '<', $file ); ],
            pass => 1,
        },
        {
            code => q[ use autodie qw< :system :file >; ( open my $fh, '<', $file ); ],
            pass => 0,
        },
    );

    foreach my $trial ( @trials ) {
        my $code = $trial->{'code'};
        my $doc = make_doc( $code );
        my $statement = $doc->find_first( sub { $_[1] eq 'open' } );
        if ( $trial->{'pass'} ) {
            ok( is_unchecked_call( $statement ), qq<is_unchecked_call returns true for "$code".> );
        } else {
            ok( ! is_unchecked_call( $statement ), qq<is_unchecked_call returns false for "$code".> );
        }
    }

    return;
}

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