← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:15 2021

Filename/usr/local/lib/perl5/site_perl/mach/5.32/DBD/Pg.pm
StatementsExecuted 35 statements in 6.81ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
1116.56ms6.56msDBD::Pg::db::::_login DBD::Pg::db::_login (xsub)
21196µs96µsDBD::Pg::db::::_ping DBD::Pg::db::_ping (xsub)
11157µs6.67msDBD::Pg::dr::::connect DBD::Pg::dr::connect
32133µs140µsDBD::Pg::db::::prepare DBD::Pg::db::prepare
21120µs124µsDBD::Pg::db::::ping DBD::Pg::db::ping
31119µs19µsDBD::Pg::st::::_prepare DBD::Pg::st::_prepare (xsub)
1117µs7µsDBD::Pg::dr::::CORE:subst DBD::Pg::dr::CORE:subst (opcode)
2114µs4µsDBD::Pg::dr::::CORE:match DBD::Pg::dr::CORE:match (opcode)
0000s0sDBD::Pg::::BEGIN@19 DBD::Pg::BEGIN@19
0000s0sDBD::Pg::::BEGIN@21 DBD::Pg::BEGIN@21
0000s0sDBD::Pg::::BEGIN@22 DBD::Pg::BEGIN@22
0000s0sDBD::Pg::::BEGIN@23 DBD::Pg::BEGIN@23
0000s0sDBD::Pg::::BEGIN@24 DBD::Pg::BEGIN@24
0000s0sDBD::Pg::::BEGIN@27 DBD::Pg::BEGIN@27
0000s0sDBD::Pg::::CLONE DBD::Pg::CLONE
0000s0sDBD::Pg::DefaultValue::::newDBD::Pg::DefaultValue::new
0000s0sDBD::Pg::::bootstrap DBD::Pg::bootstrap (xsub)
0000s0sDBD::Pg::db::::BEGIN@1567 DBD::Pg::db::BEGIN@1567
0000s0sDBD::Pg::db::::BEGIN@292 DBD::Pg::db::BEGIN@292
0000s0sDBD::Pg::db::::BEGIN@294 DBD::Pg::db::BEGIN@294
0000s0sDBD::Pg::db::::__ANON__[:1362] DBD::Pg::db::__ANON__[:1362]
0000s0sDBD::Pg::db::::__ANON__[:1425] DBD::Pg::db::__ANON__[:1425]
0000s0sDBD::Pg::db::::_calc_col_size DBD::Pg::db::_calc_col_size
0000s0sDBD::Pg::db::::_prepare_from_data DBD::Pg::db::_prepare_from_data
0000s0sDBD::Pg::db::::column_info DBD::Pg::db::column_info
0000s0sDBD::Pg::db::::foreign_key_info DBD::Pg::db::foreign_key_info
0000s0sDBD::Pg::db::::get_info DBD::Pg::db::get_info
0000s0sDBD::Pg::db::::last_insert_id DBD::Pg::db::last_insert_id
0000s0sDBD::Pg::db::::parse_trace_flag DBD::Pg::db::parse_trace_flag
0000s0sDBD::Pg::db::::pg_ping DBD::Pg::db::pg_ping
0000s0sDBD::Pg::db::::pg_type_info DBD::Pg::db::pg_type_info
0000s0sDBD::Pg::db::::primary_key DBD::Pg::db::primary_key
0000s0sDBD::Pg::db::::primary_key_info DBD::Pg::db::primary_key_info
0000s0sDBD::Pg::db::::private_attribute_info DBD::Pg::db::private_attribute_info
0000s0sDBD::Pg::db::::statistics_info DBD::Pg::db::statistics_info
0000s0sDBD::Pg::db::::table_attributes DBD::Pg::db::table_attributes
0000s0sDBD::Pg::db::::table_info DBD::Pg::db::table_info
0000s0sDBD::Pg::db::::tables DBD::Pg::db::tables
0000s0sDBD::Pg::db::::type_info_all DBD::Pg::db::type_info_all
0000s0sDBD::Pg::dr::::BEGIN@214 DBD::Pg::dr::BEGIN@214
0000s0sDBD::Pg::dr::::data_sources DBD::Pg::dr::data_sources
0000s0sDBD::Pg::dr::::private_attribute_info DBD::Pg::dr::private_attribute_info
0000s0sDBD::Pg::::driver DBD::Pg::driver
0000s0sDBD::Pg::::parse_trace_flag DBD::Pg::parse_trace_flag
0000s0sDBD::Pg::::parse_trace_flags DBD::Pg::parse_trace_flags
0000s0sDBD::Pg::st::::bind_param_array DBD::Pg::st::bind_param_array
0000s0sDBD::Pg::st::::parse_trace_flag DBD::Pg::st::parse_trace_flag
0000s0sDBD::Pg::st::::private_attribute_info DBD::Pg::st::private_attribute_info
0000s0sSympa::Database::::BEGIN@12 Sympa::Database::BEGIN@12
0000s0sSympa::Database::::BEGIN@13 Sympa::Database::BEGIN@13
0000s0sSympa::Database::::BEGIN@14 Sympa::Database::BEGIN@14
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1# -*-cperl-*-
2#
3# Copyright (c) 2002-2021 Greg Sabino Mullane and others: see the Changes file
4# Portions Copyright (c) 2002 Jeffrey W. Baker
5# Portions Copyright (c) 1997-2001 Edmund Mergl
6# Portions Copyright (c) 1994-1997 Tim Bunce
7#
8# You may distribute under the terms of either the GNU General Public
9# License or the Artistic License, as specified in the Perl README file.
10
11
12use strict;
13use warnings;
14use 5.008001;
15
16{
17 package DBD::Pg;
18
19 use version; our $VERSION = qv('3.15.0');
20
21 use DBI ();
22 use DynaLoader ();
23 use Exporter ();
24 use vars qw(@ISA %EXPORT_TAGS $err $errstr $sqlstate $drh $dbh $DBDPG_DEFAULT @EXPORT);
25 @ISA = qw(DynaLoader Exporter);
26
27 use constant {
28 PG_MIN_SMALLINT => -32768,
29 PG_MAX_SMALLINT => 32767,
30 PG_MIN_INTEGER => -2147483648,
31 PG_MAX_INTEGER => 2147483647,
32 PG_MIN_BIGINT => '-9223372036854775808',
33 PG_MAX_BIGINT => '9223372036854775807',
34 PG_MIN_SMALLSERIAL => 1,
35 PG_MAX_SMALLSERIAL => 32767,
36 PG_MIN_SERIAL => 1,
37 PG_MAX_SERIAL => 2147483647,
38 PG_MIN_BIGSERIAL => 1,
39 PG_MAX_BIGSERIAL => '9223372036854775807',
40 };
41
42 %EXPORT_TAGS =
43 (
44 async => [qw($DBDPG_DEFAULT PG_ASYNC PG_OLDQUERY_CANCEL PG_OLDQUERY_WAIT)],
45 pg_limits => [qw($DBDPG_DEFAULT
46 PG_MIN_SMALLINT PG_MAX_SMALLINT PG_MIN_INTEGER PG_MAX_INTEGER PG_MAX_BIGINT PG_MIN_BIGINT
47 PG_MIN_SMALLSERIAL PG_MAX_SMALLSERIAL PG_MIN_SERIAL PG_MAX_SERIAL PG_MIN_BIGSERIAL PG_MAX_BIGSERIAL)],
48 pg_types => [qw($DBDPG_DEFAULT PG_ASYNC PG_OLDQUERY_CANCEL PG_OLDQUERY_WAIT
49 PG_ACLITEM PG_ACLITEMARRAY PG_ANY PG_ANYARRAY PG_ANYCOMPATIBLE
50 PG_ANYCOMPATIBLEARRAY PG_ANYCOMPATIBLEMULTIRANGE PG_ANYCOMPATIBLENONARRAY PG_ANYCOMPATIBLERANGE PG_ANYELEMENT
51 PG_ANYENUM PG_ANYMULTIRANGE PG_ANYNONARRAY PG_ANYRANGE PG_BIT
52 PG_BITARRAY PG_BOOL PG_BOOLARRAY PG_BOX PG_BOXARRAY
53 PG_BPCHAR PG_BPCHARARRAY PG_BYTEA PG_BYTEAARRAY PG_CHAR
54 PG_CHARARRAY PG_CID PG_CIDARRAY PG_CIDR PG_CIDRARRAY
55 PG_CIRCLE PG_CIRCLEARRAY PG_CSTRING PG_CSTRINGARRAY PG_DATE
56 PG_DATEARRAY PG_DATEMULTIRANGE PG_DATEMULTIRANGEARRAY PG_DATERANGE PG_DATERANGEARRAY
57 PG_EVENT_TRIGGER PG_FDW_HANDLER PG_FLOAT4 PG_FLOAT4ARRAY PG_FLOAT8
58 PG_FLOAT8ARRAY PG_GTSVECTOR PG_GTSVECTORARRAY PG_INDEX_AM_HANDLER PG_INET
59 PG_INETARRAY PG_INT2 PG_INT2ARRAY PG_INT2VECTOR PG_INT2VECTORARRAY
60 PG_INT4 PG_INT4ARRAY PG_INT4MULTIRANGE PG_INT4MULTIRANGEARRAY PG_INT4RANGE
61 PG_INT4RANGEARRAY PG_INT8 PG_INT8ARRAY PG_INT8MULTIRANGE PG_INT8MULTIRANGEARRAY
62 PG_INT8RANGE PG_INT8RANGEARRAY PG_INTERNAL PG_INTERVAL PG_INTERVALARRAY
63 PG_JSON PG_JSONARRAY PG_JSONB PG_JSONBARRAY PG_JSONPATH
64 PG_JSONPATHARRAY PG_LANGUAGE_HANDLER PG_LINE PG_LINEARRAY PG_LSEG
65 PG_LSEGARRAY PG_MACADDR PG_MACADDR8 PG_MACADDR8ARRAY PG_MACADDRARRAY
66 PG_MONEY PG_MONEYARRAY PG_NAME PG_NAMEARRAY PG_NUMERIC
67 PG_NUMERICARRAY PG_NUMMULTIRANGE PG_NUMMULTIRANGEARRAY PG_NUMRANGE PG_NUMRANGEARRAY
68 PG_OID PG_OIDARRAY PG_OIDVECTOR PG_OIDVECTORARRAY PG_PATH
69 PG_PATHARRAY PG_PG_ATTRIBUTE PG_PG_ATTRIBUTEARRAY PG_PG_BRIN_BLOOM_SUMMARY PG_PG_BRIN_MINMAX_MULTI_SUMMARY
70 PG_PG_CLASS PG_PG_CLASSARRAY PG_PG_DDL_COMMAND PG_PG_DEPENDENCIES PG_PG_LSN
71 PG_PG_LSNARRAY PG_PG_MCV_LIST PG_PG_NDISTINCT PG_PG_NODE_TREE PG_PG_PROC
72 PG_PG_PROCARRAY PG_PG_SNAPSHOT PG_PG_SNAPSHOTARRAY PG_PG_TYPE PG_PG_TYPEARRAY
73 PG_POINT PG_POINTARRAY PG_POLYGON PG_POLYGONARRAY PG_RECORD
74 PG_RECORDARRAY PG_REFCURSOR PG_REFCURSORARRAY PG_REGCLASS PG_REGCLASSARRAY
75 PG_REGCOLLATION PG_REGCOLLATIONARRAY PG_REGCONFIG PG_REGCONFIGARRAY PG_REGDICTIONARY
76 PG_REGDICTIONARYARRAY PG_REGNAMESPACE PG_REGNAMESPACEARRAY PG_REGOPER PG_REGOPERARRAY
77 PG_REGOPERATOR PG_REGOPERATORARRAY PG_REGPROC PG_REGPROCARRAY PG_REGPROCEDURE
78 PG_REGPROCEDUREARRAY PG_REGROLE PG_REGROLEARRAY PG_REGTYPE PG_REGTYPEARRAY
79 PG_TABLE_AM_HANDLER PG_TEXT PG_TEXTARRAY PG_TID PG_TIDARRAY
80 PG_TIME PG_TIMEARRAY PG_TIMESTAMP PG_TIMESTAMPARRAY PG_TIMESTAMPTZ
81 PG_TIMESTAMPTZARRAY PG_TIMETZ PG_TIMETZARRAY PG_TRIGGER PG_TSMULTIRANGE
82 PG_TSMULTIRANGEARRAY PG_TSM_HANDLER PG_TSQUERY PG_TSQUERYARRAY PG_TSRANGE
83 PG_TSRANGEARRAY PG_TSTZMULTIRANGE PG_TSTZMULTIRANGEARRAY PG_TSTZRANGE PG_TSTZRANGEARRAY
84 PG_TSVECTOR PG_TSVECTORARRAY PG_TXID_SNAPSHOT PG_TXID_SNAPSHOTARRAY PG_UNKNOWN
85 PG_UUID PG_UUIDARRAY PG_VARBIT PG_VARBITARRAY PG_VARCHAR
86 PG_VARCHARARRAY PG_VOID PG_XID PG_XID8 PG_XID8ARRAY
87 PG_XIDARRAY PG_XML PG_XMLARRAY
88 )],
89 );
90
91 {
92 package DBD::Pg::DefaultValue;
93 sub new { my $self = {}; return bless $self, shift; }
94 }
95 $DBDPG_DEFAULT = DBD::Pg::DefaultValue->new();
96 Exporter::export_ok_tags('pg_types', 'async', 'pg_limits');
97 @EXPORT = qw($DBDPG_DEFAULT PG_ASYNC PG_OLDQUERY_CANCEL PG_OLDQUERY_WAIT PG_BYTEA);
98
99 require_version DBI 1.614;
100
101 bootstrap DBD::Pg $VERSION;
102
103 $err = 0; # holds error code for DBI::err
104 $errstr = ''; # holds error string for DBI::errstr
105 $sqlstate = ''; # holds five character SQLSTATE code
106 $drh = undef; # holds driver handle once initialized
107
108 ## These two methods are here to allow calling before connect()
109 sub parse_trace_flag {
110 my ($class, $flag) = @_;
111 return (0x7FFFFF00 - 0x08000000) if $flag eq 'DBD'; ## all but the prefix
112 return 0x01000000 if $flag eq 'pglibpq';
113 return 0x02000000 if $flag eq 'pgstart';
114 return 0x04000000 if $flag eq 'pgend';
115 return 0x08000000 if $flag eq 'pgprefix';
116 return 0x10000000 if $flag eq 'pglogin';
117 return 0x20000000 if $flag eq 'pgquote';
118 return DBI::parse_trace_flag($class, $flag);
119 }
120 sub parse_trace_flags {
121 my ($class, $flags) = @_;
122 return DBI::parse_trace_flags($class, $flags);
123 }
124
125 ## Both CLONE and driver are required by DBI, see perldoc DBI::DBD
126
127 sub CLONE {
128 $drh = undef;
129 return;
130 }
131
132 my $methods_are_installed = 0;
133
134 sub driver {
135
136 return $drh if defined $drh;
137
138 my $class = shift;
139
140 $class .= '::dr';
141
142 ## Work around for issue found in https://rt.cpan.org/Ticket/Display.html?id=83057
143 my $realversion = qv('3.15.0');
144
145 $drh = DBI::_new_drh($class, {
146 'Name' => 'Pg',
147 'Version' => $realversion,
148 'Err' => \$DBD::Pg::err,
149 'Errstr' => \$DBD::Pg::errstr,
150 'State' => \$DBD::Pg::sqlstate,
151 'Attribution' => "DBD::Pg $realversion by Greg Sabino Mullane and others",
152 });
153
154 # uncoverable branch false
155 if (!$methods_are_installed) {
156 DBD::Pg::db->install_method('pg_cancel');
157 DBD::Pg::db->install_method('pg_endcopy');
158 DBD::Pg::db->install_method('pg_error_field');
159 DBD::Pg::db->install_method('pg_getline');
160 DBD::Pg::db->install_method('pg_getcopydata');
161 DBD::Pg::db->install_method('pg_getcopydata_async');
162 DBD::Pg::db->install_method('pg_notifies');
163 DBD::Pg::db->install_method('pg_putcopydata');
164 DBD::Pg::db->install_method('pg_putcopyend');
165 DBD::Pg::db->install_method('pg_ping');
166 DBD::Pg::db->install_method('pg_putline');
167 DBD::Pg::db->install_method('pg_ready');
168 DBD::Pg::db->install_method('pg_release');
169 DBD::Pg::db->install_method('pg_result'); ## NOT duplicated below!
170 DBD::Pg::db->install_method('pg_rollback_to');
171 DBD::Pg::db->install_method('pg_savepoint');
172 DBD::Pg::db->install_method('pg_server_trace');
173 DBD::Pg::db->install_method('pg_server_untrace');
174 DBD::Pg::db->install_method('pg_type_info');
175
176 DBD::Pg::st->install_method('pg_cancel');
177 DBD::Pg::st->install_method('pg_result');
178 DBD::Pg::st->install_method('pg_ready');
179 DBD::Pg::st->install_method('pg_canonical_ids');
180 DBD::Pg::st->install_method('pg_canonical_names');
181
182 DBD::Pg::db->install_method('pg_lo_creat');
183 DBD::Pg::db->install_method('pg_lo_open');
184 DBD::Pg::db->install_method('pg_lo_write');
185 DBD::Pg::db->install_method('pg_lo_read');
186 DBD::Pg::db->install_method('pg_lo_lseek');
187 DBD::Pg::db->install_method('pg_lo_lseek64');
188 DBD::Pg::db->install_method('pg_lo_tell');
189 DBD::Pg::db->install_method('pg_lo_tell64');
190 DBD::Pg::db->install_method('pg_lo_truncate');
191 DBD::Pg::db->install_method('pg_lo_truncate64');
192 DBD::Pg::db->install_method('pg_lo_close');
193 DBD::Pg::db->install_method('pg_lo_unlink');
194 DBD::Pg::db->install_method('pg_lo_import');
195 DBD::Pg::db->install_method('pg_lo_import_with_oid');
196 DBD::Pg::db->install_method('pg_lo_export');
197
198 $methods_are_installed++;
199 }
200
201 return $drh;
202
203 } ## end of driver
204
205
206 1;
207
208} ## end of package DBD::Pg
209
210
211{
212 package DBD::Pg::dr;
213
214 use strict;
215
216 ## Returns an array of formatted database names from the pg_database table
217 sub data_sources {
218
219 my $drh = shift;
220 my $conninfo = shift || '';
221 my $connstring = 'dbname=postgres';
222 if ($ENV{DBI_DSN}) {
223 ($connstring = $ENV{DBI_DSN}) =~ s/dbi:Pg://i;
224 }
225 if (length $conninfo) {
226 $connstring .= ";$conninfo";
227 }
228
229 my $dbh = DBD::Pg::dr::connect($drh, $connstring) or return;
230 $dbh->{AutoCommit}=1;
231 my $SQL = 'SELECT pg_catalog.quote_ident(datname) FROM pg_catalog.pg_database ORDER BY 1';
232 my $sth = $dbh->prepare($SQL);
233 $sth->execute();
234 $conninfo and $conninfo = ";$conninfo";
235 my @sources = map { "dbi:Pg:dbname=$_->[0]$conninfo" } @{$sth->fetchall_arrayref()};
236 $dbh->disconnect;
237 return @sources;
238 }
239
240
241
# spent 6.67ms (57µs+6.61) within DBD::Pg::dr::connect which was called: # once (57µs+6.61ms) by DBI::dr::connect at line 679 of DBI.pm
sub connect { ## no critic (ProhibitBuiltinHomonyms)
242
2431900ns my ($drh, $dbname, $user, $pass, $attr) = @_;
244
245 ## Allow "db" and "database" as synonyms for "dbname"
246110µs17µs $dbname =~ s/\b(?:db|database)\s*=/dbname=/;
# spent 7µs making 1 call to DBD::Pg::dr::CORE:subst
247
2481400ns my $name = $dbname;
24919µs24µs if ($dbname =~ m{dbname\s*=\s*[\"\']([^\"\']+)}) {
# spent 4µs making 2 calls to DBD::Pg::dr::CORE:match, avg 2µs/call
250 $name = "'$1'";
251 $dbname =~ s/\"/\'/g;
252 }
253 elsif ($dbname =~ m{dbname\s*=\s*([^;]+)}) {
254 $name = $1;
255 }
256
2571900ns $user = defined($user) ? $user : defined $ENV{DBI_USER} ? $ENV{DBI_USER} : '';
2581300ns $pass = defined($pass) ? $pass : defined $ENV{DBI_PASS} ? $ENV{DBI_PASS} : '';
259
26014µs130µs my ($dbh) = DBI::_new_dbh($drh, {
# spent 30µs making 1 call to DBI::_new_dbh
261 'Name' => $dbname,
262 'Username' => $user,
263 'CURRENT_USER' => $user,
264 });
265
266 # Connect to the database..
26716.57ms16.56ms DBD::Pg::db::_login($dbh, $dbname, $user, $pass, $attr) or return undef;
# spent 6.56ms making 1 call to DBD::Pg::db::_login
268
269119µs16µs my $version = $dbh->{pg_server_version};
# spent 6µs making 1 call to DBI::common::FETCH
270118µs38µs $dbh->{private_dbdpg}{version} = $version;
# spent 6µs making 1 call to DBI::common::STORE # spent 2µs making 2 calls to DBI::common::FETCH, avg 1µs/call
271
27211µs if ($attr) {
273 if ($attr->{dbd_verbose}) {
274 $dbh->trace('DBD');
275 }
276 }
277
27814µs return $dbh;
279 }
280
281 sub private_attribute_info {
282 return {
283 };
284 }
285
286} ## end of package DBD::Pg::dr
287
288
289{
290 package DBD::Pg::db;
291
292 use DBI qw(:sql_types);
293
294 use strict;
295
296 sub parse_trace_flag {
297 return DBD::Pg->parse_trace_flag($_[1]);
298 }
299
300
# spent 140µs (33+107) within DBD::Pg::db::prepare which was called 3 times, avg 46µs/call: # 2 times (24µs+77µs) by DBI::db::prepare at line 327 of /usr/local/libexec/sympa/Sympa/Database.pm, avg 50µs/call # once (9µs+30µs) by DBI::db::prepare at line 358 of /usr/local/libexec/sympa/Sympa/Database.pm
sub prepare {
30132µs my($dbh, $statement, @attribs) = @_;
302
30332µs return undef if ! defined $statement;
304
305 # Create a 'blank' statement handle:
306315µs388µs my $sth = DBI::_new_sth($dbh, {
# spent 88µs making 3 calls to DBI::_new_sth, avg 29µs/call
307 'Statement' => $statement,
308 });
309
310327µs319µs DBD::Pg::st::_prepare($sth, $statement, @attribs);
# spent 19µs making 3 calls to DBD::Pg::st::_prepare, avg 6µs/call
311
31237µs return $sth;
313 }
314
315 sub last_insert_id {
316
317 my ($dbh, undef, $schema, $table, undef, $attr) = @_;
318
319 ## Our ultimate goal is to get a sequence
320 my ($sth, $count, $SQL, $sequence);
321
322 ## Cache all of our table lookups? Default is yes
323 my $cache = 1;
324
325 ## Catalog and col (arguments 2 and 5) are not used
326 $schema = '' if ! defined $schema;
327 $table = '' if ! defined $table;
328 my $cachename = join("\0", 'lii', $schema, $table);
329
330 if (defined $attr and length $attr) {
331 ## If not a hash, assume it is a sequence name
332 if (! ref $attr) {
333 $attr = {sequence => $attr};
334 }
335 elsif (ref $attr ne 'HASH') {
336 $dbh->set_err(1, 'last_insert_id must be passed a hashref as the final argument');
337 return undef;
338 }
339 ## Named sequence overrides any table or schema settings
340 if (exists $attr->{sequence} and length $attr->{sequence}) {
341 $sequence = $attr->{sequence};
342 }
343 if (exists $attr->{pg_cache}) {
344 $cache = $attr->{pg_cache};
345 }
346 }
347
348 if (! defined $sequence and exists $dbh->{private_dbdpg}{$cachename} and $cache) {
349 $sequence = $dbh->{private_dbdpg}{$cachename};
350 }
351 elsif (! defined $sequence) {
352 ## At this point, we must have a valid table name
353 if (! length $table) {
354 $dbh->set_err(1, 'last_insert_id needs at least a sequence or table name');
355 return undef;
356 }
357 my @args = ($table);
358 my $schemawhere;
359 if (length $schema) {
360 # if given a schema, use that
361 $schemawhere = 'n.nspname = ?';
362 push @args, $schema;
363 } else {
364 # otherwise it must be visible via the search path
365 $schemawhere = 'pg_catalog.pg_table_is_visible(c.oid)';
366 }
367 ## Is there a sequence associated with the table via a unique, indexed column,
368 ## either via ownership (e.g. serial, identity) or a manual default?
369 my $idcond = $dbh->{private_dbdpg}{version} >= 100000
370 ? q{a.attidentity <> ''} : q{false};
371 $SQL = sprintf(q{
372 SELECT i.indisprimary,
373 COALESCE(
374 -- this takes the table name as text, not regclass
375 pg_catalog.pg_get_serial_sequence(
376 -- and pre-8.3 doesn't have a cast from regclass to text,
377 -- and pre-9.3 doesn't have format, so do it the long way
378 quote_ident(n.nspname) || '.' || quote_ident(c.relname),
379 a.attname),
380 (SELECT replace(substring(pg_catalog.pg_get_expr(d.adbin, d.adrelid)
381 from $r$^nextval\('(.+)'::[\w\s]+\)$$r$),
382 -- unescape any single quotes from the default
383 $$''$$, $$'$$)
384 FROM pg_catalog.pg_attrdef d
385 WHERE a.atthasdef
386 AND a.attrelid = d.adrelid
387 AND a.attnum = d.adnum)
388 ) AS seqname
389 FROM pg_class c
390 JOIN pg_catalog.pg_namespace n ON (n.oid = c.relnamespace)
391 -- LEFT JOIN so we can distingiuish between table not found (zero rows)
392 -- and no suitable column found (at least one all-NULL row)
393 LEFT JOIN pg_catalog.pg_index i
394 ON c.oid = i.indrelid AND i.indisunique
395 LEFT JOIN pg_catalog.pg_attribute a
396 ON i.indrelid = a.attrelid AND i.indkey[0]=a.attnum
397 AND (a.atthasdef OR %s)
398 WHERE c.relname = ? AND %s
399 }, $idcond, $schemawhere);
400 $sth = $dbh->prepare_cached($SQL);
401 $count = $sth->execute(@args);
402 if (!defined $count or $count eq '0E0') {
403 $sth->finish();
404 my $message = qq{Could not find the table "$table"};
405 length $schema and $message .= qq{ in the schema "$schema"};
406 $dbh->set_err(1, $message);
407 return undef;
408 }
409 my $info = $sth->fetchall_arrayref();
410 ## We have at least one with a default value. See if we found any sequences
411 my @def = grep { defined $_->[1] } @$info;
412 if (!@def) {
413 ## This may be an inherited table, in which case we can use the parent's info
414 $SQL = 'SELECT inhparent::regclass FROM pg_inherits WHERE inhrelid = ?::regclass::oid';
415 my $isth = $dbh->prepare($SQL);
416 $count = $isth->execute($table);
417 if ($count < 1) {
418 $isth->finish();
419 $dbh->set_err(1, qq{No suitable column found for last_insert_id of table "$table"\n});
420 return undef;
421 }
422 my $parent = $isth->fetch->[0];
423 $args[0] = $parent;
424 $count = $sth->execute(@args);
425 if (1 == $count) {
426 $info = $sth->fetchall_arrayref();
427 @def = grep { defined $_->[1] } @$info;
428 }
429 if (!@def) {
430 $sth->finish();
431 $dbh->set_err(1, qq{No suitable column found for last_insert_id of table "$table"\n});
432 return undef;
433 }
434 ## Fall through with inherited information
435 }
436 ## Tiebreaker goes to the primary keys
437 if (@def > 1) {
438 my @pri = grep { $_->[0] } @def;
439 if (1 != @pri) {
440 $dbh->set_err(1, qq{No suitable column found for last_insert_id of table "$table"\n});
441 return undef;
442 }
443 @def = @pri;
444 }
445 $sequence = $def[0]->[1];
446 ## Cache this information for subsequent calls
447 $dbh->{private_dbdpg}{$cachename} = $sequence;
448 }
449
450 $sth = $dbh->prepare_cached('SELECT pg_catalog.currval(?)');
451 $count = $sth->execute($sequence);
452 return undef if ! defined $count;
453 return $sth->fetchall_arrayref()->[0][0];
454
455 } ## end of last_insert_id
456
457
# spent 124µs (20+104) within DBD::Pg::db::ping which was called 2 times, avg 62µs/call: # 2 times (20µs+104µs) by DBI::db::ping at line 454 of /usr/local/libexec/sympa/Sympa/Database.pm, avg 62µs/call
sub ping {
45821µs my $dbh = shift;
459215µs28µs local $SIG{__WARN__} if $dbh->FETCH('PrintError');
# spent 8µs making 2 calls to DBI::common::FETCH, avg 4µs/call
4602101µs296µs my $ret = DBD::Pg::db::_ping($dbh);
# spent 96µs making 2 calls to DBD::Pg::db::_ping, avg 48µs/call
46124µs return $ret < 1 ? 0 : $ret;
462 }
463
464 sub pg_ping {
465 my $dbh = shift;
466 local $SIG{__WARN__} if $dbh->FETCH('PrintError');
467 return DBD::Pg::db::_ping($dbh);
468 }
469
470 sub pg_type_info {
471 my($dbh,$pg_type) = @_;
472 local $SIG{__WARN__} if $dbh->FETCH('PrintError');
473 return DBD::Pg::db::_pg_type_info($pg_type);
474 }
475
476 # Column expected in statement handle returned.
477 # table_cat, table_schem, table_name, column_name, data_type, type_name,
478 # column_size, buffer_length, DECIMAL_DIGITS, NUM_PREC_RADIX, NULLABLE,
479 # REMARKS, COLUMN_DEF, SQL_DATA_TYPE, SQL_DATETIME_SUB, CHAR_OCTET_LENGTH,
480 # ORDINAL_POSITION, IS_NULLABLE
481 # The result set is ordered by TABLE_SCHEM, TABLE_NAME and ORDINAL_POSITION.
482
483 sub column_info {
484 my $dbh = shift;
485 my (undef, $schema, $table, $column) = @_;
486
487 my @search;
488 ## If the schema or table has an underscore or a %, use a LIKE comparison
489 if (defined $schema and length $schema) {
490 push @search, 'n.nspname ' . ($schema =~ /[_%]/ ? 'LIKE ' : '= ') .
491 $dbh->quote($schema);
492 }
493 if (defined $table and length $table) {
494 push @search, 'c.relname ' . ($table =~ /[_%]/ ? 'LIKE ' : '= ') .
495 $dbh->quote($table);
496 }
497 if (defined $column and length $column) {
498 push @search, 'a.attname ' . ($column =~ /[_%]/ ? 'LIKE ' : '= ') .
499 $dbh->quote($column);
500 }
501
502 my $whereclause = join "\n\t\t\t\tAND ", '', @search;
503
504 my $col_info_sql = qq!
505 SELECT
506 pg_catalog.quote_ident(pg_catalog.current_database()) AS "TABLE_CAT"
507 , pg_catalog.quote_ident(n.nspname) AS "TABLE_SCHEM"
508 , pg_catalog.quote_ident(c.relname) AS "TABLE_NAME"
509 , pg_catalog.quote_ident(a.attname) AS "COLUMN_NAME"
510 , a.atttypid AS "DATA_TYPE"
511 , pg_catalog.format_type(a.atttypid, NULL) AS "TYPE_NAME"
512 , a.attlen AS "COLUMN_SIZE"
513 , NULL::text AS "BUFFER_LENGTH"
514 , NULL::text AS "DECIMAL_DIGITS"
515 , NULL::text AS "NUM_PREC_RADIX"
516 , CASE a.attnotnull WHEN 't' THEN 0 ELSE 1 END AS "NULLABLE"
517 , pg_catalog.col_description(a.attrelid, a.attnum) AS "REMARKS"
518 , pg_catalog.pg_get_expr(af.adbin, af.adrelid) AS "COLUMN_DEF"
519 , NULL::text AS "SQL_DATA_TYPE"
520 , NULL::text AS "SQL_DATETIME_SUB"
521 , NULL::text AS "CHAR_OCTET_LENGTH"
522 , a.attnum AS "ORDINAL_POSITION"
523 , CASE a.attnotnull WHEN 't' THEN 'NO' ELSE 'YES' END AS "IS_NULLABLE"
524 , pg_catalog.format_type(a.atttypid, a.atttypmod) AS "pg_type"
525 , '?' AS "pg_constraint"
526 , n.nspname AS "pg_schema"
527 , c.relname AS "pg_table"
528 , a.attname AS "pg_column"
529 , a.attrelid AS "pg_attrelid"
530 , a.attnum AS "pg_attnum"
531 , a.atttypmod AS "pg_atttypmod"
532 , t.typtype AS "_pg_type_typtype"
533 , t.oid AS "_pg_type_oid"
534 FROM
535 pg_catalog.pg_type t
536 JOIN pg_catalog.pg_attribute a ON (t.oid = a.atttypid)
537 JOIN pg_catalog.pg_class c ON (a.attrelid = c.oid)
538 LEFT JOIN pg_catalog.pg_attrdef af ON (a.attnum = af.adnum AND a.attrelid = af.adrelid)
539 JOIN pg_catalog.pg_namespace n ON (n.oid = c.relnamespace)
540 WHERE
541 a.attnum >= 0
542 AND c.relkind IN ('r','p','v','m','f')
543 $whereclause
544 ORDER BY "TABLE_SCHEM", "TABLE_NAME", "ORDINAL_POSITION"
545 !;
546
547 my $data = $dbh->selectall_arrayref($col_info_sql);
548
549 # To turn the data back into a statement handle, we need
550 # to fetch the data as an array of arrays, and also have a
551 # a matching array of all the column names
552 my %col_map = (qw/
553 TABLE_CAT 0
554 TABLE_SCHEM 1
555 TABLE_NAME 2
556 COLUMN_NAME 3
557 DATA_TYPE 4
558 TYPE_NAME 5
559 COLUMN_SIZE 6
560 BUFFER_LENGTH 7
561 DECIMAL_DIGITS 8
562 NUM_PREC_RADIX 9
563 NULLABLE 10
564 REMARKS 11
565 COLUMN_DEF 12
566 SQL_DATA_TYPE 13
567 SQL_DATETIME_SUB 14
568 CHAR_OCTET_LENGTH 15
569 ORDINAL_POSITION 16
570 IS_NULLABLE 17
571 pg_type 18
572 pg_constraint 19
573 pg_schema 20
574 pg_table 21
575 pg_column 22
576 pg_enum_values 23
577 /);
578
579 for my $row (@$data) {
580 my $typoid = pop @$row;
581 my $typtype = pop @$row;
582 my $typmod = pop @$row;
583 my $attnum = pop @$row;
584 my $aid = pop @$row;
585
586 $row->[$col_map{COLUMN_SIZE}] =
587 _calc_col_size($typmod,$row->[$col_map{COLUMN_SIZE}]);
588
589 # Replace the Pg type with the SQL_ type
590 $row->[$col_map{DATA_TYPE}] = DBD::Pg::db::pg_type_info($dbh,$row->[$col_map{DATA_TYPE}]);
591
592 # Add pg_constraint
593 my $SQL = q{SELECT pg_catalog.pg_get_constraintdef(oid) }.
594 q{FROM pg_catalog.pg_constraint WHERE contype = 'c' AND }.
595 qq{conrelid = $aid AND conkey = '{$attnum}'};
596 my $info = $dbh->selectall_arrayref($SQL);
597 if (@$info) {
598 $row->[$col_map{pg_constraint}] = $info->[0][0];
599 }
600 else {
601 $row->[$col_map{pg_constraint}] = undef;
602 }
603
604 if ( $typtype eq 'e' ) {
605 my $order_column = $dbh->{private_dbdpg}{version} >= 90100
606 ? 'enumsortorder' : 'oid';
607 $SQL = "SELECT enumlabel FROM pg_catalog.pg_enum WHERE enumtypid = $typoid ORDER BY $order_column";
608 $row->[$col_map{pg_enum_values}] = $dbh->selectcol_arrayref($SQL);
609 }
610 else {
611 $row->[$col_map{pg_enum_values}] = undef;
612 }
613 }
614
615 # Since we've processed the data in Perl, we have to jump through a hoop
616 # To turn it back into a statement handle
617 #
618 return _prepare_from_data(
619 'column_info',
620 $data,
621 [ sort { $col_map{$a} <=> $col_map{$b} } keys %col_map],
622 );
623 }
624
625 sub _prepare_from_data {
626 my ($statement, $data, $names, %attrinfo) = @_;
627 my $sponge = DBI->connect('dbi:Sponge:', '', '', { RaiseError => 1 });
628 my $sth = $sponge->prepare($statement, { rows=>$data, NAME=>$names, %attrinfo });
629 return $sth;
630 }
631
632 sub statistics_info {
633
634 my $dbh = shift;
635 my (undef, $schema, $table, $unique_only) = @_;
636
637 ## Catalog is ignored, but table is mandatory
638 return undef unless defined $table and length $table;
639
640 my $schema_where = '';
641 my @exe_args = ($table);
642
643 my $input_schema = (defined $schema and length $schema) ? 1 : 0;
644
645 if ($input_schema) {
646 $schema_where = 'AND n.nspname = ?';
647 push(@exe_args, $schema);
648 }
649
650 my $stats_sql;
651
652 # Table-level stats
653 if (!$unique_only) {
654 $stats_sql .= qq{
655 SELECT
656 pg_catalog.current_database() AS "TABLE_CAT",
657 n.nspname AS "TABLE_SCHEM",
658 d.relname AS "TABLE_NAME",
659 NULL AS "NON_UNIQUE",
660 NULL AS "INDEX_QUALIFIER",
661 NULL AS "INDEX_NAME",
662 'table' AS "TYPE",
663 NULL AS "ORDINAL_POSITION",
664 NULL AS "COLUMN_NAME",
665 NULL AS "ASC_OR_DESC",
666 d.reltuples AS "CARDINALITY",
667 d.relpages AS "PAGES",
668 NULL AS "FILTER_CONDITION",
669 NULL AS "pg_expression",
670 NULL AS "pg_is_key_column",
671 NULL AS "pg_null_ordering"
672 FROM pg_catalog.pg_class d
673 JOIN pg_catalog.pg_namespace n ON n.oid = d.relnamespace
674 WHERE d.relname = ? $schema_where
675 UNION ALL
676 };
677 push @exe_args, @exe_args;
678 }
679
680 my $is_key_column = $dbh->{private_dbdpg}{version} >= 110000
681 ? 'col.i <= i.indnkeyatts' : 'true';
682
683 my ($asc_or_desc, $null_ordering);
684 if ($dbh->{private_dbdpg}{version} >= 90600) {
685 $asc_or_desc = q{
686 CASE WHEN pg_catalog.pg_index_column_has_property(c.oid, col.i, 'asc') THEN 'A'
687 WHEN pg_catalog.pg_index_column_has_property(c.oid, col.i, 'desc') THEN 'D'
688 END};
689 $null_ordering = q{
690 CASE WHEN pg_catalog.pg_index_column_has_property(c.oid, col.i, 'nulls_first') THEN 'first'
691 WHEN pg_catalog.pg_index_column_has_property(c.oid, col.i, 'nulls_last') THEN 'last'
692 END};
693 }
694 elsif ($dbh->{private_dbdpg}{version} > 80300) {
695 $asc_or_desc = q{
696 CASE WHEN a.amcanorder THEN
697 CASE WHEN i.indoption[col.i - 1] & 1 = 0 THEN 'A' ELSE 'D' END
698 END};
699 $null_ordering = q{
700 CASE WHEN a.amcanorder THEN
701 CASE WHEN i.indoption[col.i - 1] & 2 = 0 THEN 'last' ELSE 'first' END
702 END};
703 }
704 else {
705 $asc_or_desc = q{CASE WHEN a.amorderstrategy <> 0 THEN 'A' END};
706 $null_ordering = q{CASE WHEN a.amorderstrategy <> 0 THEN 'last' END};
707 }
708
709 # Fetch the index definitions
710 $stats_sql .= qq{
711 SELECT
712 pg_catalog.current_database() AS "TABLE_CAT",
713 n.nspname AS "TABLE_SCHEM",
714 d.relname AS "TABLE_NAME",
715 NOT(i.indisunique) AS "NON_UNIQUE",
716 NULL AS "INDEX_QUALIFIER",
717 c.relname AS "INDEX_NAME",
718 CASE WHEN i.indisclustered THEN 'clustered'
719 WHEN a.amname = 'btree' THEN 'btree'
720 WHEN a.amname = 'hash' THEN 'hashed'
721 ELSE 'other'
722 END AS "TYPE",
723 col.i AS "ORDINAL_POSITION",
724 att.attname AS "COLUMN_NAME",
725 $asc_or_desc AS "ASC_OR_DESC",
726 c.reltuples AS "CARDINALITY",
727 c.relpages AS "PAGES",
728 pg_catalog.pg_get_expr(i.indpred,i.indrelid)
729 AS "FILTER_CONDITION",
730 pg_catalog.pg_get_indexdef(i.indexrelid, col.i, true)
731 AS "pg_expression",
732 $is_key_column AS "pg_is_key_column",
733 $null_ordering AS "pg_null_ordering"
734 FROM
735 pg_catalog.pg_index i
736 JOIN pg_catalog.pg_class c ON c.oid = i.indexrelid
737 JOIN pg_catalog.pg_class d ON d.oid = i.indrelid
738 JOIN pg_catalog.pg_am a ON a.oid = c.relam
739 JOIN pg_catalog.pg_namespace n ON n.oid = d.relnamespace
740 JOIN pg_catalog.generate_series(1, pg_catalog.current_setting('max_index_keys')::integer) col(i)
741 ON col.i <= i.indnatts
742 LEFT JOIN pg_catalog.pg_attribute att
743 ON att.attrelid = d.oid AND att.attnum = i.indkey[col.i - 1]
744 WHERE
745 d.relname = ? $schema_where
746 AND (i.indisunique OR NOT(?)) -- unique_only
747 ORDER BY
748 "NON_UNIQUE", "TYPE", "INDEX_QUALIFIER", "INDEX_NAME", "ORDINAL_POSITION"
749 };
750
751 my $sth = $dbh->prepare($stats_sql);
752 $sth->execute(@exe_args, 0+!!$unique_only);
753 return $sth;
754 }
755
756 sub primary_key_info {
757
758 my $dbh = shift;
759 my (undef, $schema, $table, $attr) = @_;
760
761 my @cols = (qw(TABLE_CAT TABLE_SCHEM TABLE_NAME
762 COLUMN_NAME KEY_SEQ PK_NAME DATA_TYPE
763 pg_tablespace_name pg_tablespace_location
764 pg_schema pg_table pg_column
765 )
766 );
767
768 ## Catalog is ignored, but table is mandatory
769 if (! defined $table or ! length $table) {
770 return _prepare_from_data('primary_key_info', [], \@cols);
771 }
772
773 my $whereclause = 'AND c.relname = ' . $dbh->quote($table);
774
775 if (defined $schema and length $schema) {
776 $whereclause .= "\n\t\t\tAND n.nspname = " . $dbh->quote($schema);
777 }
778
779 my $pri_key_sql = qq{
780 SELECT
781 c.oid
782 , pg_catalog.quote_ident(n.nspname)
783 , pg_catalog.quote_ident(c.relname)
784 , pg_catalog.quote_ident(c2.relname)
785 , i.indkey
786 , pg_catalog.quote_ident(t.spcname)
787 , pg_catalog.quote_ident(t.spclocation)
788 , n.nspname, c.relname, c2.relname
789 , pg_catalog.quote_ident(pg_catalog.current_database())
790 FROM
791 pg_catalog.pg_class c
792 JOIN pg_catalog.pg_index i ON (i.indrelid = c.oid)
793 JOIN pg_catalog.pg_class c2 ON (c2.oid = i.indexrelid)
794 LEFT JOIN pg_catalog.pg_namespace n ON (n.oid = c.relnamespace)
795 LEFT JOIN pg_catalog.pg_tablespace t ON (t.oid = c.reltablespace)
796 WHERE
797 i.indisprimary IS TRUE
798 $whereclause
799 };
800
801 if ($dbh->{private_dbdpg}{version} >= 90200) {
802 $pri_key_sql =~ s/t.spclocation/pg_catalog.pg_tablespace_location(t.oid)/;
803 }
804
805 my $sth = $dbh->prepare($pri_key_sql);
806 $sth->execute();
807 my $info = $sth->fetchall_arrayref()->[0];
808 if (! defined $info) {
809 return _prepare_from_data('primary_key_info', [], \@cols);
810 }
811
812 # Get the attribute information
813 my $indkey = join ',', split /\s+/, $info->[4];
814 my $sql = qq{
815 SELECT a.attnum, pg_catalog.quote_ident(a.attname) AS colname,
816 pg_catalog.quote_ident(t.typname) AS typename
817 FROM pg_catalog.pg_attribute a, pg_catalog.pg_type t
818 WHERE a.attrelid = '$info->[0]'
819 AND a.atttypid = t.oid
820 AND attnum IN ($indkey);
821 };
822 $sth = $dbh->prepare($sql);
823 $sth->execute();
824 my $attribinfo = $sth->fetchall_hashref('attnum');
825
826 my $pkinfo = [];
827
828 ## Normal way: complete "row" per column in the primary key
829 if (!exists $attr->{'pg_onerow'}) {
830 my $x=0;
831 my @key_seq = split/\s+/, $info->[4];
832 for (@key_seq) {
833 # TABLE_CAT
834 $pkinfo->[$x][0] = $info->[10];
835 # SCHEMA_NAME
836 $pkinfo->[$x][1] = $info->[1];
837 # TABLE_NAME
838 $pkinfo->[$x][2] = $info->[2];
839 # COLUMN_NAME
840 $pkinfo->[$x][3] = $attribinfo->{$_}{colname};
841 # KEY_SEQ
842 $pkinfo->[$x][4] = $_;
843 # PK_NAME
844 $pkinfo->[$x][5] = $info->[3];
845 # DATA_TYPE
846 $pkinfo->[$x][6] = $attribinfo->{$_}{typename};
847 $pkinfo->[$x][7] = $info->[5];
848 $pkinfo->[$x][8] = $info->[6];
849 $pkinfo->[$x][9] = $info->[7];
850 $pkinfo->[$x][10] = $info->[8];
851 $pkinfo->[$x][11] = $info->[9];
852 $x++;
853 }
854 }
855 else { ## Nicer way: return only one row
856
857 # TABLE_CAT
858 $info->[0] = $info->[10];
859 # TABLESPACES
860 $info->[7] = $info->[5];
861 $info->[8] = $info->[6];
862 # Unquoted names
863 $info->[9] = $info->[7];
864 $info->[10] = $info->[8];
865 $info->[11] = $info->[9];
866 # PK_NAME
867 $info->[5] = $info->[3];
868 # COLUMN_NAME
869 $info->[3] = 2==$attr->{'pg_onerow'} ?
870 [ map { $attribinfo->{$_}{colname} } split /\s+/, $info->[4] ] :
871 join ', ', map { $attribinfo->{$_}{colname} } split /\s+/, $info->[4];
872 # DATA_TYPE
873 $info->[6] = 2==$attr->{'pg_onerow'} ?
874 [ map { $attribinfo->{$_}{typename} } split /\s+/, $info->[4] ] :
875 join ', ', map { $attribinfo->{$_}{typename} } split /\s+/, $info->[4];
876 # KEY_SEQ
877 $info->[4] = 2==$attr->{'pg_onerow'} ?
878 [ split /\s+/, $info->[4] ] :
879 join ', ', split /\s+/, $info->[4];
880
881 $pkinfo = [$info];
882 }
883
884 return _prepare_from_data('primary_key_info', $pkinfo, \@cols);
885
886 }
887
888 sub primary_key {
889 my $sth = primary_key_info(@_[0..3], {pg_onerow => 2});
890 my $result = $sth->fetchall_arrayref();
891 return defined $result->[0] ? @{$result->[0][3]} : ();
892 }
893
894
895 sub foreign_key_info {
896
897 my $dbh = shift;
898
899 ## PK: catalog, schema, table, FK: catalog, schema, table, attr
900 ## Each of these may be undef or empty
901 my $pschema = $_[1] || '';
902 my $ptable = $_[2] || '';
903 my $fschema = $_[4] || '';
904 my $ftable = $_[5] || '';
905
906 my @cols = (qw(
907 UK_TABLE_CAT UK_TABLE_SCHEM UK_TABLE_NAME UK_COLUMN_NAME
908 FK_TABLE_CAT FK_TABLE_SCHEM FK_TABLE_NAME FK_COLUMN_NAME
909 ORDINAL_POSITION UPDATE_RULE DELETE_RULE FK_NAME UK_NAME
910 DEFERABILITY UNIQUE_OR_PRIMARY UK_DATA_TYPE FK_DATA_TYPE
911 ));
912
913 if ($dbh->{FetchHashKeyName} eq 'NAME_lc') {
914 for my $col (@cols) {
915 $col = lc $col;
916 }
917 }
918
919 ## Must have at least one named table
920 if (!length($ptable) and !length($ftable)) {
921 return _prepare_from_data('foreign_key_info', [], \@cols);
922 }
923
924 ## If only the primary table is given, we return only those columns
925 ## that are used as foreign keys, even if that means that we return
926 ## unique keys but not primary one. We also return all the foreign
927 ## tables/columns that are referencing them, of course.
928 ## If no schema is given, respect search_path by using pg_table_is_visible()
929 my @where;
930 for ([$ptable, $pschema, 'uk'], [$ftable, $fschema, 'fk']) {
931 my ($table, $schema, $type) = @$_;
932 if (length $table) {
933 push @where, "${type}_class.relname = " . $dbh->quote($table);
934 if (length $schema) {
935 push @where, "${type}_ns.nspname = " . $dbh->quote($schema);
936 }
937 else {
938 push @where, "pg_catalog.pg_table_is_visible(${type}_class.oid)"
939 }
940 }
941 }
942
943 my $WHERE = join ' AND ', @where;
944 my $SQL = qq{
945 SELECT
946 pg_catalog.quote_ident(pg_catalog.current_database()),
947 pg_catalog.quote_ident(uk_ns.nspname),
948 pg_catalog.quote_ident(uk_class.relname),
949 pg_catalog.quote_ident(uk_col.attname),
950 pg_catalog.quote_ident(pg_catalog.current_database()),
951 pg_catalog.quote_ident(fk_ns.nspname),
952 pg_catalog.quote_ident(fk_class.relname),
953 pg_catalog.quote_ident(fk_col.attname),
954 colnum.i,
955 CASE constr.confupdtype
956 WHEN 'c' THEN 0 WHEN 'r' THEN 1 WHEN 'n' THEN 2 WHEN 'a' THEN 3 WHEN 'd' THEN 4 ELSE -1
957 END,
958 CASE constr.confdeltype
959 WHEN 'c' THEN 0 WHEN 'r' THEN 1 WHEN 'n' THEN 2 WHEN 'a' THEN 3 WHEN 'd' THEN 4 ELSE -1
960 END,
961 pg_catalog.quote_ident(constr.conname), pg_catalog.quote_ident(uk_constr.conname),
962 CASE
963 WHEN constr.condeferrable = 'f' THEN 7
964 WHEN constr.condeferred = 't' THEN 6
965 WHEN constr.condeferred = 'f' THEN 5
966 ELSE -1
967 END,
968 CASE coalesce(uk_constr.contype, 'u')
969 WHEN 'u' THEN 'UNIQUE' WHEN 'p' THEN 'PRIMARY'
970 END,
971 pg_catalog.quote_ident(uk_type.typname), pg_catalog.quote_ident(fk_type.typname)
972 FROM pg_catalog.pg_constraint constr
973 JOIN pg_catalog.pg_class uk_class ON constr.confrelid = uk_class.oid
974 JOIN pg_catalog.pg_namespace uk_ns ON uk_class.relnamespace = uk_ns.oid
975 JOIN pg_catalog.pg_class fk_class ON constr.conrelid = fk_class.oid
976 JOIN pg_catalog.pg_namespace fk_ns ON fk_class.relnamespace = fk_ns.oid
977 -- can't do unnest() until 8.4, and would need WITH ORDINALITY to get the array indices,
978 -- wich isn't available until 9.4 at the earliest, so we join against a series table instead
979 JOIN pg_catalog.generate_series(1, pg_catalog.current_setting('max_index_keys')::integer) colnum(i)
980 ON colnum.i <= pg_catalog.array_upper(constr.conkey,1)
981 JOIN pg_catalog.pg_attribute uk_col ON uk_col.attrelid = constr.confrelid AND uk_col.attnum = constr.confkey[colnum.i]
982 JOIN pg_catalog.pg_type uk_type ON uk_col.atttypid = uk_type.oid
983 JOIN pg_catalog.pg_attribute fk_col ON fk_col.attrelid = constr.conrelid AND fk_col.attnum = constr.conkey[colnum.i]
984 JOIN pg_catalog.pg_type fk_type ON fk_col.atttypid = fk_type.oid
985
986 -- We can't match confkey from the fk constraint to conkey of the unique constraint,
987 -- because the unique constraint might not exist or there might be more than one
988 -- matching one. However, there must be at least a unique _index_ on the key
989 -- columns, so we look for that; but we can't find it via pg_index, since there may
990 -- again be more than one matching index.
991
992 -- So instead, we look at pg_depend for the dependency that was created by the fk
993 -- constraint. This dependency is of type 'n' (normal) and ties the pg_constraint
994 -- row oid to the pg_class oid for the index relation (a single arbitrary one if
995 -- more than one matching unique index existed at the time the constraint was
996 -- created). Fortunately, the constraint does not create dependencies on the
997 -- referenced table itself, but on the _columns_ of the referenced table, so the
998 -- index can be distinguished easily. Then we look for another pg_depend entry,
999 -- this time an 'i' (implementation) dependency from a pg_constraint oid (the unique
1000 -- constraint if one exists) to the index oid; but we have to allow for the
1001 -- possibility that this one doesn't exist. - Andrew Gierth (RhodiumToad)
1002
1003 JOIN pg_catalog.pg_depend dep ON (
1004 dep.classid = 'pg_catalog.pg_constraint'::regclass
1005 AND dep.objid = constr.oid
1006 AND dep.objsubid = 0
1007 AND dep.deptype = 'n'
1008 AND dep.refclassid = 'pg_catalog.pg_class'::regclass
1009 AND dep.refobjsubid=0
1010 )
1011 JOIN pg_catalog.pg_class idx ON (
1012 idx.oid = dep.refobjid AND idx.relkind='i'
1013 )
1014 LEFT JOIN pg_catalog.pg_depend dep2 ON (
1015 dep2.classid = 'pg_catalog.pg_class'::regclass
1016 AND dep2.objid = idx.oid
1017 AND dep2.objsubid = 0
1018 AND dep2.deptype = 'i'
1019 AND dep2.refclassid = 'pg_catalog.pg_constraint'::regclass
1020 AND dep2.refobjsubid = 0
1021 )
1022 LEFT JOIN pg_catalog.pg_constraint uk_constr ON (
1023 uk_constr.oid = dep2.refobjid AND uk_constr.contype IN ('p','u')
1024 )
1025 WHERE $WHERE
1026 AND uk_class.relkind ~ 'r|p'
1027 AND fk_class.relkind ~ 'r|p'
1028 AND constr.contype = 'f'
1029 ORDER BY constr.conname, colnum.i
1030 };
1031 my $fkinfo = $dbh->selectall_arrayref($SQL);
1032
1033 return _prepare_from_data('foreign_key_info', $fkinfo, \@cols);
1034
1035 } ## end of foreign_key_info
1036
1037
1038 sub table_info {
1039
1040 my $dbh = shift;
1041 my ($catalog, $schema, $table, $type) = @_;
1042
1043 my $tbl_sql = ();
1044
1045 my $extracols = q{,NULL::text AS pg_schema, NULL::text AS pg_table};
1046 if ( # Rule 19a
1047 (defined $catalog and $catalog eq '%')
1048 and (defined $schema and $schema eq '')
1049 and (defined $table and $table eq '')
1050 ) {
1051 $tbl_sql = qq{
1052 SELECT
1053 pg_catalog.quote_ident(pg_catalog.current_database()) AS "TABLE_CAT"
1054 , NULL::text AS "TABLE_SCHEM"
1055 , NULL::text AS "TABLE_NAME"
1056 , NULL::text AS "TABLE_TYPE"
1057 , NULL::text AS "REMARKS" $extracols
1058 };
1059 }
1060 elsif (# Rule 19b
1061 (defined $catalog and $catalog eq '')
1062 and (defined $schema and $schema eq '%')
1063 and (defined $table and $table eq '')
1064 ) {
1065 $extracols = q{,n.nspname AS pg_schema, NULL::text AS pg_table};
1066 $tbl_sql = qq{SELECT
1067 NULL::text AS "TABLE_CAT"
1068 , pg_catalog.quote_ident(n.nspname) AS "TABLE_SCHEM"
1069 , NULL::text AS "TABLE_NAME"
1070 , NULL::text AS "TABLE_TYPE"
1071 , CASE WHEN n.nspname ~ '^pg_' THEN 'system schema' ELSE 'owned by ' || pg_catalog.pg_get_userbyid(n.nspowner) END AS "REMARKS" $extracols
1072 FROM pg_catalog.pg_namespace n
1073 ORDER BY "TABLE_SCHEM"
1074 };
1075 }
1076 elsif (# Rule 19c
1077 (defined $catalog and $catalog eq '')
1078 and (defined $schema and $schema eq '')
1079 and (defined $table and $table eq '')
1080 and (defined $type and $type eq '%')
1081 ) {
1082 $tbl_sql = q{
1083 SELECT "TABLE_CAT"
1084 , "TABLE_SCHEM"
1085 , "TABLE_NAME"
1086 , "TABLE_TYPE"
1087 , "REMARKS"
1088 FROM
1089 (SELECT NULL::text AS "TABLE_CAT"
1090 , NULL::text AS "TABLE_SCHEM"
1091 , NULL::text AS "TABLE_NAME") dummy_cols
1092 CROSS JOIN
1093 (SELECT 'TABLE' AS "TABLE_TYPE"
1094 , 'relkind ~ r|p' AS "REMARKS"
1095 UNION
1096 SELECT 'SYSTEM TABLE'
1097 , 'relkind ~ r|p; nspname ~ ^pg_(catalog|toast)$'
1098 UNION
1099 SELECT 'VIEW'
1100 , 'relkind: v'
1101 UNION
1102 SELECT 'SYSTEM VIEW'
1103 , 'relkind: v; nspname ~ ^pg_(catalog|toast)$'
1104 UNION
1105 SELECT 'MATERIALIZED VIEW'
1106 , 'relkind: m'
1107 UNION
1108 SELECT 'SYSTEM MATERIALIZED VIEW'
1109 , 'relkind: m; nspname ~ ^pg_(catalog|toast)$'
1110 UNION
1111 SELECT 'FOREIGN TABLE'
1112 , 'relkind: f'
1113 UNION
1114 SELECT 'SYSTEM FOREIGN TABLE'
1115 , 'relkind: f; nspname ~ ^pg_(catalog|toast)$'
1116 UNION
1117 SELECT 'LOCAL TEMPORARY'
1118 , 'relkind ~ r|p; nspname ~ ^pg_(toast_)?temp') type_info
1119 ORDER BY "TABLE_TYPE" ASC
1120 };
1121 }
1122 else {
1123 # Default SQL
1124 $extracols = q{,n.nspname AS pg_schema, c.relname AS pg_table};
1125 my @search = (q|c.relkind IN ('r', 'p', 'v', 'm', 'f')|, # No sequences, etc. for now
1126 q|NOT (pg_catalog.quote_ident(n.nspname) ~ '^pg_(toast_)?temp_' AND NOT pg_catalog.has_schema_privilege(n.nspname, 'USAGE'))|); # No others' temp objects
1127 my $showtablespace = sprintf q{pg_catalog.quote_ident(%s) AS "pg_tablespace_location"},
1128 $dbh->{private_dbdpg}{version} < 90200 ? 't.spclocation' : 'pg_catalog.pg_tablespace_location(t.oid)';
1129
1130 ## If the schema or table has an underscore or a %, use a LIKE comparison
1131 if (defined $schema and length $schema) {
1132 push @search, 'n.nspname ' . ($schema =~ /[_%]/ ? 'LIKE ' : '= ') . $dbh->quote($schema);
1133 }
1134 if (defined $table and length $table) {
1135 push @search, 'c.relname ' . ($table =~ /[_%]/ ? 'LIKE ' : '= ') . $dbh->quote($table);
1136 }
1137
1138 my $whereclause = join "\n\t\t\t\t\t AND " => @search;
1139 $tbl_sql = qq{
1140 SELECT pg_catalog.quote_ident(pg_catalog.current_database()) AS "TABLE_CAT"
1141 , pg_catalog.quote_ident(n.nspname) AS "TABLE_SCHEM"
1142 , pg_catalog.quote_ident(c.relname) AS "TABLE_NAME"
1143 -- any temp table or temp view is LOCAL TEMPORARY for us
1144 , CASE WHEN pg_catalog.quote_ident(n.nspname) ~ '^pg_(toast_)?temp_' THEN
1145 'LOCAL TEMPORARY'
1146 WHEN c.relkind ~ 'r|p' THEN
1147 CASE WHEN pg_catalog.quote_ident(n.nspname) ~ '^pg_' THEN
1148 'SYSTEM TABLE'
1149 ELSE 'TABLE'
1150 END
1151 WHEN c.relkind = 'v' THEN
1152 CASE WHEN pg_catalog.quote_ident(n.nspname) ~ '^pg_' THEN
1153 'SYSTEM VIEW'
1154 ELSE 'VIEW'
1155 END
1156 WHEN c.relkind = 'm' THEN
1157 CASE WHEN pg_catalog.quote_ident(n.nspname) ~ '^pg_' THEN
1158 'SYSTEM MATERIALIZED VIEW'
1159 ELSE 'MATERIALIZED VIEW'
1160 END
1161 WHEN c.relkind = 'f' THEN
1162 CASE WHEN pg_catalog.quote_ident(n.nspname) ~ '^pg_' THEN
1163 'SYSTEM FOREIGN TABLE'
1164 ELSE 'FOREIGN TABLE'
1165 END
1166 ELSE 'UNKNOWN'
1167 END AS "TABLE_TYPE"
1168 , d.description AS "REMARKS"
1169 , pg_catalog.quote_ident(t.spcname) AS "pg_tablespace_name"
1170 , $showtablespace $extracols
1171 FROM pg_catalog.pg_class AS c
1172 LEFT JOIN pg_catalog.pg_description AS d
1173 ON (c.oid = d.objoid AND c.tableoid = d.classoid AND d.objsubid = 0)
1174 LEFT JOIN pg_catalog.pg_namespace n ON (n.oid = c.relnamespace)
1175 LEFT JOIN pg_catalog.pg_tablespace t ON (t.oid = c.reltablespace)
1176 WHERE $whereclause
1177 ORDER BY "TABLE_TYPE", "TABLE_CAT", "TABLE_SCHEM", "TABLE_NAME"
1178 };
1179
1180 if (defined($type) and length($type) and $type ne '%') {
1181 my $type_restrict = join ', ' =>
1182 map { /^'/ ? $_ : $dbh->quote($_) }
1183 grep {length}
1184 split(',', $type); ## no critic
1185 $tbl_sql = qq{SELECT * FROM ($tbl_sql) ti WHERE "TABLE_TYPE" IN ($type_restrict)};
1186 }
1187 }
1188 my $sth = $dbh->prepare($tbl_sql);
1189 $sth->execute();
1190
1191 return $sth;
1192 }
1193
1194 sub tables {
1195 my ($dbh, @args) = @_;
1196 my $attr = $args[4];
1197 my $sth = $dbh->table_info(@args);
1198 my $tablelist = $sth->fetchall_arrayref();
1199 my @tables = map { (! (ref $attr eq 'HASH' and $attr->{pg_noprefix})) ?
1200 "$_->[1].$_->[2]" : $_->[2] } @$tablelist;
1201 return @tables;
1202 }
1203
1204 sub table_attributes {
1205
1206 my ($dbh, $table) = @_;
1207
1208 my $sth = $dbh->column_info(undef,undef,$table,undef);
1209
1210 my %convert = (
1211 COLUMN_NAME => 'NAME',
1212 DATA_TYPE => 'TYPE',
1213 COLUMN_SIZE => 'SIZE',
1214 NULLABLE => 'NOTNULL',
1215 REMARKS => 'REMARKS',
1216 COLUMN_DEF => 'DEFAULT',
1217 pg_constraint => 'CONSTRAINT',
1218 );
1219
1220 my $attrs = $sth->fetchall_arrayref(\%convert);
1221
1222 for my $row (@$attrs) {
1223 # switch the column names
1224 for my $name (keys %$row) {
1225 $row->{ $convert{$name} } = $row->{$name};
1226
1227 ## Keep some original columns
1228 delete $row->{$name} unless ($name eq 'REMARKS' or $name eq 'NULLABLE');
1229
1230 }
1231 # Moved check outside of loop as it was inverting the NOTNULL value for
1232 # attribute.
1233 # NOTNULL inverts the sense of NULLABLE
1234 $row->{NOTNULL} = ($row->{NOTNULL} ? 0 : 1);
1235
1236 my @pri_keys = $dbh->primary_key( undef, undef, $table );
1237 $row->{PRIMARY_KEY} = scalar(grep { /^$row->{NAME}$/i } @pri_keys) ? 1 : 0;
1238 }
1239
1240 return $attrs;
1241
1242 }
1243
1244 sub _calc_col_size {
1245
1246 my $mod = shift;
1247 my $size = shift;
1248
1249
1250 if ($size > 0) {
1251 return $size;
1252 }
1253 elsif ($mod > 0xffff) {
1254 my $prec = ($mod & 0xffff) - 4;
1255 $mod >>= 16;
1256 my $dig = $mod;
1257 return "$prec,$dig";
1258 }
1259 elsif ($mod >= 4) {
1260 return $mod - 4;
1261 }
1262
1263 return;
1264 }
1265
1266
1267 sub type_info_all {
1268
1269 my $names =
1270 {
1271 TYPE_NAME => 0,
1272 DATA_TYPE => 1,
1273 COLUMN_SIZE => 2,
1274 LITERAL_PREFIX => 3,
1275 LITERAL_SUFFIX => 4,
1276 CREATE_PARAMS => 5,
1277 NULLABLE => 6,
1278 CASE_SENSITIVE => 7,
1279 SEARCHABLE => 8,
1280 UNSIGNED_ATTRIBUTE => 9,
1281 FIXED_PREC_SCALE => 10,
1282 AUTO_UNIQUE_VALUE => 11,
1283 LOCAL_TYPE_NAME => 12,
1284 MINIMUM_SCALE => 13,
1285 MAXIMUM_SCALE => 14,
1286 SQL_DATA_TYPE => 15,
1287 SQL_DATETIME_SUB => 16,
1288 NUM_PREC_RADIX => 17,
1289 INTERVAL_PRECISION => 18,
1290 };
1291
1292 ## This list is derived from dbi_sql.h in DBI, from types.c and types.h, and from the PG docs
1293
1294 ## Aids to make the list more readable:
1295 my $GIG = 1073741824;
1296 my $PS = 'precision/scale';
1297 my $LEN = 'length';
1298 my $UN;
1299 my $ti =
1300 [
1301 $names,
1302# name sql_type size pfx/sfx crt n/c/s +-/P/I local min max sub rdx itvl
1303
1304['unknown', SQL_UNKNOWN_TYPE, 0, $UN,$UN, $UN, 1,0,0, $UN,0,0, 'UNKNOWN', $UN,$UN,
1305 SQL_UNKNOWN_TYPE, $UN, $UN, $UN ],
1306['bytea', SQL_VARBINARY, $GIG, q{'},q{'}, $UN, 1,0,3, $UN,0,0, 'BYTEA', $UN,$UN,
1307 SQL_VARBINARY, $UN, $UN, $UN ],
1308['bpchar', SQL_CHAR, $GIG, q{'},q{'}, $LEN, 1,1,3, $UN,0,0, 'CHARACTER', $UN,$UN,
1309 SQL_CHAR, $UN, $UN, $UN ],
1310['numeric', SQL_DECIMAL, 1000, $UN,$UN, $PS, 1,0,2, 0,0,0, 'FLOAT', 0,1000,
1311 SQL_DECIMAL, $UN, $UN, $UN ],
1312['numeric', SQL_NUMERIC, 1000, $UN,$UN, $PS, 1,0,2, 0,0,0, 'FLOAT', 0,1000,
1313 SQL_NUMERIC, $UN, $UN, $UN ],
1314['int4', SQL_INTEGER, 10, $UN,$UN, $UN, 1,0,2, 0,0,0, 'INTEGER', 0,0,
1315 SQL_INTEGER, $UN, $UN, $UN ],
1316['int2', SQL_SMALLINT, 5, $UN,$UN, $UN, 1,0,2, 0,0,0, 'SMALLINT', 0,0,
1317 SQL_SMALLINT, $UN, $UN, $UN ],
1318['float4', SQL_FLOAT, 6, $UN,$UN, $PS, 1,0,2, 0,0,0, 'FLOAT', 0,6,
1319 SQL_FLOAT, $UN, $UN, $UN ],
1320['float8', SQL_REAL, 15, $UN,$UN, $PS, 1,0,2, 0,0,0, 'REAL', 0,15,
1321 SQL_REAL, $UN, $UN, $UN ],
1322['int8', SQL_BIGINT, 20, $UN,$UN, $UN, 1,0,2, 0,0,0, 'INT8', 0,0,
1323 SQL_BIGINT, $UN, $UN, $UN ],
1324['date', SQL_DATE, 10, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'DATE', 0,0,
1325 SQL_DATE, $UN, $UN, $UN ],
1326['tinterval',SQL_TIME, 18, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'TINTERVAL', 0,6,
1327 SQL_TIME, $UN, $UN, $UN ],
1328['timestamp',SQL_TIMESTAMP, 29, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'TIMESTAMP', 0,6,
1329 SQL_TIMESTAMP, $UN, $UN, $UN ],
1330['text', SQL_LONGVARCHAR, $GIG, q{'},q{'}, $LEN, 1,1,3, $UN,0,0, 'TEXT', $UN,$UN,
1331 SQL_LONGVARCHAR, $UN, $UN, $UN ],
1332['bool', SQL_BOOLEAN, 1, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'BOOLEAN', $UN,$UN,
1333 SQL_BOOLEAN, $UN, $UN, $UN ],
1334['array', SQL_ARRAY, 1, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'ARRAY', $UN,$UN,
1335 SQL_ARRAY, $UN, $UN, $UN ],
1336['date', SQL_TYPE_DATE, 10, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'DATE', 0,0,
1337 SQL_TYPE_DATE, $UN, $UN, $UN ],
1338['time', SQL_TYPE_TIME, 18, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'TIME', 0,6,
1339 SQL_TYPE_TIME, $UN, $UN, $UN ],
1340['timestamp',SQL_TYPE_TIMESTAMP,29, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'TIMESTAMP', 0,6,
1341 SQL_TYPE_TIMESTAMP, $UN, $UN, $UN ],
1342['timetz', SQL_TYPE_TIME_WITH_TIMEZONE,
1343 29, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'TIMETZ', 0,6,
1344 SQL_TYPE_TIME_WITH_TIMEZONE, $UN, $UN, $UN ],
1345['timestamptz',SQL_TYPE_TIMESTAMP_WITH_TIMEZONE,
1346 29, q{'},q{'}, $UN, 1,0,2, $UN,0,0, 'TIMESTAMPTZ',0,6,
1347 SQL_TYPE_TIMESTAMP_WITH_TIMEZONE, $UN, $UN, $UN ],
1348 #
1349 # intentionally omitted: char, all geometric types, internal types
1350 ];
1351 return $ti;
1352 }
1353
1354 my %get_info_type = (
1355
1356## Driver information:
1357
1358 116 => ['SQL_ACTIVE_ENVIRONMENTS', 0 ], ## unlimited
1359 10021 => ['SQL_ASYNC_MODE', 2 ], ## SQL_AM_STATEMENT
1360 120 => ['SQL_BATCH_ROW_COUNT', 2 ], ## SQL_BRC_EXPLICIT
1361 121 => ['SQL_BATCH_SUPPORT', 3 ], ## 12 SELECT_PROC + ROW_COUNT_PROC
1362 2 => ['SQL_DATA_SOURCE_NAME', sub { sprintf 'dbi:Pg:%s', shift->{Name} } ],
1363 3 => ['SQL_DRIVER_HDBC', 0 ], ## not applicable
1364 135 => ['SQL_DRIVER_HDESC', 0 ], ## not applicable
1365 4 => ['SQL_DRIVER_HENV', 0 ], ## not applicable
1366 76 => ['SQL_DRIVER_HLIB', 0 ], ## not applicable
1367 5 => ['SQL_DRIVER_HSTMT', 0 ], ## not applicable
1368 ## Not clear what should go here. Some things suggest 'Pg', others 'Pg.pm'. We'll use DBD::Pg for now
1369 6 => ['SQL_DRIVER_NAME', 'DBD::Pg' ],
1370 77 => ['SQL_DRIVER_ODBC_VERSION', '03.00' ],
1371 7 => ['SQL_DRIVER_VER', 'DBDVERSION' ], ## magic word
1372 144 => ['SQL_DYNAMIC_CURSOR_ATTRIBUTES1', 0 ], ## we can FETCH, but not via methods
1373 145 => ['SQL_DYNAMIC_CURSOR_ATTRIBUTES2', 0 ], ## same as above
1374 84 => ['SQL_FILE_USAGE', 0 ], ## SQL_FILE_NOT_SUPPORTED (this is good)
1375 146 => ['SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES1', 519 ], ## not clear what this refers to in DBD context
1376 147 => ['SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES2', 5209 ], ## see above
1377 81 => ['SQL_GETDATA_EXTENSIONS', 15 ], ## 1+2+4+8
1378 149 => ['SQL_INFO_SCHEMA_VIEWS', 3932149 ], ## not: assert, charset, collat, trans
1379 150 => ['SQL_KEYSET_CURSOR_ATTRIBUTES1', 0 ], ## applies to us?
1380 151 => ['SQL_KEYSET_CURSOR_ATTRIBUTES2', 0 ], ## see above
1381 10022 => ['SQL_MAX_ASYNC_CONCURRENT_STATEMENTS', 0 ], ## unlimited, probably
1382 0 => ['SQL_MAX_DRIVER_CONNECTIONS', \'SHOW max_connections' ],
1383 152 => ['SQL_ODBC_INTERFACE_CONFORMANCE', 1 ], ## SQL_OIC_LEVEL_1
1384 10 => ['SQL_ODBC_VER', '03.00.0000' ],
1385 153 => ['SQL_PARAM_ARRAY_ROW_COUNTS', 2 ], ## correct?
1386 154 => ['SQL_PARAM_ARRAY_SELECTS', 3 ], ## PAS_NO_SELECT
1387 11 => ['SQL_ROW_UPDATES', 'N' ],
1388 14 => ['SQL_SEARCH_PATTERN_ESCAPE', '\\' ],
1389 13 => ['SQL_SERVER_NAME', \'SELECT pg_catalog.current_database()' ],
1390 166 => ['SQL_STANDARD_CLI_CONFORMANCE', 2 ], ## ??
1391 167 => ['SQL_STATIC_CURSOR_ATTRIBUTES1', 519 ], ## ??
1392 168 => ['SQL_STATIC_CURSOR_ATTRIBUTES2', 5209 ], ## ??
1393 9000 => ['9000', 1 ], ## can escape placeholders
1394
1395## DBMS Information
1396
1397 16 => ['SQL_DATABASE_NAME', \'SELECT pg_catalog.current_database()' ],
1398 17 => ['SQL_DBMS_NAME', 'PostgreSQL' ],
1399 18 => ['SQL_DBMS_VERSION', 'ODBCVERSION' ], ## magic word
1400
1401## Data source information
1402
1403 20 => ['SQL_ACCESSIBLE_PROCEDURES', 'Y' ], ## is this really true?
1404 19 => ['SQL_ACCESSIBLE_TABLES', 'Y' ], ## is this really true?
1405 82 => ['SQL_BOOKMARK_PERSISTENCE', 0 ],
1406 42 => ['SQL_CATALOG_TERM', '' ], ## empty = catalogs are not supported
1407 10004 => ['SQL_COLLATION_SEQ', \'SHOW server_encoding' ],
1408 22 => ['SQL_CONCAT_NULL_BEHAVIOR', 0 ], ## SQL_CB_NULL
1409 23 => ['SQL_CURSOR_COMMIT_BEHAVIOR', 1 ], ## SQL_CB_CLOSE
1410 24 => ['SQL_CURSOR_ROLLBACK_BEHAVIOR', 1 ], ## SQL_CB_CLOSE
1411 10001 => ['SQL_CURSOR_SENSITIVITY', 1 ], ## SQL_INSENSITIVE
1412 25 => ['SQL_DATA_SOURCE_READ_ONLY', 'READONLY' ], ## magic word
1413 26 => ['SQL_DEFAULT_TXN_ISOLATION', 'DEFAULTTXN' ], ## magic word (2 or 8)
1414 10002 => ['SQL_DESCRIBE_PARAMETER', 'Y' ],
1415 36 => ['SQL_MULT_RESULT_SETS', 'Y' ],
1416 37 => ['SQL_MULTIPLE_ACTIVE_TXN', 'Y' ],
1417 111 => ['SQL_NEED_LONG_DATA_LEN', 'N' ],
1418 85 => ['SQL_NULL_COLLATION', 0 ], ## SQL_NC_HIGH
1419 40 => ['SQL_PROCEDURE_TERM', 'function' ], ## for now
1420 39 => ['SQL_SCHEMA_TERM', 'schema' ],
1421 44 => ['SQL_SCROLL_OPTIONS', 8 ], ## not really for DBD?
1422 45 => ['SQL_TABLE_TERM', 'table' ],
1423 46 => ['SQL_TXN_CAPABLE', 2 ], ## SQL_TC_ALL
1424 72 => ['SQL_TXN_ISOLATION_OPTION', 10 ], ## 2+8
1425 47 => ['SQL_USER_NAME', sub { shift->{CURRENT_USER} } ],
1426
1427## Supported SQL
1428
1429 169 => ['SQL_AGGREGATE_FUNCTIONS', 127 ], ## all of 'em
1430 117 => ['SQL_ALTER_DOMAIN', 31 ], ## all but deferred
1431 86 => ['SQL_ALTER_TABLE', 32639 ], ## no collate
1432 114 => ['SQL_CATALOG_LOCATION', 0 ],
1433 10003 => ['SQL_CATALOG_NAME', 'N' ],
1434 41 => ['SQL_CATALOG_NAME_SEPARATOR', '' ],
1435 92 => ['SQL_CATALOG_USAGE', 0 ],
1436 87 => ['SQL_COLUMN_ALIAS', 'Y' ],
1437 74 => ['SQL_CORRELATION_NAME', 2 ], ## SQL_CN_ANY
1438 127 => ['SQL_CREATE_ASSERTION', 0 ],
1439 128 => ['SQL_CREATE_CHARACTER_SET', 0 ],
1440 129 => ['SQL_CREATE_COLLATION', 0 ],
1441 130 => ['SQL_CREATE_DOMAIN', 23 ], ## no collation, no defer
1442 131 => ['SQL_CREATE_SCHEMA', 3 ], ## 1+2 schema + authorize
1443 132 => ['SQL_CREATE_TABLE', 13845 ], ## no collation
1444 133 => ['SQL_CREATE_TRANSLATION', 0 ],
1445 134 => ['SQL_CREATE_VIEW', 9 ], ## local + create?
1446 119 => ['SQL_DATETIME_LITERALS', 65535 ], ## all?
1447 170 => ['SQL_DDL_INDEX', 3 ], ## create + drop
1448 136 => ['SQL_DROP_ASSERTION', 0 ],
1449 137 => ['SQL_DROP_CHARACTER_SET', 0 ],
1450 138 => ['SQL_DROP_COLLATION', 0 ],
1451 139 => ['SQL_DROP_DOMAIN', 7 ],
1452 140 => ['SQL_DROP_SCHEMA', 7 ],
1453 141 => ['SQL_DROP_TABLE', 7 ],
1454 142 => ['SQL_DROP_TRANSLATION', 0 ],
1455 143 => ['SQL_DROP_VIEW', 7 ],
1456 27 => ['SQL_EXPRESSIONS_IN_ORDERBY', 'Y' ],
1457 88 => ['SQL_GROUP_BY', 2 ], ## GROUP_BY_CONTAINS_SELECT
1458 28 => ['SQL_IDENTIFIER_CASE', 2 ], ## SQL_IC_LOWER
1459 29 => ['SQL_IDENTIFIER_QUOTE_CHAR', q{"} ],
1460 148 => ['SQL_INDEX_KEYWORDS', 0 ], ## not needed for Pg
1461 172 => ['SQL_INSERT_STATEMENT', 7 ], ## 1+2+4 = all
1462 73 => ['SQL_INTEGRITY', 'Y' ], ## e.g. ON DELETE CASCADE?
1463 89 => ['SQL_KEYWORDS', 'KEYWORDS' ], ## magic word
1464 113 => ['SQL_LIKE_ESCAPE_CLAUSE', 'Y' ],
1465 75 => ['SQL_NON_NULLABLE_COLUMNS', 1 ], ## NNC_NOT_NULL
1466 115 => ['SQL_OJ_CAPABILITIES', 127 ], ## all
1467 90 => ['SQL_ORDER_BY_COLUMNS_IN_SELECT', 'N' ],
1468 38 => ['SQL_OUTER_JOINS', 'Y' ],
1469 21 => ['SQL_PROCEDURES', 'Y' ],
1470 93 => ['SQL_QUOTED_IDENTIFIER_CASE', 3 ], ## SQL_IC_SENSITIVE
1471 91 => ['SQL_SCHEMA_USAGE', 31 ], ## all
1472 94 => ['SQL_SPECIAL_CHARACTERS', '$' ], ## there are actually many more...
1473 118 => ['SQL_SQL_CONFORMANCE', 4 ], ## SQL92_INTERMEDIATE ??
1474 95 => ['SQL_SUBQUERIES', 31 ], ## all
1475 96 => ['SQL_UNION', 3 ], ## 1+2 = all
1476
1477## SQL limits
1478
1479 112 => ['SQL_MAX_BINARY_LITERAL_LEN', 0 ],
1480 34 => ['SQL_MAX_CATALOG_NAME_LEN', 0 ],
1481 108 => ['SQL_MAX_CHAR_LITERAL_LEN', 0 ],
1482 30 => ['SQL_MAX_COLUMN_NAME_LEN', 'NAMEDATALEN' ], ## magic word
1483 97 => ['SQL_MAX_COLUMNS_IN_GROUP_BY', 0 ],
1484 98 => ['SQL_MAX_COLUMNS_IN_INDEX', 0 ],
1485 99 => ['SQL_MAX_COLUMNS_IN_ORDER_BY', 0 ],
1486 100 => ['SQL_MAX_COLUMNS_IN_SELECT', 0 ],
1487 101 => ['SQL_MAX_COLUMNS_IN_TABLE', 250 ], ## 250-1600 (depends on column types)
1488 31 => ['SQL_MAX_CURSOR_NAME_LEN', 'NAMEDATALEN' ], ## magic word
1489 10005 => ['SQL_MAX_IDENTIFIER_LEN', 'NAMEDATALEN' ], ## magic word
1490 102 => ['SQL_MAX_INDEX_SIZE', 0 ],
1491 33 => ['SQL_MAX_PROCEDURE_NAME_LEN', 'NAMEDATALEN' ], ## magic word
1492 104 => ['SQL_MAX_ROW_SIZE', 0 ], ## actually 1.6 TB, but too big to represent here
1493 103 => ['SQL_MAX_ROW_SIZE_INCLUDES_LONG', 'Y' ],
1494 32 => ['SQL_MAX_SCHEMA_NAME_LEN', 'NAMEDATALEN' ], ## magic word
1495 105 => ['SQL_MAX_STATEMENT_LEN', 0 ],
1496 35 => ['SQL_MAX_TABLE_NAME_LEN', 'NAMEDATALEN' ], ## magic word
1497 106 => ['SQL_MAX_TABLES_IN_SELECT', 0 ],
1498 107 => ['SQL_MAX_USER_NAME_LEN', 'NAMEDATALEN' ], ## magic word
1499
1500## Scalar function information
1501
1502 48 => ['SQL_CONVERT_FUNCTIONS', 2 ], ## CVT_CAST only?
1503 49 => ['SQL_NUMERIC_FUNCTIONS', 16777215 ], ## ?? all but some naming clashes: rand(om), trunc(ate), log10=ln, etc.
1504 50 => ['SQL_STRING_FUNCTIONS', 16280984 ], ## ??
1505 51 => ['SQL_SYSTEM_FUNCTIONS', 0 ], ## ??
1506 109 => ['SQL_TIMEDATE_ADD_INTERVALS', 0 ], ## ?? no explicit timestampadd?
1507 110 => ['SQL_TIMEDATE_DIFF_INTERVALS', 0 ], ## ??
1508 52 => ['SQL_TIMEDATE_FUNCTIONS', 1966083 ],
1509
1510## Conversion information - all but BIT, LONGVARBINARY, and LONGVARCHAR
1511
1512 53 => ['SQL_CONVERT_BIGINT', 1830399 ],
1513 54 => ['SQL_CONVERT_BINARY', 1830399 ],
1514 55 => ['SQL_CONVERT_BIT', 0 ],
1515 56 => ['SQL_CONVERT_CHAR', 1830399 ],
1516 57 => ['SQL_CONVERT_DATE', 1830399 ],
1517 58 => ['SQL_CONVERT_DECIMAL', 1830399 ],
1518 59 => ['SQL_CONVERT_DOUBLE', 1830399 ],
1519 60 => ['SQL_CONVERT_FLOAT', 1830399 ],
1520 61 => ['SQL_CONVERT_INTEGER', 1830399 ],
1521 123 => ['SQL_CONVERT_INTERVAL_DAY_TIME', 1830399 ],
1522 124 => ['SQL_CONVERT_INTERVAL_YEAR_MONTH', 1830399 ],
1523 71 => ['SQL_CONVERT_LONGVARBINARY', 0 ],
1524 62 => ['SQL_CONVERT_LONGVARCHAR', 0 ],
1525 63 => ['SQL_CONVERT_NUMERIC', 1830399 ],
1526 64 => ['SQL_CONVERT_REAL', 1830399 ],
1527 65 => ['SQL_CONVERT_SMALLINT', 1830399 ],
1528 66 => ['SQL_CONVERT_TIME', 1830399 ],
1529 67 => ['SQL_CONVERT_TIMESTAMP', 1830399 ],
1530 68 => ['SQL_CONVERT_TINYINT', 1830399 ],
1531 69 => ['SQL_CONVERT_VARBINARY', 0 ],
1532 70 => ['SQL_CONVERT_VARCHAR', 1830399 ],
1533 122 => ['SQL_CONVERT_WCHAR', 0 ],
1534 125 => ['SQL_CONVERT_WLONGVARCHAR', 0 ],
1535 126 => ['SQL_CONVERT_WVARCHAR', 0 ],
1536 ); ## end of %get_info_type
1537 ## Add keys for names into the hash
1538 for (keys %get_info_type) {
1539 $get_info_type{$get_info_type{$_}->[0]} = $get_info_type{$_};
1540 }
1541
1542 sub get_info {
1543
1544 my ($dbh,$type) = @_;
1545
1546 return undef unless exists $get_info_type{$type};
1547
1548 my $ans = $get_info_type{$type}->[1];
1549
1550 if (ref $ans eq 'CODE') {
1551 $ans = $ans->($dbh);
1552 }
1553 elsif (ref $ans eq 'SCALAR') { # SQL
1554 return $dbh->selectall_arrayref($$ans)->[0][0];
1555 }
1556 elsif ($ans eq 'NAMEDATALEN') {
1557 return $dbh->selectall_arrayref('SHOW max_identifier_length')->[0][0];
1558 }
1559 elsif ($ans eq 'ODBCVERSION') {
1560 my $version = $dbh->{private_dbdpg}{version};
1561 return '00.00.0000' unless $version =~ /^([0-9][0-9]?)([0-9][0-9])([0-9][0-9])$/;
1562 return sprintf '%02d.%02d.%.2d00', $1,$2,$3;
1563 }
1564 elsif ($ans eq 'DBDVERSION') {
1565 my $simpleversion = $DBD::Pg::VERSION;
1566 $simpleversion =~ s/_/./g;
1567 no if $] >= 5.022, warnings => 'redundant';
1568 return sprintf '%02d.%02d.%1d%1d%1d%1d', split (/\./, "$simpleversion.0.0.0.0.0.0");
1569 }
1570 elsif ($ans eq 'KEYWORDS') {
1571 ## http://www.postgresql.org/docs/current/static/sql-keywords-appendix.html
1572 ## Basically, we want ones that are 'reserved' for PostgreSQL but not 'reserved' in SQL:2011
1573 return join ',' => (qw(ANALYSE ANALYZE ASC CONCURRENTLY DEFERRABLE DESC DO FREEZE ILIKE INITIALLY ISNULL LIMIT NOTNULL PLACING RETURNING VARIADIC VERBOSE));
1574 }
1575 elsif ($ans eq 'READONLY') {
1576 my $SQL = q{SELECT CASE WHEN setting = 'on' THEN 'Y' ELSE 'N' END FROM pg_settings WHERE name = 'transaction_read_only'};
1577 my $info = $dbh->selectall_arrayref($SQL);
1578 return $info->[0][0];
1579 }
1580 elsif ($ans eq 'DEFAULTTXN') {
1581 my $SQL = q{SELECT CASE WHEN setting = 'read committed' THEN 2 ELSE 8 END FROM pg_settings WHERE name = 'default_transaction_isolation'};
1582 my $info = $dbh->selectall_arrayref($SQL);
1583 return $info->[0][0];
1584 }
1585
1586 return $ans;
1587 } # end of get_info
1588
1589 sub private_attribute_info {
1590 return {
1591 pg_async_status => undef,
1592 pg_bool_tf => undef,
1593 pg_db => undef,
1594 pg_default_port => undef,
1595 pg_enable_utf8 => undef,
1596 pg_utf8_flag => undef,
1597 pg_errorlevel => undef,
1598 pg_expand_array => undef,
1599 pg_host => undef,
1600 pg_INV_READ => undef,
1601 pg_INV_WRITE => undef,
1602 pg_lib_version => undef,
1603 pg_options => undef,
1604 pg_pass => undef,
1605 pg_pid => undef,
1606 pg_placeholder_dollaronly => undef,
1607 pg_placeholder_nocolons => undef,
1608 pg_placeholder_escaped => undef,
1609 pg_port => undef,
1610 pg_prepare_now => undef,
1611 pg_protocol => undef,
1612 pg_server_prepare => undef,
1613 pg_server_version => undef,
1614 pg_socket => undef,
1615 pg_standard_conforming_strings => undef,
1616 pg_switch_prepared => undef,
1617 pg_user => undef,
1618 };
1619 }
1620}
1621
1622
1623{
1624 package DBD::Pg::st;
1625
1626 sub parse_trace_flag {
1627 return DBD::Pg->parse_trace_flag($_[1]);
1628 }
1629
1630 sub bind_param_array {
1631
1632 ## Binds an array of data to a specific placeholder in a statement
1633 ## The DBI version is broken, so we implement a near-copy here
1634
1635 my $sth = shift;
1636 my ($p_id, $value_array, $attr) = @_;
1637
1638 ## Bail if the second arg is not undef or an arrayref
1639 return $sth->set_err(1, "Value for parameter $p_id must be a scalar or an arrayref, not a ".ref($value_array))
1640 if ref $value_array and ref $value_array ne 'ARRAY';
1641
1642 ## Bail if the first arg is not a number
1643 return $sth->set_err(1, q{Can't use named placeholders for non-driver supported bind_param_array})
1644 unless DBI::looks_like_number($p_id); # because we rely on execute(@ary) here
1645
1646 ## Store the list of items in the hash (will be undef or an arrayref)
1647 $sth->{ParamArrays}{$p_id} = $value_array;
1648
1649 ## If any attribs were passed in, we need to call bind_param
1650 return $sth->bind_param($p_id, '', $attr) if $attr; ## This is the big change so -w does not complain
1651
1652 return 1;
1653
1654 } ## end bind_param_array
1655
1656 sub private_attribute_info {
1657 return {
1658 pg_async => undef,
1659 pg_bound => undef,
1660 pg_current_row => undef,
1661 pg_direct => undef,
1662 pg_numbound => undef,
1663 pg_cmd_status => undef,
1664 pg_oid_status => undef,
1665 pg_placeholder_dollaronly => undef,
1666 pg_placeholder_nocolons => undef,
1667 pg_prepare_name => undef,
1668 pg_prepare_now => undef,
1669 pg_segments => undef,
1670 pg_server_prepare => undef,
1671 pg_size => undef,
1672 pg_switch_prepared => undef,
1673 pg_type => undef,
1674 };
1675 }
1676
1677} ## end st section
1678
16791;
1680
1681__END__
 
# spent 6.56ms within DBD::Pg::db::_login which was called: # once (6.56ms+0s) by DBD::Pg::dr::connect at line 267
sub DBD::Pg::db::_login; # xsub
# spent 96µs within DBD::Pg::db::_ping which was called 2 times, avg 48µs/call: # 2 times (96µs+0s) by DBD::Pg::db::ping at line 460, avg 48µs/call
sub DBD::Pg::db::_ping; # xsub
# spent 4µs within DBD::Pg::dr::CORE:match which was called 2 times, avg 2µs/call: # 2 times (4µs+0s) by DBD::Pg::dr::connect at line 249, avg 2µs/call
sub DBD::Pg::dr::CORE:match; # opcode
# spent 7µs within DBD::Pg::dr::CORE:subst which was called: # once (7µs+0s) by DBD::Pg::dr::connect at line 246
sub DBD::Pg::dr::CORE:subst; # opcode
# spent 19µs within DBD::Pg::st::_prepare which was called 3 times, avg 6µs/call: # 3 times (19µs+0s) by DBD::Pg::db::prepare at line 310, avg 6µs/call
sub DBD::Pg::st::_prepare; # xsub