← 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:08 2021

Filename/usr/local/lib/perl5/site_perl/mach/5.32/DBI.pm
StatementsExecuted 87 statements in 286µs
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
42171µs71µsDBI::::_new_handle DBI::_new_handle (xsub)
11154µs6.78msDBI::::connect DBI::connect
11139µs6.72msDBI::::__ANON__[:746] DBI::__ANON__[:746]
11135µs59µsDBI::::END DBI::END
31133µs88µsDBI::::_new_sth DBI::_new_sth
11114µs30µsDBI::::_new_dbh DBI::_new_dbh
11112µs22µsDBI::::disconnect_all DBI::disconnect_all
1118µs8µsDBI::::CORE:subst DBI::CORE:subst (opcode)
1112µs2µsDBD::_::common::::trace_msg DBD::_::common::trace_msg (xsub)
0000s0sDBD::Switch::dr::::CLONEDBD::Switch::dr::CLONE
0000s0sDBD::Switch::dr::::FETCHDBD::Switch::dr::FETCH
0000s0sDBD::Switch::dr::::STOREDBD::Switch::dr::STORE
0000s0sDBD::Switch::dr::::driverDBD::Switch::dr::driver
0000s0sDBD::_::common::::BEGIN@1364 DBD::_::common::BEGIN@1364
0000s0sDBD::_::common::::CLEAR DBD::_::common::CLEAR
0000s0sDBD::_::common::::CORE:match DBD::_::common::CORE:match (opcode)
0000s0sDBD::_::common::::EXISTS DBD::_::common::EXISTS
0000s0sDBD::_::common::::FETCH_many DBD::_::common::FETCH_many
0000s0sDBD::_::common::::FIRSTKEY DBD::_::common::FIRSTKEY
0000s0sDBD::_::common::::NEXTKEY DBD::_::common::NEXTKEY
0000s0sDBD::_::common::::install_method DBD::_::common::install_method
0000s0sDBD::_::common::::parse_trace_flag DBD::_::common::parse_trace_flag
0000s0sDBD::_::common::::parse_trace_flags DBD::_::common::parse_trace_flags
0000s0sDBD::_::common::::private_attribute_info DBD::_::common::private_attribute_info
0000s0sDBD::_::common::::visit_child_handles DBD::_::common::visit_child_handles
0000s0sDBD::_::db::::BEGIN@1529 DBD::_::db::BEGIN@1529
0000s0sDBD::_::db::::_do_selectrow DBD::_::db::_do_selectrow
0000s0sDBD::_::db::::begin_work DBD::_::db::begin_work
0000s0sDBD::_::db::::clone DBD::_::db::clone
0000s0sDBD::_::db::::data_sources DBD::_::db::data_sources
0000s0sDBD::_::db::::do DBD::_::db::do
0000s0sDBD::_::db::::ping DBD::_::db::ping
0000s0sDBD::_::db::::prepare_cached DBD::_::db::prepare_cached
0000s0sDBD::_::db::::primary_key DBD::_::db::primary_key
0000s0sDBD::_::db::::quote DBD::_::db::quote
0000s0sDBD::_::db::::quote_identifier DBD::_::db::quote_identifier
0000s0sDBD::_::db::::rows DBD::_::db::rows
0000s0sDBD::_::db::::selectall_array DBD::_::db::selectall_array
0000s0sDBD::_::db::::selectall_arrayref DBD::_::db::selectall_arrayref
0000s0sDBD::_::db::::selectall_hashref DBD::_::db::selectall_hashref
0000s0sDBD::_::db::::selectcol_arrayref DBD::_::db::selectcol_arrayref
0000s0sDBD::_::db::::selectrow_array DBD::_::db::selectrow_array
0000s0sDBD::_::db::::selectrow_arrayref DBD::_::db::selectrow_arrayref
0000s0sDBD::_::db::::selectrow_hashref DBD::_::db::selectrow_hashref
0000s0sDBD::_::db::::tables DBD::_::db::tables
0000s0sDBD::_::db::::type_info DBD::_::db::type_info
0000s0sDBD::_::dr::::BEGIN@1464 DBD::_::dr::BEGIN@1464
0000s0sDBD::_::dr::::connect DBD::_::dr::connect
0000s0sDBD::_::dr::::connect_cached DBD::_::dr::connect_cached
0000s0sDBD::_::dr::::default_user DBD::_::dr::default_user
0000s0sDBD::_::st::::BEGIN@1851 DBD::_::st::BEGIN@1851
0000s0sDBD::_::st::::__ANON__[:1967] DBD::_::st::__ANON__[:1967]
0000s0sDBD::_::st::::__ANON__[:2001] DBD::_::st::__ANON__[:2001]
0000s0sDBD::_::st::::bind_columns DBD::_::st::bind_columns
0000s0sDBD::_::st::::bind_param DBD::_::st::bind_param
0000s0sDBD::_::st::::bind_param_array DBD::_::st::bind_param_array
0000s0sDBD::_::st::::bind_param_inout_array DBD::_::st::bind_param_inout_array
0000s0sDBD::_::st::::blob_copy_to_file DBD::_::st::blob_copy_to_file
0000s0sDBD::_::st::::execute_array DBD::_::st::execute_array
0000s0sDBD::_::st::::execute_for_fetch DBD::_::st::execute_for_fetch
0000s0sDBD::_::st::::fetchall_arrayref DBD::_::st::fetchall_arrayref
0000s0sDBD::_::st::::fetchall_hashref DBD::_::st::fetchall_hashref
0000s0sDBD::_::st::::last_insert_id DBD::_::st::last_insert_id
0000s0sDBD::_::st::::more_results DBD::_::st::more_results
0000s0sDBI::::BEGIN@1049 DBI::BEGIN@1049
0000s0sDBI::::BEGIN@13 DBI::BEGIN@13
0000s0sDBI::::BEGIN@174 DBI::BEGIN@174
0000s0sDBI::::BEGIN@175 DBI::BEGIN@175
0000s0sDBI::::BEGIN@176 DBI::BEGIN@176
0000s0sDBI::::BEGIN@177 DBI::BEGIN@177
0000s0sDBI::::BEGIN@179 DBI::BEGIN@179
0000s0sDBI::::BEGIN@288 DBI::BEGIN@288
0000s0sDBI::::BEGIN@292 DBI::BEGIN@292
0000s0sDBI::::BEGIN@546 DBI::BEGIN@546
0000s0sDBI::::BEGIN@705 DBI::BEGIN@705
0000s0sDBI::::BEGIN@818 DBI::BEGIN@818
0000s0sDBI::::BEGIN@852 DBI::BEGIN@852
0000s0sDBI::::BEGIN@883 DBI::BEGIN@883
0000s0sDBI::::BEGIN@980 DBI::BEGIN@980
0000s0sDBI::::CLONE DBI::CLONE
0000s0sDBI::::CORE:match DBI::CORE:match (opcode)
0000s0sDBI::::__ANON__[:1045] DBI::__ANON__[:1045]
0000s0sDBI::::__ANON__[:1138] DBI::__ANON__[:1138]
0000s0sDBI::::__ANON__[:1172] DBI::__ANON__[:1172]
0000s0sDBI::::__ANON__[:1173] DBI::__ANON__[:1173]
0000s0sDBI::::_dbtype_names DBI::_dbtype_names
0000s0sDBI::::_install_method DBI::_install_method (xsub)
0000s0sDBI::::_load_class DBI::_load_class
0000s0sDBI::::_new_drh DBI::_new_drh
0000s0sDBI::::_rebless DBI::_rebless
0000s0sDBI::::_rebless_dbtype_subclass DBI::_rebless_dbtype_subclass
0000s0sDBI::::_set_isa DBI::_set_isa
0000s0sDBI::::available_drivers DBI::available_drivers
0000s0sDBI::::bootstrap DBI::bootstrap (xsub)
0000s0sDBI::::connect_cached DBI::connect_cached
0000s0sDBI::::connect_test_perf DBI::connect_test_perf
0000s0sDBI::::data_diff DBI::data_diff
0000s0sDBI::::data_sources DBI::data_sources
0000s0sDBI::::data_string_desc DBI::data_string_desc
0000s0sDBI::::data_string_diff DBI::data_string_diff
0000s0sDBI::::disconnect DBI::disconnect
0000s0sDBI::::driver_prefix DBI::driver_prefix
0000s0sDBI::::dump_dbd_registry DBI::dump_dbd_registry
0000s0sDBI::::dump_results DBI::dump_results
0000s0sDBI::::err DBI::err
0000s0sDBI::::errstr DBI::errstr
0000s0sDBI::::init_rootclass DBI::init_rootclass
0000s0sDBI::::install_driver DBI::install_driver
0000s0sDBI::::installed_drivers DBI::installed_drivers
0000s0sDBI::::installed_methods DBI::installed_methods
0000s0sDBI::::installed_versions DBI::installed_versions
0000s0sDBI::::neat_list DBI::neat_list
0000s0sDBI::::parse_dsn DBI::parse_dsn
0000s0sDBI::::setup_driver DBI::setup_driver
0000s0sDBI::var::::STORE DBI::var::STORE
0000s0sDBI::var::::TIESCALAR DBI::var::TIESCALAR
0000s0sDBI::::visit_handles DBI::visit_handles
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1# $Id$
2# vim: ts=8:sw=4:et
3#
4# Copyright (c) 1994-2012 Tim Bunce Ireland
5#
6# See COPYRIGHT section in pod text below for usage and distribution rights.
7#
8
9package DBI;
10
11require 5.008_001;
12
13BEGIN {
14our $XS_VERSION = our $VERSION = "1.643"; # ==> ALSO update the version in the pod text below!
15$VERSION = eval $VERSION;
# spent 0s executing statements in string eval
16}
17
18=head1 NAME
19
20DBI - Database independent interface for Perl
21
22=head1 SYNOPSIS
23
24 use DBI;
25
26 @driver_names = DBI->available_drivers;
27 %drivers = DBI->installed_drivers;
28 @data_sources = DBI->data_sources($driver_name, \%attr);
29
30 $dbh = DBI->connect($data_source, $username, $auth, \%attr);
31
32 $rv = $dbh->do($statement);
33 $rv = $dbh->do($statement, \%attr);
34 $rv = $dbh->do($statement, \%attr, @bind_values);
35
36 $ary_ref = $dbh->selectall_arrayref($statement);
37 $hash_ref = $dbh->selectall_hashref($statement, $key_field);
38
39 $ary_ref = $dbh->selectcol_arrayref($statement);
40 $ary_ref = $dbh->selectcol_arrayref($statement, \%attr);
41
42 @row_ary = $dbh->selectrow_array($statement);
43 $ary_ref = $dbh->selectrow_arrayref($statement);
44 $hash_ref = $dbh->selectrow_hashref($statement);
45
46 $sth = $dbh->prepare($statement);
47 $sth = $dbh->prepare_cached($statement);
48
49 $rc = $sth->bind_param($p_num, $bind_value);
50 $rc = $sth->bind_param($p_num, $bind_value, $bind_type);
51 $rc = $sth->bind_param($p_num, $bind_value, \%attr);
52
53 $rv = $sth->execute;
54 $rv = $sth->execute(@bind_values);
55 $rv = $sth->execute_array(\%attr, ...);
56
57 $rc = $sth->bind_col($col_num, \$col_variable);
58 $rc = $sth->bind_columns(@list_of_refs_to_vars_to_bind);
59
60 @row_ary = $sth->fetchrow_array;
61 $ary_ref = $sth->fetchrow_arrayref;
62 $hash_ref = $sth->fetchrow_hashref;
63
64 $ary_ref = $sth->fetchall_arrayref;
65 $ary_ref = $sth->fetchall_arrayref( $slice, $max_rows );
66
67 $hash_ref = $sth->fetchall_hashref( $key_field );
68
69 $rv = $sth->rows;
70
71 $rc = $dbh->begin_work;
72 $rc = $dbh->commit;
73 $rc = $dbh->rollback;
74
75 $quoted_string = $dbh->quote($string);
76
77 $rc = $h->err;
78 $str = $h->errstr;
79 $rv = $h->state;
80
81 $rc = $dbh->disconnect;
82
83I<The synopsis above only lists the major methods and parameters.>
84
85
86=head2 GETTING HELP
87
88=head3 General
89
90Before asking any questions, reread this document, consult the
91archives and read the DBI FAQ. The archives are listed
92at the end of this document and on the DBI home page L<http://dbi.perl.org/support/>
93
94You might also like to read the Advanced DBI Tutorial at
95L<http://www.slideshare.net/Tim.Bunce/dbi-advanced-tutorial-2007>
96
97To help you make the best use of the dbi-users mailing list,
98and any other lists or forums you may use, I recommend that you read
99"Getting Answers" by Mike Ash: L<http://mikeash.com/getting_answers.html>.
100
101=head3 Mailing Lists
102
103If you have questions about DBI, or DBD driver modules, you can get
104help from the I<dbi-users@perl.org> mailing list. This is the best way to get
105help. You don't have to subscribe to the list in order to post, though I'd
106recommend it. You can get help on subscribing and using the list by emailing
107I<dbi-users-help@perl.org>.
108
109Please note that Tim Bunce does not maintain the mailing lists or the
110web pages (generous volunteers do that). So please don't send mail
111directly to him; he just doesn't have the time to answer questions
112personally. The I<dbi-users> mailing list has lots of experienced
113people who should be able to help you if you need it. If you do email
114Tim he is very likely to just forward it to the mailing list.
115
116=head3 IRC
117
118DBI IRC Channel: #dbi on irc.perl.org (L<irc://irc.perl.org/#dbi>)
119
120=for html <a href="http://chat.mibbit.com/#dbi@irc.perl.org">(click for instant chatroom login)</a>
121
122=head3 Online
123
124StackOverflow has a DBI tag L<http://stackoverflow.com/questions/tagged/dbi>
125with over 800 questions.
126
127The DBI home page at L<http://dbi.perl.org/> and the DBI FAQ
128at L<http://faq.dbi-support.com/> may be worth a visit.
129They include links to other resources, but I<are rather out-dated>.
130
131=head3 Reporting a Bug
132
133If you think you've found a bug then please read
134"How to Report Bugs Effectively" by Simon Tatham:
135L<http://www.chiark.greenend.org.uk/~sgtatham/bugs.html>.
136
137If you think you've found a memory leak then read L</Memory Leaks>.
138
139Your problem is most likely related to the specific DBD driver module you're
140using. If that's the case then click on the 'Bugs' link on the L<http://metacpan.org>
141page for your driver. Only submit a bug report against the DBI itself if you're
142sure that your issue isn't related to the driver you're using.
143
144=head2 NOTES
145
146This is the DBI specification that corresponds to DBI version 1.642
147(see L<DBI::Changes> for details).
148
149The DBI is evolving at a steady pace, so it's good to check that
150you have the latest copy.
151
152The significant user-visible changes in each release are documented
153in the L<DBI::Changes> module so you can read them by executing
154C<perldoc DBI::Changes>.
155
156Some DBI changes require changes in the drivers, but the drivers
157can take some time to catch up. Newer versions of the DBI have
158added features that may not yet be supported by the drivers you
159use. Talk to the authors of your drivers if you need a new feature
160that is not yet supported.
161
162Features added after DBI 1.21 (February 2002) are marked in the
163text with the version number of the DBI release they first appeared in.
164
165Extensions to the DBI API often use the C<DBIx::*> namespace.
166See L</Naming Conventions and Name Space>. DBI extension modules
167can be found at L<https://metacpan.org/search?q=DBIx>. And all modules
168related to the DBI can be found at L<https://metacpan.org/search?q=DBI>.
169
170=cut
171
172# The POD text continues at the end of the file.
173
174use Scalar::Util ();
175use Carp();
176use DynaLoader ();
177use Exporter ();
178
179BEGIN {
180@ISA = qw(Exporter DynaLoader);
181
182# Make some utility functions available if asked for
183@EXPORT = (); # we export nothing by default
184@EXPORT_OK = qw(%DBI %DBI_methods hash); # also populated by export_ok_tags:
185%EXPORT_TAGS = (
186 sql_types => [ qw(
187 SQL_GUID
188 SQL_WLONGVARCHAR
189 SQL_WVARCHAR
190 SQL_WCHAR
191 SQL_BIGINT
192 SQL_BIT
193 SQL_TINYINT
194 SQL_LONGVARBINARY
195 SQL_VARBINARY
196 SQL_BINARY
197 SQL_LONGVARCHAR
198 SQL_UNKNOWN_TYPE
199 SQL_ALL_TYPES
200 SQL_CHAR
201 SQL_NUMERIC
202 SQL_DECIMAL
203 SQL_INTEGER
204 SQL_SMALLINT
205 SQL_FLOAT
206 SQL_REAL
207 SQL_DOUBLE
208 SQL_DATETIME
209 SQL_DATE
210 SQL_INTERVAL
211 SQL_TIME
212 SQL_TIMESTAMP
213 SQL_VARCHAR
214 SQL_BOOLEAN
215 SQL_UDT
216 SQL_UDT_LOCATOR
217 SQL_ROW
218 SQL_REF
219 SQL_BLOB
220 SQL_BLOB_LOCATOR
221 SQL_CLOB
222 SQL_CLOB_LOCATOR
223 SQL_ARRAY
224 SQL_ARRAY_LOCATOR
225 SQL_MULTISET
226 SQL_MULTISET_LOCATOR
227 SQL_TYPE_DATE
228 SQL_TYPE_TIME
229 SQL_TYPE_TIMESTAMP
230 SQL_TYPE_TIME_WITH_TIMEZONE
231 SQL_TYPE_TIMESTAMP_WITH_TIMEZONE
232 SQL_INTERVAL_YEAR
233 SQL_INTERVAL_MONTH
234 SQL_INTERVAL_DAY
235 SQL_INTERVAL_HOUR
236 SQL_INTERVAL_MINUTE
237 SQL_INTERVAL_SECOND
238 SQL_INTERVAL_YEAR_TO_MONTH
239 SQL_INTERVAL_DAY_TO_HOUR
240 SQL_INTERVAL_DAY_TO_MINUTE
241 SQL_INTERVAL_DAY_TO_SECOND
242 SQL_INTERVAL_HOUR_TO_MINUTE
243 SQL_INTERVAL_HOUR_TO_SECOND
244 SQL_INTERVAL_MINUTE_TO_SECOND
245 ) ],
246 sql_cursor_types => [ qw(
247 SQL_CURSOR_FORWARD_ONLY
248 SQL_CURSOR_KEYSET_DRIVEN
249 SQL_CURSOR_DYNAMIC
250 SQL_CURSOR_STATIC
251 SQL_CURSOR_TYPE_DEFAULT
252 ) ], # for ODBC cursor types
253 utils => [ qw(
254 neat neat_list $neat_maxlen dump_results looks_like_number
255 data_string_diff data_string_desc data_diff sql_type_cast
256 DBIstcf_DISCARD_STRING
257 DBIstcf_STRICT
258 ) ],
259 profile => [ qw(
260 dbi_profile dbi_profile_merge dbi_profile_merge_nodes dbi_time
261 ) ], # notionally "in" DBI::Profile and normally imported from there
262);
263
264$DBI::dbi_debug = 0; # mixture of bit fields and int sub-fields
265$DBI::neat_maxlen = 1000;
266$DBI::stderr = 2_000_000_000; # a very round number below 2**31
267
268# If you get an error here like "Can't find loadable object ..."
269# then you haven't installed the DBI correctly. Read the README
270# then install it again.
271if ( $ENV{DBI_PUREPERL} ) {
272 eval { bootstrap DBI $XS_VERSION } if $ENV{DBI_PUREPERL} == 1;
273 require DBI::PurePerl if $@ or $ENV{DBI_PUREPERL} >= 2;
274 $DBI::PurePerl ||= 0; # just to silence "only used once" warnings
275}
276else {
277 bootstrap DBI $XS_VERSION;
278}
279
280$EXPORT_TAGS{preparse_flags} = [ grep { /^DBIpp_\w\w_/ } keys %{__PACKAGE__."::"} ];
281
282Exporter::export_ok_tags(keys %EXPORT_TAGS);
283
284}
285
286# Alias some handle methods to also be DBI class methods
287for (qw(trace_msg set_err parse_trace_flag parse_trace_flags)) {
288 no strict;
289 *$_ = \&{"DBD::_::common::$_"};
290}
291
292use strict;
293
294DBI->trace(split /=/, $ENV{DBI_TRACE}, 2) if $ENV{DBI_TRACE};
295
296$DBI::connect_via ||= "connect";
297
298# check if user wants a persistent database connection ( Apache + mod_perl )
299if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
300 $DBI::connect_via = "Apache::DBI::connect";
301 DBI->trace_msg("DBI connect via $DBI::connect_via in $INC{'Apache/DBI.pm'}\n");
302}
303
304%DBI::installed_drh = (); # maps driver names to installed driver handles
305sub installed_drivers { %DBI::installed_drh }
306%DBI::installed_methods = (); # XXX undocumented, may change
307sub installed_methods { %DBI::installed_methods }
308
309# Setup special DBI dynamic variables. See DBI::var::FETCH for details.
310# These are dynamically associated with the last handle used.
311tie $DBI::err, 'DBI::var', '*err'; # special case: referenced via IHA list
312tie $DBI::state, 'DBI::var', '"state'; # special case: referenced via IHA list
313tie $DBI::lasth, 'DBI::var', '!lasth'; # special case: return boolean
314tie $DBI::errstr, 'DBI::var', '&errstr'; # call &errstr in last used pkg
315tie $DBI::rows, 'DBI::var', '&rows'; # call &rows in last used pkg
316sub DBI::var::TIESCALAR{ my $var = $_[1]; bless \$var, 'DBI::var'; }
317sub DBI::var::STORE { Carp::croak("Can't modify \$DBI::${$_[0]} special variable") }
318
319# --- Driver Specific Prefix Registry ---
320
321my $dbd_prefix_registry = {
322 ad_ => { class => 'DBD::AnyData', },
323 ad2_ => { class => 'DBD::AnyData2', },
324 ado_ => { class => 'DBD::ADO', },
325 amzn_ => { class => 'DBD::Amazon', },
326 best_ => { class => 'DBD::BestWins', },
327 csv_ => { class => 'DBD::CSV', },
328 cubrid_ => { class => 'DBD::cubrid', },
329 db2_ => { class => 'DBD::DB2', },
330 dbi_ => { class => 'DBI', },
331 dbm_ => { class => 'DBD::DBM', },
332 df_ => { class => 'DBD::DF', },
333 examplep_ => { class => 'DBD::ExampleP', },
334 f_ => { class => 'DBD::File', },
335 file_ => { class => 'DBD::TextFile', },
336 go_ => { class => 'DBD::Gofer', },
337 ib_ => { class => 'DBD::InterBase', },
338 ing_ => { class => 'DBD::Ingres', },
339 ix_ => { class => 'DBD::Informix', },
340 jdbc_ => { class => 'DBD::JDBC', },
341 mariadb_ => { class => 'DBD::MariaDB', },
342 mem_ => { class => 'DBD::Mem', },
343 mo_ => { class => 'DBD::MO', },
344 monetdb_ => { class => 'DBD::monetdb', },
345 msql_ => { class => 'DBD::mSQL', },
346 mvsftp_ => { class => 'DBD::MVS_FTPSQL', },
347 mysql_ => { class => 'DBD::mysql', },
348 multi_ => { class => 'DBD::Multi' },
349 mx_ => { class => 'DBD::Multiplex', },
350 neo_ => { class => 'DBD::Neo4p', },
351 nullp_ => { class => 'DBD::NullP', },
352 odbc_ => { class => 'DBD::ODBC', },
353 ora_ => { class => 'DBD::Oracle', },
354 pg_ => { class => 'DBD::Pg', },
355 pgpp_ => { class => 'DBD::PgPP', },
356 plb_ => { class => 'DBD::Plibdata', },
357 po_ => { class => 'DBD::PO', },
358 proxy_ => { class => 'DBD::Proxy', },
359 ram_ => { class => 'DBD::RAM', },
360 rdb_ => { class => 'DBD::RDB', },
361 sapdb_ => { class => 'DBD::SAP_DB', },
362 snmp_ => { class => 'DBD::SNMP', },
363 solid_ => { class => 'DBD::Solid', },
364 spatialite_ => { class => 'DBD::Spatialite', },
365 sponge_ => { class => 'DBD::Sponge', },
366 sql_ => { class => 'DBI::DBD::SqlEngine', },
367 sqlite_ => { class => 'DBD::SQLite', },
368 syb_ => { class => 'DBD::Sybase', },
369 sys_ => { class => 'DBD::Sys', },
370 tdat_ => { class => 'DBD::Teradata', },
371 tmpl_ => { class => 'DBD::Template', },
372 tmplss_ => { class => 'DBD::TemplateSS', },
373 tree_ => { class => 'DBD::TreeData', },
374 tuber_ => { class => 'DBD::Tuber', },
375 uni_ => { class => 'DBD::Unify', },
376 vt_ => { class => 'DBD::Vt', },
377 wmi_ => { class => 'DBD::WMI', },
378 x_ => { }, # for private use
379 xbase_ => { class => 'DBD::XBase', },
380 xmlsimple_ => { class => 'DBD::XMLSimple', },
381 xl_ => { class => 'DBD::Excel', },
382 yaswi_ => { class => 'DBD::Yaswi', },
383};
384
385my %dbd_class_registry = map { $dbd_prefix_registry->{$_}->{class} => { prefix => $_ } }
386 grep { exists $dbd_prefix_registry->{$_}->{class} }
387 keys %{$dbd_prefix_registry};
388
389sub dump_dbd_registry {
390 require Data::Dumper;
391 local $Data::Dumper::Sortkeys=1;
392 local $Data::Dumper::Indent=1;
393 print Data::Dumper->Dump([$dbd_prefix_registry], [qw($dbd_prefix_registry)]);
394}
395
396# --- Dynamically create the DBI Standard Interface
397
398my $keeperr = { O=>0x0004 };
399
400%DBI::DBI_methods = ( # Define the DBI interface methods per class:
401
402 common => { # Interface methods common to all DBI handle classes
403 'DESTROY' => { O=>0x004|0x10000 },
404 'CLEAR' => $keeperr,
405 'EXISTS' => $keeperr,
406 'FETCH' => { O=>0x0404 },
407 'FETCH_many' => { O=>0x0404 },
408 'FIRSTKEY' => $keeperr,
409 'NEXTKEY' => $keeperr,
410 'STORE' => { O=>0x0418 | 0x4 },
411 'DELETE' => { O=>0x0404 },
412 can => { O=>0x0100 }, # special case, see dispatch
413 debug => { U =>[1,2,'[$debug_level]'], O=>0x0004 }, # old name for trace
414 dump_handle => { U =>[1,3,'[$message [, $level]]'], O=>0x0004 },
415 err => $keeperr,
416 errstr => $keeperr,
417 state => $keeperr,
418 func => { O=>0x0006 },
419 parse_trace_flag => { U =>[2,2,'$name'], O=>0x0404, T=>8 },
420 parse_trace_flags => { U =>[2,2,'$flags'], O=>0x0404, T=>8 },
421 private_data => { U =>[1,1], O=>0x0004 },
422 set_err => { U =>[3,6,'$err, $errmsg [, $state, $method, $rv]'], O=>0x0010 },
423 trace => { U =>[1,3,'[$trace_level, [$filename]]'], O=>0x0004 },
424 trace_msg => { U =>[2,3,'$message_text [, $min_level ]' ], O=>0x0004, T=>8 },
425 swap_inner_handle => { U =>[2,3,'$h [, $allow_reparent ]'] },
426 private_attribute_info => { },
427 visit_child_handles => { U => [2,3,'$coderef [, $info ]'], O=>0x0404, T=>4 },
428 },
429 dr => { # Database Driver Interface
430 'connect' => { U =>[1,5,'[$db [,$user [,$passwd [,\%attr]]]]'], H=>3, O=>0x8000, T=>0x200 },
431 'connect_cached'=>{U=>[1,5,'[$db [,$user [,$passwd [,\%attr]]]]'], H=>3, O=>0x8000, T=>0x200 },
432 'disconnect_all'=>{ U =>[1,1], O=>0x0800, T=>0x200 },
433 data_sources => { U =>[1,2,'[\%attr]' ], O=>0x0800, T=>0x200 },
434 default_user => { U =>[3,4,'$user, $pass [, \%attr]' ], T=>0x200 },
435 dbixs_revision => $keeperr,
436 },
437 db => { # Database Session Class Interface
438 data_sources => { U =>[1,2,'[\%attr]' ], O=>0x0200 },
439 take_imp_data => { U =>[1,1], O=>0x10000 },
440 clone => { U =>[1,2,'[\%attr]'], T=>0x200 },
441 connected => { U =>[1,0], O => 0x0004, T=>0x200, H=>3 },
442 begin_work => { U =>[1,2,'[ \%attr ]'], O=>0x0400, T=>0x1000 },
443 commit => { U =>[1,1], O=>0x0480|0x0800, T=>0x1000 },
444 rollback => { U =>[1,1], O=>0x0480|0x0800, T=>0x1000 },
445 'do' => { U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x3200 },
446 last_insert_id => { U =>[1,6,'[$catalog [,$schema [,$table_name [,$field_name [, \%attr ]]]]]'], O=>0x2800 },
447 preparse => { }, # XXX
448 prepare => { U =>[2,3,'$statement [, \%attr]'], O=>0xA200 },
449 prepare_cached => { U =>[2,4,'$statement [, \%attr [, $if_active ] ]'], O=>0xA200 },
450 selectrow_array => { U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
451 selectrow_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
452 selectrow_hashref=>{ U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
453 selectall_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
454 selectall_array =>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
455 selectall_hashref=>{ U =>[3,0,'$statement, $keyfield [, \%attr [, @bind_params ] ]'], O=>0x2000 },
456 selectcol_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
457 ping => { U =>[1,1], O=>0x0404 },
458 disconnect => { U =>[1,1], O=>0x0400|0x0800|0x10000, T=>0x200 },
459 quote => { U =>[2,3, '$string [, $data_type ]' ], O=>0x0430, T=>2 },
460 quote_identifier=> { U =>[2,6, '$name [, ...] [, \%attr ]' ], O=>0x0430, T=>2 },
461 rows => $keeperr,
462
463 tables => { U =>[1,6,'$catalog, $schema, $table, $type [, \%attr ]' ], O=>0x2200 },
464 table_info => { U =>[1,6,'$catalog, $schema, $table, $type [, \%attr ]' ], O=>0x2200|0x8800 },
465 column_info => { U =>[5,6,'$catalog, $schema, $table, $column [, \%attr ]'],O=>0x2200|0x8800 },
466 primary_key_info=> { U =>[4,5,'$catalog, $schema, $table [, \%attr ]' ], O=>0x2200|0x8800 },
467 primary_key => { U =>[4,5,'$catalog, $schema, $table [, \%attr ]' ], O=>0x2200 },
468 foreign_key_info=> { U =>[7,8,'$pk_catalog, $pk_schema, $pk_table, $fk_catalog, $fk_schema, $fk_table [, \%attr ]' ], O=>0x2200|0x8800 },
469 statistics_info => { U =>[6,7,'$catalog, $schema, $table, $unique_only, $quick, [, \%attr ]' ], O=>0x2200|0x8800 },
470 type_info_all => { U =>[1,1], O=>0x2200|0x0800 },
471 type_info => { U =>[1,2,'$data_type'], O=>0x2200 },
472 get_info => { U =>[2,2,'$info_type'], O=>0x2200|0x0800 },
473 },
474 st => { # Statement Class Interface
475 bind_col => { U =>[3,4,'$column, \\$var [, \%attr]'] },
476 bind_columns => { U =>[2,0,'\\$var1 [, \\$var2, ...]'] },
477 bind_param => { U =>[3,4,'$parameter, $var [, \%attr]'] },
478 bind_param_inout=> { U =>[4,5,'$parameter, \\$var, $maxlen, [, \%attr]'] },
479 execute => { U =>[1,0,'[@args]'], O=>0x1040 },
480 last_insert_id => { U =>[1,6,'[$catalog [,$schema [,$table_name [,$field_name [, \%attr ]]]]]'], O=>0x2800 },
481
482 bind_param_array => { U =>[3,4,'$parameter, $var [, \%attr]'] },
483 bind_param_inout_array => { U =>[4,5,'$parameter, \\@var, $maxlen, [, \%attr]'] },
484 execute_array => { U =>[2,0,'\\%attribs [, @args]'], O=>0x1040|0x4000 },
485 execute_for_fetch => { U =>[2,3,'$fetch_sub [, $tuple_status]'], O=>0x1040|0x4000 },
486
487 fetch => undef, # alias for fetchrow_arrayref
488 fetchrow_arrayref => undef,
489 fetchrow_hashref => undef,
490 fetchrow_array => undef,
491 fetchrow => undef, # old alias for fetchrow_array
492
493 fetchall_arrayref => { U =>[1,3, '[ $slice [, $max_rows]]'] },
494 fetchall_hashref => { U =>[2,2,'$key_field'] },
495
496 blob_read => { U =>[4,5,'$field, $offset, $len [, \\$buf [, $bufoffset]]'] },
497 blob_copy_to_file => { U =>[3,3,'$field, $filename_or_handleref'] },
498 dump_results => { U =>[1,5,'$maxfieldlen, $linesep, $fieldsep, $filehandle'] },
499 more_results => { U =>[1,1] },
500 finish => { U =>[1,1] },
501 cancel => { U =>[1,1], O=>0x0800 },
502 rows => $keeperr,
503
504 _get_fbav => undef,
505 _set_fbav => { T=>6 },
506 },
507);
508
509while ( my ($class, $meths) = each %DBI::DBI_methods ) {
510 my $ima_trace = 0+($ENV{DBI_IMA_TRACE}||0);
511 while ( my ($method, $info) = each %$meths ) {
512 my $fullmeth = "DBI::${class}::$method";
513 if (($DBI::dbi_debug & 0xF) == 15) { # quick hack to list DBI methods
514 # and optionally filter by IMA flags
515 my $O = $info->{O}||0;
516 printf "0x%04x %-20s\n", $O, $fullmeth
517 unless $ima_trace && !($O & $ima_trace);
518 }
519 DBI->_install_method($fullmeth, 'DBI.pm', $info);
520 }
521}
522
523{
524 package DBI::common;
525 @DBI::dr::ISA = ('DBI::common');
526 @DBI::db::ISA = ('DBI::common');
527 @DBI::st::ISA = ('DBI::common');
528}
529
530# End of init code
531
532
# spent 59µs (35+24) within DBI::END which was called: # once (35µs+24µs) by main::RUNTIME at line 0 of /usr/local/libexec/sympa/task_manager-debug.pl
END {
53311µs return unless defined &DBI::trace_msg; # return unless bootstrap'd ok
534117µs local ($!,$?);
535111µs12µs DBI->trace_msg(sprintf(" -- DBI::END (\$\@: %s, \$!: %s)\n", $@||'', $!||''), 2);
# spent 2µs making 1 call to DBD::_::common::trace_msg
536 # Let drivers know why we are calling disconnect_all:
53711µs $DBI::PERL_ENDING = $DBI::PERL_ENDING = 1; # avoid typo warning
53816µs122µs DBI->disconnect_all() if %DBI::installed_drh;
# spent 22µs making 1 call to DBI::disconnect_all
539}
540
541
542sub CLONE {
543 _clone_dbis() unless $DBI::PurePerl; # clone the DBIS structure
544 DBI->trace_msg("CLONE DBI for new thread\n");
545 while ( my ($driver, $drh) = each %DBI::installed_drh) {
546 no strict 'refs';
547 next if defined &{"DBD::${driver}::CLONE"};
548 warn("$driver has no driver CLONE() function so is unsafe threaded\n");
549 }
550 %DBI::installed_drh = (); # clear loaded drivers so they have a chance to reinitialize
551}
552
553sub parse_dsn {
554 my ($class, $dsn) = @_;
555 $dsn =~ s/^(dbi):(\w*?)(?:\((.*?)\))?://i or return;
556 my ($scheme, $driver, $attr, $attr_hash) = (lc($1), $2, $3);
557 $driver ||= $ENV{DBI_DRIVER} || '';
558 $attr_hash = { split /\s*=>?\s*|\s*,\s*/, $attr, -1 } if $attr;
559 return ($scheme, $driver, $attr, $attr_hash, $dsn);
560}
561
562sub visit_handles {
563 my ($class, $code, $outer_info) = @_;
564 $outer_info = {} if not defined $outer_info;
565 my %drh = DBI->installed_drivers;
566 for my $h (values %drh) {
567 my $child_info = $code->($h, $outer_info)
568 or next;
569 $h->visit_child_handles($code, $child_info);
570 }
571 return $outer_info;
572}
573
574
575# --- The DBI->connect Front Door methods
576
577sub connect_cached {
578 # For library code using connect_cached() with mod_perl
579 # we redirect those calls to Apache::DBI::connect() as well
580 my ($class, $dsn, $user, $pass, $attr) = @_;
581 my $dbi_connect_method = ($DBI::connect_via eq "Apache::DBI::connect")
582 ? 'Apache::DBI::connect' : 'connect_cached';
583 $attr = {
584 $attr ? %$attr : (), # clone, don't modify callers data
585 dbi_connect_method => $dbi_connect_method,
586 };
587 return $class->connect($dsn, $user, $pass, $attr);
588}
589
590
# spent 6.78ms (54µs+6.73) within DBI::connect which was called: # once (54µs+6.73ms) by Sympa::Database::_connect at line 198 of /usr/local/libexec/sympa/Sympa/Database.pm
sub connect {
5911500ns my $class = shift;
59212µs my ($dsn, $user, $pass, $attr, $old_driver) = my @orig_args = @_;
5931200ns my $driver;
594
5951800ns if ($attr and !ref($attr)) { # switch $old_driver<->$attr if called in old style
596 Carp::carp("DBI->connect using 'old-style' syntax is deprecated and will be an error in future versions");
597 ($old_driver, $attr) = ($attr, $old_driver);
598 }
599
6001900ns my $connect_meth = $attr->{dbi_connect_method};
6011700ns $connect_meth ||= $DBI::connect_via; # fallback to default
602
6031600ns $dsn ||= $ENV{DBI_DSN} || $ENV{DBI_DBNAME} || '' unless $old_driver;
604
6051400ns if ($DBI::dbi_debug) {
606 local $^W = 0;
607 pop @_ if $connect_meth ne 'connect';
608 my @args = @_; $args[2] = '****'; # hide password
609 DBI->trace_msg(" -> $class->$connect_meth(".join(", ",@args).")\n");
610 }
6111900ns Carp::croak('Usage: $class->connect([$dsn [,$user [,$passwd [,\%attr]]]])')
612 if (ref $old_driver or ($attr and not ref $attr) or
613 (ref $pass and not defined Scalar::Util::blessed($pass)));
614
615 # extract dbi:driver prefix from $dsn into $1
6161400ns my $orig_dsn = $dsn;
617112µs18µs $dsn =~ s/^dbi:(\w*?)(?:\((.*?)\))?://i
# spent 8µs making 1 call to DBI::CORE:subst
618 or '' =~ /()/; # ensure $1 etc are empty if match fails
61911µs my $driver_attrib_spec = $2 || '';
620
621 # Set $driver. Old style driver, if specified, overrides new dsn style.
622 $driver = $old_driver || $1 || $ENV{DBI_DRIVER}
62311µs or Carp::croak("Can't connect to data source '$orig_dsn' "
624 ."because I can't work out what driver to use "
625 ."(it doesn't seem to contain a 'dbi:driver:' prefix "
626 ."and the DBI_DRIVER env var is not set)");
627
62811µs my $proxy;
6291700ns if ($ENV{DBI_AUTOPROXY} && $driver ne 'Proxy' && $driver ne 'Sponge' && $driver ne 'Switch') {
630 my $dbi_autoproxy = $ENV{DBI_AUTOPROXY};
631 $proxy = 'Proxy';
632 if ($dbi_autoproxy =~ s/^dbi:(\w*?)(?:\((.*?)\))?://i) {
633 $proxy = $1;
634 $driver_attrib_spec = join ",",
635 ($driver_attrib_spec) ? $driver_attrib_spec : (),
636 ($2 ) ? $2 : ();
637 }
638 $dsn = "$dbi_autoproxy;dsn=dbi:$driver:$dsn";
639 $driver = $proxy;
640 DBI->trace_msg(" DBI_AUTOPROXY: dbi:$driver($driver_attrib_spec):$dsn\n");
641 }
642 # avoid recursion if proxy calls DBI->connect itself
6431500ns local $ENV{DBI_AUTOPROXY} if $ENV{DBI_AUTOPROXY};
644
6451300ns my %attributes; # take a copy we can delete from
6461700ns if ($old_driver) {
647 %attributes = %$attr if $attr;
648 }
649 else { # new-style connect so new default semantics
65013µs %attributes = (
651 PrintError => 1,
652 AutoCommit => 1,
653 ref $attr ? %$attr : (),
654 # attributes in DSN take precedence over \%attr connect parameter
655 $driver_attrib_spec ? (split /\s*=>?\s*|\s*,\s*/, $driver_attrib_spec, -1) : (),
656 );
657 }
6581700ns $attr = \%attributes; # now set $attr to refer to our local copy
659
66012µs my $drh = $DBI::installed_drh{$driver} || $class->install_driver($driver)
661 or die "panic: $class->install_driver($driver) failed";
662
663 # attributes in DSN take precedence over \%attr connect parameter
6641700ns $user = $attr->{Username} if defined $attr->{Username};
6651400ns $pass = $attr->{Password} if defined $attr->{Password};
6661400ns delete $attr->{Password}; # always delete Password as closure stores it securely
6671300ns if ( !(defined $user && defined $pass) ) {
668 ($user, $pass) = $drh->default_user($user, $pass, $attr);
669 }
6701600ns $attr->{Username} = $user; # force the Username to be the actual one used
671
672
# spent 6.72ms (39µs+6.68) within DBI::__ANON__[/usr/local/lib/perl5/site_perl/mach/5.32/DBI.pm:746] which was called: # once (39µs+6.68ms) by DBI::connect at line 748
my $connect_closure = sub {
6731600ns my ($old_dbh, $override_attr) = @_;
674
675 #use Data::Dumper;
676 #warn "connect_closure: ".Data::Dumper::Dumper([$attr,\%attributes, $override_attr]);
677
6781200ns my $dbh;
679112µs213.3ms unless ($dbh = $drh->$connect_meth($dsn, $user, $pass, $attr)) {
# spent 6.67ms making 1 call to DBI::dr::connect # spent 6.67ms making 1 call to DBD::Pg::dr::connect
680 $user = '' if !defined $user;
681 $dsn = '' if !defined $dsn;
682 # $drh->errstr isn't safe here because $dbh->DESTROY may not have
683 # been called yet and so the dbh errstr would not have been copied
684 # up to the drh errstr. Certainly true for connect_cached!
685 my $errstr = $DBI::errstr;
686 # Getting '(no error string)' here is a symptom of a ref loop
687 $errstr = '(no error string)' if !defined $errstr;
688 my $msg = "$class connect('$dsn','$user',...) failed: $errstr";
689 DBI->trace_msg(" $msg\n");
690 # XXX HandleWarn
691 unless ($attr->{HandleError} && $attr->{HandleError}->($msg, $drh, $dbh)) {
692 Carp::croak($msg) if $attr->{RaiseError};
693 Carp::carp ($msg) if $attr->{PrintError};
694 }
695 $! = 0; # for the daft people who do DBI->connect(...) || die "$!";
696 return $dbh; # normally undef, but HandleError could change it
697 }
698
699 # merge any attribute overrides but don't change $attr itself (for closure)
70014µs my $apply = { ($override_attr) ? (%$attr, %$override_attr ) : %$attr };
701
702 # handle basic RootClass subclassing:
70312µs my $rebless_class = $apply->{RootClass} || ($class ne 'DBI' ? $class : '');
7041400ns if ($rebless_class) {
705 no strict 'refs';
706 if ($apply->{RootClass}) { # explicit attribute (ie not static method call class)
707 delete $apply->{RootClass};
708 DBI::_load_class($rebless_class, 0);
709 }
710 unless (@{"$rebless_class\::db::ISA"} && @{"$rebless_class\::st::ISA"}) {
711 Carp::carp("DBI subclasses '$rebless_class\::db' and ::st are not setup, RootClass ignored");
712 $rebless_class = undef;
713 $class = 'DBI';
714 }
715 else {
716 $dbh->{RootClass} = $rebless_class; # $dbh->STORE called via plain DBI::db
717 DBI::_set_isa([$rebless_class], 'DBI'); # sets up both '::db' and '::st'
718 DBI::_rebless($dbh, $rebless_class); # appends '::db'
719 }
720 }
721
72211µs if (%$apply) {
723
7241500ns if ($apply->{DbTypeSubclass}) {
725 my $DbTypeSubclass = delete $apply->{DbTypeSubclass};
726 DBI::_rebless_dbtype_subclass($dbh, $rebless_class||$class, $DbTypeSubclass);
727 }
7281200ns my $a;
72911µs foreach $a (qw(Profile RaiseError PrintError AutoCommit)) { # do these first
73041µs next unless exists $apply->{$a};
731210µs23µs $dbh->{$a} = delete $apply->{$a};
# spent 3µs making 2 calls to DBI::common::STORE, avg 2µs/call
732 }
73313µs while ( my ($a, $v) = each %$apply) {
73426µs12µs eval { $dbh->{$a} = $v }; # assign in void context to avoid re-FETCH
# spent 2µs making 1 call to DBI::common::STORE
7351300ns warn $@ if $@;
736 }
737 }
738
739 # confirm to driver (ie if subclassed) that we've connected successfully
740 # and finished the attribute setup. pass in the original arguments
74116µs12µs $dbh->connected(@orig_args); #if ref $dbh ne 'DBI::db' or $proxy;
# spent 2µs making 1 call to DBI::db::connected
742
7431900ns DBI->trace_msg(" <- connect= $dbh\n") if $DBI::dbi_debug & 0xF;
744
74514µs return $dbh;
746112µs };
747
74812µs16.72ms my $dbh = &$connect_closure(undef, undef);
# spent 6.72ms making 1 call to DBI::__ANON__[DBI.pm:746]
749
75016µs12µs $dbh->{dbi_connect_closure} = $connect_closure if $dbh;
# spent 2µs making 1 call to DBI::common::STORE
751
75217µs return $dbh;
753}
754
755
756
# spent 22µs (12+10) within DBI::disconnect_all which was called: # once (12µs+10µs) by DBI::END at line 538
sub disconnect_all {
75712µs keys %DBI::installed_drh; # reset iterator
758120µs110µs while ( my ($name, $drh) = each %DBI::installed_drh ) {
# spent 10µs making 1 call to DBI::dr::disconnect_all
759 $drh->disconnect_all() if ref $drh;
760 }
761}
762
763
764sub disconnect { # a regular beginners bug
765 Carp::croak("DBI->disconnect is not a DBI method (read the DBI manual)");
766}
767
768
769sub install_driver { # croaks on failure
770 my $class = shift;
771 my($driver, $attr) = @_;
772 my $drh;
773
774 $driver ||= $ENV{DBI_DRIVER} || '';
775
776 # allow driver to be specified as a 'dbi:driver:' string
777 $driver = $1 if $driver =~ s/^DBI:(.*?)://i;
778
779 Carp::croak("usage: $class->install_driver(\$driver [, \%attr])")
780 unless ($driver and @_<=3);
781
782 # already installed
783 return $drh if $drh = $DBI::installed_drh{$driver};
784
785 $class->trace_msg(" -> $class->install_driver($driver"
786 .") for $^O perl=$] pid=$$ ruid=$< euid=$>\n")
787 if $DBI::dbi_debug & 0xF;
788
789 # --- load the code
790 my $driver_class = "DBD::$driver";
791 eval qq{package # hide from PAUSE
# spent 0s executing statements in string eval
792 DBI::_firesafe; # just in case
793 require $driver_class; # load the driver
794 };
795 if ($@) {
796 my $err = $@;
797 my $advice = "";
798 if ($err =~ /Can't find loadable object/) {
799 $advice = "Perhaps DBD::$driver was statically linked into a new perl binary."
800 ."\nIn which case you need to use that new perl binary."
801 ."\nOr perhaps only the .pm file was installed but not the shared object file."
802 }
803 elsif ($err =~ /Can't locate.*?DBD\/$driver\.pm in \@INC/) {
804 my @drv = $class->available_drivers(1);
805 $advice = "Perhaps the DBD::$driver perl module hasn't been fully installed,\n"
806 ."or perhaps the capitalisation of '$driver' isn't right.\n"
807 ."Available drivers: ".join(", ", @drv).".";
808 }
809 elsif ($err =~ /Can't load .*? for module DBD::/) {
810 $advice = "Perhaps a required shared library or dll isn't installed where expected";
811 }
812 elsif ($err =~ /Can't locate .*? in \@INC/) {
813 $advice = "Perhaps a module that DBD::$driver requires hasn't been fully installed";
814 }
815 Carp::croak("install_driver($driver) failed: $err$advice\n");
816 }
817 if ($DBI::dbi_debug & 0xF) {
818 no strict 'refs';
819 (my $driver_file = $driver_class) =~ s/::/\//g;
820 my $dbd_ver = ${"$driver_class\::VERSION"} || "undef";
821 $class->trace_msg(" install_driver: $driver_class version $dbd_ver"
822 ." loaded from $INC{qq($driver_file.pm)}\n");
823 }
824
825 # --- do some behind-the-scenes checks and setups on the driver
826 $class->setup_driver($driver_class);
827
828 # --- run the driver function
829 $drh = eval { $driver_class->driver($attr || {}) };
830 unless ($drh && ref $drh && !$@) {
831 my $advice = "";
832 $@ ||= "$driver_class->driver didn't return a handle";
833 # catch people on case in-sensitive systems using the wrong case
834 $advice = "\nPerhaps the capitalisation of DBD '$driver' isn't right."
835 if $@ =~ /locate object method/;
836 Carp::croak("$driver_class initialisation failed: $@$advice");
837 }
838
839 $DBI::installed_drh{$driver} = $drh;
840 $class->trace_msg(" <- install_driver= $drh\n") if $DBI::dbi_debug & 0xF;
841 $drh;
842}
843
844*driver = \&install_driver; # currently an alias, may change
845
846
847sub setup_driver {
848 my ($class, $driver_class) = @_;
849 my $h_type;
850 foreach $h_type (qw(dr db st)){
851 my $h_class = $driver_class."::$h_type";
852 no strict 'refs';
853 push @{"${h_class}::ISA"}, "DBD::_::$h_type"
854 unless UNIVERSAL::isa($h_class, "DBD::_::$h_type");
855 # The _mem class stuff is (IIRC) a crufty hack for global destruction
856 # timing issues in early versions of perl5 and possibly no longer needed.
857 my $mem_class = "DBD::_mem::$h_type";
858 push @{"${h_class}_mem::ISA"}, $mem_class
859 unless UNIVERSAL::isa("${h_class}_mem", $mem_class)
860 or $DBI::PurePerl;
861 }
862}
863
864
865sub _rebless {
866 my $dbh = shift;
867 my ($outer, $inner) = DBI::_handles($dbh);
868 my $class = shift(@_).'::db';
869 bless $inner => $class;
870 bless $outer => $class; # outer last for return
871}
872
873
874sub _set_isa {
875 my ($classes, $topclass) = @_;
876 my $trace = DBI->trace_msg(" _set_isa([@$classes])\n");
877 foreach my $suffix ('::db','::st') {
878 my $previous = $topclass || 'DBI'; # trees are rooted here
879 foreach my $class (@$classes) {
880 my $base_class = $previous.$suffix;
881 my $sub_class = $class.$suffix;
882 my $sub_class_isa = "${sub_class}::ISA";
883 no strict 'refs';
884 if (@$sub_class_isa) {
885 DBI->trace_msg(" $sub_class_isa skipped (already set to @$sub_class_isa)\n")
886 if $trace;
887 }
888 else {
889 @$sub_class_isa = ($base_class) unless @$sub_class_isa;
890 DBI->trace_msg(" $sub_class_isa = $base_class\n")
891 if $trace;
892 }
893 $previous = $class;
894 }
895 }
896}
897
898
899sub _rebless_dbtype_subclass {
900 my ($dbh, $rootclass, $DbTypeSubclass) = @_;
901 # determine the db type names for class hierarchy
902 my @hierarchy = DBI::_dbtype_names($dbh, $DbTypeSubclass);
903 # add the rootclass prefix to each ('DBI::' or 'MyDBI::' etc)
904 $_ = $rootclass.'::'.$_ foreach (@hierarchy);
905 # load the modules from the 'top down'
906 DBI::_load_class($_, 1) foreach (reverse @hierarchy);
907 # setup class hierarchy if needed, does both '::db' and '::st'
908 DBI::_set_isa(\@hierarchy, $rootclass);
909 # finally bless the handle into the subclass
910 DBI::_rebless($dbh, $hierarchy[0]);
911}
912
913
914sub _dbtype_names { # list dbtypes for hierarchy, ie Informix=>ADO=>ODBC
915 my ($dbh, $DbTypeSubclass) = @_;
916
917 if ($DbTypeSubclass && $DbTypeSubclass ne '1' && ref $DbTypeSubclass ne 'CODE') {
918 # treat $DbTypeSubclass as a comma separated list of names
919 my @dbtypes = split /\s*,\s*/, $DbTypeSubclass;
920 $dbh->trace_msg(" DbTypeSubclass($DbTypeSubclass)=@dbtypes (explicit)\n");
921 return @dbtypes;
922 }
923
924 # XXX will call $dbh->get_info(17) (=SQL_DBMS_NAME) in future?
925
926 my $driver = $dbh->{Driver}->{Name};
927 if ( $driver eq 'Proxy' ) {
928 # XXX Looking into the internals of DBD::Proxy is questionable!
929 ($driver) = $dbh->{proxy_client}->{application} =~ /^DBI:(.+?):/i
930 or die "Can't determine driver name from proxy";
931 }
932
933 my @dbtypes = (ucfirst($driver));
934 if ($driver eq 'ODBC' || $driver eq 'ADO') {
935 # XXX will move these out and make extensible later:
936 my $_dbtype_name_regexp = 'Oracle'; # eg 'Oracle|Foo|Bar'
937 my %_dbtype_name_map = (
938 'Microsoft SQL Server' => 'MSSQL',
939 'SQL Server' => 'Sybase',
940 'Adaptive Server Anywhere' => 'ASAny',
941 'ADABAS D' => 'AdabasD',
942 );
943
944 my $name;
945 $name = $dbh->func(17, 'GetInfo') # SQL_DBMS_NAME
946 if $driver eq 'ODBC';
947 $name = $dbh->{ado_conn}->Properties->Item('DBMS Name')->Value
948 if $driver eq 'ADO';
949 die "Can't determine driver name! ($DBI::errstr)\n"
950 unless $name;
951
952 my $dbtype;
953 if ($_dbtype_name_map{$name}) {
954 $dbtype = $_dbtype_name_map{$name};
955 }
956 else {
957 if ($name =~ /($_dbtype_name_regexp)/) {
958 $dbtype = lc($1);
959 }
960 else { # generic mangling for other names:
961 $dbtype = lc($name);
962 }
963 $dbtype =~ s/\b(\w)/\U$1/g;
964 $dbtype =~ s/\W+/_/g;
965 }
966 # add ODBC 'behind' ADO
967 push @dbtypes, 'ODBC' if $driver eq 'ADO';
968 # add discovered dbtype in front of ADO/ODBC
969 unshift @dbtypes, $dbtype;
970 }
971 @dbtypes = &$DbTypeSubclass($dbh, \@dbtypes)
972 if (ref $DbTypeSubclass eq 'CODE');
973 $dbh->trace_msg(" DbTypeSubclass($DbTypeSubclass)=@dbtypes\n");
974 return @dbtypes;
975}
976
977sub _load_class {
978 my ($load_class, $missing_ok) = @_;
979 DBI->trace_msg(" _load_class($load_class, $missing_ok)\n", 2);
980 no strict 'refs';
981 return 1 if @{"$load_class\::ISA"}; # already loaded/exists
982 (my $module = $load_class) =~ s!::!/!g;
983 DBI->trace_msg(" _load_class require $module\n", 2);
984 eval { require "$module.pm"; };
985 return 1 unless $@;
986 return 0 if $missing_ok && $@ =~ /^Can't locate \Q$module.pm\E/;
987 die $@;
988}
989
990
991sub init_rootclass { # deprecated
992 return 1;
993}
994
995
996*internal = \&DBD::Switch::dr::driver;
997
998sub driver_prefix {
999 my ($class, $driver) = @_;
1000 return $dbd_class_registry{$driver}->{prefix} if exists $dbd_class_registry{$driver};
1001 return;
1002}
1003
1004sub available_drivers {
1005 my($quiet) = @_;
1006 my(@drivers, $d, $f);
1007 local(*DBI::DIR, $@);
1008 my(%seen_dir, %seen_dbd);
1009 my $haveFileSpec = eval { require File::Spec };
1010 foreach $d (@INC){
1011 chomp($d); # Perl 5 beta 3 bug in #!./perl -Ilib from Test::Harness
1012 my $dbd_dir =
1013 ($haveFileSpec ? File::Spec->catdir($d, 'DBD') : "$d/DBD");
1014 next unless -d $dbd_dir;
1015 next if $seen_dir{$d};
1016 $seen_dir{$d} = 1;
1017 # XXX we have a problem here with case insensitive file systems
1018 # XXX since we can't tell what case must be used when loading.
1019 opendir(DBI::DIR, $dbd_dir) || Carp::carp "opendir $dbd_dir: $!\n";
1020 foreach $f (readdir(DBI::DIR)){
1021 next unless $f =~ s/\.pm$//;
1022 next if $f eq 'NullP';
1023 if ($seen_dbd{$f}){
1024 Carp::carp "DBD::$f in $d is hidden by DBD::$f in $seen_dbd{$f}\n"
1025 unless $quiet;
1026 } else {
1027 push(@drivers, $f);
1028 }
1029 $seen_dbd{$f} = $d;
1030 }
1031 closedir(DBI::DIR);
1032 }
1033
1034 # "return sort @drivers" will not DWIM in scalar context.
1035 return wantarray ? sort @drivers : @drivers;
1036}
1037
1038sub installed_versions {
1039 my ($class, $quiet) = @_;
1040 my %error;
1041 my %version;
1042 for my $driver ($class->available_drivers($quiet)) {
1043 next if $DBI::PurePerl && grep { -d "$_/auto/DBD/$driver" } @INC;
1044 my $drh = eval {
1045 local $SIG{__WARN__} = sub {};
1046 $class->install_driver($driver);
1047 };
1048 ($error{"DBD::$driver"}=$@),next if $@;
1049 no strict 'refs';
1050 my $vers = ${"DBD::$driver" . '::VERSION'};
1051 $version{"DBD::$driver"} = $vers || '?';
1052 }
1053 if (wantarray) {
1054 return map { m/^DBD::(\w+)/ ? ($1) : () } sort keys %version;
1055 }
1056 $version{"DBI"} = $DBI::VERSION;
1057 $version{"DBI::PurePerl"} = $DBI::PurePerl::VERSION if $DBI::PurePerl;
1058 if (!defined wantarray) { # void context
1059 require Config; # add more detail
1060 $version{OS} = "$^O\t($Config::Config{osvers})";
1061 $version{Perl} = "$]\t($Config::Config{archname})";
1062 $version{$_} = (($error{$_} =~ s/ \(\@INC.*//s),$error{$_})
1063 for keys %error;
1064 printf " %-16s: %s\n",$_,$version{$_}
1065 for reverse sort keys %version;
1066 }
1067 return \%version;
1068}
1069
1070
1071sub data_sources {
1072 my ($class, $driver, @other) = @_;
1073 my $drh = $class->install_driver($driver);
1074 my @ds = $drh->data_sources(@other);
1075 return @ds;
1076}
1077
1078
1079sub neat_list {
1080 my ($listref, $maxlen, $sep) = @_;
1081 $maxlen = 0 unless defined $maxlen; # 0 == use internal default
1082 $sep = ", " unless defined $sep;
1083 join($sep, map { neat($_,$maxlen) } @$listref);
1084}
1085
1086
1087sub dump_results { # also aliased as a method in DBD::_::st
1088 my ($sth, $maxlen, $lsep, $fsep, $fh) = @_;
1089 return 0 unless $sth;
1090 $maxlen ||= 35;
1091 $lsep ||= "\n";
1092 $fh ||= \*STDOUT;
1093 my $rows = 0;
1094 my $ref;
1095 while($ref = $sth->fetch) {
1096 print $fh $lsep if $rows++ and $lsep;
1097 my $str = neat_list($ref,$maxlen,$fsep);
1098 print $fh $str; # done on two lines to avoid 5.003 errors
1099 }
1100 print $fh "\n$rows rows".($DBI::err ? " ($DBI::err: $DBI::errstr)" : "")."\n";
1101 $rows;
1102}
1103
1104
1105sub data_diff {
1106 my ($a, $b, $logical) = @_;
1107
1108 my $diff = data_string_diff($a, $b);
1109 return "" if $logical and !$diff;
1110
1111 my $a_desc = data_string_desc($a);
1112 my $b_desc = data_string_desc($b);
1113 return "" if !$diff and $a_desc eq $b_desc;
1114
1115 $diff ||= "Strings contain the same sequence of characters"
1116 if length($a);
1117 $diff .= "\n" if $diff;
1118 return "a: $a_desc\nb: $b_desc\n$diff";
1119}
1120
1121
1122sub data_string_diff {
1123 # Compares 'logical' characters, not bytes, so a latin1 string and an
1124 # an equivalent Unicode string will compare as equal even though their
1125 # byte encodings are different.
1126 my ($a, $b) = @_;
1127 unless (defined $a and defined $b) { # one undef
1128 return ""
1129 if !defined $a and !defined $b;
1130 return "String a is undef, string b has ".length($b)." characters"
1131 if !defined $a;
1132 return "String b is undef, string a has ".length($a)." characters"
1133 if !defined $b;
1134 }
1135
1136 require utf8;
1137 # hack to cater for perl 5.6
1138 *utf8::is_utf8 = sub { (DBI::neat(shift)=~/^"/) } unless defined &utf8::is_utf8;
1139
1140 my @a_chars = (utf8::is_utf8($a)) ? unpack("U*", $a) : unpack("C*", $a);
1141 my @b_chars = (utf8::is_utf8($b)) ? unpack("U*", $b) : unpack("C*", $b);
1142 my $i = 0;
1143 while (@a_chars && @b_chars) {
1144 ++$i, shift(@a_chars), shift(@b_chars), next
1145 if $a_chars[0] == $b_chars[0];# compare ordinal values
1146 my @desc = map {
1147 $_ > 255 ? # if wide character...
1148 sprintf("\\x{%04X}", $_) : # \x{...}
1149 chr($_) =~ /[[:cntrl:]]/ ? # else if control character ...
1150 sprintf("\\x%02X", $_) : # \x..
1151 chr($_) # else as themselves
1152 } ($a_chars[0], $b_chars[0]);
1153 # highlight probable double-encoding?
1154 foreach my $c ( @desc ) {
1155 next unless $c =~ m/\\x\{08(..)}/;
1156 $c .= "='" .chr(hex($1)) ."'"
1157 }
1158 return sprintf "Strings differ at index $i: a[$i]=$desc[0], b[$i]=$desc[1]";
1159 }
1160 return "String a truncated after $i characters" if @b_chars;
1161 return "String b truncated after $i characters" if @a_chars;
1162 return "";
1163}
1164
1165
1166sub data_string_desc { # describe a data string
1167 my ($a) = @_;
1168 require bytes;
1169 require utf8;
1170
1171 # hacks to cater for perl 5.6
1172 *utf8::is_utf8 = sub { (DBI::neat(shift)=~/^"/) } unless defined &utf8::is_utf8;
1173 *utf8::valid = sub { 1 } unless defined &utf8::valid;
1174
1175 # Give sufficient info to help diagnose at least these kinds of situations:
1176 # - valid UTF8 byte sequence but UTF8 flag not set
1177 # (might be ascii so also need to check for hibit to make it worthwhile)
1178 # - UTF8 flag set but invalid UTF8 byte sequence
1179 # could do better here, but this'll do for now
1180 my $utf8 = sprintf "UTF8 %s%s",
1181 utf8::is_utf8($a) ? "on" : "off",
1182 utf8::valid($a||'') ? "" : " but INVALID encoding";
1183 return "$utf8, undef" unless defined $a;
1184 my $is_ascii = $a =~ m/^[\000-\177]*$/;
1185 return sprintf "%s, %s, %d characters %d bytes",
1186 $utf8, $is_ascii ? "ASCII" : "non-ASCII",
1187 length($a), bytes::length($a);
1188}
1189
1190
1191sub connect_test_perf {
1192 my($class, $dsn,$dbuser,$dbpass, $attr) = @_;
1193 Carp::croak("connect_test_perf needs hash ref as fourth arg") unless ref $attr;
1194 # these are non standard attributes just for this special method
1195 my $loops ||= $attr->{dbi_loops} || 5;
1196 my $par ||= $attr->{dbi_par} || 1; # parallelism
1197 my $verb ||= $attr->{dbi_verb} || 1;
1198 my $meth ||= $attr->{dbi_meth} || 'connect';
1199 print "$dsn: testing $loops sets of $par connections:\n";
1200 require "FileHandle.pm"; # don't let toke.c create empty FileHandle package
1201 local $| = 1;
1202 my $drh = $class->install_driver($dsn) or Carp::croak("Can't install $dsn driver\n");
1203 # test the connection and warm up caches etc
1204 $drh->connect($dsn,$dbuser,$dbpass) or Carp::croak("connect failed: $DBI::errstr");
1205 my $t1 = dbi_time();
1206 my $loop;
1207 for $loop (1..$loops) {
1208 my @cons;
1209 print "Connecting... " if $verb;
1210 for (1..$par) {
1211 print "$_ ";
1212 push @cons, ($drh->connect($dsn,$dbuser,$dbpass)
1213 or Carp::croak("connect failed: $DBI::errstr\n"));
1214 }
1215 print "\nDisconnecting...\n" if $verb;
1216 for (@cons) {
1217 $_->disconnect or warn "disconnect failed: $DBI::errstr"
1218 }
1219 }
1220 my $t2 = dbi_time();
1221 my $td = $t2 - $t1;
1222 printf "$meth %d and disconnect them, %d times: %.4fs / %d = %.4fs\n",
1223 $par, $loops, $td, $loops*$par, $td/($loops*$par);
1224 return $td;
1225}
1226
1227
1228# Help people doing DBI->errstr, might even document it one day
1229# XXX probably best moved to cheaper XS code if this gets documented
1230sub err { $DBI::err }
1231sub errstr { $DBI::errstr }
1232
1233
1234# --- Private Internal Function for Creating New DBI Handles
1235
1236# XXX move to PurePerl?
1237*DBI::dr::TIEHASH = \&DBI::st::TIEHASH;
1238*DBI::db::TIEHASH = \&DBI::st::TIEHASH;
1239
1240
1241# These three special constructors are called by the drivers
1242# The way they are called is likely to change.
1243
1244our $shared_profile;
1245
1246sub _new_drh { # called by DBD::<drivername>::driver()
1247 my ($class, $initial_attr, $imp_data) = @_;
1248 # Provide default storage for State,Err and Errstr.
1249 # Note that these are shared by all child handles by default! XXX
1250 # State must be undef to get automatic faking in DBI::var::FETCH
1251 my ($h_state_store, $h_err_store, $h_errstr_store) = (undef, undef, '');
1252 my $attr = {
1253 # these attributes get copied down to child handles by default
1254 'State' => \$h_state_store, # Holder for DBI::state
1255 'Err' => \$h_err_store, # Holder for DBI::err
1256 'Errstr' => \$h_errstr_store, # Holder for DBI::errstr
1257 'TraceLevel' => 0,
1258 FetchHashKeyName=> 'NAME',
1259 %$initial_attr,
1260 };
1261 my ($h, $i) = _new_handle('DBI::dr', '', $attr, $imp_data, $class);
1262
1263 # XXX DBI_PROFILE unless DBI::PurePerl because for some reason
1264 # it kills the t/zz_*_pp.t tests (they silently exit early)
1265 if (($ENV{DBI_PROFILE} && !$DBI::PurePerl) || $shared_profile) {
1266 # The profile object created here when the first driver is loaded
1267 # is shared by all drivers so we end up with just one set of profile
1268 # data and thus the 'total time in DBI' is really the true total.
1269 if (!$shared_profile) { # first time
1270 $h->{Profile} = $ENV{DBI_PROFILE}; # write string
1271 $shared_profile = $h->{Profile}; # read and record object
1272 }
1273 else {
1274 $h->{Profile} = $shared_profile;
1275 }
1276 }
1277 return $h unless wantarray;
1278 ($h, $i);
1279}
1280
1281
# spent 30µs (14+16) within DBI::_new_dbh which was called: # once (14µs+16µs) by DBD::Pg::dr::connect at line 260 of DBD/Pg.pm
sub _new_dbh { # called by DBD::<drivername>::dr::connect()
12821600ns my ($drh, $attr, $imp_data) = @_;
1283 my $imp_class = $drh->{ImplementorClass}
128411µs or Carp::croak("DBI _new_dbh: $drh has no ImplementorClass");
128511µs substr($imp_class,-4,4) = '::db';
12861700ns my $app_class = ref $drh;
12871800ns substr($app_class,-4,4) = '::db';
128811µs $attr->{Err} ||= \my $err;
12891600ns $attr->{Errstr} ||= \my $errstr;
129011µs $attr->{State} ||= \my $state;
1291122µs116µs _new_handle($app_class, $drh, $attr, $imp_data, $imp_class);
# spent 16µs making 1 call to DBI::_new_handle
1292}
1293
1294
# spent 88µs (33+54) within DBI::_new_sth which was called 3 times, avg 29µs/call: # 3 times (33µs+54µs) by DBD::Pg::db::prepare at line 306 of DBD/Pg.pm, avg 29µs/call
sub _new_sth { # called by DBD::<drivername>::db::prepare)
129532µs my ($dbh, $attr, $imp_data) = @_;
1296 my $imp_class = $dbh->{ImplementorClass}
129733µs or Carp::croak("DBI _new_sth: $dbh has no ImplementorClass");
129834µs substr($imp_class,-4,4) = '::st';
129932µs my $app_class = ref $dbh;
130032µs substr($app_class,-4,4) = '::st';
1301370µs354µs _new_handle($app_class, $dbh, $attr, $imp_data, $imp_class);
# spent 54µs making 3 calls to DBI::_new_handle, avg 18µs/call
1302}
1303
1304
1305# end of DBI package
1306
- -
1309# --------------------------------------------------------------------
1310# === The internal DBI Switch pseudo 'driver' class ===
1311
1312{ package # hide from PAUSE
1313 DBD::Switch::dr;
1314 DBI->setup_driver('DBD::Switch'); # sets up @ISA
1315
1316 $DBD::Switch::dr::imp_data_size = 0;
1317 $DBD::Switch::dr::imp_data_size = 0; # avoid typo warning
1318 my $drh;
1319
1320 sub driver {
1321 return $drh if $drh; # a package global
1322
1323 my $inner;
1324 ($drh, $inner) = DBI::_new_drh('DBD::Switch::dr', {
1325 'Name' => 'Switch',
1326 'Version' => $DBI::VERSION,
1327 'Attribution' => "DBI $DBI::VERSION by Tim Bunce",
1328 });
1329 Carp::croak("DBD::Switch init failed!") unless ($drh && $inner);
1330 return $drh;
1331 }
1332 sub CLONE {
1333 undef $drh;
1334 }
1335
1336 sub FETCH {
1337 my($drh, $key) = @_;
1338 return DBI->trace if $key eq 'DebugDispatch';
1339 return undef if $key eq 'DebugLog'; # not worth fetching, sorry
1340 return $drh->DBD::_::dr::FETCH($key);
1341 undef;
1342 }
1343 sub STORE {
1344 my($drh, $key, $value) = @_;
1345 if ($key eq 'DebugDispatch') {
1346 DBI->trace($value);
1347 } elsif ($key eq 'DebugLog') {
1348 DBI->trace(-1, $value);
1349 } else {
1350 $drh->DBD::_::dr::STORE($key, $value);
1351 }
1352 }
1353}
1354
1355
1356# --------------------------------------------------------------------
1357# === OPTIONAL MINIMAL BASE CLASSES FOR DBI SUBCLASSES ===
1358
1359# We only define default methods for harmless functions.
1360# We don't, for example, define a DBD::_::st::prepare()
1361
1362{ package # hide from PAUSE
1363 DBD::_::common; # ====== Common base class methods ======
1364 use strict;
1365
1366 # methods common to all handle types:
1367
1368 # generic TIEHASH default methods:
1369 sub FIRSTKEY { }
1370 sub NEXTKEY { }
1371 sub EXISTS { defined($_[0]->FETCH($_[1])) } # XXX undef?
1372 sub CLEAR { Carp::carp "Can't CLEAR $_[0] (DBI)" }
1373
1374 sub FETCH_many { # XXX should move to C one day
1375 my $h = shift;
1376 # scalar is needed to workaround drivers that return an empty list
1377 # for some attributes
1378 return map { scalar $h->FETCH($_) } @_;
1379 }
1380
1381 *dump_handle = \&DBI::dump_handle;
1382
1383 sub install_method {
1384 # special class method called directly by apps and/or drivers
1385 # to install new methods into the DBI dispatcher
1386 # DBD::Foo::db->install_method("foo_mumble", { usage => [...], options => '...' });
1387 my ($class, $method, $attr) = @_;
1388 Carp::croak("Class '$class' must begin with DBD:: and end with ::db or ::st")
1389 unless $class =~ /^DBD::(\w+)::(dr|db|st)$/;
1390 my ($driver, $subtype) = ($1, $2);
1391 Carp::croak("invalid method name '$method'")
1392 unless $method =~ m/^([a-z][a-z0-9]*_)\w+$/;
1393 my $prefix = $1;
1394 my $reg_info = $dbd_prefix_registry->{$prefix};
1395 Carp::carp("method name prefix '$prefix' is not associated with a registered driver") unless $reg_info;
1396
1397 my $full_method = "DBI::${subtype}::$method";
1398 $DBI::installed_methods{$full_method} = $attr;
1399
1400 my (undef, $filename, $line) = caller;
1401 # XXX reformat $attr as needed for _install_method
1402 my %attr = %{$attr||{}}; # copy so we can edit
1403 DBI->_install_method("DBI::${subtype}::$method", "$filename at line $line", \%attr);
1404 }
1405
1406 sub parse_trace_flags {
1407 my ($h, $spec) = @_;
1408 my $level = 0;
1409 my $flags = 0;
1410 my @unknown;
1411 for my $word (split /\s*[|&,]\s*/, $spec) {
1412 if (DBI::looks_like_number($word) && $word <= 0xF && $word >= 0) {
1413 $level = $word;
1414 } elsif ($word eq 'ALL') {
1415 $flags = 0x7FFFFFFF; # XXX last bit causes negative headaches
1416 last;
1417 } elsif (my $flag = $h->parse_trace_flag($word)) {
1418 $flags |= $flag;
1419 }
1420 else {
1421 push @unknown, $word;
1422 }
1423 }
1424 if (@unknown && (ref $h ? $h->FETCH('Warn') : 1)) {
1425 Carp::carp("$h->parse_trace_flags($spec) ignored unknown trace flags: ".
1426 join(" ", map { DBI::neat($_) } @unknown));
1427 }
1428 $flags |= $level;
1429 return $flags;
1430 }
1431
1432 sub parse_trace_flag {
1433 my ($h, $name) = @_;
1434 # 0xddDDDDrL (driver, DBI, reserved, Level)
1435 return 0x00000100 if $name eq 'SQL';
1436 return 0x00000200 if $name eq 'CON';
1437 return 0x00000400 if $name eq 'ENC';
1438 return 0x00000800 if $name eq 'DBD';
1439 return 0x00001000 if $name eq 'TXN';
1440 return;
1441 }
1442
1443 sub private_attribute_info {
1444 return undef;
1445 }
1446
1447 sub visit_child_handles {
1448 my ($h, $code, $info) = @_;
1449 $info = {} if not defined $info;
1450 for my $ch (@{ $h->{ChildHandles} || []}) {
1451 next unless $ch;
1452 my $child_info = $code->($ch, $info)
1453 or next;
1454 $ch->visit_child_handles($code, $child_info);
1455 }
1456 return $info;
1457 }
1458}
1459
1460
1461{ package # hide from PAUSE
1462 DBD::_::dr; # ====== DRIVER ======
1463 @DBD::_::dr::ISA = qw(DBD::_::common);
1464 use strict;
1465
1466 sub default_user {
1467 my ($drh, $user, $pass, $attr) = @_;
1468 $user = $ENV{DBI_USER} unless defined $user;
1469 $pass = $ENV{DBI_PASS} unless defined $pass;
1470 return ($user, $pass);
1471 }
1472
1473 sub connect { # normally overridden, but a handy default
1474 my ($drh, $dsn, $user, $auth) = @_;
1475 my ($this) = DBI::_new_dbh($drh, {
1476 'Name' => $dsn,
1477 });
1478 # XXX debatable as there's no "server side" here
1479 # (and now many uses would trigger warnings on DESTROY)
1480 # $this->STORE(Active => 1);
1481 # so drivers should set it in their own connect
1482 $this;
1483 }
1484
1485
1486 sub connect_cached {
1487 my $drh = shift;
1488 my ($dsn, $user, $auth, $attr) = @_;
1489
1490 my $cache = $drh->{CachedKids} ||= {};
1491 my $key = do { local $^W;
1492 join "!\001", $dsn, $user, $auth, DBI::_concat_hash_sorted($attr, "=\001", ",\001", 0, 0)
1493 };
1494 my $dbh = $cache->{$key};
1495 $drh->trace_msg(sprintf(" connect_cached: key '$key', cached dbh $dbh\n", DBI::neat($key), DBI::neat($dbh)))
1496 if (($DBI::dbi_debug & 0xF) >= 4);
1497
1498 my $cb = $attr->{Callbacks}; # take care not to autovivify
1499 if ($dbh && $dbh->FETCH('Active') && eval { $dbh->ping }) {
1500 # If the caller has provided a callback then call it
1501 if ($cb and $cb = $cb->{"connect_cached.reused"}) {
1502 local $_ = "connect_cached.reused";
1503 $cb->($dbh, $dsn, $user, $auth, $attr);
1504 }
1505 return $dbh;
1506 }
1507
1508 # If the caller has provided a callback then call it
1509 if ($cb and (my $new_cb = $cb->{"connect_cached.new"})) {
1510 local $_ = "connect_cached.new";
1511 $new_cb->($dbh, $dsn, $user, $auth, $attr); # $dbh is dead or undef
1512 }
1513
1514 $dbh = $drh->connect(@_);
1515 $cache->{$key} = $dbh; # replace prev entry, even if connect failed
1516 if ($cb and (my $conn_cb = $cb->{"connect_cached.connected"})) {
1517 local $_ = "connect_cached.connected";
1518 $conn_cb->($dbh, $dsn, $user, $auth, $attr);
1519 }
1520 return $dbh;
1521 }
1522
1523}
1524
1525
1526{ package # hide from PAUSE
1527 DBD::_::db; # ====== DATABASE ======
1528 @DBD::_::db::ISA = qw(DBD::_::common);
1529 use strict;
1530
1531 sub clone {
1532 my ($old_dbh, $attr) = @_;
1533
1534 my $closure = $old_dbh->{dbi_connect_closure}
1535 or return $old_dbh->set_err($DBI::stderr, "Can't clone handle");
1536
1537 unless ($attr) { # XXX deprecated, caller should always pass a hash ref
1538 # copy attributes visible in the attribute cache
1539 keys %$old_dbh; # reset iterator
1540 while ( my ($k, $v) = each %$old_dbh ) {
1541 # ignore non-code refs, i.e., caches, handles, Err etc
1542 next if ref $v && ref $v ne 'CODE'; # HandleError etc
1543 $attr->{$k} = $v;
1544 }
1545 # explicitly set attributes which are unlikely to be in the
1546 # attribute cache, i.e., boolean's and some others
1547 $attr->{$_} = $old_dbh->FETCH($_) for (qw(
1548 AutoCommit ChopBlanks InactiveDestroy AutoInactiveDestroy
1549 LongTruncOk PrintError PrintWarn Profile RaiseError RaiseWarn
1550 ShowErrorStatement TaintIn TaintOut
1551 ));
1552 }
1553
1554 # use Data::Dumper; warn Dumper([$old_dbh, $attr]);
1555 my $new_dbh = &$closure($old_dbh, $attr);
1556 unless ($new_dbh) {
1557 # need to copy err/errstr from driver back into $old_dbh
1558 my $drh = $old_dbh->{Driver};
1559 return $old_dbh->set_err($drh->err, $drh->errstr, $drh->state);
1560 }
1561 $new_dbh->{dbi_connect_closure} = $closure;
1562 return $new_dbh;
1563 }
1564
1565 sub quote_identifier {
1566 my ($dbh, @id) = @_;
1567 my $attr = (@id > 3 && ref($id[-1])) ? pop @id : undef;
1568
1569 my $info = $dbh->{dbi_quote_identifier_cache} ||= [
1570 $dbh->get_info(29) || '"', # SQL_IDENTIFIER_QUOTE_CHAR
1571 $dbh->get_info(41) || '.', # SQL_CATALOG_NAME_SEPARATOR
1572 $dbh->get_info(114) || 1, # SQL_CATALOG_LOCATION
1573 ];
1574
1575 my $quote = $info->[0];
1576 foreach (@id) { # quote the elements
1577 next unless defined;
1578 s/$quote/$quote$quote/g; # escape embedded quotes
1579 $_ = qq{$quote$_$quote};
1580 }
1581
1582 # strip out catalog if present for special handling
1583 my $catalog = (@id >= 3) ? shift @id : undef;
1584
1585 # join the dots, ignoring any null/undef elements (ie schema)
1586 my $quoted_id = join '.', grep { defined } @id;
1587
1588 if ($catalog) { # add catalog correctly
1589 if ($quoted_id) {
1590 $quoted_id = ($info->[2] == 2) # SQL_CL_END
1591 ? $quoted_id . $info->[1] . $catalog
1592 : $catalog . $info->[1] . $quoted_id;
1593 } else {
1594 $quoted_id = $catalog;
1595 }
1596 }
1597 return $quoted_id;
1598 }
1599
1600 sub quote {
1601 my ($dbh, $str, $data_type) = @_;
1602
1603 return "NULL" unless defined $str;
1604 unless ($data_type) {
1605 $str =~ s/'/''/g; # ISO SQL2
1606 return "'$str'";
1607 }
1608
1609 my $dbi_literal_quote_cache = $dbh->{'dbi_literal_quote_cache'} ||= [ {} , {} ];
1610 my ($prefixes, $suffixes) = @$dbi_literal_quote_cache;
1611
1612 my $lp = $prefixes->{$data_type};
1613 my $ls = $suffixes->{$data_type};
1614
1615 if ( ! defined $lp || ! defined $ls ) {
1616 my $ti = $dbh->type_info($data_type);
1617 $lp = $prefixes->{$data_type} = $ti ? $ti->{LITERAL_PREFIX} || "" : "'";
1618 $ls = $suffixes->{$data_type} = $ti ? $ti->{LITERAL_SUFFIX} || "" : "'";
1619 }
1620 return $str unless $lp || $ls; # no quoting required
1621
1622 # XXX don't know what the standard says about escaping
1623 # in the 'general case' (where $lp != "'").
1624 # So we just do this and hope:
1625 $str =~ s/$lp/$lp$lp/g
1626 if $lp && $lp eq $ls && ($lp eq "'" || $lp eq '"');
1627 return "$lp$str$ls";
1628 }
1629
1630 sub rows { -1 } # here so $DBI::rows 'works' after using $dbh
1631
1632 sub do {
1633 my($dbh, $statement, $attr, @params) = @_;
1634 my $sth = $dbh->prepare($statement, $attr) or return undef;
1635 $sth->execute(@params) or return undef;
1636 my $rows = $sth->rows;
1637 ($rows == 0) ? "0E0" : $rows;
1638 }
1639
1640 sub _do_selectrow {
1641 my ($method, $dbh, $stmt, $attr, @bind) = @_;
1642 my $sth = ((ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr))
1643 or return undef;
1644 $sth->execute(@bind)
1645 or return undef;
1646 my $row = $sth->$method()
1647 and $sth->finish;
1648 return $row;
1649 }
1650
1651 sub selectrow_hashref { return _do_selectrow('fetchrow_hashref', @_); }
1652
1653 # XXX selectrow_array/ref also have C implementations in Driver.xst
1654 sub selectrow_arrayref { return _do_selectrow('fetchrow_arrayref', @_); }
1655 sub selectrow_array {
1656 my $row = _do_selectrow('fetchrow_arrayref', @_) or return;
1657 return $row->[0] unless wantarray;
1658 return @$row;
1659 }
1660
1661 sub selectall_array {
1662 return @{ shift->selectall_arrayref(@_) || [] };
1663 }
1664
1665 # XXX selectall_arrayref also has C implementation in Driver.xst
1666 # which fallsback to this if a slice is given
1667 sub selectall_arrayref {
1668 my ($dbh, $stmt, $attr, @bind) = @_;
1669 my $sth = (ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr)
1670 or return;
1671 $sth->execute(@bind) || return;
1672 my $slice = $attr->{Slice}; # typically undef, else hash or array ref
1673 if (!$slice and $slice=$attr->{Columns}) {
1674 if (ref $slice eq 'ARRAY') { # map col idx to perl array idx
1675 $slice = [ @{$attr->{Columns}} ]; # take a copy
1676 for (@$slice) { $_-- }
1677 }
1678 }
1679 my $rows = $sth->fetchall_arrayref($slice, my $MaxRows = $attr->{MaxRows});
1680 $sth->finish if defined $MaxRows;
1681 return $rows;
1682 }
1683
1684 sub selectall_hashref {
1685 my ($dbh, $stmt, $key_field, $attr, @bind) = @_;
1686 my $sth = (ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr);
1687 return unless $sth;
1688 $sth->execute(@bind) || return;
1689 return $sth->fetchall_hashref($key_field);
1690 }
1691
1692 sub selectcol_arrayref {
1693 my ($dbh, $stmt, $attr, @bind) = @_;
1694 my $sth = (ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr);
1695 return unless $sth;
1696 $sth->execute(@bind) || return;
1697 my @columns = ($attr->{Columns}) ? @{$attr->{Columns}} : (1);
1698 my @values = (undef) x @columns;
1699 my $idx = 0;
1700 for (@columns) {
1701 $sth->bind_col($_, \$values[$idx++]) || return;
1702 }
1703 my @col;
1704 if (my $max = $attr->{MaxRows}) {
1705 push @col, @values while 0 < $max-- && $sth->fetch;
1706 }
1707 else {
1708 push @col, @values while $sth->fetch;
1709 }
1710 return \@col;
1711 }
1712
1713 sub prepare_cached {
1714 my ($dbh, $statement, $attr, $if_active) = @_;
1715
1716 # Needs support at dbh level to clear cache before complaining about
1717 # active children. The XS template code does this. Drivers not using
1718 # the template must handle clearing the cache themselves.
1719 my $cache = $dbh->{CachedKids} ||= {};
1720 my $key = do { local $^W;
1721 join "!\001", $statement, DBI::_concat_hash_sorted($attr, "=\001", ",\001", 0, 0)
1722 };
1723 my $sth = $cache->{$key};
1724
1725 if ($sth) {
1726 return $sth unless $sth->FETCH('Active');
1727 Carp::carp("prepare_cached($statement) statement handle $sth still Active")
1728 unless ($if_active ||= 0);
1729 $sth->finish if $if_active <= 1;
1730 return $sth if $if_active <= 2;
1731 }
1732
1733 $sth = $dbh->prepare($statement, $attr);
1734 $cache->{$key} = $sth if $sth;
1735
1736 return $sth;
1737 }
1738
1739 sub ping {
1740 my $dbh = shift;
1741 # "0 but true" is a special kind of true 0 that is used here so
1742 # applications can check if the ping was a real ping or not
1743 ($dbh->FETCH('Active')) ? "0 but true" : 0;
1744 }
1745
1746 sub begin_work {
1747 my $dbh = shift;
1748 return $dbh->set_err($DBI::stderr, "Already in a transaction")
1749 unless $dbh->FETCH('AutoCommit');
1750 $dbh->STORE('AutoCommit', 0); # will croak if driver doesn't support it
1751 $dbh->STORE('BegunWork', 1); # trigger post commit/rollback action
1752 return 1;
1753 }
1754
1755 sub primary_key {
1756 my ($dbh, @args) = @_;
1757 my $sth = $dbh->primary_key_info(@args) or return;
1758 my ($row, @col);
1759 push @col, $row->[3] while ($row = $sth->fetch);
1760 Carp::croak("primary_key method not called in list context")
1761 unless wantarray; # leave us some elbow room
1762 return @col;
1763 }
1764
1765 sub tables {
1766 my ($dbh, @args) = @_;
1767 my $sth = $dbh->table_info(@args[0,1,2,3,4]) or return;
1768 my $tables = $sth->fetchall_arrayref or return;
1769 my @tables;
1770 if (defined($args[3]) && $args[3] eq '%' # special case for tables('','','','%')
1771 && grep {defined($_) && $_ eq ''} @args[0,1,2]
1772 ) {
1773 @tables = map { $_->[3] } @$tables;
1774 } elsif ($dbh->get_info(29)) { # SQL_IDENTIFIER_QUOTE_CHAR
1775 @tables = map { $dbh->quote_identifier( @{$_}[0,1,2] ) } @$tables;
1776 }
1777 else { # temporary old style hack (yeach)
1778 @tables = map {
1779 my $name = $_->[2];
1780 if ($_->[1]) {
1781 my $schema = $_->[1];
1782 # a sad hack (mostly for Informix I recall)
1783 my $quote = ($schema eq uc($schema)) ? '' : '"';
1784 $name = "$quote$schema$quote.$name"
1785 }
1786 $name;
1787 } @$tables;
1788 }
1789 return @tables;
1790 }
1791
1792 sub type_info { # this should be sufficient for all drivers
1793 my ($dbh, $data_type) = @_;
1794 my $idx_hash;
1795 my $tia = $dbh->{dbi_type_info_row_cache};
1796 if ($tia) {
1797 $idx_hash = $dbh->{dbi_type_info_idx_cache};
1798 }
1799 else {
1800 my $temp = $dbh->type_info_all;
1801 return unless $temp && @$temp;
1802 # we cache here because type_info_all may be expensive to call
1803 # (and we take a copy so the following shift can't corrupt
1804 # the data that may be returned by future calls to type_info_all)
1805 $tia = $dbh->{dbi_type_info_row_cache} = [ @$temp ];
1806 $idx_hash = $dbh->{dbi_type_info_idx_cache} = shift @$tia;
1807 }
1808
1809 my $dt_idx = $idx_hash->{DATA_TYPE} || $idx_hash->{data_type};
1810 Carp::croak("type_info_all returned non-standard DATA_TYPE index value ($dt_idx != 1)")
1811 if $dt_idx && $dt_idx != 1;
1812
1813 # --- simple DATA_TYPE match filter
1814 my @ti;
1815 my @data_type_list = (ref $data_type) ? @$data_type : ($data_type);
1816 foreach $data_type (@data_type_list) {
1817 if (defined($data_type) && $data_type != DBI::SQL_ALL_TYPES()) {
1818 push @ti, grep { $_->[$dt_idx] == $data_type } @$tia;
1819 }
1820 else { # SQL_ALL_TYPES
1821 push @ti, @$tia;
1822 }
1823 last if @ti; # found at least one match
1824 }
1825
1826 # --- format results into list of hash refs
1827 my $idx_fields = keys %$idx_hash;
1828 my @idx_names = map { uc($_) } keys %$idx_hash;
1829 my @idx_values = values %$idx_hash;
1830 Carp::croak "type_info_all result has $idx_fields keys but ".(@{$ti[0]})." fields"
1831 if @ti && @{$ti[0]} != $idx_fields;
1832 my @out = map {
1833 my %h; @h{@idx_names} = @{$_}[ @idx_values ]; \%h;
1834 } @ti;
1835 return $out[0] unless wantarray;
1836 return @out;
1837 }
1838
1839 sub data_sources {
1840 my ($dbh, @other) = @_;
1841 my $drh = $dbh->{Driver}; # XXX proxy issues?
1842 return $drh->data_sources(@other);
1843 }
1844
1845}
1846
1847
1848{ package # hide from PAUSE
1849 DBD::_::st; # ====== STATEMENT ======
1850 @DBD::_::st::ISA = qw(DBD::_::common);
1851 use strict;
1852
1853 sub bind_param { Carp::croak("Can't bind_param, not implement by driver") }
1854
1855#
1856# ********************************************************
1857#
1858# BEGIN ARRAY BINDING
1859#
1860# Array binding support for drivers which don't support
1861# array binding, but have sufficient interfaces to fake it.
1862# NOTE: mixing scalars and arrayrefs requires using bind_param_array
1863# for *all* params...unless we modify bind_param for the default
1864# case...
1865#
1866# 2002-Apr-10 D. Arnold
1867
1868 sub bind_param_array {
1869 my $sth = shift;
1870 my ($p_id, $value_array, $attr) = @_;
1871
1872 return $sth->set_err($DBI::stderr, "Value for parameter $p_id must be a scalar or an arrayref, not a ".ref($value_array))
1873 if defined $value_array and ref $value_array and ref $value_array ne 'ARRAY';
1874
1875 return $sth->set_err($DBI::stderr, "Can't use named placeholder '$p_id' for non-driver supported bind_param_array")
1876 unless DBI::looks_like_number($p_id); # because we rely on execute(@ary) here
1877
1878 return $sth->set_err($DBI::stderr, "Placeholder '$p_id' is out of range")
1879 if $p_id <= 0; # can't easily/reliably test for too big
1880
1881 # get/create arrayref to hold params
1882 my $hash_of_arrays = $sth->{ParamArrays} ||= { };
1883
1884 # If the bind has attribs then we rely on the driver conforming to
1885 # the DBI spec in that a single bind_param() call with those attribs
1886 # makes them 'sticky' and apply to all later execute(@values) calls.
1887 # Since we only call bind_param() if we're given attribs then
1888 # applications using drivers that don't support bind_param can still
1889 # use bind_param_array() so long as they don't pass any attribs.
1890
1891 $$hash_of_arrays{$p_id} = $value_array;
1892 return $sth->bind_param($p_id, undef, $attr)
1893 if $attr;
1894 1;
1895 }
1896
1897 sub bind_param_inout_array {
1898 my $sth = shift;
1899 # XXX not supported so we just call bind_param_array instead
1900 # and then return an error
1901 my ($p_num, $value_array, $attr) = @_;
1902 $sth->bind_param_array($p_num, $value_array, $attr);
1903 return $sth->set_err($DBI::stderr, "bind_param_inout_array not supported");
1904 }
1905
1906 sub bind_columns {
1907 my $sth = shift;
1908 my $fields = $sth->FETCH('NUM_OF_FIELDS') || 0;
1909 if ($fields <= 0 && !$sth->{Active}) {
1910 return $sth->set_err($DBI::stderr, "Statement has no result columns to bind"
1911 ." (perhaps you need to successfully call execute first, or again)");
1912 }
1913 # Backwards compatibility for old-style call with attribute hash
1914 # ref as first arg. Skip arg if undef or a hash ref.
1915 my $attr;
1916 $attr = shift if !defined $_[0] or ref($_[0]) eq 'HASH';
1917
1918 my $idx = 0;
1919 $sth->bind_col(++$idx, shift, $attr) or return
1920 while (@_ and $idx < $fields);
1921
1922 return $sth->set_err($DBI::stderr, "bind_columns called with ".($idx+@_)." values but $fields are needed")
1923 if @_ or $idx != $fields;
1924
1925 return 1;
1926 }
1927
1928 sub execute_array {
1929 my $sth = shift;
1930 my ($attr, @array_of_arrays) = @_;
1931 my $NUM_OF_PARAMS = $sth->FETCH('NUM_OF_PARAMS'); # may be undef at this point
1932
1933 # get tuple status array or hash attribute
1934 my $tuple_sts = $attr->{ArrayTupleStatus};
1935 return $sth->set_err($DBI::stderr, "ArrayTupleStatus attribute must be an arrayref")
1936 if $tuple_sts and ref $tuple_sts ne 'ARRAY';
1937
1938 # bind all supplied arrays
1939 if (@array_of_arrays) {
1940 $sth->{ParamArrays} = { }; # clear out old params
1941 return $sth->set_err($DBI::stderr,
1942 @array_of_arrays." bind values supplied but $NUM_OF_PARAMS expected")
1943 if defined ($NUM_OF_PARAMS) && @array_of_arrays != $NUM_OF_PARAMS;
1944 $sth->bind_param_array($_, $array_of_arrays[$_-1]) or return
1945 foreach (1..@array_of_arrays);
1946 }
1947
1948 my $fetch_tuple_sub;
1949
1950 if ($fetch_tuple_sub = $attr->{ArrayTupleFetch}) { # fetch on demand
1951
1952 return $sth->set_err($DBI::stderr,
1953 "Can't use both ArrayTupleFetch and explicit bind values")
1954 if @array_of_arrays; # previous bind_param_array calls will simply be ignored
1955
1956 if (UNIVERSAL::isa($fetch_tuple_sub,'DBI::st')) {
1957 my $fetch_sth = $fetch_tuple_sub;
1958 return $sth->set_err($DBI::stderr,
1959 "ArrayTupleFetch sth is not Active, need to execute() it first")
1960 unless $fetch_sth->{Active};
1961 # check column count match to give more friendly message
1962 my $NUM_OF_FIELDS = $fetch_sth->{NUM_OF_FIELDS};
1963 return $sth->set_err($DBI::stderr,
1964 "$NUM_OF_FIELDS columns from ArrayTupleFetch sth but $NUM_OF_PARAMS expected")
1965 if defined($NUM_OF_FIELDS) && defined($NUM_OF_PARAMS)
1966 && $NUM_OF_FIELDS != $NUM_OF_PARAMS;
1967 $fetch_tuple_sub = sub { $fetch_sth->fetchrow_arrayref };
1968 }
1969 elsif (!UNIVERSAL::isa($fetch_tuple_sub,'CODE')) {
1970 return $sth->set_err($DBI::stderr, "ArrayTupleFetch '$fetch_tuple_sub' is not a code ref or statement handle");
1971 }
1972
1973 }
1974 else {
1975 my $NUM_OF_PARAMS_given = keys %{ $sth->{ParamArrays} || {} };
1976 return $sth->set_err($DBI::stderr,
1977 "$NUM_OF_PARAMS_given bind values supplied but $NUM_OF_PARAMS expected")
1978 if defined($NUM_OF_PARAMS) && $NUM_OF_PARAMS != $NUM_OF_PARAMS_given;
1979
1980 # get the length of a bound array
1981 my $maxlen;
1982 my %hash_of_arrays = %{$sth->{ParamArrays}};
1983 foreach (keys(%hash_of_arrays)) {
1984 my $ary = $hash_of_arrays{$_};
1985 next unless ref $ary eq 'ARRAY';
1986 $maxlen = @$ary if !$maxlen || @$ary > $maxlen;
1987 }
1988 # if there are no arrays then execute scalars once
1989 $maxlen = 1 unless defined $maxlen;
1990 my @bind_ids = 1..keys(%hash_of_arrays);
1991
1992 my $tuple_idx = 0;
1993 $fetch_tuple_sub = sub {
1994 return if $tuple_idx >= $maxlen;
1995 my @tuple = map {
1996 my $a = $hash_of_arrays{$_};
1997 ref($a) ? $a->[$tuple_idx] : $a
1998 } @bind_ids;
1999 ++$tuple_idx;
2000 return \@tuple;
2001 };
2002 }
2003 # pass thru the callers scalar or list context
2004 return $sth->execute_for_fetch($fetch_tuple_sub, $tuple_sts);
2005 }
2006
2007 sub execute_for_fetch {
2008 my ($sth, $fetch_tuple_sub, $tuple_status) = @_;
2009 # start with empty status array
2010 ($tuple_status) ? @$tuple_status = () : $tuple_status = [];
2011
2012 my $rc_total = 0;
2013 my $err_count;
2014 while ( my $tuple = &$fetch_tuple_sub() ) {
2015 if ( my $rc = $sth->execute(@$tuple) ) {
2016 push @$tuple_status, $rc;
2017 $rc_total = ($rc >= 0 && $rc_total >= 0) ? $rc_total + $rc : -1;
2018 }
2019 else {
2020 $err_count++;
2021 push @$tuple_status, [ $sth->err, $sth->errstr, $sth->state ];
2022 # XXX drivers implementing execute_for_fetch could opt to "last;" here
2023 # if they know the error code means no further executes will work.
2024 }
2025 }
2026 my $tuples = @$tuple_status;
2027 return $sth->set_err($DBI::stderr, "executing $tuples generated $err_count errors")
2028 if $err_count;
2029 $tuples ||= "0E0";
2030 return $tuples unless wantarray;
2031 return ($tuples, $rc_total);
2032 }
2033
2034 sub last_insert_id {
2035 return shift->{Database}->last_insert_id(@_);
2036 }
2037
2038 sub fetchall_arrayref { # ALSO IN Driver.xst
2039 my ($sth, $slice, $max_rows) = @_;
2040
2041 # when batch fetching with $max_rows were very likely to try to
2042 # fetch the 'next batch' after the previous batch returned
2043 # <=$max_rows. So don't treat that as an error.
2044 return undef if $max_rows and not $sth->FETCH('Active');
2045
2046 my $mode = ref($slice) || 'ARRAY';
2047 my @rows;
2048
2049 if ($mode eq 'ARRAY') {
2050 my $row;
2051 # we copy the array here because fetch (currently) always
2052 # returns the same array ref. XXX
2053 if ($slice && @$slice) {
2054 $max_rows = -1 unless defined $max_rows;
2055 push @rows, [ @{$row}[ @$slice] ]
2056 while($max_rows-- and $row = $sth->fetch);
2057 }
2058 elsif (defined $max_rows) {
2059 push @rows, [ @$row ]
2060 while($max_rows-- and $row = $sth->fetch);
2061 }
2062 else {
2063 push @rows, [ @$row ] while($row = $sth->fetch);
2064 }
2065 return \@rows
2066 }
2067
2068 my %row;
2069 if ($mode eq 'REF' && ref($$slice) eq 'HASH') { # \{ $idx => $name }
2070 keys %$$slice; # reset the iterator
2071 while ( my ($idx, $name) = each %$$slice ) {
2072 $sth->bind_col($idx+1, \$row{$name});
2073 }
2074 }
2075 elsif ($mode eq 'HASH') {
2076 if (keys %$slice) { # resets the iterator
2077 my $name2idx = $sth->FETCH('NAME_lc_hash');
2078 while ( my ($name, $unused) = each %$slice ) {
2079 my $idx = $name2idx->{lc $name};
2080 return $sth->set_err($DBI::stderr, "Invalid column name '$name' for slice")
2081 if not defined $idx;
2082 $sth->bind_col($idx+1, \$row{$name});
2083 }
2084 }
2085 else {
2086 my @column_names = @{ $sth->FETCH($sth->FETCH('FetchHashKeyName')) };
2087 return [] if !@column_names;
2088
2089 $sth->bind_columns( \( @row{@column_names} ) );
2090 }
2091 }
2092 else {
2093 return $sth->set_err($DBI::stderr, "fetchall_arrayref($mode) invalid");
2094 }
2095
2096 if (not defined $max_rows) {
2097 push @rows, { %row } while ($sth->fetch); # full speed ahead!
2098 }
2099 else {
2100 push @rows, { %row } while ($max_rows-- and $sth->fetch);
2101 }
2102
2103 return \@rows;
2104 }
2105
2106 sub fetchall_hashref {
2107 my ($sth, $key_field) = @_;
2108
2109 my $hash_key_name = $sth->{FetchHashKeyName} || 'NAME';
2110 my $names_hash = $sth->FETCH("${hash_key_name}_hash");
2111 my @key_fields = (ref $key_field) ? @$key_field : ($key_field);
2112 my @key_indexes;
2113 my $num_of_fields = $sth->FETCH('NUM_OF_FIELDS');
2114 foreach (@key_fields) {
2115 my $index = $names_hash->{$_}; # perl index not column
2116 $index = $_ - 1 if !defined $index && DBI::looks_like_number($_) && $_>=1 && $_ <= $num_of_fields;
2117 return $sth->set_err($DBI::stderr, "Field '$_' does not exist (not one of @{[keys %$names_hash]})")
2118 unless defined $index;
2119 push @key_indexes, $index;
2120 }
2121 my $rows = {};
2122 my $NAME = $sth->FETCH($hash_key_name);
2123 my @row = (undef) x $num_of_fields;
2124 $sth->bind_columns(\(@row));
2125 while ($sth->fetch) {
2126 my $ref = $rows;
2127 $ref = $ref->{$row[$_]} ||= {} for @key_indexes;
2128 @{$ref}{@$NAME} = @row;
2129 }
2130 return $rows;
2131 }
2132
2133 *dump_results = \&DBI::dump_results;
2134
2135 sub blob_copy_to_file { # returns length or undef on error
2136 my($self, $field, $filename_or_handleref, $blocksize) = @_;
2137 my $fh = $filename_or_handleref;
2138 my($len, $buf) = (0, "");
2139 $blocksize ||= 512; # not too ambitious
2140 local(*FH);
2141 unless(ref $fh) {
2142 open(FH, ">$fh") || return undef;
2143 $fh = \*FH;
2144 }
2145 while(defined($self->blob_read($field, $len, $blocksize, \$buf))) {
2146 print $fh $buf;
2147 $len += length $buf;
2148 }
2149 close(FH);
2150 $len;
2151 }
2152
2153 sub more_results {
2154 shift->{syb_more_results}; # handy grandfathering
2155 }
2156
2157}
2158
2159unless ($DBI::PurePerl) { # See install_driver
2160 { @DBD::_mem::dr::ISA = qw(DBD::_mem::common); }
2161 { @DBD::_mem::db::ISA = qw(DBD::_mem::common); }
2162 { @DBD::_mem::st::ISA = qw(DBD::_mem::common); }
2163 # DBD::_mem::common::DESTROY is implemented in DBI.xs
2164}
2165
21661;
2167__END__
 
# spent 2µs within DBD::_::common::trace_msg which was called: # once (2µs+0s) by DBI::END at line 535
sub DBD::_::common::trace_msg; # xsub
# spent 8µs within DBI::CORE:subst which was called: # once (8µs+0s) by DBI::connect at line 617
sub DBI::CORE:subst; # opcode
# spent 71µs within DBI::_new_handle which was called 4 times, avg 18µs/call: # 3 times (54µs+0s) by DBI::_new_sth at line 1301, avg 18µs/call # once (16µs+0s) by DBI::_new_dbh at line 1291
sub DBI::_new_handle; # xsub