Generate Fixtures for DBD::Mock::Session
Tags: dbdmocksession, perl, testing, unittest
Published: 2024-04-29 06:43:50

A while ago I discovered `DBD::Mock` and it looked like a great tool to use in Perl unit tests. However the challenge of generating the fixtures was not always easy.
In order to solve this issue I have put together a small library that should help generate the fixture data needed.
At the core this very simple, I have mocked `DBI` subs in order to capture the necessary information and stored it into a file:
The first step was to generate an override object and store it on `$self`:

```PERL
package DBD::Mock::Session::GenerateFixtures;
use Sub::Override;
...

our $override           = Sub::Override->new();
sub new {
 $self->{override}      = $override;
}
```

Then we can use this to mock `DBI` code like in the following example:

```PERL
sub _override_dbi_execute {
	my $self        = shift;
	my $dbi_execute = shift;
	
	my $orig_execute = \&$dbi_execute;

	$self->get_override_object()->replace(
		$dbi_execute,
		sub {
			my ($sth, @args) = @_;

			my $sql = $sth->{Statement};

			my $col_names = $sth->{NAME};
			my $retval    = $orig_execute->($sth, @args);

			my $rows       = $sth->rows();
			my $query_data = {
				statement    => $sql,
				bound_params => \@args,
				col_names    => $col_names,
			};

			my $result = [];
			if ($rows > 0) {
				foreach my $row (1 .. $rows) {
					push @{$result}, [];
				}
				$query_data->{results} = $result;
			}

			$query_data->{bound_params} = $self->{bind_params}
				if scalar @{$self->{bind_params}} > 0;

			push @{$self->{result}}, $query_data;
			$self->_write_to_file();
			$self->{bind_params} = [];
			$self->{sth}         = $sth;
			return $retval;
		}
	);

	return $self;
}

```
This code works for `do` or `prepare` and `execute` when you are trying to mock insert, update or delete statements like is this example:

```Perl
subtest 'upsert generate mock data' => sub {
	my $dbh = db_handle('test.db');

	build_tests_db($dbh);
	populate_test_db($dbh);

	my $obj = DBD::Mock::Session::GenerateFixtures->new({dbh => $dbh});
	$dbh = $obj->get_dbh();

	my $sql_license = <<"SQL";
INSERT INTO licenses (name, allows_commercial) VALUES ( ?, ? )
SQL

	chomp $sql_license;
	my $r = $dbh->do($sql_license, undef, 'test_license', 'no');
	is($r, 1, 'one row inserted is ok');

	my $update_sql = 'update licenses set allows_commercial = ? where id > ?';
	$r = $dbh->do($update_sql, undef, 'yes', '3');
	is($r, 2, 'update works ok');

	$r = $dbh->do($update_sql, undef, 'yes', '100');

	is($r, '0E0', 'now rows updated');

	my $delete_sql = 'DELETE FROM licenses WHERE id = ?';
	my $sth        = $dbh->prepare($delete_sql);
	$sth->execute(3);

	is($sth->rows(), 1, 'delete with prepare and execute is ok');

	$obj->restore_all();
	$dbh->disconnect();
};

```
 
The the following data is stored in a `Json` file:


```
[
   {
      "statement" : "INSERT INTO licenses (name, allows_commercial) VALUES ( ?, ? )",
      "results" : [
         []
      ],
      "col_names" : [],
      "bound_params" : [
         "test_license",
         "no"
      ]
   },
   {
      "bound_params" : [
         "yes",
         "3"
      ],
      "statement" : "update licenses set allows_commercial = ? where id > ?",
      "col_names" : [],
      "results" : [
         [],
         []
      ]
   },
   {
      "col_names" : [],
      "statement" : "update licenses set allows_commercial = ? where id > ?",
      "bound_params" : [
         "yes",
         "100"
      ]
   },
   {
      "statement" : "DELETE FROM licenses WHERE id = ?",
      "col_names" : [],
      "results" : [
         []
      ],
      "bound_params" : [
         3
      ]
   }
]
```
 Please observe how the results key is populate with an empty array for each row touched by our statement and it is ready to be used when a DBD::Mock::Session object is built.
For select statements you need a extra layer of mocking in order to store the exact values a select could use.
Here is how the mock for `fetchrow_hashref` looks like:

```Perl

sub _override_dbi_fetchrow_hashref {
	my $self             = shift;
	my $fetchrow_hashref = shift;

	my $orig_selectrow_hashref = \&$fetchrow_hashref;

	$self->get_override_object()->replace(
		$fetchrow_hashref,
		sub {
			my ($sth) = @_;

			my $retval = $orig_selectrow_hashref->($sth);

			if (ref $retval) {
				my $query_results = $self->_set_hashref_response($sth, $retval);
				push @{$self->{result}->[-1]->{results}}, $query_results;
				$self->_write_to_file();
			}

			return $retval;
		}
	);

	return $self;
}


```
This produces the following data by pushing the each row in the result key:

```
[
   {
      "statement" : "SELECT * FROM media_types WHERE id IN(?,?)",
      "col_names" : [
         "id",
         "media_type"
      ],
      "results" : [
         [
            1,
            "video"
         ],
         [
            2,
            "audio"
         ]
      ],
      "bound_params" : [
         2,
         1
      ]
   }
]
```
Form this point one I just need to make sure that every way in which DBI lets you get the data is covered by my code. In the end I end it mocking the following subs:

```
Readonly::Hash my %MOCKED_DBI_METHODS => (
	execute            => 'DBI::st::execute',
	bind_param         => 'DBI::st::bind_param',
	fetchrow_hashref   => 'DBI::st::fetchrow_hashref',
	fetchrow_arrayref  => 'DBI::st::fetchrow_arrayref',
	fetchrow_array     => 'DBI::st::fetchrow_array',
	selectall_arrayref => 'DBI::db::selectall_arrayref',
	selectall_hashref  => 'DBI::db::selectall_hashref',
	selectcol_arrayref => 'DBI::db::selectcol_arrayref',
	selectrow_array    => 'DBI::db::selectrow_array',
	selectrow_arrayref => 'DBI::db::selectrow_arrayref',
	selectrow_hashref  => 'DBI::db::selectrow_hashref',
);
```
If you want to give this a try you can get the full code from this url:
[DBD-Fixtures](https://github.com/DragosTrif/DBD-Fixtures/tree/master)