[perl #92436] Make Filter::Simple match variables better

(This is the second bug reported in ticket #92436.)

Filter::Simple was using Text::Balanced’s extract_variable, which

       ...extracts any valid Perl variable or variable-
       involved expression, including scalars, arrays, hashes, array
       accesses, hash look-ups, method calls through objects, subrou-
       tine calls through subroutine references, etc.

So it extracts things like $x->foo("blah lbah blah").  That means
that, when the user of Filter::Simple asks for everything except
strings, "blah lbah blah" is passed through anyway, because
Filter::Simple things it’s part of a variable name.  That obviously
doesn’t work.

This commit makes Filter::Simple use a regular expression for varia-
bles, as it does for other things.  It’s certainly not foolproof, but
Filter::Simple in general is not foolproof, and this regular expres-
sion is actually less foolproof than most parts of Filter::Simple.  So
it’s a step in the right direction (unless you consider deletion to be
the right direction).

3 files changed, 42 insertions, 5 deletions

diff --git a/dist/Filter-Simple/lib/Filter/Simple.pm b/dist/Filter-Simple/lib/Filter/Simple.pm
index 308ab8c6c6..b0068037f3 100644
--- a/dist/Filter-Simple/lib/Filter/Simple.pm
+++ b/dist/Filter-Simple/lib/Filter/Simple.pm
@@ -40,18 +40,27 @@ my $pod_or_DATA = qr/
             | ^=begin .*? $CUT
             | ^__(DATA|END)__\r?\n.*
             /smx;
+my $variable = qr{
+        [\$*\@%]\s*
+            \{\s*(?!::)(?:\d+|[][&`'#+*./|,";%=~:?!\@<>()-]|\^[A-Z]?)\}
+      | (?:\$#?|[*\@\%]|\\&)\$*\s*
+               (?:  \{\s*(?:\^(?=[A-Z_]))?(?:\w|::|'\w)*\s*\}
+                  |      (?:\^(?=[A-Z_]))?(?:\w|::|'\w)*
+                  | (?=\{)  # ${ block }
+               )
+        )
+      | \$\s*(?!::)(?:\d+|[][&`'#+*./|,";%=~:?!\@<>()-]|\^[A-Z]?)
+   }x;
 
 my %extractor_for = (
-    quotelike  => [ $ws,  \&extract_variable, $id, { MATCH  => \&extract_quotelike } ],
+    quotelike  => [ $ws,  $variable, $id, { MATCH  => \&extract_quotelike } ],
     regex      => [ $ws,  $pod_or_DATA, $id, $exql           ],
     string     => [ $ws,  $pod_or_DATA, $id, $exql           ],
-    code       => [ $ws, { DONT_MATCH => $pod_or_DATA },
-    		        \&extract_variable,
+    code       => [ $ws, { DONT_MATCH => $pod_or_DATA }, $variable,
                     $id, { DONT_MATCH => \&extract_quotelike }   ],
     code_no_comments
                => [ { DONT_MATCH => $comment },
-                    $ncws, { DONT_MATCH => $pod_or_DATA },
-    		        \&extract_variable,
+                    $ncws, { DONT_MATCH => $pod_or_DATA }, $variable,
                     $id, { DONT_MATCH => \&extract_quotelike }   ],
     executable => [ $ws, { DONT_MATCH => $pod_or_DATA }      ],
     executable_no_comments
diff --git a/dist/Filter-Simple/t/code_no_comments.t b/dist/Filter-Simple/t/code_no_comments.t
new file mode 100644
index 0000000000..444e7873f0
--- /dev/null
+++ b/dist/Filter-Simple/t/code_no_comments.t
@@ -0,0 +1,15 @@
+BEGIN {
+    unshift @INC, 't/lib/';
+}
+
+use Filter::Simple::CodeNoComments qr/ok/ => 'not ok';
+
+print "1..1\n";
+
+
+# Perl bug #92436 (the second bug in the ticket)
+
+sub method { $_[1] }
+my $obj = bless[];
+
+print $obj->method("ok 1\n");
diff --git a/dist/Filter-Simple/t/lib/Filter/Simple/CodeNoComments.pm b/dist/Filter-Simple/t/lib/Filter/Simple/CodeNoComments.pm
new file mode 100644
index 0000000000..168271ff2e
--- /dev/null
+++ b/dist/Filter-Simple/t/lib/Filter/Simple/CodeNoComments.pm
@@ -0,0 +1,13 @@
+package Filter::Simple::CodeNoComments;
+
+use Filter::Simple;
+
+FILTER_ONLY
+	code_no_comments => sub {
+		shift;
+		while (my($pat, $str) = splice @_, 0, 2) {
+			s/$pat/$str/g;
+		}
+	};
+
+1;