Index: t/Variables/ProhibitPunctuationVars.run
===================================================================
--- t/Variables/ProhibitPunctuationVars.run (revision 3113)
+++ t/Variables/ProhibitPunctuationVars.run (working copy)
@@ -43,18 +43,188 @@
#-----------------------------------------------------------------------------
-## name Strings
-## failures 4
-## TODO We don't look into strings.
+## name Quoted String Interpolation - basic functional tests
+## parms { allow => '$@ $!' }
+## failures 12
## cut
+# Commented numbers in parens indicate expected violations in that section
+# The module under test doesn't use them, they're just for reader's convenience
+
+# PPI::Token::Quote::Double (5)
print "$+";
-print qq<$+>;
-print qx<$+>;
-print qr<$+>;
+print "This is my $+. is it not nifty?";
+print "This is my $+. is it not $@?";
+print "this \n should $+\n violate";
+print "as \n$+ should this";
+ # should pass (0)
+print "\$+";
+print "$@";
+print "$!";
+print "no magic here";
+print "This is my $@; is it not nifty?"
+print "but not \n\$+ this";
+
+# PPI::Token::Quote::Interpolate (3)
+print qq<$+>; #should violate
+print qq<\$+>; #should pass
+print qq<\\$+>; #should violate
+print qq<\\\$+>; #should pass
+print qq<\\\\$+>; #should violate
+
+# PPI::Token::QuoteLike::Command (1)
+print qx<$+>; #should violate
+print qx<\$+>; #should pass
+
+# PPI::Token::QuoteLike::Backtick (1)
+print `$+`; #should violate
+print `\$+`; #should pass
+
+# PPI::Token::QuoteLike::Regexp (1)
+print qr<$+>; #should violate
+print qr<\$+>; #should pass
+
+# PPI::Token::QuoteLike::Readline (1)
+while (<$+>) { 1; } #should violate
+while (<\$+>) { 1; } #should pass
+
#-----------------------------------------------------------------------------
+## name Heredoc Interpolation
+## parms { allow => '$@ $!' }
+## failures 8
+## cut
+
+print <<DEFAULT # default, implied "" context; should violate
+$+
+DEFAULT
+
+print <<DEFAULT # default, implied "" context; should violate
+$+
+fred
+wilma
+DEFAULT
+
+print <<DEFAULT # default, implied "" context; should violate
+barney
+$+
+betty
+DEFAULT
+
+print <<DEFAULT # default, implied "" context; should violate
+$+
+pebbles
+bambam
+DEFAULT
+
+print <<"DOUBLE_QUOTE" # explicit "" context; should violate
+$$
+DOUBLE_QUOTE
+
+print <<"DQ_VERYVERYVERY_LONG_HEREDOC_EOT_IDENTIFIER" # explicit "" context; should violate
+$+
+DQ_VERYVERYVERY_LONG_HEREDOC_EOT_IDENTIFIER
+
+
+print <<"MULTI_MATCHES" # explicit "" context; should violate
+$$
+$+
+$\
+$^A
+MULTI_MATCHES
+
+print <<DEFAULT_ALLOWED # default, implied "" but allowed var; should pass
+$@
+DEFAULT_ALLOWED
+
+print <<'SINGLE_QUOTE' # '' context; should pass
+$@
+SINGLE_QUOTE
+
+print <<`BACKTICK` # backtick context; should violate
+$+
+BACKTICK
+
+#-----------------------------------------------------------------------------
+
+## name Quoted String Interpolation wart cases
+## TODO debug wart cases from String Interpolation exhaustive
+## failures 0
+## cut
+
+#print "$""; # 2 of 59
+#print "$\"; # 28 of 59
+
+#-----------------------------------------------------------------------------
+
+## name Quoted String Interpolation - exhaustive tests
+## failures 57
+## cut
+
+print "$!"; # 1 of 59
+#print "$""; # 2 of 59 BROKEN, copied to TODO
+print "$#"; # 3 of 59
+print "$#+"; # 4 of 59
+print "$#-"; # 5 of 59
+print "$$"; # 6 of 59
+print "$%"; # 7 of 59
+print "$&"; # 8 of 59
+print "$'"; # 9 of 59
+print "$("; # 10 of 59
+print "$)"; # 11 of 59
+print "$*"; # 12 of 59
+print "$+"; # 13 of 59
+print "$,"; # 14 of 59
+print "$-"; # 15 of 59
+print "$."; # 16 of 59
+print "$/"; # 17 of 59
+print "$0"; # 18 of 59
+print "$:"; # 19 of 59
+print "$::|"; # 20 of 59
+print "$;"; # 21 of 59
+print "$<"; # 22 of 59
+print "$="; # 23 of 59
+print "$>"; # 24 of 59
+print "$?"; # 25 of 59
+print "$@"; # 26 of 59
+print "$["; # 27 of 59
+#print "$\"; # 28 of 59 BROKEN, copied to TODO
+print "$]"; # 29 of 59
+print "$^"; # 30 of 59
+print "$^A"; # 31 of 59
+print "$^C"; # 32 of 59
+print "$^D"; # 33 of 59
+print "$^E"; # 34 of 59
+print "$^F"; # 35 of 59
+print "$^H"; # 36 of 59
+print "$^I"; # 37 of 59
+print "$^L"; # 38 of 59
+print "$^M"; # 39 of 59
+print "$^N"; # 40 of 59
+print "$^O"; # 41 of 59
+print "$^P"; # 42 of 59
+print "$^R"; # 43 of 59
+print "$^S"; # 44 of 59
+print "$^T"; # 45 of 59
+print "$^V"; # 46 of 59
+print "$^W"; # 47 of 59
+print "$^X"; # 48 of 59
+print "$`"; # 49 of 59
+print "$|"; # 50 of 59
+print "$}"; # 51 of 59
+print "$~"; # 52 of 59
+print "%!"; # 53 of 59
+print "%+"; # 54 of 59
+print "%-"; # 55 of 59
+print "%^H"; # 56 of 59
+print "@*"; # 57 of 59
+print "@+"; # 58 of 59
+print "@-"; # 59 of 59
+
+
+#-----------------------------------------------------------------------------
+
##############################################################################
# $URL$
# $Date$
Index: lib/Perl/Critic/Policy/Variables/ProhibitPunctuationVars.pm
===================================================================
--- lib/Perl/Critic/Policy/Variables/ProhibitPunctuationVars.pm (revision 3113)
+++ lib/Perl/Critic/Policy/Variables/ProhibitPunctuationVars.pm (working copy)
@@ -12,7 +12,7 @@
use warnings;
use Readonly;
-use Perl::Critic::Utils qw{ :characters :severities :data_conversion };
+use Perl::Critic::Utils qw{ :characters :severities :data_conversion :booleans };
use base 'Perl::Critic::Policy';
our $VERSION = '1.096';
@@ -39,18 +39,153 @@
sub default_severity { return $SEVERITY_LOW }
sub default_themes { return qw(core pbp cosmetic) }
-sub applies_to { return 'PPI::Token::Magic' }
+sub applies_to {
+ return qw( PPI::Token::Magic
+ PPI::Token::Quote::Double
+ PPI::Token::Quote::Interpolate
+ PPI::Token::QuoteLike::Command
+ PPI::Token::QuoteLike::Backtick
+ PPI::Token::QuoteLike::Regexp
+ PPI::Token::QuoteLike::Readline
+ PPI::Token::HereDoc
+ );
+}
+
#-----------------------------------------------------------------------------
+# package state
+my $_magic_regexp;
+
+# private functions
+my $_violates_magic;
+my $_violates_string;
+my $_violates_heredoc;
+my $_strings_helper;
+
+#-----------------------------------------------------------------------------
+
+sub initialize_if_enabled{
+ # my $config = shift; # policy $config not needed at present
+
+ my %_magic_vars;
+
+ # Magic variables taken from perlvar.
+ # Several things added separately to avoid warnings.
+ # adapted from ADAMK's PPI::Token::Magic.pm
+ foreach (
+ qw{
+ $1 $2 $3 $4 $5 $6 $7 $8 $9
+ $_ $& $` $' $+ @+ %+ $* $. $/ $|
+ $\\ $" $; $% $= $- @- %- $)
+ $~ $^ $: $? $! %! $@ $$ $< $>
+ $( $0 $[ $] @_ @*
+
+ $^L $^A $^E $^C $^D $^F $^H
+ $^I $^M $^N $^O $^P $^R $^S
+ $^T $^V $^W $^X %^H
+
+ $::|
+ }, '$}', '$,', '$#', '$#+', '$#-'
+ ) {
+ $_magic_vars{$_} = $_;
+ $_magic_vars{$_} =~
+ s{ ( [[:punct:]] ) }{\\$1}gox; # add \ before all punctuation
+ }
+
+ delete @_magic_vars{ @{supported_parameters()->{list_always_present_values}} };
+
+ $_magic_regexp = join q(|), values %_magic_vars;
+
+ return $TRUE;
+}
+
sub violates {
my ( $self, $elem, undef ) = @_;
+
+ if ( $elem->isa('PPI::Token::Magic') ) {
+ return $_violates_magic->(@_);
+ }
+ elsif ( $elem->isa('PPI::Token::HereDoc') ){
+ return $_violates_heredoc->(@_);
+ }
+ else {
+ #the remaining applies_to() classes are all interpolated strings
+ return $_violates_string->(@_);
+ }
+
+ die 'Impossible! fall-through error in method violates()';
+}
+
+#-----------------------------------------------------------------------------
+
+$_violates_magic = sub {
+ my ( $self, $elem, undef ) = @_;
+
if ( !exists $self->{_allow}->{$elem} ) {
+
return $self->violation( $DESC, $EXPL, $elem );
}
- return; #ok!
-}
+
+ return;
+};
+$_violates_string = sub {
+ my ( $self, $elem, undef ) = @_;
+
+ my %matches = $_strings_helper->($elem->content(), $self->{_allow} );
+
+ if (%matches) {
+ my $DESC = qq{$DESC in interpolated string};
+
+ return $self->violation( $DESC, $EXPL, $elem );
+ }
+
+ return;
+
+};
+
+$_violates_heredoc = sub{
+ my ($self, $elem, undef) = @_;
+
+ if ($elem->{_mode} eq 'interpolate' or $elem->{_mode} eq 'command'){
+
+ my $heredoc_string = join qq{\n}, $elem->heredoc() ;
+ my %matches = $_strings_helper->($heredoc_string, $self->{_allow});
+
+ if (%matches) {
+ my $DESC = qq{$DESC in interpolated here-document};
+
+ return $self->violation( $DESC, $EXPL, $elem );
+ }
+ }
+
+ return;
+};
+
+$_strings_helper = sub{
+ my ($target_string, $allow_ref, undef) = @_;
+
+ my @raw_matches = (
+ $target_string =~
+ m/
+ (?: \A | [^\\] ) # beginning-of-string or any non-backslash
+ (?: \\\\ )* # zero or more double-backslashes
+ ( $_magic_regexp ) # any magic punctuation variable
+ /goxs
+ );
+
+ my %matches;
+ @matches{@raw_matches} = 1;
+ delete @matches{ keys %{$allow_ref} };
+
+ return %matches
+ if (%matches);
+
+ return; #no matches
+};
+
+
1;
__END__
@@ -102,17 +237,21 @@
=head1 BUGS
-This doesn't find punctuation variables in strings. RT #35970.
+Punctuation variables that confuse PPI's document parsing may not be
+detected correctly or at all, and may prevent detection of subsequent
+ones.
=head1 AUTHOR
Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+Edgar Whipple <perlmonk at misterwhipple dot com>
=head1 COPYRIGHT
Copyright (c) 2005-2009 Jeffrey Ryan Thalhammer. All rights reserved.
+Additions for interpolated strings (c) 2009 Edgar Whipple. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself. The full text of this license
