view release on metacpan or  search on metacpan

t/02attribs.t  view on Meta::CPAN

$result = $dbh->{pg_default_port};
like ($result, qr/^[0-9]+$/, $t);

$t='DB handle attribute "pg_options" returns a value';
$result = $dbh->{pg_options};
ok (defined $result, $t);

$t='DB handle attribute "pg_socket" returns a value';
$result = $dbh->{pg_socket};
like ($result, qr/^[0-9]+$/, $t);

$t='DB handle attribute "pg_pid" returns a value';
$result = $dbh->{pg_pid};
like ($result, qr/^[0-9]+$/, $t);

$t='Using INSERT returns correct number of rows affected';
$SQL = q{INSERT INTO dbd_pg_test (id) VALUES (444),(445),(446)};
is ($dbh->do($SQL), '3', $t);

$t='Using UPDATE returns correct number of rows affected';
$SQL = q{UPDATE dbd_pg_test SET pname = 'update_test' WHERE id IN (444,445,446)};
is ($dbh->do($SQL), '3', $t);

SKIP: {

    if ($pgversion < 150000) {
        skip ('Cannot test MERGE return value on pre 15 servers', 1);
    }

    $t='Using MERGE returns correct number of rows affected';
    $SQL = q{MERGE into dbd_pg_test d using (select 1) as f on (d.id between 444 and 446) when matched then update set pname=''};
    is ($dbh->do($SQL), '3', $t);
}

$t='Using DELETE returns correct number of rows affected';
$SQL = q{DELETE from dbd_pg_test WHERE id IN (444,445,446)};
is ($dbh->do($SQL), '3', $t);

SKIP: {

    if ($pgversion < 80200) {
        skip ('Cannot test standard_conforming_strings on pre 8.2 servers', 3);
    }

    $t='DB handle attribute "pg_standard_conforming_strings" returns a valid value';
    my $oldscs = $dbh->{pg_standard_conforming_strings};
    like ($oldscs, qr/^on|off$/, $t);

    $t='DB handle attribute "pg_standard_conforming_strings" returns correct value';
    $dbh->do('SET standard_conforming_strings = on');
    $result = $dbh->{pg_standard_conforming_strings};
    is ($result, 'on', $t);

    $t='DB handle attribute "pg_standard_conforming_strings" returns correct value';
    $dbh->do('SET standard_conforming_strings = off');
    $result = $dbh->{pg_standard_conforming_strings};
    $dbh->do("SET standard_conforming_strings = $oldscs");
    is ($result, 'off', $t);
}

# Attempt to test whether or not we can get unicode out of the database
SKIP: {
    eval { require Encode; };
    skip ('Encode module is needed for unicode tests', 5) if $@;

    my $server_encoding = $dbh->selectall_arrayref('SHOW server_encoding')->[0][0];
    skip ('Cannot reliably test unicode without a UTF8 database', 5)
        if $server_encoding ne 'UTF8';

    $SQL = 'SELECT pname FROM dbd_pg_test WHERE id = ?';
    $sth = $dbh->prepare($SQL);
    $sth->execute(1);
    local $dbh->{pg_enable_utf8} = 1;

    $t='Quote method returns correct utf-8 characters';
    my $utf8_str = chr(0x100).'dam'; # LATIN CAPITAL LETTER A WITH MACRON
    is ($dbh->quote( $utf8_str ),  "'$utf8_str'", $t);

    $t='Able to insert unicode character into the database';
    $SQL = "INSERT INTO dbd_pg_test (id, pname, val) VALUES (40, '$utf8_str', 'Orange')";
    is ($dbh->do($SQL), '1', $t);

    $t='Able to read unicode (utf8) data from the database';
    $sth->execute(40);
    my $name = $sth->fetchrow_array();
    ok (Encode::is_utf8($name), $t);

    $t='Unicode (utf8) data returned from database is not corrupted';
    is ($name, $utf8_str, $t);

    $t='ASCII text returned from database does have utf8 bit set';
    $sth->finish();
    $sth->execute(1);
    my $name2 = $sth->fetchrow_array();
    ok (Encode::is_utf8($name2), $t);
    $sth->finish();
}

#
# Use the handle attribute "Warn" to check inheritance
#

undef $sth;

$t='Attribute "Warn" attribute set on by default';
ok ($dbh->{Warn}, $t);

$t='Statement handle inherits the "Warn" attribute';
$SQL = 'SELECT 123';
$sth = $dbh->prepare($SQL);
$sth->finish();
ok ($sth->{Warn}, $t);

$t='Able to turn off the "Warn" attribute in the database handle';
$dbh->{Warn} = 0;
ok (! $dbh->{Warn}, $t);

#
# Test of the the following statement handle attributes:
# NUM_OF_PARAMS, NUM_OF_FIELDS
# NAME, NAME_lc, NAME_uc, NAME_hash, NAME_lc_hash, NAME_uc_hash
# TYPE, PRECISION, SCALE, NULLABLE
#

## First, all pre-execute checks:

$t='Statement handle attribute "NUM_OF_PARAMS" works correctly before execute with no placeholders';
$sth = $dbh->prepare('SELECT 123');
is ($sth->{'NUM_OF_PARAMS'}, 0, $t);

$t='Statement handle attribute "NUM_OF_PARAMS" works correctly before execute with three placeholders';
$sth = $dbh->prepare('SELECT 123 FROM pg_class WHERE relname=? AND reltuples=? and relpages=?');
is ($sth->{'NUM_OF_PARAMS'}, 3, $t);

$t='Statement handle attribute "NUM_OF_PARAMS" works correctly before execute with one placeholder';
$sth = $dbh->prepare('SELECT 123 AS "Sheep", CAST(id AS float) FROM dbd_pg_test WHERE id=?');
is ($sth->{'NUM_OF_PARAMS'}, 1, $t);

$t='Statement handle attribute "NUM_OF_FIELDS" returns undef before execute';
is ($sth->{'NUM_OF_FIELDS'}, undef, $t);

$t='Statement handle attribute "NAME" returns undef before execute';
is ($sth->{'NAME'}, undef, $t);