← Index
NYTProf Performance Profile   « line view »
For /home/ss5/perl5/perlbrew/perls/perl-5.22.0/bin/benchmarkanything-storage
  Run on Mon Jan 29 16:55:34 2018
Reported on Mon Jan 29 16:57:07 2018

Filename/home/ss5/perl5/perlbrew/perls/perl-5.22.0/lib/site_perl/5.22.0/x86_64-linux/DBI.pm
StatementsExecuted 52418 statements in 317ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
1895011153ms229msDBD::_::st::::fetchrow_hashref DBD::_::st::fetchrow_hashref (xsub)
3162931116ms155msDBD::_::common::::EXISTS DBD::_::common::EXISTS
10001142.0ms113msDBD::_::st::::fetchall_arrayref DBD::_::st::fetchall_arrayref
10001118.1ms41.2msDBD::_::st::::bind_columns DBD::_::st::bind_columns
1112.67ms7.05msDBI::::install_driver DBI::install_driver
2000111.80ms1.80msDBD::_::st::::bind_col DBD::_::st::bind_col (xsub)
1731207µs207µsDBI::::_new_handle DBI::_new_handle (xsub)
9421196µs196µsDBI::::_install_method DBI::_install_method (xsub)
111173µs173µsDBI::::bootstrap DBI::bootstrap (xsub)
111140µs495µsDBI::::BEGIN@181 DBI::BEGIN@181
1511101µs279µsDBI::::_new_sth DBI::_new_sth
22188µs106µsDBI::::setup_driver DBI::setup_driver
11151µs1.19msDBI::::__ANON__[:750] DBI::__ANON__[:750]
11149µs8.29msDBI::::connect DBI::connect
55144µs74µsDBD::_::common::::install_method DBD::_::common::install_method
11131µs58µsDBI::::END DBI::END
11115µs15µsDBI::::BEGIN@13 DBI::BEGIN@13
11115µs25µsDBI::::disconnect_all DBI::disconnect_all
11115µs18µsDBD::_::common::::BEGIN@1368 DBD::_::common::BEGIN@1368
11112µs29µsDBI::::_new_drh DBI::_new_drh
102110µs10µsDBD::_::common::::CORE:match DBD::_::common::CORE:match (opcode)
2218µs8µsDBI::::CORE:subst DBI::CORE:subst (opcode)
1118µs10µsDBD::_::dr::::BEGIN@1468 DBD::_::dr::BEGIN@1468
1118µs10µsDBD::_::st::::BEGIN@1851 DBD::_::st::BEGIN@1851
1118µs20µsDBI::::_new_dbh DBI::_new_dbh
1117µs8µsDBD::_::db::::BEGIN@1533 DBD::_::db::BEGIN@1533
1117µs15µsDBI::::BEGIN@1053 DBI::BEGIN@1053
1117µs10µsDBI::::BEGIN@290 DBI::BEGIN@290
1116µs13µsDBI::::BEGIN@984 DBI::BEGIN@984
1116µs13µsDBI::::BEGIN@709 DBI::BEGIN@709
1116µs12µsDBI::::BEGIN@887 DBI::BEGIN@887
127116µs6µsDBI::::CORE:match DBI::CORE:match (opcode)
1115µs14µsDBI::::BEGIN@552 DBI::BEGIN@552
1115µs13µsDBI::::BEGIN@822 DBI::BEGIN@822
1115µs7µsDBI::::BEGIN@294 DBI::BEGIN@294
1115µs12µsDBI::::BEGIN@856 DBI::BEGIN@856
5514µs4µsDBI::var::::TIESCALAR DBI::var::TIESCALAR
1113µs3µsDBI::::BEGIN@177 DBI::BEGIN@177
1112µs2µsDBD::_::common::::trace_msg DBD::_::common::trace_msg (xsub)
1112µs2µsDBI::::BEGIN@178 DBI::BEGIN@178
1112µs2µsDBI::::BEGIN@179 DBI::BEGIN@179
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::::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__[:1967] DBD::_::st::__ANON__[:1967]
0000s0sDBD::_::st::::__ANON__[:2001] DBD::_::st::__ANON__[:2001]
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::::__ANON__[:1049] DBI::__ANON__[:1049]
0000s0sDBI::::__ANON__[:1142] DBI::__ANON__[:1142]
0000s0sDBI::::__ANON__[:1176] DBI::__ANON__[:1176]
0000s0sDBI::::__ANON__[:1177] DBI::__ANON__[:1177]
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::::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
11110µsrequire 5.008_001;
12
13
# spent 15µs within DBI::BEGIN@13 which was called: # once (15µs+0s) by BenchmarkAnything::Storage::Frontend::Lib::connect at line 16
BEGIN {
141300nsour $XS_VERSION = our $VERSION = "1.634"; # ==> ALSO update the version in the pod text below!
15112µs$VERSION = eval $VERSION;
# spent 2µs executing statements in string eval
16161µs115µs}
# spent 15µ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
140If you think you've found a memory leak then read L</Memory Leaks>.
141
142Your problem is most likely related to the specific DBD driver module you're
143using. If that's the case then click on the 'Bugs' link on the L<http://metacpan.org>
144page for your driver. Only submit a bug report against the DBI itself if you're
145sure that your issue isn't related to the driver you're using.
146
147=head2 NOTES
148
149This is the DBI specification that corresponds to DBI version 1.634
150(see L<DBI::Changes> for details).
151
152The DBI is evolving at a steady pace, so it's good to check that
153you have the latest copy.
154
155The significant user-visible changes in each release are documented
156in the L<DBI::Changes> module so you can read them by executing
157C<perldoc DBI::Changes>.
158
159Some DBI changes require changes in the drivers, but the drivers
160can take some time to catch up. Newer versions of the DBI have
161added features that may not yet be supported by the drivers you
162use. Talk to the authors of your drivers if you need a new feature
163that is not yet supported.
164
165Features added after DBI 1.21 (February 2002) are marked in the
166text with the version number of the DBI release they first appeared in.
167
168Extensions to the DBI API often use the C<DBIx::*> namespace.
169See L</Naming Conventions and Name Space>. DBI extension modules
170can be found at L<https://metacpan.org/search?q=DBIx>. And all modules
171related to the DBI can be found at L<https://metacpan.org/search?q=DBI>.
172
173=cut
174
175# The POD text continues at the end of the file.
176
177212µs13µs
# spent 3µs within DBI::BEGIN@177 which was called: # once (3µs+0s) by BenchmarkAnything::Storage::Frontend::Lib::connect at line 177
use Carp();
# spent 3µs making 1 call to DBI::BEGIN@177
17829µs12µs
# spent 2µs within DBI::BEGIN@178 which was called: # once (2µs+0s) by BenchmarkAnything::Storage::Frontend::Lib::connect at line 178
use DynaLoader ();
# spent 2µs making 1 call to DBI::BEGIN@178
1792162µs12µs
# spent 2µs within DBI::BEGIN@179 which was called: # once (2µs+0s) by BenchmarkAnything::Storage::Frontend::Lib::connect at line 179
use Exporter ();
# spent 2µs making 1 call to DBI::BEGIN@179
180
181
# spent 495µs (140+356) within DBI::BEGIN@181 which was called: # once (140µs+356µs) by BenchmarkAnything::Storage::Frontend::Lib::connect at line 286
BEGIN {
18218µs@ISA = qw(Exporter DynaLoader);
183
184# Make some utility functions available if asked for
1851300ns@EXPORT = (); # we export nothing by default
1861400ns@EXPORT_OK = qw(%DBI %DBI_methods hash); # also populated by export_ok_tags:
18715µs%EXPORT_TAGS = (
188 sql_types => [ qw(
189 SQL_GUID
190 SQL_WLONGVARCHAR
191 SQL_WVARCHAR
192 SQL_WCHAR
193 SQL_BIGINT
194 SQL_BIT
195 SQL_TINYINT
196 SQL_LONGVARBINARY
197 SQL_VARBINARY
198 SQL_BINARY
199 SQL_LONGVARCHAR
200 SQL_UNKNOWN_TYPE
201 SQL_ALL_TYPES
202 SQL_CHAR
203 SQL_NUMERIC
204 SQL_DECIMAL
205 SQL_INTEGER
206 SQL_SMALLINT
207 SQL_FLOAT
208 SQL_REAL
209 SQL_DOUBLE
210 SQL_DATETIME
211 SQL_DATE
212 SQL_INTERVAL
213 SQL_TIME
214 SQL_TIMESTAMP
215 SQL_VARCHAR
216 SQL_BOOLEAN
217 SQL_UDT
218 SQL_UDT_LOCATOR
219 SQL_ROW
220 SQL_REF
221 SQL_BLOB
222 SQL_BLOB_LOCATOR
223 SQL_CLOB
224 SQL_CLOB_LOCATOR
225 SQL_ARRAY
226 SQL_ARRAY_LOCATOR
227 SQL_MULTISET
228 SQL_MULTISET_LOCATOR
229 SQL_TYPE_DATE
230 SQL_TYPE_TIME
231 SQL_TYPE_TIMESTAMP
232 SQL_TYPE_TIME_WITH_TIMEZONE
233 SQL_TYPE_TIMESTAMP_WITH_TIMEZONE
234 SQL_INTERVAL_YEAR
235 SQL_INTERVAL_MONTH
236 SQL_INTERVAL_DAY
237 SQL_INTERVAL_HOUR
238 SQL_INTERVAL_MINUTE
239 SQL_INTERVAL_SECOND
240 SQL_INTERVAL_YEAR_TO_MONTH
241 SQL_INTERVAL_DAY_TO_HOUR
242 SQL_INTERVAL_DAY_TO_MINUTE
243 SQL_INTERVAL_DAY_TO_SECOND
244 SQL_INTERVAL_HOUR_TO_MINUTE
245 SQL_INTERVAL_HOUR_TO_SECOND
246 SQL_INTERVAL_MINUTE_TO_SECOND
247 ) ],
248 sql_cursor_types => [ qw(
249 SQL_CURSOR_FORWARD_ONLY
250 SQL_CURSOR_KEYSET_DRIVEN
251 SQL_CURSOR_DYNAMIC
252 SQL_CURSOR_STATIC
253 SQL_CURSOR_TYPE_DEFAULT
254 ) ], # for ODBC cursor types
255 utils => [ qw(
256 neat neat_list $neat_maxlen dump_results looks_like_number
257 data_string_diff data_string_desc data_diff sql_type_cast
258 DBIstcf_DISCARD_STRING
259 DBIstcf_STRICT
260 ) ],
261 profile => [ qw(
262 dbi_profile dbi_profile_merge dbi_profile_merge_nodes dbi_time
263 ) ], # notionally "in" DBI::Profile and normally imported from there
264);
265
2661200ns$DBI::dbi_debug = 0; # mixture of bit fields and int sub-fields
2671200ns$DBI::neat_maxlen = 1000;
2681100ns$DBI::stderr = 2_000_000_000; # a very round number below 2**31
269
270# If you get an error here like "Can't find loadable object ..."
271# then you haven't installed the DBI correctly. Read the README
272# then install it again.
27312µsif ( $ENV{DBI_PUREPERL} ) {
274 eval { bootstrap DBI $XS_VERSION } if $ENV{DBI_PUREPERL} == 1;
275 require DBI::PurePerl if $@ or $ENV{DBI_PUREPERL} >= 2;
276 $DBI::PurePerl ||= 0; # just to silence "only used once" warnings
277}
278else {
27913µs1313µs bootstrap DBI $XS_VERSION;
# spent 313µs making 1 call to DynaLoader::bootstrap
280}
281
282128117µs1276µs$EXPORT_TAGS{preparse_flags} = [ grep { /^DBIpp_\w\w_/ } keys %{__PACKAGE__."::"} ];
# spent 6µs making 127 calls to DBI::CORE:match, avg 43ns/call
283
28413µs115µsExporter::export_ok_tags(keys %EXPORT_TAGS);
# spent 15µs making 1 call to Exporter::export_ok_tags
285
286134µs1495µs}
# spent 495µs making 1 call to DBI::BEGIN@181
287
288# Alias some handle methods to also be DBI class methods
28912µsfor (qw(trace_msg set_err parse_trace_flag parse_trace_flags)) {
290229µs213µs
# spent 10µs (7+3) within DBI::BEGIN@290 which was called: # once (7µs+3µs) by BenchmarkAnything::Storage::Frontend::Lib::connect at line 290
no strict;
# spent 10µs making 1 call to DBI::BEGIN@290 # spent 3µs making 1 call to strict::unimport
29149µs *$_ = \&{"DBD::_::common::$_"};
292}
293
2942578µs28µs
# spent 7µs (5+2) within DBI::BEGIN@294 which was called: # once (5µs+2µs) by BenchmarkAnything::Storage::Frontend::Lib::connect at line 294
use strict;
# spent 7µs making 1 call to DBI::BEGIN@294 # spent 2µs making 1 call to strict::import
295
29611µsDBI->trace(split /=/, $ENV{DBI_TRACE}, 2) if $ENV{DBI_TRACE};
297
2981400ns$DBI::connect_via ||= "connect";
299
300# check if user wants a persistent database connection ( Apache + mod_perl )
3011500nsif ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
302 $DBI::connect_via = "Apache::DBI::connect";
303 DBI->trace_msg("DBI connect via $DBI::connect_via in $INC{'Apache/DBI.pm'}\n");
304}
305
306# check for weaken support, used by ChildHandles
3071600nsmy $HAS_WEAKEN = eval {
30811µs require Scalar::Util;
309 # this will croak() if this Scalar::Util doesn't have a working weaken().
31017µs12µs Scalar::Util::weaken( \my $test ); # same test as in t/72childhandles.t
# spent 2µs making 1 call to Scalar::Util::weaken
31111µs 1;
312};
313
3141800ns%DBI::installed_drh = (); # maps driver names to installed driver handles
315sub installed_drivers { %DBI::installed_drh }
3161200ns%DBI::installed_methods = (); # XXX undocumented, may change
317sub installed_methods { %DBI::installed_methods }
318
319# Setup special DBI dynamic variables. See DBI::var::FETCH for details.
320# These are dynamically associated with the last handle used.
32114µs12µstie $DBI::err, 'DBI::var', '*err'; # special case: referenced via IHA list
# spent 2µs making 1 call to DBI::var::TIESCALAR
32211µs1500nstie $DBI::state, 'DBI::var', '"state'; # special case: referenced via IHA list
# spent 500ns making 1 call to DBI::var::TIESCALAR
3231900ns1600nstie $DBI::lasth, 'DBI::var', '!lasth'; # special case: return boolean
# spent 600ns making 1 call to DBI::var::TIESCALAR
3241900ns1500nstie $DBI::errstr, 'DBI::var', '&errstr'; # call &errstr in last used pkg
# spent 500ns making 1 call to DBI::var::TIESCALAR
3251600ns1400nstie $DBI::rows, 'DBI::var', '&rows'; # call &rows in last used pkg
# spent 400ns making 1 call to DBI::var::TIESCALAR
3261010µs
# spent 4µs within DBI::var::TIESCALAR which was called 5 times, avg 800ns/call: # once (2µs+0s) by BenchmarkAnything::Storage::Frontend::Lib::connect at line 321 # once (600ns+0s) by BenchmarkAnything::Storage::Frontend::Lib::connect at line 323 # once (500ns+0s) by BenchmarkAnything::Storage::Frontend::Lib::connect at line 324 # once (500ns+0s) by BenchmarkAnything::Storage::Frontend::Lib::connect at line 322 # once (400ns+0s) by BenchmarkAnything::Storage::Frontend::Lib::connect at line 325
sub DBI::var::TIESCALAR{ my $var = $_[1]; bless \$var, 'DBI::var'; }
327sub DBI::var::STORE { Carp::croak("Can't modify \$DBI::${$_[0]} special variable") }
328
329# --- Driver Specific Prefix Registry ---
330
331145µsmy $dbd_prefix_registry = {
332 ad_ => { class => 'DBD::AnyData', },
333 ad2_ => { class => 'DBD::AnyData2', },
334 ado_ => { class => 'DBD::ADO', },
335 amzn_ => { class => 'DBD::Amazon', },
336 best_ => { class => 'DBD::BestWins', },
337 csv_ => { class => 'DBD::CSV', },
338 cubrid_ => { class => 'DBD::cubrid', },
339 db2_ => { class => 'DBD::DB2', },
340 dbi_ => { class => 'DBI', },
341 dbm_ => { class => 'DBD::DBM', },
342 df_ => { class => 'DBD::DF', },
343 examplep_ => { class => 'DBD::ExampleP', },
344 f_ => { class => 'DBD::File', },
345 file_ => { class => 'DBD::TextFile', },
346 go_ => { class => 'DBD::Gofer', },
347 ib_ => { class => 'DBD::InterBase', },
348 ing_ => { class => 'DBD::Ingres', },
349 ix_ => { class => 'DBD::Informix', },
350 jdbc_ => { class => 'DBD::JDBC', },
351 mo_ => { class => 'DBD::MO', },
352 monetdb_ => { class => 'DBD::monetdb', },
353 msql_ => { class => 'DBD::mSQL', },
354 mvsftp_ => { class => 'DBD::MVS_FTPSQL', },
355 mysql_ => { class => 'DBD::mysql', },
356 multi_ => { class => 'DBD::Multi' },
357 mx_ => { class => 'DBD::Multiplex', },
358 neo_ => { class => 'DBD::Neo4p', },
359 nullp_ => { class => 'DBD::NullP', },
360 odbc_ => { class => 'DBD::ODBC', },
361 ora_ => { class => 'DBD::Oracle', },
362 pg_ => { class => 'DBD::Pg', },
363 pgpp_ => { class => 'DBD::PgPP', },
364 plb_ => { class => 'DBD::Plibdata', },
365 po_ => { class => 'DBD::PO', },
366 proxy_ => { class => 'DBD::Proxy', },
367 ram_ => { class => 'DBD::RAM', },
368 rdb_ => { class => 'DBD::RDB', },
369 sapdb_ => { class => 'DBD::SAP_DB', },
370 snmp_ => { class => 'DBD::SNMP', },
371 solid_ => { class => 'DBD::Solid', },
372 spatialite_ => { class => 'DBD::Spatialite', },
373 sponge_ => { class => 'DBD::Sponge', },
374 sql_ => { class => 'DBI::DBD::SqlEngine', },
375 sqlite_ => { class => 'DBD::SQLite', },
376 syb_ => { class => 'DBD::Sybase', },
377 sys_ => { class => 'DBD::Sys', },
378 tdat_ => { class => 'DBD::Teradata', },
379 tmpl_ => { class => 'DBD::Template', },
380 tmplss_ => { class => 'DBD::TemplateSS', },
381 tree_ => { class => 'DBD::TreeData', },
382 tuber_ => { class => 'DBD::Tuber', },
383 uni_ => { class => 'DBD::Unify', },
384 vt_ => { class => 'DBD::Vt', },
385 wmi_ => { class => 'DBD::WMI', },
386 x_ => { }, # for private use
387 xbase_ => { class => 'DBD::XBase', },
388 xl_ => { class => 'DBD::Excel', },
389 yaswi_ => { class => 'DBD::Yaswi', },
390};
391
392my %dbd_class_registry = map { $dbd_prefix_registry->{$_}->{class} => { prefix => $_ } }
393 grep { exists $dbd_prefix_registry->{$_}->{class} }
394160µs keys %{$dbd_prefix_registry};
395
396sub dump_dbd_registry {
397 require Data::Dumper;
398 local $Data::Dumper::Sortkeys=1;
399 local $Data::Dumper::Indent=1;
400 print Data::Dumper->Dump([$dbd_prefix_registry], [qw($dbd_prefix_registry)]);
401}
402
403# --- Dynamically create the DBI Standard Interface
404
4051700nsmy $keeperr = { O=>0x0004 };
406
407171µs%DBI::DBI_methods = ( # Define the DBI interface methods per class:
408
409 common => { # Interface methods common to all DBI handle classes
410 'DESTROY' => { O=>0x004|0x10000 },
411 'CLEAR' => $keeperr,
412 'EXISTS' => $keeperr,
413 'FETCH' => { O=>0x0404 },
414 'FETCH_many' => { O=>0x0404 },
415 'FIRSTKEY' => $keeperr,
416 'NEXTKEY' => $keeperr,
417 'STORE' => { O=>0x0418 | 0x4 },
418 'DELETE' => { O=>0x0404 },
419 can => { O=>0x0100 }, # special case, see dispatch
420 debug => { U =>[1,2,'[$debug_level]'], O=>0x0004 }, # old name for trace
421 dump_handle => { U =>[1,3,'[$message [, $level]]'], O=>0x0004 },
422 err => $keeperr,
423 errstr => $keeperr,
424 state => $keeperr,
425 func => { O=>0x0006 },
426 parse_trace_flag => { U =>[2,2,'$name'], O=>0x0404, T=>8 },
427 parse_trace_flags => { U =>[2,2,'$flags'], O=>0x0404, T=>8 },
428 private_data => { U =>[1,1], O=>0x0004 },
429 set_err => { U =>[3,6,'$err, $errmsg [, $state, $method, $rv]'], O=>0x0010 },
430 trace => { U =>[1,3,'[$trace_level, [$filename]]'], O=>0x0004 },
431 trace_msg => { U =>[2,3,'$message_text [, $min_level ]' ], O=>0x0004, T=>8 },
432 swap_inner_handle => { U =>[2,3,'$h [, $allow_reparent ]'] },
433 private_attribute_info => { },
434 visit_child_handles => { U => [2,3,'$coderef [, $info ]'], O=>0x0404, T=>4 },
435 },
436 dr => { # Database Driver Interface
437 'connect' => { U =>[1,5,'[$db [,$user [,$passwd [,\%attr]]]]'], H=>3, O=>0x8000, T=>0x200 },
438 'connect_cached'=>{U=>[1,5,'[$db [,$user [,$passwd [,\%attr]]]]'], H=>3, O=>0x8000, T=>0x200 },
439 'disconnect_all'=>{ U =>[1,1], O=>0x0800, T=>0x200 },
440 data_sources => { U =>[1,2,'[\%attr]' ], O=>0x0800, T=>0x200 },
441 default_user => { U =>[3,4,'$user, $pass [, \%attr]' ], T=>0x200 },
442 dbixs_revision => $keeperr,
443 },
444 db => { # Database Session Class Interface
445 data_sources => { U =>[1,2,'[\%attr]' ], O=>0x0200 },
446 take_imp_data => { U =>[1,1], O=>0x10000 },
447 clone => { U =>[1,2,'[\%attr]'], T=>0x200 },
448 connected => { U =>[1,0], O => 0x0004, T=>0x200, H=>3 },
449 begin_work => { U =>[1,2,'[ \%attr ]'], O=>0x0400, T=>0x1000 },
450 commit => { U =>[1,1], O=>0x0480|0x0800, T=>0x1000 },
451 rollback => { U =>[1,1], O=>0x0480|0x0800, T=>0x1000 },
452 'do' => { U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x3200 },
453 last_insert_id => { U =>[5,6,'$catalog, $schema, $table_name, $field_name [, \%attr ]'], O=>0x2800 },
454 preparse => { }, # XXX
455 prepare => { U =>[2,3,'$statement [, \%attr]'], O=>0xA200 },
456 prepare_cached => { U =>[2,4,'$statement [, \%attr [, $if_active ] ]'], O=>0xA200 },
457 selectrow_array => { U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
458 selectrow_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
459 selectrow_hashref=>{ U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
460 selectall_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
461 selectall_hashref=>{ U =>[3,0,'$statement, $keyfield [, \%attr [, @bind_params ] ]'], O=>0x2000 },
462 selectcol_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
463 ping => { U =>[1,1], O=>0x0404 },
464 disconnect => { U =>[1,1], O=>0x0400|0x0800|0x10000, T=>0x200 },
465 quote => { U =>[2,3, '$string [, $data_type ]' ], O=>0x0430, T=>2 },
466 quote_identifier=> { U =>[2,6, '$name [, ...] [, \%attr ]' ], O=>0x0430, T=>2 },
467 rows => $keeperr,
468
469 tables => { U =>[1,6,'$catalog, $schema, $table, $type [, \%attr ]' ], O=>0x2200 },
470 table_info => { U =>[1,6,'$catalog, $schema, $table, $type [, \%attr ]' ], O=>0x2200|0x8800 },
471 column_info => { U =>[5,6,'$catalog, $schema, $table, $column [, \%attr ]'],O=>0x2200|0x8800 },
472 primary_key_info=> { U =>[4,5,'$catalog, $schema, $table [, \%attr ]' ], O=>0x2200|0x8800 },
473 primary_key => { U =>[4,5,'$catalog, $schema, $table [, \%attr ]' ], O=>0x2200 },
474 foreign_key_info=> { U =>[7,8,'$pk_catalog, $pk_schema, $pk_table, $fk_catalog, $fk_schema, $fk_table [, \%attr ]' ], O=>0x2200|0x8800 },
475 statistics_info => { U =>[6,7,'$catalog, $schema, $table, $unique_only, $quick, [, \%attr ]' ], O=>0x2200|0x8800 },
476 type_info_all => { U =>[1,1], O=>0x2200|0x0800 },
477 type_info => { U =>[1,2,'$data_type'], O=>0x2200 },
478 get_info => { U =>[2,2,'$info_type'], O=>0x2200|0x0800 },
479 },
480 st => { # Statement Class Interface
481 bind_col => { U =>[3,4,'$column, \\$var [, \%attr]'] },
482 bind_columns => { U =>[2,0,'\\$var1 [, \\$var2, ...]'] },
483 bind_param => { U =>[3,4,'$parameter, $var [, \%attr]'] },
484 bind_param_inout=> { U =>[4,5,'$parameter, \\$var, $maxlen, [, \%attr]'] },
485 execute => { U =>[1,0,'[@args]'], O=>0x1040 },
486
487 bind_param_array => { U =>[3,4,'$parameter, $var [, \%attr]'] },
488 bind_param_inout_array => { U =>[4,5,'$parameter, \\@var, $maxlen, [, \%attr]'] },
489 execute_array => { U =>[2,0,'\\%attribs [, @args]'], O=>0x1040|0x4000 },
490 execute_for_fetch => { U =>[2,3,'$fetch_sub [, $tuple_status]'], O=>0x1040|0x4000 },
491
492 fetch => undef, # alias for fetchrow_arrayref
493 fetchrow_arrayref => undef,
494 fetchrow_hashref => undef,
495 fetchrow_array => undef,
496 fetchrow => undef, # old alias for fetchrow_array
497
498 fetchall_arrayref => { U =>[1,3, '[ $slice [, $max_rows]]'] },
499 fetchall_hashref => { U =>[2,2,'$key_field'] },
500
501 blob_read => { U =>[4,5,'$field, $offset, $len [, \\$buf [, $bufoffset]]'] },
502 blob_copy_to_file => { U =>[3,3,'$field, $filename_or_handleref'] },
503 dump_results => { U =>[1,5,'$maxfieldlen, $linesep, $fieldsep, $filehandle'] },
504 more_results => { U =>[1,1] },
505 finish => { U =>[1,1] },
506 cancel => { U =>[1,1], O=>0x0800 },
507 rows => $keeperr,
508
509 _get_fbav => undef,
510 _set_fbav => { T=>6 },
511 },
512);
513
514113µswhile ( my ($class, $meths) = each %DBI::DBI_methods ) {
51542µs my $ima_trace = 0+($ENV{DBI_IMA_TRACE}||0);
516435µs while ( my ($method, $info) = each %$meths ) {
5178920µs my $fullmeth = "DBI::${class}::$method";
518899µs if (($DBI::dbi_debug & 0xF) == 15) { # quick hack to list DBI methods
519 # and optionally filter by IMA flags
520 my $O = $info->{O}||0;
521 printf "0x%04x %-20s\n", $O, $fullmeth
522 unless $ima_trace && !($O & $ima_trace);
523 }
52489264µs89175µs DBI->_install_method($fullmeth, 'DBI.pm', $info);
# spent 175µs making 89 calls to DBI::_install_method, avg 2µs/call
525 }
526}
527
528{
5291200ns package DBI::common;
53017µs @DBI::dr::ISA = ('DBI::common');
53112µs @DBI::db::ISA = ('DBI::common');
53211µs @DBI::st::ISA = ('DBI::common');
533}
534
535# End of init code
536
537
538
# spent 58µs (31+27) within DBI::END which was called: # once (31µs+27µs) by main::RUNTIME at line 0 of /home/ss5/perl5/perlbrew/perls/perl-5.22.0/bin/benchmarkanything-storage
END {
5391800ns return unless defined &DBI::trace_msg; # return unless bootstrap'd ok
54016µs local ($!,$?);
541115µs12µs DBI->trace_msg(sprintf(" -- DBI::END (\$\@: %s, \$!: %s)\n", $@||'', $!||''), 2);
# spent 2µs making 1 call to DBD::_::common::trace_msg
542 # Let drivers know why we are calling disconnect_all:
5431800ns $DBI::PERL_ENDING = $DBI::PERL_ENDING = 1; # avoid typo warning
54418µs125µs DBI->disconnect_all() if %DBI::installed_drh;
# spent 25µs making 1 call to DBI::disconnect_all
545}
546
547
548sub CLONE {
549 _clone_dbis() unless $DBI::PurePerl; # clone the DBIS structure
550 DBI->trace_msg("CLONE DBI for new thread\n");
551 while ( my ($driver, $drh) = each %DBI::installed_drh) {
5522517µs222µs
# spent 14µs (5+8) within DBI::BEGIN@552 which was called: # once (5µs+8µs) by BenchmarkAnything::Storage::Frontend::Lib::connect at line 552
no strict 'refs';
# spent 14µs making 1 call to DBI::BEGIN@552 # spent 8µs making 1 call to strict::unimport
553 next if defined &{"DBD::${driver}::CLONE"};
554 warn("$driver has no driver CLONE() function so is unsafe threaded\n");
555 }
556 %DBI::installed_drh = (); # clear loaded drivers so they have a chance to reinitialize
557}
558
559sub parse_dsn {
560 my ($class, $dsn) = @_;
561 $dsn =~ s/^(dbi):(\w*?)(?:\((.*?)\))?://i or return;
562 my ($scheme, $driver, $attr, $attr_hash) = (lc($1), $2, $3);
563 $driver ||= $ENV{DBI_DRIVER} || '';
564 $attr_hash = { split /\s*=>?\s*|\s*,\s*/, $attr, -1 } if $attr;
565 return ($scheme, $driver, $attr, $attr_hash, $dsn);
566}
567
568sub visit_handles {
569 my ($class, $code, $outer_info) = @_;
570 $outer_info = {} if not defined $outer_info;
571 my %drh = DBI->installed_drivers;
572 for my $h (values %drh) {
573 my $child_info = $code->($h, $outer_info)
574 or next;
575 $h->visit_child_handles($code, $child_info);
576 }
577 return $outer_info;
578}
579
580
581# --- The DBI->connect Front Door methods
582
583sub connect_cached {
584 # For library code using connect_cached() with mod_perl
585 # we redirect those calls to Apache::DBI::connect() as well
586 my ($class, $dsn, $user, $pass, $attr) = @_;
587 my $dbi_connect_method = ($DBI::connect_via eq "Apache::DBI::connect")
588 ? 'Apache::DBI::connect' : 'connect_cached';
589 $attr = {
590 $attr ? %$attr : (), # clone, don't modify callers data
591 dbi_connect_method => $dbi_connect_method,
592 };
593 return $class->connect($dsn, $user, $pass, $attr);
594}
595
596
# spent 8.29ms (49µs+8.25) within DBI::connect which was called: # once (49µs+8.25ms) by BenchmarkAnything::Storage::Frontend::Lib::connect at line 196 of BenchmarkAnything/Storage/Frontend/Lib.pm
sub connect {
5971400ns my $class = shift;
59812µs my ($dsn, $user, $pass, $attr, $old_driver) = my @orig_args = @_;
5991200ns my $driver;
600
60111µs if ($attr and !ref($attr)) { # switch $old_driver<->$attr if called in old style
602 Carp::carp("DBI->connect using 'old-style' syntax is deprecated and will be an error in future versions");
603 ($old_driver, $attr) = ($attr, $old_driver);
604 }
605
6061500ns my $connect_meth = $attr->{dbi_connect_method};
6071500ns $connect_meth ||= $DBI::connect_via; # fallback to default
608
6091500ns $dsn ||= $ENV{DBI_DSN} || $ENV{DBI_DBNAME} || '' unless $old_driver;
610
6111300ns if ($DBI::dbi_debug) {
612 local $^W = 0;
613 pop @_ if $connect_meth ne 'connect';
614 my @args = @_; $args[2] = '****'; # hide password
615 DBI->trace_msg(" -> $class->$connect_meth(".join(", ",@args).")\n");
616 }
6171900ns Carp::croak('Usage: $class->connect([$dsn [,$user [,$passwd [,\%attr]]]])')
618 if (ref $old_driver or ($attr and not ref $attr) or ref $pass);
619
620 # extract dbi:driver prefix from $dsn into $1
621114µs18µs $dsn =~ s/^dbi:(\w*?)(?:\((.*?)\))?://i
# spent 8µs making 1 call to DBI::CORE:subst
622 or '' =~ /()/; # ensure $1 etc are empty if match fails
62311µs my $driver_attrib_spec = $2 || '';
624
625 # Set $driver. Old style driver, if specified, overrides new dsn style.
626 $driver = $old_driver || $1 || $ENV{DBI_DRIVER}
62711µs or Carp::croak("Can't connect to data source '$dsn' "
628 ."because I can't work out what driver to use "
629 ."(it doesn't seem to contain a 'dbi:driver:' prefix "
630 ."and the DBI_DRIVER env var is not set)");
631
6321400ns my $proxy;
6331700ns if ($ENV{DBI_AUTOPROXY} && $driver ne 'Proxy' && $driver ne 'Sponge' && $driver ne 'Switch') {
634 my $dbi_autoproxy = $ENV{DBI_AUTOPROXY};
635 $proxy = 'Proxy';
636 if ($dbi_autoproxy =~ s/^dbi:(\w*?)(?:\((.*?)\))?://i) {
637 $proxy = $1;
638 $driver_attrib_spec = join ",",
639 ($driver_attrib_spec) ? $driver_attrib_spec : (),
640 ($2 ) ? $2 : ();
641 }
642 $dsn = "$dbi_autoproxy;dsn=dbi:$driver:$dsn";
643 $driver = $proxy;
644 DBI->trace_msg(" DBI_AUTOPROXY: dbi:$driver($driver_attrib_spec):$dsn\n");
645 }
646 # avoid recursion if proxy calls DBI->connect itself
6471200ns local $ENV{DBI_AUTOPROXY} if $ENV{DBI_AUTOPROXY};
648
6491300ns my %attributes; # take a copy we can delete from
6501600ns if ($old_driver) {
651 %attributes = %$attr if $attr;
652 }
653 else { # new-style connect so new default semantics
65413µs %attributes = (
655 PrintError => 1,
656 AutoCommit => 1,
657 ref $attr ? %$attr : (),
658 # attributes in DSN take precedence over \%attr connect parameter
659 $driver_attrib_spec ? (split /\s*=>?\s*|\s*,\s*/, $driver_attrib_spec, -1) : (),
660 );
661 }
6621500ns $attr = \%attributes; # now set $attr to refer to our local copy
663
66414µs17.05ms my $drh = $DBI::installed_drh{$driver} || $class->install_driver($driver)
# spent 7.05ms making 1 call to DBI::install_driver
665 or die "panic: $class->install_driver($driver) failed";
666
667 # attributes in DSN take precedence over \%attr connect parameter
6681800ns $user = $attr->{Username} if defined $attr->{Username};
6691300ns $pass = $attr->{Password} if defined $attr->{Password};
6701300ns delete $attr->{Password}; # always delete Password as closure stores it securely
6711400ns if ( !(defined $user && defined $pass) ) {
672 ($user, $pass) = $drh->default_user($user, $pass, $attr);
673 }
6741400ns $attr->{Username} = $user; # force the Username to be the actual one used
675
676
# spent 1.19ms (51µs+1.14) within DBI::__ANON__[/home/ss5/perl5/perlbrew/perls/perl-5.22.0/lib/site_perl/5.22.0/x86_64-linux/DBI.pm:750] which was called: # once (51µs+1.14ms) by DBI::connect at line 752
my $connect_closure = sub {
6771300ns my ($old_dbh, $override_attr) = @_;
678
679 #use Data::Dumper;
680 #warn "connect_closure: ".Data::Dumper::Dumper([$attr,\%attributes, $override_attr]);
681
6821100ns my $dbh;
68319µs22.24ms unless ($dbh = $drh->$connect_meth($dsn, $user, $pass, $attr)) {
# spent 1.13ms making 1 call to DBI::dr::connect # spent 1.12ms making 1 call to DBD::mysql::dr::connect
684 $user = '' if !defined $user;
685 $dsn = '' if !defined $dsn;
686 # $drh->errstr isn't safe here because $dbh->DESTROY may not have
687 # been called yet and so the dbh errstr would not have been copied
688 # up to the drh errstr. Certainly true for connect_cached!
689 my $errstr = $DBI::errstr;
690 # Getting '(no error string)' here is a symptom of a ref loop
691 $errstr = '(no error string)' if !defined $errstr;
692 my $msg = "$class connect('$dsn','$user',...) failed: $errstr";
693 DBI->trace_msg(" $msg\n");
694 # XXX HandleWarn
695 unless ($attr->{HandleError} && $attr->{HandleError}->($msg, $drh, $dbh)) {
696 Carp::croak($msg) if $attr->{RaiseError};
697 Carp::carp ($msg) if $attr->{PrintError};
698 }
699 $! = 0; # for the daft people who do DBI->connect(...) || die "$!";
700 return $dbh; # normally undef, but HandleError could change it
701 }
702
703 # merge any attribute overrides but don't change $attr itself (for closure)
70413µs my $apply = { ($override_attr) ? (%$attr, %$override_attr ) : %$attr };
705
706 # handle basic RootClass subclassing:
70712µs my $rebless_class = $apply->{RootClass} || ($class ne 'DBI' ? $class : '');
7081400ns if ($rebless_class) {
7092415µs221µs
# spent 13µs (6+8) within DBI::BEGIN@709 which was called: # once (6µs+8µs) by BenchmarkAnything::Storage::Frontend::Lib::connect at line 709
no strict 'refs';
# spent 13µs making 1 call to DBI::BEGIN@709 # spent 8µs making 1 call to strict::unimport
710 if ($apply->{RootClass}) { # explicit attribute (ie not static method call class)
711 delete $apply->{RootClass};
712 DBI::_load_class($rebless_class, 0);
713 }
714 unless (@{"$rebless_class\::db::ISA"} && @{"$rebless_class\::st::ISA"}) {
715 Carp::carp("DBI subclasses '$rebless_class\::db' and ::st are not setup, RootClass ignored");
716 $rebless_class = undef;
717 $class = 'DBI';
718 }
719 else {
720 $dbh->{RootClass} = $rebless_class; # $dbh->STORE called via plain DBI::db
721 DBI::_set_isa([$rebless_class], 'DBI'); # sets up both '::db' and '::st'
722 DBI::_rebless($dbh, $rebless_class); # appends '::db'
723 }
724 }
725
7261600ns if (%$apply) {
727
7281500ns if ($apply->{DbTypeSubclass}) {
729 my $DbTypeSubclass = delete $apply->{DbTypeSubclass};
730 DBI::_rebless_dbtype_subclass($dbh, $rebless_class||$class, $DbTypeSubclass);
731 }
7321300ns my $a;
73311µs foreach $a (qw(Profile RaiseError PrintError AutoCommit)) { # do these first
73442µs next unless exists $apply->{$a};
735318µs36µs $dbh->{$a} = delete $apply->{$a};
# spent 6µs making 3 calls to DBI::common::STORE, avg 2µs/call
736 }
73713µs while ( my ($a, $v) = each %$apply) {
738418µs24µs eval { $dbh->{$a} = $v }; # assign in void context to avoid re-FETCH
# spent 4µs making 2 calls to DBI::common::STORE, avg 2µs/call
7392300ns warn $@ if $@;
740 }
741 }
742
743 # confirm to driver (ie if subclassed) that we've connected successfully
744 # and finished the attribute setup. pass in the original arguments
74516µs12µs $dbh->connected(@orig_args); #if ref $dbh ne 'DBI::db' or $proxy;
# spent 2µs making 1 call to DBI::db::connected
746
7471600ns DBI->trace_msg(" <- connect= $dbh\n") if $DBI::dbi_debug & 0xF;
748
74913µs return $dbh;
750113µs };
751
75211µs11.19ms my $dbh = &$connect_closure(undef, undef);
# spent 1.19ms making 1 call to DBI::__ANON__[DBI.pm:750]
753
75414µs11µs $dbh->{dbi_connect_closure} = $connect_closure if $dbh;
# spent 1µs making 1 call to DBI::common::STORE
755
75614µs return $dbh;
757}
758
759
760
# spent 25µs (15+10) within DBI::disconnect_all which was called: # once (15µs+10µs) by DBI::END at line 544
sub disconnect_all {
76111µs keys %DBI::installed_drh; # reset iterator
762125µs110µs while ( my ($name, $drh) = each %DBI::installed_drh ) {
# spent 10µs making 1 call to DBI::dr::disconnect_all
763 $drh->disconnect_all() if ref $drh;
764 }
765}
766
767
768sub disconnect { # a regular beginners bug
769 Carp::croak("DBI->disconnect is not a DBI method (read the DBI manual)");
770}
771
772
773
# spent 7.05ms (2.67+4.37) within DBI::install_driver which was called: # once (2.67ms+4.37ms) by DBI::connect at line 664
sub install_driver { # croaks on failure
7741300ns my $class = shift;
7751500ns my($driver, $attr) = @_;
7761400ns my $drh;
777
7781300ns $driver ||= $ENV{DBI_DRIVER} || '';
779
780 # allow driver to be specified as a 'dbi:driver:' string
78112µs1400ns $driver = $1 if $driver =~ s/^DBI:(.*?)://i;
# spent 400ns making 1 call to DBI::CORE:subst
782
7831700ns Carp::croak("usage: $class->install_driver(\$driver [, \%attr])")
784 unless ($driver and @_<=3);
785
786 # already installed
7871500ns return $drh if $drh = $DBI::installed_drh{$driver};
788
7891400ns $class->trace_msg(" -> $class->install_driver($driver"
790 .") for $^O perl=$] pid=$$ ruid=$< euid=$>\n")
791 if $DBI::dbi_debug & 0xF;
792
793 # --- load the code
7941600ns my $driver_class = "DBD::$driver";
795121µs eval qq{package # hide from PAUSE
# spent 38µs executing statements in string eval
796 DBI::_firesafe; # just in case
797 require $driver_class; # load the driver
798 };
7991200ns if ($@) {
800 my $err = $@;
801 my $advice = "";
802 if ($err =~ /Can't find loadable object/) {
803 $advice = "Perhaps DBD::$driver was statically linked into a new perl binary."
804 ."\nIn which case you need to use that new perl binary."
805 ."\nOr perhaps only the .pm file was installed but not the shared object file."
806 }
807 elsif ($err =~ /Can't locate.*?DBD\/$driver\.pm in \@INC/) {
808 my @drv = $class->available_drivers(1);
809 $advice = "Perhaps the DBD::$driver perl module hasn't been fully installed,\n"
810 ."or perhaps the capitalisation of '$driver' isn't right.\n"
811 ."Available drivers: ".join(", ", @drv).".";
812 }
813 elsif ($err =~ /Can't load .*? for module DBD::/) {
814 $advice = "Perhaps a required shared library or dll isn't installed where expected";
815 }
816 elsif ($err =~ /Can't locate .*? in \@INC/) {
817 $advice = "Perhaps a module that DBD::$driver requires hasn't been fully installed";
818 }
819 Carp::croak("install_driver($driver) failed: $err$advice\n");
820 }
8211500ns if ($DBI::dbi_debug & 0xF) {
8222143µs220µs
# spent 13µs (5+8) within DBI::BEGIN@822 which was called: # once (5µs+8µs) by BenchmarkAnything::Storage::Frontend::Lib::connect at line 822
no strict 'refs';
# spent 13µs making 1 call to DBI::BEGIN@822 # spent 8µs making 1 call to strict::unimport
823 (my $driver_file = $driver_class) =~ s/::/\//g;
824 my $dbd_ver = ${"$driver_class\::VERSION"} || "undef";
825 $class->trace_msg(" install_driver: $driver_class version $dbd_ver"
826 ." loaded from $INC{qq($driver_file.pm)}\n");
827 }
828
829 # --- do some behind-the-scenes checks and setups on the driver
83012µs153µs $class->setup_driver($driver_class);
# spent 53µs making 1 call to DBI::setup_driver
831
832 # --- run the driver function
83322µs1142µs $drh = eval { $driver_class->driver($attr || {}) };
# spent 142µs making 1 call to DBD::mysql::driver
83417µs unless ($drh && ref $drh && !$@) {
835 my $advice = "";
836 $@ ||= "$driver_class->driver didn't return a handle";
837 # catch people on case in-sensitive systems using the wrong case
838 $advice = "\nPerhaps the capitalisation of DBD '$driver' isn't right."
839 if $@ =~ /locate object method/;
840 Carp::croak("$driver_class initialisation failed: $@$advice");
841 }
842
84311µs $DBI::installed_drh{$driver} = $drh;
8441500ns $class->trace_msg(" <- install_driver= $drh\n") if $DBI::dbi_debug & 0xF;
84512µs $drh;
846}
847
8481700ns*driver = \&install_driver; # currently an alias, may change
849
850
851
# spent 106µs (88+19) within DBI::setup_driver which was called 2 times, avg 53µs/call: # once (44µs+10µs) by BenchmarkAnything::Storage::Frontend::Lib::connect at line 1318 # once (44µs+9µs) by DBI::install_driver at line 830
sub setup_driver {
85221µs my ($class, $driver_class) = @_;
8532400ns my $h_type;
85426µs foreach $h_type (qw(dr db st)){
85563µs my $h_class = $driver_class."::$h_type";
8562123µs218µs
# spent 12µs (5+7) within DBI::BEGIN@856 which was called: # once (5µs+7µs) by BenchmarkAnything::Storage::Frontend::Lib::connect at line 856
no strict 'refs';
# spent 12µs making 1 call to DBI::BEGIN@856 # spent 7µs making 1 call to strict::unimport
857651µs612µs push @{"${h_class}::ISA"}, "DBD::_::$h_type"
# spent 12µs making 6 calls to UNIVERSAL::isa, avg 2µs/call
858 unless UNIVERSAL::isa($h_class, "DBD::_::$h_type");
859 # The _mem class stuff is (IIRC) a crufty hack for global destruction
860 # timing issues in early versions of perl5 and possibly no longer needed.
86162µs my $mem_class = "DBD::_mem::$h_type";
862646µs66µs push @{"${h_class}_mem::ISA"}, $mem_class
# spent 6µs making 6 calls to UNIVERSAL::isa, avg 1µs/call
863 unless UNIVERSAL::isa("${h_class}_mem", $mem_class)
864 or $DBI::PurePerl;
865 }
866}
867
868
869sub _rebless {
870 my $dbh = shift;
871 my ($outer, $inner) = DBI::_handles($dbh);
872 my $class = shift(@_).'::db';
873 bless $inner => $class;
874 bless $outer => $class; # outer last for return
875}
876
877
878sub _set_isa {
879 my ($classes, $topclass) = @_;
880 my $trace = DBI->trace_msg(" _set_isa([@$classes])\n");
881 foreach my $suffix ('::db','::st') {
882 my $previous = $topclass || 'DBI'; # trees are rooted here
883 foreach my $class (@$classes) {
884 my $base_class = $previous.$suffix;
885 my $sub_class = $class.$suffix;
886 my $sub_class_isa = "${sub_class}::ISA";
8872306µs218µs
# spent 12µs (6+6) within DBI::BEGIN@887 which was called: # once (6µs+6µs) by BenchmarkAnything::Storage::Frontend::Lib::connect at line 887
no strict 'refs';
# spent 12µs making 1 call to DBI::BEGIN@887 # spent 6µs making 1 call to strict::unimport
888 if (@$sub_class_isa) {
889 DBI->trace_msg(" $sub_class_isa skipped (already set to @$sub_class_isa)\n")
890 if $trace;
891 }
892 else {
893 @$sub_class_isa = ($base_class) unless @$sub_class_isa;
894 DBI->trace_msg(" $sub_class_isa = $base_class\n")
895 if $trace;
896 }
897 $previous = $class;
898 }
899 }
900}
901
902
903sub _rebless_dbtype_subclass {
904 my ($dbh, $rootclass, $DbTypeSubclass) = @_;
905 # determine the db type names for class hierarchy
906 my @hierarchy = DBI::_dbtype_names($dbh, $DbTypeSubclass);
907 # add the rootclass prefix to each ('DBI::' or 'MyDBI::' etc)
908 $_ = $rootclass.'::'.$_ foreach (@hierarchy);
909 # load the modules from the 'top down'
910 DBI::_load_class($_, 1) foreach (reverse @hierarchy);
911 # setup class hierarchy if needed, does both '::db' and '::st'
912 DBI::_set_isa(\@hierarchy, $rootclass);
913 # finally bless the handle into the subclass
914 DBI::_rebless($dbh, $hierarchy[0]);
915}
916
917
918sub _dbtype_names { # list dbtypes for hierarchy, ie Informix=>ADO=>ODBC
919 my ($dbh, $DbTypeSubclass) = @_;
920
921 if ($DbTypeSubclass && $DbTypeSubclass ne '1' && ref $DbTypeSubclass ne 'CODE') {
922 # treat $DbTypeSubclass as a comma separated list of names
923 my @dbtypes = split /\s*,\s*/, $DbTypeSubclass;
924 $dbh->trace_msg(" DbTypeSubclass($DbTypeSubclass)=@dbtypes (explicit)\n");
925 return @dbtypes;
926 }
927
928 # XXX will call $dbh->get_info(17) (=SQL_DBMS_NAME) in future?
929
930 my $driver = $dbh->{Driver}->{Name};
931 if ( $driver eq 'Proxy' ) {
932 # XXX Looking into the internals of DBD::Proxy is questionable!
933 ($driver) = $dbh->{proxy_client}->{application} =~ /^DBI:(.+?):/i
934 or die "Can't determine driver name from proxy";
935 }
936
937 my @dbtypes = (ucfirst($driver));
938 if ($driver eq 'ODBC' || $driver eq 'ADO') {
939 # XXX will move these out and make extensible later:
940 my $_dbtype_name_regexp = 'Oracle'; # eg 'Oracle|Foo|Bar'
941 my %_dbtype_name_map = (
942 'Microsoft SQL Server' => 'MSSQL',
943 'SQL Server' => 'Sybase',
944 'Adaptive Server Anywhere' => 'ASAny',
945 'ADABAS D' => 'AdabasD',
946 );
947
948 my $name;
949 $name = $dbh->func(17, 'GetInfo') # SQL_DBMS_NAME
950 if $driver eq 'ODBC';
951 $name = $dbh->{ado_conn}->Properties->Item('DBMS Name')->Value
952 if $driver eq 'ADO';
953 die "Can't determine driver name! ($DBI::errstr)\n"
954 unless $name;
955
956 my $dbtype;
957 if ($_dbtype_name_map{$name}) {
958 $dbtype = $_dbtype_name_map{$name};
959 }
960 else {
961 if ($name =~ /($_dbtype_name_regexp)/) {
962 $dbtype = lc($1);
963 }
964 else { # generic mangling for other names:
965 $dbtype = lc($name);
966 }
967 $dbtype =~ s/\b(\w)/\U$1/g;
968 $dbtype =~ s/\W+/_/g;
969 }
970 # add ODBC 'behind' ADO
971 push @dbtypes, 'ODBC' if $driver eq 'ADO';
972 # add discovered dbtype in front of ADO/ODBC
973 unshift @dbtypes, $dbtype;
974 }
975 @dbtypes = &$DbTypeSubclass($dbh, \@dbtypes)
976 if (ref $DbTypeSubclass eq 'CODE');
977 $dbh->trace_msg(" DbTypeSubclass($DbTypeSubclass)=@dbtypes\n");
978 return @dbtypes;
979}
980
981sub _load_class {
982 my ($load_class, $missing_ok) = @_;
983 DBI->trace_msg(" _load_class($load_class, $missing_ok)\n", 2);
9842324µs220µs
# spent 13µs (6+7) within DBI::BEGIN@984 which was called: # once (6µs+7µs) by BenchmarkAnything::Storage::Frontend::Lib::connect at line 984
no strict 'refs';
# spent 13µs making 1 call to DBI::BEGIN@984 # spent 7µs making 1 call to strict::unimport
985 return 1 if @{"$load_class\::ISA"}; # already loaded/exists
986 (my $module = $load_class) =~ s!::!/!g;
987 DBI->trace_msg(" _load_class require $module\n", 2);
988 eval { require "$module.pm"; };
989 return 1 unless $@;
990 return 0 if $missing_ok && $@ =~ /^Can't locate \Q$module.pm\E/;
991 die $@;
992}
993
994
995sub init_rootclass { # deprecated
996 return 1;
997}
998
999
10001300ns*internal = \&DBD::Switch::dr::driver;
1001
1002sub driver_prefix {
1003 my ($class, $driver) = @_;
1004 return $dbd_class_registry{$driver}->{prefix} if exists $dbd_class_registry{$driver};
1005 return;
1006}
1007
1008sub available_drivers {
1009 my($quiet) = @_;
1010 my(@drivers, $d, $f);
1011 local(*DBI::DIR, $@);
1012 my(%seen_dir, %seen_dbd);
1013 my $haveFileSpec = eval { require File::Spec };
1014 foreach $d (@INC){
1015 chomp($d); # Perl 5 beta 3 bug in #!./perl -Ilib from Test::Harness
1016 my $dbd_dir =
1017 ($haveFileSpec ? File::Spec->catdir($d, 'DBD') : "$d/DBD");
1018 next unless -d $dbd_dir;
1019 next if $seen_dir{$d};
1020 $seen_dir{$d} = 1;
1021 # XXX we have a problem here with case insensitive file systems
1022 # XXX since we can't tell what case must be used when loading.
1023 opendir(DBI::DIR, $dbd_dir) || Carp::carp "opendir $dbd_dir: $!\n";
1024 foreach $f (readdir(DBI::DIR)){
1025 next unless $f =~ s/\.pm$//;
1026 next if $f eq 'NullP';
1027 if ($seen_dbd{$f}){
1028 Carp::carp "DBD::$f in $d is hidden by DBD::$f in $seen_dbd{$f}\n"
1029 unless $quiet;
1030 } else {
1031 push(@drivers, $f);
1032 }
1033 $seen_dbd{$f} = $d;
1034 }
1035 closedir(DBI::DIR);
1036 }
1037
1038 # "return sort @drivers" will not DWIM in scalar context.
1039 return wantarray ? sort @drivers : @drivers;
1040}
1041
1042sub installed_versions {
1043 my ($class, $quiet) = @_;
1044 my %error;
1045 my %version;
1046 for my $driver ($class->available_drivers($quiet)) {
1047 next if $DBI::PurePerl && grep { -d "$_/auto/DBD/$driver" } @INC;
1048 my $drh = eval {
1049 local $SIG{__WARN__} = sub {};
1050 $class->install_driver($driver);
1051 };
1052 ($error{"DBD::$driver"}=$@),next if $@;
105321.34ms223µs
# spent 15µs (7+8) within DBI::BEGIN@1053 which was called: # once (7µs+8µs) by BenchmarkAnything::Storage::Frontend::Lib::connect at line 1053
no strict 'refs';
# spent 15µs making 1 call to DBI::BEGIN@1053 # spent 8µs making 1 call to strict::unimport
1054 my $vers = ${"DBD::$driver" . '::VERSION'};
1055 $version{"DBD::$driver"} = $vers || '?';
1056 }
1057 if (wantarray) {
1058 return map { m/^DBD::(\w+)/ ? ($1) : () } sort keys %version;
1059 }
1060 $version{"DBI"} = $DBI::VERSION;
1061 $version{"DBI::PurePerl"} = $DBI::PurePerl::VERSION if $DBI::PurePerl;
1062 if (!defined wantarray) { # void context
1063 require Config; # add more detail
1064 $version{OS} = "$^O\t($Config::Config{osvers})";
1065 $version{Perl} = "$]\t($Config::Config{archname})";
1066 $version{$_} = (($error{$_} =~ s/ \(\@INC.*//s),$error{$_})
1067 for keys %error;
1068 printf " %-16s: %s\n",$_,$version{$_}
1069 for reverse sort keys %version;
1070 }
1071 return \%version;
1072}
1073
1074
1075sub data_sources {
1076 my ($class, $driver, @other) = @_;
1077 my $drh = $class->install_driver($driver);
1078 my @ds = $drh->data_sources(@other);
1079 return @ds;
1080}
1081
1082
1083sub neat_list {
1084 my ($listref, $maxlen, $sep) = @_;
1085 $maxlen = 0 unless defined $maxlen; # 0 == use internal default
1086 $sep = ", " unless defined $sep;
1087 join($sep, map { neat($_,$maxlen) } @$listref);
1088}
1089
1090
1091sub dump_results { # also aliased as a method in DBD::_::st
1092 my ($sth, $maxlen, $lsep, $fsep, $fh) = @_;
1093 return 0 unless $sth;
1094 $maxlen ||= 35;
1095 $lsep ||= "\n";
1096 $fh ||= \*STDOUT;
1097 my $rows = 0;
1098 my $ref;
1099 while($ref = $sth->fetch) {
1100 print $fh $lsep if $rows++ and $lsep;
1101 my $str = neat_list($ref,$maxlen,$fsep);
1102 print $fh $str; # done on two lines to avoid 5.003 errors
1103 }
1104 print $fh "\n$rows rows".($DBI::err ? " ($DBI::err: $DBI::errstr)" : "")."\n";
1105 $rows;
1106}
1107
1108
1109sub data_diff {
1110 my ($a, $b, $logical) = @_;
1111
1112 my $diff = data_string_diff($a, $b);
1113 return "" if $logical and !$diff;
1114
1115 my $a_desc = data_string_desc($a);
1116 my $b_desc = data_string_desc($b);
1117 return "" if !$diff and $a_desc eq $b_desc;
1118
1119 $diff ||= "Strings contain the same sequence of characters"
1120 if length($a);
1121 $diff .= "\n" if $diff;
1122 return "a: $a_desc\nb: $b_desc\n$diff";
1123}
1124
1125
1126sub data_string_diff {
1127 # Compares 'logical' characters, not bytes, so a latin1 string and an
1128 # an equivalent Unicode string will compare as equal even though their
1129 # byte encodings are different.
1130 my ($a, $b) = @_;
1131 unless (defined $a and defined $b) { # one undef
1132 return ""
1133 if !defined $a and !defined $b;
1134 return "String a is undef, string b has ".length($b)." characters"
1135 if !defined $a;
1136 return "String b is undef, string a has ".length($a)." characters"
1137 if !defined $b;
1138 }
1139
1140 require utf8;
1141 # hack to cater for perl 5.6
1142 *utf8::is_utf8 = sub { (DBI::neat(shift)=~/^"/) } unless defined &utf8::is_utf8;
1143
1144 my @a_chars = (utf8::is_utf8($a)) ? unpack("U*", $a) : unpack("C*", $a);
1145 my @b_chars = (utf8::is_utf8($b)) ? unpack("U*", $b) : unpack("C*", $b);
1146 my $i = 0;
1147 while (@a_chars && @b_chars) {
1148 ++$i, shift(@a_chars), shift(@b_chars), next
1149 if $a_chars[0] == $b_chars[0];# compare ordinal values
1150 my @desc = map {
1151 $_ > 255 ? # if wide character...
1152 sprintf("\\x{%04X}", $_) : # \x{...}
1153 chr($_) =~ /[[:cntrl:]]/ ? # else if control character ...
1154 sprintf("\\x%02X", $_) : # \x..
1155 chr($_) # else as themselves
1156 } ($a_chars[0], $b_chars[0]);
1157 # highlight probable double-encoding?
1158 foreach my $c ( @desc ) {
1159 next unless $c =~ m/\\x\{08(..)}/;
1160 $c .= "='" .chr(hex($1)) ."'"
1161 }
1162 return sprintf "Strings differ at index $i: a[$i]=$desc[0], b[$i]=$desc[1]";
1163 }
1164 return "String a truncated after $i characters" if @b_chars;
1165 return "String b truncated after $i characters" if @a_chars;
1166 return "";
1167}
1168
1169
1170sub data_string_desc { # describe a data string
1171 my ($a) = @_;
1172 require bytes;
1173 require utf8;
1174
1175 # hacks to cater for perl 5.6
1176 *utf8::is_utf8 = sub { (DBI::neat(shift)=~/^"/) } unless defined &utf8::is_utf8;
1177 *utf8::valid = sub { 1 } unless defined &utf8::valid;
1178
1179 # Give sufficient info to help diagnose at least these kinds of situations:
1180 # - valid UTF8 byte sequence but UTF8 flag not set
1181 # (might be ascii so also need to check for hibit to make it worthwhile)
1182 # - UTF8 flag set but invalid UTF8 byte sequence
1183 # could do better here, but this'll do for now
1184 my $utf8 = sprintf "UTF8 %s%s",
1185 utf8::is_utf8($a) ? "on" : "off",
1186 utf8::valid($a||'') ? "" : " but INVALID encoding";
1187 return "$utf8, undef" unless defined $a;
1188 my $is_ascii = $a =~ m/^[\000-\177]*$/;
1189 return sprintf "%s, %s, %d characters %d bytes",
1190 $utf8, $is_ascii ? "ASCII" : "non-ASCII",
1191 length($a), bytes::length($a);
1192}
1193
1194
1195sub connect_test_perf {
1196 my($class, $dsn,$dbuser,$dbpass, $attr) = @_;
1197 Carp::croak("connect_test_perf needs hash ref as fourth arg") unless ref $attr;
1198 # these are non standard attributes just for this special method
1199 my $loops ||= $attr->{dbi_loops} || 5;
1200 my $par ||= $attr->{dbi_par} || 1; # parallelism
1201 my $verb ||= $attr->{dbi_verb} || 1;
1202 my $meth ||= $attr->{dbi_meth} || 'connect';
1203 print "$dsn: testing $loops sets of $par connections:\n";
1204 require "FileHandle.pm"; # don't let toke.c create empty FileHandle package
1205 local $| = 1;
1206 my $drh = $class->install_driver($dsn) or Carp::croak("Can't install $dsn driver\n");
1207 # test the connection and warm up caches etc
1208 $drh->connect($dsn,$dbuser,$dbpass) or Carp::croak("connect failed: $DBI::errstr");
1209 my $t1 = dbi_time();
1210 my $loop;
1211 for $loop (1..$loops) {
1212 my @cons;
1213 print "Connecting... " if $verb;
1214 for (1..$par) {
1215 print "$_ ";
1216 push @cons, ($drh->connect($dsn,$dbuser,$dbpass)
1217 or Carp::croak("connect failed: $DBI::errstr\n"));
1218 }
1219 print "\nDisconnecting...\n" if $verb;
1220 for (@cons) {
1221 $_->disconnect or warn "disconnect failed: $DBI::errstr"
1222 }
1223 }
1224 my $t2 = dbi_time();
1225 my $td = $t2 - $t1;
1226 printf "$meth %d and disconnect them, %d times: %.4fs / %d = %.4fs\n",
1227 $par, $loops, $td, $loops*$par, $td/($loops*$par);
1228 return $td;
1229}
1230
1231
1232# Help people doing DBI->errstr, might even document it one day
1233# XXX probably best moved to cheaper XS code if this gets documented
1234sub err { $DBI::err }
1235sub errstr { $DBI::errstr }
1236
1237
1238# --- Private Internal Function for Creating New DBI Handles
1239
1240# XXX move to PurePerl?
12411400ns*DBI::dr::TIEHASH = \&DBI::st::TIEHASH;
12421100ns*DBI::db::TIEHASH = \&DBI::st::TIEHASH;
1243
1244
1245# These three special constructors are called by the drivers
1246# The way they are called is likely to change.
1247
1248our $shared_profile;
1249
1250
# spent 29µs (12+17) within DBI::_new_drh which was called: # once (12µs+17µs) by DBD::mysql::driver at line 35 of DBD/mysql.pm
sub _new_drh { # called by DBD::<drivername>::driver()
12511500ns my ($class, $initial_attr, $imp_data) = @_;
1252 # Provide default storage for State,Err and Errstr.
1253 # Note that these are shared by all child handles by default! XXX
1254 # State must be undef to get automatic faking in DBI::var::FETCH
125511µs my ($h_state_store, $h_err_store, $h_errstr_store) = (undef, undef, '');
125614µs my $attr = {
1257 # these attributes get copied down to child handles by default
1258 'State' => \$h_state_store, # Holder for DBI::state
1259 'Err' => \$h_err_store, # Holder for DBI::err
1260 'Errstr' => \$h_errstr_store, # Holder for DBI::errstr
1261 'TraceLevel' => 0,
1262 FetchHashKeyName=> 'NAME',
1263 %$initial_attr,
1264 };
1265121µs117µs my ($h, $i) = _new_handle('DBI::dr', '', $attr, $imp_data, $class);
# spent 17µs making 1 call to DBI::_new_handle
1266
1267 # XXX DBI_PROFILE unless DBI::PurePerl because for some reason
1268 # it kills the t/zz_*_pp.t tests (they silently exit early)
126911µs if (($ENV{DBI_PROFILE} && !$DBI::PurePerl) || $shared_profile) {
1270 # The profile object created here when the first driver is loaded
1271 # is shared by all drivers so we end up with just one set of profile
1272 # data and thus the 'total time in DBI' is really the true total.
1273 if (!$shared_profile) { # first time
1274 $h->{Profile} = $ENV{DBI_PROFILE}; # write string
1275 $shared_profile = $h->{Profile}; # read and record object
1276 }
1277 else {
1278 $h->{Profile} = $shared_profile;
1279 }
1280 }
128113µs return $h unless wantarray;
1282 ($h, $i);
1283}
1284
1285
# spent 20µs (8+12) within DBI::_new_dbh which was called: # once (8µs+12µs) by DBD::mysql::dr::connect at line 153 of DBD/mysql.pm
sub _new_dbh { # called by DBD::<drivername>::dr::connect()
12861700ns my ($drh, $attr, $imp_data) = @_;
1287 my $imp_class = $drh->{ImplementorClass}
12881600ns or Carp::croak("DBI _new_dbh: $drh has no ImplementorClass");
128911µs substr($imp_class,-4,4) = '::db';
12901600ns my $app_class = ref $drh;
12911400ns substr($app_class,-4,4) = '::db';
12921500ns $attr->{Err} ||= \my $err;
12931400ns $attr->{Errstr} ||= \my $errstr;
12941400ns $attr->{State} ||= \my $state;
1295115µs112µs _new_handle($app_class, $drh, $attr, $imp_data, $imp_class);
# spent 12µs making 1 call to DBI::_new_handle
1296}
1297
1298
# spent 279µs (101+178) within DBI::_new_sth which was called 15 times, avg 19µs/call: # 15 times (101µs+178µs) by DBD::mysql::db::prepare at line 243 of DBD/mysql.pm, avg 19µs/call
sub _new_sth { # called by DBD::<drivername>::db::prepare)
1299156µs my ($dbh, $attr, $imp_data) = @_;
1300 my $imp_class = $dbh->{ImplementorClass}
13011514µs or Carp::croak("DBI _new_sth: $dbh has no ImplementorClass");
13021517µs substr($imp_class,-4,4) = '::st';
1303158µs my $app_class = ref $dbh;
1304156µs substr($app_class,-4,4) = '::st';
130515232µs15178µs _new_handle($app_class, $dbh, $attr, $imp_data, $imp_class);
# spent 178µs making 15 calls to DBI::_new_handle, avg 12µs/call
1306}
1307
1308
1309# end of DBI package
1310
- -
1313# --------------------------------------------------------------------
1314# === The internal DBI Switch pseudo 'driver' class ===
1315
1316{ package # hide from PAUSE
1317 DBD::Switch::dr;
131811µs153µs DBI->setup_driver('DBD::Switch'); # sets up @ISA
# spent 53µs making 1 call to DBI::setup_driver
1319
13201200ns $DBD::Switch::dr::imp_data_size = 0;
13211100ns $DBD::Switch::dr::imp_data_size = 0; # avoid typo warning
13221300ns my $drh;
1323
1324 sub driver {
1325 return $drh if $drh; # a package global
1326
1327 my $inner;
1328 ($drh, $inner) = DBI::_new_drh('DBD::Switch::dr', {
1329 'Name' => 'Switch',
1330 'Version' => $DBI::VERSION,
1331 'Attribution' => "DBI $DBI::VERSION by Tim Bunce",
1332 });
1333 Carp::croak("DBD::Switch init failed!") unless ($drh && $inner);
1334 return $drh;
1335 }
1336 sub CLONE {
1337 undef $drh;
1338 }
1339
1340 sub FETCH {
1341 my($drh, $key) = @_;
1342 return DBI->trace if $key eq 'DebugDispatch';
1343 return undef if $key eq 'DebugLog'; # not worth fetching, sorry
1344 return $drh->DBD::_::dr::FETCH($key);
1345 undef;
1346 }
1347 sub STORE {
1348 my($drh, $key, $value) = @_;
1349 if ($key eq 'DebugDispatch') {
1350 DBI->trace($value);
1351 } elsif ($key eq 'DebugLog') {
1352 DBI->trace(-1, $value);
1353 } else {
1354 $drh->DBD::_::dr::STORE($key, $value);
1355 }
1356 }
1357}
1358
1359
1360# --------------------------------------------------------------------
1361# === OPTIONAL MINIMAL BASE CLASSES FOR DBI SUBCLASSES ===
1362
1363# We only define default methods for harmless functions.
1364# We don't, for example, define a DBD::_::st::prepare()
1365
13661200ns{ package # hide from PAUSE
1367 DBD::_::common; # ====== Common base class methods ======
13682403µs222µs
# spent 18µs (15+3) within DBD::_::common::BEGIN@1368 which was called: # once (15µs+3µs) by BenchmarkAnything::Storage::Frontend::Lib::connect at line 1368
use strict;
# spent 18µs making 1 call to DBD::_::common::BEGIN@1368 # spent 3µs making 1 call to strict::import
1369
1370 # methods common to all handle types:
1371
1372 # generic TIEHASH default methods:
1373 sub FIRSTKEY { }
1374 sub NEXTKEY { }
137531629231ms3162938.9ms
# spent 155ms (116+38.9) within DBD::_::common::EXISTS which was called 31629 times, avg 5µs/call: # 27629 times (87.0ms+32.7ms) by DBI::common::EXISTS at line 38 of BenchmarkAnything/Storage/Backend/SQL/Query.pm, avg 4µs/call # 2000 times (16.8ms+4.03ms) by DBI::common::EXISTS at line 68 of BenchmarkAnything/Storage/Backend/SQL/Query.pm, avg 10µs/call # 2000 times (12.5ms+2.17ms) by DBI::common::EXISTS at line 94 of BenchmarkAnything/Storage/Backend/SQL/Query.pm, avg 7µs/call
sub EXISTS { defined($_[0]->FETCH($_[1])) } # XXX undef?
# spent 38.9ms making 31629 calls to DBI::common::FETCH, avg 1µs/call
1376 sub CLEAR { Carp::carp "Can't CLEAR $_[0] (DBI)" }
1377
1378 sub FETCH_many { # XXX should move to C one day
1379 my $h = shift;
1380 # scalar is needed to workaround drivers that return an empty list
1381 # for some attributes
1382 return map { scalar $h->FETCH($_) } @_;
1383 }
1384
13851500ns *dump_handle = \&DBI::dump_handle;
1386
1387
# spent 74µs (44+30) within DBD::_::common::install_method which was called 5 times, avg 15µs/call: # once (19µs+11µs) by DBD::mysql::driver at line 43 of DBD/mysql.pm # once (8µs+5µs) by DBD::mysql::driver at line 44 of DBD/mysql.pm # once (6µs+6µs) by DBD::mysql::driver at line 46 of DBD/mysql.pm # once (6µs+5µs) by DBD::mysql::driver at line 47 of DBD/mysql.pm # once (6µs+4µs) by DBD::mysql::driver at line 45 of DBD/mysql.pm
sub install_method {
1388 # special class method called directly by apps and/or drivers
1389 # to install new methods into the DBI dispatcher
1390 # DBD::Foo::db->install_method("foo_mumble", { usage => [...], options => '...' });
139151µs my ($class, $method, $attr) = @_;
1392513µs56µs Carp::croak("Class '$class' must begin with DBD:: and end with ::db or ::st")
# spent 6µs making 5 calls to DBD::_::common::CORE:match, avg 1µs/call
1393 unless $class =~ /^DBD::(\w+)::(dr|db|st)$/;
139453µs my ($driver, $subtype) = ($1, $2);
139557µs53µs Carp::croak("invalid method name '$method'")
# spent 3µs making 5 calls to DBD::_::common::CORE:match, avg 620ns/call
1396 unless $method =~ m/^([a-z][a-z0-9]*_)\w+$/;
139751µs my $prefix = $1;
139852µs my $reg_info = $dbd_prefix_registry->{$prefix};
13995500ns Carp::carp("method name prefix '$prefix' is not associated with a registered driver") unless $reg_info;
1400
140153µs my $full_method = "DBI::${subtype}::$method";
140253µs $DBI::installed_methods{$full_method} = $attr;
1403
140454µs my (undef, $filename, $line) = caller;
1405 # XXX reformat $attr as needed for _install_method
140654µs my %attr = %{$attr||{}}; # copy so we can edit
1407539µs521µs DBI->_install_method("DBI::${subtype}::$method", "$filename at line $line", \%attr);
# spent 21µs making 5 calls to DBI::_install_method, avg 4µs/call
1408 }
1409
1410 sub parse_trace_flags {
1411 my ($h, $spec) = @_;
1412 my $level = 0;
1413 my $flags = 0;
1414 my @unknown;
1415 for my $word (split /\s*[|&,]\s*/, $spec) {
1416 if (DBI::looks_like_number($word) && $word <= 0xF && $word >= 0) {
1417 $level = $word;
1418 } elsif ($word eq 'ALL') {
1419 $flags = 0x7FFFFFFF; # XXX last bit causes negative headaches
1420 last;
1421 } elsif (my $flag = $h->parse_trace_flag($word)) {
1422 $flags |= $flag;
1423 }
1424 else {
1425 push @unknown, $word;
1426 }
1427 }
1428 if (@unknown && (ref $h ? $h->FETCH('Warn') : 1)) {
1429 Carp::carp("$h->parse_trace_flags($spec) ignored unknown trace flags: ".
1430 join(" ", map { DBI::neat($_) } @unknown));
1431 }
1432 $flags |= $level;
1433 return $flags;
1434 }
1435
1436 sub parse_trace_flag {
1437 my ($h, $name) = @_;
1438 # 0xddDDDDrL (driver, DBI, reserved, Level)
1439 return 0x00000100 if $name eq 'SQL';
1440 return 0x00000200 if $name eq 'CON';
1441 return 0x00000400 if $name eq 'ENC';
1442 return 0x00000800 if $name eq 'DBD';
1443 return 0x00001000 if $name eq 'TXN';
1444 return;
1445 }
1446
1447 sub private_attribute_info {
1448 return undef;
1449 }
1450
1451 sub visit_child_handles {
1452 my ($h, $code, $info) = @_;
1453 $info = {} if not defined $info;
1454 for my $ch (@{ $h->{ChildHandles} || []}) {
1455 next unless $ch;
1456 my $child_info = $code->($ch, $info)
1457 or next;
1458 $ch->visit_child_handles($code, $child_info);
1459 }
1460 return $info;
1461 }
1462}
1463
1464
14651200ns{ package # hide from PAUSE
1466 DBD::_::dr; # ====== DRIVER ======
146716µs @DBD::_::dr::ISA = qw(DBD::_::common);
14682214µs212µs
# spent 10µs (8+2) within DBD::_::dr::BEGIN@1468 which was called: # once (8µs+2µs) by BenchmarkAnything::Storage::Frontend::Lib::connect at line 1468
use strict;
# spent 10µs making 1 call to DBD::_::dr::BEGIN@1468 # spent 2µs making 1 call to strict::import
1469
1470 sub default_user {
1471 my ($drh, $user, $pass, $attr) = @_;
1472 $user = $ENV{DBI_USER} unless defined $user;
1473 $pass = $ENV{DBI_PASS} unless defined $pass;
1474 return ($user, $pass);
1475 }
1476
1477 sub connect { # normally overridden, but a handy default
1478 my ($drh, $dsn, $user, $auth) = @_;
1479 my ($this) = DBI::_new_dbh($drh, {
1480 'Name' => $dsn,
1481 });
1482 # XXX debatable as there's no "server side" here
1483 # (and now many uses would trigger warnings on DESTROY)
1484 # $this->STORE(Active => 1);
1485 # so drivers should set it in their own connect
1486 $this;
1487 }
1488
1489
1490 sub connect_cached {
1491 my $drh = shift;
1492 my ($dsn, $user, $auth, $attr) = @_;
1493
1494 my $cache = $drh->{CachedKids} ||= {};
1495 my $key = do { local $^W;
1496 join "!\001", $dsn, $user, $auth, DBI::_concat_hash_sorted($attr, "=\001", ",\001", 0, 0)
1497 };
1498 my $dbh = $cache->{$key};
1499 $drh->trace_msg(sprintf(" connect_cached: key '$key', cached dbh $dbh\n", DBI::neat($key), DBI::neat($dbh)))
1500 if (($DBI::dbi_debug & 0xF) >= 4);
1501
1502 my $cb = $attr->{Callbacks}; # take care not to autovivify
1503 if ($dbh && $dbh->FETCH('Active') && eval { $dbh->ping }) {
1504 # If the caller has provided a callback then call it
1505 if ($cb and $cb = $cb->{"connect_cached.reused"}) {
1506 local $_ = "connect_cached.reused";
1507 $cb->($dbh, $dsn, $user, $auth, $attr);
1508 }
1509 return $dbh;
1510 }
1511
1512 # If the caller has provided a callback then call it
1513 if ($cb and (my $new_cb = $cb->{"connect_cached.new"})) {
1514 local $_ = "connect_cached.new";
1515 $new_cb->($dbh, $dsn, $user, $auth, $attr); # $dbh is dead or undef
1516 }
1517
1518 $dbh = $drh->connect(@_);
1519 $cache->{$key} = $dbh; # replace prev entry, even if connect failed
1520 if ($cb and (my $conn_cb = $cb->{"connect_cached.connected"})) {
1521 local $_ = "connect_cached.connected";
1522 $conn_cb->($dbh, $dsn, $user, $auth, $attr);
1523 }
1524 return $dbh;
1525 }
1526
1527}
1528
1529
15301900ns{ package # hide from PAUSE
1531 DBD::_::db; # ====== DATABASE ======
153214µs @DBD::_::db::ISA = qw(DBD::_::common);
153321.07ms29µs
# spent 8µs (7+1) within DBD::_::db::BEGIN@1533 which was called: # once (7µs+1µs) by BenchmarkAnything::Storage::Frontend::Lib::connect at line 1533
use strict;
# spent 8µs making 1 call to DBD::_::db::BEGIN@1533 # spent 1µs making 1 call to strict::import
1534
1535 sub clone {
1536 my ($old_dbh, $attr) = @_;
1537
1538 my $closure = $old_dbh->{dbi_connect_closure}
1539 or return $old_dbh->set_err($DBI::stderr, "Can't clone handle");
1540
1541 unless ($attr) { # XXX deprecated, caller should always pass a hash ref
1542 # copy attributes visible in the attribute cache
1543 keys %$old_dbh; # reset iterator
1544 while ( my ($k, $v) = each %$old_dbh ) {
1545 # ignore non-code refs, i.e., caches, handles, Err etc
1546 next if ref $v && ref $v ne 'CODE'; # HandleError etc
1547 $attr->{$k} = $v;
1548 }
1549 # explicitly set attributes which are unlikely to be in the
1550 # attribute cache, i.e., boolean's and some others
1551 $attr->{$_} = $old_dbh->FETCH($_) for (qw(
1552 AutoCommit ChopBlanks InactiveDestroy AutoInactiveDestroy
1553 LongTruncOk PrintError PrintWarn Profile RaiseError
1554 ShowErrorStatement TaintIn TaintOut
1555 ));
1556 }
1557
1558 # use Data::Dumper; warn Dumper([$old_dbh, $attr]);
1559 my $new_dbh = &$closure($old_dbh, $attr);
1560 unless ($new_dbh) {
1561 # need to copy err/errstr from driver back into $old_dbh
1562 my $drh = $old_dbh->{Driver};
1563 return $old_dbh->set_err($drh->err, $drh->errstr, $drh->state);
1564 }
1565 $new_dbh->{dbi_connect_closure} = $closure;
1566 return $new_dbh;
1567 }
1568
1569 sub quote_identifier {
1570 my ($dbh, @id) = @_;
1571 my $attr = (@id > 3 && ref($id[-1])) ? pop @id : undef;
1572
1573 my $info = $dbh->{dbi_quote_identifier_cache} ||= [
1574 $dbh->get_info(29) || '"', # SQL_IDENTIFIER_QUOTE_CHAR
1575 $dbh->get_info(41) || '.', # SQL_CATALOG_NAME_SEPARATOR
1576 $dbh->get_info(114) || 1, # SQL_CATALOG_LOCATION
1577 ];
1578
1579 my $quote = $info->[0];
1580 foreach (@id) { # quote the elements
1581 next unless defined;
1582 s/$quote/$quote$quote/g; # escape embedded quotes
1583 $_ = qq{$quote$_$quote};
1584 }
1585
1586 # strip out catalog if present for special handling
1587 my $catalog = (@id >= 3) ? shift @id : undef;
1588
1589 # join the dots, ignoring any null/undef elements (ie schema)
1590 my $quoted_id = join '.', grep { defined } @id;
1591
1592 if ($catalog) { # add catalog correctly
1593 if ($quoted_id) {
1594 $quoted_id = ($info->[2] == 2) # SQL_CL_END
1595 ? $quoted_id . $info->[1] . $catalog
1596 : $catalog . $info->[1] . $quoted_id;
1597 } else {
1598 $quoted_id = $catalog;
1599 }
1600 }
1601 return $quoted_id;
1602 }
1603
1604 sub quote {
1605 my ($dbh, $str, $data_type) = @_;
1606
1607 return "NULL" unless defined $str;
1608 unless ($data_type) {
1609 $str =~ s/'/''/g; # ISO SQL2
1610 return "'$str'";
1611 }
1612
1613 my $dbi_literal_quote_cache = $dbh->{'dbi_literal_quote_cache'} ||= [ {} , {} ];
1614 my ($prefixes, $suffixes) = @$dbi_literal_quote_cache;
1615
1616 my $lp = $prefixes->{$data_type};
1617 my $ls = $suffixes->{$data_type};
1618
1619 if ( ! defined $lp || ! defined $ls ) {
1620 my $ti = $dbh->type_info($data_type);
1621 $lp = $prefixes->{$data_type} = $ti ? $ti->{LITERAL_PREFIX} || "" : "'";
1622 $ls = $suffixes->{$data_type} = $ti ? $ti->{LITERAL_SUFFIX} || "" : "'";
1623 }
1624 return $str unless $lp || $ls; # no quoting required
1625
1626 # XXX don't know what the standard says about escaping
1627 # in the 'general case' (where $lp != "'").
1628 # So we just do this and hope:
1629 $str =~ s/$lp/$lp$lp/g
1630 if $lp && $lp eq $ls && ($lp eq "'" || $lp eq '"');
1631 return "$lp$str$ls";
1632 }
1633
1634 sub rows { -1 } # here so $DBI::rows 'works' after using $dbh
1635
1636 sub do {
1637 my($dbh, $statement, $attr, @params) = @_;
1638 my $sth = $dbh->prepare($statement, $attr) or return undef;
1639 $sth->execute(@params) or return undef;
1640 my $rows = $sth->rows;
1641 ($rows == 0) ? "0E0" : $rows;
1642 }
1643
1644 sub _do_selectrow {
1645 my ($method, $dbh, $stmt, $attr, @bind) = @_;
1646 my $sth = ((ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr))
1647 or return undef;
1648 $sth->execute(@bind)
1649 or return undef;
1650 my $row = $sth->$method()
1651 and $sth->finish;
1652 return $row;
1653 }
1654
1655 sub selectrow_hashref { return _do_selectrow('fetchrow_hashref', @_); }
1656
1657 # XXX selectrow_array/ref also have C implementations in Driver.xst
1658 sub selectrow_arrayref { return _do_selectrow('fetchrow_arrayref', @_); }
1659 sub selectrow_array {
1660 my $row = _do_selectrow('fetchrow_arrayref', @_) or return;
1661 return $row->[0] unless wantarray;
1662 return @$row;
1663 }
1664
1665 # XXX selectall_arrayref also has C implementation in Driver.xst
1666 # which fallsback to this if a slice is given
1667 sub selectall_arrayref {
1668 my ($dbh, $stmt, $attr, @bind) = @_;
1669 my $sth = (ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr)
1670 or return;
1671 $sth->execute(@bind) || return;
1672 my $slice = $attr->{Slice}; # typically undef, else hash or array ref
1673 if (!$slice and $slice=$attr->{Columns}) {
1674 if (ref $slice eq 'ARRAY') { # map col idx to perl array idx
1675 $slice = [ @{$attr->{Columns}} ]; # take a copy
1676 for (@$slice) { $_-- }
1677 }
1678 }
1679 my $rows = $sth->fetchall_arrayref($slice, my $MaxRows = $attr->{MaxRows});
1680 $sth->finish if defined $MaxRows;
1681 return $rows;
1682 }
1683
1684 sub selectall_hashref {
1685 my ($dbh, $stmt, $key_field, $attr, @bind) = @_;
1686 my $sth = (ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr);
1687 return unless $sth;
1688 $sth->execute(@bind) || return;
1689 return $sth->fetchall_hashref($key_field);
1690 }
1691
1692 sub selectcol_arrayref {
1693 my ($dbh, $stmt, $attr, @bind) = @_;
1694 my $sth = (ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr);
1695 return unless $sth;
1696 $sth->execute(@bind) || return;
1697 my @columns = ($attr->{Columns}) ? @{$attr->{Columns}} : (1);
1698 my @values = (undef) x @columns;
1699 my $idx = 0;
1700 for (@columns) {
1701 $sth->bind_col($_, \$values[$idx++]) || return;
1702 }
1703 my @col;
1704 if (my $max = $attr->{MaxRows}) {
1705 push @col, @values while 0 < $max-- && $sth->fetch;
1706 }
1707 else {
1708 push @col, @values while $sth->fetch;
1709 }
1710 return \@col;
1711 }
1712
1713 sub prepare_cached {
1714 my ($dbh, $statement, $attr, $if_active) = @_;
1715
1716 # Needs support at dbh level to clear cache before complaining about
1717 # active children. The XS template code does this. Drivers not using
1718 # the template must handle clearing the cache themselves.
1719 my $cache = $dbh->{CachedKids} ||= {};
1720 my $key = do { local $^W;
1721 join "!\001", $statement, DBI::_concat_hash_sorted($attr, "=\001", ",\001", 0, 0)
1722 };
1723 my $sth = $cache->{$key};
1724
1725 if ($sth) {
1726 return $sth unless $sth->FETCH('Active');
1727 Carp::carp("prepare_cached($statement) statement handle $sth still Active")
1728 unless ($if_active ||= 0);
1729 $sth->finish if $if_active <= 1;
1730 return $sth if $if_active <= 2;
1731 }
1732
1733 $sth = $dbh->prepare($statement, $attr);
1734 $cache->{$key} = $sth if $sth;
1735
1736 return $sth;
1737 }
1738
1739 sub ping {
1740 my $dbh = shift;
1741 # "0 but true" is a special kind of true 0 that is used here so
1742 # applications can check if the ping was a real ping or not
1743 ($dbh->FETCH('Active')) ? "0 but true" : 0;
1744 }
1745
1746 sub begin_work {
1747 my $dbh = shift;
1748 return $dbh->set_err($DBI::stderr, "Already in a transaction")
1749 unless $dbh->FETCH('AutoCommit');
1750 $dbh->STORE('AutoCommit', 0); # will croak if driver doesn't support it
1751 $dbh->STORE('BegunWork', 1); # trigger post commit/rollback action
1752 return 1;
1753 }
1754
1755 sub primary_key {
1756 my ($dbh, @args) = @_;
1757 my $sth = $dbh->primary_key_info(@args) or return;
1758 my ($row, @col);
1759 push @col, $row->[3] while ($row = $sth->fetch);
1760 Carp::croak("primary_key method not called in list context")
1761 unless wantarray; # leave us some elbow room
1762 return @col;
1763 }
1764
1765 sub tables {
1766 my ($dbh, @args) = @_;
1767 my $sth = $dbh->table_info(@args[0,1,2,3,4]) or return;
1768 my $tables = $sth->fetchall_arrayref or return;
1769 my @tables;
1770 if (defined($args[3]) && $args[3] eq '%' # special case for tables('','','','%')
1771 && grep {defined($_) && $_ eq ''} @args[0,1,2]
1772 ) {
1773 @tables = map { $_->[3] } @$tables;
1774 } elsif ($dbh->get_info(29)) { # SQL_IDENTIFIER_QUOTE_CHAR
1775 @tables = map { $dbh->quote_identifier( @{$_}[0,1,2] ) } @$tables;
1776 }
1777 else { # temporary old style hack (yeach)
1778 @tables = map {
1779 my $name = $_->[2];
1780 if ($_->[1]) {
1781 my $schema = $_->[1];
1782 # a sad hack (mostly for Informix I recall)
1783 my $quote = ($schema eq uc($schema)) ? '' : '"';
1784 $name = "$quote$schema$quote.$name"
1785 }
1786 $name;
1787 } @$tables;
1788 }
1789 return @tables;
1790 }
1791
1792 sub type_info { # this should be sufficient for all drivers
1793 my ($dbh, $data_type) = @_;
1794 my $idx_hash;
1795 my $tia = $dbh->{dbi_type_info_row_cache};
1796 if ($tia) {
1797 $idx_hash = $dbh->{dbi_type_info_idx_cache};
1798 }
1799 else {
1800 my $temp = $dbh->type_info_all;
1801 return unless $temp && @$temp;
1802 # we cache here because type_info_all may be expensive to call
1803 # (and we take a copy so the following shift can't corrupt
1804 # the data that may be returned by future calls to type_info_all)
1805 $tia = $dbh->{dbi_type_info_row_cache} = [ @$temp ];
1806 $idx_hash = $dbh->{dbi_type_info_idx_cache} = shift @$tia;
1807 }
1808
1809 my $dt_idx = $idx_hash->{DATA_TYPE} || $idx_hash->{data_type};
1810 Carp::croak("type_info_all returned non-standard DATA_TYPE index value ($dt_idx != 1)")
1811 if $dt_idx && $dt_idx != 1;
1812
1813 # --- simple DATA_TYPE match filter
1814 my @ti;
1815 my @data_type_list = (ref $data_type) ? @$data_type : ($data_type);
1816 foreach $data_type (@data_type_list) {
1817 if (defined($data_type) && $data_type != DBI::SQL_ALL_TYPES()) {
1818 push @ti, grep { $_->[$dt_idx] == $data_type } @$tia;
1819 }
1820 else { # SQL_ALL_TYPES
1821 push @ti, @$tia;
1822 }
1823 last if @ti; # found at least one match
1824 }
1825
1826 # --- format results into list of hash refs
1827 my $idx_fields = keys %$idx_hash;
1828 my @idx_names = map { uc($_) } keys %$idx_hash;
1829 my @idx_values = values %$idx_hash;
1830 Carp::croak "type_info_all result has $idx_fields keys but ".(@{$ti[0]})." fields"
1831 if @ti && @{$ti[0]} != $idx_fields;
1832 my @out = map {
1833 my %h; @h{@idx_names} = @{$_}[ @idx_values ]; \%h;
1834 } @ti;
1835 return $out[0] unless wantarray;
1836 return @out;
1837 }
1838
1839 sub data_sources {
1840 my ($dbh, @other) = @_;
1841 my $drh = $dbh->{Driver}; # XXX proxy issues?
1842 return $drh->data_sources(@other);
1843 }
1844
1845}
1846
1847
18481700ns{ package # hide from PAUSE
1849 DBD::_::st; # ====== STATEMENT ======
185014µs @DBD::_::st::ISA = qw(DBD::_::common);
185121.10ms212µs
# spent 10µs (8+2) within DBD::_::st::BEGIN@1851 which was called: # once (8µs+2µs) by BenchmarkAnything::Storage::Frontend::Lib::connect at line 1851
use strict;
# spent 10µs making 1 call to DBD::_::st::BEGIN@1851 # spent 2µs making 1 call to strict::import
1852
1853 sub bind_param { Carp::croak("Can't bind_param, not implement by driver") }
1854
1855#
1856# ********************************************************
1857#
1858# BEGIN ARRAY BINDING
1859#
1860# Array binding support for drivers which don't support
1861# array binding, but have sufficient interfaces to fake it.
1862# NOTE: mixing scalars and arrayrefs requires using bind_param_array
1863# for *all* params...unless we modify bind_param for the default
1864# case...
1865#
1866# 2002-Apr-10 D. Arnold
1867
1868 sub bind_param_array {
1869 my $sth = shift;
1870 my ($p_id, $value_array, $attr) = @_;
1871
1872 return $sth->set_err($DBI::stderr, "Value for parameter $p_id must be a scalar or an arrayref, not a ".ref($value_array))
1873 if defined $value_array and ref $value_array and ref $value_array ne 'ARRAY';
1874
1875 return $sth->set_err($DBI::stderr, "Can't use named placeholder '$p_id' for non-driver supported bind_param_array")
1876 unless DBI::looks_like_number($p_id); # because we rely on execute(@ary) here
1877
1878 return $sth->set_err($DBI::stderr, "Placeholder '$p_id' is out of range")
1879 if $p_id <= 0; # can't easily/reliably test for too big
1880
1881 # get/create arrayref to hold params
1882 my $hash_of_arrays = $sth->{ParamArrays} ||= { };
1883
1884 # If the bind has attribs then we rely on the driver conforming to
1885 # the DBI spec in that a single bind_param() call with those attribs
1886 # makes them 'sticky' and apply to all later execute(@values) calls.
1887 # Since we only call bind_param() if we're given attribs then
1888 # applications using drivers that don't support bind_param can still
1889 # use bind_param_array() so long as they don't pass any attribs.
1890
1891 $$hash_of_arrays{$p_id} = $value_array;
1892 return $sth->bind_param($p_id, undef, $attr)
1893 if $attr;
1894 1;
1895 }
1896
1897 sub bind_param_inout_array {
1898 my $sth = shift;
1899 # XXX not supported so we just call bind_param_array instead
1900 # and then return an error
1901 my ($p_num, $value_array, $attr) = @_;
1902 $sth->bind_param_array($p_num, $value_array, $attr);
1903 return $sth->set_err($DBI::stderr, "bind_param_inout_array not supported");
1904 }
1905
1906
# spent 41.2ms (18.1+23.1) within DBD::_::st::bind_columns which was called 1000 times, avg 41µs/call: # 1000 times (18.1ms+23.1ms) by DBD::mysql::st::__ANON__[/home/ss5/perl5/perlbrew/perls/perl-5.22.0/lib/site_perl/5.22.0/x86_64-linux/DBD/mysql.pm:881] at line 880 of DBD/mysql.pm, avg 41µs/call
sub bind_columns {
19071000404µs my $sth = shift;
190810002.61ms1000730µs my $fields = $sth->FETCH('NUM_OF_FIELDS') || 0;
# spent 730µs making 1000 calls to DBI::common::FETCH, avg 730ns/call
19091000487µs if ($fields <= 0 && !$sth->{Active}) {
1910 return $sth->set_err($DBI::stderr, "Statement has no result columns to bind"
1911 ." (perhaps you need to successfully call execute first, or again)");
1912 }
1913 # Backwards compatibility for old-style call with attribute hash
1914 # ref as first arg. Skip arg if undef or a hash ref.
19151000256µs my $attr;
191610001.08ms $attr = shift if !defined $_[0] or ref($_[0]) eq 'HASH';
1917
19181000307µs my $idx = 0;
1919100014.1ms400033.9ms $sth->bind_col(++$idx, shift, $attr) or return
# spent 22.4ms making 2000 calls to DBI::st::bind_col, avg 11µs/call # spent 11.5ms making 2000 calls to DBD::mysql::st::__ANON__[DBD/mysql.pm:881], avg 6µs/call
1920 while (@_ and $idx < $fields);
1921
19221000903µs return $sth->set_err($DBI::stderr, "bind_columns called with ".($idx+@_)." values but $fields are needed")
1923 if @_ or $idx != $fields;
1924
192510002.41ms return 1;
1926 }
1927
1928 sub execute_array {
1929 my $sth = shift;
1930 my ($attr, @array_of_arrays) = @_;
1931 my $NUM_OF_PARAMS = $sth->FETCH('NUM_OF_PARAMS'); # may be undef at this point
1932
1933 # get tuple status array or hash attribute
1934 my $tuple_sts = $attr->{ArrayTupleStatus};
1935 return $sth->set_err($DBI::stderr, "ArrayTupleStatus attribute must be an arrayref")
1936 if $tuple_sts and ref $tuple_sts ne 'ARRAY';
1937
1938 # bind all supplied arrays
1939 if (@array_of_arrays) {
1940 $sth->{ParamArrays} = { }; # clear out old params
1941 return $sth->set_err($DBI::stderr,
1942 @array_of_arrays." bind values supplied but $NUM_OF_PARAMS expected")
1943 if defined ($NUM_OF_PARAMS) && @array_of_arrays != $NUM_OF_PARAMS;
1944 $sth->bind_param_array($_, $array_of_arrays[$_-1]) or return
1945 foreach (1..@array_of_arrays);
1946 }
1947
1948 my $fetch_tuple_sub;
1949
1950 if ($fetch_tuple_sub = $attr->{ArrayTupleFetch}) { # fetch on demand
1951
1952 return $sth->set_err($DBI::stderr,
1953 "Can't use both ArrayTupleFetch and explicit bind values")
1954 if @array_of_arrays; # previous bind_param_array calls will simply be ignored
1955
1956 if (UNIVERSAL::isa($fetch_tuple_sub,'DBI::st')) {
1957 my $fetch_sth = $fetch_tuple_sub;
1958 return $sth->set_err($DBI::stderr,
1959 "ArrayTupleFetch sth is not Active, need to execute() it first")
1960 unless $fetch_sth->{Active};
1961 # check column count match to give more friendly message
1962 my $NUM_OF_FIELDS = $fetch_sth->{NUM_OF_FIELDS};
1963 return $sth->set_err($DBI::stderr,
1964 "$NUM_OF_FIELDS columns from ArrayTupleFetch sth but $NUM_OF_PARAMS expected")
1965 if defined($NUM_OF_FIELDS) && defined($NUM_OF_PARAMS)
1966 && $NUM_OF_FIELDS != $NUM_OF_PARAMS;
1967 $fetch_tuple_sub = sub { $fetch_sth->fetchrow_arrayref };
1968 }
1969 elsif (!UNIVERSAL::isa($fetch_tuple_sub,'CODE')) {
1970 return $sth->set_err($DBI::stderr, "ArrayTupleFetch '$fetch_tuple_sub' is not a code ref or statement handle");
1971 }
1972
1973 }
1974 else {
1975 my $NUM_OF_PARAMS_given = keys %{ $sth->{ParamArrays} || {} };
1976 return $sth->set_err($DBI::stderr,
1977 "$NUM_OF_PARAMS_given bind values supplied but $NUM_OF_PARAMS expected")
1978 if defined($NUM_OF_PARAMS) && $NUM_OF_PARAMS != $NUM_OF_PARAMS_given;
1979
1980 # get the length of a bound array
1981 my $maxlen;
1982 my %hash_of_arrays = %{$sth->{ParamArrays}};
1983 foreach (keys(%hash_of_arrays)) {
1984 my $ary = $hash_of_arrays{$_};
1985 next unless ref $ary eq 'ARRAY';
1986 $maxlen = @$ary if !$maxlen || @$ary > $maxlen;
1987 }
1988 # if there are no arrays then execute scalars once
1989 $maxlen = 1 unless defined $maxlen;
1990 my @bind_ids = 1..keys(%hash_of_arrays);
1991
1992 my $tuple_idx = 0;
1993 $fetch_tuple_sub = sub {
1994 return if $tuple_idx >= $maxlen;
1995 my @tuple = map {
1996 my $a = $hash_of_arrays{$_};
1997 ref($a) ? $a->[$tuple_idx] : $a
1998 } @bind_ids;
1999 ++$tuple_idx;
2000 return \@tuple;
2001 };
2002 }
2003 # pass thru the callers scalar or list context
2004 return $sth->execute_for_fetch($fetch_tuple_sub, $tuple_sts);
2005 }
2006
2007 sub execute_for_fetch {
2008 my ($sth, $fetch_tuple_sub, $tuple_status) = @_;
2009 # start with empty status array
2010 ($tuple_status) ? @$tuple_status = () : $tuple_status = [];
2011
2012 my $rc_total = 0;
2013 my $err_count;
2014 while ( my $tuple = &$fetch_tuple_sub() ) {
2015 if ( my $rc = $sth->execute(@$tuple) ) {
2016 push @$tuple_status, $rc;
2017 $rc_total = ($rc >= 0 && $rc_total >= 0) ? $rc_total + $rc : -1;
2018 }
2019 else {
2020 $err_count++;
2021 push @$tuple_status, [ $sth->err, $sth->errstr, $sth->state ];
2022 # XXX drivers implementing execute_for_fetch could opt to "last;" here
2023 # if they know the error code means no further executes will work.
2024 }
2025 }
2026 my $tuples = @$tuple_status;
2027 return $sth->set_err($DBI::stderr, "executing $tuples generated $err_count errors")
2028 if $err_count;
2029 $tuples ||= "0E0";
2030 return $tuples unless wantarray;
2031 return ($tuples, $rc_total);
2032 }
2033
2034
2035
# spent 113ms (42.0+71.2) within DBD::_::st::fetchall_arrayref which was called 1000 times, avg 113µs/call: # 1000 times (42.0ms+71.2ms) by DBI::st::fetchall_arrayref at line 642 of BenchmarkAnything/Storage/Backend/SQL.pm, avg 113µs/call
sub fetchall_arrayref { # ALSO IN Driver.xst
20361000819µs my ($sth, $slice, $max_rows) = @_;
2037
2038 # when batch fetching with $max_rows were very likely to try to
2039 # fetch the 'next batch' after the previous batch returned
2040 # <=$max_rows. So don't treat that as an error.
20411000394µs return undef if $max_rows and not $sth->FETCH('Active');
2042
20431000939µs my $mode = ref($slice) || 'ARRAY';
20441000285µs my @rows;
2045
20461000551µs if ($mode eq 'ARRAY') {
2047 my $row;
2048 # we copy the array here because fetch (currently) always
2049 # returns the same array ref. XXX
2050 if ($slice && @$slice) {
2051 $max_rows = -1 unless defined $max_rows;
2052 push @rows, [ @{$row}[ @$slice] ]
2053 while($max_rows-- and $row = $sth->fetch);
2054 }
2055 elsif (defined $max_rows) {
2056 push @rows, [ @$row ]
2057 while($max_rows-- and $row = $sth->fetch);
2058 }
2059 else {
2060 push @rows, [ @$row ] while($row = $sth->fetch);
2061 }
2062 return \@rows
2063 }
2064
20651000313µs my %row;
206610001.61ms if ($mode eq 'REF' && ref($$slice) eq 'HASH') { # \{ $idx => $name }
2067 keys %$$slice; # reset the iterator
2068 while ( my ($idx, $name) = each %$$slice ) {
2069 $sth->bind_col($idx+1, \$row{$name});
2070 }
2071 }
2072 elsif ($mode eq 'HASH') {
207310001.13ms if (keys %$slice) { # resets the iterator
2074 my $name2idx = $sth->FETCH('NAME_lc_hash');
2075 while ( my ($name, $unused) = each %$slice ) {
2076 my $idx = $name2idx->{lc $name};
2077 return $sth->set_err($DBI::stderr, "Invalid column name '$name' for slice")
2078 if not defined $idx;
2079 $sth->bind_col($idx+1, \$row{$name});
2080 }
2081 }
2082 else {
2083100026.7ms4000116ms $sth->bind_columns( \( @row{ @{$sth->FETCH($sth->FETCH('FetchHashKeyName')) } } ) );
# spent 60.9ms making 1000 calls to DBI::st::bind_columns, avg 61µs/call # spent 51.6ms making 1000 calls to DBD::mysql::st::__ANON__[DBD/mysql.pm:881], avg 52µs/call # spent 3.94ms making 2000 calls to DBI::common::FETCH, avg 2µs/call
2084 }
2085 }
2086 else {
2087 return $sth->set_err($DBI::stderr, "fetchall_arrayref($mode) invalid");
2088 }
2089
2090100019.7ms56506.37ms if (not defined $max_rows) {
# spent 6.37ms making 5650 calls to DBI::st::fetch, avg 1µs/call
2091 push @rows, { %row } while ($sth->fetch); # full speed ahead!
2092 }
2093 else {
2094 push @rows, { %row } while ($max_rows-- and $sth->fetch);
2095 }
2096
209710002.88ms return \@rows;
2098 }
2099
2100 sub fetchall_hashref {
2101 my ($sth, $key_field) = @_;
2102
2103 my $hash_key_name = $sth->{FetchHashKeyName} || 'NAME';
2104 my $names_hash = $sth->FETCH("${hash_key_name}_hash");
2105 my @key_fields = (ref $key_field) ? @$key_field : ($key_field);
2106 my @key_indexes;
2107 my $num_of_fields = $sth->FETCH('NUM_OF_FIELDS');
2108 foreach (@key_fields) {
2109 my $index = $names_hash->{$_}; # perl index not column
2110 $index = $_ - 1 if !defined $index && DBI::looks_like_number($_) && $_>=1 && $_ <= $num_of_fields;
2111 return $sth->set_err($DBI::stderr, "Field '$_' does not exist (not one of @{[keys %$names_hash]})")
2112 unless defined $index;
2113 push @key_indexes, $index;
2114 }
2115 my $rows = {};
2116 my $NAME = $sth->FETCH($hash_key_name);
2117 my @row = (undef) x $num_of_fields;
2118 $sth->bind_columns(\(@row));
2119 while ($sth->fetch) {
2120 my $ref = $rows;
2121 $ref = $ref->{$row[$_]} ||= {} for @key_indexes;
2122 @{$ref}{@$NAME} = @row;
2123 }
2124 return $rows;
2125 }
2126
212711µs *dump_results = \&DBI::dump_results;
2128
2129 sub blob_copy_to_file { # returns length or undef on error
2130 my($self, $field, $filename_or_handleref, $blocksize) = @_;
2131 my $fh = $filename_or_handleref;
2132 my($len, $buf) = (0, "");
2133 $blocksize ||= 512; # not too ambitious
2134 local(*FH);
2135 unless(ref $fh) {
2136 open(FH, ">$fh") || return undef;
2137 $fh = \*FH;
2138 }
2139 while(defined($self->blob_read($field, $len, $blocksize, \$buf))) {
2140 print $fh $buf;
2141 $len += length $buf;
2142 }
2143 close(FH);
2144 $len;
2145 }
2146
2147 sub more_results {
2148 shift->{syb_more_results}; # handy grandfathering
2149 }
2150
2151}
2152
215321µsunless ($DBI::PurePerl) { # See install_driver
215416µs { @DBD::_mem::dr::ISA = qw(DBD::_mem::common); }
215524µs { @DBD::_mem::db::ISA = qw(DBD::_mem::common); }
215635µs { @DBD::_mem::st::ISA = qw(DBD::_mem::common); }
2157 # DBD::_mem::common::DESTROY is implemented in DBI.xs
2158}
2159
2160157µs1;
2161__END__
 
# spent 10µs within DBD::_::common::CORE:match which was called 10 times, avg 950ns/call: # 5 times (6µs+0s) by DBD::_::common::install_method at line 1392, avg 1µs/call # 5 times (3µs+0s) by DBD::_::common::install_method at line 1395, avg 620ns/call
sub DBD::_::common::CORE:match; # opcode
# spent 2µs within DBD::_::common::trace_msg which was called: # once (2µs+0s) by DBI::END at line 541
sub DBD::_::common::trace_msg; # xsub
# spent 1.80ms within DBD::_::st::bind_col which was called 2000 times, avg 899ns/call: # 2000 times (1.80ms+0s) by DBD::mysql::st::__ANON__[/home/ss5/perl5/perlbrew/perls/perl-5.22.0/lib/site_perl/5.22.0/x86_64-linux/DBD/mysql.pm:881] at line 880 of DBD/mysql.pm, avg 899ns/call
sub DBD::_::st::bind_col; # xsub
# spent 229ms (153+76.6) within DBD::_::st::fetchrow_hashref which was called 18950 times, avg 12µs/call: # 18950 times (153ms+76.6ms) by DBD::mysql::st::__ANON__[/home/ss5/perl5/perlbrew/perls/perl-5.22.0/lib/site_perl/5.22.0/x86_64-linux/DBD/mysql.pm:870] at line 869 of DBD/mysql.pm, avg 12µs/call
sub DBD::_::st::fetchrow_hashref; # xsub
# spent 6µs within DBI::CORE:match which was called 127 times, avg 43ns/call: # 127 times (6µs+0s) by DBI::BEGIN@181 at line 282, avg 43ns/call
sub DBI::CORE:match; # opcode
# spent 8µs within DBI::CORE:subst which was called 2 times, avg 4µs/call: # once (8µs+0s) by DBI::connect at line 621 # once (400ns+0s) by DBI::install_driver at line 781
sub DBI::CORE:subst; # opcode
# spent 196µs within DBI::_install_method which was called 94 times, avg 2µs/call: # 89 times (175µs+0s) by BenchmarkAnything::Storage::Frontend::Lib::connect at line 524, avg 2µs/call # 5 times (21µs+0s) by DBD::_::common::install_method at line 1407, avg 4µs/call
sub DBI::_install_method; # xsub
# spent 207µs within DBI::_new_handle which was called 17 times, avg 12µs/call: # 15 times (178µs+0s) by DBI::_new_sth at line 1305, avg 12µs/call # once (17µs+0s) by DBI::_new_drh at line 1265 # once (12µs+0s) by DBI::_new_dbh at line 1295
sub DBI::_new_handle; # xsub
# spent 173µs within DBI::bootstrap which was called: # once (173µs+0s) by DynaLoader::bootstrap at line 216 of DynaLoader.pm
sub DBI::bootstrap; # xsub