Update upstream source from tag 'upstream/1.54'

Update to upstream version '1.54'
with Debian dir ffa10d21e378f6afd47b5566688d78cd19838286

8 files changed, 157 insertions, 47 deletions

diff --git a/Changes b/Changes
index 2169b78..800c42c 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,17 @@
 Revision history for Perl extension DBD::Mock.
 
+1.54 2019-12-23T12:44:22Z
+    - Added Bernhard Graf's 'Feature: one shot failure' merge request.
+    - Fixed description of the failure attribute of mock_add_resultset. It
+      no longer claims to support a hash ref (as it doesn't). Thanks to
+      Bernhard Graf for both the bug report and a merge request that fixes it.
+    - Fixed bug where it wasn't possible to replace a regular expression 
+      mock resultset. Thanks to Bernhard Graf for both the bug report and
+      a merge request that fixes it.
+    - Fixed bug where the failure attribute wasn't working with regular
+      expression mock resultsets. Thanks to Bernhard Graf for both the bug
+      report and a merge request that fixes it.
+
 1.53 2019-12-03T10:50:57Z
     - Error handling in mock_add_resultset is no longer experimental
     - Attribute Aliasing is no longer experimental
diff --git a/META.json b/META.json
index 5563512..f8216e4 100644
--- a/META.json
+++ b/META.json
@@ -61,7 +61,7 @@
    "provides" : {
       "DBD::Mock" : {
          "file" : "lib/DBD/Mock.pm",
-         "version" : "1.53"
+         "version" : "1.54"
       },
       "DBD::Mock::Pool" : {
          "file" : "lib/DBD/Mock/Pool.pm"
@@ -96,9 +96,10 @@
          "web" : "https://gitlab.com/scrapheap/DBD-Mock"
       }
    },
-   "version" : "1.53",
+   "version" : "1.54",
    "x_authority" : "cpan:JLCOOPER",
    "x_contributors" : [
+      "Bernhard Graf <GRAF@cpan.org>",
       "Chisel <CHISEL@cpan.org>",
       "Dave Rolsky <DROLSKY@cpan.org>",
       "Frédéric Brière <FBRIERE@cpan.org>",
diff --git a/META.yml b/META.yml
index 9b8aa6b..43d9e62 100644
--- a/META.yml
+++ b/META.yml
@@ -31,7 +31,7 @@ no_index:
 provides:
   DBD::Mock:
     file: lib/DBD/Mock.pm
-    version: '1.53'
+    version: '1.54'
   DBD::Mock::Pool:
     file: lib/DBD/Mock/Pool.pm
   DBD::Mock::Pool::db:
@@ -55,9 +55,10 @@ requires:
 resources:
   homepage: https://gitlab.com/scrapheap/DBD-Mock
   repository: git://gitlab.com/scrapheap/DBD-Mock.git
-version: '1.53'
+version: '1.54'
 x_authority: cpan:JLCOOPER
 x_contributors:
+  - 'Bernhard Graf <GRAF@cpan.org>'
   - 'Chisel <CHISEL@cpan.org>'
   - 'Dave Rolsky <DROLSKY@cpan.org>'
   - 'Frédéric Brière <FBRIERE@cpan.org>'
diff --git a/README.md b/README.md
index 4ac975d..e74771d 100644
--- a/README.md
+++ b/README.md
@@ -300,7 +300,7 @@ information as properties (accessed like a hash) rather than methods.
     to be set to `0` (or off), then both `Active` and `ping` would return false
     values (or `0`).
 
-- **`mock_add_resultset( \@resultset | \%sql_and_resultset )`**
+- **`mock_add_resultset( \@resultset | \%resultset_and_options )`**
 
     This stocks the database handle with a record set, allowing you to seed data
     for your application to see if it works properly. Each recordset is a simple
@@ -351,7 +351,21 @@ information as properties (accessed like a hash) rather than methods.
         # this will fetch rows from the second resultset...
         my $row = $sth->fetchrow_arrayref;
 
-    You can also associate a resultset with a particular SQL statement instead of
+    It is possible to assign a hashref where the resultset must be given as
+    value for the `results` key:
+
+        $dbh->{mock_add_resultset} = {
+            results => [
+                [ 'foo', 'bar' ],
+                [ 'this_one', 'that_one' ],
+                [ 'this_two', 'that_two' ],
+            ],
+        };
+
+    The reason for the hashref form is that you can add options as described
+    in the following.
+
+    You can associate a resultset with a particular SQL statement instead of
     adding them in the order they will be fetched:
 
         $dbh->{mock_add_resultset} = {
@@ -445,11 +459,8 @@ information as properties (accessed like a hash) rather than methods.
     patch ;) it will do for now.
 
     If you want a given statement to fail, you will have to use the hashref method
-    and add a `failure` key. That key can be handed an arrayref with the error
-    number and error string, in that order. It can also be handed a hashref with
-    two keys - `errornum` and `errorstring`. If the `failure` key has no useful
-    value associated with it, the `errornum` will be `1` and the `errorstring`
-    will be `Unknown error`.
+    and add a `failure` key. That key must be handed an arrayref with the error
+    number and error string, in that order.
 
         $dbh->{mock_add_resultset} = {
             sql => 'SELECT foo FROM bar',
@@ -457,6 +468,13 @@ information as properties (accessed like a hash) rather than methods.
             failure => [ 5, 'Ooops!' ],
         };
 
+    Without the `sql` attribute the next statement will fail in any case:
+
+        $dbh->{mock_add_resultset} = {
+            results => DBD::Mock->NULL_RESULTSET,
+            failure => [ 5, 'Ooops!' ],
+        };
+
 - **`mock_get_info`**
 
     This attribute can be used to set up values for `get_info()`. It takes a
@@ -1233,6 +1251,8 @@ methods and tests.
 - Thanks to Chas Owens for patch and test for the `mock_can_prepare`,
 `mock_can_execute`, and `mock_can_fetch` features.
 - Thanks to Tomas Zemresfor the unit test in RT #71438.
+- Thanks to Bernhard Graf for multiple patches fixing a range of issues
+and adding a new _One Shot Failure_ feature to `mock_add_resultset`.
 
 # COPYRIGHT
 
diff --git a/lib/DBD/Mock.pm b/lib/DBD/Mock.pm
index 0272066..ffcefea 100644
--- a/lib/DBD/Mock.pm
+++ b/lib/DBD/Mock.pm
@@ -30,7 +30,7 @@ sub import {
       if ( @_ && lc( $_[0] ) eq "pool" );
 }
 
-our $VERSION = '1.53';
+our $VERSION = '1.54';
 
 our $drh    = undef;    # will hold driver handle
 our $err    = 0;        # will hold any error codes
@@ -447,7 +447,7 @@ according to the value of C<mock_can_connect>. So if C<mock_can_connect> were
 to be set to C<0> (or off), then both C<Active> and C<ping> would return false
 values (or C<0>).
 
-=item B<C<mock_add_resultset( \@resultset | \%sql_and_resultset )>>
+=item B<C<mock_add_resultset( \@resultset | \%resultset_and_options )>>
 
 This stocks the database handle with a record set, allowing you to seed data
 for your application to see if it works properly. Each recordset is a simple
@@ -498,7 +498,21 @@ Here is a sample usage, partially from the test suite:
     # this will fetch rows from the second resultset...
     my $row = $sth->fetchrow_arrayref;
 
-You can also associate a resultset with a particular SQL statement instead of
+It is possible to assign a hashref where the resultset must be given as
+value for the C<results> key:
+
+    $dbh->{mock_add_resultset} = {
+        results => [
+            [ 'foo', 'bar' ],
+            [ 'this_one', 'that_one' ],
+            [ 'this_two', 'that_two' ],
+        ],
+    };
+
+The reason for the hashref form is that you can add options as described
+in the following.
+
+You can associate a resultset with a particular SQL statement instead of
 adding them in the order they will be fetched:
 
     $dbh->{mock_add_resultset} = {
@@ -592,11 +606,8 @@ me for now, and until I can come up with a better method, or someone sends me a
 patch ;) it will do for now.
 
 If you want a given statement to fail, you will have to use the hashref method
-and add a C<failure> key. That key can be handed an arrayref with the error
-number and error string, in that order. It can also be handed a hashref with
-two keys - C<errornum> and C<errorstring>. If the C<failure> key has no useful
-value associated with it, the C<errornum> will be C<1> and the C<errorstring>
-will be C<Unknown error>.
+and add a C<failure> key. That key must be handed an arrayref with the error
+number and error string, in that order.
 
     $dbh->{mock_add_resultset} = {
         sql => 'SELECT foo FROM bar',
@@ -604,6 +615,12 @@ will be C<Unknown error>.
         failure => [ 5, 'Ooops!' ],
     };
 
+Without the C<sql> attribute the next statement will fail in any case:
+
+    $dbh->{mock_add_resultset} = {
+        results => DBD::Mock->NULL_RESULTSET,
+        failure => [ 5, 'Ooops!' ],
+    };
 
 =item B<C<mock_get_info>>
 
@@ -1453,6 +1470,9 @@ C<mock_can_execute>, and C<mock_can_fetch> features.
 
 =item Thanks to Tomas Zemresfor the unit test in RT #71438.
 
+=item Thanks to Bernhard Graf for multiple patches fixing a range of issues
+and adding a new I<One Shot Failure> feature to C<mock_add_resultset>.
+
 =back
 
 =head1 COPYRIGHT
diff --git a/lib/DBD/Mock/db.pm b/lib/DBD/Mock/db.pm
index 4324f53..80ba29d 100644
--- a/lib/DBD/Mock/db.pm
+++ b/lib/DBD/Mock/db.pm
@@ -110,19 +110,22 @@ sub prepare {
     else {
         # If we have available resultsets seed the tracker with one
 
-        my $rs;
-        my $callback;
+        my ($rs, $callback, $failure);
+
         if ( my $all_rs = $dbh->{mock_rs} ) {
             if ( my $by_name = defined $all_rs->{named}{$statement} ? $all_rs->{named}{$statement} : first { $statement =~ m/$_->{regexp}/ } @{ $all_rs->{matching} } ) {
                 # We want to copy this, because it is meant to be reusable
                 $rs = [ @{ $by_name->{results} } ];
                 $callback = $by_name->{callback};
-                if ( exists $by_name->{failure} ) {
-                    $track_params{failure} = [ @{ $by_name->{failure} } ];
-                }
+                $failure = $by_name->{failure};
             }
             else {
                 $rs = shift @{ $all_rs->{ordered} };
+                if (ref($rs) eq 'HASH') {
+                    $callback = $rs->{callback};
+                    $failure = $rs->{failure};
+                    $rs = [ @{ $rs->{results} } ];
+                }
             }
         }
 
@@ -131,6 +134,7 @@ sub prepare {
             $track_params{return_data} = $rs;
             $track_params{fields}      = $fields;
             $track_params{callback}    = $callback;
+            $track_params{failure}     = $failure;
 
             if( $fields ) {
                 $sth->STORE( NAME          => $fields );
@@ -344,45 +348,55 @@ sub STORE {
         return $value;
     }
     elsif ( $attrib eq 'mock_add_resultset' ) {
+        my @copied_values;
+
         $dbh->{mock_rs} ||= {
             named   => {},
             ordered => [],
             matching => [],
         };
+
         if ( ref $value eq 'ARRAY' ) {
-            my @copied_values = @{$value};
+            @copied_values = @{$value};
             push @{ $dbh->{mock_rs}{ordered} }, \@copied_values;
-            return \@copied_values;
         }
         elsif ( ref $value eq 'HASH' ) {
             my $name = $value->{sql};
-            unless ($name) {
-                die "Indexing resultset by name requires passing in 'sql' ",
-                  "as hashref key to 'mock_add_resultset'.\n";
-            }
 
-            my @copied_values = @{ $value->{results} ? $value->{results} : [] };
+            @copied_values = @{ $value->{results} ? $value->{results} : [] };
 
-            if ( ref $name eq "Regexp" ) {
-                push @{ $dbh->{mock_rs}{matching} }, {
+            if (not defined $name) {
+                push @{ $dbh->{mock_rs}{ordered} }, {
+                    results => \@copied_values,
+                    callback => $value->{callback},
+                    failure => ref($value->{failure}) ? [ @{ $value->{failure} } ] : undef,
+                };
+            }
+            elsif ( ref $name eq "Regexp" ) {
+                my $matching = {
                     regexp => $name,
                     results => \@copied_values,
                     callback => $value->{callback},
+                    failure => ref($value->{failure}) ? [ @{ $value->{failure} } ] : undef,
                 };
-            } else {
-                $dbh->{mock_rs}{named}{$name} = { results => \@copied_values, callback => $value->{callback} };
+                # either replace existing match or push
+                grep { $_->{regexp} eq $name && ($_ = $matching) } @{ $dbh->{mock_rs}{matching} }
+                  or push @{ $dbh->{mock_rs}{matching} }, $matching;
             }
-
-            if ( exists $value->{failure} ) {
-                $dbh->{mock_rs}{named}{$name}{failure} =
-                  [ @{ $value->{failure} }, ];
+            else {
+                $dbh->{mock_rs}{named}{$name} = {
+                    results => \@copied_values,
+                    callback => $value->{callback},
+                    failure => ref($value->{failure}) ? [ @{ $value->{failure} } ] : undef,
+                };
             }
-            return \@copied_values;
         }
         else {
             die "Must provide an arrayref or hashref when adding ",
               "resultset via 'mock_add_resultset'.\n";
         }
+
+        return \@copied_values;
     }
     elsif ( $attrib eq 'mock_start_insert_id' ) {
         if ( ref $value eq 'ARRAY' ) {
diff --git a/t/016_mock_add_resultset_test.t b/t/016_mock_add_resultset_test.t
index 78525f4..6743a82 100644
--- a/t/016_mock_add_resultset_test.t
+++ b/t/016_mock_add_resultset_test.t
@@ -114,6 +114,26 @@ $dbh->{mock_add_resultset} = {
     $sth->finish();
 }
 
+## overwrite regular expression matching
+$dbh->{mock_add_resultset} = {
+    sql => qr/^SELECT foo/,
+    results => [ [ 'foo' ], [ 400 ] ],
+};
+
+{
+    my $sth = $dbh->prepare('SELECT foo FROM oof');
+    isa_ok($sth, 'DBI::st');
+
+    my $rows = $sth->execute();
+    is($rows, '0E0', '... got back 0E0 for rows with a SELECT statement');
+
+    my ($result) = $sth->fetchrow_array();
+
+    is($result, 400, '... got the result we expected');
+
+    $sth->finish();
+}
+
 # check that statically assigned queries take precedence over regex matched ones
 {
     my $sth = $dbh->prepare('SELECT foo FROM bar');
diff --git a/t/023_statement_failure.t b/t/023_statement_failure.t
index 1e47a19..873565a 100644
--- a/t/023_statement_failure.t
+++ b/t/023_statement_failure.t
@@ -13,25 +13,47 @@ BEGIN {
 # test misc. attributes
 
 {
-    my $dbh = DBI->connect('DBI:Mock:', 'user', 'pass');
+    my $dbh = DBI->connect('DBI:Mock:', '', '', {RaiseError => 1, PrintError => 0});
     isa_ok($dbh, 'DBI::db'); 
-    
+
     $dbh->{mock_add_resultset} = {
-        sql => 'SELECT foo FROM bar',
+        results => DBD::Mock->NULL_RESULTSET,
+        failure => [ 3, 'Ohlala!' ],
+    };
+
+    my $sth = eval { $dbh->prepare('INSERT INTO bar (foo) VALUES (?)') };
+    ok(!$@, '$sth handle prepared correctly');
+    isa_ok($sth, 'DBI::st');
+
+    eval { $sth->execute('baz') };
+    ok( $@, '$sth handled executed and died' );
+
+    $dbh->{mock_add_resultset} = {
+        sql => qr/SELECT/,
         results => DBD::Mock->NULL_RESULTSET,
         failure => [ 5, 'Ooops!' ],
     };
 
-    $dbh->{PrintError} = 0;
-    $dbh->{RaiseError} = 1;
+    $sth = eval { $dbh->prepare('SELECT foo FROM bar') };
+    ok(!$@, '$sth handle prepared correctly');
+    isa_ok($sth, 'DBI::st');
+
+    eval { $sth->execute() };
+    ok( $@, '$sth handled executed and died' );
+
+    $dbh->{mock_add_resultset} = {
+        sql => 'SELECT foo FROM bar',
+        results => DBD::Mock->NULL_RESULTSET,
+        failure => [ 5, 'Ooops!' ],
+    };
 
-    my $sth = eval { $dbh->prepare('SELECT foo FROM bar') };
+    $sth = eval { $dbh->prepare('SELECT foo FROM bar') };
     ok(!$@, '$sth handle prepared correctly');
     isa_ok($sth, 'DBI::st');
 
     eval { $sth->execute() };
     ok( $@, '$sth handled executed and died' );
-    
+
     $dbh->{mock_add_resultset} = {
         sql     => 'SELECT bar FROM foo',
         results => [