@@ -1,5 +1,120 @@
'GSM' is Greg Sabino Mullane, greg@turnstep.com
+
+Version 3.5.1 Released February 17, 2015 (git commit 6c3457ee20c19ae492d29c490af6800e7e6a0774)
+
+ - Prevent core dump if the second argument to the quote() method
+ is anything but a hashref
+ [Greg Sabino Mullane]
+ (CPAN bug #101980)
+
+ - Better "support" for SQL_ASCII servers in the tests.
+ Allow env var DBDPG_TEST_ALWAYS_ENV to force use of DBI_DSN and DBI_USER in tests.
+ [Greg Sabino Mullane]
+
+ - Fix client_encoding detection on pre-9.1 servers
+ [Dagfinn Ilmari Mannsåker]
+
+ - Fix operator existence check in tests on pre-8.3 servers
+ [Dagfinn Ilmari Mannsåker]
+
+ - Documentation fix
+ [Stuart A Johnston]
+
+ - Fix pg_switch_prepared database handle documentation
+ [Dagfinn Ilmari Mannsåker]
+
+Version 3.5.0 Released January 6, 2015 (git commit bb13d3306fd1c73fac1c0c8a330c14e6b8443942)
+
+ - Allow "placeholder escaping" by the use of a backslash directly before it, e.g.
+ "SELECT 1 FROM jsontable WHERE foo \\? ?"
+ will contain a single placeholder, and the first question mark will be sent directly
+ to the backend to be parsed as an operator.
+ [Greg Sabino Mullane, Tim Bunce]
+ (CPAN bug #101030)
+
+ - Improve the workings of the ping() method, so it always tests for
+ a valid database backend and returns the correct true/false.
+ [Greg Sabino Mullane, with help from Andrew Gierth and Tim Bunce]
+ (CPAN bug #100648)
+
+ - Add get_info(9000) => 1 to indicate driver can escape placeholders.
+ [Tim Bunce]
+
+ - In tests, force the client_encoding to UTF8, skip tests that involve
+ characters not supported by the server_encoding
+ [Dagfinn Ilmari Mannsåker]
+
+ - Fix memory leak when selecting from arrays
+ [Dagfinn Ilmari Mannsåker, reported by Krystian Samp]
+
+ - Make get_info much more efficient and slightly simpler.
+ [Tim Bunce]
+
+
+Version 3.4.2 Released September 25, 2014 (git commit 61440e1f4ccb6c293c5838676da1942e0df67271)
+
+ - Fix bug where single-quoted type arguments to the table_info()
+ method were causing a SQL error.
+ [Greg Sabino Mullane] (CPAN bug #99144)
+
+
+Version 3.4.1 Released August 20, 2014 (git commit cfd146effde09c493ac7573408ac29d6d9cbed47)
+
+ - Allow '%' again for the type in table_info() and thus tables()
+ It's not documented or tested in DBI, but it used to work until
+ DBD::Pg 3.4.0, and the change broke DBIx::Class::Schema::Loader, which
+ uses type='%'.
+ [Dagfinn Ilmari Mannsåker]
+
+
+Version 3.4.0 Released August 16, 2014 (git commit 7a5da12d84b4c2e9879f90fb6168f56c095071fa)
+
+ - Cleanup and improve table_info()
+ [Mike Pomraning <mjp@pilcrow.madison.wi.us>] (github issue #7)
+
+ table_info() type searching now supports TABLE, VIEW, SYSTEM TABLE,
+ SYSTEM VIEW, and LOCAL TEMPORARY
+
+ table_info() object searching fully supports the above types.
+
+ table_info() object searching no longer ignores invalid types - a filter
+ of 'NOSUCH' will return no rows, and 'NOSUCH,LOCAL TEMPORARY' will
+ return only temp objects.
+
+ tableinfo() type filters are strictly matched now ... previously a
+ search for SYSTEM TABLE would have fetched plain TABLE objects.
+
+ table_info() now treats temporary tables and temporary views as LOCAL TEMPORARY
+
+ - Make sure column_info() and table_info() can handle materialized views.
+ [Greg Sabino Mullane] (CPAN bug #97032)
+
+
+Version 3.3.0 Released May 31, 2014 (git commit 055f788cf96b380b9fe0e80b6cedb88f8d1799b8)
+
+ - Major cleanup of UTF-8 support:
+ Fix quoting of UTF-8 values
+ Add support for UTF-8 statement strings
+ Fix UTF-8 support in placeholders and return values
+ [Dagfinn Ilmari Mannsåker] (CPAN bug #95214 and #91655)
+ Test that the Pg server agrees with us about the lengths of input strings.
+ Refactor Unicode test to use anon hashes to describe the tests to run.
+ Test pg_enable_utf8 of -1, in addition to 0 and 1.
+ Extend the Unicode round-trip tests to verify ASCII, BMP and non-BMP code points.
+ Test that characters created in the server reach the client correctly.
+ [Nicholas Clark]
+
+ - Rewrite foreign_key_info to be just one query
+ [Dagfinn Ilmari Mannsåker]
+
+ - Remove ODBC support from foreign_key_info
+ [Dagfinn Ilmari Mannsåker]
+
+ - Remove use of dTHX in functions in quote.c and types.c
+ [Nicholas Clark]
+
+
Version 3.2.1 Released May 20, 2014 (git commit a56ef5c4715440d4fc2054df5477996b0e287467)
- Stricter testing for array slices: disallow number-colon-number from being
@@ -1,6 +1,6 @@
--- #YAML:1.0
name : DBD-Pg
-version : 3.2.1
+version : 3.5.1
abstract : DBI PostgreSQL interface
author:
- Greg Sabino Mullane <greg@turnstep.com>
@@ -30,10 +30,10 @@ recommends:
provides:
DBD::Pg:
file : Pg.pm
- version : 3.2.1
+ version : 3.5.1
Bundle::DBD::Pg:
file : lib/Bundle/DBD/Pg.pm
- version : 3.2.1
+ version : 3.5.1
keywords:
- Postgres
@@ -48,6 +48,7 @@ resources:
bugtracker : http://rt.cpan.org/Public/Dist/Display.html?Name=DBD-Pg
repository : git://bucardo.org/dbdpg.git
MailingList : http://www.nntp.perl.org/group/perl.dbd.pg/
+ IRC : irc://irc.freenode.net/#postgresql
meta-spec:
version : 1.4
@@ -5,7 +5,7 @@ use warnings;
use 5.008001;
## No version.pm for this one, as the prereqs are not loaded yet.
-my $VERSION = '3.2.1';
+my $VERSION = '3.5.1';
## App::Info is stored inside t/lib
## Create a proper path so we can use it below
@@ -1,5 +1,5 @@
/*
- Copyright (c) 2000-2013 Greg Sabino Mullane and others: see the Changes file
+ Copyright (c) 2000-2015 Greg Sabino Mullane and others: see the Changes file
Copyright (c) 1997-2000 Edmund Mergl
Portions Copyright (c) 1994-1997 Tim Bunce
@@ -1,6 +1,6 @@
# -*-cperl-*-
#
-# Copyright (c) 2002-2013 Greg Sabino Mullane and others: see the Changes file
+# Copyright (c) 2002-2015 Greg Sabino Mullane and others: see the Changes file
# Portions Copyright (c) 2002 Jeffrey W. Baker
# Portions Copyright (c) 1997-2001 Edmund Mergl
# Portions Copyright (c) 1994-1997 Tim Bunce
@@ -16,7 +16,7 @@ use 5.008001;
{
package DBD::Pg;
- use version; our $VERSION = qv('3.2.1');
+ use version; our $VERSION = qv('3.5.1');
use DBI ();
use DynaLoader ();
@@ -485,7 +485,7 @@ use 5.008001;
$schemajoin
WHERE
a.attnum >= 0
- AND c.relkind IN ('r','v')
+ AND c.relkind IN ('r','v','m')
$whereclause
ORDER BY "TABLE_SCHEM", "TABLE_NAME", "ORDINAL_POSITION"
!;
@@ -626,7 +626,7 @@ use 5.008001;
i.indisunique desc, a.amname, c.relname
};
- my $indexdef_sql = qq{
+ my $indexdef_sql = q{
SELECT
pg_get_indexdef(indexrelid,x,true)
FROM
@@ -867,11 +867,6 @@ use 5.008001;
my $dbh = shift;
## PK: catalog, schema, table, FK: catalog, schema, table, attr
-
- my $oldname = $dbh->{FetchHashKeyName};
-
- local $dbh->{FetchHashKeyName} = 'NAME_lc';
-
## Each of these may be undef or empty
my $pschema = $_[1] || '';
my $ptable = $_[2] || '';
@@ -879,249 +874,128 @@ use 5.008001;
my $ftable = $_[5] || '';
my $args = $_[6];
- ## No way to currently specify it, but we are ready when there is
- my $odbc = 0;
-
## Must have at least one named table
- return undef if !$ptable and !$ftable;
+ return undef if !length($ptable) and !length($ftable);
## If only the primary table is given, we return only those columns
## that are used as foreign keys, even if that means that we return
## unique keys but not primary one. We also return all the foreign
## tables/columns that are referencing them, of course.
-
- ## The first step is to find the oid of each specific table in the args:
- ## Return undef if no matching relation found
- my %oid;
- for ([$ptable, $pschema, 'P'], [$ftable, $fschema, 'F']) {
- if (length $_->[0]) {
- my $SQL = "SELECT c.oid AS schema FROM pg_catalog.pg_class c, pg_catalog.pg_namespace n\n".
- 'WHERE c.relnamespace = n.oid AND c.relname = ' . $dbh->quote($_->[0]);
- if (length $_->[1]) {
- $SQL .= ' AND n.nspname = ' . $dbh->quote($_->[1]);
+ ## If no schema is given, respect search_path by using pg_table_is_visible()
+ my @where;
+ for ([$ptable, $pschema, 'uk'], [$ftable, $fschema, 'fk']) {
+ my ($table, $schema, $type) = @$_;
+ if (length $table) {
+ push @where, "${type}_class.relname = " . $dbh->quote($table);
+ if (length $schema) {
+ push @where, "${type}_ns.nspname = " . $dbh->quote($schema);
}
else {
- $SQL .= ' AND pg_catalog.pg_table_is_visible(c.oid)'
+ push @where, "pg_catalog.pg_table_is_visible(${type}_class.oid)"
}
- my $info = $dbh->selectall_arrayref($SQL);
- return undef if ! @$info;
- $oid{$_->[2]} = $info->[0][0];
}
}
- ## We now need information about each constraint we care about.
- ## Foreign table: only 'f' / Primary table: only 'p' or 'u'
- my $WHERE = $odbc ? q{((contype = 'p'} : q{((contype IN ('p','u')};
- if (length $ptable) {
- $WHERE .= " AND conrelid=$oid{'P'}::oid";
- }
- else {
- $WHERE .= " AND conrelid IN (SELECT DISTINCT confrelid FROM pg_catalog.pg_constraint WHERE conrelid=$oid{'F'}::oid)";
- if (length $pschema) {
- $WHERE .= ' AND n2.nspname = ' . $dbh->quote($pschema);
- }
- }
-
- $WHERE .= ")\n \t\t\t\tOR \n \t\t\t\t(contype = 'f'";
- if (length $ftable) {
- $WHERE .= " AND conrelid=$oid{'F'}::oid";
- if (length $ptable) {
- $WHERE .= " AND confrelid=$oid{'P'}::oid";
- }
- }
- else {
- $WHERE .= " AND confrelid = $oid{'P'}::oid";
- if (length $fschema) {
- $WHERE .= ' AND n2.nspname = ' . $dbh->quote($fschema);
- }
- }
- $WHERE .= '))';
-
- ## Grab everything except specific column names:
- my $fk_sql = qq{
- SELECT conrelid, confrelid, contype, conkey, confkey,
- pg_catalog.quote_ident(c.relname) AS t_name, pg_catalog.quote_ident(n2.nspname) AS t_schema,
- pg_catalog.quote_ident(n.nspname) AS c_schema, pg_catalog.quote_ident(conname) AS c_name,
- CASE
- WHEN confupdtype = 'c' THEN 0
- WHEN confupdtype = 'r' THEN 1
- WHEN confupdtype = 'n' THEN 2
- WHEN confupdtype = 'a' THEN 3
- WHEN confupdtype = 'd' THEN 4
- ELSE -1
- END AS update,
- CASE
- WHEN confdeltype = 'c' THEN 0
- WHEN confdeltype = 'r' THEN 1
- WHEN confdeltype = 'n' THEN 2
- WHEN confdeltype = 'a' THEN 3
- WHEN confdeltype = 'd' THEN 4
- ELSE -1
- END AS delete,
- CASE
- WHEN condeferrable = 'f' THEN 7
- WHEN condeferred = 't' THEN 6
- WHEN condeferred = 'f' THEN 5
- ELSE -1
- END AS defer
- FROM pg_catalog.pg_constraint k, pg_catalog.pg_class c, pg_catalog.pg_namespace n, pg_catalog.pg_namespace n2
- WHERE $WHERE
- AND k.connamespace = n.oid
- AND k.conrelid = c.oid
- AND c.relnamespace = n2.oid
- ORDER BY conrelid ASC
- };
-
- my $sth = $dbh->prepare($fk_sql);
- $sth->execute();
-
- ## We have to make sure expand_array is on for the items below to work
- my $oldexpand = $dbh->FETCH('pg_expand_array');
- $oldexpand or $dbh->STORE('pg_expand_array', 1);
-
- my $info = $sth->fetchall_arrayref({});
- $oldexpand or $dbh->STORE('pg_expand_array', 0);
- return undef if ! defined $info or ! @$info;
-
- ## Return undef if just ptable given but no fk found
- return undef if ! length $ftable and ! grep { $_->{'contype'} eq 'f'} @$info;
-
- ## Figure out which columns we need information about
- my %colnum;
- for my $row (@$info) {
- for (@{$row->{'conkey'}}) {
- $colnum{$row->{'conrelid'}}{$_}++;
- }
- if ($row->{'contype'} eq 'f') {
- for (@{$row->{'confkey'}}) {
- $colnum{$row->{'confrelid'}}{$_}++;
- }
- }
- }
- ## Get the information about the columns computed above
+ my $WHERE = join ' AND ', @where;
my $SQL = qq{
- SELECT a.attrelid, a.attnum, pg_catalog.quote_ident(a.attname) AS colname,
- pg_catalog.quote_ident(t.typname) AS typename
- FROM pg_catalog.pg_attribute a, pg_catalog.pg_type t
- WHERE a.atttypid = t.oid
- AND (\n};
-
- $SQL .= join "\n\t\t\t\tOR\n" => map {
- my $cols = join ',' => keys %{$colnum{$_}};
- "\t\t\t\t( a.attrelid = '$_' AND a.attnum IN ($cols) )"
- } sort keys %colnum;
-
- $sth = $dbh->prepare(qq{$SQL )});
- $sth->execute();
- my $attribs = $sth->fetchall_arrayref({});
-
- ## Make a lookup hash
- my %attinfo;
- for (@$attribs) {
- $attinfo{"$_->{'attrelid'}"}{"$_->{'attnum'}"} = $_;
- }
-
- ## This is an array in case we have identical oid/column combos. Lowest oid wins
- my %ukey;
- for my $c (grep { $_->{'contype'} ne 'f' } @$info) {
- ## Munge multi-column keys into sequential order
- my $multi = join ' ' => sort @{$c->{'conkey'}};
- push @{$ukey{$c->{'conrelid'}}{$multi}}, $c;
- }
-
- ## Finally, return as a SQL/CLI structure:
- my $fkinfo = [];
- my $x=0;
- for my $t (sort { $a->{'c_name'} cmp $b->{'c_name'} } grep { $_->{'contype'} eq 'f' } @$info) {
- ## We need to find which constraint row (if any) matches our confrelid-confkey combo
- ## by checking out ukey hash. We sort for proper matching of { 1 2 } vs. { 2 1 }
- ## No match means we have a pure index constraint
- my $u;
- my $multi = join ' ' => sort @{$t->{'confkey'}};
- if (exists $ukey{$t->{'confrelid'}}{$multi}) {
- $u = $ukey{$t->{'confrelid'}}{$multi}->[0];
- }
- else {
- ## Mark this as an index so we can fudge things later on
- $multi = 'index';
- ## Grab the first one found, modify later on as needed
- $u = ((values %{$ukey{$t->{'confrelid'}}})[0]||[])->[0];
- ## Bail in case there was no match
- next if ! ref $u;
- }
+ SELECT
+ NULL, pg_catalog.quote_ident(uk_ns.nspname), pg_catalog.quote_ident(uk_class.relname), pg_catalog.quote_ident(uk_col.attname),
+ NULL, pg_catalog.quote_ident(fk_ns.nspname), pg_catalog.quote_ident(fk_class.relname), pg_catalog.quote_ident(fk_col.attname),
+ colnum.i,
+ CASE constr.confupdtype
+ WHEN 'c' THEN 0 WHEN 'r' THEN 1 WHEN 'n' THEN 2 WHEN 'a' THEN 3 WHEN 'd' THEN 4 ELSE -1
+ END,
+ CASE constr.confdeltype
+ WHEN 'c' THEN 0 WHEN 'r' THEN 1 WHEN 'n' THEN 2 WHEN 'a' THEN 3 WHEN 'd' THEN 4 ELSE -1
+ END,
+ pg_catalog.quote_ident(constr.conname), pg_catalog.quote_ident(uk_constr.conname),
+ CASE
+ WHEN constr.condeferrable = 'f' THEN 7
+ WHEN constr.condeferred = 't' THEN 6
+ WHEN constr.condeferred = 'f' THEN 5
+ ELSE -1
+ END,
+ CASE coalesce(uk_constr.contype, 'u')
+ WHEN 'u' THEN 'UNIQUE' WHEN 'p' THEN 'PRIMARY'
+ END,
+ pg_catalog.quote_ident(uk_type.typname), pg_catalog.quote_ident(fk_type.typname)
+ FROM pg_catalog.pg_constraint constr
+ JOIN pg_catalog.pg_class uk_class ON constr.confrelid = uk_class.oid
+ JOIN pg_catalog.pg_namespace uk_ns ON uk_class.relnamespace = uk_ns.oid
+ JOIN pg_catalog.pg_class fk_class ON constr.conrelid = fk_class.oid
+ JOIN pg_catalog.pg_namespace fk_ns ON fk_class.relnamespace = fk_ns.oid
+ -- can't do unnest() until 8.4, and would need WITH ORDINALITY to get the array indices,
+ -- wich isn't available until 9.4 at the earliest, so we join against a series table instead
+ JOIN pg_catalog.generate_series(1, pg_catalog.current_setting('max_index_keys')::integer) colnum(i)
+ ON colnum.i <= pg_catalog.array_upper(constr.conkey,1)
+ JOIN pg_catalog.pg_attribute uk_col ON uk_col.attrelid = constr.confrelid AND uk_col.attnum = constr.confkey[colnum.i]
+ JOIN pg_catalog.pg_type uk_type ON uk_col.atttypid = uk_type.oid
+ JOIN pg_catalog.pg_attribute fk_col ON fk_col.attrelid = constr.conrelid AND fk_col.attnum = constr.conkey[colnum.i]
+ JOIN pg_catalog.pg_type fk_type ON fk_col.atttypid = fk_type.oid
+
+ -- We can't match confkey from the fk constraint to conkey of the unique constraint,
+ -- because the unique constraint might not exist or there might be more than one
+ -- matching one. However, there must be at least a unique _index_ on the key
+ -- columns, so we look for that; but we can't find it via pg_index, since there may
+ -- again be more than one matching index.
+
+ -- So instead, we look at pg_depend for the dependency that was created by the fk
+ -- constraint. This dependency is of type 'n' (normal) and ties the pg_constraint
+ -- row oid to the pg_class oid for the index relation (a single arbitrary one if
+ -- more than one matching unique index existed at the time the constraint was
+ -- created). Fortunately, the constraint does not create dependencies on the
+ -- referenced table itself, but on the _columns_ of the referenced table, so the
+ -- index can be distinguished easily. Then we look for another pg_depend entry,
+ -- this time an 'i' (implementation) dependency from a pg_constraint oid (the unique
+ -- constraint if one exists) to the index oid; but we have to allow for the
+ -- possibility that this one doesn't exist. - Andrew Gierth (RhodiumToad)
+
+ JOIN pg_catalog.pg_depend dep ON (
+ dep.classid = 'pg_catalog.pg_constraint'::regclass
+ AND dep.objid = constr.oid
+ AND dep.objsubid = 0
+ AND dep.deptype = 'n'
+ AND dep.refclassid = 'pg_catalog.pg_class'::regclass
+ AND dep.refobjsubid=0
+ )
+ JOIN pg_catalog.pg_class idx ON (
+ idx.oid = dep.refobjid AND idx.relkind='i'
+ )
+ LEFT JOIN pg_catalog.pg_depend dep2 ON (
+ dep2.classid = 'pg_catalog.pg_class'::regclass
+ AND dep2.objid = idx.oid
+ AND dep2.objsubid = 0
+ AND dep2.deptype = 'i'
+ AND dep2.refclassid = 'pg_catalog.pg_constraint'::regclass
+ AND dep2.refobjsubid = 0
+ )
+ LEFT JOIN pg_catalog.pg_constraint uk_constr ON (
+ uk_constr.oid = dep2.refobjid AND uk_constr.contype IN ('p','u')
+ )
+ WHERE $WHERE
+ AND uk_class.relkind = 'r'
+ AND fk_class.relkind = 'r'
+ AND constr.contype = 'f'
+ ORDER BY constr.conname, colnum.i
+ };
+ my $fkinfo = $dbh->selectall_arrayref($SQL);
- ## ODBC is primary keys only
- next if $odbc and ($u->{'contype'} ne 'p' or $multi eq 'index');
-
- my $conkey = $t->{'conkey'};
- my $confkey = $t->{'confkey'};
- for (my $y=0; $conkey->[$y]; $y++) {
- # UK_TABLE_CAT
- $fkinfo->[$x][0] = undef;
- # UK_TABLE_SCHEM
- $fkinfo->[$x][1] = $u->{'t_schema'};
- # UK_TABLE_NAME
- $fkinfo->[$x][2] = $u->{'t_name'};
- # UK_COLUMN_NAME
- $fkinfo->[$x][3] = $attinfo{$t->{'confrelid'}}{$confkey->[$y]}{'colname'};
- # FK_TABLE_CAT
- $fkinfo->[$x][4] = undef;
- # FK_TABLE_SCHEM
- $fkinfo->[$x][5] = $t->{'t_schema'};
- # FK_TABLE_NAME
- $fkinfo->[$x][6] = $t->{'t_name'};
- # FK_COLUMN_NAME
- $fkinfo->[$x][7] = $attinfo{$t->{'conrelid'}}{$conkey->[$y]}{'colname'};
- # ORDINAL_POSITION
- $fkinfo->[$x][8] = $y+1;
- # UPDATE_RULE
- $fkinfo->[$x][9] = "$t->{'update'}";
- # DELETE_RULE
- $fkinfo->[$x][10] = "$t->{'delete'}";
- # FK_NAME
- $fkinfo->[$x][11] = $t->{'c_name'};
- # UK_NAME (may be undef if an index with no named constraint)
- $fkinfo->[$x][12] = $multi eq 'index' ? undef : $u->{'c_name'};
- # DEFERRABILITY
- $fkinfo->[$x][13] = "$t->{'defer'}";
- # UNIQUE_OR_PRIMARY
- $fkinfo->[$x][14] = ($u->{'contype'} eq 'p' and $multi ne 'index') ? 'PRIMARY' : 'UNIQUE';
- # UK_DATA_TYPE
- $fkinfo->[$x][15] = $attinfo{$t->{'confrelid'}}{$confkey->[$y]}{'typename'};
- # FK_DATA_TYPE
- $fkinfo->[$x][16] = $attinfo{$t->{'conrelid'}}{$conkey->[$y]}{'typename'};
- $x++;
- } ## End each column in this foreign key
- } ## End each foreign key
+ return undef unless $fkinfo && @{$fkinfo};
- my @CLI_cols = (qw(
+ my @cols = (qw(
UK_TABLE_CAT UK_TABLE_SCHEM UK_TABLE_NAME UK_COLUMN_NAME
FK_TABLE_CAT FK_TABLE_SCHEM FK_TABLE_NAME FK_COLUMN_NAME
ORDINAL_POSITION UPDATE_RULE DELETE_RULE FK_NAME UK_NAME
DEFERABILITY UNIQUE_OR_PRIMARY UK_DATA_TYPE FK_DATA_TYPE
));
- my @ODBC_cols = (qw(
- PKTABLE_CAT PKTABLE_SCHEM PKTABLE_NAME PKCOLUMN_NAME
- FKTABLE_CAT FKTABLE_SCHEM FKTABLE_NAME FKCOLUMN_NAME
- KEY_SEQ UPDATE_RULE DELETE_RULE FK_NAME PK_NAME
- DEFERABILITY UNIQUE_OR_PRIMARY PK_DATA_TYPE FKDATA_TYPE
- ));
-
- if ($oldname eq 'NAME_lc') {
- if ($odbc) {
- for my $col (@ODBC_cols) {
- $col = lc $col;
- }
- }
- else {
- for my $col (@CLI_cols) {
- $col = lc $col;
- }
+ if ($dbh->{FetchHashKeyName} eq 'NAME_lc') {
+ for my $col (@cols) {
+ $col = lc $col;
}
}
- return _prepare_from_data('foreign_key_info', $fkinfo, $odbc ? \@ODBC_cols : \@CLI_cols);
+ return _prepare_from_data('foreign_key_info', $fkinfo, \@cols);
}
@@ -1170,190 +1044,220 @@ use 5.008001;
and (defined $table and $table eq '')
and (defined $type and $type eq '%')
) {
- $tbl_sql = qq{
- SELECT
- NULL::text AS "TABLE_CAT"
- , NULL::text AS "TABLE_SCHEM"
- , NULL::text AS "TABLE_NAME"
- , 'TABLE' AS "TABLE_TYPE"
- , 'relkind: r' AS "REMARKS" $extracols
- UNION
- SELECT
- NULL::text AS "TABLE_CAT"
- , NULL::text AS "TABLE_SCHEM"
- , NULL::text AS "TABLE_NAME"
- , 'VIEW' AS "TABLE_TYPE"
- , 'relkind: v' AS "REMARKS" $extracols
+ $tbl_sql = q{
+ SELECT "TABLE_CAT"
+ , "TABLE_SCHEM"
+ , "TABLE_NAME"
+ , "TABLE_TYPE"
+ , "REMARKS"
+ FROM
+ (SELECT NULL::text AS "TABLE_CAT"
+ , NULL::text AS "TABLE_SCHEM"
+ , NULL::text AS "TABLE_NAME") dummy_cols
+ CROSS JOIN
+ (SELECT 'TABLE' AS "TABLE_TYPE"
+ , 'relkind: r' AS "REMARKS"
+ UNION
+ SELECT 'SYSTEM TABLE'
+ , 'relkind: r; nspname ~ ^pg_(catalog|toast)$'
+ UNION
+ SELECT 'VIEW'
+ , 'relkind: v'
+ UNION
+ SELECT 'SYSTEM VIEW'
+ , 'relkind: v; nspname ~ ^pg_(catalog|toast)$'
+ UNION
+ SELECT 'MATERIALIZED VIEW'
+ , 'relkind: m'
+ UNION
+ SELECT 'SYSTEM MATERIALIZED VIEW'
+ , 'relkind: m; nspname ~ ^pg_(catalog|toast)$'
+ UNION
+ SELECT 'LOCAL TEMPORARY'
+ , 'relkind: r; nspname ~ ^pg_(toast_)?temp') type_info
+ ORDER BY "TABLE_TYPE" ASC
};
- }
- else {
- # Default SQL
- $extracols = q{,n.nspname AS pg_schema, c.relname AS pg_table};
- my @search;
- my $showtablespace = ', quote_ident(t.spcname) AS "pg_tablespace_name", quote_ident(t.spclocation) AS "pg_tablespace_location"';
- if ($dbh->{private_dbdpg}{version} >= 90200) {
- $showtablespace = ', quote_ident(t.spcname) AS "pg_tablespace_name", quote_ident(pg_tablespace_location(t.oid)) AS "pg_tablespace_location"';
- }
-
- ## If the schema or table has an underscore or a %, use a LIKE comparison
- if (defined $schema and length $schema) {
- push @search, 'n.nspname ' . ($schema =~ /[_%]/ ? 'LIKE ' : '= ') . $dbh->quote($schema);
- }
- if (defined $table and length $table) {
- push @search, 'c.relname ' . ($table =~ /[_%]/ ? 'LIKE ' : '= ') . $dbh->quote($table);
- }
- ## All we can see is "table" or "view". Default is both
- my $typesearch = q{IN ('r','v')};
- if (defined $type and length $type) {
- if ($type =~ /\btable\b/i and $type !~ /\bview\b/i) {
- $typesearch = q{= 'r'};
- }
- elsif ($type =~ /\bview\b/i and $type !~ /\btable\b/i) {
- $typesearch = q{= 'v'};
- }
- }
- push @search, "c.relkind $typesearch";
-
- my $TSJOIN = 'pg_catalog.pg_tablespace t ON (t.oid = c.reltablespace)';
- if ($dbh->{private_dbdpg}{version} < 80000) {
- $TSJOIN = '(SELECT 0 AS oid, 0 AS spcname, 0 AS spclocation LIMIT 0) AS t ON (t.oid=1)';
- }
- my $whereclause = join "\n\t\t\t\t\t AND " => @search;
- $tbl_sql = qq{
+ }
+ else {
+ # Default SQL
+ $extracols = q{,n.nspname AS pg_schema, c.relname AS pg_table};
+ my @search = (q|c.relkind IN ('r', 'v', 'm')|, # No sequences, etc. for now
+ q|NOT (quote_ident(n.nspname) ~ '^pg_(toast_)?temp_' AND NOT has_schema_privilege(n.nspname, 'USAGE'))|); # No others' temp objects
+ my $showtablespace = ', quote_ident(t.spcname) AS "pg_tablespace_name", quote_ident(t.spclocation) AS "pg_tablespace_location"';
+ if ($dbh->{private_dbdpg}{version} >= 90200) {
+ $showtablespace = ', quote_ident(t.spcname) AS "pg_tablespace_name", quote_ident(pg_tablespace_location(t.oid)) AS "pg_tablespace_location"';
+ }
+
+ ## If the schema or table has an underscore or a %, use a LIKE comparison
+ if (defined $schema and length $schema) {
+ push @search, 'n.nspname ' . ($schema =~ /[_%]/ ? 'LIKE ' : '= ') . $dbh->quote($schema);
+ }
+ if (defined $table and length $table) {
+ push @search, 'c.relname ' . ($table =~ /[_%]/ ? 'LIKE ' : '= ') . $dbh->quote($table);
+ }
+
+ my $TSJOIN = 'pg_catalog.pg_tablespace t ON (t.oid = c.reltablespace)';
+ if ($dbh->{private_dbdpg}{version} < 80000) {
+ $TSJOIN = '(SELECT 0 AS oid, 0 AS spcname, 0 AS spclocation LIMIT 0) AS t ON (t.oid=1)';
+ }
+ my $whereclause = join "\n\t\t\t\t\t AND " => @search;
+ $tbl_sql = qq{
SELECT NULL::text AS "TABLE_CAT"
, quote_ident(n.nspname) AS "TABLE_SCHEM"
, quote_ident(c.relname) AS "TABLE_NAME"
- , CASE
- WHEN c.relkind = 'v' THEN
- CASE WHEN quote_ident(n.nspname) ~ '^pg_' THEN 'SYSTEM VIEW' ELSE 'VIEW' END
- ELSE
- CASE WHEN quote_ident(n.nspname) ~ '^pg_' THEN 'SYSTEM TABLE' ELSE 'TABLE' END
- END AS "TABLE_TYPE"
+ -- any temp table or temp view is LOCAL TEMPORARY for us
+ , CASE WHEN quote_ident(n.nspname) ~ '^pg_(toast_)?temp_' THEN
+ 'LOCAL TEMPORARY'
+ WHEN c.relkind = 'r' THEN
+ CASE WHEN quote_ident(n.nspname) ~ '^pg_' THEN
+ 'SYSTEM TABLE'
+ ELSE 'TABLE'
+ END
+ WHEN c.relkind = 'v' THEN
+ CASE WHEN quote_ident(n.nspname) ~ '^pg_' THEN
+ 'SYSTEM VIEW'
+ ELSE 'VIEW'
+ END
+ WHEN c.relkind = 'm' THEN
+ CASE WHEN quote_ident(n.nspname) ~ '^pg_' THEN
+ 'SYSTEM MATERIALIZED VIEW'
+ ELSE 'MATERIALIZED VIEW'
+ END
+ ELSE 'UNKNOWN'
+ END AS "TABLE_TYPE"
, d.description AS "REMARKS" $showtablespace $extracols
- FROM pg_catalog.pg_class AS c
- LEFT JOIN pg_catalog.pg_description AS d
- ON (c.oid = d.objoid AND c.tableoid = d.classoid AND d.objsubid = 0)
- LEFT JOIN pg_catalog.pg_namespace n ON (n.oid = c.relnamespace)
- LEFT JOIN $TSJOIN
- WHERE $whereclause
- ORDER BY "TABLE_TYPE", "TABLE_CAT", "TABLE_SCHEM", "TABLE_NAME"
+ FROM pg_catalog.pg_class AS c
+ LEFT JOIN pg_catalog.pg_description AS d
+ ON (c.oid = d.objoid AND c.tableoid = d.classoid AND d.objsubid = 0)
+ LEFT JOIN pg_catalog.pg_namespace n ON (n.oid = c.relnamespace)
+ LEFT JOIN $TSJOIN
+ WHERE $whereclause
+ ORDER BY "TABLE_TYPE", "TABLE_CAT", "TABLE_SCHEM", "TABLE_NAME"
};
- }
- my $sth = $dbh->prepare( $tbl_sql ) or return undef;
- $sth->execute();
- return $sth;
- }
+ if (defined($type) and length($type) and $type ne '%') {
+ my $type_restrict = join ', ' =>
+ map { /^'/ ? $_ : $dbh->quote($_) }
+ grep {length}
+ split(',', $type); ## no critic
+ $tbl_sql = qq{SELECT * FROM ($tbl_sql) ti WHERE "TABLE_TYPE" IN ($type_restrict)};
+ }
+ }
+ my $sth = $dbh->prepare( $tbl_sql ) or return undef;
+ $sth->execute();
+
+ return $sth;
+ }
- sub tables {
- my ($dbh, @args) = @_;
- my $attr = $args[4];
- my $sth = $dbh->table_info(@args) or return;
- my $tables = $sth->fetchall_arrayref() or return;
- my @tables = map { (! (ref $attr eq 'HASH' and $attr->{pg_noprefix})) ?
- "$_->[1].$_->[2]" : $_->[2] } @$tables;
- return @tables;
- }
+ sub tables {
+ my ($dbh, @args) = @_;
+ my $attr = $args[4];
+ my $sth = $dbh->table_info(@args) or return;
+ my $tables = $sth->fetchall_arrayref() or return;
+ my @tables = map { (! (ref $attr eq 'HASH' and $attr->{pg_noprefix})) ?
+ "$_->[1].$_->[2]" : $_->[2] } @$tables;
+ return @tables;
+ }
- sub table_attributes {
- my ($dbh, $table) = @_;
+ sub table_attributes {
+ my ($dbh, $table) = @_;
- my $sth = $dbh->column_info(undef,undef,$table,undef);
+ my $sth = $dbh->column_info(undef,undef,$table,undef);
- my %convert = (
- COLUMN_NAME => 'NAME',
- DATA_TYPE => 'TYPE',
- COLUMN_SIZE => 'SIZE',
- NULLABLE => 'NOTNULL',
- REMARKS => 'REMARKS',
- COLUMN_DEF => 'DEFAULT',
- pg_constraint => 'CONSTRAINT',
- );
+ my %convert = (
+ COLUMN_NAME => 'NAME',
+ DATA_TYPE => 'TYPE',
+ COLUMN_SIZE => 'SIZE',
+ NULLABLE => 'NOTNULL',
+ REMARKS => 'REMARKS',
+ COLUMN_DEF => 'DEFAULT',
+ pg_constraint => 'CONSTRAINT',
+ );
- my $attrs = $sth->fetchall_arrayref(\%convert);
+ my $attrs = $sth->fetchall_arrayref(\%convert);
- for my $row (@$attrs) {
- # switch the column names
- for my $name (keys %$row) {
- $row->{ $convert{$name} } = $row->{$name};
+ for my $row (@$attrs) {
+ # switch the column names
+ for my $name (keys %$row) {
+ $row->{ $convert{$name} } = $row->{$name};
- ## Keep some original columns
- delete $row->{$name} unless ($name eq 'REMARKS' or $name eq 'NULLABLE');
+ ## Keep some original columns
+ delete $row->{$name} unless ($name eq 'REMARKS' or $name eq 'NULLABLE');
- }
- # Moved check outside of loop as it was inverting the NOTNULL value for
- # attribute.
- # NOTNULL inverts the sense of NULLABLE
- $row->{NOTNULL} = ($row->{NOTNULL} ? 0 : 1);
+ }
+ # Moved check outside of loop as it was inverting the NOTNULL value for
+ # attribute.
+ # NOTNULL inverts the sense of NULLABLE
+ $row->{NOTNULL} = ($row->{NOTNULL} ? 0 : 1);
- my @pri_keys = $dbh->primary_key( undef, undef, $table );
- $row->{PRIMARY_KEY} = scalar(grep { /^$row->{NAME}$/i } @pri_keys) ? 1 : 0;
- }
+ my @pri_keys = $dbh->primary_key( undef, undef, $table );
+ $row->{PRIMARY_KEY} = scalar(grep { /^$row->{NAME}$/i } @pri_keys) ? 1 : 0;
+ }
- return $attrs;
+ return $attrs;
- }
+ }
- sub _calc_col_size {
+ sub _calc_col_size {
- my $mod = shift;
- my $size = shift;
+ my $mod = shift;
+ my $size = shift;
- if ((defined $size) and ($size > 0)) {
- return $size;
- } elsif ($mod > 0xffff) {
- my $prec = ($mod & 0xffff) - 4;
- $mod >>= 16;
- my $dig = $mod;
- return "$prec,$dig";
- } elsif ($mod >= 4) {
- return $mod - 4;
- } # else {
- # $rtn = $mod;
- # $rtn = undef;
- # }
+ if ((defined $size) and ($size > 0)) {
+ return $size;
+ } elsif ($mod > 0xffff) {
+ my $prec = ($mod & 0xffff) - 4;
+ $mod >>= 16;
+ my $dig = $mod;
+ return "$prec,$dig";
+ } elsif ($mod >= 4) {
+ return $mod - 4;
+ } # else {
+ # $rtn = $mod;
+ # $rtn = undef;
+ # }
- return;
- }
+ return;
+ }
- sub type_info_all {
- my ($dbh) = @_;
-
- my $names =
- {
- TYPE_NAME => 0,
- DATA_TYPE => 1,
- COLUMN_SIZE => 2,
- LITERAL_PREFIX => 3,
- LITERAL_SUFFIX => 4,
- CREATE_PARAMS => 5,
- NULLABLE => 6,
- CASE_SENSITIVE => 7,
- SEARCHABLE => 8,
- UNSIGNED_ATTRIBUTE => 9,
- FIXED_PREC_SCALE => 10,
- AUTO_UNIQUE_VALUE => 11,
- LOCAL_TYPE_NAME => 12,
- MINIMUM_SCALE => 13,
- MAXIMUM_SCALE => 14,
- SQL_DATA_TYPE => 15,
- SQL_DATETIME_SUB => 16,
- NUM_PREC_RADIX => 17,
- INTERVAL_PRECISION => 18,
- };
-
- ## This list is derived from dbi_sql.h in DBI, from types.c and types.h, and from the PG docs
-
- ## Aids to make the list more readable:
- my $GIG = 1073741824;
- my $PS = 'precision/scale';
- my $LEN = 'length';
- my $UN;
- my $ti =
- [
- $names,
+ sub type_info_all {
+ my ($dbh) = @_;
+
+ my $names =
+ {
+ TYPE_NAME => 0,
+ DATA_TYPE => 1,
+ COLUMN_SIZE => 2,
+ LITERAL_PREFIX => 3,
+ LITERAL_SUFFIX => 4,
+ CREATE_PARAMS => 5,
+ NULLABLE => 6,
+ CASE_SENSITIVE => 7,
+ SEARCHABLE => 8,
+ UNSIGNED_ATTRIBUTE => 9,
+ FIXED_PREC_SCALE => 10,
+ AUTO_UNIQUE_VALUE => 11,
+ LOCAL_TYPE_NAME => 12,
+ MINIMUM_SCALE => 13,
+ MAXIMUM_SCALE => 14,
+ SQL_DATA_TYPE => 15,
+ SQL_DATETIME_SUB => 16,
+ NUM_PREC_RADIX => 17,
+ INTERVAL_PRECISION => 18,
+ };
+
+ ## This list is derived from dbi_sql.h in DBI, from types.c and types.h, and from the PG docs
+
+ ## Aids to make the list more readable:
+ my $GIG = 1073741824;
+ my $PS = 'precision/scale';
+ my $LEN = 'length';
+ my $UN;
+ my $ti =
+ [
+ $names,
# name sql_type size pfx/sfx crt n/c/s +-/P/I local min max sub rdx itvl
['unknown', SQL_UNKNOWN_TYPE, 0, $UN,$UN, $UN, 1,0,0, $UN,0,0, 'UNKNOWN', $UN,$UN,
@@ -1400,31 +1304,25 @@ use 5.008001;
['timestamptz',SQL_TYPE_TIMESTAMP_WITH_TIMEZONE,
29, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'TIMESTAMPTZ',0,6,
SQL_TYPE_TIMESTAMP_WITH_TIMEZONE, $UN, $UN, $UN ],
- #
- # intentionally omitted: char, all geometric types, internal types
- ];
- return $ti;
- }
-
-
- # Characters that need to be escaped by quote().
- my %esc = (
- q{'} => '\\047', # '\\' . sprintf("%03o", ord("'")), # ISO SQL 2
- '\\' => '\\134', # '\\' . sprintf("%03o", ord("\\")),
- );
-
- # Set up lookup for SQL types we don't want to escape.
- my %no_escape = map { $_ => 1 }
- DBI::SQL_INTEGER, DBI::SQL_SMALLINT, DBI::SQL_BIGINT, DBI::SQL_DECIMAL,
- DBI::SQL_FLOAT, DBI::SQL_REAL, DBI::SQL_DOUBLE, DBI::SQL_NUMERIC;
+ #
+ # intentionally omitted: char, all geometric types, internal types
+ ];
+ return $ti;
+ }
- sub get_info {
- my ($dbh,$type) = @_;
+ # Characters that need to be escaped by quote().
+ my %esc = (
+ q{'} => '\\047', # '\\' . sprintf("%03o", ord("'")), # ISO SQL 2
+ '\\' => '\\134', # '\\' . sprintf("%03o", ord("\\")),
+ );
- return undef unless defined $type and length $type;
+ # Set up lookup for SQL types we don't want to escape.
+ my %no_escape = map { $_ => 1 }
+ DBI::SQL_INTEGER, DBI::SQL_SMALLINT, DBI::SQL_BIGINT, DBI::SQL_DECIMAL,
+ DBI::SQL_FLOAT, DBI::SQL_REAL, DBI::SQL_DOUBLE, DBI::SQL_NUMERIC;
- my %type = (
+ my %get_info_type = (
## Driver information:
@@ -1432,13 +1330,13 @@ use 5.008001;
10021 => ['SQL_ASYNC_MODE', 2 ], ## SQL_AM_STATEMENT
120 => ['SQL_BATCH_ROW_COUNT', 2 ], ## SQL_BRC_EXPLICIT
121 => ['SQL_BATCH_SUPPORT', 3 ], ## 12 SELECT_PROC + ROW_COUNT_PROC
- 2 => ['SQL_DATA_SOURCE_NAME', "dbi:Pg:$dbh->{Name}" ],
+ 2 => ['SQL_DATA_SOURCE_NAME', sub { sprintf 'dbi:Pg:%', shift->{Name} } ],
3 => ['SQL_DRIVER_HDBC', 0 ], ## not applicable
135 => ['SQL_DRIVER_HDESC', 0 ], ## not applicable
4 => ['SQL_DRIVER_HENV', 0 ], ## not applicable
76 => ['SQL_DRIVER_HLIB', 0 ], ## not applicable
5 => ['SQL_DRIVER_HSTMT', 0 ], ## not applicable
- ## Not clear what should go here. Some things suggest 'Pg', others 'Pg.pm'. We'll use DBD::Pg for now
+ ## Not clear what should go here. Some things suggest 'Pg', others 'Pg.pm'. We'll use DBD::Pg for now
6 => ['SQL_DRIVER_NAME', 'DBD::Pg' ],
77 => ['SQL_DRIVER_ODBC_VERSION', '03.00' ],
7 => ['SQL_DRIVER_VER', 'DBDVERSION' ], ## magic word
@@ -1452,21 +1350,22 @@ use 5.008001;
150 => ['SQL_KEYSET_CURSOR_ATTRIBUTES1', 0 ], ## applies to us?
151 => ['SQL_KEYSET_CURSOR_ATTRIBUTES2', 0 ], ## see above
10022 => ['SQL_MAX_ASYNC_CONCURRENT_STATEMENTS', 0 ], ## unlimited, probably
- 0 => ['SQL_MAX_DRIVER_CONNECTIONS', 'MAXCONNECTIONS' ], ## magic word
+ 0 => ['SQL_MAX_DRIVER_CONNECTIONS', \'SHOW max_connections' ],
152 => ['SQL_ODBC_INTERFACE_CONFORMANCE', 1 ], ## SQL_OIC_LEVEL_1
10 => ['SQL_ODBC_VER', '03.00.0000' ],
153 => ['SQL_PARAM_ARRAY_ROW_COUNTS', 2 ], ## correct?
154 => ['SQL_PARAM_ARRAY_SELECTS', 3 ], ## PAS_NO_SELECT
11 => ['SQL_ROW_UPDATES', 'N' ],
14 => ['SQL_SEARCH_PATTERN_ESCAPE', '\\' ],
- 13 => ['SQL_SERVER_NAME', 'CURRENTDB' ], ## magic word
+ 13 => ['SQL_SERVER_NAME', \'SELECT pg_catalog.current_database()' ],
166 => ['SQL_STANDARD_CLI_CONFORMANCE', 2 ], ## ??
167 => ['SQL_STATIC_CURSOR_ATTRIBUTES1', 519 ], ## ??
168 => ['SQL_STATIC_CURSOR_ATTRIBUTES2', 5209 ], ## ??
+ 9000 => ['9000', 1 ], ## can escape placeholders
## DBMS Information
- 16 => ['SQL_DATABASE_NAME', 'CURRENTDB' ], ## magic word
+ 16 => ['SQL_DATABASE_NAME', \'SELECT pg_catalog.current_database()' ],
17 => ['SQL_DBMS_NAME', 'PostgreSQL' ],
18 => ['SQL_DBMS_VERSION', 'ODBCVERSION' ], ## magic word
@@ -1476,7 +1375,7 @@ use 5.008001;
19 => ['SQL_ACCESSIBLE_TABLES', 'Y' ], ## is this really true?
82 => ['SQL_BOOKMARK_PERSISTENCE', 0 ],
42 => ['SQL_CATALOG_TERM', '' ], ## empty = catalogs are not supported
- 10004 => ['SQL_COLLATION_SEQ', 'ENCODING' ], ## magic word
+ 10004 => ['SQL_COLLATION_SEQ', \'SHOW server_encoding' ],
22 => ['SQL_CONCAT_NULL_BEHAVIOR', 0 ], ## SQL_CB_NULL
23 => ['SQL_CURSOR_COMMIT_BEHAVIOR', 1 ], ## SQL_CB_CLOSE
24 => ['SQL_CURSOR_ROLLBACK_BEHAVIOR', 1 ], ## SQL_CB_CLOSE
@@ -1494,7 +1393,7 @@ use 5.008001;
45 => ['SQL_TABLE_TERM', 'table' ],
46 => ['SQL_TXN_CAPABLE', 2 ], ## SQL_TC_ALL
72 => ['SQL_TXN_ISOLATION_OPTION', 10 ], ## 2+8
- 47 => ['SQL_USER_NAME', $dbh->{CURRENT_USER} ],
+ 47 => ['SQL_USER_NAME', sub { shift->{CURRENT_USER} } ],
## Supported SQL
@@ -1605,147 +1504,146 @@ use 5.008001;
122 => ['SQL_CONVERT_WCHAR', 0 ],
125 => ['SQL_CONVERT_WLONGVARCHAR', 0 ],
126 => ['SQL_CONVERT_WVARCHAR', 0 ],
+ ); ## end of %get_info_type
+ ## Add keys for names into the hash
+ for (keys %get_info_type) {
+ $get_info_type{$get_info_type{$_}->[0]} = $get_info_type{$_};
+ }
- ); ## end of %type
-
- ## Put both numbers and names into a hash
- my %t;
- for (keys %type) {
- $t{$_} = $type{$_}->[1];
- $t{$type{$_}->[0]} = $type{$_}->[1];
- }
-
- return undef unless exists $t{$type};
-
- my $ans = $t{$type};
-
- if ($ans eq 'NAMEDATALEN') {
- return $dbh->selectall_arrayref('SHOW max_identifier_length')->[0][0];
- }
- elsif ($ans eq 'ODBCVERSION') {
- my $version = $dbh->{private_dbdpg}{version};
- return '00.00.0000' unless $version =~ /^(\d\d?)(\d\d)(\d\d)$/o;
- return sprintf '%02d.%02d.%.2d00', $1,$2,$3;
- }
- elsif ($ans eq 'DBDVERSION') {
- my $simpleversion = $DBD::Pg::VERSION;
- $simpleversion =~ s/_/./g;
- return sprintf '%02d.%02d.%1d%1d%1d%1d', split (/\./, "$simpleversion.0.0.0.0.0.0");
- }
- elsif ($ans eq 'MAXCONNECTIONS') {
- return $dbh->selectall_arrayref('SHOW max_connections')->[0][0];
- }
- elsif ($ans eq 'ENCODING') {
- return $dbh->selectall_arrayref('SHOW server_encoding')->[0][0];
- }
- elsif ($ans eq 'KEYWORDS') {
- ## http://www.postgresql.org/docs/current/static/sql-keywords-appendix.html
- ## Basically, we want ones that are 'reserved' for PostgreSQL but not 'reserved' in SQL:2003
- ##
- return join ',' => (qw(ANALYSE ANALYZE ASC DEFERRABLE DESC DO FREEZE ILIKE INITIALLY ISNULL LIMIT NOTNULL OFF OFFSET PLACING RETURNING VERBOSE));
- }
- elsif ($ans eq 'CURRENTDB') {
- return $dbh->selectall_arrayref('SELECT pg_catalog.current_database()')->[0][0];
- }
- elsif ($ans eq 'READONLY') {
- my $SQL = q{SELECT CASE WHEN setting = 'on' THEN 'Y' ELSE 'N' END FROM pg_settings WHERE name = 'transaction_read_only'};
- my $info = $dbh->selectall_arrayref($SQL);
- return defined $info->[0] ? $info->[0][0] : 'N';
- }
- elsif ($ans eq 'DEFAULTTXN') {
- my $SQL = q{SELECT CASE WHEN setting = 'read committed' THEN 2 ELSE 8 END FROM pg_settings WHERE name = 'default_transaction_isolation'};
- my $info = $dbh->selectall_arrayref($SQL);
- return defined $info->[0] ? $info->[0][0] : 2;
- }
-
- return $ans;
- } # end of get_info
-
- sub private_attribute_info {
- return {
- pg_async_status => undef,
- pg_bool_tf => undef,
- pg_db => undef,
- pg_default_port => undef,
- pg_enable_utf8 => undef,
- pg_utf8_flag => undef,
- pg_errorlevel => undef,
- pg_expand_array => undef,
- pg_host => undef,
- pg_INV_READ => undef,
- pg_INV_WRITE => undef,
- pg_lib_version => undef,
- pg_options => undef,
- pg_pass => undef,
- pg_pid => undef,
- pg_placeholder_dollaronly => undef,
- pg_placeholder_nocolons => undef,
- pg_port => undef,
- pg_prepare_now => undef,
- pg_protocol => undef,
- pg_server_prepare => undef,
- pg_server_version => undef,
- pg_socket => undef,
- pg_standard_conforming_strings => undef,
- pg_switch_prepared => undef,
- pg_user => undef,
- };
- }
+ sub get_info {
+
+ my ($dbh,$type) = @_;
+
+ return undef unless defined $type;
+ return undef unless exists $get_info_type{$type};
+
+ my $ans = $get_info_type{$type}->[1];
+
+ if (ref $ans eq 'CODE') {
+ $ans = $ans->($dbh);
+ }
+ elsif (ref $ans eq 'SCALAR') { # SQL
+ return $dbh->selectall_arrayref($$ans)->[0][0];
+ }
+ elsif ($ans eq 'NAMEDATALEN') {
+ return $dbh->selectall_arrayref('SHOW max_identifier_length')->[0][0];
+ }
+ elsif ($ans eq 'ODBCVERSION') {
+ my $version = $dbh->{private_dbdpg}{version};
+ return '00.00.0000' unless $version =~ /^(\d\d?)(\d\d)(\d\d)$/o;
+ return sprintf '%02d.%02d.%.2d00', $1,$2,$3;
+ }
+ elsif ($ans eq 'DBDVERSION') {
+ my $simpleversion = $DBD::Pg::VERSION;
+ $simpleversion =~ s/_/./g;
+ return sprintf '%02d.%02d.%1d%1d%1d%1d', split (/\./, "$simpleversion.0.0.0.0.0.0");
+ }
+ elsif ($ans eq 'KEYWORDS') {
+ ## http://www.postgresql.org/docs/current/static/sql-keywords-appendix.html
+ ## Basically, we want ones that are 'reserved' for PostgreSQL but not 'reserved' in SQL:2003
+ ##
+ return join ',' => (qw(ANALYSE ANALYZE ASC DEFERRABLE DESC DO FREEZE ILIKE INITIALLY ISNULL LIMIT NOTNULL OFF OFFSET PLACING RETURNING VERBOSE));
+ }
+ elsif ($ans eq 'READONLY') {
+ my $SQL = q{SELECT CASE WHEN setting = 'on' THEN 'Y' ELSE 'N' END FROM pg_settings WHERE name = 'transaction_read_only'};
+ my $info = $dbh->selectall_arrayref($SQL);
+ return defined $info->[0] ? $info->[0][0] : 'N';
+ }
+ elsif ($ans eq 'DEFAULTTXN') {
+ my $SQL = q{SELECT CASE WHEN setting = 'read committed' THEN 2 ELSE 8 END FROM pg_settings WHERE name = 'default_transaction_isolation'};
+ my $info = $dbh->selectall_arrayref($SQL);
+ return defined $info->[0] ? $info->[0][0] : 2;
+ }
+
+ return $ans;
+ } # end of get_info
+
+ sub private_attribute_info {
+ return {
+ pg_async_status => undef,
+ pg_bool_tf => undef,
+ pg_db => undef,
+ pg_default_port => undef,
+ pg_enable_utf8 => undef,
+ pg_utf8_flag => undef,
+ pg_errorlevel => undef,
+ pg_expand_array => undef,
+ pg_host => undef,
+ pg_INV_READ => undef,
+ pg_INV_WRITE => undef,
+ pg_lib_version => undef,
+ pg_options => undef,
+ pg_pass => undef,
+ pg_pid => undef,
+ pg_placeholder_dollaronly => undef,
+ pg_placeholder_nocolons => undef,
+ pg_placeholder_escapes => undef,
+ pg_port => undef,
+ pg_prepare_now => undef,
+ pg_protocol => undef,
+ pg_server_prepare => undef,
+ pg_server_version => undef,
+ pg_socket => undef,
+ pg_standard_conforming_strings => undef,
+ pg_switch_prepared => undef,
+ pg_user => undef,
+ };
+ }
}
{
- package DBD::Pg::st;
-
- sub parse_trace_flag {
- my ($h, $flag) = @_;
- return DBD::Pg->parse_trace_flag($flag);
- }
-
- sub bind_param_array {
-
- ## Binds an array of data to a specific placeholder in a statement
- ## The DBI version is broken, so we implement a near-copy here
-
- my $sth = shift;
- my ($p_id, $value_array, $attr) = @_;
-
- ## Bail if the second arg is not undef or an arrayref
- return $sth->set_err(1, "Value for parameter $p_id must be a scalar or an arrayref, not a ".ref($value_array))
- if defined $value_array and ref $value_array and ref $value_array ne 'ARRAY';
+ package DBD::Pg::st;
- ## Bail if the first arg is not a number
- return $sth->set_err(1, q{Can't use named placeholders for non-driver supported bind_param_array})
- unless DBI::looks_like_number($p_id); # because we rely on execute(@ary) here
-
- ## Store the list of items in the hash (will be undef or an arrayref)
- $sth->{ParamArrays}{$p_id} = $value_array;
-
- ## If any attribs were passed in, we need to call bind_param
- return $sth->bind_param($p_id, '', $attr) if $attr; ## This is the big change so -w does not complain
-
- return 1;
- } ## end bind_param_array
+ sub parse_trace_flag {
+ my ($h, $flag) = @_;
+ return DBD::Pg->parse_trace_flag($flag);
+ }
- sub private_attribute_info {
- return {
- pg_async => undef,
- pg_bound => undef,
- pg_current_row => undef,
- pg_direct => undef,
- pg_numbound => undef,
- pg_cmd_status => undef,
- pg_oid_status => undef,
- pg_placeholder_dollaronly => undef,
- pg_placeholder_nocolons => undef,
- pg_prepare_name => undef,
- pg_prepare_now => undef,
- pg_segments => undef,
- pg_server_prepare => undef,
- pg_size => undef,
- pg_switch_prepared => undef,
- pg_type => undef,
- };
+ sub bind_param_array {
+
+ ## Binds an array of data to a specific placeholder in a statement
+ ## The DBI version is broken, so we implement a near-copy here
+
+ my $sth = shift;
+ my ($p_id, $value_array, $attr) = @_;
+
+ ## Bail if the second arg is not undef or an arrayref
+ return $sth->set_err(1, "Value for parameter $p_id must be a scalar or an arrayref, not a ".ref($value_array))
+ if defined $value_array and ref $value_array and ref $value_array ne 'ARRAY';
+
+ ## Bail if the first arg is not a number
+ return $sth->set_err(1, q{Can't use named placeholders for non-driver supported bind_param_array})
+ unless DBI::looks_like_number($p_id); # because we rely on execute(@ary) here
+
+ ## Store the list of items in the hash (will be undef or an arrayref)
+ $sth->{ParamArrays}{$p_id} = $value_array;
+
+ ## If any attribs were passed in, we need to call bind_param
+ return $sth->bind_param($p_id, '', $attr) if $attr; ## This is the big change so -w does not complain
+
+ return 1;
+ } ## end bind_param_array
+
+ sub private_attribute_info {
+ return {
+ pg_async => undef,
+ pg_bound => undef,
+ pg_current_row => undef,
+ pg_direct => undef,
+ pg_numbound => undef,
+ pg_cmd_status => undef,
+ pg_oid_status => undef,
+ pg_placeholder_dollaronly => undef,
+ pg_placeholder_nocolons => undef,
+ pg_prepare_name => undef,
+ pg_prepare_now => undef,
+ pg_segments => undef,
+ pg_server_prepare => undef,
+ pg_size => undef,
+ pg_switch_prepared => undef,
+ pg_type => undef,
+ };
}
} ## end st section
@@ -1778,7 +1676,7 @@ DBD::Pg - PostgreSQL database driver for the DBI module
=head1 VERSION
-This documents version 3.2.1 of the DBD::Pg module
+This documents version 3.5.1 of the DBD::Pg module
=head1 DESCRIPTION
@@ -1791,7 +1689,7 @@ This documentation describes driver specific behavior and restrictions. It is
not supposed to be used as the only reference for the user. In any case
consult the B<DBI> documentation first!
-=for html <a href="http://search.cpan.org/~timb/DBI/DBI.pm">Latest DBI docmentation.</a>
+=for html <a href="http://search.cpan.org/dist/DBI/DBI.pm">Latest DBI docmentation.</a>
=head1 THE DBI CLASS
@@ -1952,7 +1850,7 @@ handle. This is a number used by libpq and is one of:
$str = $h->errstr;
Returns the last error that was reported by Postgres. This message is affected
-by the L</pg_errorlevel> setting.
+by the L<pg_errorlevel|/pg_errorlevel_(integer)> setting.
=head3 B<state>
@@ -2079,7 +1977,7 @@ the database has been disconnected. Also output if trace level is 5 or greater.
=for text See the DBI section on TRACING for more information.
-=for html See the <a href="http://search.cpan.org/~timb/DBI/DBI.pm#TRACING">DBI section on TRACING</a> for more information.<br />
+=for html See the <a href="http://search.cpan.org/dist/DBI/DBI.pm#TRACING">DBI section on TRACING</a> for more information.<br />
=head3 B<func>
@@ -2121,12 +2019,12 @@ Upon failure it returns C<undef>. This function cannot be used if AutoCommit is
The old way of calling large objects functions is deprecated: $dbh->func(.., 'lo_);
-=item lo_open
+=item pg_lo_open
$lobj_fd = $dbh->pg_lo_open($lobjId, $mode);
Opens an existing large object and returns an object-descriptor for use in
-subsequent C<lo_*> calls. C<$mode> is a bitmask describing read and write
+subsequent C<pg_lo_*> calls. C<$mode> is a bitmask describing read and write
access to the opened object. It may be one of:
$dbh->{pg_INV_READ}
@@ -2139,26 +2037,26 @@ Reading from the object will provide the object as written in other committed
transactions, along with any writes performed by the current transaction.
Objects opened with C<pg_INV_READ> cannot be written to. Reading from this
object will provide the stored data at the time of the transaction snapshot
-which was active when C<lo_write> was called.
+which was active when C<pg_lo_write> was called.
Returns C<undef> upon failure. Note that 0 is a perfectly correct (and common)
object descriptor! This function cannot be used if AutoCommit is enabled.
-=item lo_write
+=item pg_lo_write
$nbytes = $dbh->pg_lo_write($lobj_fd, $buffer, $len);
Writes C<$len> bytes of c<$buffer> into the large object C<$lobj_fd>. Returns the number
of bytes written and C<undef> upon failure. This function cannot be used if AutoCommit is enabled.
-=item lo_read
+=item pg_lo_read
$nbytes = $dbh->pg_lo_read($lobj_fd, $buffer, $len);
Reads C<$len> bytes into c<$buffer> from large object C<$lobj_fd>. Returns the number of
bytes read and C<undef> upon failure. This function cannot be used if AutoCommit is enabled.
-=item lo_lseek
+=item pg_lo_lseek
$loc = $dbh->pg_lo_lseek($lobj_fd, $offset, $whence);
@@ -2166,53 +2064,53 @@ Changes the current read or write location on the large object
C<$obj_id>. Currently C<$whence> can only be 0 (which is L_SET). Returns the current
location and C<undef> upon failure. This function cannot be used if AutoCommit is enabled.
-=item lo_tell
+=item pg_lo_tell
$loc = $dbh->pg_lo_tell($lobj_fd);
Returns the current read or write location on the large object C<$lobj_fd> and C<undef> upon failure.
This function cannot be used if AutoCommit is enabled.
-=item lo_truncate
+=item pg_lo_truncate
$loc = $dbh->pg_lo_truncate($lobj_fd, $len);
Truncates the given large object to the new size. Returns C<undef> on failure, and 0 on success.
This function cannot be used if AutoCommit is enabled.
-=item lo_close
+=item pg_lo_close
$lobj_fd = $dbh->pg_lo_close($lobj_fd);
Closes an existing large object. Returns true upon success and false upon failure.
This function cannot be used if AutoCommit is enabled.
-=item lo_unlink
+=item pg_lo_unlink
$ret = $dbh->pg_lo_unlink($lobjId);
Deletes an existing large object. Returns true upon success and false upon failure.
This function cannot be used if AutoCommit is enabled.
-=item lo_import
+=item pg_lo_import
$lobjId = $dbh->pg_lo_import($filename);
Imports a Unix file as a large object and returns the object id of the new
object or C<undef> upon failure.
-=item lo_import_with_oid
+=item pg_lo_import_with_oid
$lobjId = $dbh->pg_lo_import($filename, $OID);
-Same as lo_import, but attempts to use the supplied OID as the
+Same as pg_lo_import, but attempts to use the supplied OID as the
large object number. If this number is 0, it falls back to the
-behavior of lo_import (which assigns the next available OID).
+behavior of pg_lo_import (which assigns the next available OID).
This is only available when DBD::Pg is compiled against a Postgres
server version 8.4 or later.
-=item lo_export
+=item pg_lo_export
$ret = $dbh->pg_lo_export($lobjId, $filename);
@@ -2222,7 +2120,7 @@ Exports a large object into a Unix file. Returns false upon failure, true otherw
$fd = $dbh->func('getfd');
-Deprecated, use L<< $dbh->{pg_socket}|/pg_socket >> instead.
+Deprecated, use $dbh->{pg_socket} instead.
=back
@@ -2288,7 +2186,7 @@ true for the lifetime of the statement handle.
=head3 B<TraceLevel> (integer, inherited)
Sets the trace level, similar to the L</trace> method. See the sections on
-L</trace> and L</parse_trace_flag> for more details.
+L</trace> and L<parse_trace_flag|/parse_trace_flag and parse_trace_flags> for more details.
=head3 B<Active> (boolean, read-only)
@@ -2424,15 +2322,15 @@ Queries that do not begin with the word "SELECT", "INSERT",
Deciding whether or not to use prepared statements depends on many factors,
but you can force them to be used or not used by using the
-L</pg_server_prepare> attribute when calling L</prepare>. Setting this to "0" means to never use
-prepared statements. Setting L</pg_server_prepare> to "1" means that prepared
+L<pg_server_prepare|/pg_server_prepare_(integer)> attribute when calling L</prepare>. Setting this to "0" means to never use
+prepared statements. Setting pg_server_prepare to "1" means that prepared
statements should be used whenever possible. This is the default when connected
to Postgres servers version 8.0 or higher. Servers that are version 7.4 get a special
default value of "2", because server-side statements were only partially supported
in that version. In this case, it only uses server-side prepares if all
parameters are specifically bound.
-The L</pg_server_prepare> attribute can also be set at connection time like so:
+The pg_server_prepare attribute can also be set at connection time like so:
$dbh = DBI->connect($DBNAME, $DBUSER, $DBPASS,
{ AutoCommit => 0,
@@ -2494,11 +2392,11 @@ be provided after the prepare but before the execute.
A server-side prepare may happen before the first L</execute>, but only if the server can
handle the server-side prepare, and the statement contains no placeholders. It will
-also be prepared if the L</pg_prepare_now> attribute is passed in and set to a true
-value. Similarly, the L</pg_prepare_now> attribute can be set to 0 to ensure that
+also be prepared if the L<pg_prepare_now|/pg_prepare_now_(boolean)> attribute is passed in and set to a true
+value. Similarly, the pg_prepare_now attribute can be set to 0 to ensure that
the statement is B<not> prepared immediately, although the cases in which you would
want this are very rare. Finally, you can set the default behavior of all prepare
-statements by setting the L</pg_prepare_now> attribute on the database handle:
+statements by setting the pg_prepare_now attribute on the database handle:
$dbh->{pg_prepare_now} = 1;
@@ -2517,7 +2415,7 @@ The following two examples will NOT be prepared right away:
There are times when you may want to prepare a statement yourself. To do this,
simply send the C<PREPARE> statement directly to the server (e.g. with
the L</do> method). Create a statement handle and set the prepared name via
-the L</pg_prepare_name> attribute. The statement handle can be created with a dummy
+the L<pg_prepare_name|/pg_prepare_name_(string)> attribute. The statement handle can be created with a dummy
statement, as it will not be executed. However, it should have the same
number of placeholders as your prepared statement. Example:
@@ -2536,7 +2434,7 @@ which is the equivalent of:
SELECT COUNT(*) FROM pg_class WHERE reltuples < 123;
You can force DBD::Pg to send your query directly to the server by adding
-the L</pg_direct> attribute to your prepare call. This is not recommended,
+the L<pg_direct|/pg_direct_(boolean)> attribute to your prepare call. This is not recommended,
but is added just in case you need it.
=head4 B<Placeholders>
@@ -2547,7 +2445,7 @@ question mark character. This is the method recommended by the DBI specs and is
portable. Each question mark is internally replaced by a "dollar sign number" in the order
in which they appear in the query (important when using L</bind_param>).
-The method second type of placeholder is "dollar sign numbers". This is the method
+The second type of placeholder is "dollar sign numbers". This is the method
that Postgres uses internally and is overall probably the best method to use
if you do not need compatibility with other database systems. DBD::Pg, like
PostgreSQL, allows the same number to be used more than once in the query.
@@ -2591,9 +2489,13 @@ use different ones for each statement handle you have. This is confusing at best
stick to one style within your program.
If your queries use operators that contain question marks (e.g. some of the native
-Postgres geometric operators) or array slices (e.g. C<data[100:300]>), you can tell
-DBD::Pg to ignore any non-dollar sign placeholders by setting the
-L</pg_placeholder_dollaronly> attribute at either the database handle or the statement
+Postgres geometric operators and JSON operators) or array slices (e.g. C<data[100:300]>),
+there are methods to instruct DBD::Pg to not treat some symbols as placeholders. First, you
+may simply add a backslash before the start of a placeholder, and DBD::Pg will strip the
+backslash and not treat the character as a placeholder.
+
+You can also tell DBD::Pg to ignore any non-dollar sign placeholders by setting the
+L<pg_placeholder_dollaronly|/pg_placeholder_dollaronly_(boolean)> attribute at either the database handle or the statement
handle level. Examples:
$dbh->{pg_placeholder_dollaronly} = 1;
@@ -2626,7 +2528,7 @@ Again, you may set it param time as well:
Implemented by DBI, no driver-specific impact. This method is most useful
when using a server that supports server-side prepares, and you have asked
-the prepare to happen immediately via the L</pg_prepare_now> attribute.
+the prepare to happen immediately via the L<pg_prepare_now|/pg_prepare_now_(boolean)> attribute.
=head3 B<do>
@@ -2721,7 +2623,7 @@ false on error. See also the the section on L</Transactions>.
=head3 B<begin_work>
-This method turns on transactions until the next call to L</commit> or L</rollback>, if L</AutoCommit> is
+This method turns on transactions until the next call to L</commit> or L</rollback>, if L<AutoCommit|/AutoCommit_(boolean)> is
currently enabled. If it is not enabled, calling begin_work will issue an error. Note that the
transaction will not actually begin until the first statement after begin_work is called.
Example:
@@ -2834,9 +2736,11 @@ server version 9.0 or higher.
$rv = $dbh->ping;
-This C<ping> method is used to check the validity of a database handle. The value returned is
-either 0, indicating that the connection is no longer valid, or a positive integer, indicating
-the following:
+The C<ping> method determines if there is a working connection to an active
+database server. It does this by sending a small query to the server, currently
+B<'DBD::Pg ping test v3.5.1'>. It returns 0 (false) if the connection is not valid,
+otherwise it returns a positive number (true). The value returned indicates the
+current state:
Value Meaning
--------------------------------------------------
@@ -2862,9 +2766,8 @@ return the following:
--------------------------------------------------
-1 There is no connection to the database at all (e.g. after disconnect)
-2 An unknown transaction status was returned (e.g. after forking)
- -3 The handle exists, but no data was returned from a test query.
-
-In practice, you should only ever see -1 and -2.
+ -3 The test query failed (PQexec returned null)
+ -4 PQstatus returned a CONNECTION_BAD
=head3 B<get_info>
@@ -2877,11 +2780,14 @@ recommended by DBI.
$sth = $dbh->table_info(undef, $schema, $table, $type);
-Returns all tables and views visible to the current user.
-The schema and table arguments will do a C<LIKE> search if a percent sign (C<%>) or an
-underscore (C<_>) is detected in the argument. The C<$type> argument accepts a value of either
-"TABLE" or "VIEW" (using both is the default action). Note that a statement handle is returned,
-and not a direct list of tables. See the examples below for ways to handle this.
+Returns all tables and views visible to the current user. The schema and table
+arguments will do a C<LIKE> search if a percent sign (C<%>) or an underscore
+(C<_>) is detected in the argument. The C<$type> argument accepts any
+comma-separated combination of "TABLE", "VIEW", "SYSTEM TABLE", "SYSTEM VIEW",
+"MATERIALIZED VIEW", "SYSTEM MATERIALIZED VIEW", or "LOCAL TEMPORARY". (Using all is the default action.)
+
+Note that a statement handle is returned, and not a direct list of tables. See
+the examples below for ways to handle this.
The following fields are returned:
@@ -2891,8 +2797,9 @@ B<TABLE_SCHEM>: The name of the schema that the table or view is in.
B<TABLE_NAME>: The name of the table or view.
-B<TABLE_TYPE>: The type of object returned. Will be one of "TABLE", "VIEW",
-or "SYSTEM TABLE".
+B<TABLE_TYPE>: The type of object returned. Will be one of "TABLE", "VIEW",
+"MATERIALIZED VIEW", "SYSTEM VIEW", "SYSTEM MATERIALIZED VIEW", "SYSTEM TABLE",
+or "LOCAL TEMPORARY".
The TABLE_SCHEM and TABLE_NAME will be quoted via C<quote_ident()>.
@@ -2909,7 +2816,7 @@ B<pg_tablespace_name>: the name of the tablespace the table is in
B<pg_tablespace_location>: the location of the tablespace the table is in
-Tables that have not been assigned to a particular tablespace (or views)
+Tables that have not been assigned to a particular tablespace (or views)
will return NULL (C<undef>) for both of the above field.
Rows are returned alphabetically, with all tables first, and then all views.
@@ -3035,7 +2942,7 @@ causes only information about unique indexes to be returned. The C<$quick> argum
not used by DBD::Pg. For information on the format of the standard rows returned, please
see the DBI documentation.
-=for html <a href="http://search.cpan.org/~timb/DBI/DBI.pm#statistics_info">DBI section on statistics_info</a>
+=for html <a href="http://search.cpan.org/dist/DBI/DBI.pm#statistics_info">DBI section on statistics_info</a>
In addition, the following Postgres specific columns are returned:
@@ -3055,7 +2962,7 @@ that this is an index expression.
@names = $dbh->tables( undef, $schema, $table, $type, \%attr );
Supported by this driver as proposed by DBI. This method returns all tables
-and/or views which are visible to the current user: see L</table_info>
+and/or views (including materialized views) which are visible to the current user: see L</table_info>
for more information about the arguments. The name of the schema appears
before the table or view name. This can be turned off by adding in the
C<pg_noprefix> attribute:
@@ -3210,20 +3117,22 @@ PQexecParams to PQexecPrepared. In other words, when it will start using server-
prepared statements (assuming all other requirements for them are met). The default value,
2, means that a prepared statement will be prepared and used the second and subsequent
time execute is called. To always use PQexecPrepared instead of PQexecParams, set
-pg_switch_prepared to 1. Setting it to 0 will force DBD::Pg to use PQexecPrepared always -
-this was the default behavior in versions older than 3.0.0.
+pg_switch_prepared to 1 (this was the default behavior in earlier versions).
+Setting pg_switch_prepared to 0 will force DBD::Pg to always use PQexecParams.
=head3 B<pg_placeholder_dollaronly> (boolean)
DBD::Pg specific attribute. Defaults to false. When true, question marks inside of statements
are not treated as L<placeholders|/Placeholders>. Useful for statements that contain unquoted question
-marks, such as geometric operators.
+marks, such as geometric operators. Note that you may also simply escape question marks with
+a backslash to prevent them from being treated as placeholders.
=head3 B<pg_placeholder_nocolons> (boolean)
DBD::Pg specific attribute. Defaults to false. When true, colons inside of statements
are not treated as L<placeholders|/Placeholders>. Useful for statements that contain an
-array slice.
+array slice. You may also place a backslash directly before the colon to prevent it from
+being treated as a placeholder.
=head3 B<pg_enable_utf8> (integer)
@@ -3351,11 +3260,11 @@ server is version 8.2 or better.
=head3 B<pg_INV_READ> (integer, read-only)
-Constant to be used for the mode in L</lo_creat> and L</lo_open>.
+Constant to be used for the mode in L</pg_lo_creat> and L</pg_lo_open>.
=head3 B<pg_INV_WRITE> (integer, read-only)
-Constant to be used for the mode in L</lo_creat> and L</lo_open>.
+Constant to be used for the mode in L</pg_lo_creat> and L</pg_lo_open>.
=head3 B<Driver> (handle, read-only)
@@ -3588,7 +3497,7 @@ Fetches the next row of data from the statement handle, and returns a reference
holding the column values. Any columns that are NULL are returned as undef within the array.
If there are no more rows or if an error occurs, the this method return undef. You should
-check C<< $sth->err >> afterwards (or use the L</RaiseError> attribute) to discover if the undef returned
+check C<< $sth->err >> afterwards (or use the L<RaiseError|/RaiseError_(boolean,_inherited)> attribute) to discover if the undef returned
was due to an error.
Note that the same array reference is returned for each fetch, so don't store the reference and
@@ -3611,7 +3520,7 @@ Fetches the next row of data and returns a hashref containing the name of the co
and the data itself as the values. Any NULL value is returned as an undef value.
If there are no more rows or if an error occurs, the this method return undef. You should
-check C<< $sth->err >> afterwards (or use the L</RaiseError> attribute) to discover if the undef returned
+check C<< $sth->err >> afterwards (or use the L<RaiseError|/RaiseError_(boolean,_inherited)> attribute) to discover if the undef returned
was due to an error.
The optional C<$name> argument should be either C<NAME>, C<NAME_lc> or C<NAME_uc>, and indicates
@@ -3626,7 +3535,7 @@ what sort of transformation to make to the keys in the hash.
Returns a reference to an array of arrays that contains all the remaining rows to be fetched from the
statement handle. If there are no more rows, an empty arrayref will be returned. If an error occurs,
the data read in so far will be returned. Because of this, you should always check C<< $sth->err >> after
-calling this method, unless L</RaiseError> has been enabled.
+calling this method, unless L<RaiseError|/RaiseError_(boolean,_inherited)> has been enabled.
If C<$slice> is an array reference, fetchall_arrayref uses the L</fetchrow_arrayref> method to fetch each
row as an array ref. If the C<$slice> array is not empty then it is used as a slice to select individual
@@ -3888,15 +3797,17 @@ Setting pg_switch_prepared to 0 will force DBD::Pg to always use PQexecParams.
=head3 B<pg_placeholder_dollaronly> (boolean)
-DBD::Pg specific attribute. Defaults to off. When true, question marks inside of the query
+DBD::Pg specific attribute. Defaults to false. When true, question marks inside of the query
being prepared are not treated as placeholders. Useful for statements that contain unquoted question
-marks, such as geometric operators.
+marks, such as geometric operators. Note that you may also simply escape question marks with
+a backslash to prevent them from being treated as placeholders.
=head3 B<pg_placeholder_nocolons> (boolean)
-DBD::Pg specific attribute. Defaults to off. When true, colons inside of statements
+DBD::Pg specific attribute. Defaults to false. When true, colons inside of statements
are not treated as L<placeholders|/Placeholders>. Useful for statements that contain an
-array slice.
+array slice. You may also place a backslash directly before the colon to prevent it from
+being treated as a placeholder.
=head3 B<pg_async> (integer)
@@ -3917,6 +3828,16 @@ Not used by DBD::Pg. See the note about L</Cursors> elsewhere in this document.
=head1 FURTHER INFORMATION
+=head2 Encoding
+
+DBD::Pg has extensive support for a client_encoding of UTF-8, and most
+things like encoding and decoding should happen automatically. If you are
+using a different encoding, you will need do the encoding and decoding
+yourself. For this reason, it is highly recommended to always use a
+client_encoding of UTF-8. The server_encoding can be anything, and no
+recommendations are made there, other than avoid SQL_ASCII whenever
+possible.
+
=head2 Transactions
Transaction behavior is controlled via the L</AutoCommit> attribute. For a
@@ -4319,7 +4240,7 @@ or by manipulating the schema search path with C<SET search_path>, e.g.
=for text The B<DBI> module.
-=for html <a href="http://search.cpan.org/~timb/DBI/DBI.pm">The DBI module</a>
+=for html <a href="http://search.cpan.org/dist/DBI/DBI.pm">The DBI module</a>
=head1 BUGS
@@ -4339,8 +4260,8 @@ DBI by Tim Bunce L<http://www.tim.bunce.name>
The original DBD-Pg was by Edmund Mergl (E.Mergl@bawue.de) and Jeffrey W. Baker
(jwbaker@acm.org). Major developers include David Wheeler <david@justatheory.com>, Jason
Stewart <jason@openinformatics.com>, Bruce Momjian <pgman@candle.pha.pa.us>, and
-Greg Sabino Mullane <greg@turnstep.com>, with help from many others: see the F<Changes>
-file for a complete list.
+Greg Sabino Mullane <greg@turnstep.com>, with help from many others: see the Changes
+file (L<http://search.cpan.org/dist/DBD-Pg/Changes>) for a complete list.
Parts of this package were originally copied from DBI and DBD-Oracle.
@@ -4352,7 +4273,7 @@ Visit the archives at http://grokbase.com/g/perl/dbd-pg
=head1 COPYRIGHT AND LICENSE
-Copyright (C) 1994-2013, Greg Sabino Mullane
+Copyright (C) 1994-2015, Greg Sabino Mullane
This module (DBD::Pg) is free software; you can redistribute it and/or modify it
under the same terms as Perl 5.10.0. For more details, see the full text of the
@@ -1,6 +1,6 @@
/*
- Copyright (c) 2000-2013 Greg Sabino Mullane and others: see the Changes file
+ Copyright (c) 2000-2015 Greg Sabino Mullane and others: see the Changes file
Portions Copyright (c) 1997-2000 Edmund Mergl
Portions Copyright (c) 1994-1997 Tim Bunce
@@ -9,6 +9,7 @@
*/
+#define NEED_newSVpvn_flags
#include "Pg.h"
@@ -215,6 +216,7 @@ quote(dbh, to_quote_sv, type_sv=Nullsv)
CODE:
{
+ bool utf8;
D_imp_dbh(dbh);
SvGETMAGIC(to_quote_sv);
@@ -224,7 +226,7 @@ quote(dbh, to_quote_sv, type_sv=Nullsv)
if (SvROK(to_quote_sv) && !SvAMAGIC(to_quote_sv)) {
if (SvTYPE(SvRV(to_quote_sv)) != SVt_PVAV)
croak("Cannot quote a reference");
- to_quote_sv = pg_stringify_array(to_quote_sv, ",", imp_dbh->pg_server_version);
+ to_quote_sv = pg_stringify_array(to_quote_sv, ",", imp_dbh->pg_server_version, imp_dbh->client_encoding_utf8);
}
/* Null is always returned as "NULL", so we can ignore any type given */
@@ -250,6 +252,9 @@ quote(dbh, to_quote_sv, type_sv=Nullsv)
}
else {
SV **svp;
+ /* Currently the type argument must be a hashref, so throw an exception if not */
+ if (!SvROK(type_sv) || SvTYPE(SvRV(type_sv)) != SVt_PVHV)
+ croak("Second argument to quote must be a hashref");
if ((svp = hv_fetch((HV*)SvRV(type_sv),"pg_type", 7, 0)) != NULL) {
type_info = pg_type_data(SvIV(*svp));
}
@@ -261,22 +266,27 @@ quote(dbh, to_quote_sv, type_sv=Nullsv)
}
}
if (!type_info) {
- warn("Unknown type %" IVdf ", defaulting to UNKNOWN",SvIV(type_sv));
+ if (NULL == type_info)
+ warn("No type given, defaulting to UNKNOWN");
+ else
+ warn("Unknown type %" IVdf ", defaulting to UNKNOWN", SvIV(type_sv));
type_info = pg_type_data(PG_UNKNOWN);
}
}
/* At this point, type_info points to a valid struct, one way or another */
+ utf8 = imp_dbh->client_encoding_utf8 && PG_BYTEA != type_info->type_id;
if (SvMAGICAL(to_quote_sv))
(void)mg_get(to_quote_sv);
+
+ /* avoid up- or down-grading the argument */
+ to_quote_sv = pg_rightgraded_sv(aTHX_ to_quote_sv, utf8);
to_quote = SvPV(to_quote_sv, len);
/* Need good debugging here */
- quoted = type_info->quote(to_quote, len, &retlen, imp_dbh->pg_server_version >= 80100 ? 1 : 0);
- RETVAL = newSVpvn(quoted, retlen);
- if (SvUTF8(to_quote_sv)) /* What about overloaded objects? */
- SvUTF8_on(RETVAL);
+ quoted = type_info->quote(aTHX_ to_quote, len, &retlen, imp_dbh->pg_server_version >= 80100 ? 1 : 0);
+ RETVAL = newSVpvn_utf8(quoted, retlen, utf8);
Safefree (quoted);
}
}
@@ -1,11 +1,11 @@
-DBD::Pg is Copyright (C) 1994-2013, Greg Sabino Mullane
+DBD::Pg is Copyright (C) 1994-2015, Greg Sabino Mullane
DBD::Pg -- the DBI PostgreSQL interface for Perl
DESCRIPTION:
------------
-This is version 3.2.1 of DBD::Pg, the Perl interface to Postgres using DBI.
+This is version 3.5.1 of DBD::Pg, the Perl interface to Postgres using DBI.
The web site for this interface, and the latest version, can be found at:
http://search.cpan.org/dist/DBD-Pg/
@@ -359,7 +359,7 @@ Once this is done, 'make test' succeeds properly.
COPYRIGHT:
----------
- Copyright (c) 2002-2013 Greg Sabino Mullane and others: see the Changes file
+ Copyright (c) 2002-2015 Greg Sabino Mullane and others: see the Changes file
Portions Copyright (c) 2002 Jeffrey W. Baker
Portions Copyright (c) 1997-2001 Edmund Mergl
Portions Copyright (c) 1994-1997 Tim Bunce
@@ -575,6 +575,10 @@ other sections referenced herein (indicated with **)
* Test on variety of versions (see ** Heavy Testing), including the optional tests.
+* Test modules that depend on DBD::Pg, in particular DBIx::Class and DBIx::Class::Schema::Loader
+
+* Consider a pre-release announcement to dbix-class-devel@lists.scsys.co.uk
+
* Make sure everything is up to date in git (git status)
* Update the versions (see ** Version Numbers) in README, Pg.pm (2 places!), Makefile.PL,
@@ -15,43 +15,43 @@ not run its Makefile.PL or Build.PL.
Hash: RIPEMD160
SHA1 6f4143600430e0bc949c17b05ac34844e5fb3ee4 .perlcriticrc
-SHA1 a7455c7f2bb22d86f56015bb3b571c142399e4d6 Changes
+SHA1 7fd50009ca75ffa163778593b7e80d6df1d76390 Changes
SHA1 21bc5f3c797d4d5b72285198ffeb1e4e1f0a2902 LICENSES/artistic.txt
SHA1 06877624ea5c77efe3b7e39b0f909eda6e25a4ec LICENSES/gpl-2.0.txt
SHA1 9c2b33069c9ceb7cd57ea0aeb7b8de144ab75672 MANIFEST
SHA1 8d2857ee9a6326c08507d8552f86709dd068fbe5 MANIFEST.SKIP
-SHA1 42f9f611147d0fdef3832c90fc726186db261aef META.yml
-SHA1 757ee49ab010961773e6829880e9c9025d3b37e6 Makefile.PL
-SHA1 92b6c5da08942e820f090ee1adb4e55c1f46fe8c Pg.h
-SHA1 a48823add28e3e51a3220311d40cd401987c7513 Pg.pm
-SHA1 27ff80390a0518b5d24dd15b90b8cdd7710d76dc Pg.xs
-SHA1 a8c560c2ef2983ca8770522782e70332862a7b40 README
-SHA1 34036e0b0dc15d899f561e8177227661eaaef2f1 README.dev
+SHA1 51f67eaf226fbacb6481bdf1cd9ba2b1e60156bd META.yml
+SHA1 18a007634ef746e54755063a017dd05274c3ba1e Makefile.PL
+SHA1 920964b687f475c0c89d208f7b0cf445cc75cfa5 Pg.h
+SHA1 c80599daa9f4d7bc0c1ea69733da2be9ebd130ca Pg.pm
+SHA1 881347f6fd99e6327a7b752a9da49d2d245bcff6 Pg.xs
+SHA1 f4a18e8d7b65ec7fbb99c6b263f5e15b9e60b977 README
+SHA1 0332ac652afae7e53181e075ca446b88b8631ac6 README.dev
SHA1 7e213bf90f513595b59c0a2c4ef94fea1592efcf README.win32
-SHA1 3aac8fa93676046f9fa31d8fd05914bf638b6c1f TODO
-SHA1 51bf2e4a7f1222187037971e70e147d73d489b8e dbdimp.c
-SHA1 9cb68abb0de526d0a9c58d52d2b6868642d50cec dbdimp.h
+SHA1 d1d664776d39011f328c21bef989b937d5d5b1db TODO
+SHA1 f026a43c85faa98115cecfa4cb3939249610d761 dbdimp.c
+SHA1 277805794455057c0b8c843b1169ed121a92ae75 dbdimp.h
SHA1 6c33bcf138e577722283bef02fceb8cbce4d100d dbivport.h
-SHA1 735fc3a48aec812cad99ba5b6d24b1c678d1819d lib/Bundle/DBD/Pg.pm
-SHA1 7e97b01e2facd3e71a79d400979357e609cc922c quote.c
-SHA1 7ccff1056809e35bcc1a3ff4f5a3d337f207681f quote.h
+SHA1 48908ba26ca5d480c713932716ea31cc0e889d1e lib/Bundle/DBD/Pg.pm
+SHA1 31be571044014a059db6e66f81e73b50a8abe086 quote.c
+SHA1 931179894b8b48de407547a38ce0e034f75baaaa quote.h
SHA1 93aa7e8cae0a361d1e6163dea0281ebff41f3c5f t/00_signature.t
SHA1 4691376dd83eef11b59ee6b1bb4ce2eb951e1920 t/00basic.t
SHA1 1f50adea4f2c7a5110eca34dc8b6d5dc9d4121ed t/01connect.t
SHA1 42b566f777c15a3d07e41d4bca55be435349376c t/01constants.t
-SHA1 a4d444f64951fc1eadd1cba8291e366d13359d81 t/02attribs.t
-SHA1 664fb661b7f70a32468f801471f9dd413c8df25a t/03dbmethod.t
+SHA1 428de15fda885a2834908679123f0a527ae345f2 t/02attribs.t
+SHA1 fe201e464695e9e0c521889e7aabb48f673024d8 t/03dbmethod.t
SHA1 4e16959f7f2e68667a42c86c3d35e8d317034b23 t/03smethod.t
SHA1 dd47bd1ac55072177a57f856daca98904939112c t/04misc.t
SHA1 9113f062bf144a5768e9e4e98a0f140f498caee1 t/06bytea.t
SHA1 c4c43b2229411c3850de0a9cb9bae8e5ccc7d822 t/07copy.t
-SHA1 e6fe3d9c739d31f344c4a56382004a97202e4d51 t/08async.t
-SHA1 3ead013fa8268caf62b6401a00969d70d0596d06 t/09arrays.t
-SHA1 97ce6ffdd6b2ac1f080a0147a0377bf5f88bebf9 t/12placeholders.t
+SHA1 3da07722ec0801113b6624c5e2037043e48b9203 t/08async.t
+SHA1 36a86f92ee4e573a05e6d21186dee2722cea23f7 t/09arrays.t
+SHA1 d844cdaa86209a4424ffabb562798138611c0b2b t/12placeholders.t
SHA1 81558ca5c783ea6792fd103444a04df615a8d127 t/20savepoints.t
-SHA1 e27c7167fdca6072b68f7b0b465504b1de5f27bc t/30unicode.t
-SHA1 b1e1d98917296def69afa730d963a3d16c23def1 t/99cleanup.t
-SHA1 28b835a7aefed7dc7167867c40f5c4e293bfb33b t/dbdpg_test_setup.pl
+SHA1 e793893121498fd1317a2bc97336edbf405b18d6 t/30unicode.t
+SHA1 1d2b40b3d8b4c19e98983b4b749d651b834ca5d0 t/99cleanup.t
+SHA1 dbe586c65d10a865565257e07aadc1bd708f7956 t/dbdpg_test_setup.pl
SHA1 0e196509e83b3ca603478d994a0837edd51b841d t/lib/App/Info.pm
SHA1 e02b0b5206c37280f9259e6a02839cbfc10be53f t/lib/App/Info/Handler.pm
SHA1 cc5d256a57f1fe0ddc587685a0cd64f812bb1ce9 t/lib/App/Info/Handler/Print.pm
@@ -60,13 +60,13 @@ SHA1 d31aa651f66190f994b05f9694d08adc207c8f86 t/lib/App/Info/RDBMS.pm
SHA1 e30faf1a65a0c61c975f1594fb848b764b82ea79 t/lib/App/Info/RDBMS/PostgreSQL.pm
SHA1 967e270789d36c0fd70b28d564ed621c9efb5f28 t/lib/App/Info/Request.pm
SHA1 cc065cffdcbb3f95349b37d34c2d203c7ea77bf2 t/lib/App/Info/Util.pm
-SHA1 09f4174a3ec321ae75112429da9d3a4667d6cf3c testme.tmp.pl
-SHA1 e2ff9705f94b93aa62fa763368b551d309fb188d types.c
+SHA1 ce6b21b77b015a4c266f03d15d82443c7ce23d03 testme.tmp.pl
+SHA1 8ac0e3d1624d7a3c7661f1e3dfdecd652af05f62 types.c
SHA1 3b6cb08c1f652a8648a5939751bbc380b3939504 types.h
SHA1 f07cd5ecaeb854c81ceb9206364979cf607e6546 win32.mak
-----BEGIN PGP SIGNATURE-----
-iEYEAREDAAYFAlN7eqcACgkQvJuQZxSWSsgSugCfXnP7REGKz2R3qfw4DoT0jN0Y
-aYwAniV6rB9t/XmA9kVi2cQoVsM8oxoE
-=1d4n
+iEYEAREDAAYFAlTjsBsACgkQvJuQZxSWSshm2gCeNleZPlGqWsGQbAdLGs+r7xAS
+CuAAniw4aN/9Xi1rkGwbTx1hKoN2Biyn
+=jZjV
-----END PGP SIGNATURE-----
@@ -7,6 +7,10 @@ May also be some at
https://github.com/bucardo/dbdpg
(although we prefer using cpan.org)
+- Make all tests work when server and/or client encoding is SQL_ASCII
+- Enable native JSON decoding, similar to arrays, perhaps with JSON::PP
+- Allow partial result sets, either via PQsetSingleRowMode or something better
+- Hack libpq to make user-defined number of rows returned
- Map hstore to hashes ala array/array mapping
- Fix ping problem: http://www.cpantesters.org/cpan/report/53c5cc72-6d39-11e1-8b9d-82c3d2d9ea9f
- Use WITH HOLD for cursor work
@@ -1,6 +1,6 @@
/*
- Copyright (c) 2002-2013 Greg Sabino Mullane and others: see the Changes file
+ Copyright (c) 2002-2015 Greg Sabino Mullane and others: see the Changes file
Portions Copyright (c) 2002 Jeffrey W. Baker
Portions Copyright (c) 1997-2000 Edmund Mergl
Portions Copyright (c) 1994-1997 Tim Bunce
@@ -84,6 +84,7 @@ static int pg_st_deallocate_statement(pTHX_ SV *sth, imp_sth_t *imp_sth);
static PGTransactionStatusType pg_db_txn_status (pTHX_ imp_dbh_t *imp_dbh);
static int pg_db_start_txn (pTHX_ SV *dbh, imp_dbh_t *imp_dbh);
static int handle_old_async(pTHX_ SV * handle, imp_dbh_t * imp_dbh, const int asyncflag);
+static void pg_db_detect_client_encoding_utf8(pTHX_ imp_dbh_t *imp_dbh);
/* ================================================================== */
void dbd_init (dbistate_t *dbistate)
@@ -224,9 +225,7 @@ int dbd_db_login6 (SV * dbh, imp_dbh_t * imp_dbh, char * dbname, char * uid, cha
}
}
- imp_dbh->client_encoding_utf8 =
- (0 == strncmp(PQparameterStatus(imp_dbh->conn, "client_encoding"), "UTF8", 4))
- ? DBDPG_TRUE : DBDPG_FALSE;
+ pg_db_detect_client_encoding_utf8(aTHX_ imp_dbh);
/* If the client_encoding is UTF8, flip the utf8 flag until convinced otherwise */
imp_dbh->pg_utf8_flag = imp_dbh->client_encoding_utf8;
@@ -237,6 +236,7 @@ int dbd_db_login6 (SV * dbh, imp_dbh_t * imp_dbh, char * dbname, char * uid, cha
imp_dbh->done_begin = DBDPG_FALSE;
imp_dbh->dollaronly = DBDPG_FALSE;
imp_dbh->nocolons = DBDPG_FALSE;
+ imp_dbh->ph_escaped = DBDPG_TRUE;
imp_dbh->expand_array = DBDPG_TRUE;
imp_dbh->txn_read_only = DBDPG_FALSE;
imp_dbh->pid_number = getpid();
@@ -455,6 +455,7 @@ int dbd_db_ping (SV * dbh)
D_imp_dbh(dbh);
PGTransactionStatusType tstatus;
ExecStatusType status;
+ PGresult * result;
if (TSTART_slow) TRC(DBILOGFP, "%sBegin dbd_db_ping\n", THEADER_slow);
@@ -464,7 +465,6 @@ int dbd_db_ping (SV * dbh)
}
tstatus = pg_db_txn_status(aTHX_ imp_dbh);
-
if (TRACE5_slow) TRC(DBILOGFP, "%sdbd_db_ping txn_status is %d\n", THEADER_slow, tstatus);
if (tstatus >= 4) { /* Unknown, so we err on the side of "bad" */
@@ -472,25 +472,34 @@ int dbd_db_ping (SV * dbh)
return -2;
}
- if (tstatus != 0) {/* 2=active, 3=intrans, 4=inerror */
- if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_pg_ping (result: %d)\n", THEADER_slow, 1+tstatus);
- return 1+tstatus;
+ /* No matter what state we are in, send an empty query to the backend */
+ result = PQexec(imp_dbh->conn, "/* DBD::Pg ping test v3.5.1 */");
+ if (NULL == result) {
+ /* Something very bad, usually indicating the backend is gone */
+ return -3;
}
+ status = PQresultStatus(result);
+ PQclear(result);
- /* Even though it may be reported as normal, we have to make sure by issuing a command */
-
- status = _result(aTHX_ imp_dbh, "SELECT 'DBD::Pg ping test'");
+ /* We expect to see an empty query most times */
+ if (PGRES_EMPTY_QUERY == status) {
+ if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_pg_ping (PGRES_EMPTY_QUERY)\n", THEADER_slow);
+ return 1+tstatus;
+ /* 0=idle 1=active 2=intrans 3=inerror 4=unknown */
+ }
- if (PGRES_TUPLES_OK == status) {
- if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_pg_ping (result: 1 PGRES_TUPLES_OK)\n", THEADER_slow);
- return 1;
+ /* As a safety measure, check PQstatus as well */
+ if (CONNECTION_BAD == PQstatus(imp_dbh->conn)) {
+ if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_pg_ping (PQstatus returned CONNECTION_BAD)\n", THEADER_slow);
+ return -4;
}
- if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_pg_ping (result: -3)\n", THEADER_slow);
- return -3;
+ if (TEND_slow) TRC(DBILOGFP, "%sEnd dbd_pg_ping\n", THEADER_slow);
-} /* end of dbd_db_ping */
+ return 1+tstatus;
+} /* end of dbd_db_ping */
+
/* ================================================================== */
static PGTransactionStatusType pg_db_txn_status (pTHX_ imp_dbh_t * imp_dbh)
@@ -918,9 +927,7 @@ int dbd_db_STORE_attrib (SV * dbh, imp_dbh_t * imp_dbh, SV * keysv, SV * valuesv
}
/* Do The Right Thing */
else if (-1 == imp_dbh->pg_enable_utf8) {
- imp_dbh->client_encoding_utf8 =
- (0 == strncmp(PQparameterStatus(imp_dbh->conn, "client_encoding"), "UTF8", 4))
- ? DBDPG_TRUE : DBDPG_FALSE;
+ pg_db_detect_client_encoding_utf8(aTHX_ imp_dbh);
imp_dbh->pg_enable_utf8 = -1;
imp_dbh->pg_utf8_flag = imp_dbh->client_encoding_utf8;
}
@@ -961,6 +968,14 @@ int dbd_db_STORE_attrib (SV * dbh, imp_dbh_t * imp_dbh, SV * keysv, SV * valuesv
}
break;
+ case 22: /* pg_placeholder_escaped */
+
+ if (strEQ("pg_placeholder_escaped", key)) {
+ imp_dbh->ph_escaped = newval ? DBDPG_TRUE : DBDPG_FALSE;
+ retval = 1;
+ }
+ break;
+
case 23: /* pg_placeholder_nocolons */
if (strEQ("pg_placeholder_nocolons", key)) {
@@ -1530,13 +1545,16 @@ SV * pg_db_pg_notifies (SV * dbh, imp_dbh_t * imp_dbh)
/* ================================================================== */
-int dbd_st_prepare (SV * sth, imp_sth_t * imp_sth, char * statement, SV * attribs)
+int dbd_st_prepare_sv (SV * sth, imp_sth_t * imp_sth, SV * statement_sv, SV * attribs)
{
dTHX;
D_imp_dbh_from_sth;
STRLEN mypos=0, wordstart, newsize; /* Used to find and set firstword */
SV **svp; /* To help parse the arguments */
+ statement_sv = pg_rightgraded_sv(aTHX_ statement_sv, imp_dbh->client_encoding_utf8);
+ char *statement = SvPV_nolen(statement_sv);
+
if (TSTART_slow) TRC(DBILOGFP, "%sBegin dbd_st_prepare (statement: %s)\n", THEADER_slow, statement);
if ('\0' == *statement)
@@ -1721,7 +1739,7 @@ static void pg_st_split_statement (pTHX_ imp_sth_t * imp_sth, int version, char
if (TSTART_slow) TRC(DBILOGFP, "%sBegin pg_st_split_statement\n", THEADER_slow);
if (TRACE6_slow) TRC(DBILOGFP, "%spg_st_split_statement: (%s)\n", THEADER_slow, statement);
-
+
/*
If the pg_direct flag is set (or the string has no length), we do not split at all,
but simply put everything verbatim into a single segment and return.
@@ -1967,6 +1985,25 @@ static void pg_st_split_statement (pTHX_ imp_sth_t * imp_sth, int version, char
continue;
}
+ /*
+ If this placeholder is escaped, we rewrite the string to remove the
+ backslash, and move on as if there is no placeholder.
+ The use of $dbh->{pg_placeholder_escaped} = 0 is left as an emergency measure.
+ It will probably be removed at some point.
+ */
+ if ('\\' == oldch && imp_dbh->ph_escaped) {
+ /* copy the placeholder-like character but ignore the backslash */
+ char *p = statement-2;
+ while(*p++) {
+ *(p-1) = *p;
+ }
+ /* We need to adjust these items because we just rewrote 'statement'! */
+ statement--;
+ currpos--;
+ ch = *statement;
+ continue;
+ }
+
/* We might slurp in a placeholder, so mark the character before the current one */
/* In other words, inside of "ABC?", set sectionstop to point to "C" */
sectionstop=currpos-1;
@@ -2446,7 +2483,7 @@ int dbd_bind_ph (SV * sth, imp_sth_t * imp_sth, SV * ph_name, SV * newvalue, IV
}
else if (SvTYPE(SvRV(newvalue)) == SVt_PVAV) {
SV * quotedval;
- quotedval = pg_stringify_array(newvalue,",",imp_dbh->pg_server_version);
+ quotedval = pg_stringify_array(newvalue,",",imp_dbh->pg_server_version,imp_dbh->client_encoding_utf8);
currph->valuelen = sv_len(quotedval);
Renew(currph->value, currph->valuelen+1, char); /* freed in dbd_st_destroy */
Copy(SvUTF8(quotedval) ? SvPVutf8_nolen(quotedval) : SvPV_nolen(quotedval),
@@ -2544,6 +2581,8 @@ int dbd_bind_ph (SV * sth, imp_sth_t * imp_sth, SV * ph_name, SV * newvalue, IV
(void)SvUPGRADE(newvalue, SVt_PV);
if (SvOK(newvalue)) {
+ /* get the right encoding, without modifying the caller's copy */
+ newvalue = pg_rightgraded_sv(aTHX_ newvalue, imp_dbh->client_encoding_utf8 && PG_BYTEA!=currph->bind_type->type_id);
value_string = SvPV(newvalue, currph->valuelen);
Renew(currph->value, currph->valuelen+1, char); /* freed in dbd_st_destroy */
Copy(value_string, currph->value, currph->valuelen, char);
@@ -2582,7 +2621,7 @@ int dbd_bind_ph (SV * sth, imp_sth_t * imp_sth, SV * ph_name, SV * newvalue, IV
/* ================================================================== */
-SV * pg_stringify_array(SV *input, const char * array_delim, int server_version) {
+SV * pg_stringify_array(SV *input, const char * array_delim, int server_version, bool utf8) {
dTHX;
AV * toparr;
@@ -2602,6 +2641,8 @@ SV * pg_stringify_array(SV *input, const char * array_delim, int server_version)
toparr = (AV *) SvRV(input);
value = newSVpv("{", 1);
+ if (utf8)
+ SvUTF8_on(value);
/* Empty arrays are easy */
if (av_len(toparr) < 0) {
@@ -2685,8 +2726,8 @@ SV * pg_stringify_array(SV *input, const char * array_delim, int server_version)
}
else {
sv_catpv(value, "\"");
- if (SvUTF8(svitem))
- SvUTF8_on(value);
+ /* avoid up- or down-grading the caller's value */
+ svitem = pg_rightgraded_sv(aTHX_ svitem, utf8);
string = SvPV(svitem, stringlength);
while (stringlength--) {
/* Escape backslashes and double-quotes. */
@@ -2822,7 +2863,7 @@ static SV * pg_destringify_array(pTHX_ imp_dbh_t *imp_dbh, unsigned char * input
else {
// Bytea gets special dequoting
if (0 == strncmp(coltype->type_name, "_bytea", 6)) {
- coltype->dequote(string, §ion_size);
+ coltype->dequote(aTHX_ string, §ion_size);
}
SV *sv = newSVpvn(string, section_size);
@@ -2872,6 +2913,60 @@ static SV * pg_destringify_array(pTHX_ imp_dbh_t *imp_dbh, unsigned char * input
} /* end of pg_destringify_array */
+SV * pg_upgraded_sv(pTHX_ SV *input) {
+ U8 *p, *end;
+ STRLEN len;
+ /* SvPV() can change the value SvUTF8() (for overloaded values and tied values). */
+ p = (U8*)SvPV(input, len);
+ if(SvUTF8(input)) return input;
+ for(end = p + len; p != end; p++) {
+ if(*p & 0x80) {
+ SV *output = sv_mortalcopy(input);
+ sv_utf8_upgrade(output);
+ return output;
+ }
+ }
+ return input;
+}
+
+SV * pg_downgraded_sv(pTHX_ SV *input) {
+ U8 *p, *end;
+ STRLEN len;
+ /* SvPV() can change the value SvUTF8() (for overloaded values and tied values). */
+ p = (U8*)SvPV(input, len);
+ if(!SvUTF8(input)) return input;
+ for(end = p + len; p != end; p++) {
+ if(*p & 0x80) {
+ SV *output = sv_mortalcopy(input);
+ sv_utf8_downgrade(output, DBDPG_FALSE);
+ return output;
+ }
+ }
+ return input;
+}
+
+SV * pg_rightgraded_sv(pTHX_ SV *input, bool utf8) {
+ return utf8 ? pg_upgraded_sv(aTHX_ input) : pg_downgraded_sv(aTHX_ input);
+}
+
+static void pg_db_detect_client_encoding_utf8(pTHX_ imp_dbh_t *imp_dbh) {
+ char *clean_encoding;
+ int i, j;
+ const char * const client_encoding =
+ PQparameterStatus(imp_dbh->conn, "client_encoding");
+ STRLEN len = strlen(client_encoding);
+ Newx(clean_encoding, len + 1, char);
+ for (i = 0, j = 0; i < len; i++) {
+ const char c = toLOWER(client_encoding[i]);
+ if (isALPHA(c) || isDIGIT(c))
+ clean_encoding[j++] = c;
+ };
+ clean_encoding[j] = '\0';
+ imp_dbh->client_encoding_utf8 =
+ (strnEQ(clean_encoding, "utf8", 4) || strnEQ(clean_encoding, "unicode", 8))
+ ? DBDPG_TRUE : DBDPG_FALSE;
+ Safefree(clean_encoding);
+}
/* ================================================================== */
int pg_quickexec (SV * dbh, const char * sql, const int asyncflag)
@@ -3216,6 +3311,7 @@ int dbd_st_execute (SV * sth, imp_sth_t * imp_sth)
if (currph->quoted)
Safefree(currph->quoted);
currph->quoted = currph->bind_type->quote(
+ aTHX_
currph->value,
currph->valuelen,
&currph->quotedlen,
@@ -3605,11 +3701,11 @@ AV * dbd_st_fetch (SV * sth, imp_sth_t * imp_sth)
if (type_info
&& 0 == strncmp(type_info->arrayout, "array", 5)
&& imp_dbh->expand_array) {
- sv_setsv(sv, pg_destringify_array(aTHX_ imp_dbh, value, type_info));
+ sv_setsv(sv, sv_2mortal(pg_destringify_array(aTHX_ imp_dbh, value, type_info)));
}
else {
if (type_info) {
- type_info->dequote(value, &value_len); /* dequote in place */
+ type_info->dequote(aTHX_ value, &value_len); /* dequote in place */
/* For certain types, we can cast to non-string Perlish values */
switch (type_info->type_id) {
case PG_BOOL:
@@ -3652,7 +3748,11 @@ AV * dbd_st_fetch (SV * sth, imp_sth_t * imp_sth)
if (type_info && PG_BYTEA == type_info->type_id) {
SvUTF8_off(sv);
}
- else {
+ /*
+ Don't try to upgrade references (e.g. arrays).
+ pg_destringify_array() upgrades the items as appropriate.
+ */
+ else if (!SvROK(sv)) {
SvUTF8_on(sv);
}
}
@@ -1,5 +1,5 @@
/*
- Copyright (c) 2000-2013 Greg Sabino Mullane and others: see the Changes file
+ Copyright (c) 2000-2015 Greg Sabino Mullane and others: see the Changes file
Portions Copyright (c) 1997-2000 Edmund Mergl
Portions Copyright (c) 1994-1997 Tim Bunce
@@ -37,6 +37,7 @@ struct imp_dbh_st {
bool done_begin; /* have we done a begin? (e.g. are we in a transaction?) */
bool dollaronly; /* only consider $1, $2 ... as valid placeholders */
bool nocolons; /* do not consider :1, :2 ... as valid placeholders */
+ bool ph_escaped; /* allow backslash to escape placeholders */
bool expand_array; /* transform arrays from the db into Perl arrays? Default is 1 */
bool txn_read_only; /* are we in read-only mode? Set with $dbh->{ReadOnly} */
@@ -158,8 +159,8 @@ int dbd_st_STORE_attrib (SV * sth, imp_sth_t * imp_sth, SV * keysv, SV * valuesv
#define dbd_discon_all pg_discon_all
int dbd_discon_all (SV * drh, imp_drh_t * imp_drh);
-#define dbd_st_prepare pg_st_prepare
-int dbd_st_prepare (SV * sth, imp_sth_t * imp_sth, char * statement, SV * attribs);
+#define dbd_st_prepare_sv pg_st_prepare_sv
+int dbd_st_prepare_sv (SV * sth, imp_sth_t * imp_sth, SV * statement_sv, SV * attribs);
#define dbd_bind_ph pg_bind_ph
int dbd_bind_ph (SV * sth, imp_sth_t * imp_sth, SV * ph_name, SV * newvalue, IV sql_type, SV * attribs, int is_inout, IV maxlen);
@@ -197,7 +198,9 @@ int pg_db_getfd (imp_dbh_t * imp_dbh);
SV * pg_db_pg_notifies (SV *dbh, imp_dbh_t *imp_dbh);
-SV * pg_stringify_array(SV * input, const char * array_delim, int server_version);
+SV * pg_rightgraded_sv(pTHX_ SV *input, bool utf8);
+
+SV * pg_stringify_array(SV * input, const char * array_delim, int server_version, bool utf8);
int pg_quickexec (SV *dbh, const char *sql, const int asyncflag);
@@ -4,7 +4,7 @@ package Bundle::DBD::Pg;
use strict;
use warnings;
-$VERSION = '3.2.1';
+$VERSION = '3.5.1';
1;
@@ -1,6 +1,6 @@
/*
- Copyright (c) 2003-2013 Greg Sabino Mullane and others: see the Changes file
+ Copyright (c) 2003-2015 Greg Sabino Mullane and others: see the Changes file
You may distribute under the terms of either the GNU General Public
License or the Artistic License, as specified in the Perl README file.
@@ -34,9 +34,8 @@ In other words, is it 8.1 or better?
It must arrive as 0 or 1
*/
-char * null_quote(const char *string, STRLEN len, STRLEN *retlen, int estring)
+char * null_quote(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring)
{
- dTHX;
char *result;
New(0, result, len+1, char);
@@ -47,9 +46,8 @@ char * null_quote(const char *string, STRLEN len, STRLEN *retlen, int estring)
}
-char * quote_string(const char *string, STRLEN len, STRLEN *retlen, int estring)
+char * quote_string(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring)
{
- dTHX;
char * result;
STRLEN oldlen = len;
const char * const tmp = string;
@@ -93,9 +91,8 @@ char * quote_string(const char *string, STRLEN len, STRLEN *retlen, int estring)
/* Quote a geometric constant. */
/* Note: we only verify correct characters here, not for 100% valid input */
/* Covers: points, lines, lsegs, boxes, polygons */
-char * quote_geom(const char *string, STRLEN len, STRLEN *retlen, int estring)
+char * quote_geom(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring)
{
- dTHX;
char * result;
const char *tmp;
@@ -125,9 +122,8 @@ char * quote_geom(const char *string, STRLEN len, STRLEN *retlen, int estring)
}
/* Same as quote_geom, but also allows square brackets */
-char * quote_path(const char *string, STRLEN len, STRLEN *retlen, int estring)
+char * quote_path(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring)
{
- dTHX;
char * result;
const char * const tmp = string;
@@ -156,9 +152,8 @@ char * quote_path(const char *string, STRLEN len, STRLEN *retlen, int estring)
}
/* Same as quote_geom, but also allows less than / greater than signs */
-char * quote_circle(const char *string, STRLEN len, STRLEN *retlen, int estring)
+char * quote_circle(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring)
{
- dTHX;
char * result;
const char * const tmp = string;
@@ -188,9 +183,8 @@ char * quote_circle(const char *string, STRLEN len, STRLEN *retlen, int estring)
}
-char * quote_bytea(char *string, STRLEN len, STRLEN *retlen, int estring)
+char * quote_bytea(pTHX_ char *string, STRLEN len, STRLEN *retlen, int estring)
{
- dTHX;
char * result;
STRLEN oldlen = len;
@@ -249,20 +243,18 @@ char * quote_bytea(char *string, STRLEN len, STRLEN *retlen, int estring)
return (char *)result - (*retlen);
}
-char * quote_sql_binary(char *string, STRLEN len, STRLEN *retlen, int estring)
+char * quote_sql_binary(pTHX_ char *string, STRLEN len, STRLEN *retlen, int estring)
{
- dTHX;
/* We are going to return a quote_bytea() for backwards compat but
we warn first */
warn("Use of SQL_BINARY invalid in quote()");
- return quote_bytea(string, len, retlen, estring);
+ return quote_bytea(aTHX_ string, len, retlen, estring);
}
/* Return TRUE, FALSE, or throws an error */
-char * quote_bool(const char *value, STRLEN len, STRLEN *retlen, int estring)
+char * quote_bool(pTHX_ const char *value, STRLEN len, STRLEN *retlen, int estring)
{
- dTHX;
char *result;
/* Things that are true: t, T, 1, true, TRUE, 0E0, 0 but true */
@@ -299,9 +291,8 @@ char * quote_bool(const char *value, STRLEN len, STRLEN *retlen, int estring)
}
-char * quote_int(const char *string, STRLEN len, STRLEN *retlen, int estring)
+char * quote_int(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring)
{
- dTHX;
char * result;
New(0, result, len+1, char);
@@ -320,9 +311,8 @@ char * quote_int(const char *string, STRLEN len, STRLEN *retlen, int estring)
return result;
}
-char * quote_float(char *string, STRLEN len, STRLEN *retlen, int estring)
+char * quote_float(pTHX_ char *string, STRLEN len, STRLEN *retlen, int estring)
{
- dTHX;
char * result;
/* Empty string is always an error. Here for dumb compilers. */
@@ -359,9 +349,8 @@ char * quote_float(char *string, STRLEN len, STRLEN *retlen, int estring)
return result;
}
-char * quote_name(const char *string, STRLEN len, STRLEN *retlen, int estring)
+char * quote_name(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring)
{
- dTHX;
char * result;
const char *ptr;
int nquotes = 0;
@@ -424,17 +413,15 @@ char * quote_name(const char *string, STRLEN len, STRLEN *retlen, int estring)
return result;
}
-void dequote_char(const char *string, STRLEN *retlen, int estring)
+void dequote_char(pTHX_ const char *string, STRLEN *retlen, int estring)
{
- dTHX;
/* TODO: chop_blanks if requested */
*retlen = strlen(string);
}
-void dequote_string(const char *string, STRLEN *retlen, int estring)
+void dequote_string(pTHX_ const char *string, STRLEN *retlen, int estring)
{
- dTHX;
*retlen = strlen(string);
}
@@ -442,7 +429,6 @@ void dequote_string(const char *string, STRLEN *retlen, int estring)
static void _dequote_bytea_escape(char *string, STRLEN *retlen, int estring)
{
- dTHX;
char *result;
(*retlen) = 0;
@@ -480,7 +466,6 @@ static void _dequote_bytea_escape(char *string, STRLEN *retlen, int estring)
static int _decode_hex_digit(char digit)
{
- dTHX;
if (digit >= '0' && digit <= '9')
return digit - '0';
if (digit >= 'a' && digit <= 'f')
@@ -493,7 +478,6 @@ static int _decode_hex_digit(char digit)
static void _dequote_bytea_hex(char *string, STRLEN *retlen, int estring)
{
- dTHX;
char *result;
(*retlen) = 0;
@@ -515,9 +499,8 @@ static void _dequote_bytea_hex(char *string, STRLEN *retlen, int estring)
}
}
-void dequote_bytea(char *string, STRLEN *retlen, int estring)
+void dequote_bytea(pTHX_ char *string, STRLEN *retlen, int estring)
{
- dTHX;
if (NULL != string) {
if ('\\' == *string && 'x' == *(string+1))
@@ -532,22 +515,20 @@ void dequote_bytea(char *string, STRLEN *retlen, int estring)
it might be nice to let people go the other way too. Say when talking
to something that uses SQL_BINARY
*/
-void dequote_sql_binary(char *string, STRLEN *retlen, int estring)
+void dequote_sql_binary(pTHX_ char *string, STRLEN *retlen, int estring)
{
- dTHX;
/* We are going to return a dequote_bytea(), just in case */
warn("Use of SQL_BINARY invalid in dequote()");
- dequote_bytea(string, retlen, estring);
+ dequote_bytea(aTHX_ string, retlen, estring);
/* Put dequote_sql_binary function here at some point */
}
-void dequote_bool(char *string, STRLEN *retlen, int estring)
+void dequote_bool(pTHX_ char *string, STRLEN *retlen, int estring)
{
- dTHX;
switch(*string){
case 'f': *string = '0'; break;
@@ -559,9 +540,8 @@ void dequote_bool(char *string, STRLEN *retlen, int estring)
}
-void null_dequote(const char *string, STRLEN *retlen, int estring)
+void null_dequote(pTHX_ const char *string, STRLEN *retlen, int estring)
{
- dTHX;
*retlen = strlen(string);
}
@@ -1,20 +1,20 @@
-char * null_quote(const char *string, STRLEN len, STRLEN *retlen, int estring);
-char * quote_string(const char *string, STRLEN len, STRLEN *retlen, int estring);
-char * quote_bytea(char *string, STRLEN len, STRLEN *retlen, int estring);
-char * quote_sql_binary(char *string, STRLEN len, STRLEN *retlen, int estring);
-char * quote_bool(const char *string, STRLEN len, STRLEN *retlen, int estring);
-char * quote_integer(const char *string, STRLEN len, STRLEN *retlen, int estring);
-char * quote_int(const char *string, STRLEN len, STRLEN *retlen, int estring);
-char * quote_float(char *string, STRLEN len, STRLEN *retlen, int estring);
-char * quote_name(const char *string, STRLEN len, STRLEN *retlen, int estring);
-char * quote_geom(const char *string, STRLEN len, STRLEN *retlen, int estring);
-char * quote_path(const char *string, STRLEN len, STRLEN *retlen, int estring);
-char * quote_circle(const char *string, STRLEN len, STRLEN *retlen, int estring);
-void dequote_char(const char *string, STRLEN *retlen, int estring);
-void dequote_string(const char *string, STRLEN *retlen, int estring);
-void dequote_bytea(char *string, STRLEN *retlen, int estring);
-void dequote_sql_binary(char *string, STRLEN *retlen, int estring);
-void dequote_bool(char *string, STRLEN *retlen, int estring);
-void null_dequote(const char *string, STRLEN *retlen, int estring);
+char * null_quote(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring);
+char * quote_string(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring);
+char * quote_bytea(pTHX_ char *string, STRLEN len, STRLEN *retlen, int estring);
+char * quote_sql_binary(pTHX_ char *string, STRLEN len, STRLEN *retlen, int estring);
+char * quote_bool(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring);
+char * quote_integer(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring);
+char * quote_int(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring);
+char * quote_float(pTHX_ char *string, STRLEN len, STRLEN *retlen, int estring);
+char * quote_name(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring);
+char * quote_geom(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring);
+char * quote_path(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring);
+char * quote_circle(pTHX_ const char *string, STRLEN len, STRLEN *retlen, int estring);
+void dequote_char(pTHX_ const char *string, STRLEN *retlen, int estring);
+void dequote_string(pTHX_ const char *string, STRLEN *retlen, int estring);
+void dequote_bytea(pTHX_ char *string, STRLEN *retlen, int estring);
+void dequote_sql_binary(pTHX_ char *string, STRLEN *retlen, int estring);
+void dequote_bool(pTHX_ char *string, STRLEN *retlen, int estring);
+void null_dequote(pTHX_ const char *string, STRLEN *retlen, int estring);
bool is_keyword(const char *string);
@@ -18,7 +18,7 @@ my ($helpconnect,$connerror,$dbh) = connect_database();
if (! $dbh) {
plan skip_all => 'Connection to database failed, cannot continue testing';
}
-plan tests => 260;
+plan tests => 259;
isnt ($dbh, undef, 'Connect to database for handle attributes testing');
@@ -194,7 +194,6 @@ is ($rows, 1, $t);
ok ($dbh2->disconnect(), 'Disconnect with second database handle');
-
#
# Test of the database handle attribute "Driver"
#
@@ -220,6 +219,7 @@ SKIP: {
is ($attrib, $expected, $t);
}
+
#
# Test of the database handle attribute "RowCacheSize"
#
@@ -282,7 +282,6 @@ $dbh->rollback();
}
-
#
# Test of the database handle attributes "pg_INV_WRITE" and "pg_INV_READ"
# (these are used by the lo_* database handle methods)
@@ -403,13 +402,6 @@ SKIP: {
is ($result, 'off', $t);
}
-## If Encode is available, we will insert some non-ASCII into the test table
-## Since this will fail with client encodings such as BIG5, we force UTF8
-my $old_encoding = $dbh->selectall_arrayref('SHOW client_encoding')->[0][0];
-if ($old_encoding ne 'UTF8') {
- $dbh->do(q{SET NAMES 'UTF8'});
-}
-
# Attempt to test whether or not we can get unicode out of the database
SKIP: {
eval { require Encode; };
@@ -438,7 +430,7 @@ SKIP: {
ok (Encode::is_utf8($name), $t);
$t='Unicode (utf8) data returned from database is not corrupted';
- is (length($name), 4, $t);
+ is ($name, $utf8_str, $t);
$t='ASCII text returned from database does have utf8 bit set';
$sth->finish();
@@ -961,20 +953,16 @@ q{SELECT * FROM dbd_pg_test},
like ($result, qr/^$expected/, $t);
}
-## From this point forward, it is safe to use the client's native encoding again
-if ($old_encoding ne 'UTF8') {
- $dbh->do(qq{SET NAMES '$old_encoding'});
-}
-
#
# Test of the handle attribute "Active"
#
+
$t='Database handle attribute "Active" is true while connected';
$attrib = $dbh->{Active};
is ($attrib, 1, $t);
-$t='Statement handle attribute "Active" is false before SELECT';
+
$sth = $dbh->prepare('SELECT 123 UNION SELECT 456');
$attrib = $sth->{Active};
is ($attrib, '', $t);
@@ -998,6 +986,7 @@ is ($attrib, '', $t);
# Test of the handle attribute "Executed"
#
+
my $dbh3 = connect_database({quickreturn => 1});
$dbh3->{AutoCommit} = 0;
@@ -1043,20 +1032,18 @@ is ($dbh3->{Executed}, '', $t);
$t='Statement handle attribute "Executed" is true after rollback()';
is ($sth->{Executed}, 1, $t);
-$dbh3->disconnect();
-
#
# Test of the handle attribute "Kids"
#
$t='Database handle attribute "Kids" is set properly';
-$attrib = $dbh->{Kids};
-is ($attrib, 2, $t);
+$attrib = $dbh3->{Kids};
+is ($attrib, 1, $t);
$t='Database handle attribute "Kids" works';
-my $sth2 = $dbh->prepare('SELECT 234');
-$attrib = $dbh->{Kids};
-is ($attrib, 3, $t);
+my $sth2 = $dbh3->prepare('SELECT 234');
+$attrib = $dbh3->{Kids};
+is ($attrib, 2, $t);
$t='Statement handle attribute "Kids" is zero';
$attrib = $sth2->{Kids};
@@ -1067,26 +1054,33 @@ is ($attrib, 0, $t);
#
$t='Database handle attribute "ActiveKids" is set properly';
-$attrib = $dbh->{ActiveKids};
+$attrib = $dbh3->{ActiveKids};
is ($attrib, 0, $t);
$t='Database handle attribute "ActiveKids" works';
-$sth2 = $dbh->prepare('SELECT 234');
+$sth2 = $dbh3->prepare('SELECT 234');
$sth2->execute();
-$attrib = $dbh->{ActiveKids};
+$attrib = $dbh3->{ActiveKids};
is ($attrib, 1, $t);
$t='Statement handle attribute "ActiveKids" is zero';
$attrib = $sth2->{ActiveKids};
is ($attrib, 0, $t);
+$sth2->finish();
#
# Test of the handle attribute "CachedKids"
#
$t='Database handle attribute "CachedKids" is set properly';
-$attrib = $dbh->{CachedKids};
-is (keys %$attrib, 2, $t);
+$attrib = $dbh3->{CachedKids};
+is (keys %$attrib, 0, $t);
+my $sth4 = $dbh3->prepare_cached('select 1');
+$attrib = $dbh3->{CachedKids};
+is (keys %$attrib, 1, $t);
+$sth4->finish();
+
+$dbh3->disconnect();
#
# Test of the handle attribute "Type"
@@ -1114,17 +1108,17 @@ is_deeply ($attrib, [], $t);
$t='Statement handle attribute "ChildHandles" is an empty list on creation';
{
- my $sth4 = $dbh4->prepare('SELECT 1');
- $attrib = $sth4->{ChildHandles};
+ my $sth5 = $dbh4->prepare('SELECT 1');
+ $attrib = $sth5->{ChildHandles};
is_deeply ($attrib, [], $t);
$t='Database handle attribute "ChildHandles" contains newly created statement handle';
$attrib = $dbh4->{ChildHandles};
- is_deeply ($attrib, [$sth4], $t);
+ is_deeply ($attrib, [$sth5], $t);
$sth4->finish();
-} ## sth4 now out of scope
+} ## sth5 now out of scope
$t='Database handle attribute "ChildHandles" has undef for destroyed statement handle';
$attrib = $dbh4->{ChildHandles};
@@ -1595,10 +1589,6 @@ SKIP: {
$t=qq{Ping fails after the child has exited ("AutoInactiveDestroy" = $destroy)};
is ( $dbh->ping(), 0, $t);
- $t='Failed ping returns a SQLSTATE code of 08000';
- my $state = $dbh->state();
- is ($state, '08000', $t);
-
$t=qq{pg_ping gives an error code of -2 after the child has exited ("AutoInactiveDestroy" = $destroy)};
is ( $dbh->pg_ping(), -2, $t);
ok ($dbh->disconnect(), 'Disconnect from database');
@@ -1667,10 +1657,6 @@ SKIP: {
$t=qq{Ping fails after the child has exited ("InactiveDestroy" = $destroy)};
is ( $dbh->ping(), 0, $t);
- $t='Failed ping returns a SQLSTATE code of 08000';
- my $state = $dbh->state();
- is ($state, '08000', $t);
-
$t=qq{pg_ping gives an error code of -2 after the child has exited ("InactiveDestroy" = $destroy)};
is ( $dbh->pg_ping(), -2,$t);
}
@@ -26,7 +26,7 @@ my $dbh = connect_database();
if (! $dbh) {
plan skip_all => 'Connection to database failed, cannot continue testing';
}
-plan tests => 538;
+plan tests => 562;
isnt ($dbh, undef, 'Connect to database for database handle method testing');
@@ -444,6 +444,10 @@ my %get_info = (
SQL_IDENTIFIER_QUOTE_CHAR => 29,
SQL_CATALOG_NAME_SEPARATOR => 41,
SQL_USER_NAME => 47,
+ # this also tests the dynamic attributes that run SQL
+ SQL_COLLATION_SEQ => 10004,
+ SQL_DATABASE_NAME => 16,
+ SQL_SERVER_NAME => 13,
);
for (keys %get_info) {
@@ -459,6 +463,11 @@ for (keys %get_info) {
is ($back, $forth, $t);
}
+# Make sure SQL_MAX_COLUMN_NAME_LEN looks normal
+$t='DB handle method "get_info" returns a valid looking SQL_MAX_COLUMN_NAME_LEN string}';
+my $namedatalen = $dbh->get_info('SQL_MAX_COLUMN_NAME_LEN');
+cmp_ok ($namedatalen, '>=', 63, $t);
+
# Make sure odbcversion looks normal
$t='DB handle method "get_info" returns a valid looking ODBCVERSION string}';
my $odbcversion = $dbh->get_info(18);
@@ -466,7 +475,7 @@ like ($odbcversion, qr{^([1-9]\d|\d[1-9])\.\d\d\.\d\d00$}, $t);
# Testing max connections is good as this info is dynamic
$t='DB handle method "get_info" returns a number for SQL_MAX_DRIVER_CONNECTIONS';
-my $maxcon = $dbh->get_info(0);
+my $maxcon = $dbh->get_info('SQL_MAX_DRIVER_CONNECTIONS');
like ($maxcon, qr{^\d+$}, $t);
$t='DB handle method "get_info" returns correct string for SQL_DATA_SOURCE_READ_ONLY when "on"';
@@ -483,11 +492,19 @@ is ($dbh->get_info(25), 'N', $t);
# Test of the "table_info" database handle method
#
-$t='DB handle method "table_info" works when called with undef arguments';
+$t='DB handle method "table_info" works when called with empty arguments';
$sth = $dbh->table_info('', '', 'dbd_pg_test', '');
my $number = $sth->rows();
ok ($number, $t);
+$t='DB handle method "table_info" works when called with \'%\' arguments';
+$sth = $dbh->table_info('%', '%', 'dbd_pg_test', '%');
+$number = $sth->rows();
+ok ($number, $t);
+
+$t=q{DB handle method "table_info" works when called with a 'TABLE' last argument};
+$sth = $dbh->table_info( '', '', '', q{'TABLE'});
+
# Check required minimum fields
$t='DB handle method "table_info" returns fields required by DBI';
$result = $sth->fetchall_arrayref({});
@@ -511,10 +528,15 @@ $sth = $dbh->table_info(undef,undef,undef,'TABLE,VIEW');
$number = $sth->rows();
cmp_ok ($number, '>', 1, $t);
-$t='DB handle method "table_info" returns correct number of rows when given an invalid type argument';
+$t=q{DB handle method "table_info" returns correct number of rows when given a 'TABLE,VIEW,SYSTEM TABLE,SYSTEM VIEW' type argument};
+$sth = $dbh->table_info(undef,undef,undef,'TABLE,VIEW,SYSTEM TABLE,SYSTEM VIEW');
+$number = $sth->rows();
+cmp_ok ($number, '>', 1, $t);
+
+$t='DB handle method "table_info" returns zero rows when given an invalid type argument';
$sth = $dbh->table_info(undef,undef,undef,'DUMMY');
$rows = $sth->rows();
-is ($rows, $number, $t);
+is ($rows, 0, $t);
$t=q{DB handle method "table_info" returns correct number of rows when given a 'VIEW' type argument};
$sth = $dbh->table_info(undef,undef,undef,'VIEW');
@@ -526,6 +548,30 @@ $sth = $dbh->table_info(undef,undef,undef,'TABLE');
$rows = $sth->rows();
cmp_ok ($rows, '<', $number, $t);
+$dbh->do('CREATE TEMP TABLE dbd_pg_local_temp (i INT)');
+
+$t=q{DB handle method "table_info" returns correct number of rows when given a 'LOCAL TEMPORARY' type argument};
+$sth = $dbh->table_info(undef,undef,undef,'LOCAL TEMPORARY');
+$rows = $sth->rows();
+cmp_ok ($rows, '<', $number, $t);
+cmp_ok ($rows, '>', 0, $t);
+
+$t=q{DB handle method "table_info" returns correct number of rows when given a 'MATERIALIZED VIEW' type argument};
+$sth = $dbh->table_info(undef,undef,undef,'MATERIALIZED VIEW');
+$rows = $sth->rows();
+is ($rows, 0, $t);
+
+SKIP: {
+ if ($pgversion < 90300) {
+ skip 'Postgres version 9.3 or better required to create materialized views', 1;
+ }
+ $dbh->do('CREATE MATERIALIZED VIEW dbd_pg_matview (a) AS SELECT count(*) FROM pg_class');
+ $t=q{DB handle method "table_info" returns correct number of rows when given a 'MATERIALIZED VIEW' type argument};
+ $sth = $dbh->table_info(undef,undef,undef,'MATERIALIZED VIEW');
+ $rows = $sth->rows();
+ is ($rows, 1, $t);
+}
+
# Test listing catalog names
$t='DB handle method "table_info" works when called with a catalog of %';
$sth = $dbh->table_info('%', '', '');
@@ -536,10 +582,35 @@ $t='DB handle method "table_info" works when called with a schema of %';
$sth = $dbh->table_info('', '%', '');
ok ($sth, $t);
-# Test listing table types
+{ # Test listing table types
+
+my @expected = ('LOCAL TEMPORARY',
+ 'SYSTEM TABLE',
+ 'SYSTEM VIEW',
+ 'MATERIALIZED VIEW',
+ 'SYSTEM MATERIALIZED VIEW',
+ 'TABLE',
+ 'VIEW',);
+
$t='DB handle method "table_info" works when called with a type of %';
$sth = $dbh->table_info('', '', '', '%');
-ok ($sth, $t);
+ok($sth, $t);
+
+$t='DB handle method "table_info" type list returns all expected types';
+my %advertised = map { $_->[0] => 1 } @{ $sth->fetchall_arrayref([3]) };
+is_deeply([sort keys %advertised], [sort @expected], $t);
+
+$t='DB handle method "table_info" object list returns no unadvertised types';
+$sth = $dbh->table_info('', '', '%');
+my %surprises = map { $_->[0] => 1 }
+ grep { ! $advertised{$_->[0]} }
+ @{ $sth->fetchall_arrayref([3]) };
+
+is_deeply([keys %surprises], [], $t)
+ or diag('Objects of unexpected type(s) found: '
+ . join(', ', sort keys %surprises));
+
+} # END test listing table types
#
# Test of the "column_info" database handle method
@@ -832,11 +903,9 @@ is ($sth, undef, $t);
## Create a pk table
-# The order of the tables returned by the OID query in foreign_key_info
-# seems to be influenced by schema creation order, so create the schemas
-# in the opposite order of the search_path, so we have at least a vague
-# chance of testing that we respect the search_path order. Also create
-# the tables in the opposite order, for good measure
+# Create identical tables and relations in multiple schemas, and in the
+# opposite order of the search_path, so we have at least a vague chance
+# of testing that we respect the search_path order.
$dbh->do("CREATE SCHEMA $schema3");
$dbh->do("CREATE SCHEMA $schema2");
$dbh->do("SET search_path = $schema2,$schema3");
@@ -1127,6 +1196,10 @@ $t='DB handle method "tables" works with a "pg_noprefix" attribute';
@result = $dbh->tables('', '', 'dbd_pg_test', '', {pg_noprefix => 1});
is ($result[0], 'dbd_pg_test', $t);
+$t='DB handle method "tables" works with type=\'%\'';
+@result = $dbh->tables('', '', 'dbd_pg_test', '%');
+like ($result[0], qr/dbd_pg_test/, $t);
+
#
# Test of the "type_info_all" database handle method
#
@@ -1241,6 +1314,24 @@ is ($dbh->quote('foobar'), q{'foobar'}, $t);
# Test various quote types
#
+## Invalid type arguments
+$t='DB handle method "quote" throws exception on non-reference type argument';
+eval { $dbh->quote('abc', 'def'); };
+like ($@, qr{hashref}, $t);
+
+$t='DB handle method "quote" throws exception on arrayref type argument';
+eval { $dbh->quote('abc', ['arraytest']); };
+like ($@, qr{hashref}, $t);
+
+SKIP: {
+ eval { require Test::Warn; };
+ if ($@) {
+ skip ('Need Test::Warn for some tests', 1);
+ }
+
+ $t='DB handle method "quote" allows an empty hashref';
+ Test::Warn::warning_like ( sub { $dbh->quote('abc', {}); }, qr/UNKNOWN/, $t);
+}
## Points
$t='DB handle method "quote" works with type PG_POINT';
@@ -1477,251 +1568,259 @@ $dbh->rollback();
SKIP: {
- eval {
- require File::Temp;
- };
- $@ and skip ('Must have File::Temp to test pg_lo_import* and pg_lo_export', 8);
-
- $t='DB handle method "pg_lo_import" works';
- my ($fh,$filename) = File::Temp::tmpnam();
- print {$fh} "abc\ndef";
- close $fh or warn 'Failed to close temporary file';
- $handle = $dbh->pg_lo_import($filename);
- my $objid = $handle;
- ok ($handle, $t);
-
- $t='DB handle method "pg_lo_import" inserts correct data';
- $SQL = "SELECT data FROM pg_largeobject where loid = $handle";
- $info = $dbh->selectall_arrayref($SQL)->[0][0];
- is_deeply ($info, "abc\ndef", $t);
- $dbh->commit();
+ my $super = is_super();
+
+ $super or skip ('Cannot run largeobject tests unless run as Postgres superuser', 38);
+
SKIP: {
- if ($pglibversion < 80400) {
- skip ('Cannot test pg_lo_import_with_oid unless compiled against 8.4 or better server', 5);
- }
- if ($pgversion < 80100) {
- skip ('Cannot test pg_lo_import_with_oid against old versions of Postgres', 5);
- }
- $t='DB handle method "pg_lo_import_with_oid" works with high number';
- my $highnumber = 345167;
- $dbh->pg_lo_unlink($highnumber);
+ eval {
+ require File::Temp;
+ };
+ $@ and skip ('Must have File::Temp to test pg_lo_import* and pg_lo_export', 8);
+
+ $t='DB handle method "pg_lo_import" works';
+ my ($fh,$filename) = File::Temp::tmpnam();
+ print {$fh} "abc\ndef";
+ close $fh or warn 'Failed to close temporary file';
+ $handle = $dbh->pg_lo_import($filename);
+ my $objid = $handle;
+ ok ($handle, $t);
+
+ $t='DB handle method "pg_lo_import" inserts correct data';
+ $SQL = "SELECT data FROM pg_largeobject where loid = $handle";
+ $info = $dbh->selectall_arrayref($SQL)->[0][0];
+ is_deeply ($info, "abc\ndef", $t);
$dbh->commit();
- my $thandle;
- SKIP: {
-
- skip ('Known bug: pg_log_import_with_oid throws an error. See RT #90448', 3);
- $thandle = $dbh->pg_lo_import_with_oid($filename, $highnumber);
- is ($thandle, $highnumber, $t);
+ SKIP: {
+ if ($pglibversion < 80400) {
+ skip ('Cannot test pg_lo_import_with_oid unless compiled against 8.4 or better server', 5);
+ }
+ if ($pgversion < 80100) {
+ skip ('Cannot test pg_lo_import_with_oid against old versions of Postgres', 5);
+ }
+
+ $t='DB handle method "pg_lo_import_with_oid" works with high number';
+ my $highnumber = 345167;
+ $dbh->pg_lo_unlink($highnumber);
+ $dbh->commit();
+ my $thandle;
+ SKIP: {
+
+ skip ('Known bug: pg_log_import_with_oid throws an error. See RT #90448', 3);
+
+ $thandle = $dbh->pg_lo_import_with_oid($filename, $highnumber);
+ is ($thandle, $highnumber, $t);
+ ok ($thandle, $t);
+
+ $t='DB handle method "pg_lo_import_with_oid" inserts correct data';
+ $SQL = "SELECT data FROM pg_largeobject where loid = $thandle";
+ $info = $dbh->selectall_arrayref($SQL)->[0][0];
+ is_deeply ($info, "abc\ndef", $t);
+ }
+
+ $t='DB handle method "pg_lo_import_with_oid" fails when given already used number';
+ eval {
+ $thandle = $dbh->pg_lo_import_with_oid($filename, $objid);
+ };
+ is ($thandle, undef, $t);
+ $dbh->rollback();
+
+ $t='DB handle method "pg_lo_import_with_oid" falls back to lo_import when number is 0';
+ eval {
+ $thandle = $dbh->pg_lo_import_with_oid($filename, 0);
+ };
ok ($thandle, $t);
-
- $t='DB handle method "pg_lo_import_with_oid" inserts correct data';
- $SQL = "SELECT data FROM pg_largeobject where loid = $thandle";
- $info = $dbh->selectall_arrayref($SQL)->[0][0];
- is_deeply ($info, "abc\ndef", $t);
+ $dbh->rollback();
}
- $t='DB handle method "pg_lo_import_with_oid" fails when given already used number';
- eval {
- $thandle = $dbh->pg_lo_import_with_oid($filename, $objid);
- };
- is ($thandle, undef, $t);
- $dbh->rollback();
-
- $t='DB handle method "pg_lo_import_with_oid" falls back to lo_import when number is 0';
- eval {
- $thandle = $dbh->pg_lo_import_with_oid($filename, 0);
- };
- ok ($thandle, $t);
- $dbh->rollback();
+ unlink $filename;
+
+ $t='DB handle method "pg_lo_open" works after "pg_lo_insert"';
+ $handle = $dbh->pg_lo_open($handle, $R);
+ like ($handle, qr/^\d+$/o, $t);
+
+ $t='DB handle method "pg_lo_read" returns correct data after "pg_lo_import"';
+ $data = '';
+ $result = $dbh->pg_lo_read($handle, $data, 100);
+ is ($result, 7, $t);
+ is ($data, "abc\ndef", $t);
+
+ $t='DB handle method "pg_lo_export" works';
+ ($fh,$filename) = File::Temp::tmpnam();
+ $result = $dbh->pg_lo_export($objid, $filename);
+ ok (-e $filename, $t);
+ seek($fh,0,1);
+ seek($fh,0,0);
+ $result = read $fh, $data, 10;
+ is ($result, 7, $t);
+ is ($data, "abc\ndef", $t);
+ close $fh or warn 'Could not close tempfile';
+ unlink $filename;
+ $dbh->pg_lo_unlink($objid);
}
- unlink $filename;
-
- $t='DB handle method "pg_lo_open" works after "pg_lo_insert"';
- $handle = $dbh->pg_lo_open($handle, $R);
- like ($handle, qr/^\d+$/o, $t);
-
- $t='DB handle method "pg_lo_read" returns correct data after "pg_lo_import"';
- $data = '';
- $result = $dbh->pg_lo_read($handle, $data, 100);
- is ($result, 7, $t);
- is ($data, "abc\ndef", $t);
-
- $t='DB handle method "pg_lo_export" works';
- ($fh,$filename) = File::Temp::tmpnam();
- $result = $dbh->pg_lo_export($objid, $filename);
- ok (-e $filename, $t);
- seek($fh,0,1);
- seek($fh,0,0);
- $result = read $fh, $data, 10;
- is ($result, 7, $t);
- is ($data, "abc\ndef", $t);
- close $fh or warn 'Could not close tempfile';
- unlink $filename;
- $dbh->pg_lo_unlink($objid);
-}
-
-## Same pg_lo_* tests, but with AutoCommit on
+ ## Same pg_lo_* tests, but with AutoCommit on
-$dbh->{AutoCommit}=1;
-
-$t='DB handle method "pg_lo_creat" fails when AutoCommit on';
-eval {
- $dbh->pg_lo_creat($W);
-};
-like ($@, qr{pg_lo_creat when AutoCommit is on}, $t);
-
-$t='DB handle method "pg_lo_open" fails with AutoCommit on';
-eval {
- $dbh->pg_lo_open($object, $W);
-};
-like ($@, qr{pg_lo_open when AutoCommit is on}, $t);
-
-$t='DB handle method "pg_lo_read" fails with AutoCommit on';
-eval {
- $dbh->pg_lo_read($object, $data, 0);
-};
-like ($@, qr{pg_lo_read when AutoCommit is on}, $t);
+ $dbh->{AutoCommit}=1;
-$t='DB handle method "pg_lo_lseek" fails with AutoCommit on';
-eval {
- $dbh->pg_lo_lseek($handle, 0, 0);
-};
-like ($@, qr{pg_lo_lseek when AutoCommit is on}, $t);
+ $t='DB handle method "pg_lo_creat" fails when AutoCommit on';
+ eval {
+ $dbh->pg_lo_creat($W);
+ };
+ like ($@, qr{pg_lo_creat when AutoCommit is on}, $t);
-$t='DB handle method "pg_lo_write" fails with AutoCommit on';
-$buf = 'tangelo mulberry passionfruit raspberry plantain' x 500;
-eval {
- $dbh->pg_lo_write($handle, $buf, length($buf));
-};
-like ($@, qr{pg_lo_write when AutoCommit is on}, $t);
+ $t='DB handle method "pg_lo_open" fails with AutoCommit on';
+ eval {
+ $dbh->pg_lo_open($object, $W);
+ };
+ like ($@, qr{pg_lo_open when AutoCommit is on}, $t);
-$t='DB handle method "pg_lo_close" fails with AutoCommit on';
-eval {
- $dbh->pg_lo_close($handle);
-};
-like ($@, qr{pg_lo_close when AutoCommit is on}, $t);
+ $t='DB handle method "pg_lo_read" fails with AutoCommit on';
+ eval {
+ $dbh->pg_lo_read($object, $data, 0);
+ };
+ like ($@, qr{pg_lo_read when AutoCommit is on}, $t);
-$t='DB handle method "pg_lo_tell" fails with AutoCommit on';
-eval {
- $dbh->pg_lo_tell($handle);
-};
-like ($@, qr{pg_lo_tell when AutoCommit is on}, $t);
+ $t='DB handle method "pg_lo_lseek" fails with AutoCommit on';
+ eval {
+ $dbh->pg_lo_lseek($handle, 0, 0);
+ };
+ like ($@, qr{pg_lo_lseek when AutoCommit is on}, $t);
-$t='DB handle method "pg_lo_unlink" fails with AutoCommit on';
-eval {
- $dbh->pg_lo_unlink($object);
-};
-like ($@, qr{pg_lo_unlink when AutoCommit is on}, $t);
+ $t='DB handle method "pg_lo_write" fails with AutoCommit on';
+ $buf = 'tangelo mulberry passionfruit raspberry plantain' x 500;
+ eval {
+ $dbh->pg_lo_write($handle, $buf, length($buf));
+ };
+ like ($@, qr{pg_lo_write when AutoCommit is on}, $t);
+ $t='DB handle method "pg_lo_close" fails with AutoCommit on';
+ eval {
+ $dbh->pg_lo_close($handle);
+ };
+ like ($@, qr{pg_lo_close when AutoCommit is on}, $t);
-SKIP: {
+ $t='DB handle method "pg_lo_tell" fails with AutoCommit on';
+ eval {
+ $dbh->pg_lo_tell($handle);
+ };
+ like ($@, qr{pg_lo_tell when AutoCommit is on}, $t);
+ $t='DB handle method "pg_lo_unlink" fails with AutoCommit on';
eval {
- require File::Temp;
+ $dbh->pg_lo_unlink($object);
};
- $@ and skip ('Must have File::Temp to test pg_lo_import and pg_lo_export', 5);
-
- $t='DB handle method "pg_lo_import" works (AutoCommit on)';
- my ($fh,$filename) = File::Temp::tmpnam();
- print {$fh} "abc\ndef";
- close $fh or warn 'Failed to close temporary file';
- $handle = $dbh->pg_lo_import($filename);
- ok ($handle, $t);
-
- $t='DB handle method "pg_lo_import" inserts correct data (AutoCommit on, begin_work not called)';
- $SQL = 'SELECT data FROM pg_largeobject where loid = ?';
- $sth = $dbh->prepare($SQL);
- $sth->execute($handle);
- $info = $sth->fetchall_arrayref()->[0][0];
- is_deeply ($info, "abc\ndef", $t);
-
- # cleanup last lo
- $dbh->{AutoCommit} = 0;
- $dbh->pg_lo_unlink($handle);
- $dbh->{AutoCommit} = 1;
+ like ($@, qr{pg_lo_unlink when AutoCommit is on}, $t);
- $t='DB handle method "pg_lo_import" works (AutoCommit on, begin_work called, no command)';
- $dbh->begin_work();
- $handle = $dbh->pg_lo_import($filename);
- ok ($handle, $t);
- $sth->execute($handle);
- $info = $sth->fetchall_arrayref()->[0][0];
- is_deeply ($info, "abc\ndef", $t);
- $dbh->rollback();
- $t='DB handle method "pg_lo_import" works (AutoCommit on, begin_work called, no command, rollback)';
- $dbh->begin_work();
- $handle = $dbh->pg_lo_import($filename);
- ok ($handle, $t);
- $dbh->rollback();
- $sth->execute($handle);
- $info = $sth->fetchall_arrayref()->[0][0];
- is_deeply ($info, undef, $t);
+ SKIP: {
- $t='DB handle method "pg_lo_import" works (AutoCommit on, begin_work called, second command)';
- $dbh->begin_work();
- $dbh->do('SELECT 123');
- $handle = $dbh->pg_lo_import($filename);
- ok ($handle, $t);
- $sth->execute($handle);
- $info = $sth->fetchall_arrayref()->[0][0];
- is_deeply ($info, "abc\ndef", $t);
- $dbh->rollback();
+ eval {
+ require File::Temp;
+ };
+ $@ and skip ('Must have File::Temp to test pg_lo_import and pg_lo_export', 5);
+
+ $t='DB handle method "pg_lo_import" works (AutoCommit on)';
+ my ($fh,$filename) = File::Temp::tmpnam();
+ print {$fh} "abc\ndef";
+ close $fh or warn 'Failed to close temporary file';
+ $handle = $dbh->pg_lo_import($filename);
+ ok ($handle, $t);
+
+ $t='DB handle method "pg_lo_import" inserts correct data (AutoCommit on, begin_work not called)';
+ $SQL = 'SELECT data FROM pg_largeobject where loid = ?';
+ $sth = $dbh->prepare($SQL);
+ $sth->execute($handle);
+ $info = $sth->fetchall_arrayref()->[0][0];
+ is_deeply ($info, "abc\ndef", $t);
+
+ # cleanup last lo
+ $dbh->{AutoCommit} = 0;
+ $dbh->pg_lo_unlink($handle);
+ $dbh->{AutoCommit} = 1;
+
+ $t='DB handle method "pg_lo_import" works (AutoCommit on, begin_work called, no command)';
+ $dbh->begin_work();
+ $handle = $dbh->pg_lo_import($filename);
+ ok ($handle, $t);
+ $sth->execute($handle);
+ $info = $sth->fetchall_arrayref()->[0][0];
+ is_deeply ($info, "abc\ndef", $t);
+ $dbh->rollback();
- $t='DB handle method "pg_lo_import" works (AutoCommit on, begin_work called, second command, rollback)';
- $dbh->begin_work();
- $dbh->do('SELECT 123');
- $handle = $dbh->pg_lo_import($filename);
- ok ($handle, $t);
- $dbh->rollback();
- $sth->execute($handle);
- $info = $sth->fetchall_arrayref()->[0][0];
- is_deeply ($info, undef, $t);
+ $t='DB handle method "pg_lo_import" works (AutoCommit on, begin_work called, no command, rollback)';
+ $dbh->begin_work();
+ $handle = $dbh->pg_lo_import($filename);
+ ok ($handle, $t);
+ $dbh->rollback();
+ $sth->execute($handle);
+ $info = $sth->fetchall_arrayref()->[0][0];
+ is_deeply ($info, undef, $t);
+
+ $t='DB handle method "pg_lo_import" works (AutoCommit on, begin_work called, second command)';
+ $dbh->begin_work();
+ $dbh->do('SELECT 123');
+ $handle = $dbh->pg_lo_import($filename);
+ ok ($handle, $t);
+ $sth->execute($handle);
+ $info = $sth->fetchall_arrayref()->[0][0];
+ is_deeply ($info, "abc\ndef", $t);
+ $dbh->rollback();
- $t='DB handle method "pg_lo_import" works (AutoCommit not on, no command)';
- $dbh->{AutoCommit} = 0;
- $dbh->commit();
- $handle = $dbh->pg_lo_import($filename);
- ok ($handle, $t);
- $sth->execute($handle);
- $info = $sth->fetchall_arrayref()->[0][0];
- is_deeply ($info, "abc\ndef", $t);
+ $t='DB handle method "pg_lo_import" works (AutoCommit on, begin_work called, second command, rollback)';
+ $dbh->begin_work();
+ $dbh->do('SELECT 123');
+ $handle = $dbh->pg_lo_import($filename);
+ ok ($handle, $t);
+ $dbh->rollback();
+ $sth->execute($handle);
+ $info = $sth->fetchall_arrayref()->[0][0];
+ is_deeply ($info, undef, $t);
- $t='DB handle method "pg_lo_import" works (AutoCommit not on, second command)';
- $dbh->rollback();
- $dbh->do('SELECT 123');
- $handle = $dbh->pg_lo_import($filename);
- ok ($handle, $t);
- $sth->execute($handle);
- $info = $sth->fetchall_arrayref()->[0][0];
- is_deeply ($info, "abc\ndef", $t);
-
- unlink $filename;
- $dbh->{AutoCommit} = 1;
-
- my $objid = $handle;
- $t='DB handle method "pg_lo_export" works (AutoCommit on)';
- ($fh,$filename) = File::Temp::tmpnam();
- $result = $dbh->pg_lo_export($objid, $filename);
- ok (-e $filename, $t);
- seek($fh,0,1);
- seek($fh,0,0);
- $result = read $fh, $data, 10;
- is ($result, 7, $t);
- is ($data, "abc\ndef", $t);
- close $fh or warn 'Could not close tempfile';
- unlink $filename;
-
- # cleanup last lo
+ $t='DB handle method "pg_lo_import" works (AutoCommit not on, no command)';
+ $dbh->{AutoCommit} = 0;
+ $dbh->commit();
+ $handle = $dbh->pg_lo_import($filename);
+ ok ($handle, $t);
+ $sth->execute($handle);
+ $info = $sth->fetchall_arrayref()->[0][0];
+ is_deeply ($info, "abc\ndef", $t);
+
+ $t='DB handle method "pg_lo_import" works (AutoCommit not on, second command)';
+ $dbh->rollback();
+ $dbh->do('SELECT 123');
+ $handle = $dbh->pg_lo_import($filename);
+ ok ($handle, $t);
+ $sth->execute($handle);
+ $info = $sth->fetchall_arrayref()->[0][0];
+ is_deeply ($info, "abc\ndef", $t);
+
+ unlink $filename;
+ $dbh->{AutoCommit} = 1;
+
+ my $objid = $handle;
+ $t='DB handle method "pg_lo_export" works (AutoCommit on)';
+ ($fh,$filename) = File::Temp::tmpnam();
+ $result = $dbh->pg_lo_export($objid, $filename);
+ ok (-e $filename, $t);
+ seek($fh,0,1);
+ seek($fh,0,0);
+ $result = read $fh, $data, 10;
+ is ($result, 7, $t);
+ is ($data, "abc\ndef", $t);
+ close $fh or warn 'Could not close tempfile';
+ unlink $filename;
+
+ # cleanup last lo
+ $dbh->{AutoCommit} = 0;
+ $dbh->pg_lo_unlink($handle);
+ $dbh->{AutoCommit} = 1;
+ }
$dbh->{AutoCommit} = 0;
- $dbh->pg_lo_unlink($handle);
- $dbh->{AutoCommit} = 1;
}
-$dbh->{AutoCommit} = 0;
#
# Test of the "pg_notifies" database handle method
@@ -1812,85 +1911,74 @@ is ($@, q{}, $t);
$dbh2->disconnect();
#
-# Test of the "ping" database handle method
+# Test of the "ping" and "pg_ping" database handle methods
#
-$t='DB handle method "ping" returns 1 on an idle connection';
-is ($dbh->ping(), 1, $t);
-
-$t='DB handle method "ping" returns 3 for a good connection inside a transaction';
-$dbh->do('SELECT 123');
-$result = 3;
-is ($result, $dbh->ping(), $t);
-
-$t='DB handle method "ping" returns 1 on an idle connection';
-$dbh->commit();
-is ($dbh->ping(), 1, $t);
-
-my $mtvar; ## This is an implicit test of getline: please leave this var undefined
-
-$t='DB handle method "ping" returns 2 when in COPY IN state';
-$dbh->do('COPY dbd_pg_test(id,pname) TO STDOUT');
-{
- local $SIG{__WARN__} = sub {};
- $dbh->pg_getline($mtvar,100);
-}
-is ($dbh->ping(), 2, $t);
-1 while $dbh->pg_getline($mtvar,1000);
-
-$t='DB handle method "ping" returns 3 for a good connection inside a transaction';
-$dbh->do('SELECT 123');
-is ($dbh->ping(), 3, $t);
+my $mtvar; ## This is an implicit test of getcopydata: please leave this var undefined
-$t='DB handle method "ping" returns a 4 when inside a failed transaction';
-eval {
- $dbh->do('DBD::Pg creating an invalid command for testing');
-};
-is ($dbh->ping(), 4, $t);
-
-$t='DB handle method "ping" fails (returns 0) on a disconnected handle';
-$dbh->disconnect();
-is ($dbh->ping(), 0, $t);
+for my $type (qw/ ping pg_ping /) {
-$t='Able to reconnect to the database after disconnect';
-$dbh = connect_database({nosetup => 1});
-isnt ($dbh, undef, $t);
-
-#
-# Test of the "pg_ping" database handle method
-#
+ $t=qq{DB handle method "$type" returns 1 on an idle connection};
+ $dbh->commit();
+ is ($dbh->$type(), 1, $t);
-$t='DB handle method "pg_ping" returns 1 on an idle connection';
-is ($dbh->pg_ping(), 1, $t);
+ $t=qq{DB handle method "$type" returns 2 when in COPY IN state};
+ $dbh->do('COPY dbd_pg_test(id,pname) TO STDOUT');
+ $dbh->pg_getcopydata($mtvar);
+ is ($dbh->$type(), 2, $t);
+ ## the ping messes up the copy state, so all we can do is rollback
+ $dbh->rollback();
-$t='DB handle method "pg_ping" returns 3 for a good connection inside a transaction';
-$dbh->do('SELECT 123');
-is ($dbh->pg_ping(), 3, $t);
+ $t=qq{DB handle method "$type" returns 2 when in COPY IN state};
+ $dbh->do('COPY dbd_pg_test(id,pname) FROM STDIN');
+ $dbh->pg_putcopydata("123\tfoobar\n");
+ is ($dbh->$type(), 2, $t);
+ $dbh->rollback();
-$t='DB handle method "pg_ping" returns 1 on an idle connection';
-$dbh->commit();
-is ($dbh->pg_ping(), 1, $t);
+ $t=qq{DB handle method "$type" returns 3 for a good connection inside a transaction};
+ $dbh->do('SELECT 123');
+ is ($dbh->$type(), 3, $t);
-$t='DB handle method "pg_ping" returns 2 when in COPY IN state';
-$dbh->do('COPY dbd_pg_test(id,pname) TO STDOUT');
-$dbh->pg_getline($mtvar,100);
-is ($dbh->pg_ping(), 2, $t);
+ $t=qq{DB handle method "$type" returns a 4 when inside a failed transaction};
+ eval {
+ $dbh->do('DBD::Pg creating an invalid command for testing');
+ };
+ is ($dbh->$type(), 4, $t);
+ $dbh->rollback();
-$t='DB handle method "pg_ping" returns 2 immediately after COPY IN state';
-1 while $dbh->pg_getline($mtvar,1000);
-is ($dbh->pg_ping(), 2, $t);
+ my $val = $type eq 'ping' ? 0 : -1;
+ $t=qq{DB handle method "type" fails (returns $val) on a disconnected handle};
+ $dbh->disconnect();
+ is ($dbh->$type(), $val, $t);
+
+ $t='Able to reconnect to the database after disconnect';
+ $dbh = connect_database({nosetup => 1});
+ isnt ($dbh, undef, $t);
+
+ $val = $type eq 'ping' ? 0 : -3;
+ $t=qq{DB handle method "$type" returns $val after a lost network connection (outside transaction)};
+ socket_fail($dbh);
+ is ($dbh->$type(), $val, $t);
+
+ ## Reconnect, and try the same thing but inside a transaction
+ $val = $type eq 'ping' ? 0 : -3;
+ $t=qq{DB handle method "$type" returns $val after a lost network connection (inside transaction)};
+ $dbh = connect_database({nosetup => 1});
+ $dbh->do(q{SELECT 'DBD::Pg testing'});
+ socket_fail($dbh);
+ is ($dbh->$type(), $val, $t);
+
+ $type eq 'ping' and $dbh = connect_database({nosetup => 1});
+}
-$t='DB handle method "pg_ping" returns 3 for a good connection inside a transaction';
-$dbh->do('SELECT 123');
-is ($dbh->pg_ping(), 3, $t);
+exit;
-$t='DB handle method "pg_ping" returns a 4 when inside a failed transaction';
-eval {
- $dbh->do('DBD::Pg creating an invalid command for testing');
-};
-is ($dbh->pg_ping(), 4, $t);
+sub socket_fail {
+ my $ldbh = shift;
+ $ldbh->{InactiveDestroy} = 1;
+ my $fd = $ldbh->{pg_socket} or die 'Could not determine socket';
+ open(DBH_PG_FH, '<&='.$fd) or die "Could not open socket: $!"; ## no critic
+ close DBH_PG_FH or die "Could not close socket: $!";
+ return;
+}
-$t='DB handle method "pg_ping" fails (returns 0) on a disconnected handle';
-cleanup_database($dbh,'test');
-$dbh->disconnect();
-is ($dbh->pg_ping(), -1, $t);
@@ -32,8 +32,6 @@ isnt ($dbh, undef, 'Connect to database for async testing');
my ($t,$sth,$res);
my $pgversion = $dbh->{pg_server_version};
-my $table = 'dbd_pg_test1';
-
## First, test out do() in all its variants
@@ -541,12 +541,6 @@ SKIP: {
$t='Quoted array of strings should be UTF-8';
ok (Encode::is_utf8( $quoted ), $t);
- ## Workaround for client encodings such as SJIS
- my $old_encoding = $dbh->selectall_arrayref('SHOW client_encoding')->[0][0];
- if ($old_encoding ne 'UTF8') {
- $dbh->do(q{SET NAMES 'UTF8'});
- }
-
$t='Inserting utf-8 into an array via quoted do() works';
$dbh->do('DELETE FROM dbd_pg_test');
$SQL = qq{INSERT INTO dbd_pg_test (id, testarray, val) VALUES (1, $quoted, 'one')};
@@ -17,7 +17,7 @@ my $dbh = connect_database();
if (! $dbh) {
plan skip_all => 'Connection to database failed, cannot continue testing';
}
-plan tests => 251;
+plan tests => 256;
my $t='Connect to database for placeholder testing';
isnt ($dbh, undef, $t);
@@ -169,12 +169,6 @@ is ($count, 1, $t);
$sth->finish();
-## Force client encoding, as we cannot use backslashes in client-only encodings
-my $old_encoding = $dbh->selectall_arrayref('SHOW client_encoding')->[0][0];
-if ($old_encoding ne 'UTF8') {
- $dbh->do(q{SET NAMES 'UTF8'});
-}
-
$t='Prepare with backslashes inside quotes works';
$SQL = q{SELECT setting FROM pg_settings WHERE name = 'backslash_quote'};
$count = $dbh->selectall_arrayref($SQL)->[0];
@@ -414,7 +408,7 @@ for my $line (split /\n\n+/ => $testdata) {
$dbh->do('DELETE FROM dbd_pg_test_geom');
eval { $qresult = $dbh->quote($input, {pg_type => $typemap{$type}}); };
if ($@) {
- if ($quoted !~ /ERROR: (.+)/) {
+ if ($quoted !~ /ERROR: (.+)/) { ## no critic
fail ("$t error: $@");
}
else {
@@ -428,7 +422,7 @@ for my $line (split /\n\n+/ => $testdata) {
eval { $dbh->do("EXECUTE geotest('$input')"); };
if ($@) {
- if ($rows !~ /ERROR: (.+)/) {
+ if ($rows !~ /ERROR: .+/) {
fail ("$t error: $@");
}
else {
@@ -440,7 +434,7 @@ for my $line (split /\n\n+/ => $testdata) {
eval { $sth->execute($input); };
if ($@) {
- if ($rows !~ /ERROR: (.+)/) {
+ if ($rows !~ /ERROR: .+/) {
fail ($t);
}
else {
@@ -661,13 +655,23 @@ for my $char (qw{0 9 A Z a z}) { ## six letters
is ($@, q{}, $t);
}
-for my $ident (qq{\x{5317}}, qq{abc\x{5317}}, qq{_cde\x{5317}}) { ## hi-bit chars
- eval {
- $sth = $dbh->prepare(qq{SELECT \$$ident\$ 123 \$$ident\$});
- $sth->execute();
- $sth->finish();
- };
- is ($@, q{}, $t);
+SKIP: {
+ my $server_encoding = $dbh->selectrow_array('SHOW server_encoding');
+ my $client_encoding = $dbh->selectrow_array('SHOW client_encoding');
+ skip "Cannot test non-ascii dollar quotes with server_encoding='$server_encoding' (need UTF8 or SQL_ASCII)", 3,
+ unless $server_encoding =~ /\A(?:UTF8|SQL_ASCII)\z/;
+
+ skip 'Cannot test non-ascii dollar quotes unless client_encoding is UTF8', 3
+ if $client_encoding ne 'UTF8';
+
+ for my $ident (qq{\x{5317}}, qq{abc\x{5317}}, qq{_cde\x{5317}}) { ## hi-bit chars
+ eval {
+ $sth = $dbh->prepare(qq{SELECT \$$ident\$ 123 \$$ident\$});
+ $sth->execute();
+ $sth->finish();
+ };
+ is ($@, q{}, $t);
+ }
}
}
@@ -841,10 +845,68 @@ while (my ($name,$res) = each %booltest) {
}
}
+## Test of placeholder escaping. Enabled by default, so let's jump right in
+$t = q{Basic placeholder escaping works via backslash-question mark for \?};
+
+## But first, we need some operators
+$dbh->do('create operator ? (leftarg=int,rightarg=int,procedure=int4eq)');
+$dbh->commit();
+$dbh->do('create operator ?? (leftarg=text,rightarg=text,procedure=texteq)');
+$dbh->commit();
+
+$SQL = qq{SELECT count(*) FROM dbd_pg_test WHERE id \\? ?}; ## no critic
+$sth = $dbh->prepare($SQL);
+eval {
+ $count = $sth->execute(123);
+};
+is($@, '', $t);
+$sth->finish();
+
+$t = q{Basic placeholder escaping works via backslash-question mark for \?\?};
+$SQL = qq{SELECT count(*) FROM dbd_pg_test WHERE pname \\?\\? ?}; ## no critic
+$sth = $dbh->prepare($SQL);
+eval {
+ $count = $sth->execute('foobar');
+};
+is($@, '', $t);
+$sth->finish();
+
+## This is an emergency hatch only. Hopefully will never be used in the wild!
+$dbh->{pg_placeholder_escaped} = 0;
+$t = q{Basic placeholder escaping fails when pg_placeholder_escaped is set to false};
+$SQL = qq{SELECT count(*) FROM dbd_pg_test WHERE pname \\?\\? ?}; ## no critic
+$sth = $dbh->prepare($SQL);
+eval {
+ $count = $sth->execute('foobar');
+};
+like($@, qr{execute}, $t);
+$sth->finish();
+
+## The space before the colon is significant here
+$SQL = qq{SELECT testarray [1 :5] FROM dbd_pg_test WHERE pname = :foo};
+$sth = $dbh->prepare($SQL);
+eval {
+ $sth->bind_param(':foo', 'abc');
+ $count = $sth->execute();
+};
+like($@, qr{execute}, $t);
+$sth->finish();
+
+$t = q{Placeholder escaping works for colons};
+$dbh->{pg_placeholder_escaped} = 1;
+$SQL = qq{SELECT testarray [1 \\:5] FROM dbd_pg_test WHERE pname = :foo};
+$sth = $dbh->prepare($SQL);
+eval {
+ $sth->bind_param(':foo', 'abc');
+ $count = $sth->execute();
+};
+is($@, '', $t);
+$sth->finish();
+
+
## Begin custom type testing
$dbh->rollback();
cleanup_database($dbh,'test');
$dbh->disconnect();
-
@@ -9,7 +9,7 @@ use strict;
use warnings;
use utf8;
use charnames ':full';
-use Encode;
+use Encode qw(encode_utf8);
use Test::More;
use lib 't','.';
require 'dbdpg_test_setup.pl';
@@ -23,59 +23,155 @@ if (! $dbh) {
isnt ($dbh, undef, 'Connect to database for unicode testing');
-my $pgversion = $dbh->{pg_server_version};
-
-my $t;
-
-my $name = "\N{LATIN CAPITAL LETTER E WITH ACUTE}milie du Ch\N{LATIN SMALL LETTER A WITH CIRCUMFLEX}telet";
-
-my $SQL = 'SELECT ?::text';
-my $sth = $dbh->prepare($SQL);
-$sth->execute($name);
-my $result = $sth->fetchall_arrayref->[0][0];
-$t = 'Fetching UTF-8 string from the database returns proper string';
-is ($result, $name, $t);
-$t = 'Fetching UTF-8 string from the database returns string with UTF-8 flag on';
-ok (utf8::is_utf8($result), $t);
-
-$dbh->{pg_enable_utf8} = 0;
-$sth->execute($name);
-$result = $sth->fetchall_arrayref->[0][0];
-$t = 'Fetching UTF-8 string from the database returns proper string (pg_enable_utf8=0)';
-my $noutfname = $name;
-Encode::_utf8_off($noutfname);
-is ($result, $noutfname, $t);
-$t = 'Fetching UTF-8 string from the database returns string with UTF-8 flag off (pg_enable_utf8=0)';
-ok (!utf8::is_utf8($result), $t);
-
-$t = 'Generated string is not utf8';
-$name = 'Ada Lovelace';
-utf8::encode($name);
-ok (!utf8::is_utf8($name), $t);
-
-$dbh->{pg_enable_utf8} = -1;
-$SQL = 'SELECT ?::text';
-$sth = $dbh->prepare($SQL);
-$sth->execute($name);
-$result = $sth->fetchall_arrayref->[0][0];
-$t = 'Fetching ASCII string from the database returns proper string';
-is ($result, $name, $t);
-$t = 'Fetching ASCII string from the database returns string with UTF-8 flag on';
-ok (utf8::is_utf8($result), $t);
-
-$dbh->{pg_enable_utf8} = 0;
-$sth->execute($name);
-$result = $sth->fetchall_arrayref->[0][0];
-$t = 'Fetching ASCII string from the database returns proper string (pg_enable_utf8=0)';
-is ($result, $name, $t);
-$t = 'Fetching ASCII string from the database returns string with UTF-8 flag off (pg_enable_utf8=0)';
-ok (!utf8::is_utf8($result), $t);
-
-$dbh->{pg_enable_utf8} = 1;
-my $before = "\N{WHITE SMILING FACE}";
-my ($after) = $dbh->selectrow_array('SELECT ?::text', {}, $before);
-is($after, $before, 'string is the same after round trip');
-ok(utf8::is_utf8($after), 'string has utf8 flag set');
+
+my @tests;
+
+my $server_encoding = $dbh->selectrow_array('SHOW server_encoding');
+my $client_encoding = $dbh->selectrow_array('SHOW client_encoding');
+
+# Beware, characters used for testing need to be known to Unicode version 4.0.0,
+# which is what perl 5.8.1 shipped with.
+foreach (
+ [ascii => 'Ada Lovelace'],
+ ['latin 1 range' => "\N{LATIN CAPITAL LETTER E WITH ACUTE}milie du Ch\N{LATIN SMALL LETTER A WITH CIRCUMFLEX}telet"],
+ # I'm finding it awkward to continue the theme of female mathematicians
+ ['base plane' => "Interrobang\N{INTERROBANG}"],
+ ['astral plane' => "\N{MUSICAL SYMBOL CRESCENDO}"],
+ ) {
+ my ($range, $text) = @$_;
+ my $name_d = my $name_u = $text;
+ utf8::upgrade($name_u);
+ # Before 5.12.0 the text to the left of => gets to be SvUTF8() under use utf8;
+ # even if it's plain ASCII. This would confuse what we test for below.
+ push @tests, (
+ [upgraded => $range => 'text' => $name_u],
+ [upgraded => $range => 'text[]' => [$name_u]],
+ );
+ if (utf8::downgrade($name_d, 1)) {
+ push @tests, (
+ [downgraded => $range => 'text' => $name_d],
+ [downgraded => $range => 'text[]' => [$name_d]],
+ [mixed => $range => 'text[]' => [$name_d,$name_u]],
+ );
+ }
+}
+
+my %ranges = (
+ UTF8 => qr/.*/,
+ LATIN1 => qr/\A(?:ascii|latin 1 range)\z/,
+);
+
+foreach (@tests) {
+ my ($state, $range, $type, $value) = @$_;
+ SKIP:
+ foreach my $test (
+ {
+ qtype => 'placeholder',
+ sql => "SELECT ?::$type",
+ args => [$value],
+ },
+ (($type eq 'text') ? (
+ {
+ qtype => 'interpolated',
+ sql => "SELECT '$value'::$type",
+ },
+ # Test that what we send is the same as the database's idea of characters:
+ {
+ qtype => 'placeholder length',
+ sql => "SELECT length(?::$type)",
+ args => [$value],
+ want => length($value),
+ },
+ {
+ qtype => 'interpolated length',
+ sql => "SELECT length('$value'::$type)",
+ want => length($value),
+ },
+ ):()),
+ ) {
+ skip "Can't do $range tests with server_encoding='$server_encoding'", 1
+ if $range !~ ($ranges{$server_encoding} || qr/\A(?:ascii)\z/);
+
+ skip 'Cannot perform range tests if client_encoding is not UTF8', 1
+ if $client_encoding ne 'UTF8';
+
+ foreach my $enable_utf8 (1, 0, -1) {
+ my $desc = "$state $range UTF-8 $test->{qtype} $type (pg_enable_utf8=$enable_utf8)";
+ my @args = @{$test->{args} || []};
+ my $want = exists $test->{want} ? $test->{want} : $value;
+ if (!$enable_utf8) {
+ $want = ref $want ? [ map encode_utf8($_), @{$want} ] ## no critic
+ : encode_utf8($want);
+ }
+
+ is(utf8::is_utf8($test->{sql}), ($state eq 'upgraded'), "$desc query has correct flag")
+ if $test->{qtype} =~ /^interpolated/;
+ if ($state ne 'mixed') {
+ foreach my $arg (map { ref($_) ? @{$_} : $_ } @args) {
+ is(utf8::is_utf8($arg), ($state eq 'upgraded'), "$desc arg has correct flag")
+ }
+ }
+ $dbh->{pg_enable_utf8} = $enable_utf8;
+
+ my $sth = $dbh->prepare($test->{sql});
+ $sth->execute(@args);
+ my $result = $sth->fetchall_arrayref->[0][0];
+ is_deeply ($result, $want,
+ "$desc returns proper value");
+ if ($test->{qtype} !~ /length$/) {
+ # Whilst XS code can set SVf_UTF8 on an IV, the core's SV
+ # copying code doesn't copy it. So we can't assume that numeric
+ # values we see "out here" still have it set. Hence skip this
+ # test for the SQL length() tests.
+ is(utf8::is_utf8($_), !!$enable_utf8, "$desc returns string with correct UTF-8 flag")
+ for (ref $result ? @{$result} : $result);
+ }
+ }
+ }
+}
+
+my %ord_max = (
+ LATIN1 => 255,
+ UTF8 => 2**31,
+);
+
+# Test that what we get is the same as the database's idea of characters:
+for my $name ('LATIN CAPITAL LETTER N',
+ 'LATIN SMALL LETTER E WITH ACUTE',
+ 'CURRENCY SIGN',
+ # Has a different code point in Unicode, Windows 1252 and ISO-8859-15
+ 'EURO SIGN',
+ 'POUND SIGN',
+ 'YEN SIGN',
+ # Has a different code point in Unicode and Windows 1252
+ 'LATIN CAPITAL LETTER S WITH CARON',
+ 'SNOWMAN',
+ # U+1D196 should be 1 character, not a surrogate pair
+ 'MUSICAL SYMBOL TR',
+ ) {
+ my $ord = charnames::vianame($name);
+ SKIP:
+ foreach my $enable_utf8 (1, 0, -1) {
+ my $desc = sprintf "chr(?) for U+%04X $name, \$enable_utf8=$enable_utf8", $ord;
+ skip "Pg < 8.3 has broken $desc", 1
+ if $ord > 127 && $dbh->{pg_server_version} < 80300;
+ skip "Cannot do $desc with server_encoding='$server_encoding'", 1
+ if $ord > ($ord_max{$server_encoding} || 127);
+ $dbh->{pg_enable_utf8} = $enable_utf8;
+ my $sth = $dbh->prepare('SELECT chr(?)');
+ $sth->execute($ord);
+ my $result = $sth->fetchall_arrayref->[0][0];
+ if (!$enable_utf8) {
+ # We asked for UTF-8 octets to arrive in Perl-space.
+ # Check this, and convert them to character(s).
+ # If we didn't, the next two tests are meaningless, so skip them.
+ is(utf8::decode($result), 1, "Got valid UTF-8 for $desc")
+ or next;
+ }
+ is (length $result, 1, "Got 1 character for $desc");
+ is (ord $result, $ord, "Got correct character for $desc");
+ }
+}
cleanup_database($dbh,'test');
$dbh->disconnect();
@@ -11,7 +11,7 @@ use Test::More tests => 1;
use lib 't','.';
if ($ENV{DBDPG_NOCLEANUP}) {
- ok (q{No cleaning up because ENV 'DBDPG_NOCLEANUP' is set});
+ pass (q{No cleaning up because ENV 'DBDPG_NOCLEANUP' is set});
exit;
}
@@ -9,6 +9,8 @@ use Cwd;
use 5.006;
select(($|=1,select(STDERR),$|=1)[1]);
+my $superuser = 1;
+
my $testfh;
if (exists $ENV{TEST_OUTPUT}) {
my $file = $ENV{TEST_OUTPUT};
@@ -17,6 +19,17 @@ if (exists $ENV{TEST_OUTPUT}) {
Test::More->builder->todo_output($testfh);
}
+my @matviews =
+ (
+ 'dbd_pg_matview',
+ );
+
+my @operators =
+ (
+ '?.integer.integer',
+ '??.text.text',
+ );
+
my @schemas =
(
'dbd_pg_testschema',
@@ -92,17 +105,21 @@ version: $version
## Did we fail last time? Fail this time too, but quicker!
if ($testdsn =~ /FAIL!/) {
+ $debug and diag 'Previous failure detected';
return $helpconnect, "Previous failure ($error)", undef;
}
## We may want to force an initdb call
if (!$helpconnect and $ENV{DBDPG_TESTINITDB}) {
+ $debug and diag 'Jumping to INITDB';
goto INITDB;
}
## Got a working DSN? Give it an attempt
if ($testdsn and $testuser) {
+ $debug and diag "Trying with $testuser and $testdsn";
+
## Used by t/01connect.t
if ($arg->{dbreplace}) {
$testdsn =~ s/$alias\s*=/$arg->{dbreplace}=/;
@@ -117,6 +134,8 @@ version: $version
1;
};
+ $debug and diag "Connection failed: $@";
+
if ($@ =~ /invalid connection option/ or $@ =~ /dbbarf/) {
return $helpconnect, $@, undef;
}
@@ -216,6 +235,10 @@ version: $version
$testuser = 'postgres';
}
+ # non-ASCII parts of the tests assume UTF8
+ $testdsn =~ s/;?\bclient_encoding=[^;]+//;
+ $testdsn .= ';client_encoding=utf8';
+
## From here on out, we don't return directly, but save it first
GETHANDLE: {
eval {
@@ -228,7 +251,7 @@ version: $version
if ($@ =~ /postgres/) {
if ($helpconnect) {
- $testdsn .= 'dbname=postgres';
+ $testdsn .= ';dbname=postgres';
$helpconnect += 2;
}
$helpconnect += 4;
@@ -531,7 +554,7 @@ version: $version
}
## Attempt to connect to this server
- $testdsn = "dbi:Pg:dbname=postgres;port=$testport";
+ $testdsn = "dbi:Pg:dbname=postgres;client_encoding=utf8;port=$testport";
if ($^O =~ /Win32/) {
$testdsn .= ';host=localhost';
}
@@ -626,13 +649,16 @@ version: $version
$ENV{DBI_DSN} = $testdsn;
$ENV{DBI_USER} = $testuser;
+ $debug and diag "Got a database handle ($dbh)";
+
if ($arg->{quickreturn}) {
+ $debug and diag 'Returning via quickreturn';
return $helpconnect, '', $dbh;
}
my $SQL = 'SELECT usesuper FROM pg_user WHERE usename = current_user';
- my $bga = $dbh->selectall_arrayref($SQL)->[0][0];
- if ($bga) {
+ $superuser = $dbh->selectall_arrayref($SQL)->[0][0];
+ if ($superuser) {
$dbh->do(q{SET LC_MESSAGES = 'C'});
}
@@ -642,11 +668,13 @@ version: $version
}
else {
+ $debug and diag 'Attempting to cleanup database';
cleanup_database($dbh);
eval {
$dbh->do("CREATE SCHEMA $S");
};
+ $@ and $debug and diag "Create schema error: $@";
if ($@ =~ /Permission denied/ and $helpconnect != 16) {
## Okay, this ain't gonna work, let's try initdb
goto INITDB;
@@ -694,6 +722,12 @@ return $helpconnect, '', $dbh;
} ## end of connect_database
+sub is_super {
+
+ return $superuser;
+
+}
+
sub find_tempdir {
if (eval { require File::Temp; 1; }) {
@@ -753,6 +787,12 @@ sub get_test_settings {
$testdir = "$dir/dbdpg_test_database";
}
+ ## Allow forcing of ENV variables
+ if ($ENV{DBDPG_TEST_ALWAYS_ENV}) {
+ $testdsn = $ENV{DBI_DSN} || '';
+ $testuser = $ENV{DBI_USER} || '';
+ }
+
return $testdsn, $testuser, $helpconnect, $su, $uid, $testdir, $pg_ctl, $initdb, $error, $version;
} ## end of get_test_settings
@@ -783,6 +823,22 @@ sub relation_exists {
} ## end of relation_exists
+sub operator_exists {
+
+ my ($dbh,$opname,$leftarg,$rightarg) = @_;
+
+ my $schema = 'dbd_pg_testschema';
+ my $SQL = 'SELECT 1 FROM pg_operator o, pg_namespace n '.
+ 'WHERE oprname=? AND oprleft = ?::regtype AND oprright = ?::regtype'.
+ ' AND o.oprnamespace = n.oid AND n.nspname = ?';
+ my $sth = $dbh->prepare_cached($SQL);
+ my $count = $sth->execute($opname,$leftarg,$rightarg,$schema);
+ $sth->finish();
+ return $count < 1 ? 0 : 1;
+
+} ## end of operator_exists
+
+
sub cleanup_database {
## Clear out any testing objects in the current database
@@ -796,6 +852,18 @@ sub cleanup_database {
$dbh->rollback() if ! $dbh->{AutoCommit};
+ for my $name (@matviews) {
+ my $schema = ($name =~ s/(.+)\.(.+)/$2/) ? $1 : $S;
+ next if ! relation_exists($dbh,$schema,$name);
+ $dbh->do("DROP MATERIALIZED VIEW $schema.$name");
+ }
+
+ for my $name (@operators) {
+ my ($opname,$leftarg,$rightarg) = split /\./ => $name;
+ next if ! operator_exists($dbh,$opname,$leftarg,$rightarg);
+ $dbh->do("DROP OPERATOR dbd_pg_testschema.$opname($leftarg,$rightarg)");
+ }
+
for my $name (@tables) {
my $schema = ($name =~ s/(.+)\.(.+)/$2/) ? $1 : $S;
next if ! relation_exists($dbh,$schema,$name);
@@ -839,7 +907,6 @@ sub shutdown_test_database {
## Remove the test directory entirely
return if $ENV{DBDPG_TESTINITDB};
return if ! eval { require File::Path; 1; };
- warn "Removing test database directory\n";
File::Path::rmtree($testdir);
return;
@@ -13,6 +13,8 @@ use Data::Dumper;
use YAML;
use DBD::Pg qw/:pg_types/;
use Data::Peek;
+use Devel::Leak;
+use Time::HiRes qw/ sleep /;
use vars qw/$sth $info $count $SQL/;
@@ -26,15 +28,44 @@ my $dbh = DBI->connect($DSN, '', '', {AutoCommit=>0,RaiseError=>1,PrintError=>0}
my $me = $dbh->{Driver}{Name};
print "DBI is version $DBI::VERSION, I am $me, version of DBD::Pg is $DBD::Pg::VERSION\n";
-user_arrays();
+#user_arrays();
-commit_return_test();
+#commit_return_test();
#utf8_print_test();
#memory_leak_test_bug_65734();
-exit;
+memory_leak_arrays();
+
+sub memory_leak_arrays {
+
+# $dbh->{pg_expand_array} = 0;
+
+ $dbh->do('CREATE TABLE leaktest ( id TEXT, arr TEXT[] )');
+ $dbh->do('TRUNCATE TABLE leaktest');
+ for my $var (qw/ a b c/ ) {
+ $dbh->do(qq{INSERT INTO leaktest VALUES ( '$var', '{"a","b","c"}' )});
+ }
+
+ my $sth = $dbh->prepare( 'SELECT arr FROM leaktest' );
+ my $count0 = 0;
+
+ {
+ my $handle;
+ my $count1 = Devel::Leak::NoteSV( $handle );
+ $sth->execute();
+ my $r = $sth->fetchall_arrayref( {} );
+ my $count2 = Devel::Leak::NoteSV( $handle );
+ $count0 ||= $count1;
+ my $diff = $count2 - $count0;
+ printf "New SVs: %4d Total: %d\n", $diff, $count2;
+ sleep 0.2;
+ last if $diff > 100;
+ redo;
+ }
+
+} ## end of memory_leak_arrays
sub user_arrays {
@@ -1,6 +1,6 @@
/*
- Copyright (c) 2003-2013 Greg Sabino Mullane and others: see the Changes file
+ Copyright (c) 2003-2015 Greg Sabino Mullane and others: see the Changes file
You may distribute under the terms of either the GNU General Public
License or the Artistic License, as specified in the Perl README file.
@@ -175,8 +175,6 @@ static sql_type_info_t pg_types[] = {
sql_type_info_t* pg_type_data(int sql_type)
{
- dTHX;
-
switch(sql_type) {
case PG_ABSTIMEARRAY: return &pg_types[0];
@@ -366,8 +364,6 @@ static sql_type_info_t sql_types[] = {
sql_type_info_t* sql_type_data(int sql_type)
{
- dTHX;
-
switch(sql_type) {
case SQL_BOOLEAN: return &sql_types[0];
case SQL_CHAR: return &sql_types[1];
@@ -642,7 +638,7 @@ open $newfh, '>', "$file.tmp" or die qq{Could not write to "$file.tmp": $!\n};
print $newfh qq{$slashstar
- Copyright (c) 2003-2013 Greg Sabino Mullane and others: see the Changes file
+ Copyright (c) 2003-2015 Greg Sabino Mullane and others: see the Changes file
You may distribute under the terms of either the GNU General Public
License or the Artistic License, as specified in the Perl README file.
@@ -700,8 +696,6 @@ print $newfh "\};\n\n";
print $newfh
"sql_type_info_t* pg_type_data(int sql_type)
{
-\tdTHX;
-
\tswitch(sql_type) {
\n";
@@ -728,7 +722,7 @@ for my $name (sort { $a cmp $b } keys %pgtype) {
}
print $newfh "\};\n\n";
-print $newfh "sql_type_info_t* sql_type_data(int sql_type)\n\{\n\tdTHX;\n\n";
+print $newfh "sql_type_info_t* sql_type_data(int sql_type)\n\{\n";
print $newfh "\tswitch(sql_type) \{\n";
for (sort { $pos{$a} <=> $pos{$b} } keys %pos) {