Filename | /usr/local/lib/perl5/site_perl/mach/5.32/DBD/Pg.pm |
Statements | Executed 35 statements in 6.81ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 6.56ms | 6.56ms | _login (xsub) | DBD::Pg::db::
2 | 1 | 1 | 96µs | 96µs | _ping (xsub) | DBD::Pg::db::
1 | 1 | 1 | 57µs | 6.67ms | connect | DBD::Pg::dr::
3 | 2 | 1 | 33µs | 140µs | prepare | DBD::Pg::db::
2 | 1 | 1 | 20µs | 124µs | ping | DBD::Pg::db::
3 | 1 | 1 | 19µs | 19µs | _prepare (xsub) | DBD::Pg::st::
1 | 1 | 1 | 7µs | 7µs | CORE:subst (opcode) | DBD::Pg::dr::
2 | 1 | 1 | 4µs | 4µs | CORE:match (opcode) | DBD::Pg::dr::
0 | 0 | 0 | 0s | 0s | BEGIN@19 | DBD::Pg::
0 | 0 | 0 | 0s | 0s | BEGIN@21 | DBD::Pg::
0 | 0 | 0 | 0s | 0s | BEGIN@22 | DBD::Pg::
0 | 0 | 0 | 0s | 0s | BEGIN@23 | DBD::Pg::
0 | 0 | 0 | 0s | 0s | BEGIN@24 | DBD::Pg::
0 | 0 | 0 | 0s | 0s | BEGIN@27 | DBD::Pg::
0 | 0 | 0 | 0s | 0s | CLONE | DBD::Pg::
0 | 0 | 0 | 0s | 0s | new | DBD::Pg::DefaultValue::
0 | 0 | 0 | 0s | 0s | bootstrap (xsub) | DBD::Pg::
0 | 0 | 0 | 0s | 0s | BEGIN@1567 | DBD::Pg::db::
0 | 0 | 0 | 0s | 0s | BEGIN@292 | DBD::Pg::db::
0 | 0 | 0 | 0s | 0s | BEGIN@294 | DBD::Pg::db::
0 | 0 | 0 | 0s | 0s | __ANON__[:1362] | DBD::Pg::db::
0 | 0 | 0 | 0s | 0s | __ANON__[:1425] | DBD::Pg::db::
0 | 0 | 0 | 0s | 0s | _calc_col_size | DBD::Pg::db::
0 | 0 | 0 | 0s | 0s | _prepare_from_data | DBD::Pg::db::
0 | 0 | 0 | 0s | 0s | column_info | DBD::Pg::db::
0 | 0 | 0 | 0s | 0s | foreign_key_info | DBD::Pg::db::
0 | 0 | 0 | 0s | 0s | get_info | DBD::Pg::db::
0 | 0 | 0 | 0s | 0s | last_insert_id | DBD::Pg::db::
0 | 0 | 0 | 0s | 0s | parse_trace_flag | DBD::Pg::db::
0 | 0 | 0 | 0s | 0s | pg_ping | DBD::Pg::db::
0 | 0 | 0 | 0s | 0s | pg_type_info | DBD::Pg::db::
0 | 0 | 0 | 0s | 0s | primary_key | DBD::Pg::db::
0 | 0 | 0 | 0s | 0s | primary_key_info | DBD::Pg::db::
0 | 0 | 0 | 0s | 0s | private_attribute_info | DBD::Pg::db::
0 | 0 | 0 | 0s | 0s | statistics_info | DBD::Pg::db::
0 | 0 | 0 | 0s | 0s | table_attributes | DBD::Pg::db::
0 | 0 | 0 | 0s | 0s | table_info | DBD::Pg::db::
0 | 0 | 0 | 0s | 0s | tables | DBD::Pg::db::
0 | 0 | 0 | 0s | 0s | type_info_all | DBD::Pg::db::
0 | 0 | 0 | 0s | 0s | BEGIN@214 | DBD::Pg::dr::
0 | 0 | 0 | 0s | 0s | data_sources | DBD::Pg::dr::
0 | 0 | 0 | 0s | 0s | private_attribute_info | DBD::Pg::dr::
0 | 0 | 0 | 0s | 0s | driver | DBD::Pg::
0 | 0 | 0 | 0s | 0s | parse_trace_flag | DBD::Pg::
0 | 0 | 0 | 0s | 0s | parse_trace_flags | DBD::Pg::
0 | 0 | 0 | 0s | 0s | bind_param_array | DBD::Pg::st::
0 | 0 | 0 | 0s | 0s | parse_trace_flag | DBD::Pg::st::
0 | 0 | 0 | 0s | 0s | private_attribute_info | DBD::Pg::st::
0 | 0 | 0 | 0s | 0s | BEGIN@12 | Sympa::Database::
0 | 0 | 0 | 0s | 0s | BEGIN@13 | Sympa::Database::
0 | 0 | 0 | 0s | 0s | BEGIN@14 | Sympa::Database::
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 | |||||
12 | use strict; | ||||
13 | use warnings; | ||||
14 | use 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 | ||||
242 | |||||
243 | 1 | 900ns | my ($drh, $dbname, $user, $pass, $attr) = @_; | ||
244 | |||||
245 | ## Allow "db" and "database" as synonyms for "dbname" | ||||
246 | 1 | 10µs | 1 | 7µs | $dbname =~ s/\b(?:db|database)\s*=/dbname=/; # spent 7µs making 1 call to DBD::Pg::dr::CORE:subst |
247 | |||||
248 | 1 | 400ns | my $name = $dbname; | ||
249 | 1 | 9µs | 2 | 4µ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 | |||||
257 | 1 | 900ns | $user = defined($user) ? $user : defined $ENV{DBI_USER} ? $ENV{DBI_USER} : ''; | ||
258 | 1 | 300ns | $pass = defined($pass) ? $pass : defined $ENV{DBI_PASS} ? $ENV{DBI_PASS} : ''; | ||
259 | |||||
260 | 1 | 4µs | 1 | 30µ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.. | ||||
267 | 1 | 6.57ms | 1 | 6.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 | |||||
269 | 1 | 19µs | 1 | 6µs | my $version = $dbh->{pg_server_version}; # spent 6µs making 1 call to DBI::common::FETCH |
270 | 1 | 18µs | 3 | 8µ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 | |||||
272 | 1 | 1µs | if ($attr) { | ||
273 | if ($attr->{dbd_verbose}) { | ||||
274 | $dbh->trace('DBD'); | ||||
275 | } | ||||
276 | } | ||||
277 | |||||
278 | 1 | 4µ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 | ||||
301 | 3 | 2µs | my($dbh, $statement, @attribs) = @_; | ||
302 | |||||
303 | 3 | 2µs | return undef if ! defined $statement; | ||
304 | |||||
305 | # Create a 'blank' statement handle: | ||||
306 | 3 | 15µs | 3 | 88µ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 | |||||
310 | 3 | 27µs | 3 | 19µs | DBD::Pg::st::_prepare($sth, $statement, @attribs); # spent 19µs making 3 calls to DBD::Pg::st::_prepare, avg 6µs/call |
311 | |||||
312 | 3 | 7µ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 | ||||
458 | 2 | 1µs | my $dbh = shift; | ||
459 | 2 | 15µs | 2 | 8µs | local $SIG{__WARN__} if $dbh->FETCH('PrintError'); # spent 8µs making 2 calls to DBI::common::FETCH, avg 4µs/call |
460 | 2 | 101µs | 2 | 96µs | my $ret = DBD::Pg::db::_ping($dbh); # spent 96µs making 2 calls to DBD::Pg::db::_ping, avg 48µs/call |
461 | 2 | 4µ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 | |||||
1679 | 1; | ||||
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 | |||||
# 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 | |||||
# 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 | |||||
# spent 7µs within DBD::Pg::dr::CORE:subst which was called:
# once (7µs+0s) by DBD::Pg::dr::connect at line 246 | |||||
# 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 |