Test::MockDBI - Mock DBI interface for testing

Test-MockDBI documentation Contained in the Test-MockDBI distribution.

Index

Code Index:

NAME

Top

Test::MockDBI - Mock DBI interface for testing

SYNOPSIS

Top

  use Test::MockDBI;
     OR
  use Test::MockDBI qw( :all );

  Test::MockDBI::set_dbi_test_type(42);
  if (Test::MockDBI::get_dbi_test_type() == 42) {
    ...

  $mock_dbi = get_instance Test::MockDBI;

  $mock_dbi->bad_method(
   $method_name,
   $dbi_testing_type,
   $matching_sql);

  $mock_dbi->bad_param(
   $dbi_testing_type,
   $param_number,
   $param_value);

  $mock_dbi->set_retval_array(
   $dbi_testing_type,
   $matching_sql,
   @retval || CODEREF);
  $mock_dbi->set_retval_array(MOCKDBI_WILDCARD, ...

  $mock_dbi->set_retval_scalar(
   $dbi_testing_type,
   $matching_sql,
   $retval || CODEREF);
  $mock_dbi->set_retval_scalar(MOCKDBI_WILDCARD, ...

  $mock_dbi->set_rows(
   $dbi_testing_type,
   $matching_sql,
   $rows || CODEREF);
  $mock_dbi->set_rows(MOCKDBI_WILDCARD, ...

EXAMPLE

Top

Code: 

  # Enable testing with Test::MockDBI
  BEGIN { push @ARGV, "--dbitest"; }
  use Test::MockDBI qw( :all );
  my $md  = Test::MockDBI::get_instance();
  my $dbh = DBI->connect("", "", "");

  # Set of return values for given sql query
  my $aref_of_hrefs = [
    { name => 'Huey',  instrument => 'cello' },
    { name => 'Dewey', instrument => 'trombone' },
    { name => 'Louie', instrument => 'piano' },
  ];
  $md->set_retval_scalar(
    MOCKDBI_WILDCARD,
    "select name, instrument from nephews",
    sub { shift @$aref_of_hrefs }
  );

  # Execute the sql query and fetch results
  $dbh->prepare("select name, instrument from nephews");
  while (my $href = $dbh->fetchrow_hashref()) {
    print $href->{name} .
          " plays the " .
          $href->{instrument} . "\n";
  }
  __END__

Expected output:

  Huey plays the cello
  Dewey plays the trombone
  Louie plays the piano

DESCRIPTION

Top

Test::MockDBI provides a way to test DBI interfaces by creating rules for changing the DBI's behavior, then examining the standard output for matching patterns.

Testing using Test::MockDBI is enabled by setting the DBI testing type to a non-zero value. This can be done either by using a first program argument of "--dbitest[=TYPE]", or by using the class method Test::MockDBI::set_dbi_test_type(). (Supplying a first argument of "--dbitest[=TYPE]" often works well during testing.) TYPE is a simple integer (/^\d+$/). Supplying "--dbitest[=TYPE]" as a first argument works even if no other command-line processing is done, as Test::MockDBI does its own command-line processing to check for this first "--dbitest[=TYPE]" argument. You will want to add "--dbitest[=TYPE]" during a BEGIN block before the "use Test::MockDBI", so that the mock DBI is initialized as early as possible.

TYPE is optional, as a first argument of "--dbitest" will set the DBI testing type to 1 (one). DBI testing is also disabled by "--dbitest=0" (although this may not be generally useful). The class method Test::MockDBI::set_dbi_test_type() can also be used to set or change the DBI testing type.

When DBI testing is disabled, DBI is used as you would expect. This makes using Test::MockDBI transparent to your users.

The one exportable constant is:

MOCKDBI_WILDCARD

MOCKDBI_WILDCARD is the wildcard DBI testing type ("--dbitest=TYPE"), used when the fetch*() functions should always return the same value no matter what DBI testing type has been set.

External methods are:

get_dbi_test_type()

Returns the numeric DBI test type. The type is 0 when not testing the DBI interface.

set_dbi_test_type()

Sets the numeric DBI test type. The type is set to 0 if the argument cannot be interpreted as a simple integer digit string (/^\d+$/).

bad_method()

For the DBI method $method_name, when the DBI testing type is $dbi_testing_type and the current SQL matches the regex pattern in the string $matching_sql, make the function _fail (usually by returning undef).

bad_param()

When the DBI testing type is $dbi_testing_type, make the fetch*() functions fail if one of their corresponding bind_param()s has parameter number $param_number with the value $param_value.

set_retval_array()

When the DBI testing type is $dbi_testing_type and the current SQL matches the pattern in the string $matching_sql, fetch() and fetchrow_array() return the contents of the array @retval. If retval is actually a CODEREF, the array returned from calling that subroutine will be returned instead.

set_retval_scalar()

When the DBI testing type is $dbi_testing_type and the current SQL matches the pattern in the string $matching_sql, fetchall_arrayref(), fetchrow_arrayref(), fetchall_hashref(), fetchrow_hashref(), and fetchrow() return the scalar value $retval . If retval is actually a CODEREF, the scalar returned from calling that subroutine will be returned instead .

set_rows()

When the DBI testing type is $dbi_testing_type and the current SQL matches the pattern in the string $matching_sql, rows() returns the scalar value $rows. If retval is actually a CODEREF, the scalar returned from calling that subroutine will be returned instead.

set_errstr()

Allows errstr to be set and unset at runtime.

get_instance()

Returns the Test::MockDBI instance. This is a singleton. Will print debug messages to stdout if given a defined argument.

NOTES

Top

A good source of Test::MockDBI examples is how the t/*.t test programs works.

bad_method() forces developers to use a different DBI testing type ("--dbitest=TYPE") for each different SQL pattern for a DBI method. This can be construed as a feature. (The workaround to this feature is to use MOCKDBI_WILDCARD.)

DBI fetch() and fetchrow_array() will return the undef value if the specified return value is a 1-element array with undef as the only element. I don't think this should prove a major obstacle in testing. It was coded this way due to how Perl currently handles a return value of undef when an array is expected, which is a one-element array with undef as the only element.

MOCKDBI_WILDCARD is only supported for the fetch*() return value setting methods, set_retval_scalar() and set_retval_array(). It probably does not make sense for the other external methods, as they are for creating DBI failures (and how often do you want your code to fail for all DBI testing types?)

If for some strange reason you should be installing Test::MockDBI into a system with DBI but without any DBD drivers (apart from DBD drivers bundled with DBI), you can use: perl samples/DBD-setup.pl cp samples/DBI.cfg . to create a sample DBM database (zipcodes.*) for testing Test::MockDBI (DBD::DBM ships with DBI).

DBI fetchrow() is supported, although it is so old it is no longer documented in the mainline DBI docs.

SEE ALSO

Top

DBI, Test::MockObject::Extends, Test::Simple, Test::More, perl(1)

DBD::Mock (another approach to testing DBI applications)

DBI trace() (still another approach to testing DBI applications)

IO::String (for capturing standard output)

CAVEAT

Top

fetch*_hashref does not allow modification of returned data set.

This means you must copy-by-value if you wish to modify the data before returning to the calling client.

AUTHOR

Top

Mark Leighton Fisher, <mark-fisher@fisherscreek.com>

Minor modifications (version 0.62 onwards) by Andreas Faafeng <aff@cpan.org>

COPYRIGHT

Top

Copyright 2004, Fisher's Creek Consulting, LLC. Copyright 2004, DeepData, Inc.

LICENSE

Top

This code is released under the same licenses as Perl itself.

Test-MockDBI documentation Contained in the Test-MockDBI distribution. 
package Test::MockDBI;

# Test DBI interfaces using Test::MockObject.

# $Id: MockDBI.pm 283 2009-02-03 12:39:11Z aff $

# ------ use/require pragmas
use 5.008;                              # minimum Perl is V5.8.0
use strict;                             # better compile-time checking
use warnings;                           # better run-time checking
use Data::Dumper;                       # dump data in a pleasing format
use Test::MockObject::Extends;          # mock objects for extending classes
require Exporter;                       # we are an Exporter


# ------ exportable constant
use constant MOCKDBI_WILDCARD => 0;     # DBI type wildcard ("--dbitest=TYPE")


# ------ global variables
our %EXPORT_TAGS                        # named lists of symbols to export
 = ( 'all' => [ qw( MOCKDBI_WILDCARD ) ] );
our @EXPORT_OK                          # symbols to export upon request
 = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = qw();                     # symbols to always export
our @ISA = qw(Exporter);                # we ISA Exporter :)
our $VERSION = '0.65';                  # our version number

# ------ file-global variables
my %array_retval  = ();                 # return array values for matching SQL
my @bad_params    = ();                 # list of bad parameter values
my @bind_columns  = ();                 # bind_columns() list of refs to bind
my @cur_array     = ();                 # current array to return
my $cur_scalar    = undef;              # current scalar to return
my $cur_sql       = "";                 # current SQL
my %fail          = ();                 # hash for methods to fail, why and how
my $fail_param    = 0;                  # TRUE when failing due to bad param
my $instance      = undef;              # my only instance
my $mock          = "";                 # mock DBI object from Test::MockObject::Extends
my $object        = "";                 # our fake DBI object
my %rows_retval   = ();                 # return DBI::rows() values for matching SQL
my %scalar_retval = ();                 # return scalar values for matching SQL
my $type          = 0;                  # DBI testing type from command line
my %errstr        = ();                 # The scalar to return for errors
my $debug         = undef;              # Toggle to enable debugging

# ------ convert argument to defined value, use "" if undef argument
sub _define {
    my $arg = shift;                    # argument to convert

    if (defined($arg)) {
        return ($arg);
    }
    return "";
}


# ------ return TRUE if SQL matches pattern, handle undef values
sub _sql_match {
    my $sql     = _define(shift);        # SQL
    my $pattern = _define(shift);        # SQL regex string to match

    if (!$sql && !$pattern) {
        return 1;
    }
    if (!$pattern) {
        return 0;
    }
        if ($sql =~ m/$pattern/ms) {
                return 1;
        }
        return 0;
}


# ------ check if this DBI method should fail
sub _fail {
    my $method  = shift;                # method name
    my $spec    = "";                   # method failure specification

    # ------ fail returned data due to bad parameter
    if ($fail_param &&
     ($method =~ m/^fetch/ || $method =~ m/^select/)) {
        $fail_param = 0;
        return 1;
    }

    # ------ no failure modes for this DBI method
    $spec = $fail{$method};
    if (!defined($spec)) {
        return 0;
    }

    # ------ no failure modes for this MockDBI type
    if (!defined($spec->{$type})) {
        return 0;
    }

    # ------ return TRUE if SQL matches
    return _sql_match($cur_sql, $spec->{$type}->{"SQL"});
}


# ------ bind an array to DBI columns bound by bind_columns()
sub _bind_array {
    my $i;                              # generic loop index

    return if (scalar(@bind_columns == 0));

    for ($i = 0; $i < scalar(@bind_columns); $i++) {
        ${$bind_columns[$i]} = $_[$i];
    }
}


# ------ force an array return value
sub _force_retval_array {
    local $_;                           # localized topic
    my @array = ();                     # generic array

    foreach (@{ $array_retval{MOCKDBI_WILDCARD()} }, @{ $array_retval{$type} }) {
        if (_sql_match($cur_sql, $_->{"SQL"})) {
            if (ref($_->{"retval"}) eq "ARRAY"
             && ref($_->{"retval"}->[0]) eq "CODE") {
                @array = &{ $_->{"retval"}->[0] }();
                if (scalar(@array) > 0) {
                    _bind_array(@array);
                }
                return @array;
            }
            @array = @{ $_->{"retval"} };
            _bind_array(@array);

            # Return array ref if first element of array is HASH ref
            if (scalar(@array) && ref($array[0]) eq 'HASH') {
              (defined($array[0])) ? return \@array : return;
            }

            return @array;
        }
    }
    if (scalar(@_) < 1) {
        return ();
    }
    _bind_array(@_);
    return @_;
}


# ------ bind an arrayref to DBI columns bound by bind_columns()
sub _bind_arrayref {
    my $i;                              # generic loop index

    return if (scalar(@bind_columns == 0));
    if (ref($_[0]) ne "ARRAY") {
        for ($i = 0; $i < scalar(@bind_columns); $i++) {
            ${$bind_columns[$i]} = undef;
        }
    }

    for ($i = 0; $i < scalar(@bind_columns); $i++) {
        ${$bind_columns[$i]} = $_[0]->[$i];
    }
}


# ------ force a scalar return value
sub _force_retval_scalar {
    local $_;                           # localized topic
    my $arrayref = "";                  # (probably) generic arrayref

    foreach (@{ $scalar_retval{MOCKDBI_WILDCARD()} }, @{ $scalar_retval{$type} }) {
        if (_sql_match($cur_sql, $_->{"SQL"})) {
            if (ref($_->{"retval"}) eq "CODE") {
                $arrayref = &{ $_->{"retval"} }();
                if (defined($arrayref) && ref($arrayref) eq "ARRAY") {
                    _bind_arrayref($arrayref);
                }
                return $arrayref;
            }
            $arrayref = $_->{"retval"};
            _bind_arrayref($arrayref);
            return $arrayref;
        }
    }
    if (defined($_[0])) {
        _bind_arrayref($_[0]);
    }
    return $_[0];
}


# ------ force a DBI::rows() return value
sub _force_retval_rows {
    local $_;                           # localized topic

    foreach (@{ $rows_retval{MOCKDBI_WILDCARD()} }, @{ $rows_retval{$type} }) {
        if (_sql_match($cur_sql, $_->{"SQL"})) {
            if (ref($_->{"retval"}) eq "CODE") {
                return &{ $_->{"retval"} }();
            }
            return $_->{"retval"};
        }
    }
    return $_[0];
}


# ------ fake the specified DBI method call
sub _fake {
    my $method = shift;                 # file-global method name
    my $arg    = shift;                 # first method arg
    my $retval;                         # scalar to return

    print "\n$method()" if ($debug);
    if (defined($arg)) {
        print " '$arg'" if ($debug);
    }
    print "\n" if ($debug);
    if (_fail($method)) {
      return;
    }

    if ($method eq "rows") {
        $retval = shift;
        return _force_retval_rows($retval);
    } elsif ($method =~ m/^fetch/ || $method =~ m/^select/) {
        if ($method eq "fetch"
         || $method eq "fetchrow"
         || $method eq "fetchrow_array"
         || $method eq "selectrow_array") {
            return _force_retval_array(@_);
        }
        $retval = shift;
        return _force_retval_scalar($retval);
    }

    $retval = shift;
    return $retval;
}


# ------
# ------ Test::MockDBI external methods
# ------


# ------ return the current DBI testing type number
sub get_dbi_test_type {
    return $type;
}


# ------ set the current DBI testing type number
sub set_dbi_test_type {
    $type = shift;
    if (!defined($type) || $type !~ m/^\d+$/) {
        $type = 0;
    }
}


# ------ force a DBI method to be bad
sub bad_method {
    my $self   = shift;                 # my blessed self
    my $method = shift;                 # method name
    my $type   = shift;                 # type number from --dbitest=TYPE
    my $sql    = shift;                 # SQL pattern for badness

    $fail{$method}->{$type}->{"SQL"} = $sql;
    return 1;
}


# ------ set up an array return value for the specified SQL pattern
sub set_retval_array {
    my $self   = shift;                 # my blessed self
    my $type   = shift;                 # type number from --dbitest=TYPE
    my $sql    = shift;                 # SQL pattern for badness

    push @{ $array_retval{$type} },
     { "SQL" => $sql, "retval" => [ @_ ] },
}


# ------ set up scalar return value for the specified SQL pattern
sub set_retval_scalar {
    my $self   = shift;                 # my blessed self
    my $type   = shift;                 # type number from --dbitest=TYPE
    my $sql    = shift;                 # SQL pattern for badness

    push @{ $scalar_retval{$type} },
     { "SQL" => $sql, "retval" => $_[0] };
}


# ------ set up DBI::rows return value for the specified SQL pattern
sub set_rows {
    my $self   = shift;                 # my blessed self
    my $type   = shift;                 # type number from --dbitest=TYPE
    my $sql    = shift;                 # SQL pattern for badness

    push @{ $rows_retval{$type} },
     { "SQL" => $sql, "retval" => $_[0] },
}


# ------ force a parameter to be bad
# ------ Returns current number of bad params
sub bad_param {
    my $self      = shift;              # my blessed self
    my $bad_type  = shift;              # type number from --dbitest=TYPE
    my $bad_param = shift;              # "known" bad parameter number
    my $bad_value = shift;              # "known" bad parameter value

    push(@bad_params, [ $bad_type, $bad_param, $bad_value ] );
}

# ------ allow errstr to be set and unset
sub set_errstr {
    my $self      = shift;              # my blessed self
    my $bad_type  = shift;              # type number from --dbitest=TYPE
    my $arg       = shift;              # the argument
    if (defined($arg) && $arg ne '') {
      $errstr{$bad_type} = $arg;
    } else {
      $errstr{$bad_type} = undef;
    }
}

# Return true if given param name and value is bad in given mode,
# otherwise undefined.  Used for testing purposes only.
sub _is_bad_param {
  my $self   = shift;    # my blessed self
  my $type   = shift;    # type number from --dbitest=TYPE
  my $number = shift;    # "known" bad parameter number
  my $value  = shift;    # "known" bad parameter value

  foreach my $param (@bad_params) {
    if ( $param->[0] == $type
      && $param->[1] == $number
      && $param->[2] eq $value)
    {
      return 1;
    }
  }
  return;
}


#
# ------ GLOBAL INITIALIZATION
#
# ------ initialize our instance
$instance = bless {}, "Test::MockDBI";

# ------ set our testing type if we are in test mode
$type = 0;
if ($#ARGV >= 0 && $ARGV[0] =~ m/^--?dbitest(=(\d+))?/) {
    $type = 1;
    if (defined($2)) {
        $type = $2;
    }
    shift;
}

# ------ non-zero type of DBI testing to perform
if ($type) {

    # ------ initialize DBI mock interface
    $mock = Test::MockObject::Extends->new();
    print "mock DBI interface initialized...\n" if ($debug);

    $mock->fake_module("DBI",
     connect =>  sub {
        my $self = shift;
        my $dsn  = _define(shift);
        my $user = _define(shift);
        my $pass = _define(shift);
        $object = bless({}, "DBI");
        $cur_sql = "CONNECT TO $dsn AS $user WITH $pass";
        $fail_param = 0;
        @bind_columns = ();
        return _fake("connect", $cur_sql, $object);
     },
     ping =>  sub {
         return _fake("ping", $_[1], 1);
     },
     disconnect =>  sub {
        $cur_sql = "DISCONNECT";
        $fail_param = 0;
        @bind_columns = ();
        return _fake("disconnect", $_[1], 1);
     },
     errstr =>  sub {
       return _fake("errstr", $_[1], $errstr{$type});
     },
     prepare =>  sub {
        $cur_sql = _define($_[1]);
        $fail_param = 0;
        @bind_columns = ();
        return _fake("prepare", $_[1], $object);
     },
     prepare_cached =>  sub {
        $cur_sql = _define($_[1]);
        $fail_param = 0;
        @bind_columns = ();
        return _fake("prepare_cached", $_[1], $object);
     },
     commit =>  sub {
        return _fake("commit", $_[1], 1);
     },
     bind_columns =>  sub {
        shift;
        @bind_columns = @_;
        return _fake("bind_columns", $_[0], 1);
     },
     bind_param => sub {
        # Return 1 if param bound was good, otherwise -1 (still true,
        # but indicates badness)

        my $self         = shift;             # my blessed self
        my $param        = _define(shift);    # parameter number
        my $value        = shift;             # parameter value
        my $attr_or_type = _define(shift);    # attributes or type
        my $bad_param    = "";                # 1 of @bad_params

        print "\nbind_param()\n" if ($debug);
        print "parm $param, value " if ($debug);
        print Dumper($value);
        if ($attr_or_type) {
            if (ref($attr_or_type) eq "HASH") {
                print "  attrs ", Dumper($attr_or_type) if ($debug);
            } else {
                print "type '$attr_or_type'" if ($debug);
            }
        }
        print "\n" if ($debug);
        if (_fail("bind_param")) {
           return;
        }
        ## no critic (RequireLexicalLoopIterators)
        foreach $bad_param (@bad_params) {
            if ($bad_param->[0] == $type
             && $bad_param->[1] == $param
             && $bad_param->[2] eq $value) {
                print "MOCK_DBI: BAD PARAM $param = '$value'\n" if ($debug);
                $fail_param = 1;
                return -1;  # Indicate that param is bad
            }
        }
        return 1;
     },
     do =>  sub {
        return _fake("do", $_[1], 1);
     },
     execute =>  sub {
        return _fake("execute", $_[1], 1);
     },
     finish =>  sub {
        $fail_param = 0;
        return _fake("finish", $_[1], 1);
     },
     fetchall_arrayref =>  sub {
        return _fake("fetchall_arrayref", $_[1], undef);
     },
     fetchrow_arrayref =>  sub {
        return _fake("fetchrow_arrayref", $_[1], undef);
     },
     fetchrow_hashref =>  sub {
        return _fake("fetchrow_hashref", $_[1], undef);
     },
     fetchall_hashref =>  sub {
        return _fake("fetchall_hashref", $_[1], undef);
     },
     fetchrow_array =>  sub {
        return _fake("fetchrow_array", $_[1]);
     },
     fetchrow =>  sub {
        return _fake("fetchrow", $_[1]);
     },
     fetch =>  sub {
        return _fake("fetch", $_[1]);
     },
     rows =>  sub {
        return _fake("rows", $_[1], 0);
     },
     );
    $mock->fake_new("DBI");
}



# ------ return our instance, as we are a singleton class
sub get_instance {
  $debug = shift;
  return $instance;
}


1;

__END__