# DBD::Pg for pperl - pure-Perl PostgreSQL driver over Peta::FFI/libpq. # # pperl-authored (docs/internal/design/dbi.md Track 3). API-parity # reference: DBD-Pg-3.20.2 (Pg.pm + dbdimp.c) in perl5-modules; this is # NOT a transliteration - the substrate is libpq via Peta::FFI instead # of XS - but DSN grammar, placeholder rules, transaction semantics and # error conventions follow the reference. # # Phase 1 scope: connect/prepare/execute/fetch/finish/disconnect, # ?-, $1- and :name-placeholders via PQexecParams, transactions # (AutoCommit, begin/commit/rollback), quote via PQescapeLiteral, # bool/bytea/bpchar output conversion, err/errstr/state, ping, # last_insert_id(sequence). Known gaps vs reference: COPY, LOB, # async, server-side prepared statements, table_info/column_info. use strict; use warnings; { package DBD::Pg; use DBI (); use Peta::FFI (); # Upstream t/00basic.t asserts /^v?[0-9]+\.[0-9]+\.[0-9]+(?:_[0-9]+)?$/, # which a '-pperl1' suffix fails. Attribution below carries the # "this is the pperl driver" fact; see DBD::mysql for the same fix. our $VERSION = '3.20.2_01'; our $drh; # libpq enums (libpq-fe.h) use constant { CONNECTION_OK => 0, CONNECTION_BAD => 1, PGRES_EMPTY_QUERY => 0, PGRES_COMMAND_OK => 1, PGRES_TUPLES_OK => 2, PGRES_FATAL => 7, PG_DIAG_SQLSTATE => 67, # 'C' PQTRANS_UNKNOWN => 4, }; # ---- Exported constant surface ----------------------------------- # # Upstream Pg.pm declares the names in %EXPORT_TAGS and defines only # the pure-Perl PG_MIN_*/PG_MAX_* limits itself; the 209 PG_ # OIDs and the three async flags come from the compiled half (Pg.xs # ALIAS values over types.h / Pg.h). A pure-Perl driver has to supply # both halves, which is what the generated block below is. # # Not cosmetic: without it `use DBD::Pg ':pg_types'` dies with # "Attempt to call missing import method with arguments" and takes # the whole file with it - four of the six reference test files we # first ran died exactly there, before asserting anything. # # Regenerate with perl-src/DBD-Pg/regen-constants.pl. # --- BEGIN generated constants (regen-constants.pl) --- # 212 constants: PG_ OIDs and the async flags from the # reference types.h/Pg.h, PG_MIN_*/PG_MAX_* from its Pg.pm. use constant { PG_ACLITEM => 1033, PG_ACLITEMARRAY => 1034, PG_ANY => 2276, PG_ANYARRAY => 2277, PG_ANYCOMPATIBLE => 5077, PG_ANYCOMPATIBLEARRAY => 5078, PG_ANYCOMPATIBLEMULTIRANGE => 4538, PG_ANYCOMPATIBLENONARRAY => 5079, PG_ANYCOMPATIBLERANGE => 5080, PG_ANYELEMENT => 2283, PG_ANYENUM => 3500, PG_ANYMULTIRANGE => 4537, PG_ANYNONARRAY => 2776, PG_ANYRANGE => 3831, PG_ASYNC => 1, PG_BIT => 1560, PG_BITARRAY => 1561, PG_BOOL => 16, PG_BOOLARRAY => 1000, PG_BOX => 603, PG_BOXARRAY => 1020, PG_BPCHAR => 1042, PG_BPCHARARRAY => 1014, PG_BYTEA => 17, PG_BYTEAARRAY => 1001, PG_CHAR => 18, PG_CHARARRAY => 1002, PG_CID => 29, PG_CIDARRAY => 1012, PG_CIDR => 650, PG_CIDRARRAY => 651, PG_CIRCLE => 718, PG_CIRCLEARRAY => 719, PG_CSTRING => 2275, PG_CSTRINGARRAY => 1263, PG_DATE => 1082, PG_DATEARRAY => 1182, PG_DATEMULTIRANGE => 4535, PG_DATEMULTIRANGEARRAY => 6155, PG_DATERANGE => 3912, PG_DATERANGEARRAY => 3913, PG_EVENT_TRIGGER => 3838, PG_FDW_HANDLER => 3115, PG_FLOAT4 => 700, PG_FLOAT4ARRAY => 1021, PG_FLOAT8 => 701, PG_FLOAT8ARRAY => 1022, PG_GTSVECTOR => 3642, PG_GTSVECTORARRAY => 3644, PG_INDEX_AM_HANDLER => 325, PG_INET => 869, PG_INETARRAY => 1041, PG_INT2 => 21, PG_INT2ARRAY => 1005, PG_INT2VECTOR => 22, PG_INT2VECTORARRAY => 1006, PG_INT4 => 23, PG_INT4ARRAY => 1007, PG_INT4MULTIRANGE => 4451, PG_INT4MULTIRANGEARRAY => 6150, PG_INT4RANGE => 3904, PG_INT4RANGEARRAY => 3905, PG_INT8 => 20, PG_INT8ARRAY => 1016, PG_INT8MULTIRANGE => 4536, PG_INT8MULTIRANGEARRAY => 6157, PG_INT8RANGE => 3926, PG_INT8RANGEARRAY => 3927, PG_INTERNAL => 2281, PG_INTERVAL => 1186, PG_INTERVALARRAY => 1187, PG_JSON => 114, PG_JSONARRAY => 199, PG_JSONB => 3802, PG_JSONBARRAY => 3807, PG_JSONPATH => 4072, PG_JSONPATHARRAY => 4073, PG_LANGUAGE_HANDLER => 2280, PG_LINE => 628, PG_LINEARRAY => 629, PG_LSEG => 601, PG_LSEGARRAY => 1018, PG_MACADDR => 829, PG_MACADDR8 => 774, PG_MACADDR8ARRAY => 775, PG_MACADDRARRAY => 1040, PG_MAX_BIGINT => 9223372036854775807, PG_MAX_BIGSERIAL => 9223372036854775807, PG_MAX_INTEGER => 2147483647, PG_MAX_SERIAL => 2147483647, PG_MAX_SMALLINT => 32767, PG_MAX_SMALLSERIAL => 32767, PG_MIN_BIGINT => -9223372036854775808, PG_MIN_BIGSERIAL => 1, PG_MIN_INTEGER => -2147483648, PG_MIN_SERIAL => 1, PG_MIN_SMALLINT => -32768, PG_MIN_SMALLSERIAL => 1, PG_MONEY => 790, PG_MONEYARRAY => 791, PG_NAME => 19, PG_NAMEARRAY => 1003, PG_NUMERIC => 1700, PG_NUMERICARRAY => 1231, PG_NUMMULTIRANGE => 4532, PG_NUMMULTIRANGEARRAY => 6151, PG_NUMRANGE => 3906, PG_NUMRANGEARRAY => 3907, PG_OID => 26, PG_OID8 => 8256, PG_OID8ARRAY => 8261, PG_OIDARRAY => 1028, PG_OIDVECTOR => 30, PG_OIDVECTORARRAY => 1013, PG_OLDQUERY_CANCEL => 2, PG_OLDQUERY_WAIT => 4, PG_PATH => 602, PG_PATHARRAY => 1019, PG_PG_ATTRIBUTE => 75, PG_PG_ATTRIBUTEARRAY => 270, PG_PG_BRIN_BLOOM_SUMMARY => 4600, PG_PG_BRIN_MINMAX_MULTI_SUMMARY => 4601, PG_PG_CLASS => 83, PG_PG_CLASSARRAY => 273, PG_PG_DDL_COMMAND => 32, PG_PG_DEPENDENCIES => 3402, PG_PG_LSN => 3220, PG_PG_LSNARRAY => 3221, PG_PG_MCV_LIST => 5017, PG_PG_NDISTINCT => 3361, PG_PG_NODE_TREE => 194, PG_PG_PROC => 81, PG_PG_PROCARRAY => 272, PG_PG_SNAPSHOT => 5038, PG_PG_SNAPSHOTARRAY => 5039, PG_PG_TYPE => 71, PG_PG_TYPEARRAY => 210, PG_POINT => 600, PG_POINTARRAY => 1017, PG_POLYGON => 604, PG_POLYGONARRAY => 1027, PG_RECORD => 2249, PG_RECORDARRAY => 2287, PG_REFCURSOR => 1790, PG_REFCURSORARRAY => 2201, PG_REGCLASS => 2205, PG_REGCLASSARRAY => 2210, PG_REGCOLLATION => 4191, PG_REGCOLLATIONARRAY => 4192, PG_REGCONFIG => 3734, PG_REGCONFIGARRAY => 3735, PG_REGDATABASE => 8326, PG_REGDATABASEARRAY => 8327, PG_REGDICTIONARY => 3769, PG_REGDICTIONARYARRAY => 3770, PG_REGNAMESPACE => 4089, PG_REGNAMESPACEARRAY => 4090, PG_REGOPER => 2203, PG_REGOPERARRAY => 2208, PG_REGOPERATOR => 2204, PG_REGOPERATORARRAY => 2209, PG_REGPROC => 24, PG_REGPROCARRAY => 1008, PG_REGPROCEDURE => 2202, PG_REGPROCEDUREARRAY => 2207, PG_REGROLE => 4096, PG_REGROLEARRAY => 4097, PG_REGTYPE => 2206, PG_REGTYPEARRAY => 2211, PG_TABLE_AM_HANDLER => 269, PG_TEXT => 25, PG_TEXTARRAY => 1009, PG_TID => 27, PG_TIDARRAY => 1010, PG_TIME => 1083, PG_TIMEARRAY => 1183, PG_TIMESTAMP => 1114, PG_TIMESTAMPARRAY => 1115, PG_TIMESTAMPTZ => 1184, PG_TIMESTAMPTZARRAY => 1185, PG_TIMETZ => 1266, PG_TIMETZARRAY => 1270, PG_TRIGGER => 2279, PG_TSMULTIRANGE => 4533, PG_TSMULTIRANGEARRAY => 6152, PG_TSM_HANDLER => 3310, PG_TSQUERY => 3615, PG_TSQUERYARRAY => 3645, PG_TSRANGE => 3908, PG_TSRANGEARRAY => 3909, PG_TSTZMULTIRANGE => 4534, PG_TSTZMULTIRANGEARRAY => 6153, PG_TSTZRANGE => 3910, PG_TSTZRANGEARRAY => 3911, PG_TSVECTOR => 3614, PG_TSVECTORARRAY => 3643, PG_TXID_SNAPSHOT => 2970, PG_TXID_SNAPSHOTARRAY => 2949, PG_UNKNOWN => 705, PG_UUID => 2950, PG_UUIDARRAY => 2951, PG_VARBIT => 1562, PG_VARBITARRAY => 1563, PG_VARCHAR => 1043, PG_VARCHARARRAY => 1015, PG_VOID => 2278, PG_XID => 28, PG_XID8 => 5069, PG_XID8ARRAY => 271, PG_XIDARRAY => 1011, PG_XML => 142, PG_XMLARRAY => 143, }; our %EXPORT_TAGS = ( async => [qw( $DBDPG_DEFAULT PG_ASYNC PG_OLDQUERY_CANCEL PG_OLDQUERY_WAIT )], pg_limits => [qw( $DBDPG_DEFAULT PG_MIN_SMALLINT PG_MAX_SMALLINT PG_MIN_INTEGER PG_MAX_INTEGER PG_MAX_BIGINT PG_MIN_BIGINT PG_MIN_SMALLSERIAL PG_MAX_SMALLSERIAL PG_MIN_SERIAL PG_MAX_SERIAL PG_MIN_BIGSERIAL PG_MAX_BIGSERIAL )], pg_types => [qw( $DBDPG_DEFAULT PG_ASYNC PG_OLDQUERY_CANCEL PG_OLDQUERY_WAIT PG_ACLITEM PG_ACLITEMARRAY PG_ANY PG_ANYARRAY PG_ANYCOMPATIBLE PG_ANYCOMPATIBLEARRAY PG_ANYCOMPATIBLEMULTIRANGE PG_ANYCOMPATIBLENONARRAY PG_ANYCOMPATIBLERANGE PG_ANYELEMENT PG_ANYENUM PG_ANYMULTIRANGE PG_ANYNONARRAY PG_ANYRANGE PG_BIT PG_BITARRAY PG_BOOL PG_BOOLARRAY PG_BOX PG_BOXARRAY PG_BPCHAR PG_BPCHARARRAY PG_BYTEA PG_BYTEAARRAY PG_CHAR PG_CHARARRAY PG_CID PG_CIDARRAY PG_CIDR PG_CIDRARRAY PG_CIRCLE PG_CIRCLEARRAY PG_CSTRING PG_CSTRINGARRAY PG_DATE PG_DATEARRAY PG_DATEMULTIRANGE PG_DATEMULTIRANGEARRAY PG_DATERANGE PG_DATERANGEARRAY PG_EVENT_TRIGGER PG_FDW_HANDLER PG_FLOAT4 PG_FLOAT4ARRAY PG_FLOAT8 PG_FLOAT8ARRAY PG_GTSVECTOR PG_GTSVECTORARRAY PG_INDEX_AM_HANDLER PG_INET PG_INETARRAY PG_INT2 PG_INT2ARRAY PG_INT2VECTOR PG_INT2VECTORARRAY PG_INT4 PG_INT4ARRAY PG_INT4MULTIRANGE PG_INT4MULTIRANGEARRAY PG_INT4RANGE PG_INT4RANGEARRAY PG_INT8 PG_INT8ARRAY PG_INT8MULTIRANGE PG_INT8MULTIRANGEARRAY PG_INT8RANGE PG_INT8RANGEARRAY PG_INTERNAL PG_INTERVAL PG_INTERVALARRAY PG_JSON PG_JSONARRAY PG_JSONB PG_JSONBARRAY PG_JSONPATH PG_JSONPATHARRAY PG_LANGUAGE_HANDLER PG_LINE PG_LINEARRAY PG_LSEG PG_LSEGARRAY PG_MACADDR PG_MACADDR8 PG_MACADDR8ARRAY PG_MACADDRARRAY PG_MONEY PG_MONEYARRAY PG_NAME PG_NAMEARRAY PG_NUMERIC PG_NUMERICARRAY PG_NUMMULTIRANGE PG_NUMMULTIRANGEARRAY PG_NUMRANGE PG_NUMRANGEARRAY PG_OID PG_OID8 PG_OID8ARRAY PG_OIDARRAY PG_OIDVECTOR PG_OIDVECTORARRAY PG_PATH PG_PATHARRAY PG_PG_ATTRIBUTE PG_PG_ATTRIBUTEARRAY PG_PG_BRIN_BLOOM_SUMMARY PG_PG_BRIN_MINMAX_MULTI_SUMMARY PG_PG_CLASS PG_PG_CLASSARRAY PG_PG_DDL_COMMAND PG_PG_DEPENDENCIES PG_PG_LSN PG_PG_LSNARRAY PG_PG_MCV_LIST PG_PG_NDISTINCT PG_PG_NODE_TREE PG_PG_PROC PG_PG_PROCARRAY PG_PG_SNAPSHOT PG_PG_SNAPSHOTARRAY PG_PG_TYPE PG_PG_TYPEARRAY PG_POINT PG_POINTARRAY PG_POLYGON PG_POLYGONARRAY PG_RECORD PG_RECORDARRAY PG_REFCURSOR PG_REFCURSORARRAY PG_REGCLASS PG_REGCLASSARRAY PG_REGCOLLATION PG_REGCOLLATIONARRAY PG_REGCONFIG PG_REGCONFIGARRAY PG_REGDATABASE PG_REGDATABASEARRAY PG_REGDICTIONARY PG_REGDICTIONARYARRAY PG_REGNAMESPACE PG_REGNAMESPACEARRAY PG_REGOPER PG_REGOPERARRAY PG_REGOPERATOR PG_REGOPERATORARRAY PG_REGPROC PG_REGPROCARRAY PG_REGPROCEDURE PG_REGPROCEDUREARRAY PG_REGROLE PG_REGROLEARRAY PG_REGTYPE PG_REGTYPEARRAY PG_TABLE_AM_HANDLER PG_TEXT PG_TEXTARRAY PG_TID PG_TIDARRAY PG_TIME PG_TIMEARRAY PG_TIMESTAMP PG_TIMESTAMPARRAY PG_TIMESTAMPTZ PG_TIMESTAMPTZARRAY PG_TIMETZ PG_TIMETZARRAY PG_TRIGGER PG_TSMULTIRANGE PG_TSMULTIRANGEARRAY PG_TSM_HANDLER PG_TSQUERY PG_TSQUERYARRAY PG_TSRANGE PG_TSRANGEARRAY PG_TSTZMULTIRANGE PG_TSTZMULTIRANGEARRAY PG_TSTZRANGE PG_TSTZRANGEARRAY PG_TSVECTOR PG_TSVECTORARRAY PG_TXID_SNAPSHOT PG_TXID_SNAPSHOTARRAY PG_UNKNOWN PG_UUID PG_UUIDARRAY PG_VARBIT PG_VARBITARRAY PG_VARCHAR PG_VARCHARARRAY PG_VOID PG_XID PG_XID8 PG_XID8ARRAY PG_XIDARRAY PG_XML PG_XMLARRAY )], ); # --- END generated constants --- # Exporter, as upstream: @ISA, the tags above, then the default set. # `export_ok_tags` folds every tagged name into @EXPORT_OK, which is # what makes `use DBD::Pg ':pg_types'` work at all. our @ISA = qw(Exporter); Exporter::export_ok_tags('pg_types', 'async', 'pg_limits'); our @EXPORT = qw($DBDPG_DEFAULT PG_ASYNC PG_OLDQUERY_CANCEL PG_OLDQUERY_WAIT PG_BYTEA); # Upstream's placeholder for "use the column default", a blessed # singleton compared by identity rather than value. { package DBD::Pg::DefaultValue; sub new { my $class = shift; return bless {}, $class; } } our $DBDPG_DEFAULT = DBD::Pg::DefaultValue->new(); # Which OIDs denote an array type, for the fetch path. Derived from # the generated constants rather than kept as a second hand-written # list - a new PostgreSQL release adds array types in pairs, and two # lists would drift apart silently (the DRY failure mode that made # mro croak on deep @ISA chains). our %ARRAY_OID; { no strict 'refs'; for my $name (@{ $EXPORT_TAGS{pg_types} }) { next unless $name =~ /ARRAY\z/; my $sub = DBD::Pg->can($name) or next; $ARRAY_OID{ $sub->() } = 1; } } # Type OIDs (pg_type.h) needed for output conversion + TYPE attr. use constant { BOOLOID => 16, BYTEAOID => 17, INT8OID => 20, INT2OID => 21, INT4OID => 23, TEXTOID => 25, FLOAT4OID => 700, FLOAT8OID => 701, BPCHAROID => 1042, VARCHAROID => 1043, DATEOID => 1082, TIMEOID => 1083, TIMESTAMPOID => 1114, TIMESTAMPTZOID => 1184, NUMERICOID => 1700, }; # types.c pg_types[]: the .sql half of each row's union. An entry # ABSENT here is upstream's {0} - a PostgreSQL type with no SQL # equivalent (circle, point, ...), which is not the same as a type we # happen not to list. my %oid2sql = ( BOOLOID() => 16, BYTEAOID() => -3, INT8OID() => -5, INT2OID() => 5, INT4OID() => 4, TEXTOID() => -1, FLOAT4OID() => 7, FLOAT8OID() => 6, BPCHAROID() => 1, VARCHAROID() => 12, DATEOID() => 91, TIMEOID() => 92, TIMESTAMPOID() => 93, TIMESTAMPTZOID() => 93, NUMERICOID() => 2, ); sub _sql_type { $oid2sql{ $_[0] } || 12 } # The raw lookup, for callers that must tell "no SQL equivalent" # (report pg_type) from "some SQL type" - _sql_type's 12 fallback # cannot express that. sub _sql_type_raw { $oid2sql{ $_[0] } } # types.c sql_type_data(): a SQL type always binds as its PostgreSQL # equivalent - "always bind as pg_type, because we know we are # inserting into a pg database". Several SQL types share one pg type, # exactly as upstream's table does. my %sql2pg = ( 16 => BOOLOID(), # SQL_BOOLEAN 1 => BPCHAROID(), # SQL_CHAR -3 => BYTEAOID(), # SQL_VARBINARY 30 => BYTEAOID(), # SQL_BLOB -2 => BYTEAOID(), # SQL_BINARY -4 => BYTEAOID(), # SQL_LONGVARBINARY 91 => DATEOID(), # SQL_TYPE_DATE 7 => FLOAT4OID(), # SQL_REAL 6 => FLOAT8OID(), # SQL_FLOAT 8 => FLOAT8OID(), # SQL_DOUBLE 5 => INT2OID(), # SQL_SMALLINT -6 => INT2OID(), # SQL_TINYINT 4 => INT4OID(), # SQL_INTEGER -5 => INT8OID(), # SQL_BIGINT 2 => NUMERICOID(), # SQL_NUMERIC 3 => NUMERICOID(), # SQL_DECIMAL -1 => TEXTOID(), # SQL_LONGVARCHAR 92 => TIMEOID(), # SQL_TYPE_TIME 11 => TIMESTAMPOID(), # SQL_TIMESTAMP 93 => TIMESTAMPOID(), # SQL_TYPE_TIMESTAMP 95 => TIMESTAMPTZOID(), # SQL_TYPE_TIMESTAMP_WITH_TIMEZONE 94 => 1266, # SQL_TYPE_TIME_WITH_TIMEZONE -> PG_TIMETZ 12 => VARCHAROID(), # SQL_VARCHAR ); sub _pg_type_for_sql { $sql2pg{ $_[0] } } my $pq; # dlopen handle, process-wide sub _pq { $pq ||= Peta::FFI::dlopen("libpq.so.5") } sub _c { my $sig = splice @_, 1, 1; Peta::FFI::call(_pq(), $_[0], $sig, @_[1..$#_]) } # Pg.pm: "These two methods are here to allow calling before # connect()" - they are CLASS methods, so a caller can resolve a # trace flag with no handle in hand. The bit values are DBD::Pg's # own; anything it does not recognise falls through to DBI's parser. sub parse_trace_flag { my ($class, $flag) = @_; return (0x7FFFFF00 - 0x08000000) if $flag eq 'DBD'; # all but the prefix return 0x01000000 if $flag eq 'pglibpq'; return 0x02000000 if $flag eq 'pgstart'; return 0x04000000 if $flag eq 'pgend'; return 0x08000000 if $flag eq 'pgprefix'; return 0x10000000 if $flag eq 'pglogin'; return 0x20000000 if $flag eq 'pgquote'; return DBI::parse_trace_flag($class, $flag); } sub parse_trace_flags { my ($class, $flags) = @_; return DBI::parse_trace_flags($class, $flags); } sub driver { return $drh if $drh; my ($class, $attr) = @_; # Pg.pm installs its private methods here, once. Defining a # sub in DBD::Pg::db is not enough: DBI dispatches through # DBI::db, so an uninstalled pg_* method is "Can't locate object # method via package DBI::db" no matter that the sub exists. if (!$DBD::Pg::methods_are_installed) { DBD::Pg::db->install_method($_) for qw( pg_endcopy pg_getline pg_putline pg_getcopydata pg_putcopydata pg_putcopyend pg_getcopydata_async pg_ready pg_result pg_cancel pg_send_cancel pg_savepoint pg_rollback_to pg_release pg_ping ); $DBD::Pg::methods_are_installed = 1; } ($drh) = DBI::_new_drh("${class}::dr", { Name => 'Pg', Version => $VERSION, Attribution => 'DBD::Pg over Peta::FFI/libpq (peta-perl)', }); $drh; } sub CLONE { undef $drh } } { package DBD::Pg::dr; our $imp_data_size = 0; # Pg.pm: an empty hashref on every handle class. sub private_attribute_info { return {} } # Split a conninfo-ish DSN on ';' respecting single-quoted values, # then join with spaces for PQconnectdb (dbdimp.c pg_db_login6 # replaces separators the same way). sub _dsn_to_conninfo { my ($dsn, $user, $pass) = @_; my @parts; my $cur = ''; my $q = 0; for my $ch (split //, $dsn) { if ($ch eq "'") { $q = !$q; $cur .= $ch } elsif ($ch eq ';' && !$q) { push @parts, $cur; $cur = '' } else { $cur .= $ch } } push @parts, $cur if length $cur; my $conninfo = join ' ', grep { /\S/ } @parts; for ([user => $user], [password => $pass]) { my ($k, $v) = @$_; next unless defined $v && length $v; $v =~ s/([\\'])/\\$1/g; $conninfo .= " $k='$v'"; } return $conninfo; } sub connect { my ($drh, $dsn, $user, $pass, $attr) = @_; # Pg.pm: db/database are synonyms for dbname; "..." -> '...' $dsn =~ s/\b(?:db|database)\s*=/dbname=/; $dsn =~ s/dbname\s*=\s*"(.+?)"/dbname='$1'/; $user = defined($user) ? $user : defined $ENV{DBI_USER} ? $ENV{DBI_USER} : ''; $pass = defined($pass) ? $pass : defined $ENV{DBI_PASS} ? $ENV{DBI_PASS} : ''; my ($outer, $dbh) = DBI::_new_dbh($drh, { Name => $dsn, Username => $user, CURRENT_USER => $user, }); my $conninfo = _dsn_to_conninfo($dsn, $user, $pass); my $conn = DBD::Pg::_c("PQconnectdb", "(p)o", $conninfo); if (!$conn || DBD::Pg::_c("PQstatus", "(o)i", $conn) != DBD::Pg::CONNECTION_OK) { my $msg = $conn ? Peta::FFI::peek_cstr(DBD::Pg::_c("PQerrorMessage", "(o)o", $conn)) : 'PQconnectdb returned NULL'; DBD::Pg::_c("PQfinish", "(o)v", $conn) if $conn; return $drh->set_err(DBD::Pg::PGRES_FATAL, $msg, '08006'); } $dbh->{pg_conn} = $conn; # dbd_db_login6: imp_dbh->pg_errorlevel = 1 and # imp_dbh->skip_deallocate = DBDPG_FALSE are set as connection # defaults, so both are readable before anyone assigns to them. $dbh->{pg_errorlevel} = 1; $dbh->{pg_skip_deallocate} = 0; $dbh->{pg_pid} = DBD::Pg::_c("PQbackendPID", "(o)i", $conn); $dbh->{pg_server_version} = DBD::Pg::_c("PQserverVersion", "(o)i", $conn); # PQlibVersion() - the CLIENT library, distinct from the server's. # Upstream's tests read this and compare it numerically # (`if ($pglibversion < 100000)`), so leaving it undef does not # just omit an attribute, it makes those comparisons warn and # take the wrong branch. Same class as the DBD::SQLite # sqlite_version_number bug that silently skipped 24 files. $dbh->{pg_lib_version} = DBD::Pg::_c("PQlibVersion", "()i"); # Pg.pm: the default pg_enable_utf8 of -1 means "decode iff # client_encoding is UTF8", and the docs are explicit that the # encoding is sampled at CONNECT time only - changing it later # requires re-setting pg_enable_utf8 to -1 by hand. $dbh->{pg_client_encoding} = Peta::FFI::peek_cstr( DBD::Pg::_c("PQparameterStatus", "(op)o", $conn, "client_encoding")); $dbh->{pg_enable_utf8} = -1 unless defined $dbh->{pg_enable_utf8}; $dbh->{pg_async_status} = 0; # dbdimp.c initialises both to DBDPG_FALSE, and 12placeholders.t # reads them before ever setting one - undef would be a divergence # even though it behaves the same in the scanner. $dbh->{pg_placeholder_dollaronly} = 0; $dbh->{pg_placeholder_nocolons} = 0; $dbh->{pg_AutoCommit} = 1; $dbh->STORE(Active => 1); return $outer; } sub data_sources { () } } { package DBD::Pg::db; our $imp_data_size = 0; # Pg.pm: an empty hashref on every handle class. sub private_attribute_info { return {} } sub _conn { $_[0]->{pg_conn} } # PQtransactionStatus: 0 idle, 1 active, 2 intrans, 3 inerror, 4 unknown sub _txn { DBD::Pg::_c("PQtransactionStatus", "(o)i", $_[0]->{pg_conn}) } # Report a failed result: err = result status, state = SQLSTATE. sub _result_err { my ($h, $conn, $res, $status) = @_; my $msg = $res ? Peta::FFI::peek_cstr(DBD::Pg::_c("PQresultErrorMessage", "(o)o", $res)) : Peta::FFI::peek_cstr(DBD::Pg::_c("PQerrorMessage", "(o)o", $conn)); my $state = $res ? Peta::FFI::peek_cstr(DBD::Pg::_c("PQresultErrorField", "(oi)o", $res, DBD::Pg::PG_DIAG_SQLSTATE)) : undef; DBD::Pg::_c("PQclear", "(o)v", $res) if $res; $msg =~ s/\s+\z// if defined $msg; return $h->set_err($status || DBD::Pg::PGRES_FATAL, $msg, $state); } # Issue a plain command via PQexec, with error reporting. sub _simple_exec { my ($dbh, $sql) = @_; my $conn = $dbh->{pg_conn}; my $res = DBD::Pg::_c("PQexec", "(op)o", $conn, $sql); my $status = $res ? DBD::Pg::_c("PQresultStatus", "(o)i", $res) : DBD::Pg::PGRES_FATAL; if ($status != DBD::Pg::PGRES_COMMAND_OK && $status != DBD::Pg::PGRES_TUPLES_OK) { return _result_err($dbh, $conn, $res, $status); } DBD::Pg::_c("PQclear", "(o)v", $res); return 1; } # dbdimp.c: with AutoCommit off a BEGIN is issued lazily before the # first command outside a transaction. sub _maybe_begin { my $dbh = shift; return 1 if $dbh->{pg_AutoCommit}; return 1 if _txn($dbh) != 0; return _simple_exec($dbh, 'begin'); } # Placeholder scanner (dbdimp.c prescan). Styles are mutually # exclusive per statement: ? | $1 | :name. Quoted regions ('', # E'', "", $tag$..$tag$), line (--) and nested block (/* */) # comments, ::casts and := are not placeholders. sub _parse_statement { my ($dbh, $sql, $attr) = @_; my ($out, $n, $style, %names) = ('', 0, undef); # dbdimp.c dbd_st_prepare: the sth inherits both flags from the # dbh, and the prepare attributes override. $N is scanned # whatever they say - only ? and : are switchable. my $dollaronly = ref $attr eq 'HASH' && exists $attr->{pg_placeholder_dollaronly} ? $attr->{pg_placeholder_dollaronly} : $dbh->{pg_placeholder_dollaronly}; my $nocolons = ref $attr eq 'HASH' && exists $attr->{pg_placeholder_nocolons} ? $attr->{pg_placeholder_nocolons} : $dbh->{pg_placeholder_nocolons}; my $len = length $sql; my $i = 0; my $err = sub { die "DBD::Pg placeholder error: $_[0]\n" }; my $set_style = sub { $style = $_[0] unless defined $style; $err->("Cannot mix placeholder styles ($style / $_[0])") if $style ne $_[0]; }; while ($i < $len) { my $c = substr($sql, $i, 1); my $rest = substr($sql, $i); if ($c eq "'" || ($c =~ /[eE]/ && substr($sql, $i, 2) =~ /\A[eE]'/)) { my $estr = $c ne "'"; my $start = $i; $i += $estr ? 2 : 1; while ($i < $len) { my $ch = substr($sql, $i, 1); if ($estr && $ch eq '\\') { $i += 2; next } if ($ch eq "'") { if (substr($sql, $i + 1, 1) eq "'") { $i += 2; next } $i++; last; } $i++; } $out .= substr($sql, $start, $i - $start); next; } if ($c eq '"') { my $start = $i++; $i++ while $i < $len && substr($sql, $i, 1) ne '"'; $i++; $out .= substr($sql, $start, $i - $start); next; } if ($rest =~ /\A--/) { my $e = index($sql, "\n", $i); $e = $len if $e < 0; $out .= substr($sql, $i, $e - $i); $i = $e; next; } if ($rest =~ m{\A/\*}) { my $depth = 0; my $start = $i; while ($i < $len) { if (substr($sql, $i, 2) eq '/*') { $depth++; $i += 2 } elsif (substr($sql, $i, 2) eq '*/') { $depth--; $i += 2; last if !$depth } else { $i++ } } $out .= substr($sql, $start, $i - $start); next; } if ($rest =~ /\A(\$([A-Za-z_][A-Za-z0-9_]*)?\$)/) { my $tag = $1; my $e = index($sql, $tag, $i + length $tag); $err->("Unterminated dollar quote $tag") if $e < 0; $e += length $tag; $out .= substr($sql, $i, $e - $i); $i = $e; next; } # dbdimp.c prescan: "If this placeholder is escaped, we # rewrite the string to remove the backslash, and move on as # if there is no placeholder." Gated on the # pg_placeholder_escaped attribute, default on. # # This is not a nicety. PostgreSQL's jsonb existence operator # IS `?`, so `'{"a":1}'::jsonb \? 'abc'` has to reach the # server as a `?` operator while `$1` in the same statement # stays a placeholder. Without the rule the scanner saw two # styles in one statement and died with "Cannot mix # placeholder styles (? / $1)", taking the remaining 260 # assertions of 12placeholders.t with it. if ($c =~ /[?\$:]/ && $i > 0 && substr($sql, $i - 1, 1) eq '\\') { my $esc = $dbh->{pg_placeholder_escaped}; $esc = 1 unless defined $esc; if ($esc) { chop $out if length $out; # drop the backslash already emitted $out .= $c; $i++; next; } } # dollaronly leaves ? and : as ordinary text, which is how a # statement can use PostgreSQL's geometric operators ?- and # ?# alongside $1 placeholders. if ($c eq '?' && !$dollaronly) { $set_style->('?'); $n++; $out .= "\$$n"; $i++; next; } if ($rest =~ /\A\$(\d+)/) { $set_style->('$1'); $n = $1 if $1 > $n; $out .= "\$$1"; $i += 1 + length $1; next; } # `:1`, `:2`, ... - the NUMBERED colon form, which upstream # accepts alongside `:name`. The number is the position, so # it maps straight onto $N rather than being allocated a new # index like a name. Guarded against `::` casts the same way. # "Skip number-colon-number" (dbdimp.c): `arr[1:2]` is an # array SLICE, not a placeholder, and the only thing telling # them apart is the digit before the colon. if ($rest =~ /\A:(\d+)/ && !$dollaronly && !$nocolons && !($i > 0 && substr($sql, $i - 1, 1) =~ /[0-9]/) && substr($sql, $i - 1, 1) ne ':' && substr($sql, $i + 1, 1) ne ':') { my $num = $1; $set_style->(':1'); $n = $num if $num > $n; $out .= "\$$num"; $i += 1 + length $num; next; } if ($rest =~ /\A:([A-Za-z_][A-Za-z0-9_]*)/ && !$dollaronly && !$nocolons && substr($sql, $i - 1, 1) ne ':' && substr($sql, $i + 1, 1) ne ':' && substr($sql, $i + 1, 1) ne '=') { my $name = $1; $set_style->(':name'); $names{$name} = ++$n unless exists $names{$name}; $out .= "\$$names{$name}"; $i += 1 + length $name; next; } $out .= $c; $i++; } return ($out, $n, \%names); } # dbdimp.c dbd_st_prepare: classify on the statement's FIRST WORD. # Everything else is DDL or a utility command, which PostgreSQL will # not accept parameters for however well formed they are. my %DML_WORD = map { $_ => 1 } qw(select insert update delete merge values table with); sub _is_dml { my $sql = shift; return 0 unless defined $sql; $sql =~ s/\A\s+//; my ($word) = $sql =~ /\A([A-Za-z]+)/; return $word ? ($DML_WORD{lc $word} ? 1 : 0) : 0; } # The PQexec path has to put the values into the SQL itself, so it # quotes each one the way quote() would - which is why typed quoting # had to exist before this could be correct. sub _interpolate { my ($dbh, $sth, $params) = @_; my $sql = $sth->{pg_rewritten}; my $oids = $sth->{pg_param_oids} || []; my $out = ''; my $i = 0; # pg_rewritten is already normalised to $N, so splicing means # replacing $1..$N - and a literal $$ or dollar-quoted body was # consumed by the scanner, so what is left is unambiguous. while ($sql =~ /\G(.*?)\$(\d+)/gcs) { my ($lit, $num) = ($1, $2); my $v = $params->[$num - 1]; my $q = eval { defined $oids->[$num - 1] ? $dbh->quote($v, { pg_type => $oids->[$num - 1] }) : $dbh->quote($v); }; if ($@) { $sth->set_err(DBD::Pg::PGRES_FATAL, $@); return undef } $out .= $lit . $q; $i++; } $out .= substr $sql, pos($sql) // 0; return $out; } sub prepare { my ($dbh, $statement, $attr) = @_; my ($rewritten, $nparams, $names) = eval { _parse_statement($dbh, $statement, $attr) }; return $dbh->set_err(DBD::Pg::PGRES_FATAL, $@) if $@; my ($outer, $sth) = DBI::_new_sth($dbh, { Statement => $statement }); $sth->{pg_rewritten} = $rewritten; $sth->{pg_param_names} = $names; $sth->{pg_params} = []; # dbd_st_prepare copies both onto the sth so they are readable # there afterwards; the scan itself has already happened. for my $k (qw(pg_placeholder_dollaronly pg_placeholder_nocolons)) { $sth->{$k} = ref $attr eq 'HASH' && exists $attr->{$k} ? ($attr->{$k} ? 1 : 0) : ($dbh->{$k} ? 1 : 0); } # {pg_async => PG_ASYNC} at PREPARE, not just at do(): the flag # is recorded here and acted on at execute. Preparing does not # start anything, so pg_async_status stays 0 until then - # 02attribs.t asserts that gap explicitly. $sth->{pg_async} = (ref $attr eq 'HASH' && ($attr->{pg_async} || 0)) || 0; $outer->STORE(NUM_OF_PARAMS => $nparams); return $outer; } sub commit { my $dbh = shift; if ($dbh->{pg_AutoCommit}) { warn 'commit ineffective with AutoCommit enabled' if $dbh->FETCH('Warn'); return 1; } return 1 if _txn($dbh) == 0; # dbdimp.c pg_db_rollback_commit: "we just did a rollback or a # commit, so savepoints are not relevant". @{ $dbh->{pg_savepoints} } = (); return _simple_exec($dbh, 'commit'); } sub rollback { my $dbh = shift; if ($dbh->{pg_AutoCommit}) { warn 'rollback ineffective with AutoCommit enabled' if $dbh->FETCH('Warn'); return 1; } return 1 if _txn($dbh) == 0; @{ $dbh->{pg_savepoints} } = (); return _simple_exec($dbh, 'rollback'); } # dbdimp.c pg_db_savepoint / pg_db_rollback_to / pg_db_release. The # stack of live savepoint names is imp_dbh->savepoints upstream, an # AV; here an arrayref on the handle. It is not decoration - a # rollback_to or release pops every savepoint established AFTER the # named one, which is what makes calling rollback_to twice with the # same name work (20savepoints.t does exactly that). # # All three are no-ops under AutoCommit or on a dead connection, and # savepoint starts the transaction lazily the way every other command # does. sub pg_db_free_savepoints_to { my ($dbh, $savepoint) = @_; my $sp = $dbh->{pg_savepoints} ||= []; while (@$sp) { my $elem = pop @$sp; last if $elem eq $savepoint; } return; } sub pg_savepoint { my ($dbh, $savepoint) = @_; my $conn = $dbh->{pg_conn}; return 0 if !$conn || $dbh->{pg_AutoCommit}; _maybe_begin($dbh) or return -2; _simple_exec($dbh, "savepoint $savepoint") or return 0; push @{ $dbh->{pg_savepoints} ||= [] }, $savepoint; return 1; } sub pg_rollback_to { my ($dbh, $savepoint) = @_; my $conn = $dbh->{pg_conn}; return 0 if !$conn || $dbh->{pg_AutoCommit}; _simple_exec($dbh, "rollback to $savepoint") or return 0; pg_db_free_savepoints_to($dbh, $savepoint); return 1; } sub pg_release { my ($dbh, $savepoint) = @_; my $conn = $dbh->{pg_conn}; return 0 if !$conn || $dbh->{pg_AutoCommit}; _simple_exec($dbh, "release $savepoint") or return 0; pg_db_free_savepoints_to($dbh, $savepoint); return 1; } # dbd_db_ping: "No matter what state we are in, send an empty query # to the backend". Only a round trip distinguishes a live connection # from one whose backend has gone away - checking PQstatus and the # transaction status alone reports a dead connection as healthy, # which is what 02attribs.t's fork test catches. # # Codes: -1 no connection, -2 unknown transaction status, -3 the # probe returned a fatal error, -4 PQstatus says CONNECTION_BAD; # otherwise 1+tstatus (1 idle, 2 active, 3 intrans, 4 inerror). sub _ping { my $dbh = shift; my $conn = $dbh->{pg_conn} or return -1; my $t = _txn($dbh); return -2 if $t >= DBD::Pg::PQTRANS_UNKNOWN; my $res = DBD::Pg::_c("PQexec", "(op)o", $conn, '/* DBD::Pg ping test v3.20.2 */'); my $status = $res ? DBD::Pg::_c("PQresultStatus", "(o)i", $res) : DBD::Pg::PGRES_FATAL; DBD::Pg::_c("PQclear", "(o)v", $res) if $res; return -3 if $status == DBD::Pg::PGRES_FATAL; return 1 + $t if $status == DBD::Pg::PGRES_EMPTY_QUERY; # Safety measure: the probe may come back "fine" on a connection # libpq has already marked bad. return -4 if DBD::Pg::_c("PQstatus", "(o)i", $conn) == DBD::Pg::CONNECTION_BAD; return 1 + $t; } # Pg.pm: ping() folds every negative code to a plain false, pg_ping() # hands the caller the code itself. PrintError is silenced across the # probe because a dead backend makes libpq noisy. sub ping { my $dbh = shift; local $SIG{__WARN__} = sub {} if $dbh->FETCH('PrintError'); my $ret = _ping($dbh); return $ret < 1 ? 0 : $ret; } sub pg_ping { my $dbh = shift; local $SIG{__WARN__} = sub {} if $dbh->FETCH('PrintError'); return _ping($dbh); } # Reference behavior: a sequence name must be resolvable; phase 1 # supports the explicit {sequence} attribute (currval), or lastval() # when none is given. sub last_insert_id { my ($dbh, $catalog, $schema, $table, $col, $attr) = @_; # Pg.pm last_insert_id(): a non-ref final argument is taken as # the sequence NAME, and a ref that is not a hashref is reported # through set_err - not left to die as "Not a HASH reference" # when the deref is attempted. The difference is observable: # set_err runs the HandleSetErr hook, which 02attribs.t installs # precisely to rewrite this error's code and message. my $sequence; if (defined $attr and length $attr) { if (!ref $attr) { $attr = { sequence => $attr }; } elsif (ref $attr ne 'HASH') { $dbh->set_err(1, 'last_insert_id must be passed a hashref as the final argument'); return undef; } $sequence = $attr->{sequence} if exists $attr->{sequence} and length $attr->{sequence}; } my $sql = defined $sequence ? 'SELECT currval(' . $dbh->quote($sequence) . ')' : 'SELECT lastval()'; my $row = $dbh->selectrow_arrayref($sql) or return undef; return $row->[0]; } # dbdimp.c pg_stringify_array(): an arrayref becomes a PostgreSQL # array literal, `{...}`, with these rules - # - an empty array is `{}`; # - an undef element is the bare word NULL, not a quoted string; # - a scalar element is double-quoted with `\` and `"` escaped; # - nested arrays recurse, and sibling arrays must all be the same # length, because PostgreSQL arrays are rectangular. # The two croaks are upstream's, wording included: callers test for # them, and a silently-accepted ragged array would reach the server # as a syntactically valid literal of the wrong shape. # # Written recursively where dbdimp.c walks depth iteratively. The # driver is API-parity, not a transliteration (see the file header), # and the emitted literal is what has to match. sub _stringify_array { my ($aref, $delim) = @_; $delim = ',' unless defined $delim; return '{}' unless @$aref; # All-or-nothing: a level is either all arrays or all scalars. my $nested = grep { ref $_ eq 'ARRAY' } @$aref; if ($nested) { die "Invalid array - all arrays must be of equal size\n" if $nested != @$aref; my $len; for my $sub (@$aref) { $len = @$sub unless defined $len; die "Invalid array - all arrays must be of equal size\n" if @$sub != $len; } return '{' . join($delim, map { _stringify_array($_, $delim) } @$aref) . '}'; } my @out; for my $item (@$aref) { die "Arrays must contain only scalars and other arrays\n" if ref $item; if (!defined $item) { push @out, 'NULL'; next } my $s = $item; $s =~ s/(["\\])/\\$1/g; push @out, qq{"$s"}; } return '{' . join($delim, @out) . '}'; } # dbdimp.c pg_expand_array(): the inverse of _stringify_array, used on # the way OUT. PostgreSQL renders an array column as `{...}` with # elements comma-separated, quoted only when they need it, `NULL` # unquoted for a null element, and nesting by further braces. Returns # nested arrayrefs. # # Gated on the pg_expand_array handle attribute (upstream default on) # because a caller that wants the raw literal has no other way back # to it once we have parsed it. sub _expand_array { my ($str) = @_; return $str unless defined $str && $str =~ /\A\{/; my $pos = 0; my $parse; $parse = sub { my @out; $pos++; # consume '{' return \@out if substr($str, $pos, 1) eq '}' && ++$pos; while ($pos < length $str) { my $c = substr($str, $pos, 1); if ($c eq '{') { push @out, $parse->(); } elsif ($c eq '"') { $pos++; my $v = ''; while ($pos < length $str) { my $d = substr($str, $pos, 1); if ($d eq '\\') { $v .= substr($str, $pos + 1, 1); $pos += 2; next } last if $d eq '"'; $v .= $d; $pos++; } $pos++; # consume closing quote push @out, $v; } else { my $start = $pos; $pos++ while $pos < length($str) && substr($str, $pos, 1) !~ /[,}]/; my $v = substr($str, $start, $pos - $start); # An UNQUOTED NULL is the null element; a quoted # "NULL" is the four-character string and was handled # by the branch above. push @out, ($v eq 'NULL' ? undef : $v); } my $d = substr($str, $pos, 1); $pos++; # consume ',' or '}' last if $d eq '}'; } return \@out; }; return $parse->(); } # Pg.xs: `if (items < 4) { /* No bind arguments */ ... pg_quickexec }` # - a do() with no bind values goes STRAIGHT to PQexec and is never # scanned for placeholders. That is not just an optimisation: it is # what lets a statement contain a literal $1 that belongs to the # SERVER, as in # do(qq{PREPARE geotest(point) AS INSERT ... VALUES (\$1)}) # Routing that through prepare/execute counts the $1 as ours and # fails with "called with 0 bind variables when 1 are needed", which # is where 12placeholders.t stopped, 246 assertions short. # # DBI's default do() is prepare-then-execute, so without this the # fast path does not exist at all. # dbdimp.c: "Must call pg_endcopy before issuing more commands" - # any statement issued mid-COPY is refused. Not just a nicety: left # unguarded the statement reaches libpq, which aborts the transfer, # so the copy state is gone by the time pg_endcopy runs and it fails # with "no COPY in progress" - a confusing error for a mistake made # two calls earlier. sub _no_copy_in_progress { my $dbh = shift; die "Must call pg_endcopy before issuing more commands\n" if $dbh->{pg_copystate}; } sub do { my ($dbh, $statement, $attr, @bind) = @_; _no_copy_in_progress($dbh); # {pg_async => PG_ASYNC}: fire and return immediately. The caller # polls with pg_ready and collects with pg_result. if (ref $attr eq 'HASH' && ($attr->{pg_async} || 0) & DBD::Pg::PG_ASYNC) { my $conn = $dbh->{pg_conn} or return $dbh->set_err(DBD::Pg::PGRES_FATAL, 'do on disconnected handle'); DBD::Pg::db::_maybe_begin($dbh) or return undef; my $rc = DBD::Pg::_c("PQsendQuery", "(op)i", $conn, $statement); return _result_err($dbh, $conn, undef, DBD::Pg::PGRES_FATAL) unless $rc; $dbh->{pg_async_status} = 1; return '0E0'; } return $dbh->SUPER::do($statement, $attr, @bind) if @bind; DBD::Pg::db::_maybe_begin($dbh) or return undef; my $conn = $dbh->{pg_conn} or return $dbh->set_err(DBD::Pg::PGRES_FATAL, 'do on disconnected handle'); my $res = DBD::Pg::_c("PQexec", "(op)o", $conn, $statement); my $st = $res ? DBD::Pg::_c("PQresultStatus", "(o)i", $res) : DBD::Pg::PGRES_FATAL; # dbdimp.c pg_quickexec: COPY_OUT(3), COPY_IN(4) and COPY_BOTH(8) # are not failures - they mean a copy transfer is now in # progress. It records the state and returns -1 rows. Treating # them as errors made every `do("COPY ...")` fail with a bare # status number, which is where 07copy.t stopped at 2 of 62. if ($st == 3 || $st == 4 || $st == 8) { $dbh->{pg_copystate} = $st; DBD::Pg::_c("PQclear", "(o)v", $res); return -1; } if ($st != DBD::Pg::PGRES_COMMAND_OK && $st != DBD::Pg::PGRES_TUPLES_OK) { # _result_err clears the result itself. return _result_err($dbh, $conn, $res, $st); } my $rows = DBD::Pg::_c("PQcmdTuples", "(o)p", $res); DBD::Pg::_c("PQclear", "(o)v", $res); return (defined $rows && length $rows) ? ($rows == 0 ? '0E0' : $rows) : '0E0'; } # ---- COPY transfer ------------------------------------------------ # dbdimp.c pg_db_putline / pg_db_getline / pg_db_endcopy. These are # only legal between a `COPY` and its end, and which one is legal # depends on the DIRECTION: putline needs COPY_IN, getline COPY_OUT. # Upstream croaks rather than set_err on a misuse, and the tests # check the message, so croak it is. # ---- Async query support ------------------------------------------ # dbdimp.c: an async query goes out with PQsendQuery instead of # PQexec and the caller polls. pg_async_status is 0 when nothing is # outstanding and 1 while a query is in flight. # # do()/execute() take {pg_async => PG_ASYNC}; the result is collected # later with pg_result, or discarded with pg_cancel. sub pg_ready { my $dbh = shift; my $conn = $dbh->{pg_conn} or return undef; return 0 unless $dbh->{pg_async_status}; # PQconsumeInput first: PQisBusy only reports what has already # been read off the socket, so without it a finished query still # looks busy forever. DBD::Pg::_c("PQconsumeInput", "(o)i", $conn); return DBD::Pg::_c("PQisBusy", "(o)i", $conn) ? 0 : 1; } sub pg_result { my $dbh = shift; my $conn = $dbh->{pg_conn} or return undef; return $dbh->set_err(DBD::Pg::PGRES_FATAL, 'No asynchronous query is running') unless $dbh->{pg_async_status}; my $rows = 0; my $last; while (my $res = DBD::Pg::_c("PQgetResult", "(o)o", $conn)) { my $st = DBD::Pg::_c("PQresultStatus", "(o)i", $res); if ($st != DBD::Pg::PGRES_COMMAND_OK && $st != DBD::Pg::PGRES_TUPLES_OK) { $dbh->{pg_async_status} = 0; return _result_err($dbh, $conn, $res, $st); } my $n = DBD::Pg::_c("PQcmdTuples", "(o)p", $res); $rows = $n if defined $n && length $n; DBD::Pg::_c("PQclear", "(o)v", $res); $last = 1; } $dbh->{pg_async_status} = 0; return $rows == 0 ? '0E0' : $rows; } sub pg_cancel { my $dbh = shift; my $conn = $dbh->{pg_conn} or return undef; return $dbh->set_err(DBD::Pg::PGRES_FATAL, 'No asynchronous query is running') unless $dbh->{pg_async_status}; my $cancel = DBD::Pg::_c("PQgetCancel", "(o)o", $conn) or return undef; my $buf = Peta::FFI::alloc(256); my $rc = DBD::Pg::_c("PQcancel", "(opi)i", $cancel, $buf, 256); DBD::Pg::_c("PQfreeCancel", "(o)v", $cancel); Peta::FFI::free($buf); # Drain whatever the server sends back, or the connection stays # busy and the next command fails. while (my $res = DBD::Pg::_c("PQgetResult", "(o)o", $conn)) { DBD::Pg::_c("PQclear", "(o)v", $res); } $dbh->{pg_async_status} = 0; return $rc == 1 ? 1 : 0; } # Send the cancel request WITHOUT draining the connection - the # caller is expected to collect the (now-cancelled) result itself, # which is what distinguishes this from pg_cancel. sub pg_send_cancel { my $dbh = shift; my $conn = $dbh->{pg_conn} or return undef; my $cancel = DBD::Pg::_c("PQgetCancel", "(o)o", $conn) or return undef; my $buf = Peta::FFI::alloc(256); my $rc = DBD::Pg::_c("PQcancel", "(opi)i", $cancel, $buf, 256); DBD::Pg::_c("PQfreeCancel", "(o)v", $cancel); Peta::FFI::free($buf); return $rc == 1 ? 1 : 0; } sub pg_putline { my ($dbh, $line) = @_; my $cs = $dbh->{pg_copystate} || 0; die "pg_putline can only be called directly after issuing a COPY FROM command\n" unless $cs == 4; # PGRES_COPY_IN die "pg_putline can only be called with a defined value\n" unless defined $line; my $conn = $dbh->{pg_conn}; my $rc = DBD::Pg::_c("PQputCopyData", "(opi)i", $conn, $line, length $line); return 1 if $rc == 1; return _result_err($dbh, $conn, undef, DBD::Pg::PGRES_FATAL); } sub pg_getline { my $dbh = shift; my $cs = $dbh->{pg_copystate} || 0; die "pg_getline can only be called directly after issuing a COPY TO command\n" unless $cs == 3 || $cs == 8; # COPY_OUT / COPY_BOTH my $conn = $dbh->{pg_conn}; my $cell = Peta::FFI::alloc(8); my $n = DBD::Pg::_c("PQgetCopyData", "(ooi)i", $conn, $cell, 0); if ($n == -1) { # End of stream: empty the caller's buffer, drop the copy # state, and drain. Upstream calls PQendcopy "can't hurt". $_[0] = ''; $dbh->{pg_copystate} = 0; DBD::Pg::_c("PQendcopy", "(o)i", $conn); Peta::FFI::free($cell); return 0; # false: no more data } if ($n < 1) { Peta::FFI::free($cell); return _result_err($dbh, $conn, undef, DBD::Pg::PGRES_FATAL); } my $p = Peta::FFI::unpack_ptr(Peta::FFI::peek($cell, 8)); $_[0] = Peta::FFI::peek($p, $n); DBD::Pg::_c("PQfreemem", "(o)v", $p); Peta::FFI::free($cell); # Pg.xs maps the C return to a BOOLEAN - `(-1 != ret) ? yes : no` # - so callers see true while data arrives and false at the end, # NOT the C function's 0/-1. return 1; } # The modern COPY trio, alongside the legacy putline/getline pair. # Same libpq calls; the difference is the interface DBD::Pg exposes, # and both are used in the wild, so both are here. sub pg_putcopydata { my ($dbh, $data) = @_; _no_copy_in_progress_ok($dbh, 4); my $conn = $dbh->{pg_conn}; my $rc = DBD::Pg::_c("PQputCopyData", "(opi)i", $conn, $data, length $data); return 1 if $rc == 1; return _result_err($dbh, $conn, undef, DBD::Pg::PGRES_FATAL); } sub pg_putcopyend { return pg_endcopy(@_) } # Same call with libpq's async flag set: returns immediately with 0 # when no row is ready yet, rather than blocking. The state check is # identical, which is what 07copy.t exercises. sub pg_getcopydata_async { my $dbh = shift; _no_copy_in_progress_ok($dbh, 3, 8); my $conn = $dbh->{pg_conn}; my $cell = Peta::FFI::alloc(8); my $n = DBD::Pg::_c("PQgetCopyData", "(ooi)i", $conn, $cell, 1); if ($n < 1) { Peta::FFI::free($cell); $_[0] = ''; return $n == -1 ? 0 : -1 } my $ptr = Peta::FFI::unpack_ptr(Peta::FFI::peek($cell, 8)); $_[0] = Peta::FFI::peek($ptr, $n); DBD::Pg::_c("PQfreemem", "(o)v", $ptr); Peta::FFI::free($cell); return $n; } sub pg_getcopydata { my $dbh = shift; _no_copy_in_progress_ok($dbh, 3, 8); my $conn = $dbh->{pg_conn}; my $cell = Peta::FFI::alloc(8); my $n = DBD::Pg::_c("PQgetCopyData", "(ooi)i", $conn, $cell, 0); if ($n == -1) { $_[0] = ''; $dbh->{pg_copystate} = 0; DBD::Pg::_c("PQendcopy", "(o)i", $conn); Peta::FFI::free($cell); return 0; } if ($n < 1) { Peta::FFI::free($cell); return _result_err($dbh, $conn, undef, DBD::Pg::PGRES_FATAL); } my $ptr = Peta::FFI::unpack_ptr(Peta::FFI::peek($cell, 8)); $_[0] = Peta::FFI::peek($ptr, $n); DBD::Pg::_c("PQfreemem", "(o)v", $ptr); Peta::FFI::free($cell); return $n; } # Assert we are in one of the given copy states, with upstream's # wording for the direction that was expected. sub _no_copy_in_progress_ok { my ($dbh, @want) = @_; my $cs = $dbh->{pg_copystate} || 0; return if grep { $cs == $_ } @want; die $want[0] == 4 ? "pg_putcopydata can only be called directly after issuing a COPY FROM command\n" : "pg_getcopydata can only be called directly after issuing a COPY TO command\n"; } sub pg_endcopy { my $dbh = shift; my $cs = $dbh->{pg_copystate} || 0; die "pg_endcopy cannot be called until a COPY is issued\n" unless $cs; my $conn = $dbh->{pg_conn}; if ($cs == 4) { # COPY_IN my $rc = DBD::Pg::_c("PQputCopyEnd", "(oo)i", $conn, undef); return _result_err($dbh, $conn, undef, DBD::Pg::PGRES_FATAL) if $rc != 1; } # Drain the result the copy left behind, or the connection stays # busy and the next command fails with "another command is # already in progress". while (my $res = DBD::Pg::_c("PQgetResult", "(o)o", $conn)) { DBD::Pg::_c("PQclear", "(o)v", $res); } $dbh->{pg_copystate} = 0; return 1; } # ---- Typed quoting (quote.c) --------------------------------------- # # Every type in types.c names a quoting function, and they are not # interchangeable: the numeric ones VALIDATE and pass the value # through UNQUOTED, so `quote(3.14, SQL_FLOAT)` is 3.14 and not # '3.14', while `quote('3abc', SQL_FLOAT)` must die. Ignoring the # type argument - which is what this did - is wrong in both # directions at once and cost 12placeholders.t 100 assertions. # quote.c quote_string, via libpq rather than upstream's hand-rolled # escaper: PQescapeLiteral applies the connection's encoding and # standard_conforming_strings, which a literal cannot know. sub _q_string { my ($dbh, $value) = @_; my $conn = $dbh->{pg_conn}; my $p = DBD::Pg::_c("PQescapeLiteral", "(opL)o", $conn, $value, length $value); return $dbh->set_err(DBD::Pg::PGRES_FATAL, Peta::FFI::peek_cstr(DBD::Pg::_c("PQerrorMessage", "(o)o", $conn))) unless $p; my $quoted = Peta::FFI::peek_cstr($p); DBD::Pg::_c("PQfreemem", "(o)v", $p); return $quoted; } # quote.c quote_bool. The accepted spellings are exact and # length-checked upstream, which is why this is a set of anchored # alternations and not a truthiness test - '0 but true' is TRUE and # the empty string is FALSE. sub _q_bool { my ($dbh, $v) = @_; # Case-insensitive throughout: upstream compares with strncasecmp, # so '0 BUT TRUE' is as true as '0 but true'. return 'TRUE' if $v =~ /\A(?:t|1|true|0e0|0 but true)\z/i; return 'FALSE' if $v =~ /\A(?:f|0|false)\z/i || $v eq ''; die "Invalid boolean value\n"; } # quote.c quote_int: sign and spaces only BEFORE the first digit, # nothing but digits after it. Returned unquoted. sub _q_int { my ($dbh, $v) = @_; my $seendigit = 0; for my $c (split //, $v) { if ($c =~ /[0-9]/) { $seendigit = 1; next } next if !$seendigit && $c =~ /[ +-]/; die "Invalid integer\n"; } return $v; } # quote.c quote_float. The three specials are matched whole and # case-insensitively (upstream's strncasecmp passes len+1 so the NUL # is compared, making it an exact match); everything else may hold # only the characters a float can be spelled with. Deliberately does # NOT check the ORDER of those characters - upstream leaves that to # the server, and so do we. sub _q_float { my ($dbh, $v) = @_; die "Invalid float\n" if !length $v; return $v if $v =~ /\A(?:NaN|Infinity|-Infinity)\z/i; die "Invalid float\n" if $v =~ /[^0-9. +\-eE]/; return $v; } # quote.c quote_geom / quote_path / quote_circle: the same scan over # a widening character set - path adds square brackets, circle adds # angle brackets. Validated, then wrapped in plain single quotes; # nothing needs escaping because nothing that would has survived. # The message names the TYPE, not the family: 12placeholders.t # matches "Invalid input for path type" and "... circle type" # specifically, so a shared "geometric type" wording fails the very # assertions that check the wrong bracket was rejected. sub _q_geom { _q_geomish($_[1], '', 'geometric') } sub _q_path { _q_geomish($_[1], '\[\]', 'path') } sub _q_circle { _q_geomish($_[1], '<>', 'circle') } sub _q_geomish { my ($v, $extra, $what) = @_; die "Invalid input for $what type\n" if $v =~ /[^\t ()\-+.eE,0-9$extra]/; return "'$v'"; } # 473 PostgreSQL keywords, generated by regen-keywords.pl from # DBD-Pg-3.20.2 quote.c is_keyword(). Do not edit by hand. use constant MAX_KEYWORD_LENGTH => 17; my %KEYWORD = map { $_ => 1 } qw( abort absent absolute access action add admin after aggregate all also alter always analyse analyze and any array as asc asensitive assertion assignment asymmetric at atomic attach attribute authorization backward before begin between bigint binary bit boolean both breadth by cache call called cascade cascaded case cast catalog chain char character characteristics check checkpoint class close cluster coalesce collate collation column columns comment comments commit committed compression concurrently configuration conflict connection constraint constraints content continue conversion copy cost create cross csv cube current current_catalog current_date current_role current_schema current_time current_timestamp current_user cursor cycle data database day deallocate dec decimal declare default defaults deferrable deferred definer delete delimiter delimiters depends depth desc detach dictionary disable discard distinct do document domain double drop each else enable encoding encrypted end enum escape event except exclude excluding exclusive execute exists explain expression extension external extract false family fetch filter finalize first float following for force foreign format forward freeze from full function functions generated global grant granted greatest group grouping groups handler having header hold hour identity if ilike immediate immutable implicit import in include including increment indent index indexes inherit inherits initially inline inner inout input insensitive insert instead int integer intersect interval into invoker is isnull isolation join json json_array json_arrayagg json_object json_objectagg json_scalar json_serialize key keys label language large last lateral leading leakproof least left level like limit listen load local localtime localtimestamp location lock locked logged mapping match matched materialized maxvalue merge method minute minvalue mode month move name names national natural nchar new next nfc nfd nfkc nfkd no none normalize normalized not nothing notify notnull nowait null nullif nulls numeric object of off offset oids old on only operator option options or order ordinality others out outer over overlaps overlay overriding owned owner parallel parameter parser partial partition passing password placing plans policy position preceding precision prepare prepared preserve primary prior privileges procedural procedure procedures program publication quote range read real reassign recheck recursive ref references referencing refresh reindex relative release rename repeatable replace replica reset restart restrict return returning returns revoke right role rollback rollup routine routines row rows rule savepoint scalar schema schemas scroll search second security select sequence sequences serializable server session session_user set setof sets share show similar simple skip smallint snapshot some sql stable standalone start statement statistics stdin stdout storage stored strict strip subscription substring support symmetric sysid system system_user table tables tablesample tablespace temp template temporary text then ties time timestamp to trailing transaction transform treat trigger trim true truncate trusted type types uescape unbounded uncommitted unencrypted union unique unknown unlisten unlogged until update user using vacuum valid validate validator value values varchar variadic varying verbose version view views volatile when where whitespace window with within without work wrapper write xml xmlattributes xmlconcat xmlelement xmlexists xmlforest xmlnamespaces xmlparse xmlpi xmlroot xmlserialize xmltable year yes zone ); # quote.c quote_name: an identifier is left BARE only if it starts # [a-z_], contains only [a-z_0-9], and is not a reserved word. # Anything else gets double quotes, with inner quotes doubled. The # keyword check is the whole reason "user" is quoted and "userz" is # not - the character rules alone cannot tell them apart. sub _q_name { my ($dbh, $v) = @_; die "Empty identifier name\n" if !length $v; my $safe = $v =~ /\A[a-z_]/ && $v !~ /[^a-z_0-9]/; # Upstream's is_keyword refuses anything longer than the longest # keyword before looking, so a long safe identifier stays bare. return $v if $safe && (length($v) > MAX_KEYWORD_LENGTH || !$KEYWORD{$v}); (my $q = $v) =~ s/"/""/g; return qq{"$q"}; } # quote.c quote_bytea: the escaped-string literal form, NOT libpq's # PQescapeByteaConn. Two levels of escaping are in play - one for the # SQL string literal, one for bytea's own input syntax - which is why # a backslash becomes FOUR and a non-printable becomes \\NNN octal. # Emitted as E'...' so the doubling is read literally regardless of # standard_conforming_strings. sub _q_bytea { my ($dbh, $v) = @_; my $out = ''; for my $c (split //, $v) { if ($c eq "'") { $out .= "''" } elsif ($c eq "\\") { $out .= "\\\\\\\\" } elsif ($c lt "\x20" || $c gt "\x7e") { $out .= sprintf "\\\\%03o", ord $c; } else { $out .= $c } } return "E'$out'"; } # types.c sql_types[] and pg_types[], reduced to the only thing the # quoting path reads out of them. Built from DBI's own constants so a # transcribed number cannot be wrong. my (%SQL_QUOTE, %PG_QUOTE); sub _init_quote_tables { return if %SQL_QUOTE; %SQL_QUOTE = ( DBI::SQL_BOOLEAN() => \&_q_bool, DBI::SQL_CHAR() => \&_q_string, DBI::SQL_VARBINARY() => \&_q_bytea, DBI::SQL_BLOB() => \&_q_bytea, DBI::SQL_BINARY() => \&_q_bytea, DBI::SQL_LONGVARBINARY() => \&_q_bytea, DBI::SQL_TYPE_DATE() => \&_q_string, DBI::SQL_REAL() => \&_q_float, DBI::SQL_FLOAT() => \&_q_float, DBI::SQL_DOUBLE() => \&_q_float, DBI::SQL_SMALLINT() => \&_q_int, DBI::SQL_TINYINT() => \&_q_int, DBI::SQL_INTEGER() => \&_q_int, DBI::SQL_BIGINT() => \&_q_int, DBI::SQL_NUMERIC() => \&_q_float, DBI::SQL_DECIMAL() => \&_q_float, DBI::SQL_LONGVARCHAR() => \&_q_string, DBI::SQL_TYPE_TIME() => \&_q_string, DBI::SQL_TIMESTAMP() => \&_q_string, DBI::SQL_TYPE_TIMESTAMP() => \&_q_string, DBI::SQL_TYPE_TIMESTAMP_WITH_TIMEZONE() => \&_q_string, DBI::SQL_TYPE_TIME_WITH_TIMEZONE() => \&_q_string, DBI::SQL_VARCHAR() => \&_q_string, ); %PG_QUOTE = ( DBD::Pg::PG_BOOL() => \&_q_bool, DBD::Pg::PG_BYTEA() => \&_q_bytea, DBD::Pg::PG_INT2() => \&_q_int, DBD::Pg::PG_INT4() => \&_q_int, DBD::Pg::PG_INT8() => \&_q_int, DBD::Pg::PG_OID() => \&_q_int, DBD::Pg::PG_FLOAT4() => \&_q_float, DBD::Pg::PG_FLOAT8() => \&_q_float, DBD::Pg::PG_NUMERIC() => \&_q_float, DBD::Pg::PG_BOX() => \&_q_geom, DBD::Pg::PG_LINE() => \&_q_geom, DBD::Pg::PG_LSEG() => \&_q_geom, DBD::Pg::PG_POINT() => \&_q_geom, DBD::Pg::PG_POLYGON() => \&_q_geom, DBD::Pg::PG_TID() => \&_q_geom, DBD::Pg::PG_PATH() => \&_q_path, DBD::Pg::PG_CIRCLE() => \&_q_circle, DBD::Pg::PG_NAME() => \&_q_name, ); return; } sub quote { my ($dbh, $value, $type) = @_; # Pg.xs quote(): NULL is returned whatever the type, so the type # is not even looked at. return 'NULL' unless defined $value; # An arrayref quotes as the array LITERAL, then as a string - # `$dbh->quote([q{Quote's Test}])` is '{"Quote''s Test"}'. Without # this the arrayref stringified to ARRAY(0x...) and every array # test failed at the first INSERT, aborting the transaction and # cascading into 142 failures from one bug. $value = _stringify_array($value) if ref $value eq 'ARRAY'; _init_quote_tables(); my $quoter; if (!defined $type) { $quoter = \&_q_string; # PG_UNKNOWN } elsif (ref $type eq 'HASH') { $quoter = defined $type->{pg_type} ? $PG_QUOTE{ $type->{pg_type} } : defined $type->{type} ? $SQL_QUOTE{ $type->{type} } : undef; } elsif (ref $type) { die "Second argument to quote must be a hashref\n"; } else { $quoter = $SQL_QUOTE{$type}; } if (!$quoter) { warn "No type given, defaulting to UNKNOWN\n"; $quoter = \&_q_string; } return $quoter->($dbh, $value); } sub quote_identifier { my ($dbh, @id) = @_; my $conn = $dbh->{pg_conn}; my @out; for my $part (@id) { next unless defined $part; my $p = DBD::Pg::_c("PQescapeIdentifier", "(opL)o", $conn, $part, length $part); push @out, Peta::FFI::peek_cstr($p); DBD::Pg::_c("PQfreemem", "(o)v", $p); } return join '.', @out; } sub get_info { my ($dbh, $type) = @_; my %info = ( 17 => 'PostgreSQL', # SQL_DBMS_NAME 18 => $dbh->{pg_server_version}, # SQL_DBMS_VER 29 => '"', # SQL_IDENTIFIER_QUOTE_CHAR ); return $info{$type}; } sub disconnect { my $dbh = shift; if (my $conn = delete $dbh->{pg_conn}) { DBD::Pg::_c("PQfinish", "(o)v", $conn); } $dbh->STORE(Active => 0); return 1; } sub STORE { my ($dbh, $attrib, $value) = @_; if ($attrib eq 'AutoCommit') { my $old = $dbh->{pg_AutoCommit}; $value = $value ? 1 : 0; # dbdimp.c: switching AutoCommit ON inside a transaction # commits it. if ($value && !$old && $dbh->{pg_conn} && _txn($dbh) >= 2) { _simple_exec($dbh, 'commit'); } $dbh->{pg_AutoCommit} = $value; return 1; } # dbd_db_STORE_attrib, case pg_errorlevel: only 0, 1 and 2 are # verbosity levels; anything else is silently taken as the # default 1 rather than stored as given. The value is pushed # straight through to PQsetErrorVerbosity, so accepting a 3 here # would hand libpq an out-of-range enum. if ($attrib eq 'pg_errorlevel') { my $n = defined $value ? int $value : 1; $n = ($n == 0) ? 0 : ($n == 2) ? 2 : 1; if (my $conn = $dbh->{pg_conn}) { DBD::Pg::_c("PQsetErrorVerbosity", "(oi)i", $conn, $n); } return $dbh->{pg_errorlevel} = $n; } return $dbh->{$attrib} = $value if $attrib =~ /^pg_/; return $dbh->SUPER::STORE($attrib, $value); } # dbd_db_FETCH_attrib: the informational attributes are read LIVE # off the connection rather than snapshotted at connect, because # that is where libpq keeps them - PQdb() and friends answer from # the PGconn, and a reconnect changes them. my %conn_info = ( pg_db => [ 'PQdb', '(o)p' ], pg_user => [ 'PQuser', '(o)p' ], pg_pass => [ 'PQpass', '(o)p' ], pg_port => [ 'PQport', '(o)p' ], pg_host => [ 'PQhost', '(o)p' ], pg_options => [ 'PQoptions', '(o)p' ], pg_socket => [ 'PQsocket', '(o)i' ], pg_pid => [ 'PQbackendPID', '(o)i' ], pg_protocol => [ 'PQprotocolVersion', '(o)i' ], ); sub FETCH { my ($dbh, $attrib) = @_; return $dbh->{pg_AutoCommit} if $attrib eq 'AutoCommit'; # PGDEFPORT, a compile-time constant on the libpq side. return 5432 if $attrib eq 'pg_default_port'; # libpq-fs.h INV_WRITE / INV_READ, the large-object open modes. return 0x00020000 if $attrib eq 'pg_INV_WRITE'; return 0x00040000 if $attrib eq 'pg_INV_READ'; if (my $q = $conn_info{$attrib}) { my $conn = $dbh->{pg_conn} or return undef; return DBD::Pg::_c($q->[0], $q->[1], $conn); } return $dbh->{$attrib} if $attrib =~ /^pg_/; return $dbh->SUPER::FETCH($attrib); } sub DESTROY { my $dbh = shift; # dbd_db_destroy: "If the InactiveDestroy flag has been set, we # go no further". After a fork the child holds a COPY of the # PGconn but the same socket, so letting the child's DESTROY # disconnect tears down the PARENT's connection too. DBI sets # InactiveDestroy itself when AutoInactiveDestroy is on and the # pid has changed; honouring it is the driver's half. return if $dbh->{InactiveDestroy}; return unless $dbh->{pg_conn}; _simple_exec($dbh, 'rollback') if !$dbh->{pg_AutoCommit} && _txn($dbh) >= 2; $dbh->disconnect; } } { package DBD::Pg::st; our $imp_data_size = 0; # Pg.pm: an empty hashref on every handle class. sub private_attribute_info { return {} } # pg_st_placeholder_key(): a placeholder is keyed by its own NAME in # a ":foo" statement and by its 1-based number otherwise. ParamValues # and ParamTypes both use it, which is what makes their keys valid # bind_param() arguments - 02attribs.t feeds them straight back in. sub _placeholder_keys { my $sth = shift; my $np = $sth->FETCH('NUM_OF_PARAMS') || 0; my $names = $sth->{pg_param_names}; return [ 1 .. $np ] unless $names && %$names; my @keys = (1 .. $np); $keys[ $names->{$_} - 1 ] = ":$_" for keys %$names; return \@keys; } sub bind_param { my ($sth, $param, $value, $attr) = @_; # dbd_bind_ph: the placeholder is named in the statement's OWN # style, and the accepted spellings differ per style rather than # being a union. For :foo statements the name must carry the # colon; for ? and $N statements it must be digits with an # optional leading '$' - which is why `bind_param('$1', ...)` is # valid and was crashing here with "Modification of # non-creatable array value attempted, subscript -1" ('$1' - 1). my $names = $sth->{pg_param_names}; my $named = $names && %$names; if ($named) { die qq{Placeholders must begin with ':' when using the ":foo" style\n} unless $param =~ /\A:/; my ($bare) = $param =~ /\A:(.*)\z/s; die "Cannot bind unknown placeholder '$param'\n" unless exists $names->{$bare}; $param = $names->{$bare}; } else { # DBI also allows the positional form written ':N'. $param = $1 if $param =~ /\A:(\d+)\z/; die qq{Placeholder should be in the format "\$1"\n} unless $param =~ /\A\$?\d+\z/; $param =~ s/\A\$//; # dbdimp.c: "Cannot bind unknown placeholder %d". Outside # 1..NUM_OF_PARAMS is an error, not a slot to create. # Silently accepting it grew pg_params, and the NEXT execute # then failed with "called with 3 bind variables when 1 are # needed" - an error naming the wrong call, two tests later. my $np = $sth->FETCH('NUM_OF_PARAMS') || 0; die "Cannot bind unknown placeholder $param\n" if $param < 1 || $param > $np; } $sth->{pg_params}[$param - 1] = $value; # Reference: a type bound once persists across executes. bytea # ({pg_type => PG_BYTEA} or SQL (VAR)BINARY) switches that # parameter to binary wire format - the only way NUL bytes can # travel (text format is a C string). # dbd_bind_ph: pg_type is taken as-is; a sql_type is resolved # through sql_type_data()->type.pg, i.e. it binds as the # equivalent PostgreSQL type. Recording only bytea here left # ParamTypes blind to every other declared type. if (ref $attr && ($attr->{pg_type} || defined $attr->{TYPE})) { die "Cannot specify both sql_type and pg_type\n" if $attr->{pg_type} && defined $attr->{TYPE}; my $oid = $attr->{pg_type} || DBD::Pg::_pg_type_for_sql($attr->{TYPE}); die "Cannot bind param $param: unknown sql_type $attr->{TYPE}\n" if !$oid && !$attr->{pg_type}; $sth->{pg_param_oids}[$param - 1] = $oid if $oid; } elsif (defined $attr && !ref $attr) { my $oid = DBD::Pg::_pg_type_for_sql($attr); $sth->{pg_param_oids}[$param - 1] = $oid if $oid; } return 1; } # dbdimp.c dbd_bind_ph with is_inout: the value is a REFERENCE, read # at execute time (not at bind time - the caller may assign to the # variable in between), and after each fetch the corresponding column # is copied BACK into it, placeholder i <-> column i positionally. # PostgreSQL has no true OUT parameters; this is what DBD::Pg calls # its "experimental inout support" and it is what the DBI API means # here. # dbdimp.c dbd_st_cancel: PQgetCancel gives a thread-safe handle that # can be used from a signal handler while the connection is busy; # PQcancel sends the request. Both must be paired with PQfreeCancel. # # Worth having even though cancelling is niche: 03smethod.t invokes # it FROM a SIGALRM handler during a blocking execute, so an # unimplemented method dies inside a signal handler with libpq # mid-call, and the process aborted with "free(): invalid pointer" # rather than failing an assertion. sub cancel { my $sth = shift; my $dbh = $sth->{Database}; my $conn = $dbh->{pg_conn} or return undef; my $cancel = DBD::Pg::_c("PQgetCancel", "(o)o", $conn) or return undef; my $buf = Peta::FFI::alloc(256); my $rc = DBD::Pg::_c("PQcancel", "(opi)i", $cancel, $buf, 256); DBD::Pg::_c("PQfreeCancel", "(o)v", $cancel); if ($rc != 1) { my $msg = Peta::FFI::peek_cstr($buf); Peta::FFI::free($buf); return $sth->set_err(DBD::Pg::PGRES_FATAL, $msg || 'PQcancel failed'); } Peta::FFI::free($buf); return 1; } sub bind_param_inout { my ($sth, $param, $ref, $maxlen, $attr) = @_; die "bind_param_inout($param, $ref) needs a reference to a scalar\n" unless ref $ref eq 'SCALAR'; $sth->{pg_inout}[$param - 1] = $ref; return $sth->bind_param($param, $$ref, $attr); } sub execute { my ($sth, @bind) = @_; my $dbh = $sth->{Database}; my $conn = $dbh->{pg_conn} or return $sth->set_err(DBD::Pg::PGRES_FATAL, 'execute on disconnected handle'); DBD::Pg::db::_no_copy_in_progress($dbh); # Re-read every inout placeholder from its reference: the bound # value is whatever the variable holds NOW, not what it held when # bind_param_inout was called. # Bounded by THIS statement's placeholder count: the inout list # can outlive a re-prepare and be longer, and writing past the # count grows pg_params so execute then reports "called with 3 # bind variables when 1 are needed". if (my $io = $sth->{pg_inout}) { my $np = $sth->FETCH('NUM_OF_PARAMS') || 0; for my $i (0 .. $#$io) { last if $i >= $np; $sth->{pg_params}[$i] = ${ $io->[$i] } if ref $io->[$i]; } } if (@bind) { $sth->{pg_params} = [@bind]; } my $params = $sth->{pg_params}; my $nparams = $sth->FETCH('NUM_OF_PARAMS'); return $sth->set_err(DBD::Pg::PGRES_FATAL, 'called with ' . scalar(@$params) . " bind variables when $nparams are needed") if @$params != $nparams; DBD::Pg::db::_maybe_begin($dbh) or return undef; $sth->finish if $sth->FETCH('Active'); # dbdimp.c dbd_st_execute: only preparable DML may carry bound # parameters. PostgreSQL takes no parameters in DDL or utility # statements, so `SET search_path TO ?` sent through # PQexecParams fails with `syntax error at or near "$1"`. # Upstream's answer is not to special-case SET but to classify on # the FIRST WORD and route everything else through PQexec with # the values quoted in. my $direct = $nparams && !DBD::Pg::db::_is_dml($sth->{Statement}); # Marshal parameters: char*[] of NUL-terminated copies; an # unset slot stays NULL (calloc) = SQL NULL. Params typed bytea # additionally get paramTypes (Oid[]), paramLengths (int[]) and # paramFormats (int[], 1 = binary) so NUL bytes survive. my (@bufs, $vec, $types, $lens, $fmts); my $oids = $sth->{pg_param_oids}; # dbdimp.c: has_binary means "some parameter is BYTEA", NOT "some # parameter has a declared type". Only bytea travels in BINARY # wire format; everything else stays text even when its OID is # given. Conflating the two sent `bind_param(1, undef, {pg_type # => PG_INT4})` + execute(400) to the server as binary int4, i.e. # the three bytes "400" where four were promised, and the server # answered "insufficient data left in message" - which reads like # a bytea bug and is not one. my $have_binary = $oids && grep { defined $_ && $_ == DBD::Pg::BYTEAOID } @$oids; if ($nparams && !$direct) { $vec = Peta::FFI::alloc(8 * $nparams); if ($have_binary) { $types = Peta::FFI::alloc(4 * $nparams); $lens = Peta::FFI::alloc(4 * $nparams); $fmts = Peta::FFI::alloc(4 * $nparams); } for my $i (0 .. $nparams - 1) { my $v = $params->[$i]; # An arrayref parameter goes to the server as an array # LITERAL, same as quote() produces. Done here rather # than in bind_param so it covers both routes in - # bind_param($n, $aref) and execute($aref) - which is # also where dbdimp.c does it (dbd_bind_ph calls # pg_stringify_array). $v = DBD::Pg::db::_stringify_array($v) if ref $v eq q{ARRAY}; if ($have_binary) { my $oid = $oids->[$i] || 0; Peta::FFI::poke($types + 4 * $i, pack 'L', $oid); # Only bytea is binary. The others get length 0 and # format 0, exactly as dbdimp.c's else-branch does. my $bin = ($oid == DBD::Pg::BYTEAOID) ? 1 : 0; Peta::FFI::poke($fmts + 4 * $i, pack 'l', $bin); Peta::FFI::poke($lens + 4 * $i, pack 'l', ($bin && defined $v) ? length $v : 0); } next unless defined $v; my $b = Peta::FFI::alloc(length($v) + 1); Peta::FFI::poke($b, $v) if length $v; push @bufs, $b; Peta::FFI::poke($vec + 8 * $i, Peta::FFI::pack_ptr($b)); } } my $res; # An async statement goes out with PQsendQuery and returns # immediately; there is no result to describe until pg_result # collects one. Placeholders are interpolated for the same reason # the non-DML path does it - PQsendQuery has no parameter form. if ($sth->{pg_async} & DBD::Pg::PG_ASYNC) { my $sql = $nparams ? DBD::Pg::db::_interpolate($dbh, $sth, $params) : $sth->{pg_rewritten}; Peta::FFI::free($_) for grep { $_ } @bufs, $vec, $types, $lens, $fmts; return undef unless defined $sql; my $rc = DBD::Pg::_c("PQsendQuery", "(op)i", $conn, $sql); return DBD::Pg::db::_result_err($dbh, $conn, undef, DBD::Pg::PGRES_FATAL) unless $rc; $dbh->{pg_async_status} = 1; $sth->STORE(Active => 1); return '0E0'; } if ($direct) { my $sql = DBD::Pg::db::_interpolate($dbh, $sth, $params); return undef unless defined $sql; $res = DBD::Pg::_c("PQexec", "(op)o", $conn, $sql); } else { $res = DBD::Pg::_c("PQexecParams", "(opiooooi)o", $conn, $sth->{pg_rewritten}, $nparams, $types, $vec, $lens, $fmts, 0); } Peta::FFI::free($_) for grep { $_ } @bufs, $vec, $types, $lens, $fmts; my $status = $res ? DBD::Pg::_c("PQresultStatus", "(o)i", $res) : DBD::Pg::PGRES_FATAL; if ($status == DBD::Pg::PGRES_TUPLES_OK) { my $nf = DBD::Pg::_c("PQnfields", "(o)i", $res); my $nt = DBD::Pg::_c("PQntuples", "(o)i", $res); $sth->{pg_result} = $res; $sth->{pg_row} = 0; $sth->{pg_rows} = $nt; # dbd_st_FETCH_attrib reads these straight off imp_sth->result; # we capture them with the rest of the per-result metadata # because the handle may be re-executed against another one. $sth->{pg_cmd_status} = DBD::Pg::_c("PQcmdStatus", "(o)p", $res); $sth->{pg_oid_status} = DBD::Pg::_c("PQoidValue", "(o)i", $res); $sth->{pg_type} = [ map { DBD::Pg::_c("PQftype", "(oi)i", $res, $_) } 0 .. $nf - 1 ]; # Column metadata for PRECISION / SCALE / NULLABLE. Captured # here because it belongs to THIS result: the handle may be # re-executed against a different one, and PQ* on a cleared # result is undefined. $sth->{pg_fmod} = [ map { DBD::Pg::_c("PQfmod", "(oi)i", $res, $_) } 0 .. $nf - 1 ]; $sth->{pg_fsize} = [ map { DBD::Pg::_c("PQfsize", "(oi)i", $res, $_) } 0 .. $nf - 1 ]; $sth->{pg_ftable} = [ map { DBD::Pg::_c("PQftable", "(oi)i", $res, $_) } 0 .. $nf - 1 ]; $sth->{pg_ftablecol}= [ map { DBD::Pg::_c("PQftablecol","(oi)i", $res, $_) } 0 .. $nf - 1 ]; $sth->STORE(NUM_OF_FIELDS => $nf) unless ($sth->FETCH('NUM_OF_FIELDS') || 0) == $nf; $sth->{NAME} = [ map { DBD::Pg::_c("PQfname", "(oi)p", $res, $_) } 0 .. $nf - 1 ]; $sth->STORE(Active => 1); return $nt == 0 ? '0E0' : $nt; } if ($status == DBD::Pg::PGRES_COMMAND_OK) { my $ct = DBD::Pg::_c("PQcmdTuples", "(o)p", $res); $sth->{pg_cmd_status} = DBD::Pg::_c("PQcmdStatus", "(o)p", $res); $sth->{pg_oid_status} = DBD::Pg::_c("PQoidValue", "(o)i", $res); DBD::Pg::_c("PQclear", "(o)v", $res); $sth->{pg_rows} = length($ct) ? 0 + $ct : -1; # dbd_st_FETCH_attrib gates the description attributes on # imp_sth->result being non-NULL, then fills them with # DBIc_NUM_FIELDS entries - which is 0 for a non-SELECT, so # they read back as EMPTY aggregates, not undef. Undef means # "not executed yet" and nothing else; leaving these unset # after an UPDATE conflated the two states, and NAME_lc, # NAME_uc and the three _hash forms that DBI derives from # NAME went undef with it. $sth->{$_} = [] for qw( pg_type pg_fmod pg_fsize pg_ftable pg_ftablecol NAME ); return length($ct) ? ($ct == 0 ? '0E0' : 0 + $ct) : -1; } return DBD::Pg::db::_result_err($sth, $conn, $res, $status); } sub fetch { my $sth = shift; my $res = $sth->{pg_result} or return $sth->set_err(DBD::Pg::PGRES_FATAL, 'fetch without execute'); my $row = $sth->{pg_row}; if ($row >= $sth->{pg_rows}) { $sth->finish; return undef; } $sth->{pg_row} = $row + 1; my $types = $sth->{pg_type}; my $chop = $sth->FETCH('ChopBlanks'); my $utf8 = do { my $e = $sth->{Database}{pg_enable_utf8}; $e = -1 unless defined $e; $e == 1 ? 1 : $e == 0 ? 0 : (($sth->{Database}{pg_client_encoding} // '') eq 'UTF8') ? 1 : 0; }; my @out; for my $col (0 .. $#$types) { if (DBD::Pg::_c("PQgetisnull", "(oii)i", $res, $row, $col)) { push @out, undef; next; } my $t = $types->[$col]; if ($t == DBD::Pg::BYTEAOID) { # PQunescapeBytea gives the raw bytes + length out-param. my $vp = DBD::Pg::_c("PQgetvalue", "(oii)o", $res, $row, $col); my $cell = Peta::FFI::alloc(8); my $bp = DBD::Pg::_c("PQunescapeBytea", "(oo)o", $vp, $cell); my $blen = Peta::FFI::unpack_ptr(Peta::FFI::peek($cell, 8)); my $v = Peta::FFI::peek($bp, $blen); DBD::Pg::_c("PQfreemem", "(o)v", $bp); Peta::FFI::free($cell); push @out, $v; next; } my $v = DBD::Pg::_c("PQgetvalue", "(oii)p", $res, $row, $col); # pg_enable_utf8: 1 = always decode, 0 = never, -1 (default) # = decode iff client_encoding is UTF8. bytea is excluded and # never reaches here - it returned above. Decoding is what # sets the UTF-8 FLAG on the returned scalar, which is what # 30unicode.t actually asserts; the bytes were already right. if ($utf8) { # utf8::decode alone is not enough: on PURE ASCII it # succeeds and leaves the flag OFF, because the two # representations are identical. Upstream's XS calls # SvUTF8_on unconditionally, and 30unicode.t checks the # FLAG ("upgraded ascii ... returns string with correct # UTF-8 flag"), so force it up. Only when the decode # actually succeeded - upgrading undecodable bytes would # reinterpret them as latin-1 and mangle the value. if (utf8::decode($v)) { utf8::upgrade($v) unless utf8::is_utf8($v); } } if ($t == DBD::Pg::BOOLOID) { # dbdimp.c: bool comes back 't'/'f', presented as 1/0. $v = $v eq 't' ? 1 : 0; } elsif ($DBD::Pg::ARRAY_OID{$t}) { my $expand = $sth->{Database}{pg_expand_array}; $expand = 1 unless defined $expand; # upstream default if ($expand) { $v = DBD::Pg::db::_expand_array($v); # A bool[] carries 't'/'f' per element, and upstream # presents those as 1/0 exactly as it does a scalar # bool - the elements are not left as letters. if ($t == DBD::Pg::PG_BOOLARRAY) { my $fix; $fix = sub { for my $e (@{ $_[0] }) { if (ref $e eq 'ARRAY') { $fix->($e) } elsif (defined $e) { $e = $e eq 't' ? 1 : 0 } } }; $fix->($v) if ref $v eq 'ARRAY'; } } } elsif ($chop && $t == DBD::Pg::BPCHAROID) { $v =~ s/\s+\z//; } push @out, $v; } # dbd_st_fetch: copy field i back into inout placeholder i. if (my $io = $sth->{pg_inout}) { for my $i (0 .. $#$io) { ${ $io->[$i] } = $out[$i] if ref $io->[$i] && $i <= $#out; } } return $sth->_set_fbav(\@out); } *fetchrow_arrayref = \&fetch; sub rows { defined $_[0]->{pg_rows} ? $_[0]->{pg_rows} : -1 } sub finish { my $sth = shift; if (my $res = delete $sth->{pg_result}) { DBD::Pg::_c("PQclear", "(o)v", $res); } $sth->SUPER::finish; return 1; } # 170 type OID -> name pairs, generated by regen-typenames.pl # from DBD-Pg-3.20.2 types.c pg_types[]. Do not edit by hand. my %TYPENAME = ( 16 => 'bool', 17 => 'bytea', 18 => 'char', 19 => 'name', 20 => 'int8', 21 => 'int2', 22 => 'int2vector', 23 => 'int4', 24 => 'regproc', 25 => 'text', 26 => 'oid', 27 => 'tid', 28 => 'xid', 29 => 'cid', 30 => 'oidvector', 114 => 'json', 142 => 'xml', 143 => '_xml', 199 => '_json', 271 => '_xid8', 600 => 'point', 601 => 'lseg', 602 => 'path', 603 => 'box', 604 => 'polygon', 628 => 'line', 629 => '_line', 650 => 'cidr', 651 => '_cidr', 700 => 'float4', 701 => 'float8', 705 => 'unknown', 718 => 'circle', 719 => '_circle', 774 => 'macaddr8', 775 => '_macaddr8', 790 => 'money', 791 => '_money', 829 => 'macaddr', 869 => 'inet', 1000 => '_bool', 1001 => '_bytea', 1002 => '_char', 1003 => '_name', 1005 => '_int2', 1006 => '_int2vector', 1007 => '_int4', 1008 => '_regproc', 1009 => '_text', 1010 => '_tid', 1011 => '_xid', 1012 => '_cid', 1013 => '_oidvector', 1014 => '_bpchar', 1015 => '_varchar', 1016 => '_int8', 1017 => '_point', 1018 => '_lseg', 1019 => '_path', 1020 => '_box', 1021 => '_float4', 1022 => '_float8', 1027 => '_polygon', 1028 => '_oid', 1033 => 'aclitem', 1034 => '_aclitem', 1040 => '_macaddr', 1041 => '_inet', 1042 => 'bpchar', 1043 => 'varchar', 1082 => 'date', 1083 => 'time', 1114 => 'timestamp', 1115 => '_timestamp', 1182 => '_date', 1183 => '_time', 1184 => 'timestamptz', 1185 => '_timestamptz', 1186 => 'interval', 1187 => '_interval', 1231 => '_numeric', 1263 => '_cstring', 1266 => 'timetz', 1270 => '_timetz', 1560 => 'bit', 1561 => '_bit', 1562 => 'varbit', 1563 => '_varbit', 1700 => 'numeric', 1790 => 'refcursor', 2201 => '_refcursor', 2202 => 'regprocedure', 2203 => 'regoper', 2204 => 'regoperator', 2205 => 'regclass', 2206 => 'regtype', 2207 => '_regprocedure', 2208 => '_regoper', 2209 => '_regoperator', 2210 => '_regclass', 2211 => '_regtype', 2249 => 'record', 2275 => 'cstring', 2276 => 'any', 2277 => 'anyarray', 2278 => 'void', 2279 => 'trigger', 2281 => 'internal', 2283 => 'anyelement', 2287 => '_record', 2776 => 'anynonarray', 2950 => 'uuid', 2951 => '_uuid', 3500 => 'anyenum', 3614 => 'tsvector', 3615 => 'tsquery', 3642 => 'gtsvector', 3643 => '_tsvector', 3644 => '_gtsvector', 3645 => '_tsquery', 3734 => 'regconfig', 3735 => '_regconfig', 3769 => 'regdictionary', 3770 => '_regdictionary', 3802 => 'jsonb', 3807 => '_jsonb', 3831 => 'anyrange', 3904 => 'int4range', 3905 => '_int4range', 3906 => 'numrange', 3907 => '_numrange', 3908 => 'tsrange', 3909 => '_tsrange', 3910 => 'tstzrange', 3911 => '_tstzrange', 3912 => 'daterange', 3913 => '_daterange', 3926 => 'int8range', 3927 => '_int8range', 4072 => 'jsonpath', 4073 => '_jsonpath', 4089 => 'regnamespace', 4090 => '_regnamespace', 4096 => 'regrole', 4097 => '_regrole', 4191 => 'regcollation', 4192 => '_regcollation', 4451 => 'int4multirange', 4532 => 'nummultirange', 4533 => 'tsmultirange', 4534 => 'tstzmultirange', 4535 => 'datemultirange', 4536 => 'int8multirange', 4537 => 'anymultirange', 4538 => 'anycompatiblemultirange', 5069 => 'xid8', 5077 => 'anycompatible', 5078 => 'anycompatiblearray', 5079 => 'anycompatiblenonarray', 5080 => 'anycompatiblerange', 6150 => '_int4multirange', 6151 => '_nummultirange', 6152 => '_tsmultirange', 6153 => '_tstzmultirange', 6155 => '_datemultirange', 6157 => '_int8multirange', 8256 => 'oid8', 8261 => '_oid8', 8326 => 'regdatabase', 8327 => '_regdatabase', ); sub FETCH { my ($sth, $attrib) = @_; # The result-description attributes are UNDEF until the # statement has been executed - DBI's contract, and 02attribs.t # checks each one both before and after. We were returning an # empty-but-defined arrayref from prepare onwards, so every # "returns undef before execute" assertion saw ARRAY(0x...). if ($attrib eq 'TYPE') { return undef unless $sth->{pg_type}; return [ map { DBD::Pg::_sql_type($_) } @{ $sth->{pg_type} } ]; } # dbd_st_FETCH_attrib returns type_info[i]->type_name, i.e. the # NAME ('int4'), while the OIDs stay internal for output # conversion. Only the outer handle reaches this, so the driver's # own direct reads of {pg_type} still see the OIDs. if ($attrib eq 'pg_type') { return undef unless $sth->{pg_type}; return [ map { $TYPENAME{$_} } @{ $sth->{pg_type} } ]; } # The in-flight state is per CONNECTION, so the statement-handle # spelling reports the database handle's - which is why 02attribs # asserts the same value through both in the same breath. if ($attrib eq 'pg_async_status') { my $dbh = $sth->{Database}; return $dbh ? ($dbh->{pg_async_status} || 0) : 0; } # dbdimp.c dbd_st_FETCH_attrib, case PRECISION: char types report # their typmod, numeric the precision packed into its high half, # everything else the fixed type width. A non-positive result is # undef, not 0 - that is how variable-width types say "no fixed # precision". if ($attrib eq 'PRECISION') { return undef unless $sth->{pg_type}; my @out; for my $i (0 .. $#{ $sth->{pg_type} }) { my $o = $sth->{pg_type}[$i]; my $sz; if ($o == DBD::Pg::PG_BPCHAR || $o == DBD::Pg::PG_VARCHAR) { $sz = $sth->{pg_fmod}[$i]; } elsif ($o == DBD::Pg::PG_NUMERIC) { $sz = $sth->{pg_fmod}[$i] - 4; $sz = $sz >> 16 if $sz > 0; } else { $sz = $sth->{pg_fsize}[$i]; } push @out, ($sz > 0 ? $sz : undef); } return \@out; } # case SCALE: only numeric has one. The expression is upstream's # verbatim, odd as it looks - o % (o >> 16) on the typmod less # the header. if ($attrib eq 'SCALE') { return undef unless $sth->{pg_type}; my @out; for my $i (0 .. $#{ $sth->{pg_type} }) { if ($sth->{pg_type}[$i] == DBD::Pg::PG_NUMERIC) { my $o = $sth->{pg_fmod}[$i] - 4; push @out, ($o >> 16) ? $o % ($o >> 16) : undef; } else { push @out, undef } } return \@out; } # case NULLABLE: 0 = not nullable, 1 = nullable, 2 = unknown. # Only a column traceable to a real table can be resolved, via # pg_attribute.attnotnull; a computed column stays 2, which is # why a SELECT of literals reports [2,2] rather than [1,1]. if ($attrib eq 'NULLABLE') { return undef unless $sth->{pg_type}; my $dbh = $sth->{Database}; my @out; for my $i (0 .. $#{ $sth->{pg_type} }) { my $tbl = $sth->{pg_ftable}[$i] // 0; my $col = $sth->{pg_ftablecol}[$i] // 0; my $nullable = 2; if ($tbl && $tbl != 4294967295 && $col > 0) { # InvalidOid my $r = $dbh->selectrow_arrayref( 'SELECT attnotnull FROM pg_catalog.pg_attribute' . " WHERE attrelid=$tbl AND attnum=$col"); if ($r && defined $r->[0]) { $nullable = ($r->[0] eq 't' || $r->[0] eq '1') ? 0 : 1; } } push @out, $nullable; } return \@out; } # DBI standard: hashrefs keyed by 1-based placeholder number. # ParamValues is what was bound; ParamTypes the declared types. # Both are readable BEFORE execute, unlike the result-description # attributes above, because they describe the INPUT side. if ($attrib eq 'ParamValues') { my $p = $sth->{pg_params} || []; my $k = _placeholder_keys($sth); return { map { $k->[$_ - 1] => $p->[$_ - 1] } 1 .. scalar @$k }; } # dbd_st_FETCH_attrib, case ParamTypes: one entry per # PLACEHOLDER - unbound ones included, with the value undef - # and the value reports TYPE when the bound pg type has a SQL # equivalent, pg_type when it has none (circle, point, ...). if ($attrib eq 'ParamTypes') { my $o = $sth->{pg_param_oids} || []; my $k = _placeholder_keys($sth); my %out; for my $i (1 .. scalar @$k) { my $oid = $o->[$i - 1]; if (!defined $oid) { $out{ $k->[$i - 1] } = undef; next } my $sql = DBD::Pg::_sql_type_raw($oid); $out{ $k->[$i - 1] } = defined $sql ? { TYPE => $sql } : { pg_type => $oid }; } return \%out; } return $sth->{$attrib} if $attrib eq 'NAME' || $attrib =~ /^pg_/; return $sth->SUPER::FETCH($attrib); } sub STORE { my ($sth, $attrib, $value) = @_; return $sth->{$attrib} = $value if $attrib eq 'NAME' || $attrib =~ /^pg_/; return $sth->SUPER::STORE($attrib, $value); } sub DESTROY { my $sth = shift; # dbd_st_destroy: same InactiveDestroy short-circuit as the db # handle - finishing here would talk to a connection this # process does not own. return if $sth->{InactiveDestroy}; $sth->finish if $sth->{pg_result}; } } 1;