From 3f47291432d23a4da5e85270f0a5e356ca6994ff Mon Sep 17 00:00:00 2001
From: Nicholas Clark <nick@ccl4.org>
Date: Fri, 4 Feb 2011 15:32:28 +0000
Subject: [PATCH] In B's OptreeCheck, implement proper qr// matching for
 regexps.

Hence we can now do string matching on strings, rather than treating everything
as a regexp.
---
 ext/B/t/OptreeCheck.pm   | 39 ++++++++++++++++++---------------------
 ext/B/t/optree_concise.t |  2 +-
 2 files changed, 19 insertions(+), 22 deletions(-)

diff --git a/ext/B/t/OptreeCheck.pm b/ext/B/t/OptreeCheck.pm
index 09f6c4b..fc374aa 100644
--- a/ext/B/t/OptreeCheck.pm
+++ b/ext/B/t/OptreeCheck.pm
@@ -51,7 +51,8 @@ various modes.
     prog   => 'sort @a',	# run in subprocess, aka -MO=Concise
     bcopts => '-exec',		# $opt or \@opts, passed to BC::compile
 
-    errs   => 'Useless variable "@main::a" .*'	# str, regex, [str+] [regex+],
+    errs   => 'Name "main::a" used only once: possible typo at -e line 1.',
+				# str, regex, [str+] [regex+],
 
     # various test options
     # errs   => '.*',		# match against any emitted errs, -w warnings
@@ -452,19 +453,8 @@ sub newTestCases {
 	    $tc->{$k} = $gOpts{$k} unless defined $tc->{$k};
 	}
     }
-    # transform errs to self-hash for efficient set-math
     if ($tc->{errs}) {
-	if (not ref $tc->{errs}) {
-	    $tc->{errs} = { $tc->{errs} => 1};
-	}
-	elsif (ref $tc->{errs} eq 'ARRAY') {
-	    my %errs;
-	    @errs{@{$tc->{errs}}} = (1) x @{$tc->{errs}};
-	    $tc->{errs} = \%errs;
-	}
-	elsif (ref $tc->{errs} eq 'Regexp') {
-	    warn "regexp err matching not yet implemented";
-	}
+	$tc->{errs} = [$tc->{errs}] unless ref $tc->{errs} eq 'ARRAY';
     }
     return $tc;
 }
@@ -559,23 +549,30 @@ sub checkErrs {
     # check rendering errs against expected errors, reduce and report
     my $tc = shift;
 
-    # check for agreement, by hash (order less important)
-    my (%goterrs, @got);
+    # check for agreement (order not important)
+    my (%goterrs, @missed);
     @goterrs{@{$tc->{goterrs}}} = (1) x scalar @{$tc->{goterrs}}
 	if $tc->{goterrs};
 
-    foreach my $k (keys %{$tc->{errs}}) {
-	if (@got = grep /^$k$/, keys %goterrs) {
-	    delete $tc->{errs}{$k};
-	    delete $goterrs{$_} foreach @got;
+    foreach my $want (@{$tc->{errs}}) {
+	if (ref $want) {
+	    my $seen;
+	    foreach my $k (keys %goterrs) {
+		next unless $k =~ $want;
+		delete $goterrs{$k};
+		++$seen;
+	    }
+	    push @missed, $want unless $seen;
+	} else {
+	    push @missed, $want unless defined delete $goterrs{$want};
 	}
     }
 
     # relook at altered
-    if (%{$tc->{errs}} or %goterrs) {
+    if (@missed or %goterrs) {
 	my @lines;
 	push @lines, "got unexpected:", sort keys %goterrs if %goterrs;
-	push @lines, "missed expected:", sort keys %{$tc->{errs}}   if %{$tc->{errs}};
+	push @lines, "missed expected:", sort @missed if @missed;
 
 	if (@lines) {
 	    unshift @lines, $tc->{name};
diff --git a/ext/B/t/optree_concise.t b/ext/B/t/optree_concise.t
index df4162a..a72e7c8 100644
--- a/ext/B/t/optree_concise.t
+++ b/ext/B/t/optree_concise.t
@@ -274,7 +274,7 @@ checkOptree
     ( name	=> 'cmdline self-strict compile err using code',
       code	=> 'use strict; sort @a',
       bcopts	=> [qw/ -basic -concise -exec /],
-      errs	=> 'Global symbol "@a" requires explicit package name at .*? line 1.',
+      errs	=> qr/Global symbol "\@a" requires explicit package name at .*? line 1\./,
       note	=> 'this test relys on a kludge which copies $@ to rendering when empty',
       expect	=> 'Global symbol',
       expect_nt	=> 'Global symbol',
-- 
2.7.4