← Index
NYTProf Performance Profile   « line view »
For script/ponapi
  Run on Wed Feb 10 15:51:26 2016
Reported on Thu Feb 11 09:43:11 2016

Filename/usr/local/lib/perl/5.18.2/DBI.pm
StatementsExecuted 5950783 statements in 23.1s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
368129316.11s6.11sDBI::::_new_handle DBI::_new_handle (xsub)
187055115.32s12.4sDBD::_::st::::fetchall_arrayref DBD::_::st::fetchall_arrayref
368127113.60s9.71sDBI::::_new_sth DBI::_new_sth
187055113.21s4.09sDBD::_::st::::bind_columns DBD::_::st::bind_columns
11221347µs347µsDBI::::_install_method DBI::_install_method (xsub)
23231240µs396µsDBD::_::common::::install_method DBD::_::common::install_method
111223µs223µsDBI::::bootstrap DBI::bootstrap (xsub)
111197µs656µsDBI::::BEGIN@179 DBI::BEGIN@179
332120µs153µsDBI::::setup_driver DBI::setup_driver
11180µs710µsDBI::::install_driver DBI::install_driver
11161µs1.15msDBI::::connect DBI::connect
11154µs372µsDBI::::__ANON__[:748] DBI::__ANON__[:748]
462149µs49µsDBD::_::common::::CORE:match DBD::_::common::CORE:match (opcode)
11123µs23µsDBI::::BEGIN@13 DBI::BEGIN@13
1271116µs16µsDBI::::CORE:match DBI::CORE:match (opcode)
11115µs42µsDBI::::_new_drh DBI::_new_drh
11115µs24µsDBI::::BEGIN@550 DBI::BEGIN@550
1119µs19µsDBI::::_new_dbh DBI::_new_dbh
1118µs17µsDBI::::BEGIN@982 DBI::BEGIN@982
1118µs16µsDBI::::BEGIN@1051 DBI::BEGIN@1051
1118µs20µsDBI::::BEGIN@288 DBI::BEGIN@288
1118µs17µsDBD::_::db::::BEGIN@1531 DBD::_::db::BEGIN@1531
1117µs39µsDBD::_::st::::BEGIN@1841 DBD::_::st::BEGIN@1841
1117µs19µsDBD::_::common::::BEGIN@1366 DBD::_::common::BEGIN@1366
1117µs16µsDBI::::BEGIN@707 DBI::BEGIN@707
1116µs16µsDBD::_::dr::::BEGIN@1466 DBD::_::dr::BEGIN@1466
1116µs15µsDBI::::BEGIN@820 DBI::BEGIN@820
1116µs15µsDBI::::BEGIN@854 DBI::BEGIN@854
5516µs6µsDBI::var::::TIESCALAR DBI::var::TIESCALAR
1116µs14µsDBI::::BEGIN@885 DBI::BEGIN@885
1115µs14µsDBI::::BEGIN@292 DBI::BEGIN@292
2215µs5µsDBI::::CORE:subst DBI::CORE:subst (opcode)
1114µs4µsDBI::::BEGIN@175 DBI::BEGIN@175
1113µs3µsDBI::::BEGIN@177 DBI::BEGIN@177
1113µs3µsDBI::::BEGIN@176 DBI::BEGIN@176
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::::CLEAR DBD::_::common::CLEAR
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::::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::::_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_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::::connect DBD::_::dr::connect
0000s0sDBD::_::dr::::connect_cached DBD::_::dr::connect_cached
0000s0sDBD::_::dr::::default_user DBD::_::dr::default_user
0000s0sDBD::_::st::::__ANON__[:1957] DBD::_::st::__ANON__[:1957]
0000s0sDBD::_::st::::__ANON__[:1991] DBD::_::st::__ANON__[:1991]
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_hashref DBD::_::st::fetchall_hashref
0000s0sDBD::_::st::::more_results DBD::_::st::more_results
0000s0sDBI::::CLONE DBI::CLONE
0000s0sDBI::::END DBI::END
0000s0sDBI::::__ANON__[:1047] DBI::__ANON__[:1047]
0000s0sDBI::::__ANON__[:1140] DBI::__ANON__[:1140]
0000s0sDBI::::__ANON__[:1174] DBI::__ANON__[:1174]
0000s0sDBI::::__ANON__[:1175] DBI::__ANON__[:1175]
0000s0sDBI::::_dbtype_names DBI::_dbtype_names
0000s0sDBI::::_load_class DBI::_load_class
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::::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::::disconnect_all DBI::disconnect_all
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::::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::var::::STORE DBI::var::STORE
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
11113µsrequire 5.008_001;
12
13
# spent 23µs within DBI::BEGIN@13 which was called: # once (23µs+0s) by DBD::SQLite::BEGIN@5 at line 16
BEGIN {
141500nsour $XS_VERSION = our $VERSION = "1.633"; # ==> ALSO update the version in the pod text below!
15119µs$VERSION = eval $VERSION;
# spent 2µs executing statements in string eval
16183µs123µs}
# spent 23µs making 1 call to DBI::BEGIN@13
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 400 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
131I don't recommend the DBI cpanforum (at http://www.cpanforum.com/dist/DBI)
132because relatively few people read it compared with dbi-users@perl.org.
133
134=head3 Reporting a Bug
135
136If you think you've found a bug then please read
137"How to Report Bugs Effectively" by Simon Tatham:
138L<http://www.chiark.greenend.org.uk/~sgtatham/bugs.html>.
139
140Your problem is most likely related to the specific DBD driver module you're
141using. If that's the case then click on the 'Bugs' link on the L<http://metacpan.org>
142page for your driver. Only submit a bug report against the DBI itself if you're
143sure that your issue isn't related to the driver you're using.
144
145=head2 NOTES
146
147This is the DBI specification that corresponds to DBI version 1.633
148(see L<DBI::Changes> for details).
149
150The DBI is evolving at a steady pace, so it's good to check that
151you have the latest copy.
152
153The significant user-visible changes in each release are documented
154in the L<DBI::Changes> module so you can read them by executing
155C<perldoc DBI::Changes>.
156
157Some DBI changes require changes in the drivers, but the drivers
158can take some time to catch up. Newer versions of the DBI have
159added features that may not yet be supported by the drivers you
160use. Talk to the authors of your drivers if you need a new feature
161that is not yet supported.
162
163Features added after DBI 1.21 (February 2002) are marked in the
164text with the version number of the DBI release they first appeared in.
165
166Extensions to the DBI API often use the C<DBIx::*> namespace.
167See L</Naming Conventions and Name Space>. DBI extension modules
168can be found at L<https://metacpan.org/search?q=DBIx>. And all modules
169related to the DBI can be found at L<https://metacpan.org/search?q=DBI>.
170
171=cut
172
173# The POD text continues at the end of the file.
174
175217µs14µs
# spent 4µs within DBI::BEGIN@175 which was called: # once (4µs+0s) by DBD::SQLite::BEGIN@5 at line 175
use Carp();
# spent 4µs making 1 call to DBI::BEGIN@175
176216µs13µs
# spent 3µs within DBI::BEGIN@176 which was called: # once (3µs+0s) by DBD::SQLite::BEGIN@5 at line 176
use DynaLoader ();
# spent 3µs making 1 call to DBI::BEGIN@176
1772264µs13µs
# spent 3µs within DBI::BEGIN@177 which was called: # once (3µs+0s) by DBD::SQLite::BEGIN@5 at line 177
use Exporter ();
# spent 3µs making 1 call to DBI::BEGIN@177
178
179
# spent 656µs (197+459) within DBI::BEGIN@179 which was called: # once (197µs+459µs) by DBD::SQLite::BEGIN@5 at line 284
BEGIN {
18019µs@ISA = qw(Exporter DynaLoader);
181
182# Make some utility functions available if asked for
1831300ns@EXPORT = (); # we export nothing by default
1841800ns@EXPORT_OK = qw(%DBI %DBI_methods hash); # also populated by export_ok_tags:
185111µs%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
2641200ns$DBI::dbi_debug = 0; # mixture of bit fields and int sub-fields
2651100ns$DBI::neat_maxlen = 1000;
2661100ns$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.
27112µsif ( $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 {
27714µs1391µs bootstrap DBI $XS_VERSION;
# spent 391µs making 1 call to DynaLoader::bootstrap
278}
279
280128174µs12716µs$EXPORT_TAGS{preparse_flags} = [ grep { /^DBIpp_\w\w_/ } keys %{__PACKAGE__."::"} ];
# spent 16µs making 127 calls to DBI::CORE:match, avg 123ns/call
281
28214µs118µsExporter::export_ok_tags(keys %EXPORT_TAGS);
# spent 18µs making 1 call to Exporter::export_ok_tags
283
284143µs1656µs}
# spent 656µs making 1 call to DBI::BEGIN@179
285
286# Alias some handle methods to also be DBI class methods
28711µsfor (qw(trace_msg set_err parse_trace_flag parse_trace_flags)) {
288241µs233µs
# spent 20µs (8+12) within DBI::BEGIN@288 which was called: # once (8µs+12µs) by DBD::SQLite::BEGIN@5 at line 288
no strict;
# spent 20µs making 1 call to DBI::BEGIN@288 # spent 12µs making 1 call to strict::unimport
289410µs *$_ = \&{"DBD::_::common::$_"};
290}
291
2922919µs222µs
# spent 14µs (5+9) within DBI::BEGIN@292 which was called: # once (5µs+9µs) by DBD::SQLite::BEGIN@5 at line 292
use strict;
# spent 14µs making 1 call to DBI::BEGIN@292 # spent 9µs making 1 call to strict::import
293
2941600nsDBI->trace(split /=/, $ENV{DBI_TRACE}, 2) if $ENV{DBI_TRACE};
295
29612µs$DBI::connect_via ||= "connect";
297
298# check if user wants a persistent database connection ( Apache + mod_perl )
2991200nsif ($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# check for weaken support, used by ChildHandles
3051400nsmy $HAS_WEAKEN = eval {
3061500ns require Scalar::Util;
307 # this will croak() if this Scalar::Util doesn't have a working weaken().
30817µs12µs Scalar::Util::weaken( \my $test ); # same test as in t/72childhandles.t
# spent 2µs making 1 call to Scalar::Util::weaken
30911µs 1;
310};
311
3121800ns%DBI::installed_drh = (); # maps driver names to installed driver handles
313sub installed_drivers { %DBI::installed_drh }
3141300ns%DBI::installed_methods = (); # XXX undocumented, may change
315sub installed_methods { %DBI::installed_methods }
316
317# Setup special DBI dynamic variables. See DBI::var::FETCH for details.
318# These are dynamically associated with the last handle used.
31915µs12µstie $DBI::err, 'DBI::var', '*err'; # special case: referenced via IHA list
# spent 2µs making 1 call to DBI::var::TIESCALAR
32012µs11µstie $DBI::state, 'DBI::var', '"state'; # special case: referenced via IHA list
# spent 1µs making 1 call to DBI::var::TIESCALAR
32111µs1800nstie $DBI::lasth, 'DBI::var', '!lasth'; # special case: return boolean
# spent 800ns making 1 call to DBI::var::TIESCALAR
32211µs1800nstie $DBI::errstr, 'DBI::var', '&errstr'; # call &errstr in last used pkg
# spent 800ns making 1 call to DBI::var::TIESCALAR
32311µs1900nstie $DBI::rows, 'DBI::var', '&rows'; # call &rows in last used pkg
# spent 900ns making 1 call to DBI::var::TIESCALAR
3241014µs
# spent 6µs within DBI::var::TIESCALAR which was called 5 times, avg 1µs/call: # once (2µs+0s) by DBD::SQLite::BEGIN@5 at line 319 # once (1µs+0s) by DBD::SQLite::BEGIN@5 at line 320 # once (900ns+0s) by DBD::SQLite::BEGIN@5 at line 323 # once (800ns+0s) by DBD::SQLite::BEGIN@5 at line 321 # once (800ns+0s) by DBD::SQLite::BEGIN@5 at line 322
sub DBI::var::TIESCALAR{ my $var = $_[1]; bless \$var, 'DBI::var'; }
325sub DBI::var::STORE { Carp::croak("Can't modify \$DBI::${$_[0]} special variable") }
326
327# --- Driver Specific Prefix Registry ---
328
329142µsmy $dbd_prefix_registry = {
330 ad_ => { class => 'DBD::AnyData', },
331 ad2_ => { class => 'DBD::AnyData2', },
332 ado_ => { class => 'DBD::ADO', },
333 amzn_ => { class => 'DBD::Amazon', },
334 best_ => { class => 'DBD::BestWins', },
335 csv_ => { class => 'DBD::CSV', },
336 cubrid_ => { class => 'DBD::cubrid', },
337 db2_ => { class => 'DBD::DB2', },
338 dbi_ => { class => 'DBI', },
339 dbm_ => { class => 'DBD::DBM', },
340 df_ => { class => 'DBD::DF', },
341 examplep_ => { class => 'DBD::ExampleP', },
342 f_ => { class => 'DBD::File', },
343 file_ => { class => 'DBD::TextFile', },
344 go_ => { class => 'DBD::Gofer', },
345 ib_ => { class => 'DBD::InterBase', },
346 ing_ => { class => 'DBD::Ingres', },
347 ix_ => { class => 'DBD::Informix', },
348 jdbc_ => { class => 'DBD::JDBC', },
349 mo_ => { class => 'DBD::MO', },
350 monetdb_ => { class => 'DBD::monetdb', },
351 msql_ => { class => 'DBD::mSQL', },
352 mvsftp_ => { class => 'DBD::MVS_FTPSQL', },
353 mysql_ => { class => 'DBD::mysql', },
354 multi_ => { class => 'DBD::Multi' },
355 mx_ => { class => 'DBD::Multiplex', },
356 neo_ => { class => 'DBD::Neo4p', },
357 nullp_ => { class => 'DBD::NullP', },
358 odbc_ => { class => 'DBD::ODBC', },
359 ora_ => { class => 'DBD::Oracle', },
360 pg_ => { class => 'DBD::Pg', },
361 pgpp_ => { class => 'DBD::PgPP', },
362 plb_ => { class => 'DBD::Plibdata', },
363 po_ => { class => 'DBD::PO', },
364 proxy_ => { class => 'DBD::Proxy', },
365 ram_ => { class => 'DBD::RAM', },
366 rdb_ => { class => 'DBD::RDB', },
367 sapdb_ => { class => 'DBD::SAP_DB', },
368 snmp_ => { class => 'DBD::SNMP', },
369 solid_ => { class => 'DBD::Solid', },
370 spatialite_ => { class => 'DBD::Spatialite', },
371 sponge_ => { class => 'DBD::Sponge', },
372 sql_ => { class => 'DBI::DBD::SqlEngine', },
373 sqlite_ => { class => 'DBD::SQLite', },
374 syb_ => { class => 'DBD::Sybase', },
375 sys_ => { class => 'DBD::Sys', },
376 tdat_ => { class => 'DBD::Teradata', },
377 tmpl_ => { class => 'DBD::Template', },
378 tmplss_ => { class => 'DBD::TemplateSS', },
379 tree_ => { class => 'DBD::TreeData', },
380 tuber_ => { class => 'DBD::Tuber', },
381 uni_ => { class => 'DBD::Unify', },
382 vt_ => { class => 'DBD::Vt', },
383 wmi_ => { class => 'DBD::WMI', },
384 x_ => { }, # for private use
385 xbase_ => { class => 'DBD::XBase', },
386 xl_ => { class => 'DBD::Excel', },
387 yaswi_ => { class => 'DBD::Yaswi', },
388};
389
390my %dbd_class_registry = map { $dbd_prefix_registry->{$_}->{class} => { prefix => $_ } }
391 grep { exists $dbd_prefix_registry->{$_}->{class} }
392179µs keys %{$dbd_prefix_registry};
393
394sub dump_dbd_registry {
395 require Data::Dumper;
396 local $Data::Dumper::Sortkeys=1;
397 local $Data::Dumper::Indent=1;
398 print Data::Dumper->Dump([$dbd_prefix_registry], [qw($dbd_prefix_registry)]);
399}
400
401# --- Dynamically create the DBI Standard Interface
402
4031800nsmy $keeperr = { O=>0x0004 };
404
405190µs%DBI::DBI_methods = ( # Define the DBI interface methods per class:
406
407 common => { # Interface methods common to all DBI handle classes
408 'DESTROY' => { O=>0x004|0x10000 },
409 'CLEAR' => $keeperr,
410 'EXISTS' => $keeperr,
411 'FETCH' => { O=>0x0404 },
412 'FETCH_many' => { O=>0x0404 },
413 'FIRSTKEY' => $keeperr,
414 'NEXTKEY' => $keeperr,
415 'STORE' => { O=>0x0418 | 0x4 },
416 'DELETE' => { O=>0x0404 },
417 can => { O=>0x0100 }, # special case, see dispatch
418 debug => { U =>[1,2,'[$debug_level]'], O=>0x0004 }, # old name for trace
419 dump_handle => { U =>[1,3,'[$message [, $level]]'], O=>0x0004 },
420 err => $keeperr,
421 errstr => $keeperr,
422 state => $keeperr,
423 func => { O=>0x0006 },
424 parse_trace_flag => { U =>[2,2,'$name'], O=>0x0404, T=>8 },
425 parse_trace_flags => { U =>[2,2,'$flags'], O=>0x0404, T=>8 },
426 private_data => { U =>[1,1], O=>0x0004 },
427 set_err => { U =>[3,6,'$err, $errmsg [, $state, $method, $rv]'], O=>0x0010 },
428 trace => { U =>[1,3,'[$trace_level, [$filename]]'], O=>0x0004 },
429 trace_msg => { U =>[2,3,'$message_text [, $min_level ]' ], O=>0x0004, T=>8 },
430 swap_inner_handle => { U =>[2,3,'$h [, $allow_reparent ]'] },
431 private_attribute_info => { },
432 visit_child_handles => { U => [2,3,'$coderef [, $info ]'], O=>0x0404, T=>4 },
433 },
434 dr => { # Database Driver Interface
435 'connect' => { U =>[1,5,'[$db [,$user [,$passwd [,\%attr]]]]'], H=>3, O=>0x8000, T=>0x200 },
436 'connect_cached'=>{U=>[1,5,'[$db [,$user [,$passwd [,\%attr]]]]'], H=>3, O=>0x8000, T=>0x200 },
437 'disconnect_all'=>{ U =>[1,1], O=>0x0800, T=>0x200 },
438 data_sources => { U =>[1,2,'[\%attr]' ], O=>0x0800, T=>0x200 },
439 default_user => { U =>[3,4,'$user, $pass [, \%attr]' ], T=>0x200 },
440 dbixs_revision => $keeperr,
441 },
442 db => { # Database Session Class Interface
443 data_sources => { U =>[1,2,'[\%attr]' ], O=>0x0200 },
444 take_imp_data => { U =>[1,1], O=>0x10000 },
445 clone => { U =>[1,2,'[\%attr]'], T=>0x200 },
446 connected => { U =>[1,0], O => 0x0004, T=>0x200, H=>3 },
447 begin_work => { U =>[1,2,'[ \%attr ]'], O=>0x0400, T=>0x1000 },
448 commit => { U =>[1,1], O=>0x0480|0x0800, T=>0x1000 },
449 rollback => { U =>[1,1], O=>0x0480|0x0800, T=>0x1000 },
450 'do' => { U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x3200 },
451 last_insert_id => { U =>[5,6,'$catalog, $schema, $table_name, $field_name [, \%attr ]'], O=>0x2800 },
452 preparse => { }, # XXX
453 prepare => { U =>[2,3,'$statement [, \%attr]'], O=>0xA200 },
454 prepare_cached => { U =>[2,4,'$statement [, \%attr [, $if_active ] ]'], O=>0xA200 },
455 selectrow_array => { U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
456 selectrow_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
457 selectrow_hashref=>{ U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
458 selectall_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
459 selectall_hashref=>{ U =>[3,0,'$statement, $keyfield [, \%attr [, @bind_params ] ]'], O=>0x2000 },
460 selectcol_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
461 ping => { U =>[1,1], O=>0x0404 },
462 disconnect => { U =>[1,1], O=>0x0400|0x0800|0x10000, T=>0x200 },
463 quote => { U =>[2,3, '$string [, $data_type ]' ], O=>0x0430, T=>2 },
464 quote_identifier=> { U =>[2,6, '$name [, ...] [, \%attr ]' ], O=>0x0430, T=>2 },
465 rows => $keeperr,
466
467 tables => { U =>[1,6,'$catalog, $schema, $table, $type [, \%attr ]' ], O=>0x2200 },
468 table_info => { U =>[1,6,'$catalog, $schema, $table, $type [, \%attr ]' ], O=>0x2200|0x8800 },
469 column_info => { U =>[5,6,'$catalog, $schema, $table, $column [, \%attr ]'],O=>0x2200|0x8800 },
470 primary_key_info=> { U =>[4,5,'$catalog, $schema, $table [, \%attr ]' ], O=>0x2200|0x8800 },
471 primary_key => { U =>[4,5,'$catalog, $schema, $table [, \%attr ]' ], O=>0x2200 },
472 foreign_key_info=> { U =>[7,8,'$pk_catalog, $pk_schema, $pk_table, $fk_catalog, $fk_schema, $fk_table [, \%attr ]' ], O=>0x2200|0x8800 },
473 statistics_info => { U =>[6,7,'$catalog, $schema, $table, $unique_only, $quick, [, \%attr ]' ], O=>0x2200|0x8800 },
474 type_info_all => { U =>[1,1], O=>0x2200|0x0800 },
475 type_info => { U =>[1,2,'$data_type'], O=>0x2200 },
476 get_info => { U =>[2,2,'$info_type'], O=>0x2200|0x0800 },
477 },
478 st => { # Statement Class Interface
479 bind_col => { U =>[3,4,'$column, \\$var [, \%attr]'] },
480 bind_columns => { U =>[2,0,'\\$var1 [, \\$var2, ...]'] },
481 bind_param => { U =>[3,4,'$parameter, $var [, \%attr]'] },
482 bind_param_inout=> { U =>[4,5,'$parameter, \\$var, $maxlen, [, \%attr]'] },
483 execute => { U =>[1,0,'[@args]'], O=>0x1040 },
484
485 bind_param_array => { U =>[3,4,'$parameter, $var [, \%attr]'] },
486 bind_param_inout_array => { U =>[4,5,'$parameter, \\@var, $maxlen, [, \%attr]'] },
487 execute_array => { U =>[2,0,'\\%attribs [, @args]'], O=>0x1040|0x4000 },
488 execute_for_fetch => { U =>[2,3,'$fetch_sub [, $tuple_status]'], O=>0x1040|0x4000 },
489
490 fetch => undef, # alias for fetchrow_arrayref
491 fetchrow_arrayref => undef,
492 fetchrow_hashref => undef,
493 fetchrow_array => undef,
494 fetchrow => undef, # old alias for fetchrow_array
495
496 fetchall_arrayref => { U =>[1,3, '[ $slice [, $max_rows]]'] },
497 fetchall_hashref => { U =>[2,2,'$key_field'] },
498
499 blob_read => { U =>[4,5,'$field, $offset, $len [, \\$buf [, $bufoffset]]'] },
500 blob_copy_to_file => { U =>[3,3,'$field, $filename_or_handleref'] },
501 dump_results => { U =>[1,5,'$maxfieldlen, $linesep, $fieldsep, $filehandle'] },
502 more_results => { U =>[1,1] },
503 finish => { U =>[1,1] },
504 cancel => { U =>[1,1], O=>0x0800 },
505 rows => $keeperr,
506
507 _get_fbav => undef,
508 _set_fbav => { T=>6 },
509 },
510);
511
51214µswhile ( my ($class, $meths) = each %DBI::DBI_methods ) {
51342µs my $ima_trace = 0+($ENV{DBI_IMA_TRACE}||0);
514463µs while ( my ($method, $info) = each %$meths ) {
5158930µs my $fullmeth = "DBI::${class}::$method";
5168911µs if (($DBI::dbi_debug & 0xF) == 15) { # quick hack to list DBI methods
517 # and optionally filter by IMA flags
518 my $O = $info->{O}||0;
519 printf "0x%04x %-20s\n", $O, $fullmeth
520 unless $ima_trace && !($O & $ima_trace);
521 }
52289387µs89240µs DBI->_install_method($fullmeth, 'DBI.pm', $info);
# spent 240µs making 89 calls to DBI::_install_method, avg 3µs/call
523 }
524}
525
526{
5271100ns package DBI::common;
528116µs @DBI::dr::ISA = ('DBI::common');
52914µs @DBI::db::ISA = ('DBI::common');
53012µs @DBI::st::ISA = ('DBI::common');
531}
532
533# End of init code
534
535
536END {
537 return unless defined &DBI::trace_msg; # return unless bootstrap'd ok
538 local ($!,$?);
539 DBI->trace_msg(sprintf(" -- DBI::END (\$\@: %s, \$!: %s)\n", $@||'', $!||''), 2);
540 # Let drivers know why we are calling disconnect_all:
541 $DBI::PERL_ENDING = $DBI::PERL_ENDING = 1; # avoid typo warning
542 DBI->disconnect_all() if %DBI::installed_drh;
543}
544
545
546sub CLONE {
547 _clone_dbis() unless $DBI::PurePerl; # clone the DBIS structure
548 DBI->trace_msg("CLONE DBI for new thread\n");
549 while ( my ($driver, $drh) = each %DBI::installed_drh) {
5502778µs233µs
# spent 24µs (15+9) within DBI::BEGIN@550 which was called: # once (15µs+9µs) by DBD::SQLite::BEGIN@5 at line 550
no strict 'refs';
# spent 24µs making 1 call to DBI::BEGIN@550 # spent 9µs making 1 call to strict::unimport
551 next if defined &{"DBD::${driver}::CLONE"};
552 warn("$driver has no driver CLONE() function so is unsafe threaded\n");
553 }
554 %DBI::installed_drh = (); # clear loaded drivers so they have a chance to reinitialize
555}
556
557sub parse_dsn {
558 my ($class, $dsn) = @_;
559 $dsn =~ s/^(dbi):(\w*?)(?:\((.*?)\))?://i or return;
560 my ($scheme, $driver, $attr, $attr_hash) = (lc($1), $2, $3);
561 $driver ||= $ENV{DBI_DRIVER} || '';
562 $attr_hash = { split /\s*=>?\s*|\s*,\s*/, $attr, -1 } if $attr;
563 return ($scheme, $driver, $attr, $attr_hash, $dsn);
564}
565
566sub visit_handles {
567 my ($class, $code, $outer_info) = @_;
568 $outer_info = {} if not defined $outer_info;
569 my %drh = DBI->installed_drivers;
570 for my $h (values %drh) {
571 my $child_info = $code->($h, $outer_info)
572 or next;
573 $h->visit_child_handles($code, $child_info);
574 }
575 return $outer_info;
576}
577
578
579# --- The DBI->connect Front Door methods
580
581sub connect_cached {
582 # For library code using connect_cached() with mod_perl
583 # we redirect those calls to Apache::DBI::connect() as well
584 my ($class, $dsn, $user, $pass, $attr) = @_;
585 my $dbi_connect_method = ($DBI::connect_via eq "Apache::DBI::connect")
586 ? 'Apache::DBI::connect' : 'connect_cached';
587 $attr = {
588 $attr ? %$attr : (), # clone, don't modify callers data
589 dbi_connect_method => $dbi_connect_method,
590 };
591 return $class->connect($dsn, $user, $pass, $attr);
592}
593
594
# spent 1.15ms (61µs+1.09) within DBI::connect which was called: # once (61µs+1.09ms) by Test::PONAPI::Repository::MockDB::Loader::_build_dbh at line 30 of lib/Test/PONAPI/Repository/MockDB/Loader.pm
sub connect {
5951400ns my $class = shift;
596111µs my ($dsn, $user, $pass, $attr, $old_driver) = my @orig_args = @_;
5971300ns my $driver;
598
5991600ns if ($attr and !ref($attr)) { # switch $old_driver<->$attr if called in old style
600 Carp::carp("DBI->connect using 'old-style' syntax is deprecated and will be an error in future versions");
601 ($old_driver, $attr) = ($attr, $old_driver);
602 }
603
6041900ns my $connect_meth = $attr->{dbi_connect_method};
6051700ns $connect_meth ||= $DBI::connect_via; # fallback to default
606
6071400ns $dsn ||= $ENV{DBI_DSN} || $ENV{DBI_DBNAME} || '' unless $old_driver;
608
6091400ns if ($DBI::dbi_debug) {
610 local $^W = 0;
611 pop @_ if $connect_meth ne 'connect';
612 my @args = @_; $args[2] = '****'; # hide password
613 DBI->trace_msg(" -> $class->$connect_meth(".join(", ",@args).")\n");
614 }
61511µs Carp::croak('Usage: $class->connect([$dsn [,$user [,$passwd [,\%attr]]]])')
616 if (ref $old_driver or ($attr and not ref $attr) or ref $pass);
617
618 # extract dbi:driver prefix from $dsn into $1
619110µs14µs $dsn =~ s/^dbi:(\w*?)(?:\((.*?)\))?://i
# spent 4µs making 1 call to DBI::CORE:subst
620 or '' =~ /()/; # ensure $1 etc are empty if match fails
62111µs my $driver_attrib_spec = $2 || '';
622
623 # Set $driver. Old style driver, if specified, overrides new dsn style.
62411µs $driver = $old_driver || $1 || $ENV{DBI_DRIVER}
625 or Carp::croak("Can't connect to data source '$dsn' "
626 ."because I can't work out what driver to use "
627 ."(it doesn't seem to contain a 'dbi:driver:' prefix "
628 ."and the DBI_DRIVER env var is not set)");
629
6301300ns my $proxy;
6311600ns if ($ENV{DBI_AUTOPROXY} && $driver ne 'Proxy' && $driver ne 'Sponge' && $driver ne 'Switch') {
632 my $dbi_autoproxy = $ENV{DBI_AUTOPROXY};
633 $proxy = 'Proxy';
634 if ($dbi_autoproxy =~ s/^dbi:(\w*?)(?:\((.*?)\))?://i) {
635 $proxy = $1;
636 $driver_attrib_spec = join ",",
637 ($driver_attrib_spec) ? $driver_attrib_spec : (),
638 ($2 ) ? $2 : ();
639 }
640 $dsn = "$dbi_autoproxy;dsn=dbi:$driver:$dsn";
641 $driver = $proxy;
642 DBI->trace_msg(" DBI_AUTOPROXY: dbi:$driver($driver_attrib_spec):$dsn\n");
643 }
644 # avoid recursion if proxy calls DBI->connect itself
6451400ns local $ENV{DBI_AUTOPROXY} if $ENV{DBI_AUTOPROXY};
646
6471200ns my %attributes; # take a copy we can delete from
6481500ns if ($old_driver) {
649 %attributes = %$attr if $attr;
650 }
651 else { # new-style connect so new default semantics
65213µs %attributes = (
653 PrintError => 1,
654 AutoCommit => 1,
655 ref $attr ? %$attr : (),
656 # attributes in DSN take precedence over \%attr connect parameter
657 $driver_attrib_spec ? (split /\s*=>?\s*|\s*,\s*/, $driver_attrib_spec, -1) : (),
658 );
659 }
66012µs $attr = \%attributes; # now set $attr to refer to our local copy
661
66214µs1710µs my $drh = $DBI::installed_drh{$driver} || $class->install_driver($driver)
# spent 710µs making 1 call to DBI::install_driver
663 or die "panic: $class->install_driver($driver) failed";
664
665 # attributes in DSN take precedence over \%attr connect parameter
6661700ns $user = $attr->{Username} if defined $attr->{Username};
6671500ns $pass = $attr->{Password} if defined $attr->{Password};
6681500ns delete $attr->{Password}; # always delete Password as closure stores it securely
6691400ns if ( !(defined $user && defined $pass) ) {
670 ($user, $pass) = $drh->default_user($user, $pass, $attr);
671 }
6721700ns $attr->{Username} = $user; # force the Username to be the actual one used
673
674
# spent 372µs (54+318) within DBI::__ANON__[/usr/local/lib/perl/5.18.2/DBI.pm:748] which was called: # once (54µs+318µs) by DBI::connect at line 750
my $connect_closure = sub {
6751300ns my ($old_dbh, $override_attr) = @_;
676
677 #use Data::Dumper;
678 #warn "connect_closure: ".Data::Dumper::Dumper([$attr,\%attributes, $override_attr]);
679
6801200ns my $dbh;
681120µs2584µs unless ($dbh = $drh->$connect_meth($dsn, $user, $pass, $attr)) {
# spent 299µs making 1 call to DBI::dr::connect # spent 285µs making 1 call to DBD::SQLite::dr::connect
682 $user = '' if !defined $user;
683 $dsn = '' if !defined $dsn;
684 # $drh->errstr isn't safe here because $dbh->DESTROY may not have
685 # been called yet and so the dbh errstr would not have been copied
686 # up to the drh errstr. Certainly true for connect_cached!
687 my $errstr = $DBI::errstr;
688 # Getting '(no error string)' here is a symptom of a ref loop
689 $errstr = '(no error string)' if !defined $errstr;
690 my $msg = "$class connect('$dsn','$user',...) failed: $errstr";
691 DBI->trace_msg(" $msg\n");
692 # XXX HandleWarn
693 unless ($attr->{HandleError} && $attr->{HandleError}->($msg, $drh, $dbh)) {
694 Carp::croak($msg) if $attr->{RaiseError};
695 Carp::carp ($msg) if $attr->{PrintError};
696 }
697 $! = 0; # for the daft people who do DBI->connect(...) || die "$!";
698 return $dbh; # normally undef, but HandleError could change it
699 }
700
701 # merge any attribute overrides but don't change $attr itself (for closure)
70213µs my $apply = { ($override_attr) ? (%$attr, %$override_attr ) : %$attr };
703
704 # handle basic RootClass subclassing:
70512µs my $rebless_class = $apply->{RootClass} || ($class ne 'DBI' ? $class : '');
7061300ns if ($rebless_class) {
7072584µs226µs
# spent 16µs (7+9) within DBI::BEGIN@707 which was called: # once (7µs+9µs) by DBD::SQLite::BEGIN@5 at line 707
no strict 'refs';
# spent 16µs making 1 call to DBI::BEGIN@707 # spent 9µs making 1 call to strict::unimport
708 if ($apply->{RootClass}) { # explicit attribute (ie not static method call class)
709 delete $apply->{RootClass};
710 DBI::_load_class($rebless_class, 0);
711 }
712 unless (@{"$rebless_class\::db::ISA"} && @{"$rebless_class\::st::ISA"}) {
713 Carp::carp("DBI subclasses '$rebless_class\::db' and ::st are not setup, RootClass ignored");
714 $rebless_class = undef;
715 $class = 'DBI';
716 }
717 else {
718 $dbh->{RootClass} = $rebless_class; # $dbh->STORE called via plain DBI::db
719 DBI::_set_isa([$rebless_class], 'DBI'); # sets up both '::db' and '::st'
720 DBI::_rebless($dbh, $rebless_class); # appends '::db'
721 }
722 }
723
7241600ns if (%$apply) {
725
7261400ns if ($apply->{DbTypeSubclass}) {
727 my $DbTypeSubclass = delete $apply->{DbTypeSubclass};
728 DBI::_rebless_dbtype_subclass($dbh, $rebless_class||$class, $DbTypeSubclass);
729 }
7301100ns my $a;
7311900ns foreach $a (qw(Profile RaiseError PrintError AutoCommit)) { # do these first
73242µs next unless exists $apply->{$a};
733332µs311µs $dbh->{$a} = delete $apply->{$a};
# spent 11µs making 3 calls to DBI::common::STORE, avg 4µs/call
734 }
73512µs while ( my ($a, $v) = each %$apply) {
73629µs15µs eval { $dbh->{$a} = $v }; # assign in void context to avoid re-FETCH
# spent 5µs making 1 call to DBI::common::STORE
7371300ns warn $@ if $@;
738 }
739 }
740
741 # confirm to driver (ie if subclassed) that we've connected successfully
742 # and finished the attribute setup. pass in the original arguments
743110µs13µs $dbh->connected(@orig_args); #if ref $dbh ne 'DBI::db' or $proxy;
# spent 3µs making 1 call to DBI::db::connected
744
7451500ns DBI->trace_msg(" <- connect= $dbh\n") if $DBI::dbi_debug & 0xF;
746
74713µs return $dbh;
748114µs };
749
75012µs1372µs my $dbh = &$connect_closure(undef, undef);
# spent 372µs making 1 call to DBI::__ANON__[DBI.pm:748]
751
75217µs13µs $dbh->{dbi_connect_closure} = $connect_closure if $dbh;
# spent 3µs making 1 call to DBI::common::STORE
753
75413µs return $dbh;
755}
756
757
758sub disconnect_all {
759 keys %DBI::installed_drh; # reset iterator
760 while ( my ($name, $drh) = each %DBI::installed_drh ) {
761 $drh->disconnect_all() if ref $drh;
762 }
763}
764
765
766sub disconnect { # a regular beginners bug
767 Carp::croak("DBI->disconnect is not a DBI method (read the DBI manual)");
768}
769
770
771
# spent 710µs (80+630) within DBI::install_driver which was called: # once (80µs+630µs) by DBI::connect at line 662
sub install_driver { # croaks on failure
7721400ns my $class = shift;
7731500ns my($driver, $attr) = @_;
7741300ns my $drh;
775
7761200ns $driver ||= $ENV{DBI_DRIVER} || '';
777
778 # allow driver to be specified as a 'dbi:driver:' string
77913µs1500ns $driver = $1 if $driver =~ s/^DBI:(.*?)://i;
# spent 500ns making 1 call to DBI::CORE:subst
780
7811600ns Carp::croak("usage: $class->install_driver(\$driver [, \%attr])")
782 unless ($driver and @_<=3);
783
784 # already installed
7851500ns return $drh if $drh = $DBI::installed_drh{$driver};
786
7871500ns $class->trace_msg(" -> $class->install_driver($driver"
788 .") for $^O perl=$] pid=$$ ruid=$< euid=$>\n")
789 if $DBI::dbi_debug & 0xF;
790
791 # --- load the code
7921900ns my $driver_class = "DBD::$driver";
793154µs eval qq{package # hide from PAUSE
# spent 2µs executing statements in string eval
794 DBI::_firesafe; # just in case
795 require $driver_class; # load the driver
796 };
7971300ns if ($@) {
798 my $err = $@;
799 my $advice = "";
800 if ($err =~ /Can't find loadable object/) {
801 $advice = "Perhaps DBD::$driver was statically linked into a new perl binary."
802 ."\nIn which case you need to use that new perl binary."
803 ."\nOr perhaps only the .pm file was installed but not the shared object file."
804 }
805 elsif ($err =~ /Can't locate.*?DBD\/$driver\.pm in \@INC/) {
806 my @drv = $class->available_drivers(1);
807 $advice = "Perhaps the DBD::$driver perl module hasn't been fully installed,\n"
808 ."or perhaps the capitalisation of '$driver' isn't right.\n"
809 ."Available drivers: ".join(", ", @drv).".";
810 }
811 elsif ($err =~ /Can't load .*? for module DBD::/) {
812 $advice = "Perhaps a required shared library or dll isn't installed where expected";
813 }
814 elsif ($err =~ /Can't locate .*? in \@INC/) {
815 $advice = "Perhaps a module that DBD::$driver requires hasn't been fully installed";
816 }
817 Carp::croak("install_driver($driver) failed: $err$advice\n");
818 }
8191900ns if ($DBI::dbi_debug & 0xF) {
8202216µs224µs
# spent 15µs (6+9) within DBI::BEGIN@820 which was called: # once (6µs+9µs) by DBD::SQLite::BEGIN@5 at line 820
no strict 'refs';
# spent 15µs making 1 call to DBI::BEGIN@820 # spent 9µs making 1 call to strict::unimport
821 (my $driver_file = $driver_class) =~ s/::/\//g;
822 my $dbd_ver = ${"$driver_class\::VERSION"} || "undef";
823 $class->trace_msg(" install_driver: $driver_class version $dbd_ver"
824 ." loaded from $INC{qq($driver_file.pm)}\n");
825 }
826
827 # --- do some behind-the-scenes checks and setups on the driver
82814µs173µs $class->setup_driver($driver_class);
# spent 73µs making 1 call to DBI::setup_driver
829
830 # --- run the driver function
831213µs1556µs $drh = eval { $driver_class->driver($attr || {}) };
# spent 556µs making 1 call to DBD::SQLite::driver
83214µs unless ($drh && ref $drh && !$@) {
833 my $advice = "";
834 $@ ||= "$driver_class->driver didn't return a handle";
835 # catch people on case in-sensitive systems using the wrong case
836 $advice = "\nPerhaps the capitalisation of DBD '$driver' isn't right."
837 if $@ =~ /locate object method/;
838 Carp::croak("$driver_class initialisation failed: $@$advice");
839 }
840
84111µs $DBI::installed_drh{$driver} = $drh;
8421400ns $class->trace_msg(" <- install_driver= $drh\n") if $DBI::dbi_debug & 0xF;
84313µs $drh;
844}
845
8461900ns*driver = \&install_driver; # currently an alias, may change
847
848
849
# spent 153µs (120+32) within DBI::setup_driver which was called 3 times, avg 51µs/call: # once (56µs+17µs) by DBI::install_driver at line 828 # once (52µs+12µs) by DBD::SQLite::BEGIN@5 at line 1316 # once (13µs+4µs) by DBD::SQLite::driver at line 35 of DBD/SQLite.pm
sub setup_driver {
85032µs my ($class, $driver_class) = @_;
8513500ns my $h_type;
85239µs foreach $h_type (qw(dr db st)){
85394µs my $h_class = $driver_class."::$h_type";
8542188µs224µs
# spent 15µs (6+9) within DBI::BEGIN@854 which was called: # once (6µs+9µs) by DBD::SQLite::BEGIN@5 at line 854
no strict 'refs';
# spent 15µs making 1 call to DBI::BEGIN@854 # spent 9µs making 1 call to strict::unimport
855969µs918µs push @{"${h_class}::ISA"}, "DBD::_::$h_type"
# spent 18µs making 9 calls to UNIVERSAL::isa, avg 2µs/call
856 unless UNIVERSAL::isa($h_class, "DBD::_::$h_type");
857 # The _mem class stuff is (IIRC) a crufty hack for global destruction
858 # timing issues in early versions of perl5 and possibly no longer needed.
85993µs my $mem_class = "DBD::_mem::$h_type";
860968µs914µs push @{"${h_class}_mem::ISA"}, $mem_class
# spent 14µs making 9 calls to UNIVERSAL::isa, avg 2µs/call
861 unless UNIVERSAL::isa("${h_class}_mem", $mem_class)
862 or $DBI::PurePerl;
863 }
864}
865
866
867sub _rebless {
868 my $dbh = shift;
869 my ($outer, $inner) = DBI::_handles($dbh);
870 my $class = shift(@_).'::db';
871 bless $inner => $class;
872 bless $outer => $class; # outer last for return
873}
874
875
876sub _set_isa {
877 my ($classes, $topclass) = @_;
878 my $trace = DBI->trace_msg(" _set_isa([@$classes])\n");
879 foreach my $suffix ('::db','::st') {
880 my $previous = $topclass || 'DBI'; # trees are rooted here
881 foreach my $class (@$classes) {
882 my $base_class = $previous.$suffix;
883 my $sub_class = $class.$suffix;
884 my $sub_class_isa = "${sub_class}::ISA";
8852460µs222µs
# spent 14µs (6+8) within DBI::BEGIN@885 which was called: # once (6µs+8µs) by DBD::SQLite::BEGIN@5 at line 885
no strict 'refs';
# spent 14µs making 1 call to DBI::BEGIN@885 # spent 8µs making 1 call to strict::unimport
886 if (@$sub_class_isa) {
887 DBI->trace_msg(" $sub_class_isa skipped (already set to @$sub_class_isa)\n")
888 if $trace;
889 }
890 else {
891 @$sub_class_isa = ($base_class) unless @$sub_class_isa;
892 DBI->trace_msg(" $sub_class_isa = $base_class\n")
893 if $trace;
894 }
895 $previous = $class;
896 }
897 }
898}
899
900
901sub _rebless_dbtype_subclass {
902 my ($dbh, $rootclass, $DbTypeSubclass) = @_;
903 # determine the db type names for class hierarchy
904 my @hierarchy = DBI::_dbtype_names($dbh, $DbTypeSubclass);
905 # add the rootclass prefix to each ('DBI::' or 'MyDBI::' etc)
906 $_ = $rootclass.'::'.$_ foreach (@hierarchy);
907 # load the modules from the 'top down'
908 DBI::_load_class($_, 1) foreach (reverse @hierarchy);
909 # setup class hierarchy if needed, does both '::db' and '::st'
910 DBI::_set_isa(\@hierarchy, $rootclass);
911 # finally bless the handle into the subclass
912 DBI::_rebless($dbh, $hierarchy[0]);
913}
914
915
916sub _dbtype_names { # list dbtypes for hierarchy, ie Informix=>ADO=>ODBC
917 my ($dbh, $DbTypeSubclass) = @_;
918
919 if ($DbTypeSubclass && $DbTypeSubclass ne '1' && ref $DbTypeSubclass ne 'CODE') {
920 # treat $DbTypeSubclass as a comma separated list of names
921 my @dbtypes = split /\s*,\s*/, $DbTypeSubclass;
922 $dbh->trace_msg(" DbTypeSubclass($DbTypeSubclass)=@dbtypes (explicit)\n");
923 return @dbtypes;
924 }
925
926 # XXX will call $dbh->get_info(17) (=SQL_DBMS_NAME) in future?
927
928 my $driver = $dbh->{Driver}->{Name};
929 if ( $driver eq 'Proxy' ) {
930 # XXX Looking into the internals of DBD::Proxy is questionable!
931 ($driver) = $dbh->{proxy_client}->{application} =~ /^DBI:(.+?):/i
932 or die "Can't determine driver name from proxy";
933 }
934
935 my @dbtypes = (ucfirst($driver));
936 if ($driver eq 'ODBC' || $driver eq 'ADO') {
937 # XXX will move these out and make extensible later:
938 my $_dbtype_name_regexp = 'Oracle'; # eg 'Oracle|Foo|Bar'
939 my %_dbtype_name_map = (
940 'Microsoft SQL Server' => 'MSSQL',
941 'SQL Server' => 'Sybase',
942 'Adaptive Server Anywhere' => 'ASAny',
943 'ADABAS D' => 'AdabasD',
944 );
945
946 my $name;
947 $name = $dbh->func(17, 'GetInfo') # SQL_DBMS_NAME
948 if $driver eq 'ODBC';
949 $name = $dbh->{ado_conn}->Properties->Item('DBMS Name')->Value
950 if $driver eq 'ADO';
951 die "Can't determine driver name! ($DBI::errstr)\n"
952 unless $name;
953
954 my $dbtype;
955 if ($_dbtype_name_map{$name}) {
956 $dbtype = $_dbtype_name_map{$name};
957 }
958 else {
959 if ($name =~ /($_dbtype_name_regexp)/) {
960 $dbtype = lc($1);
961 }
962 else { # generic mangling for other names:
963 $dbtype = lc($name);
964 }
965 $dbtype =~ s/\b(\w)/\U$1/g;
966 $dbtype =~ s/\W+/_/g;
967 }
968 # add ODBC 'behind' ADO
969 push @dbtypes, 'ODBC' if $driver eq 'ADO';
970 # add discovered dbtype in front of ADO/ODBC
971 unshift @dbtypes, $dbtype;
972 }
973 @dbtypes = &$DbTypeSubclass($dbh, \@dbtypes)
974 if (ref $DbTypeSubclass eq 'CODE');
975 $dbh->trace_msg(" DbTypeSubclass($DbTypeSubclass)=@dbtypes\n");
976 return @dbtypes;
977}
978
979sub _load_class {
980 my ($load_class, $missing_ok) = @_;
981 DBI->trace_msg(" _load_class($load_class, $missing_ok)\n", 2);
9822423µs226µs
# spent 17µs (8+9) within DBI::BEGIN@982 which was called: # once (8µs+9µs) by DBD::SQLite::BEGIN@5 at line 982
no strict 'refs';
# spent 17µs making 1 call to DBI::BEGIN@982 # spent 9µs making 1 call to strict::unimport
983 return 1 if @{"$load_class\::ISA"}; # already loaded/exists
984 (my $module = $load_class) =~ s!::!/!g;
985 DBI->trace_msg(" _load_class require $module\n", 2);
986 eval { require "$module.pm"; };
987 return 1 unless $@;
988 return 0 if $missing_ok && $@ =~ /^Can't locate \Q$module.pm\E/;
989 die $@;
990}
991
992
993sub init_rootclass { # deprecated
994 return 1;
995}
996
997
9981300ns*internal = \&DBD::Switch::dr::driver;
999
1000sub driver_prefix {
1001 my ($class, $driver) = @_;
1002 return $dbd_class_registry{$driver}->{prefix} if exists $dbd_class_registry{$driver};
1003 return;
1004}
1005
1006sub available_drivers {
1007 my($quiet) = @_;
1008 my(@drivers, $d, $f);
1009 local(*DBI::DIR, $@);
1010 my(%seen_dir, %seen_dbd);
1011 my $haveFileSpec = eval { require File::Spec };
1012 foreach $d (@INC){
1013 chomp($d); # Perl 5 beta 3 bug in #!./perl -Ilib from Test::Harness
1014 my $dbd_dir =
1015 ($haveFileSpec ? File::Spec->catdir($d, 'DBD') : "$d/DBD");
1016 next unless -d $dbd_dir;
1017 next if $seen_dir{$d};
1018 $seen_dir{$d} = 1;
1019 # XXX we have a problem here with case insensitive file systems
1020 # XXX since we can't tell what case must be used when loading.
1021 opendir(DBI::DIR, $dbd_dir) || Carp::carp "opendir $dbd_dir: $!\n";
1022 foreach $f (readdir(DBI::DIR)){
1023 next unless $f =~ s/\.pm$//;
1024 next if $f eq 'NullP';
1025 if ($seen_dbd{$f}){
1026 Carp::carp "DBD::$f in $d is hidden by DBD::$f in $seen_dbd{$f}\n"
1027 unless $quiet;
1028 } else {
1029 push(@drivers, $f);
1030 }
1031 $seen_dbd{$f} = $d;
1032 }
1033 closedir(DBI::DIR);
1034 }
1035
1036 # "return sort @drivers" will not DWIM in scalar context.
1037 return wantarray ? sort @drivers : @drivers;
1038}
1039
1040sub installed_versions {
1041 my ($class, $quiet) = @_;
1042 my %error;
1043 my %version;
1044 for my $driver ($class->available_drivers($quiet)) {
1045 next if $DBI::PurePerl && grep { -d "$_/auto/DBD/$driver" } @INC;
1046 my $drh = eval {
1047 local $SIG{__WARN__} = sub {};
1048 $class->install_driver($driver);
1049 };
1050 ($error{"DBD::$driver"}=$@),next if $@;
105121.57ms225µs
# spent 16µs (8+9) within DBI::BEGIN@1051 which was called: # once (8µs+9µs) by DBD::SQLite::BEGIN@5 at line 1051
no strict 'refs';
# spent 16µs making 1 call to DBI::BEGIN@1051 # spent 9µs making 1 call to strict::unimport
1052 my $vers = ${"DBD::$driver" . '::VERSION'};
1053 $version{"DBD::$driver"} = $vers || '?';
1054 }
1055 if (wantarray) {
1056 return map { m/^DBD::(\w+)/ ? ($1) : () } sort keys %version;
1057 }
1058 $version{"DBI"} = $DBI::VERSION;
1059 $version{"DBI::PurePerl"} = $DBI::PurePerl::VERSION if $DBI::PurePerl;
1060 if (!defined wantarray) { # void context
1061 require Config; # add more detail
1062 $version{OS} = "$^O\t($Config::Config{osvers})";
1063 $version{Perl} = "$]\t($Config::Config{archname})";
1064 $version{$_} = (($error{$_} =~ s/ \(\@INC.*//s),$error{$_})
1065 for keys %error;
1066 printf " %-16s: %s\n",$_,$version{$_}
1067 for reverse sort keys %version;
1068 }
1069 return \%version;
1070}
1071
1072
1073sub data_sources {
1074 my ($class, $driver, @other) = @_;
1075 my $drh = $class->install_driver($driver);
1076 my @ds = $drh->data_sources(@other);
1077 return @ds;
1078}
1079
1080
1081sub neat_list {
1082 my ($listref, $maxlen, $sep) = @_;
1083 $maxlen = 0 unless defined $maxlen; # 0 == use internal default
1084 $sep = ", " unless defined $sep;
1085 join($sep, map { neat($_,$maxlen) } @$listref);
1086}
1087
1088
1089sub dump_results { # also aliased as a method in DBD::_::st
1090 my ($sth, $maxlen, $lsep, $fsep, $fh) = @_;
1091 return 0 unless $sth;
1092 $maxlen ||= 35;
1093 $lsep ||= "\n";
1094 $fh ||= \*STDOUT;
1095 my $rows = 0;
1096 my $ref;
1097 while($ref = $sth->fetch) {
1098 print $fh $lsep if $rows++ and $lsep;
1099 my $str = neat_list($ref,$maxlen,$fsep);
1100 print $fh $str; # done on two lines to avoid 5.003 errors
1101 }
1102 print $fh "\n$rows rows".($DBI::err ? " ($DBI::err: $DBI::errstr)" : "")."\n";
1103 $rows;
1104}
1105
1106
1107sub data_diff {
1108 my ($a, $b, $logical) = @_;
1109
1110 my $diff = data_string_diff($a, $b);
1111 return "" if $logical and !$diff;
1112
1113 my $a_desc = data_string_desc($a);
1114 my $b_desc = data_string_desc($b);
1115 return "" if !$diff and $a_desc eq $b_desc;
1116
1117 $diff ||= "Strings contain the same sequence of characters"
1118 if length($a);
1119 $diff .= "\n" if $diff;
1120 return "a: $a_desc\nb: $b_desc\n$diff";
1121}
1122
1123
1124sub data_string_diff {
1125 # Compares 'logical' characters, not bytes, so a latin1 string and an
1126 # an equivalent Unicode string will compare as equal even though their
1127 # byte encodings are different.
1128 my ($a, $b) = @_;
1129 unless (defined $a and defined $b) { # one undef
1130 return ""
1131 if !defined $a and !defined $b;
1132 return "String a is undef, string b has ".length($b)." characters"
1133 if !defined $a;
1134 return "String b is undef, string a has ".length($a)." characters"
1135 if !defined $b;
1136 }
1137
1138 require utf8;
1139 # hack to cater for perl 5.6
1140 *utf8::is_utf8 = sub { (DBI::neat(shift)=~/^"/) } unless defined &utf8::is_utf8;
1141
1142 my @a_chars = (utf8::is_utf8($a)) ? unpack("U*", $a) : unpack("C*", $a);
1143 my @b_chars = (utf8::is_utf8($b)) ? unpack("U*", $b) : unpack("C*", $b);
1144 my $i = 0;
1145 while (@a_chars && @b_chars) {
1146 ++$i, shift(@a_chars), shift(@b_chars), next
1147 if $a_chars[0] == $b_chars[0];# compare ordinal values
1148 my @desc = map {
1149 $_ > 255 ? # if wide character...
1150 sprintf("\\x{%04X}", $_) : # \x{...}
1151 chr($_) =~ /[[:cntrl:]]/ ? # else if control character ...
1152 sprintf("\\x%02X", $_) : # \x..
1153 chr($_) # else as themselves
1154 } ($a_chars[0], $b_chars[0]);
1155 # highlight probable double-encoding?
1156 foreach my $c ( @desc ) {
1157 next unless $c =~ m/\\x\{08(..)}/;
1158 $c .= "='" .chr(hex($1)) ."'"
1159 }
1160 return sprintf "Strings differ at index $i: a[$i]=$desc[0], b[$i]=$desc[1]";
1161 }
1162 return "String a truncated after $i characters" if @b_chars;
1163 return "String b truncated after $i characters" if @a_chars;
1164 return "";
1165}
1166
1167
1168sub data_string_desc { # describe a data string
1169 my ($a) = @_;
1170 require bytes;
1171 require utf8;
1172
1173 # hacks to cater for perl 5.6
1174 *utf8::is_utf8 = sub { (DBI::neat(shift)=~/^"/) } unless defined &utf8::is_utf8;
1175 *utf8::valid = sub { 1 } unless defined &utf8::valid;
1176
1177 # Give sufficient info to help diagnose at least these kinds of situations:
1178 # - valid UTF8 byte sequence but UTF8 flag not set
1179 # (might be ascii so also need to check for hibit to make it worthwhile)
1180 # - UTF8 flag set but invalid UTF8 byte sequence
1181 # could do better here, but this'll do for now
1182 my $utf8 = sprintf "UTF8 %s%s",
1183 utf8::is_utf8($a) ? "on" : "off",
1184 utf8::valid($a||'') ? "" : " but INVALID encoding";
1185 return "$utf8, undef" unless defined $a;
1186 my $is_ascii = $a =~ m/^[\000-\177]*$/;
1187 return sprintf "%s, %s, %d characters %d bytes",
1188 $utf8, $is_ascii ? "ASCII" : "non-ASCII",
1189 length($a), bytes::length($a);
1190}
1191
1192
1193sub connect_test_perf {
1194 my($class, $dsn,$dbuser,$dbpass, $attr) = @_;
1195 Carp::croak("connect_test_perf needs hash ref as fourth arg") unless ref $attr;
1196 # these are non standard attributes just for this special method
1197 my $loops ||= $attr->{dbi_loops} || 5;
1198 my $par ||= $attr->{dbi_par} || 1; # parallelism
1199 my $verb ||= $attr->{dbi_verb} || 1;
1200 my $meth ||= $attr->{dbi_meth} || 'connect';
1201 print "$dsn: testing $loops sets of $par connections:\n";
1202 require "FileHandle.pm"; # don't let toke.c create empty FileHandle package
1203 local $| = 1;
1204 my $drh = $class->install_driver($dsn) or Carp::croak("Can't install $dsn driver\n");
1205 # test the connection and warm up caches etc
1206 $drh->connect($dsn,$dbuser,$dbpass) or Carp::croak("connect failed: $DBI::errstr");
1207 my $t1 = dbi_time();
1208 my $loop;
1209 for $loop (1..$loops) {
1210 my @cons;
1211 print "Connecting... " if $verb;
1212 for (1..$par) {
1213 print "$_ ";
1214 push @cons, ($drh->connect($dsn,$dbuser,$dbpass)
1215 or Carp::croak("connect failed: $DBI::errstr\n"));
1216 }
1217 print "\nDisconnecting...\n" if $verb;
1218 for (@cons) {
1219 $_->disconnect or warn "disconnect failed: $DBI::errstr"
1220 }
1221 }
1222 my $t2 = dbi_time();
1223 my $td = $t2 - $t1;
1224 printf "$meth %d and disconnect them, %d times: %.4fs / %d = %.4fs\n",
1225 $par, $loops, $td, $loops*$par, $td/($loops*$par);
1226 return $td;
1227}
1228
1229
1230# Help people doing DBI->errstr, might even document it one day
1231# XXX probably best moved to cheaper XS code if this gets documented
1232sub err { $DBI::err }
1233sub errstr { $DBI::errstr }
1234
1235
1236# --- Private Internal Function for Creating New DBI Handles
1237
1238# XXX move to PurePerl?
12391400ns*DBI::dr::TIEHASH = \&DBI::st::TIEHASH;
12401200ns*DBI::db::TIEHASH = \&DBI::st::TIEHASH;
1241
1242
1243# These three special constructors are called by the drivers
1244# The way they are called is likely to change.
1245
12461100nsour $shared_profile;
1247
1248
# spent 42µs (15+27) within DBI::_new_drh which was called: # once (15µs+27µs) by DBD::SQLite::driver at line 64 of DBD/SQLite.pm
sub _new_drh { # called by DBD::<drivername>::driver()
12491500ns my ($class, $initial_attr, $imp_data) = @_;
1250 # Provide default storage for State,Err and Errstr.
1251 # Note that these are shared by all child handles by default! XXX
1252 # State must be undef to get automatic faking in DBI::var::FETCH
12531700ns my ($h_state_store, $h_err_store, $h_errstr_store) = (undef, undef, '');
125414µs my $attr = {
1255 # these attributes get copied down to child handles by default
1256 'State' => \$h_state_store, # Holder for DBI::state
1257 'Err' => \$h_err_store, # Holder for DBI::err
1258 'Errstr' => \$h_errstr_store, # Holder for DBI::errstr
1259 'TraceLevel' => 0,
1260 FetchHashKeyName=> 'NAME',
1261 %$initial_attr,
1262 };
1263131µs127µs my ($h, $i) = _new_handle('DBI::dr', '', $attr, $imp_data, $class);
# spent 27µs making 1 call to DBI::_new_handle
1264
1265 # XXX DBI_PROFILE unless DBI::PurePerl because for some reason
1266 # it kills the t/zz_*_pp.t tests (they silently exit early)
126712µs if (($ENV{DBI_PROFILE} && !$DBI::PurePerl) || $shared_profile) {
1268 # The profile object created here when the first driver is loaded
1269 # is shared by all drivers so we end up with just one set of profile
1270 # data and thus the 'total time in DBI' is really the true total.
1271 if (!$shared_profile) { # first time
1272 $h->{Profile} = $ENV{DBI_PROFILE}; # write string
1273 $shared_profile = $h->{Profile}; # read and record object
1274 }
1275 else {
1276 $h->{Profile} = $shared_profile;
1277 }
1278 }
127913µs return $h unless wantarray;
1280 ($h, $i);
1281}
1282
1283
# spent 19µs (9+10) within DBI::_new_dbh which was called: # once (9µs+10µs) by DBD::SQLite::dr::connect at line 89 of DBD/SQLite.pm
sub _new_dbh { # called by DBD::<drivername>::dr::connect()
12841400ns my ($drh, $attr, $imp_data) = @_;
12851700ns my $imp_class = $drh->{ImplementorClass}
1286 or Carp::croak("DBI _new_dbh: $drh has no ImplementorClass");
12871900ns substr($imp_class,-4,4) = '::db';
128811µs my $app_class = ref $drh;
12891600ns substr($app_class,-4,4) = '::db';
12901800ns $attr->{Err} ||= \my $err;
12911300ns $attr->{Errstr} ||= \my $errstr;
12921300ns $attr->{State} ||= \my $state;
1293115µs110µs _new_handle($app_class, $drh, $attr, $imp_data, $imp_class);
# spent 10µs making 1 call to DBI::_new_handle
1294}
1295
1296
# spent 9.71s (3.60+6.11) within DBI::_new_sth which was called 368127 times, avg 26µs/call: # 368127 times (3.60s+6.11s) by DBD::SQLite::db::prepare at line 198 of DBD/SQLite.pm, avg 26µs/call
sub _new_sth { # called by DBD::<drivername>::db::prepare)
1297368127208ms my ($dbh, $attr, $imp_data) = @_;
1298368127304ms my $imp_class = $dbh->{ImplementorClass}
1299 or Carp::croak("DBI _new_sth: $dbh has no ImplementorClass");
1300368127409ms substr($imp_class,-4,4) = '::st';
1301368127245ms my $app_class = ref $dbh;
1302368127262ms substr($app_class,-4,4) = '::st';
13033681278.83s3681276.11s _new_handle($app_class, $dbh, $attr, $imp_data, $imp_class);
# spent 6.11s making 368127 calls to DBI::_new_handle, avg 17µs/call
1304}
1305
1306
1307# end of DBI package
1308
- -
1311# --------------------------------------------------------------------
1312# === The internal DBI Switch pseudo 'driver' class ===
1313
13141100ns{ package # hide from PAUSE
1315 DBD::Switch::dr;
131612µs163µs DBI->setup_driver('DBD::Switch'); # sets up @ISA
# spent 63µs making 1 call to DBI::setup_driver
1317
13181200ns $DBD::Switch::dr::imp_data_size = 0;
13191100ns $DBD::Switch::dr::imp_data_size = 0; # avoid typo warning
13201300ns my $drh;
1321
1322 sub driver {
1323 return $drh if $drh; # a package global
1324
1325 my $inner;
1326 ($drh, $inner) = DBI::_new_drh('DBD::Switch::dr', {
1327 'Name' => 'Switch',
1328 'Version' => $DBI::VERSION,
1329 'Attribution' => "DBI $DBI::VERSION by Tim Bunce",
1330 });
1331 Carp::croak("DBD::Switch init failed!") unless ($drh && $inner);
1332 return $drh;
1333 }
1334 sub CLONE {
1335 undef $drh;
1336 }
1337
1338 sub FETCH {
1339 my($drh, $key) = @_;
1340 return DBI->trace if $key eq 'DebugDispatch';
1341 return undef if $key eq 'DebugLog'; # not worth fetching, sorry
1342 return $drh->DBD::_::dr::FETCH($key);
1343 undef;
1344 }
1345 sub STORE {
1346 my($drh, $key, $value) = @_;
1347 if ($key eq 'DebugDispatch') {
1348 DBI->trace($value);
1349 } elsif ($key eq 'DebugLog') {
1350 DBI->trace(-1, $value);
1351 } else {
1352 $drh->DBD::_::dr::STORE($key, $value);
1353 }
1354 }
1355}
1356
1357
1358# --------------------------------------------------------------------
1359# === OPTIONAL MINIMAL BASE CLASSES FOR DBI SUBCLASSES ===
1360
1361# We only define default methods for harmless functions.
1362# We don't, for example, define a DBD::_::st::prepare()
1363
13641200ns{ package # hide from PAUSE
1365 DBD::_::common; # ====== Common base class methods ======
13662551µs232µs
# spent 19µs (7+12) within DBD::_::common::BEGIN@1366 which was called: # once (7µs+12µs) by DBD::SQLite::BEGIN@5 at line 1366
use strict;
# spent 19µs making 1 call to DBD::_::common::BEGIN@1366 # spent 12µs making 1 call to strict::import
1367
1368 # methods common to all handle types:
1369
1370 # generic TIEHASH default methods:
1371 sub FIRSTKEY { }
1372 sub NEXTKEY { }
1373 sub EXISTS { defined($_[0]->FETCH($_[1])) } # XXX undef?
1374 sub CLEAR { Carp::carp "Can't CLEAR $_[0] (DBI)" }
1375
1376 sub FETCH_many { # XXX should move to C one day
1377 my $h = shift;
1378 # scalar is needed to workaround drivers that return an empty list
1379 # for some attributes
1380 return map { scalar $h->FETCH($_) } @_;
1381 }
1382
13831700ns *dump_handle = \&DBI::dump_handle;
1384
1385
# spent 396µs (240+156) within DBD::_::common::install_method which was called 23 times, avg 17µs/call: # once (27µs+15µs) by DBD::SQLite::driver at line 37 of DBD/SQLite.pm # once (10µs+13µs) by DBD::SQLite::driver at line 39 of DBD/SQLite.pm # once (10µs+9µs) by DBD::SQLite::driver at line 54 of DBD/SQLite.pm # once (11µs+7µs) by DBD::SQLite::driver at line 57 of DBD/SQLite.pm # once (10µs+8µs) by DBD::SQLite::driver at line 58 of DBD/SQLite.pm # once (11µs+6µs) by DBD::SQLite::driver at line 38 of DBD/SQLite.pm # once (10µs+7µs) by DBD::SQLite::driver at line 56 of DBD/SQLite.pm # once (9µs+8µs) by DBD::SQLite::driver at line 46 of DBD/SQLite.pm # once (9µs+8µs) by DBD::SQLite::driver at line 50 of DBD/SQLite.pm # once (10µs+6µs) by DBD::SQLite::driver at line 53 of DBD/SQLite.pm # once (10µs+6µs) by DBD::SQLite::driver at line 40 of DBD/SQLite.pm # once (10µs+6µs) by DBD::SQLite::driver at line 52 of DBD/SQLite.pm # once (9µs+6µs) by DBD::SQLite::driver at line 41 of DBD/SQLite.pm # once (9µs+6µs) by DBD::SQLite::driver at line 42 of DBD/SQLite.pm # once (10µs+5µs) by DBD::SQLite::driver at line 59 of DBD/SQLite.pm # once (10µs+6µs) by DBD::SQLite::driver at line 55 of DBD/SQLite.pm # once (10µs+6µs) by DBD::SQLite::driver at line 47 of DBD/SQLite.pm # once (10µs+5µs) by DBD::SQLite::driver at line 44 of DBD/SQLite.pm # once (10µs+5µs) by DBD::SQLite::driver at line 45 of DBD/SQLite.pm # once (9µs+5µs) by DBD::SQLite::driver at line 51 of DBD/SQLite.pm # once (9µs+5µs) by DBD::SQLite::driver at line 43 of DBD/SQLite.pm # once (9µs+5µs) by DBD::SQLite::driver at line 49 of DBD/SQLite.pm # once (9µs+5µs) by DBD::SQLite::driver at line 48 of DBD/SQLite.pm
sub install_method {
1386 # special class method called directly by apps and/or drivers
1387 # to install new methods into the DBI dispatcher
1388 # DBD::Foo::db->install_method("foo_mumble", { usage => [...], options => '...' });
13892310µs my ($class, $method, $attr) = @_;
13902362µs2329µs Carp::croak("Class '$class' must begin with DBD:: and end with ::db or ::st")
# spent 29µs making 23 calls to DBD::_::common::CORE:match, avg 1µs/call
1391 unless $class =~ /^DBD::(\w+)::(dr|db|st)$/;
13922317µs my ($driver, $subtype) = ($1, $2);
13932347µs2320µs Carp::croak("invalid method name '$method'")
# spent 20µs making 23 calls to DBD::_::common::CORE:match, avg 848ns/call
1394 unless $method =~ m/^([a-z]+_)\w+$/;
1395238µs my $prefix = $1;
1396237µs my $reg_info = $dbd_prefix_registry->{$prefix};
1397232µs Carp::carp("method name prefix '$prefix' is not associated with a registered driver") unless $reg_info;
1398
13992311µs my $full_method = "DBI::${subtype}::$method";
14002315µs $DBI::installed_methods{$full_method} = $attr;
1401
14022319µs my (undef, $filename, $line) = caller;
1403 # XXX reformat $attr as needed for _install_method
14042321µs my %attr = %{$attr||{}}; # copy so we can edit
140523215µs23107µs DBI->_install_method("DBI::${subtype}::$method", "$filename at line $line", \%attr);
# spent 107µs making 23 calls to DBI::_install_method, avg 5µs/call
1406 }
1407
1408 sub parse_trace_flags {
1409 my ($h, $spec) = @_;
1410 my $level = 0;
1411 my $flags = 0;
1412 my @unknown;
1413 for my $word (split /\s*[|&,]\s*/, $spec) {
1414 if (DBI::looks_like_number($word) && $word <= 0xF && $word >= 0) {
1415 $level = $word;
1416 } elsif ($word eq 'ALL') {
1417 $flags = 0x7FFFFFFF; # XXX last bit causes negative headaches
1418 last;
1419 } elsif (my $flag = $h->parse_trace_flag($word)) {
1420 $flags |= $flag;
1421 }
1422 else {
1423 push @unknown, $word;
1424 }
1425 }
1426 if (@unknown && (ref $h ? $h->FETCH('Warn') : 1)) {
1427 Carp::carp("$h->parse_trace_flags($spec) ignored unknown trace flags: ".
1428 join(" ", map { DBI::neat($_) } @unknown));
1429 }
1430 $flags |= $level;
1431 return $flags;
1432 }
1433
1434 sub parse_trace_flag {
1435 my ($h, $name) = @_;
1436 # 0xddDDDDrL (driver, DBI, reserved, Level)
1437 return 0x00000100 if $name eq 'SQL';
1438 return 0x00000200 if $name eq 'CON';
1439 return 0x00000400 if $name eq 'ENC';
1440 return 0x00000800 if $name eq 'DBD';
1441 return 0x00001000 if $name eq 'TXN';
1442 return;
1443 }
1444
1445 sub private_attribute_info {
1446 return undef;
1447 }
1448
1449 sub visit_child_handles {
1450 my ($h, $code, $info) = @_;
1451 $info = {} if not defined $info;
1452 for my $ch (@{ $h->{ChildHandles} || []}) {
1453 next unless $ch;
1454 my $child_info = $code->($ch, $info)
1455 or next;
1456 $ch->visit_child_handles($code, $child_info);
1457 }
1458 return $info;
1459 }
1460}
1461
1462
146311µs{ package # hide from PAUSE
1464 DBD::_::dr; # ====== DRIVER ======
146516µs @DBD::_::dr::ISA = qw(DBD::_::common);
14662308µs226µs
# spent 16µs (6+10) within DBD::_::dr::BEGIN@1466 which was called: # once (6µs+10µs) by DBD::SQLite::BEGIN@5 at line 1466
use strict;
# spent 16µs making 1 call to DBD::_::dr::BEGIN@1466 # spent 10µs making 1 call to strict::import
1467
1468 sub default_user {
1469 my ($drh, $user, $pass, $attr) = @_;
1470 $user = $ENV{DBI_USER} unless defined $user;
1471 $pass = $ENV{DBI_PASS} unless defined $pass;
1472 return ($user, $pass);
1473 }
1474
1475 sub connect { # normally overridden, but a handy default
1476 my ($drh, $dsn, $user, $auth) = @_;
1477 my ($this) = DBI::_new_dbh($drh, {
1478 'Name' => $dsn,
1479 });
1480 # XXX debatable as there's no "server side" here
1481 # (and now many uses would trigger warnings on DESTROY)
1482 # $this->STORE(Active => 1);
1483 # so drivers should set it in their own connect
1484 $this;
1485 }
1486
1487
1488 sub connect_cached {
1489 my $drh = shift;
1490 my ($dsn, $user, $auth, $attr) = @_;
1491
1492 my $cache = $drh->{CachedKids} ||= {};
1493 my $key = do { local $^W;
1494 join "!\001", $dsn, $user, $auth, DBI::_concat_hash_sorted($attr, "=\001", ",\001", 0, 0)
1495 };
1496 my $dbh = $cache->{$key};
1497 $drh->trace_msg(sprintf(" connect_cached: key '$key', cached dbh $dbh\n", DBI::neat($key), DBI::neat($dbh)))
1498 if (($DBI::dbi_debug & 0xF) >= 4);
1499
1500 my $cb = $attr->{Callbacks}; # take care not to autovivify
1501 if ($dbh && $dbh->FETCH('Active') && eval { $dbh->ping }) {
1502 # If the caller has provided a callback then call it
1503 if ($cb and $cb = $cb->{"connect_cached.reused"}) {
1504 local $_ = "connect_cached.reused";
1505 $cb->($dbh, $dsn, $user, $auth, $attr);
1506 }
1507 return $dbh;
1508 }
1509
1510 # If the caller has provided a callback then call it
1511 if ($cb and (my $new_cb = $cb->{"connect_cached.new"})) {
1512 local $_ = "connect_cached.new";
1513 $new_cb->($dbh, $dsn, $user, $auth, $attr); # $dbh is dead or undef
1514 }
1515
1516 $dbh = $drh->connect(@_);
1517 $cache->{$key} = $dbh; # replace prev entry, even if connect failed
1518 if ($cb and (my $conn_cb = $cb->{"connect_cached.connected"})) {
1519 local $_ = "connect_cached.connected";
1520 $conn_cb->($dbh, $dsn, $user, $auth, $attr);
1521 }
1522 return $dbh;
1523 }
1524
1525}
1526
1527
15281800ns{ package # hide from PAUSE
1529 DBD::_::db; # ====== DATABASE ======
153015µs @DBD::_::db::ISA = qw(DBD::_::common);
153121.44ms226µs
# spent 17µs (8+9) within DBD::_::db::BEGIN@1531 which was called: # once (8µs+9µs) by DBD::SQLite::BEGIN@5 at line 1531
use strict;
# spent 17µs making 1 call to DBD::_::db::BEGIN@1531 # spent 9µs making 1 call to strict::import
1532
1533 sub clone {
1534 my ($old_dbh, $attr) = @_;
1535
1536 my $closure = $old_dbh->{dbi_connect_closure}
1537 or return $old_dbh->set_err($DBI::stderr, "Can't clone handle");
1538
1539 unless ($attr) { # XXX deprecated, caller should always pass a hash ref
1540 # copy attributes visible in the attribute cache
1541 keys %$old_dbh; # reset iterator
1542 while ( my ($k, $v) = each %$old_dbh ) {
1543 # ignore non-code refs, i.e., caches, handles, Err etc
1544 next if ref $v && ref $v ne 'CODE'; # HandleError etc
1545 $attr->{$k} = $v;
1546 }
1547 # explicitly set attributes which are unlikely to be in the
1548 # attribute cache, i.e., boolean's and some others
1549 $attr->{$_} = $old_dbh->FETCH($_) for (qw(
1550 AutoCommit ChopBlanks InactiveDestroy AutoInactiveDestroy
1551 LongTruncOk PrintError PrintWarn Profile RaiseError
1552 ShowErrorStatement TaintIn TaintOut
1553 ));
1554 }
1555
1556 # use Data::Dumper; warn Dumper([$old_dbh, $attr]);
1557 my $new_dbh = &$closure($old_dbh, $attr);
1558 unless ($new_dbh) {
1559 # need to copy err/errstr from driver back into $old_dbh
1560 my $drh = $old_dbh->{Driver};
1561 return $old_dbh->set_err($drh->err, $drh->errstr, $drh->state);
1562 }
1563 $new_dbh->{dbi_connect_closure} = $closure;
1564 return $new_dbh;
1565 }
1566
1567 sub quote_identifier {
1568 my ($dbh, @id) = @_;
1569 my $attr = (@id > 3 && ref($id[-1])) ? pop @id : undef;
1570
1571 my $info = $dbh->{dbi_quote_identifier_cache} ||= [
1572 $dbh->get_info(29) || '"', # SQL_IDENTIFIER_QUOTE_CHAR
1573 $dbh->get_info(41) || '.', # SQL_CATALOG_NAME_SEPARATOR
1574 $dbh->get_info(114) || 1, # SQL_CATALOG_LOCATION
1575 ];
1576
1577 my $quote = $info->[0];
1578 foreach (@id) { # quote the elements
1579 next unless defined;
1580 s/$quote/$quote$quote/g; # escape embedded quotes
1581 $_ = qq{$quote$_$quote};
1582 }
1583
1584 # strip out catalog if present for special handling
1585 my $catalog = (@id >= 3) ? shift @id : undef;
1586
1587 # join the dots, ignoring any null/undef elements (ie schema)
1588 my $quoted_id = join '.', grep { defined } @id;
1589
1590 if ($catalog) { # add catalog correctly
1591 $quoted_id = ($info->[2] == 2) # SQL_CL_END
1592 ? $quoted_id . $info->[1] . $catalog
1593 : $catalog . $info->[1] . $quoted_id;
1594 }
1595 return $quoted_id;
1596 }
1597
1598 sub quote {
1599 my ($dbh, $str, $data_type) = @_;
1600
1601 return "NULL" unless defined $str;
1602 unless ($data_type) {
1603 $str =~ s/'/''/g; # ISO SQL2
1604 return "'$str'";
1605 }
1606
1607 my $dbi_literal_quote_cache = $dbh->{'dbi_literal_quote_cache'} ||= [ {} , {} ];
1608 my ($prefixes, $suffixes) = @$dbi_literal_quote_cache;
1609
1610 my $lp = $prefixes->{$data_type};
1611 my $ls = $suffixes->{$data_type};
1612
1613 if ( ! defined $lp || ! defined $ls ) {
1614 my $ti = $dbh->type_info($data_type);
1615 $lp = $prefixes->{$data_type} = $ti ? $ti->{LITERAL_PREFIX} || "" : "'";
1616 $ls = $suffixes->{$data_type} = $ti ? $ti->{LITERAL_SUFFIX} || "" : "'";
1617 }
1618 return $str unless $lp || $ls; # no quoting required
1619
1620 # XXX don't know what the standard says about escaping
1621 # in the 'general case' (where $lp != "'").
1622 # So we just do this and hope:
1623 $str =~ s/$lp/$lp$lp/g
1624 if $lp && $lp eq $ls && ($lp eq "'" || $lp eq '"');
1625 return "$lp$str$ls";
1626 }
1627
1628 sub rows { -1 } # here so $DBI::rows 'works' after using $dbh
1629
1630 sub do {
1631 my($dbh, $statement, $attr, @params) = @_;
1632 my $sth = $dbh->prepare($statement, $attr) or return undef;
1633 $sth->execute(@params) or return undef;
1634 my $rows = $sth->rows;
1635 ($rows == 0) ? "0E0" : $rows;
1636 }
1637
1638 sub _do_selectrow {
1639 my ($method, $dbh, $stmt, $attr, @bind) = @_;
1640 my $sth = ((ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr))
1641 or return undef;
1642 $sth->execute(@bind)
1643 or return undef;
1644 my $row = $sth->$method()
1645 and $sth->finish;
1646 return $row;
1647 }
1648
1649 sub selectrow_hashref { return _do_selectrow('fetchrow_hashref', @_); }
1650
1651 # XXX selectrow_array/ref also have C implementations in Driver.xst
1652 sub selectrow_arrayref { return _do_selectrow('fetchrow_arrayref', @_); }
1653 sub selectrow_array {
1654 my $row = _do_selectrow('fetchrow_arrayref', @_) or return;
1655 return $row->[0] unless wantarray;
1656 return @$row;
1657 }
1658
1659 # XXX selectall_arrayref also has C implementation in Driver.xst
1660 # which fallsback to this if a slice is given
1661 sub selectall_arrayref {
1662 my ($dbh, $stmt, $attr, @bind) = @_;
1663 my $sth = (ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr)
1664 or return;
1665 $sth->execute(@bind) || return;
1666 my $slice = $attr->{Slice}; # typically undef, else hash or array ref
1667 if (!$slice and $slice=$attr->{Columns}) {
1668 if (ref $slice eq 'ARRAY') { # map col idx to perl array idx
1669 $slice = [ @{$attr->{Columns}} ]; # take a copy
1670 for (@$slice) { $_-- }
1671 }
1672 }
1673 my $rows = $sth->fetchall_arrayref($slice, my $MaxRows = $attr->{MaxRows});
1674 $sth->finish if defined $MaxRows;
1675 return $rows;
1676 }
1677
1678 sub selectall_hashref {
1679 my ($dbh, $stmt, $key_field, $attr, @bind) = @_;
1680 my $sth = (ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr);
1681 return unless $sth;
1682 $sth->execute(@bind) || return;
1683 return $sth->fetchall_hashref($key_field);
1684 }
1685
1686 sub selectcol_arrayref {
1687 my ($dbh, $stmt, $attr, @bind) = @_;
1688 my $sth = (ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr);
1689 return unless $sth;
1690 $sth->execute(@bind) || return;
1691 my @columns = ($attr->{Columns}) ? @{$attr->{Columns}} : (1);
1692 my @values = (undef) x @columns;
1693 my $idx = 0;
1694 for (@columns) {
1695 $sth->bind_col($_, \$values[$idx++]) || return;
1696 }
1697 my @col;
1698 if (my $max = $attr->{MaxRows}) {
1699 push @col, @values while 0 < $max-- && $sth->fetch;
1700 }
1701 else {
1702 push @col, @values while $sth->fetch;
1703 }
1704 return \@col;
1705 }
1706
1707 sub prepare_cached {
1708 my ($dbh, $statement, $attr, $if_active) = @_;
1709
1710 # Needs support at dbh level to clear cache before complaining about
1711 # active children. The XS template code does this. Drivers not using
1712 # the template must handle clearing the cache themselves.
1713 my $cache = $dbh->{CachedKids} ||= {};
1714 my $key = do { local $^W;
1715 join "!\001", $statement, DBI::_concat_hash_sorted($attr, "=\001", ",\001", 0, 0)
1716 };
1717 my $sth = $cache->{$key};
1718
1719 if ($sth) {
1720 return $sth unless $sth->FETCH('Active');
1721 Carp::carp("prepare_cached($statement) statement handle $sth still Active")
1722 unless ($if_active ||= 0);
1723 $sth->finish if $if_active <= 1;
1724 return $sth if $if_active <= 2;
1725 }
1726
1727 $sth = $dbh->prepare($statement, $attr);
1728 $cache->{$key} = $sth if $sth;
1729
1730 return $sth;
1731 }
1732
1733 sub ping {
1734 my $dbh = shift;
1735 # "0 but true" is a special kind of true 0 that is used here so
1736 # applications can check if the ping was a real ping or not
1737 ($dbh->FETCH('Active')) ? "0 but true" : 0;
1738 }
1739
1740 sub begin_work {
1741 my $dbh = shift;
1742 return $dbh->set_err($DBI::stderr, "Already in a transaction")
1743 unless $dbh->FETCH('AutoCommit');
1744 $dbh->STORE('AutoCommit', 0); # will croak if driver doesn't support it
1745 $dbh->STORE('BegunWork', 1); # trigger post commit/rollback action
1746 return 1;
1747 }
1748
1749 sub primary_key {
1750 my ($dbh, @args) = @_;
1751 my $sth = $dbh->primary_key_info(@args) or return;
1752 my ($row, @col);
1753 push @col, $row->[3] while ($row = $sth->fetch);
1754 Carp::croak("primary_key method not called in list context")
1755 unless wantarray; # leave us some elbow room
1756 return @col;
1757 }
1758
1759 sub tables {
1760 my ($dbh, @args) = @_;
1761 my $sth = $dbh->table_info(@args[0,1,2,3,4]) or return;
1762 my $tables = $sth->fetchall_arrayref or return;
1763 my @tables;
1764 if ($dbh->get_info(29)) { # SQL_IDENTIFIER_QUOTE_CHAR
1765 @tables = map { $dbh->quote_identifier( @{$_}[0,1,2] ) } @$tables;
1766 }
1767 else { # temporary old style hack (yeach)
1768 @tables = map {
1769 my $name = $_->[2];
1770 if ($_->[1]) {
1771 my $schema = $_->[1];
1772 # a sad hack (mostly for Informix I recall)
1773 my $quote = ($schema eq uc($schema)) ? '' : '"';
1774 $name = "$quote$schema$quote.$name"
1775 }
1776 $name;
1777 } @$tables;
1778 }
1779 return @tables;
1780 }
1781
1782 sub type_info { # this should be sufficient for all drivers
1783 my ($dbh, $data_type) = @_;
1784 my $idx_hash;
1785 my $tia = $dbh->{dbi_type_info_row_cache};
1786 if ($tia) {
1787 $idx_hash = $dbh->{dbi_type_info_idx_cache};
1788 }
1789 else {
1790 my $temp = $dbh->type_info_all;
1791 return unless $temp && @$temp;
1792 # we cache here because type_info_all may be expensive to call
1793 # (and we take a copy so the following shift can't corrupt
1794 # the data that may be returned by future calls to type_info_all)
1795 $tia = $dbh->{dbi_type_info_row_cache} = [ @$temp ];
1796 $idx_hash = $dbh->{dbi_type_info_idx_cache} = shift @$tia;
1797 }
1798
1799 my $dt_idx = $idx_hash->{DATA_TYPE} || $idx_hash->{data_type};
1800 Carp::croak("type_info_all returned non-standard DATA_TYPE index value ($dt_idx != 1)")
1801 if $dt_idx && $dt_idx != 1;
1802
1803 # --- simple DATA_TYPE match filter
1804 my @ti;
1805 my @data_type_list = (ref $data_type) ? @$data_type : ($data_type);
1806 foreach $data_type (@data_type_list) {
1807 if (defined($data_type) && $data_type != DBI::SQL_ALL_TYPES()) {
1808 push @ti, grep { $_->[$dt_idx] == $data_type } @$tia;
1809 }
1810 else { # SQL_ALL_TYPES
1811 push @ti, @$tia;
1812 }
1813 last if @ti; # found at least one match
1814 }
1815
1816 # --- format results into list of hash refs
1817 my $idx_fields = keys %$idx_hash;
1818 my @idx_names = map { uc($_) } keys %$idx_hash;
1819 my @idx_values = values %$idx_hash;
1820 Carp::croak "type_info_all result has $idx_fields keys but ".(@{$ti[0]})." fields"
1821 if @ti && @{$ti[0]} != $idx_fields;
1822 my @out = map {
1823 my %h; @h{@idx_names} = @{$_}[ @idx_values ]; \%h;
1824 } @ti;
1825 return $out[0] unless wantarray;
1826 return @out;
1827 }
1828
1829 sub data_sources {
1830 my ($dbh, @other) = @_;
1831 my $drh = $dbh->{Driver}; # XXX proxy issues?
1832 return $drh->data_sources(@other);
1833 }
1834
1835}
1836
1837
18381300ns{ package # hide from PAUSE
1839 DBD::_::st; # ====== STATEMENT ======
184015µs @DBD::_::st::ISA = qw(DBD::_::common);
184121.46ms271µs
# spent 39µs (7+32) within DBD::_::st::BEGIN@1841 which was called: # once (7µs+32µs) by DBD::SQLite::BEGIN@5 at line 1841
use strict;
# spent 39µs making 1 call to DBD::_::st::BEGIN@1841 # spent 32µs making 1 call to strict::import
1842
1843 sub bind_param { Carp::croak("Can't bind_param, not implement by driver") }
1844
1845#
1846# ********************************************************
1847#
1848# BEGIN ARRAY BINDING
1849#
1850# Array binding support for drivers which don't support
1851# array binding, but have sufficient interfaces to fake it.
1852# NOTE: mixing scalars and arrayrefs requires using bind_param_array
1853# for *all* params...unless we modify bind_param for the default
1854# case...
1855#
1856# 2002-Apr-10 D. Arnold
1857
1858 sub bind_param_array {
1859 my $sth = shift;
1860 my ($p_id, $value_array, $attr) = @_;
1861
1862 return $sth->set_err($DBI::stderr, "Value for parameter $p_id must be a scalar or an arrayref, not a ".ref($value_array))
1863 if defined $value_array and ref $value_array and ref $value_array ne 'ARRAY';
1864
1865 return $sth->set_err($DBI::stderr, "Can't use named placeholder '$p_id' for non-driver supported bind_param_array")
1866 unless DBI::looks_like_number($p_id); # because we rely on execute(@ary) here
1867
1868 return $sth->set_err($DBI::stderr, "Placeholder '$p_id' is out of range")
1869 if $p_id <= 0; # can't easily/reliably test for too big
1870
1871 # get/create arrayref to hold params
1872 my $hash_of_arrays = $sth->{ParamArrays} ||= { };
1873
1874 # If the bind has attribs then we rely on the driver conforming to
1875 # the DBI spec in that a single bind_param() call with those attribs
1876 # makes them 'sticky' and apply to all later execute(@values) calls.
1877 # Since we only call bind_param() if we're given attribs then
1878 # applications using drivers that don't support bind_param can still
1879 # use bind_param_array() so long as they don't pass any attribs.
1880
1881 $$hash_of_arrays{$p_id} = $value_array;
1882 return $sth->bind_param($p_id, undef, $attr)
1883 if $attr;
1884 1;
1885 }
1886
1887 sub bind_param_inout_array {
1888 my $sth = shift;
1889 # XXX not supported so we just call bind_param_array instead
1890 # and then return an error
1891 my ($p_num, $value_array, $attr) = @_;
1892 $sth->bind_param_array($p_num, $value_array, $attr);
1893 return $sth->set_err($DBI::stderr, "bind_param_inout_array not supported");
1894 }
1895
1896
# spent 4.09s (3.21+880ms) within DBD::_::st::bind_columns which was called 187055 times, avg 22µs/call: # 187055 times (3.21s+880ms) by DBI::st::bind_columns at line 2074, avg 22µs/call
sub bind_columns {
189718705596.6ms my $sth = shift;
18981870551.00s187055224ms my $fields = $sth->FETCH('NUM_OF_FIELDS') || 0;
# spent 224ms making 187055 calls to DBI::common::FETCH, avg 1µs/call
189918705578.5ms if ($fields <= 0 && !$sth->{Active}) {
1900 return $sth->set_err($DBI::stderr, "Statement has no result columns to bind"
1901 ." (perhaps you need to successfully call execute first, or again)");
1902 }
1903 # Backwards compatibility for old-style call with attribute hash
1904 # ref as first arg. Skip arg if undef or a hash ref.
190518705529.5ms my $attr;
1906187055203ms $attr = shift if !defined $_[0] or ref($_[0]) eq 'HASH';
1907
190818705543.8ms my $idx = 0;
19091870552.23s374110656ms $sth->bind_col(++$idx, shift, $attr) or return
# spent 656ms making 374110 calls to DBI::st::bind_col, avg 2µs/call
1910 while (@_ and $idx < $fields);
1911
1912187055111ms return $sth->set_err($DBI::stderr, "bind_columns called with ".($idx+@_)." values but $fields are needed")
1913 if @_ or $idx != $fields;
1914
1915187055720ms return 1;
1916 }
1917
1918 sub execute_array {
1919 my $sth = shift;
1920 my ($attr, @array_of_arrays) = @_;
1921 my $NUM_OF_PARAMS = $sth->FETCH('NUM_OF_PARAMS'); # may be undef at this point
1922
1923 # get tuple status array or hash attribute
1924 my $tuple_sts = $attr->{ArrayTupleStatus};
1925 return $sth->set_err($DBI::stderr, "ArrayTupleStatus attribute must be an arrayref")
1926 if $tuple_sts and ref $tuple_sts ne 'ARRAY';
1927
1928 # bind all supplied arrays
1929 if (@array_of_arrays) {
1930 $sth->{ParamArrays} = { }; # clear out old params
1931 return $sth->set_err($DBI::stderr,
1932 @array_of_arrays." bind values supplied but $NUM_OF_PARAMS expected")
1933 if defined ($NUM_OF_PARAMS) && @array_of_arrays != $NUM_OF_PARAMS;
1934 $sth->bind_param_array($_, $array_of_arrays[$_-1]) or return
1935 foreach (1..@array_of_arrays);
1936 }
1937
1938 my $fetch_tuple_sub;
1939
1940 if ($fetch_tuple_sub = $attr->{ArrayTupleFetch}) { # fetch on demand
1941
1942 return $sth->set_err($DBI::stderr,
1943 "Can't use both ArrayTupleFetch and explicit bind values")
1944 if @array_of_arrays; # previous bind_param_array calls will simply be ignored
1945
1946 if (UNIVERSAL::isa($fetch_tuple_sub,'DBI::st')) {
1947 my $fetch_sth = $fetch_tuple_sub;
1948 return $sth->set_err($DBI::stderr,
1949 "ArrayTupleFetch sth is not Active, need to execute() it first")
1950 unless $fetch_sth->{Active};
1951 # check column count match to give more friendly message
1952 my $NUM_OF_FIELDS = $fetch_sth->{NUM_OF_FIELDS};
1953 return $sth->set_err($DBI::stderr,
1954 "$NUM_OF_FIELDS columns from ArrayTupleFetch sth but $NUM_OF_PARAMS expected")
1955 if defined($NUM_OF_FIELDS) && defined($NUM_OF_PARAMS)
1956 && $NUM_OF_FIELDS != $NUM_OF_PARAMS;
1957 $fetch_tuple_sub = sub { $fetch_sth->fetchrow_arrayref };
1958 }
1959 elsif (!UNIVERSAL::isa($fetch_tuple_sub,'CODE')) {
1960 return $sth->set_err($DBI::stderr, "ArrayTupleFetch '$fetch_tuple_sub' is not a code ref or statement handle");
1961 }
1962
1963 }
1964 else {
1965 my $NUM_OF_PARAMS_given = keys %{ $sth->{ParamArrays} || {} };
1966 return $sth->set_err($DBI::stderr,
1967 "$NUM_OF_PARAMS_given bind values supplied but $NUM_OF_PARAMS expected")
1968 if defined($NUM_OF_PARAMS) && $NUM_OF_PARAMS != $NUM_OF_PARAMS_given;
1969
1970 # get the length of a bound array
1971 my $maxlen;
1972 my %hash_of_arrays = %{$sth->{ParamArrays}};
1973 foreach (keys(%hash_of_arrays)) {
1974 my $ary = $hash_of_arrays{$_};
1975 next unless ref $ary eq 'ARRAY';
1976 $maxlen = @$ary if !$maxlen || @$ary > $maxlen;
1977 }
1978 # if there are no arrays then execute scalars once
1979 $maxlen = 1 unless defined $maxlen;
1980 my @bind_ids = 1..keys(%hash_of_arrays);
1981
1982 my $tuple_idx = 0;
1983 $fetch_tuple_sub = sub {
1984 return if $tuple_idx >= $maxlen;
1985 my @tuple = map {
1986 my $a = $hash_of_arrays{$_};
1987 ref($a) ? $a->[$tuple_idx] : $a
1988 } @bind_ids;
1989 ++$tuple_idx;
1990 return \@tuple;
1991 };
1992 }
1993 # pass thru the callers scalar or list context
1994 return $sth->execute_for_fetch($fetch_tuple_sub, $tuple_sts);
1995 }
1996
1997 sub execute_for_fetch {
1998 my ($sth, $fetch_tuple_sub, $tuple_status) = @_;
1999 # start with empty status array
2000 ($tuple_status) ? @$tuple_status = () : $tuple_status = [];
2001
2002 my $rc_total = 0;
2003 my $err_count;
2004 while ( my $tuple = &$fetch_tuple_sub() ) {
2005 if ( my $rc = $sth->execute(@$tuple) ) {
2006 push @$tuple_status, $rc;
2007 $rc_total = ($rc >= 0 && $rc_total >= 0) ? $rc_total + $rc : -1;
2008 }
2009 else {
2010 $err_count++;
2011 push @$tuple_status, [ $sth->err, $sth->errstr, $sth->state ];
2012 # XXX drivers implementing execute_for_fetch could opt to "last;" here
2013 # if they know the error code means no further executes will work.
2014 }
2015 }
2016 my $tuples = @$tuple_status;
2017 return $sth->set_err($DBI::stderr, "executing $tuples generated $err_count errors")
2018 if $err_count;
2019 $tuples ||= "0E0";
2020 return $tuples unless wantarray;
2021 return ($tuples, $rc_total);
2022 }
2023
2024
2025
# spent 12.4s (5.32+7.10) within DBD::_::st::fetchall_arrayref which was called 187055 times, avg 66µs/call: # 187055 times (5.32s+7.10s) by DBI::st::fetchall_arrayref at line 739 of lib/Test/PONAPI/Repository/MockDB.pm, avg 66µs/call
sub fetchall_arrayref { # ALSO IN Driver.xst
2026187055120ms my ($sth, $slice, $max_rows) = @_;
2027
2028 # when batch fetching with $max_rows were very likely to try to
2029 # fetch the 'next batch' after the previous batch returned
2030 # <=$max_rows. So don't treat that as an error.
203118705554.9ms return undef if $max_rows and not $sth->FETCH('Active');
2032
2033187055125ms my $mode = ref($slice) || 'ARRAY';
203418705539.9ms my @rows;
2035
2036187055117ms if ($mode eq 'ARRAY') {
2037 my $row;
2038 # we copy the array here because fetch (currently) always
2039 # returns the same array ref. XXX
2040 if ($slice && @$slice) {
2041 $max_rows = -1 unless defined $max_rows;
2042 push @rows, [ @{$row}[ @$slice] ]
2043 while($max_rows-- and $row = $sth->fetch);
2044 }
2045 elsif (defined $max_rows) {
2046 push @rows, [ @$row ]
2047 while($max_rows-- and $row = $sth->fetch);
2048 }
2049 else {
2050 push @rows, [ @$row ] while($row = $sth->fetch);
2051 }
2052 return \@rows
2053 }
2054
205518705556.0ms my %row;
2056187055306ms if ($mode eq 'REF' && ref($$slice) eq 'HASH') { # \{ $idx => $name }
2057 keys %$$slice; # reset the iterator
2058 while ( my ($idx, $name) = each %$$slice ) {
2059 $sth->bind_col($idx+1, \$row{$name});
2060 }
2061 }
2062 elsif ($mode eq 'HASH') {
2063187055203ms if (keys %$slice) {
2064 keys %$slice; # reset the iterator
2065 my $name2idx = $sth->FETCH('NAME_lc_hash');
2066 while ( my ($name, $unused) = each %$slice ) {
2067 my $idx = $name2idx->{lc $name};
2068 return $sth->set_err($DBI::stderr, "Invalid column name '$name' for slice")
2069 if not defined $idx;
2070 $sth->bind_col($idx+1, \$row{$name});
2071 }
2072 }
2073 else {
20741870553.31s7482209.83s $sth->bind_columns( \( @row{ @{$sth->FETCH($sth->FETCH('FetchHashKeyName')) } } ) );
# spent 5.00s making 187055 calls to DBI::st::bind_columns, avg 27µs/call # spent 4.09s making 187055 calls to DBD::_::st::bind_columns, avg 22µs/call # spent 745ms making 374110 calls to DBI::common::FETCH, avg 2µs/call
2075 }
2076 }
2077 else {
2078 return $sth->set_err($DBI::stderr, "fetchall_arrayref($mode) invalid");
2079 }
2080
20811870553.10s3599381.35s if (not defined $max_rows) {
# spent 1.35s making 359938 calls to DBI::st::fetch, avg 4µs/call
2082 push @rows, { %row } while ($sth->fetch); # full speed ahead!
2083 }
2084 else {
2085 push @rows, { %row } while ($max_rows-- and $sth->fetch);
2086 }
2087
2088187055849ms return \@rows;
2089 }
2090
2091 sub fetchall_hashref {
2092 my ($sth, $key_field) = @_;
2093
2094 my $hash_key_name = $sth->{FetchHashKeyName} || 'NAME';
2095 my $names_hash = $sth->FETCH("${hash_key_name}_hash");
2096 my @key_fields = (ref $key_field) ? @$key_field : ($key_field);
2097 my @key_indexes;
2098 my $num_of_fields = $sth->FETCH('NUM_OF_FIELDS');
2099 foreach (@key_fields) {
2100 my $index = $names_hash->{$_}; # perl index not column
2101 $index = $_ - 1 if !defined $index && DBI::looks_like_number($_) && $_>=1 && $_ <= $num_of_fields;
2102 return $sth->set_err($DBI::stderr, "Field '$_' does not exist (not one of @{[keys %$names_hash]})")
2103 unless defined $index;
2104 push @key_indexes, $index;
2105 }
2106 my $rows = {};
2107 my $NAME = $sth->FETCH($hash_key_name);
2108 my @row = (undef) x $num_of_fields;
2109 $sth->bind_columns(\(@row));
2110 while ($sth->fetch) {
2111 my $ref = $rows;
2112 $ref = $ref->{$row[$_]} ||= {} for @key_indexes;
2113 @{$ref}{@$NAME} = @row;
2114 }
2115 return $rows;
2116 }
2117
21181900ns *dump_results = \&DBI::dump_results;
2119
2120 sub blob_copy_to_file { # returns length or undef on error
2121 my($self, $field, $filename_or_handleref, $blocksize) = @_;
2122 my $fh = $filename_or_handleref;
2123 my($len, $buf) = (0, "");
2124 $blocksize ||= 512; # not too ambitious
2125 local(*FH);
2126 unless(ref $fh) {
2127 open(FH, ">$fh") || return undef;
2128 $fh = \*FH;
2129 }
2130 while(defined($self->blob_read($field, $len, $blocksize, \$buf))) {
2131 print $fh $buf;
2132 $len += length $buf;
2133 }
2134 close(FH);
2135 $len;
2136 }
2137
2138 sub more_results {
2139 shift->{syb_more_results}; # handy grandfathering
2140 }
2141
2142}
2143
21441800nsunless ($DBI::PurePerl) { # See install_driver
214527µs { @DBD::_mem::dr::ISA = qw(DBD::_mem::common); }
214625µs { @DBD::_mem::db::ISA = qw(DBD::_mem::common); }
214724µs { @DBD::_mem::st::ISA = qw(DBD::_mem::common); }
2148 # DBD::_mem::common::DESTROY is implemented in DBI.xs
2149}
2150
2151162µs1;
2152__END__
 
# spent 49µs within DBD::_::common::CORE:match which was called 46 times, avg 1µs/call: # 23 times (29µs+0s) by DBD::_::common::install_method at line 1390, avg 1µs/call # 23 times (20µs+0s) by DBD::_::common::install_method at line 1393, avg 848ns/call
sub DBD::_::common::CORE:match; # opcode
# spent 16µs within DBI::CORE:match which was called 127 times, avg 123ns/call: # 127 times (16µs+0s) by DBI::BEGIN@179 at line 280, avg 123ns/call
sub DBI::CORE:match; # opcode
# spent 5µs within DBI::CORE:subst which was called 2 times, avg 2µs/call: # once (4µs+0s) by DBI::connect at line 619 # once (500ns+0s) by DBI::install_driver at line 779
sub DBI::CORE:subst; # opcode
# spent 347µs within DBI::_install_method which was called 112 times, avg 3µs/call: # 89 times (240µs+0s) by DBD::SQLite::BEGIN@5 at line 522, avg 3µs/call # 23 times (107µs+0s) by DBD::_::common::install_method at line 1405, avg 5µs/call
sub DBI::_install_method; # xsub
# spent 6.11s within DBI::_new_handle which was called 368129 times, avg 17µs/call: # 368127 times (6.11s+0s) by DBI::_new_sth at line 1303, avg 17µs/call # once (27µs+0s) by DBI::_new_drh at line 1263 # once (10µs+0s) by DBI::_new_dbh at line 1293
sub DBI::_new_handle; # xsub
# spent 223µs within DBI::bootstrap which was called: # once (223µs+0s) by DynaLoader::bootstrap at line 207 of DynaLoader.pm
sub DBI::bootstrap; # xsub