Fix handling of empty pattern in "pattern", "patternProperties" keywords

perldoc perlop: "If the PATTERN evaluates to the empty string, the last
successfully matched regular expression is used instead."

This could lead to bizarre failures if there was a successful match in a
containing scope to the evaluation.

Author: karenetheridge

Changes

@@ -1,6 +1,8 @@
 Revision history for JSON-Schema-Tiny
 
 {{$NEXT}}
+          - fix bad handling of empty patterns in "pattern",
+            "patternProperties" keywords
 
 0.020     2023-04-12 03:28:28Z
           - update test results and exemptions for TJSA 1.019

lib/JSON/Schema/Tiny.pm

@@ -520,7 +520,7 @@ sub _eval_keyword_pattern ($data, $schema, $state) {
   assert_pattern($state, $schema->{pattern});
 
   return 1 if not is_type('string', $data);
-  return 1 if $data =~ m/$schema->{pattern}/;
+  return 1 if $data =~ m/(?:$schema->{pattern})/;
   return E($state, 'pattern does not match');
 }
 
@@ -950,7 +950,7 @@ sub _eval_keyword_patternProperties ($data, $schema, $state) {
 
   my $valid = 1;
   foreach my $property_pattern (sort keys $schema->{patternProperties}->%*) {
-    foreach my $property (sort grep m/$property_pattern/, keys %$data) {
+    foreach my $property (sort grep m/(?:$property_pattern)/, keys %$data) {
       if (is_type('boolean', $schema->{patternProperties}{$property_pattern})) {
         next if $schema->{patternProperties}{$property_pattern};
         $valid = E({ %$state, data_path => jsonp($state->{data_path}, $property),
@@ -979,7 +979,7 @@ sub _eval_keyword_additionalProperties ($data, $schema, $state) {
   foreach my $property (sort keys %$data) {
     next if exists $schema->{properties} and exists $schema->{properties}{$property};
     next if exists $schema->{patternProperties}
-      and any { $property =~ /$_/ } keys $schema->{patternProperties}->%*;
+      and any { $property =~ /(?:$_)/ } keys $schema->{patternProperties}->%*;
 
     if (is_type('boolean', $schema->{additionalProperties})) {
       next if $schema->{additionalProperties};

t/pattern.t

@@ -49,4 +49,30 @@ $tests->($letter, 'upgraded');
 utf8::downgrade($letter);
 $tests->($letter, 'downgraded');
 
+subtest 'empty pattern' => sub {
+  # create a "last successful match" in a containing scope
+  my $str = "furble" =~ s/fur/meow/r;
+
+  cmp_deeply(
+    evaluate('hello', { pattern => '' }),
+    { valid => true },
+    'empty pattern in "pattern" will correctly match',
+  );
+
+  # create a new "last successful match"
+  $str = "furble" =~ s/fur/meow/r;
+
+  cmp_deeply(
+    evaluate(
+      { alpha => 'hello' },
+      {
+        patternProperties => { '' => true },
+        additionalProperties => false,
+      },
+    ),
+    { valid => true },
+    'empty pattern in "patternProperties" will correctly match',
+  );
+};
+
 done_testing;