← Index
NYTProf Performance Profile   « block view • line view • sub view »
For reply.pl
  Run on Thu Oct 21 22:40:13 2010
Reported on Thu Oct 21 22:44:38 2010

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