File Coverage

blib/lib/Test/DatabaseRow.pm

Criterion	Covered	Total	%
statement	55	55	100.0
branch	18	18	100.0
condition	9	15	60.0
subroutine	9	9	100.0
pod	3	3	100.0
total	94	100	94.0

package Test::DatabaseRow;

# require at least a version of Perl that is merely ancient, but not
# prehistoric
use 5.006;

use strict;
use warnings;

# set row_ok to be exported
use base qw(Exporter);
our @EXPORT;

use Carp qw(croak);
our @CARP_OK = qw(Test::DatabaseRow TestDatabaseRow::Object);

# set the version number
our $VERSION = "2.04";

use Test::DatabaseRow::Object;
our $object_class = "Test::DatabaseRow::Object";

sub row_ok {

  # horrible, horrible package vars
  # In 2003 Mark Fowler chose to make a procedual interface
  # to this module and keep state in package vars to make the
  # interface easy.  In 2011 Mark Fowler isn't sure this is
  # a great idea
  our $dbh;
  our $force_utf8;
  our $verbose;
  our $verbose_data;

  # defaults
  my %args = (
    dbh => $dbh,
    force_utf8 => $force_utf8,
    verbose => $verbose || $ENV{TEST_DBROW_VERBOSE},
    verbose_data => $verbose_data || $ENV{TEST_DBROW_VERBOSE_DATA},
    check_all_rows => 0,
  @_ );

  # rename "sql" to "sql_and_bind"
  # (it's called just sql for legacy reasons)
  $args{sql_and_bind} = $args{sql}
    if exists $args{sql} && !exists $args{sql_and_bind};

  # remove description, provide default fallback from label
  my $label       = delete $args{label};
  my $description = delete $args{description};
  $description = $label unless defined $description;
  $description = "simple db test" unless defined $description;

  # do the test
  my $tbr = $object_class->new(%args);
  my $tbr_result = $tbr->test_ok();

  # store the results of the database operation in a var passed
  # into this function.
  #
  # This is another example of functionality that is difficult
  # to add to a procedural interface and would have been easier
  # if I'd used an OO interface.  That's the problem with
  # published APIs though, isn't it?  It's hard to change them
  if ($args{store_rows}) {
    croak "Must pass an arrayref in 'store_rows'"
      unless ref $args{store_rows}  eq "ARRAY";
    @{ $args{store_rows} } = @{ $tbr->db_results };
  }
  if ($args{store_row}) {
    if (ref $args{store_row} eq "HASH") {
      %{ $args{store_row} } = %{ $tbr->db_results->[0] };
    } elsif (ref $args{store_row} eq "SCALAR" && !defined ${ $args{store_row} }) {
      ${ $args{store_row} } = $tbr->db_results->[0];
    } elsif (ref $args{store_row} eq "REF" && ref ${ $args{store_row} } eq "HASH" ) {
      %{${ $args{store_row} }} = %{ $tbr->db_results->[0] };
    } else {
      croak "Invalid argument passed in 'store_row'";
    }
  }

  # render the result with Test::Builder
  local $Test::Builder::Level = $Test::Builder::Level + 1;
  return $tbr_result->pass_to_test_builder( $description );
}
push @EXPORT, qw(row_ok);

sub not_row_ok {
  local $Test::Builder::Level = $Test::Builder::Level + 1;
  return row_ok(@_, results => 0);
}
push @EXPORT, qw(not_row_ok);

sub all_row_ok {
  local $Test::Builder::Level = $Test::Builder::Level + 1;
  return row_ok(@_, check_all_rows => 1);
}
push @EXPORT, qw(all_row_ok);


# truth at end of the module
1;

__END__