Login
RT #72910: False-positive of Variables::ProhibitPunctuationVars when {}
authorTom Wyant <harryfmudd@comcast.net>
Sat, 3 Dec 2011 20:48:10 +0000 (20:48 +0000)
committerTom Wyant <harryfmudd@comcast.net>
Sat, 3 Dec 2011 20:48:10 +0000 (20:48 +0000)
used in interpolated string

Since the original interpolation code in this policy recognized
punctuation variables using a big honkin' regexp, the fix was by
computing and adding to the regexp the bracketed forms of the forbidden
variables. The brackets (if any) are stripped before comparison to the
{_allowed} configuration.

It also seemed a good idea to add the name of the variable to the error
description, since the position of the violation may not tell you enough
when the element containing the violation is a string.

Changes
lib/Perl/Critic/Policy/Variables/ProhibitPunctuationVars.pm
t/Variables/ProhibitPunctuationVars.run

diff --git a/Changes b/Changes
index b222164..fd7e0b8 100644 (file)
--- a/Changes
+++ b/Changes
@@ -25,6 +25,10 @@ Next release, whenever it is:
       set with 'use re "/modifiers"'. RT #72151.
     * Subroutines::ProhibitManyArgs now recognizes '+' as a prototype
       character.
+    * Variables::ProhibitPunctuationVars now recognizes bracketed
+      variables embedded in interpolated strings (e.g. "${$}"). For the
+      purpose of the 'allow' configuration, these are considered
+      equivalent to the unbracketed form. RT #72910.
     Other Changes:
     * Corrected POD in Perl::Critic::PPI::Utils. RT #68898.
     * Perl::Critic::Violation source() method now returns the line
index f38a19b..9ac9e90 100644 (file)
@@ -25,7 +25,7 @@ our $VERSION = '1.116';
 
 #-----------------------------------------------------------------------------
 
-Readonly::Scalar my $DESC => q<Magic punctuation variable used>;
+Readonly::Scalar my $DESC => q<Magic punctuation variable %s used>;
 Readonly::Scalar my $EXPL => [79];
 
 #-----------------------------------------------------------------------------
@@ -127,7 +127,7 @@ sub _violates_magic {
     my ( $self, $elem, undef ) = @_;
 
     if ( !exists $self->{_allow}->{$elem} ) {
-        return $self->violation( $DESC, $EXPL, $elem );
+        return $self->_make_violation( $DESC, $EXPL, $elem );
     }
 
     return;    # no violation
@@ -160,7 +160,7 @@ sub _violates_string {
     my %matches = _strings_helper( $self, $string );
     if (%matches) {
         my $DESC = qq<$DESC in interpolated string>;
-        return $self->violation( $DESC, $EXPL, $elem );
+        return $self->_make_violation( $DESC, $EXPL, $elem, \%matches );
     }
 
     return;    # no violation
@@ -174,7 +174,7 @@ sub _violates_heredoc {
         my %matches = _strings_helper( $self, $heredoc_string );
         if (%matches) {
             my $DESC = qq<$DESC in interpolated here-document>;
-            return $self->violation( $DESC, $EXPL, $elem );
+            return $self->_make_violation( $DESC, $EXPL, $elem, \%matches );
         }
     }
 
@@ -194,7 +194,8 @@ sub _strings_helper {
 
     # we are in string_mode = simple
 
-    my @raw_matches = $target_string =~ m/$MAGIC_REGEX/goxms;
+    my @raw_matches = map { _unbracket_variable_name( $_ ) }
+        $target_string =~ m/$MAGIC_REGEX/goxms;
     return if not @raw_matches;
 
     my %matches = hashify(@raw_matches);
@@ -212,7 +213,8 @@ sub _strings_thorough {
     MATCH:
     while ( my ($match) = $target_string =~ m/$MAGIC_REGEX/gcxms ) {
         my $nextchar = substr $target_string, $LAST_MATCH_END[0], 1;
-        my $c = $match . $nextchar;
+        my $vname = _unbracket_variable_name( $match );
+        my $c = $vname . $nextchar;
 
         # These tests closely parallel those in PPI::Token::Magic,
         # from which the regular expressions were taken.
@@ -253,7 +255,7 @@ sub _strings_thorough {
         # The additional checking that PPI::Token::Magic does at this point
         # is not necessary here, in an interpolated string context.
 
-        $matches{$match} = 1;
+        $matches{$vname} = 1;
     }
 
     delete @matches{ keys %{ $self->{_allow} } };
@@ -261,6 +263,29 @@ sub _strings_thorough {
     return %matches;
 }
 
+# RT #72910: A magic variable may appear in bracketed form; e.g. "$$" as
+# "${$}".  Generate the bracketed form from the unbracketed form, and
+# return both.
+sub _bracketed_form_of_variable_name {
+    my ( $name ) = @_;
+    length $name > 1
+        or return ( $name );
+    my $brktd = $name;
+    substr $brktd, 1, 0, '{';
+    $brktd .= '}';
+    return( $name, $brktd );
+}
+
+# RT #72910: Since we loaded both bracketed and unbracketed forms of the
+# punctuation variables into our detecting regex, we need to detect and
+# strip the brackets if they are present to recover the canonical name.
+sub _unbracket_variable_name {
+    my ( $name ) = @_;
+    $name =~ m/ \A ( . ) [{] ( .+ ) [}] \z /smx
+        and return "$1$2";
+    return $name;
+}
+
 #-----------------------------------------------------------------------------
 
 sub _create_magic_detector {
@@ -278,6 +303,7 @@ sub _create_magic_detector {
                 q<|>,
                 map          { quotemeta $_ }
                 reverse sort { length $a <=> length $b }
+                map          { _bracketed_form_of_variable_name( $_ ) }
                 grep         { q<%> ne substr $_, 0, 1 }
                 @MAGIC_VARIABLES
         )
@@ -290,6 +316,15 @@ sub _create_magic_detector {
     >xsm;
 }
 
+sub _make_violation {
+    my ( $self, $desc, $expl, $elem, $vars ) = @_;
+
+    my $vname = 'HASH' eq ref $vars ?
+        join ', ', sort keys %{ $vars } :
+        $elem->content();
+    return $self->violation( sprintf( $desc, $vname ), $expl, $elem );
+}
+
 1;
 
 __END__
index e4d41ed..f4725b9 100644 (file)
@@ -412,6 +412,15 @@ qr/foo$/
 
 #-----------------------------------------------------------------------------
 
+## name detect bracketed punctuation variables - RT #72910
+## failures 0
+## parms { allow => '$$' }
+## cut
+
+"${$}";
+
+#-----------------------------------------------------------------------------
+
 ##############################################################################
 #      $URL$
 #     $Date$