develooper Front page | perl.dbi.dev | Postings from January 2011

more on execute_array not complying with the specification

Thread Next
From:
Martin J. Evans
Date:
January 30, 2011 09:47
Subject:
more on execute_array not complying with the specification
Message ID:
4D45A409.9060007@easysoft.com
#!/usr/bin/perl -w -I./t
# $Id$

use Test::More;
use strict;
use Data::Dumper;

$| = 1;

my $has_test_nowarnings = 1;
eval "require Test::NoWarnings";
$has_test_nowarnings = undef if $@;

my $table = 'PERL_DBD_execute_array';
my $table2 = 'PERL_DBD_execute_array2';
my @captured_error;                  # values captured in error handler
my $dbh;
my @p1 = (1,2,3,4,5);
my @p2 = qw(one two three four five);
my $fetch_row = 0;

use DBI qw(:sql_types);
#use_ok('ODBCTEST');
use_ok('Data::Dumper');

BEGIN {
    plan skip_all => "DBI_DSN is undefined"
        if (!defined $ENV{DBI_DSN});
}
END {
    if ($dbh) {
        drop_table($dbh);
    }
    Test::NoWarnings::had_no_warnings()
          if ($has_test_nowarnings);
    done_testing();
}

sub error_handler
{
    @captured_error = @_;
    diag("***** error handler called *****");
    0;                          # pass errors on
}

sub create_table
{
    my $dbh = shift;

    eval {
        $dbh->do(qq/create table $table (a int primary key, b char(20))/);
    };
    if ($@) {
        diag("Failed to create test table $table - $@");
        return 0;
    }
    eval {
        $dbh->do(qq/create table $table2 (a int primary key, b char(20))/);
    };
    if ($@) {
        diag("Failed to create test table $table2 - $@");
        return 0;
    }
    my $sth = $dbh->prepare(qq/insert into $table2 values(?,?)/);
    for (my $row = 0; $row < @p1; $row++) {
        $sth->execute($p1[$row], $p2[$row]);
    }
    1;
}

sub drop_table
{
    my $dbh = shift;

    eval {
        local $dbh->{PrintError} = 0;
        local $dbh->{PrintWarn} = 0;
        $dbh->do(qq/drop table $table/);
        $dbh->do(qq/drop table $table2/);
    };
    diag("Table dropped");
}

sub clear_table
{
    $_[0]->do(qq/delete from $table/);
}

sub check_data
{
    my ($dbh, $c1, $c2) = @_;

    my $data = $dbh->selectall_arrayref(qq/select * from $table/);
    my $row = 0;
    foreach (@$data) {
        is($_->[0], $c1->[$row], "row $row p1 data");
        is($_->[1], $c2->[$row], "row $row p2 data");
        $row++;
    }
}

sub check_tuple_status
{
    my ($tsts, $expected) = @_;

    diag(Data::Dumper->Dump([$tsts], [qw(ArrayTupleStatus)]));
    my $row = 0;
    foreach my $s (@$tsts) {
        if (ref($expected->[$row])) {
            is(ref($s), 'ARRAY', 'array in array tuple status');
            is(scalar(@$s), 2, '2 elements in array tuple status error');
        } else {
            is($s, $expected->[$row], "row $row tuple status");
        }
        $row++
    }
}

sub insert
{
    my ($dbh, $sth, $ref) = @_;

    die "need hashref arg" if (!$ref || (ref($ref) ne 'HASH'));
    diag("insert " . join(", ", map {"$_ = ". DBI::neat($ref->{$_})} keys %$ref ));

    @captured_error = ();

    if ($ref->{raise}) {
        $sth->{RaiseError} = 1;
    } else {
        $sth->{RaiseError} = 0;
    }

    my (@tuple_status, $sts, $total_affected);
    $sts = 999999;              # to ensure it is overwritten
    $total_affected = 999998;
    if ($ref->{array_context}) {
        eval {
            if ($ref->{params}) {
                ($sts, $total_affected) =
                    $sth->execute_array({ArrayTupleStatus => \@tuple_status},
                                        @{$ref->{params}});
            } elsif ($ref->{fetch}) {
                ($sts, $total_affected) =
                    $sth->execute_array(
                        {ArrayTupleStatus => \@tuple_status,
                         ArrayTupleFetch => $ref->{fetch}});
            } else {
                ($sts, $total_affected) =
                    $sth->execute_array({ArrayTupleStatus => \@tuple_status});
            }
        };
    } else {
        eval {
            if ($ref->{params}) {
                $sts =
                    $sth->execute_array({ArrayTupleStatus => \@tuple_status},
                                        @{$ref->{params}});
            } else {
                $sts =
                    $sth->execute_array({ArrayTupleStatus => \@tuple_status});
            }
        };
    }
    if ($ref->{error} && $ref->{raise}) {
        ok($@, 'error in execute_array eval');
    } else {
        ok(!$@, 'no error in execute_array eval') or diag($@);
    }
    $dbh->commit if $ref->{commit};

    if (!$ref->{raise} || ($ref->{error} == 0)) {
        if (exists($ref->{sts})) {
            is($sts, $ref->{sts},
               "execute_array returned " . DBI::neat($sts) . " rows executed");
        }
        if (exists($ref->{affected}) && $ref->{array_context}) {
            is($total_affected, $ref->{affected},
               "total affected " . DBI::neat($total_affected))
        }
    }
    if ($ref->{raise}) {
        if ($ref->{error}) {
            ok(scalar(@captured_error) > 0, "error captured");
        } else {
            is(scalar(@captured_error), 0, "no error captured");
        }
    }
    if ($ref->{sts}) {
        is(scalar(@tuple_status), (($ref->{sts} eq '0E0') ? 0 : $ref->{sts}),
           "$ref->{sts} rows in tuple_status");
    }
    if ($ref->{tuple}) {
        check_tuple_status(\@tuple_status, $ref->{tuple});
    }
}
# simple test on ensure execute_array with no errors:
# o checks returned status and affected is correct
# o checks ArrayTupleStatus is correct
# o checks no error is raised
# o checks rows are inserted
# o run twice with AutoCommit on/off
# o checks if less values are specified for one parameter the right number
#   of rows are still inserted and NULLs are placed in the missing rows
# checks binding via bind_param_array and adding params to execute_array
# checks binding no parameters at all
sub simple
{
    my ($dbh, $ref) = @_;

    diag('simple tests ' . join(", ", map {"$_ = $ref->{$_}"} keys %$ref ));

    diag("  all param arrays the same size");
    foreach my $commit (1,0) {
        diag("    Autocommit: $commit");
        clear_table($dbh);
        $dbh->begin_work if !$commit;

        my $sth = $dbh->prepare(qq/insert into $table values(?,?)/);
        $sth->bind_param_array(1, \@p1);
        $sth->bind_param_array(2, \@p2);
        insert($dbh, $sth,
               { commit => !$commit, error => 0, sts => 5, affected => 5,
                 tuple => [1, 1, 1, 1, 1], %$ref});
        check_data($dbh, \@p1, \@p2);
    }

    diag "  Not all param arrays the same size";
    clear_table($dbh);
    my $sth = $dbh->prepare(qq/insert into $table values(?,?)/);

    $sth->bind_param_array(1, \@p1);
    $sth->bind_param_array(2, [qw(one)]);
    insert($dbh, $sth, {commit => 0, error => 0,
                        raise => 1, sts => 5, affected => 5,
                        tuple => [1, 1, 1, 1, 1], %$ref});
    check_data($dbh, \@p1, ['one', undef, undef, undef, undef]);

    diag "  Not all param arrays the same size with bind on execute_array";
    clear_table($dbh);
    $sth = $dbh->prepare(qq/insert into $table values(?,?)/);

    insert($dbh, $sth, {commit => 0, error => 0,
                        raise => 1, sts => 5, affected => 5,
                        tuple => [1, 1, 1, 1, 1], %$ref,
                        params => [\@p1, [qw(one)]]});
    check_data($dbh, \@p1, ['one', undef, undef, undef, undef]);

    diag "  no parameters";
    clear_table($dbh);
    $sth = $dbh->prepare(qq/insert into $table values(?,?)/);

    insert($dbh, $sth, {commit => 0, error => 0,
                        raise => 1, sts => '0E0', affected => 0,
                        tuple => [], %$ref,
                        params => [[], []]});
    check_data($dbh, \@p1, ['one', undef, undef, undef, undef]);
}

# error test to ensure correct behavior for execute_array when it errors:
# o execute_array of 5 inserts with last one failing
#  o check it raises an error
#  o check caught error is passed on from handler for eval
#  o check returned status and affected rows
#  o check ArrayTupleStatus
#  o check valid inserts are inserted
# o execute_array of 5 inserts with 2nd last one failing
#  o check it raises an error
#  o check caught error is passed on from handler for eval
#  o check returned status and affected rows
#  o check ArrayTupleStatus
#  o check valid inserts are inserted
sub error
{
    my ($dbh, $ref) = @_;

    die "need hashref arg" if (!$ref || (ref($ref) ne 'HASH'));

    diag('error tests ' . join(", ", map {"$_ = $ref->{$_}"} keys %$ref ));
#    diag("Last row in error, array_context=$array_context");
# breaks easysoft sql server driver
#    clear_table($dbh);
#    my $sth = $dbh->prepare(qq/insert into $table values(?,?)/);
#    my @pe1 = @p1;
#    $pe1[-1] = 1;
#    $sth->bind_param_array(1, \@pe1);
#    $sth->bind_param_array(2, \@p2);
#    insert($dbh, $sth, 0, 1, 5, 5, [1, 1, 1, 1, []]);
#    check_data($dbh, [@pe1[0..4]], [@p2[0..4]]);

    diag("2nd last row in error");
    clear_table($dbh);
    my $sth = $dbh->prepare(qq/insert into $table values(?,?)/);
    my @pe1 = @p1;
    $pe1[-2] = 1;
    $sth->bind_param_array(1, \@pe1);
    $sth->bind_param_array(2, \@p2);
    insert($dbh, $sth, {commit => 0, error => 1, sts => undef,
           affected => undef, tuple => [1, 1, 1, [], 1], %$ref});
    check_data($dbh, [@pe1[0..2],$pe1[4]], [@p2[0..2], $p2[4]]);
}

sub fetch_sub
{
    diag("fetch_sub");
    return undef if ($fetch_row == scalar(@p1));

    return [$p1[$fetch_row], $p2[$fetch_row++]];
}

# test insertion via execute_array and ArrayTupleFetch
sub row_wise
{
    my ($dbh, $ref) = @_;

    diag("row_size via execute_for_fetch");

    $fetch_row = 0;
    clear_table($dbh);
    my $sth = $dbh->prepare(qq/insert into $table values(?,?)/);
    insert($dbh, $sth,
           {commit => 0, error => 0, sts => 5, affected => 5,
            tuple => [1, 1, 1, 1, 1], %$ref,
            fetch => \&fetch_sub});

# NOTE: I'd like to do the following test but it requires Multiple
# Active Statements and although I can find ODBC drivers which do this
# it is not easy (if at all possible) to know if an ODBC driver can
# handle MAS or not.
#    diag("row_size via select");
#    clear_table($dbh);
#    my $sth = $dbh->prepare(qq/insert into $table values(?,?)/);
#    my $sth2 = $dbh->prepare(qq/select * from $table2/);
#    $sth2->execute;
#    insert($dbh, $sth,
#           {commit => 0, error => 0, sts => 5, affected => 5,
#            tuple => [1, 1, 1, 1, 1], %$ref,
#            fetch => $sth2});
#
}

$dbh = DBI->connect();
unless($dbh) {
   BAIL_OUT("Unable to connect to the database $DBI::errstr\nTests skipped.\n");
   exit 0;
}
$dbh->{RaiseError} = 1;
$dbh->{PrintError} = 0;
$dbh->{ChopBlanks} = 1;
$dbh->{HandleError} = \&error_handler;
$dbh->{AutoCommit} = 1;

drop_table($dbh);
ok(create_table($dbh), "create test table") or exit 1;
simple($dbh, {array_context => 1, raise => 1});
simple($dbh, {array_context => 0, raise => 1});
error($dbh, {array_context => 1, raise => 1});
error($dbh, {array_context => 0, raise => 1});
error($dbh, {array_context => 1, raise => 0});
error($dbh, {array_context => 0, raise => 0});

row_wise($dbh, {array_context => 1, raise => 1});
Thread Next

nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About