#!/usr/bin/perl -w
# Copyright 2009, 2010, 2011, 2012, 2013, 2014 Kevin Ryde
# This file is part of Perl-Critic-Pulp.
#
# Perl-Critic-Pulp is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by the
# Free Software Foundation; either version 3, or (at your option) any later
# version.
#
# Perl-Critic-Pulp is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Perl-Critic-Pulp. If not, see <http://www.gnu.org/licenses/>.
use 5.006;
use strict;
use warnings;
use Test::More tests => 288;
use lib 't';
use MyTestHelpers;
#BEGIN { MyTestHelpers::nowarnings() }
require Perl::Critic::Policy::ValuesAndExpressions::ProhibitUnknownBackslash;
#-----------------------------------------------------------------------------
my $want_version = 85;
is ($Perl::Critic::Policy::ValuesAndExpressions::ProhibitUnknownBackslash::VERSION, $want_version, 'VERSION variable');
is (Perl::Critic::Policy::ValuesAndExpressions::ProhibitUnknownBackslash->VERSION, $want_version, 'VERSION class method');
{
ok (eval { Perl::Critic::Policy::ValuesAndExpressions::ProhibitUnknownBackslash->VERSION($want_version); 1 }, "VERSION class check $want_version");
my $check_version = $want_version + 1000;
ok (! eval { Perl::Critic::Policy::ValuesAndExpressions::ProhibitUnknownBackslash->VERSION($check_version); 1 }, "VERSION class check $check_version");
}
#-----------------------------------------------------------------------------
# _pos_after_interpolate_variable()
foreach my $elem (## no critic (RequireInterpolationOfMetachars)
['$#x blah', 3],
['$#{x} blah', 5],
['$x blah', 2],
['${\scalar @a} blah', 13],
['${x} blah', 4],
['$x{y} blah', 5],
['$x{\'y\'} blah', 7],
['$x{$y}|', 6],
['$hash{1} {y} blah', 8],
['$array[1][2] {y} blah', 12],
['@{[foo()]} blah', 10],
['@{[foo()]} blah', 10],
['@{[foo()]}{123}', 10],
['$foo}; 1', 4],
['$foo[1]', 7],
['$_[1]', 5],
['$foo.bar', 4],
) {
my ($str, $want) = @$elem;
## no critic (ProtectPrivateSubs)
my $got = Perl::Critic::Policy::ValuesAndExpressions::ProhibitUnknownBackslash::_pos_after_interpolate_variable($str, 0);
is ($got, $want, "_pos_after_interpolate_variable: $str");
if ($got != $want) {
require PPI::Dumper;
my $doc = PPI::Document->new(\$str);
my $dumper = PPI::Dumper->new($doc);
diag $dumper->string;
diag "child2: ", $doc->child(0)->child(0)->content;
}
}
#-----------------------------------------------------------------------------
# _string(), but not _quote_delims() for now ...
require PPI::Document;
foreach my $want_string ("abc", "a\nb") {
foreach my $want_q ('', 'q', 'qq', 'qx') {
foreach my $quotes ("''", '""', '{}', '##', '%%', 'ZZ') {
next if (!$want_q && $quotes ne "''" && $quotes ne '""');
my $want_open = substr ($quotes, 0, 1);
my $want_close = substr ($quotes, 1, 1);
foreach my $comment ("", " #\n", " # blah\n\t# blah \t\n ") {
next if ($quotes eq '##' && $comment);
next if ($quotes eq 'ZZ' && !$comment);
my $str = $want_q.$comment.$want_open.$want_string.$want_close;
my $doc = PPI::Document->new(\$str);
my $elem = $doc->schild(0)->schild(0);
($elem->isa('PPI::Token::Quote')
|| $elem->isa('PPI::Token::QuoteLike'))
or die "Oops, didn't get Quote or QuoteLike: $str";
# unused ...
# ## no critic (ProtectPrivateSubs)
# my ($got_string) = Perl::Critic::Policy::ValuesAndExpressions::ProhibitUnknownBackslash::_string($elem);
# is ($got_string, $want_string, "string of: $str");
# unused ...
# my ($got_q, $got_open, $got_close) = Perl::Critic::Policy::ValuesAndExpressions::ProhibitUnknownBackslash::_quote_delims($elem);
# is ($got_q, $want_q, "q of: $str");
# is ($got_open, $want_open, "open of: $str");
# is ($got_close, $want_close, "close of: $str");
}
}
}
}
#-----------------------------------------------------------------------------
# policy
require PPI;
diag "PPI version ",PPI->VERSION;
{
require Perl::Critic;
my $critic = Perl::Critic->new
('-profile' => '',
'-single-policy' => '^Perl::Critic::Policy::ValuesAndExpressions::ProhibitUnknownBackslash$');
my @policies = $critic->policies;
is (scalar @policies, 1, 'single policy ProhibitUnknownBackslash');
my $policy = $policies[0];
ok (eval { $policy->VERSION($want_version); 1 },
"VERSION object check $want_version");
my $check_version = $want_version + 1000;
ok (! eval { $policy->VERSION($check_version); 1 },
"VERSION object check $check_version");
#---------------------
# default
foreach my $data
(## no critic (RequireInterpolationOfMetachars)
#-------------------
# "$foo\::bar" etc
# not sure this one parses right
# [ 0, ' "$foo{\\"key\\"}\\[1]" ' ],
#
[ 0, ' "$foo{\'key\'}\\[1]" ' ],
[ 0, ' "$foo{key}\\[1]" ' ],
[ 0, ' "$foo{key}\\{k2}" ' ],
[ 0, ' "$foo{key}{k2}\\{k3}" ' ],
[ 0, ' "$foo{key}{k2}\\[0]" ' ],
[ 0, ' "$foo\\->[0]" ' ],
[ 0, ' "$foo\\->{k}" ' ],
[ 1, ' "$foo\\->method" ' ],
[ 1, ' "$coderef\\->(123)" ' ],
[ 1, ' "$foo\\-> [0]" ' ], # doesn't interpolate with space
[ 0, ' "$foo->[0]" ' ],
[ 0, ' "$foo\\::bar" ' ],
[ 0, ' "$foo\\:\\:bar" ' ],
[ 0, ' "$foo\\:" ' ],
[ 0, ' "$foo\\:\\:" ' ],
[ 0, ' "$#foo\\:\\:bar" ' ],
[ 0, ' "@foo\\:\\:bar" ' ],
[ 0, ' "$foo[0]\\[1]" ' ],
[ 0, ' "$foo[0]\\{key}" ' ],
[ 0, ' "$foo[0][1]\\[2]" ' ],
[ 0, ' "$foo[0][1]\\{key}" ' ],
[ 1, ' "\\:" ' ],
[ 1, ' "\\::" ' ],
[ 1, ' "\\::bar" ' ],
[ 2, ' "\\:\\:bar" ' ],
[ 1, ' "foo\\::" ' ],
[ 1, ' "foo\\::bar" ' ],
[ 1, ' "\\[" ' ],
[ 1, ' "foo\\[" ' ],
[ 1, ' "\\{" ' ],
[ 1, ' "foo\\{" ' ],
#----------------
# \cX including \c\
[ 0, ' "\\cA" ' ],
[ 0, ' "\\cz" ' ],
[ 0, ' "\\cm\\cj" ' ],
[ 0, ' "\\c\\" ' ],
[ 0, ' "\\c\\v" ' ],
[ 0, ' "\\c\\z" ' ],
[ 0, ' "\\c\\\\n" ' ],
[ 1, ' "\\c\\\\v" ' ],
[ 1, ' "\\c*" ' ],
[ 2, ' "\\c1\\c2" ' ],
#----------------
# \c at end-of-string
[ 1, ' "\\c" ' ],
[ 1, ' qq X\\cX ' ],
#----------------
# control-\ before interpolation
[ 1, q{ qq$\\c\\${\\scalar 123} $ } ],
[ 0, q{ qq@\\c\\${\\scalar 123} @ } ],
#----------------
[ 0, ' qq{} ' ],
[ 0, ' "" ' ],
[ 1, ' "\\z" ' ],
[ 1, ' qq{\\z} ' ],
[ 0, ' "\\\\z" ' ],
[ 0, ' qq{\\\\z} ' ],
[ 1, ' "\\\\\\z" ' ],
[ 1, ' qq{\\\\\\z} ' ],
[ 2, ' "\\\\\\z\z" ' ],
[ 2, ' qq{\\\\\\z\z} ' ],
[ 0, ' "$" ' ], # dodgy interpolation, but not an unknown backslash
[ 0, ' "\\$" ' ],
[ 0, "qx'echo \\z'" ],
[ 1, "qx{echo \\z}" ],
[ 0, '"blah ${\scalar @array} blah"' ],
[ 0, "print <<'HERE'
\\z
HERE
" ],
[ 1, "print <<\"HERE\"
\\z
HERE
" ],
[ 1, "print <<HERE
\\z
HERE
" ],
# Not sure if wide chars and/or non-ascii are supposed to be allowed in
# an input string, presumably yes, but some combination of perl 5.8.3
# and PPI 1.206 threw an error on wide chars. It runs ok with 5.10.1.
#
# [ 1, ($] >= 5.008
# ? 'qq{\\'.chr(0x16A).'}' # 5.8 wide U-with-macron
# : '') ], # not 5.8, dummy passing
#
[ 1, "qq{\\\374}" ], # latin-1/unicode u-dieresis
[ 1, 'use 5.005; "\\400"' ],
[ 0, 'use 5.006; "\\400"' ],
[ 0, '"\\400"' ],
[ 0, 'use 5.005; "\\000"' ],
[ 0, 'use 5.005; "\\100"' ],
[ 0, 'use 5.005; "\\200"' ],
[ 0, 'use 5.005; "\\300"' ],
[ 1, 'use 5.005; "\\400"' ],
[ 1, 'use 5.005; "\\500"' ],
[ 1, 'use 5.005; "\\600"' ],
[ 1, 'use 5.005; "\\700"' ],
[ 1, 'use 5.005; "\\800"' ],
[ 1, 'use 5.005; "\\900"' ],
[ 0, '"\\000"' ],
[ 0, '"\\100"' ],
[ 0, '"\\200"' ],
[ 0, '"\\300"' ],
[ 0, '"\\400"' ],
[ 0, '"\\500"' ],
[ 0, '"\\600"' ],
[ 0, '"\\700"' ],
[ 1, '"\\800"' ],
[ 1, '"\\900"' ],
#----------------
# the various known escapes
[ 0, ' "aa\\t\\n\\r\\f\\b\\a\\ebb" ' ],
[ 0, ' "aa\\033\177\200\377\\xFF\\cJ\\tbb" ' ],
[ 0, ' "aa\\Ua\\u\\LX\\l\\Q\\E" ' ],
#----------------
# close of singles and doubles
[ 0, " 'aa\\\\'bb' " ],
[ 0, ' q{aa\\}bb} ' ],
[ 0, ' q{aa\\}bb} ' ],
[ 0, ' qq{aa\\}bb} ' ],
[ 0, ' qq {aa\\}bb} ' ],
[ 0, ' `aa\\nbb` ' ],
[ 0, ' qx{aa\\n\\}bb} ' ],
[ 0, q{ qx'aa\\nbb' } ],
#----------------
# singles ok
[ 0, q{ '\\xFF' } ],
[ 0, q{ '\\c*' } ],
[ 0, q{ my $pat = '[0-9eE\\.\\-]' } ],
[ 1, 'use 5.005; "\\777" ' ],
[ 0, 'use 5.006; "\\777" ' ],
#----------------
# \N
[ 1, ' "\\N{COLON}" ' ],
[ 0, 'use charnames q{:full}; "\\N{COLON}" ' ],
[ 1, '{ use charnames q{:full}; } "\\N{COLON}" ' ], # not in scope
#----------------
# runs of backslashes
[ 0, q{ "\\\\s" } ],
[ 1, q{ "\\\\\\s" } ],
[ 0, q{ "\\\\\\\\s" } ],
[ 1, q{ "\\\\\\\\\\s" } ],
[ 0, q{ "\\\\\\\\\\\\s" } ],
[ 1, q{ "\\\\\\\\\\\\\\s" } ],
) {
my ($want_count, $str) = @$data;
foreach my $str ($str, $str . ';') {
my @violations = $critic->critique (\$str);
# foreach my $violation (@violations) {
# diag $violation->description;
# }
my $got_count = scalar @violations;
require Data::Dumper;
my $testname = 'default: '
. Data::Dumper->new([$str],['str'])->Useqq(1)->Dump;
is ($got_count, $want_count, $testname);
}
}
#-------------------
# double=quotemeta
$policy->{_double} = 'quotemeta';
foreach my $data
(# no critic (RequireInterpolationOfMetachars)
# non-ascii allowed under default 'quotemeta'
[ 0, "qq{\\\374}" ], # latin-1/unicode u-dieresis
# Not sure if literal wide chars are supposed to be allowed in an input
# string, presumably yes, but some combination of perl 5.8.6 and PPI
# 1.212 threw an error on it. It runs ok with 5.10.1.
#
# [ 1, ($] >= 5.008
# ? 'qq{\\'.chr(0x16A).'}' # 5.8 wide U-with-macron
# : '') ], # not 5.8, dummy passing
) {
my ($want_count, $str) = @$data;
foreach my $str ($str, $str . ';') {
# my $printable = Perl::Critic::Policy::ValuesAndExpressions::ProhibitUnknownBackslash::_printable($str);
# ### str printable: $printable
my @violations = $critic->critique (\$str);
# foreach my $violation (@violations) {
# diag $violation->description;
# }
my $got_count = scalar @violations;
require Data::Dumper;
my $testname = 'quotemeta: '
. Data::Dumper->new([$str],['str'])->Useqq(1)->Dump;
is ($got_count, $want_count, $testname);
}
}
#-----------------------
# single=all
# FIXME: what's the progammatic way to set parameters?
$policy->{_single} = 'all';
foreach my $data
(## no critic (RequireInterpolationOfMetachars)
[ 0, 'q{}' ],
[ 0, 'q{\\\\}' ],
[ 1, 'q{\\z}' ],
[ 0, 'q{\\\\z}' ],
[ 1, 'q{\\\\\\z}' ],
[ 0, '\'\\\'\'' ],
[ 1, 'q{\\\'}' ],
[ 0, 'q{\\}}' ],
[ 1, 'q{\\{}' ],
[ 1, "qx'echo \\z'" ],
[ 1, q{ qx'aa\\nbb' } ],
[ 1, q{ '\\xFF' } ],
[ 2, q{ my $pat = '[0-9eE\\.\\-]' } ],
[ 1, "q{\\\374}" ], # latin-1/unicode u-dieresis
# Not sure if wide chars and/or non-ascii are supposed to be allowed in
# an input string, presumably yes, but some combination of perl 5.8.3
# and PPI 1.206 threw an error on wide chars. It runs ok with 5.10.1.
#
# [ 1, ($] >= 5.008
# ? 'q{\\'.chr(0x16A).'}' # 5.8 unicode U-with-macron
# : 'q{\\z}') ], # not 5.8, dummy failing
# [ 1, ($] >= 5.008
# ? 'q{\\'.chr(0x2022).'}' # 5.8 unicode BULLET
# : 'q{\\z}') ], # not 5.8, dummy failing
# backslash then some whitespaces
[ 1, " '\\\n' " ],
[ 1, " '\\\t' " ],
[ 1, " '\\\f' " ],
[ 1, " '\\ ' " ],
# two violations, not a control-\
[ 2, " '\\c\\z ' " ],
) {
my ($want_count, $str) = @$data;
foreach my $str ($str, $str . ';') {
my @violations = $critic->critique (\$str);
# foreach my $violation (@violations) {
# diag $violation->description;
# }
my $got_count = scalar @violations;
require Data::Dumper;
my $testname = 'single: '
. Data::Dumper->new([$str],['str'])->Useqq(1)->Dump;
is ($got_count, $want_count, $testname);
}
}
}
#-----------------------------------------------------------------------------
# _quote_open()
# require PPI::Document;
# foreach my $data ([ "'", "'x'" ],
# [ '"', '"x"' ],
# [ '`', '`echo hi`' ],
#
# [ 'q{', 'q{x}' ],
# [ 'qq{', 'qq{x}' ],
# [ 'qx{', 'qx{x}' ],
#
# [ 'q#', 'q#x#' ],
# [ 'q{', "q #foo#\n{bar}" ],
# [ 'q{', "q #foo\n#foo\n{bar}" ],
# [ 'q{', "q #foo\n #foo\n{bar}" ],
# [ 'q{', "q #foo\n #foo\n \t{bar}" ],
#
# ) {
# my ($want, $str) = @$data;
#
# my $document = PPI::Document->new (\$str)
# or die $@->message;
# my $elem = $document->schild(0)->schild(0);
#
# diag "elem: $elem";
# my $got = Perl::Critic::Policy::ValuesAndExpressions::ProhibitUnknownBackslash::_quote_open($elem);
# is ($got, $want, "_quote_open: $str");
# }
exit 0;