← Index
NYTProf Performance Profile   « block view • line view • sub view »
For xt/tapper-mcp-scheduler-with-db-longrun.t
  Run on Tue May 22 17:18:39 2012
Reported on Tue May 22 17:24:03 2012

Filename/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/x86_64-linux/DBI.pm
StatementsExecuted 67843 statements in 305ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
801911185ms280msDBD::_::db::::prepare_cached DBD::_::db::prepare_cached
80191123.7ms23.7msDBI::::_concat_hash_sorted DBI::_concat_hash_sorted (xsub)
89983221.9ms21.9msDBI::::SQL_INTEGER DBI::SQL_INTEGER (xsub)
152317.34ms7.34msDBI::::_new_handle DBI::_new_handle (xsub)
294114.89ms9.39msDBD::_::db::::begin_work DBD::_::db::begin_work
145113.66ms10.8msDBI::::_new_sth DBI::_new_sth
1112.46ms3.91msDBI::::install_driver DBI::install_driver
611486µs2.79msDBI::::__ANON__[:725] DBI::__ANON__[:725]
611399µs7.17msDBI::::connect DBI::connect
10421383µs383µsDBI::::_install_method DBI::_install_method (xsub)
111290µs290µsDBI::::bootstrap DBI::bootstrap (xsub)
111282µs949µsDBI::::BEGIN@161 DBI::BEGIN@161
15151200µs336µsDBD::_::common::::install_method DBD::_::common::install_method
332155µs182µsDBI::::setup_driver DBI::setup_driver
611111µs292µsDBI::::_new_dbh DBI::_new_dbh
11183µs132µsDBI::::END DBI::END
72156µs56µsDBI::::CORE:subst DBI::CORE:subst (opcode)
302144µs44µsDBD::_::common::::CORE:match DBD::_::common::CORE:match (opcode)
1271134µs34µsDBI::::CORE:match DBI::CORE:match (opcode)
11132µs45µsDBI::::disconnect_all DBI::disconnect_all
11123µs63µsDBI::::_new_drh DBI::_new_drh
21123µs60µsDBD::_::db::::ping DBD::_::db::ping
55117µs17µsDBI::var::::TIESCALAR DBI::var::TIESCALAR
21117µs22µsDBD::_::common::::_not_impl DBD::_::common::_not_impl
11116µs16µsDBI::::BEGIN@13 DBI::BEGIN@13
11115µs18µsDBD::_::dr::::BEGIN@1449 DBD::_::dr::BEGIN@1449
81114µs14µsDBI::::SQL_UNKNOWN_TYPE DBI::SQL_UNKNOWN_TYPE (xsub)
41114µs14µsDBD::_::common::::FIRSTKEY DBD::_::common::FIRSTKEY
11112µs14µsDBD::_::db::::BEGIN@1510 DBD::_::db::BEGIN@1510
11111µs17µsDBI::::BEGIN@270 DBI::BEGIN@270
11110µs18µsDBI::::BEGIN@1030 DBI::BEGIN@1030
11110µs18µsDBI::::BEGIN@862 DBI::BEGIN@862
11110µs14µsDBD::_::common::::BEGIN@1343 DBD::_::common::BEGIN@1343
11110µs13µsDBD::_::st::::BEGIN@1821 DBD::_::st::BEGIN@1821
1119µs12µsDBI::::BEGIN@274 DBI::BEGIN@274
1117µs16µsDBI::::BEGIN@684 DBI::BEGIN@684
1117µs14µsDBI::::BEGIN@959 DBI::BEGIN@959
1117µs15µsDBI::::BEGIN@797 DBI::BEGIN@797
1116µs23µsDBI::::BEGIN@527 DBI::BEGIN@527
1116µs14µsDBI::::BEGIN@831 DBI::BEGIN@831
1115µs5µsDBD::_::common::::trace_msg DBD::_::common::trace_msg (xsub)
1113µs3µsDBI::::BEGIN@157 DBI::BEGIN@157
1113µs3µsDBI::::BEGIN@159 DBI::BEGIN@159
1113µs3µsDBI::::BEGIN@158 DBI::BEGIN@158
2111µs1µsDBI::::SQL_BLOB DBI::SQL_BLOB (xsub)
2111µs1µsDBI::::SQL_DECIMAL DBI::SQL_DECIMAL (xsub)
111600ns600nsDBI::::SQL_LONGVARCHAR DBI::SQL_LONGVARCHAR (xsub)
111600ns600nsDBI::::SQL_NUMERIC DBI::SQL_NUMERIC (xsub)
111600ns600nsDBI::::SQL_VARBINARY DBI::SQL_VARBINARY (xsub)
111500ns500nsDBI::::SQL_BINARY DBI::SQL_BINARY (xsub)
111500ns500nsDBI::::SQL_DATETIME DBI::SQL_DATETIME (xsub)
111500ns500nsDBI::::SQL_SMALLINT DBI::SQL_SMALLINT (xsub)
111500ns500nsDBI::::SQL_TIME DBI::SQL_TIME (xsub)
111500ns500nsDBI::::SQL_VARCHAR DBI::SQL_VARCHAR (xsub)
111400ns400nsDBI::::SQL_BIT DBI::SQL_BIT (xsub)
111400ns400nsDBI::::SQL_CHAR DBI::SQL_CHAR (xsub)
111400ns400nsDBI::::SQL_DATE DBI::SQL_DATE (xsub)
111400ns400nsDBI::::SQL_DOUBLE DBI::SQL_DOUBLE (xsub)
111400ns400nsDBI::::SQL_TIMESTAMP DBI::SQL_TIMESTAMP (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::::NEXTKEY DBD::_::common::NEXTKEY
0000s0sDBD::_::common::::parse_trace_flag DBD::_::common::parse_trace_flag
0000s0sDBD::_::common::::parse_trace_flags DBD::_::common::parse_trace_flags
0000s0sDBD::_::common::::private_attribute_info DBD::_::common::private_attribute_info
0000s0sDBD::_::common::::visit_child_handles DBD::_::common::visit_child_handles
0000s0sDBD::_::db::::_do_selectrow DBD::_::db::_do_selectrow
0000s0sDBD::_::db::::clone DBD::_::db::clone
0000s0sDBD::_::db::::data_sources DBD::_::db::data_sources
0000s0sDBD::_::db::::do DBD::_::db::do
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__[:1937] DBD::_::st::__ANON__[:1937]
0000s0sDBD::_::st::::__ANON__[:1971] DBD::_::st::__ANON__[:1971]
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::::__ANON__[:1026] DBI::__ANON__[:1026]
0000s0sDBI::::__ANON__[:1117] DBI::__ANON__[:1117]
0000s0sDBI::::__ANON__[:1151] DBI::__ANON__[:1151]
0000s0sDBI::::__ANON__[:1152] DBI::__ANON__[:1152]
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 15300 2012-04-25 12:29:58Z timbo $
2# vim: ts=8:sw=4:et
3#
4# Copyright (c) 1994-2012 Tim Bunce Ireland
5#
6# See COPYRIGHT section in pod text below for usage and distribution rights.
7#
8
9package DBI;
10
11129µsrequire 5.008_001;
12
13
# spent 16µs within DBI::BEGIN@13 which was called: # once (16µs+0s) by DBIx::Class::Storage::DBI::__ANON__[/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/DBIx/Class/Storage/DBI.pm:1300] at line 15
BEGIN {
1415µs$VERSION = "1.620"; # ==> ALSO update the version in the pod text below!
15167µs116µs}
# spent 16µs making 1 call to DBI::BEGIN@13
16
17=head1 NAME
18
19DBI - Database independent interface for Perl
20
21=head1 SYNOPSIS
22
23 use DBI;
24
25 @driver_names = DBI->available_drivers;
26 %drivers = DBI->installed_drivers;
27 @data_sources = DBI->data_sources($driver_name, \%attr);
28
29 $dbh = DBI->connect($data_source, $username, $auth, \%attr);
30
31 $rv = $dbh->do($statement);
32 $rv = $dbh->do($statement, \%attr);
33 $rv = $dbh->do($statement, \%attr, @bind_values);
34
35 $ary_ref = $dbh->selectall_arrayref($statement);
36 $hash_ref = $dbh->selectall_hashref($statement, $key_field);
37
38 $ary_ref = $dbh->selectcol_arrayref($statement);
39 $ary_ref = $dbh->selectcol_arrayref($statement, \%attr);
40
41 @row_ary = $dbh->selectrow_array($statement);
42 $ary_ref = $dbh->selectrow_arrayref($statement);
43 $hash_ref = $dbh->selectrow_hashref($statement);
44
45 $sth = $dbh->prepare($statement);
46 $sth = $dbh->prepare_cached($statement);
47
48 $rc = $sth->bind_param($p_num, $bind_value);
49 $rc = $sth->bind_param($p_num, $bind_value, $bind_type);
50 $rc = $sth->bind_param($p_num, $bind_value, \%attr);
51
52 $rv = $sth->execute;
53 $rv = $sth->execute(@bind_values);
54 $rv = $sth->execute_array(\%attr, ...);
55
56 $rc = $sth->bind_col($col_num, \$col_variable);
57 $rc = $sth->bind_columns(@list_of_refs_to_vars_to_bind);
58
59 @row_ary = $sth->fetchrow_array;
60 $ary_ref = $sth->fetchrow_arrayref;
61 $hash_ref = $sth->fetchrow_hashref;
62
63 $ary_ref = $sth->fetchall_arrayref;
64 $ary_ref = $sth->fetchall_arrayref( $slice, $max_rows );
65
66 $hash_ref = $sth->fetchall_hashref( $key_field );
67
68 $rv = $sth->rows;
69
70 $rc = $dbh->begin_work;
71 $rc = $dbh->commit;
72 $rc = $dbh->rollback;
73
74 $quoted_string = $dbh->quote($string);
75
76 $rc = $h->err;
77 $str = $h->errstr;
78 $rv = $h->state;
79
80 $rc = $dbh->disconnect;
81
82I<The synopsis above only lists the major methods and parameters.>
83
84
85=head2 GETTING HELP
86
87If you have questions about DBI, or DBD driver modules, you can get
88help from the I<dbi-users@perl.org> mailing list. You don't have to subscribe
89to the list in order to post, though I'd recommend it. You can get help on
90subscribing and using the list by emailing I<dbi-users-help@perl.org>.
91
92I don't recommend the DBI cpanforum (at http://www.cpanforum.com/dist/DBI)
93because relatively few people read it compared with dbi-users@perl.org.
94
95To help you make the best use of the dbi-users mailing list,
96and any other lists or forums you may use, I recommend that you read
97"Getting Answers" by Mike Ash: L<http://mikeash.com/getting_answers.html>.
98
99If you think you've found a bug then please also read
100"How to Report Bugs Effectively" by Simon Tatham:
101L<http://www.chiark.greenend.org.uk/~sgtatham/bugs.html>.
102
103The DBI home page at L<http://dbi.perl.org/> and the DBI FAQ
104at L<http://faq.dbi-support.com/> may be worth a visit.
105They include links to other resources, but are rather out-dated.
106
107Before asking any questions, reread this document, consult the
108archives and read the DBI FAQ. The archives are listed
109at the end of this document and on the DBI home page.
110
111You might also like to read the Advanced DBI Tutorial at
112L<http://www.slideshare.net/Tim.Bunce/dbi-advanced-tutorial-2007>
113
114This document often uses terms like I<references>, I<objects>,
115I<methods>. If you're not familiar with those terms then it would
116be a good idea to read at least the following perl manuals first:
117L<perlreftut>, L<perldsc>, L<perllol>, and L<perlboot>.
118
119Please note that Tim Bunce does not maintain the mailing lists or the
120web page (generous volunteers do that). So please don't send mail
121directly to him; he just doesn't have the time to answer questions
122personally. The I<dbi-users> mailing list has lots of experienced
123people who should be able to help you if you need it. If you do email
124Tim he is very likely to just forward it to the mailing list.
125
126=head2 NOTES
127
128This is the DBI specification that corresponds to DBI version 1.620
129(see L<DBI::Changes> for details).
130
131The DBI is evolving at a steady pace, so it's good to check that
132you have the latest copy.
133
134The significant user-visible changes in each release are documented
135in the L<DBI::Changes> module so you can read them by executing
136C<perldoc DBI::Changes>.
137
138Some DBI changes require changes in the drivers, but the drivers
139can take some time to catch up. Newer versions of the DBI have
140added features that may not yet be supported by the drivers you
141use. Talk to the authors of your drivers if you need a new feature
142that is not yet supported.
143
144Features added after DBI 1.21 (February 2002) are marked in the
145text with the version number of the DBI release they first appeared in.
146
147Extensions to the DBI API often use the C<DBIx::*> namespace.
148See L</Naming Conventions and Name Space>. DBI extension modules
149can be found at L<http://search.cpan.org/search?mode=module&query=DBIx>.
150And all modules related to the DBI can be found at
151L<http://search.cpan.org/search?query=DBI&mode=all>.
152
153=cut
154
155# The POD text continues at the end of the file.
156
157317µs13µs
# spent 3µs within DBI::BEGIN@157 which was called: # once (3µs+0s) by DBIx::Class::Storage::DBI::__ANON__[/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/DBIx/Class/Storage/DBI.pm:1300] at line 157
use Carp();
# spent 3µs making 1 call to DBI::BEGIN@157
158324µs13µs
# spent 3µs within DBI::BEGIN@158 which was called: # once (3µs+0s) by DBIx::Class::Storage::DBI::__ANON__[/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/DBIx/Class/Storage/DBI.pm:1300] at line 158
use DynaLoader ();
# spent 3µs making 1 call to DBI::BEGIN@158
1593238µs13µs
# spent 3µs within DBI::BEGIN@159 which was called: # once (3µs+0s) by DBIx::Class::Storage::DBI::__ANON__[/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/DBIx/Class/Storage/DBI.pm:1300] at line 159
use Exporter ();
# spent 3µs making 1 call to DBI::BEGIN@159
160
161
# spent 949µs (282+666) within DBI::BEGIN@161 which was called: # once (282µs+666µs) by DBIx::Class::Storage::DBI::__ANON__[/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/DBIx/Class/Storage/DBI.pm:1300] at line 266
BEGIN {
162115µs@ISA = qw(Exporter DynaLoader);
163
164# Make some utility functions available if asked for
1651300ns@EXPORT = (); # we export nothing by default
1661800ns@EXPORT_OK = qw(%DBI %DBI_methods hash); # also populated by export_ok_tags:
167120µs%EXPORT_TAGS = (
168 sql_types => [ qw(
169 SQL_GUID
170 SQL_WLONGVARCHAR
171 SQL_WVARCHAR
172 SQL_WCHAR
173 SQL_BIGINT
174 SQL_BIT
175 SQL_TINYINT
176 SQL_LONGVARBINARY
177 SQL_VARBINARY
178 SQL_BINARY
179 SQL_LONGVARCHAR
180 SQL_UNKNOWN_TYPE
181 SQL_ALL_TYPES
182 SQL_CHAR
183 SQL_NUMERIC
184 SQL_DECIMAL
185 SQL_INTEGER
186 SQL_SMALLINT
187 SQL_FLOAT
188 SQL_REAL
189 SQL_DOUBLE
190 SQL_DATETIME
191 SQL_DATE
192 SQL_INTERVAL
193 SQL_TIME
194 SQL_TIMESTAMP
195 SQL_VARCHAR
196 SQL_BOOLEAN
197 SQL_UDT
198 SQL_UDT_LOCATOR
199 SQL_ROW
200 SQL_REF
201 SQL_BLOB
202 SQL_BLOB_LOCATOR
203 SQL_CLOB
204 SQL_CLOB_LOCATOR
205 SQL_ARRAY
206 SQL_ARRAY_LOCATOR
207 SQL_MULTISET
208 SQL_MULTISET_LOCATOR
209 SQL_TYPE_DATE
210 SQL_TYPE_TIME
211 SQL_TYPE_TIMESTAMP
212 SQL_TYPE_TIME_WITH_TIMEZONE
213 SQL_TYPE_TIMESTAMP_WITH_TIMEZONE
214 SQL_INTERVAL_YEAR
215 SQL_INTERVAL_MONTH
216 SQL_INTERVAL_DAY
217 SQL_INTERVAL_HOUR
218 SQL_INTERVAL_MINUTE
219 SQL_INTERVAL_SECOND
220 SQL_INTERVAL_YEAR_TO_MONTH
221 SQL_INTERVAL_DAY_TO_HOUR
222 SQL_INTERVAL_DAY_TO_MINUTE
223 SQL_INTERVAL_DAY_TO_SECOND
224 SQL_INTERVAL_HOUR_TO_MINUTE
225 SQL_INTERVAL_HOUR_TO_SECOND
226 SQL_INTERVAL_MINUTE_TO_SECOND
227 DBIstcf_DISCARD_STRING
228 DBIstcf_STRICT
229 ) ],
230 sql_cursor_types => [ qw(
231 SQL_CURSOR_FORWARD_ONLY
232 SQL_CURSOR_KEYSET_DRIVEN
233 SQL_CURSOR_DYNAMIC
234 SQL_CURSOR_STATIC
235 SQL_CURSOR_TYPE_DEFAULT
236 ) ], # for ODBC cursor types
237 utils => [ qw(
238 neat neat_list $neat_maxlen dump_results looks_like_number
239 data_string_diff data_string_desc data_diff sql_type_cast
240 ) ],
241 profile => [ qw(
242 dbi_profile dbi_profile_merge dbi_profile_merge_nodes dbi_time
243 ) ], # notionally "in" DBI::Profile and normally imported from there
244);
245
2461300ns$DBI::dbi_debug = 0; # mixture of bit fields and int sub-fields
2471200ns$DBI::neat_maxlen = 1000;
2481200ns$DBI::stderr = 2_000_000_000; # a very round number below 2**31
249
250# If you get an error here like "Can't find loadable object ..."
251# then you haven't installed the DBI correctly. Read the README
252# then install it again.
25311µsif ( $ENV{DBI_PUREPERL} ) {
254 eval { bootstrap DBI } if $ENV{DBI_PUREPERL} == 1;
255 require DBI::PurePerl if $@ or $ENV{DBI_PUREPERL} >= 2;
256 $DBI::PurePerl ||= 0; # just to silence "only used once" warnings
257}
258else {
25917µs1566µs bootstrap DBI;
# spent 566µs making 1 call to DynaLoader::bootstrap
260}
261
262128259µs12734µs$EXPORT_TAGS{preparse_flags} = [ grep { /^DBIpp_\w\w_/ } keys %{__PACKAGE__."::"} ];
# spent 34µs making 127 calls to DBI::CORE:match, avg 267ns/call
263
26419µs124µsExporter::export_ok_tags(keys %EXPORT_TAGS);
# spent 24µs making 1 call to Exporter::export_ok_tags
265
266152µs1949µs}
# spent 949µs making 1 call to DBI::BEGIN@161
267
268# Alias some handle methods to also be DBI class methods
26912µsfor (qw(trace_msg set_err parse_trace_flag parse_trace_flags)) {
270344µs223µs
# spent 17µs (11+6) within DBI::BEGIN@270 which was called: # once (11µs+6µs) by DBIx::Class::Storage::DBI::__ANON__[/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/DBIx/Class/Storage/DBI.pm:1300] at line 270
no strict;
# spent 17µs making 1 call to DBI::BEGIN@270 # spent 6µs making 1 call to strict::unimport
271417µs *$_ = \&{"DBD::_::common::$_"};
272}
273
27431.01ms215µs
# spent 12µs (9+3) within DBI::BEGIN@274 which was called: # once (9µs+3µs) by DBIx::Class::Storage::DBI::__ANON__[/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/DBIx/Class/Storage/DBI.pm:1300] at line 274
use strict;
# spent 12µs making 1 call to DBI::BEGIN@274 # spent 3µs making 1 call to strict::import
275
27611µsDBI->trace(split /=/, $ENV{DBI_TRACE}, 2) if $ENV{DBI_TRACE};
277
2781700ns$DBI::connect_via ||= "connect";
279
280# check if user wants a persistent database connection ( Apache + mod_perl )
28111µsif ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
282 $DBI::connect_via = "Apache::DBI::connect";
283 DBI->trace_msg("DBI connect via $DBI::connect_via in $INC{'Apache/DBI.pm'}\n");
284}
285
286# check for weaken support, used by ChildHandles
2871900nsmy $HAS_WEAKEN = eval {
28811µs require Scalar::Util;
289 # this will croak() if this Scalar::Util doesn't have a working weaken().
290110µs13µs Scalar::Util::weaken( \my $test ); # same test as in t/72childhandles.t
# spent 3µs making 1 call to Scalar::Util::weaken
29112µs 1;
292};
293
29411µs%DBI::installed_drh = (); # maps driver names to installed driver handles
295sub installed_drivers { %DBI::installed_drh }
2961300ns%DBI::installed_methods = (); # XXX undocumented, may change
297sub installed_methods { %DBI::installed_methods }
298
299# Setup special DBI dynamic variables. See DBI::var::FETCH for details.
300# These are dynamically associated with the last handle used.
30116µs111µstie $DBI::err, 'DBI::var', '*err'; # special case: referenced via IHA list
# spent 11µs making 1 call to DBI::var::TIESCALAR
30213µs12µstie $DBI::state, 'DBI::var', '"state'; # special case: referenced via IHA list
# spent 2µs making 1 call to DBI::var::TIESCALAR
30312µs11µstie $DBI::lasth, 'DBI::var', '!lasth'; # special case: return boolean
# spent 1µs making 1 call to DBI::var::TIESCALAR
30412µs11µstie $DBI::errstr, 'DBI::var', '&errstr'; # call &errstr in last used pkg
# spent 1µs making 1 call to DBI::var::TIESCALAR
30512µs11µstie $DBI::rows, 'DBI::var', '&rows'; # call &rows in last used pkg
# spent 1µs making 1 call to DBI::var::TIESCALAR
3061028µs
# spent 17µs within DBI::var::TIESCALAR which was called 5 times, avg 3µs/call: # once (11µs+0s) by DBIx::Class::Storage::DBI::__ANON__[/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/DBIx/Class/Storage/DBI.pm:1300] at line 301 # once (2µs+0s) by DBIx::Class::Storage::DBI::__ANON__[/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/DBIx/Class/Storage/DBI.pm:1300] at line 302 # once (1µs+0s) by DBIx::Class::Storage::DBI::__ANON__[/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/DBIx/Class/Storage/DBI.pm:1300] at line 305 # once (1µs+0s) by DBIx::Class::Storage::DBI::__ANON__[/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/DBIx/Class/Storage/DBI.pm:1300] at line 303 # once (1µs+0s) by DBIx::Class::Storage::DBI::__ANON__[/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/DBIx/Class/Storage/DBI.pm:1300] at line 304
sub DBI::var::TIESCALAR{ my $var = $_[1]; bless \$var, 'DBI::var'; }
307sub DBI::var::STORE { Carp::croak("Can't modify \$DBI::${$_[0]} special variable") }
308
309# --- Driver Specific Prefix Registry ---
310
311155µsmy $dbd_prefix_registry = {
312 ad_ => { class => 'DBD::AnyData', },
313 ado_ => { class => 'DBD::ADO', },
314 amzn_ => { class => 'DBD::Amazon', },
315 best_ => { class => 'DBD::BestWins', },
316 csv_ => { class => 'DBD::CSV', },
317 db2_ => { class => 'DBD::DB2', },
318 dbi_ => { class => 'DBI', },
319 dbm_ => { class => 'DBD::DBM', },
320 df_ => { class => 'DBD::DF', },
321 f_ => { class => 'DBD::File', },
322 file_ => { class => 'DBD::TextFile', },
323 go_ => { class => 'DBD::Gofer', },
324 ib_ => { class => 'DBD::InterBase', },
325 ing_ => { class => 'DBD::Ingres', },
326 ix_ => { class => 'DBD::Informix', },
327 jdbc_ => { class => 'DBD::JDBC', },
328 mo_ => { class => 'DBD::MO', },
329 monetdb_ => { class => 'DBD::monetdb', },
330 msql_ => { class => 'DBD::mSQL', },
331 mvsftp_ => { class => 'DBD::MVS_FTPSQL', },
332 mysql_ => { class => 'DBD::mysql', },
333 mx_ => { class => 'DBD::Multiplex', },
334 nullp_ => { class => 'DBD::NullP', },
335 odbc_ => { class => 'DBD::ODBC', },
336 ora_ => { class => 'DBD::Oracle', },
337 pg_ => { class => 'DBD::Pg', },
338 pgpp_ => { class => 'DBD::PgPP', },
339 plb_ => { class => 'DBD::Plibdata', },
340 po_ => { class => 'DBD::PO', },
341 proxy_ => { class => 'DBD::Proxy', },
342 ram_ => { class => 'DBD::RAM', },
343 rdb_ => { class => 'DBD::RDB', },
344 sapdb_ => { class => 'DBD::SAP_DB', },
345 snmp_ => { class => 'DBD::SNMP', },
346 solid_ => { class => 'DBD::Solid', },
347 spatialite_ => { class => 'DBD::Spatialite', },
348 sponge_ => { class => 'DBD::Sponge', },
349 sql_ => { class => 'DBI::DBD::SqlEngine', },
350 sqlite_ => { class => 'DBD::SQLite', },
351 syb_ => { class => 'DBD::Sybase', },
352 sys_ => { class => 'DBD::Sys', },
353 tdat_ => { class => 'DBD::Teradata', },
354 tmpl_ => { class => 'DBD::Template', },
355 tmplss_ => { class => 'DBD::TemplateSS', },
356 tree_ => { class => 'DBD::TreeData', },
357 tuber_ => { class => 'DBD::Tuber', },
358 uni_ => { class => 'DBD::Unify', },
359 vt_ => { class => 'DBD::Vt', },
360 wmi_ => { class => 'DBD::WMI', },
361 x_ => { }, # for private use
362 xbase_ => { class => 'DBD::XBase', },
363 xl_ => { class => 'DBD::Excel', },
364 yaswi_ => { class => 'DBD::Yaswi', },
365};
366
367my %dbd_class_registry = map { $dbd_prefix_registry->{$_}->{class} => { prefix => $_ } }
368 grep { exists $dbd_prefix_registry->{$_}->{class} }
3691105µs keys %{$dbd_prefix_registry};
370
371sub dump_dbd_registry {
372 require Data::Dumper;
373 local $Data::Dumper::Sortkeys=1;
374 local $Data::Dumper::Indent=1;
375 print Data::Dumper->Dump([$dbd_prefix_registry], [qw($dbd_prefix_registry)]);
376}
377
378# --- Dynamically create the DBI Standard Interface
379
3801900nsmy $keeperr = { O=>0x0004 };
381
3821109µs%DBI::DBI_methods = ( # Define the DBI interface methods per class:
383
384 common => { # Interface methods common to all DBI handle classes
385 'DESTROY' => { O=>0x004|0x10000 },
386 'CLEAR' => $keeperr,
387 'EXISTS' => $keeperr,
388 'FETCH' => { O=>0x0404 },
389 'FETCH_many' => { O=>0x0404 },
390 'FIRSTKEY' => $keeperr,
391 'NEXTKEY' => $keeperr,
392 'STORE' => { O=>0x0418 | 0x4 },
393 _not_impl => undef,
394 can => { O=>0x0100 }, # special case, see dispatch
395 debug => { U =>[1,2,'[$debug_level]'], O=>0x0004 }, # old name for trace
396 dump_handle => { U =>[1,3,'[$message [, $level]]'], O=>0x0004 },
397 err => $keeperr,
398 errstr => $keeperr,
399 state => $keeperr,
400 func => { O=>0x0006 },
401 parse_trace_flag => { U =>[2,2,'$name'], O=>0x0404, T=>8 },
402 parse_trace_flags => { U =>[2,2,'$flags'], O=>0x0404, T=>8 },
403 private_data => { U =>[1,1], O=>0x0004 },
404 set_err => { U =>[3,6,'$err, $errmsg [, $state, $method, $rv]'], O=>0x0010 },
405 trace => { U =>[1,3,'[$trace_level, [$filename]]'], O=>0x0004 },
406 trace_msg => { U =>[2,3,'$message_text [, $min_level ]' ], O=>0x0004, T=>8 },
407 swap_inner_handle => { U =>[2,3,'$h [, $allow_reparent ]'] },
408 private_attribute_info => { },
409 visit_child_handles => { U => [2,3,'$coderef [, $info ]'], O=>0x0404, T=>4 },
410 },
411 dr => { # Database Driver Interface
412 'connect' => { U =>[1,5,'[$db [,$user [,$passwd [,\%attr]]]]'], H=>3, O=>0x8000, T=>0x200 },
413 'connect_cached'=>{U=>[1,5,'[$db [,$user [,$passwd [,\%attr]]]]'], H=>3, O=>0x8000, T=>0x200 },
414 'disconnect_all'=>{ U =>[1,1], O=>0x0800, T=>0x200 },
415 data_sources => { U =>[1,2,'[\%attr]' ], O=>0x0800, T=>0x200 },
416 default_user => { U =>[3,4,'$user, $pass [, \%attr]' ], T=>0x200 },
417 dbixs_revision => $keeperr,
418 },
419 db => { # Database Session Class Interface
420 data_sources => { U =>[1,2,'[\%attr]' ], O=>0x0200 },
421 take_imp_data => { U =>[1,1], O=>0x10000 },
422 clone => { U =>[1,2,'[\%attr]'], T=>0x200 },
423 connected => { U =>[1,0], O => 0x0004, T=>0x200, H=>3 },
424 begin_work => { U =>[1,2,'[ \%attr ]'], O=>0x0400, T=>0x1000 },
425 commit => { U =>[1,1], O=>0x0480|0x0800, T=>0x1000 },
426 rollback => { U =>[1,1], O=>0x0480|0x0800, T=>0x1000 },
427 'do' => { U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x3200 },
428 last_insert_id => { U =>[5,6,'$catalog, $schema, $table_name, $field_name [, \%attr ]'], O=>0x2800 },
429 preparse => { }, # XXX
430 prepare => { U =>[2,3,'$statement [, \%attr]'], O=>0xA200 },
431 prepare_cached => { U =>[2,4,'$statement [, \%attr [, $if_active ] ]'], O=>0xA200 },
432 selectrow_array => { U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
433 selectrow_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
434 selectrow_hashref=>{ U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
435 selectall_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
436 selectall_hashref=>{ U =>[3,0,'$statement, $keyfield [, \%attr [, @bind_params ] ]'], O=>0x2000 },
437 selectcol_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
438 ping => { U =>[1,1], O=>0x0404 },
439 disconnect => { U =>[1,1], O=>0x0400|0x0800|0x10000, T=>0x200 },
440 quote => { U =>[2,3, '$string [, $data_type ]' ], O=>0x0430 },
441 quote_identifier=> { U =>[2,6, '$name [, ...] [, \%attr ]' ], O=>0x0430 },
442 rows => $keeperr,
443
444 tables => { U =>[1,6,'$catalog, $schema, $table, $type [, \%attr ]' ], O=>0x2200 },
445 table_info => { U =>[1,6,'$catalog, $schema, $table, $type [, \%attr ]' ], O=>0x2200|0x8800 },
446 column_info => { U =>[5,6,'$catalog, $schema, $table, $column [, \%attr ]'],O=>0x2200|0x8800 },
447 primary_key_info=> { U =>[4,5,'$catalog, $schema, $table [, \%attr ]' ], O=>0x2200|0x8800 },
448 primary_key => { U =>[4,5,'$catalog, $schema, $table [, \%attr ]' ], O=>0x2200 },
449 foreign_key_info=> { U =>[7,8,'$pk_catalog, $pk_schema, $pk_table, $fk_catalog, $fk_schema, $fk_table [, \%attr ]' ], O=>0x2200|0x8800 },
450 statistics_info => { U =>[6,7,'$catalog, $schema, $table, $unique_only, $quick, [, \%attr ]' ], O=>0x2200|0x8800 },
451 type_info_all => { U =>[1,1], O=>0x2200|0x0800 },
452 type_info => { U =>[1,2,'$data_type'], O=>0x2200 },
453 get_info => { U =>[2,2,'$info_type'], O=>0x2200|0x0800 },
454 },
455 st => { # Statement Class Interface
456 bind_col => { U =>[3,4,'$column, \\$var [, \%attr]'] },
457 bind_columns => { U =>[2,0,'\\$var1 [, \\$var2, ...]'] },
458 bind_param => { U =>[3,4,'$parameter, $var [, \%attr]'] },
459 bind_param_inout=> { U =>[4,5,'$parameter, \\$var, $maxlen, [, \%attr]'] },
460 execute => { U =>[1,0,'[@args]'], O=>0x1040 },
461
462 bind_param_array => { U =>[3,4,'$parameter, $var [, \%attr]'] },
463 bind_param_inout_array => { U =>[4,5,'$parameter, \\@var, $maxlen, [, \%attr]'] },
464 execute_array => { U =>[2,0,'\\%attribs [, @args]'], O=>0x1040|0x4000 },
465 execute_for_fetch => { U =>[2,3,'$fetch_sub [, $tuple_status]'], O=>0x1040|0x4000 },
466
467 fetch => undef, # alias for fetchrow_arrayref
468 fetchrow_arrayref => undef,
469 fetchrow_hashref => undef,
470 fetchrow_array => undef,
471 fetchrow => undef, # old alias for fetchrow_array
472
473 fetchall_arrayref => { U =>[1,3, '[ $slice [, $max_rows]]'] },
474 fetchall_hashref => { U =>[2,2,'$key_field'] },
475
476 blob_read => { U =>[4,5,'$field, $offset, $len [, \\$buf [, $bufoffset]]'] },
477 blob_copy_to_file => { U =>[3,3,'$field, $filename_or_handleref'] },
478 dump_results => { U =>[1,5,'$maxfieldlen, $linesep, $fieldsep, $filehandle'] },
479 more_results => { U =>[1,1] },
480 finish => { U =>[1,1] },
481 cancel => { U =>[1,1], O=>0x0800 },
482 rows => $keeperr,
483
484 _get_fbav => undef,
485 _set_fbav => { T=>6 },
486 },
487);
488
48916µswhile ( my ($class, $meths) = each %DBI::DBI_methods ) {
49043µs my $ima_trace = 0+($ENV{DBI_IMA_TRACE}||0);
4914135µs while ( my ($method, $info) = each %$meths ) {
4928940µs my $fullmeth = "DBI::${class}::$method";
4938921µs if (($DBI::dbi_debug & 0xF) == 15) { # quick hack to list DBI methods
494 # and optionally filter by IMA flags
495 my $O = $info->{O}||0;
496 printf "0x%04x %-20s\n", $O, $fullmeth
497 unless $ima_trace && !($O & $ima_trace);
498 }
49989486µs89292µs DBI->_install_method($fullmeth, 'DBI.pm', $info);
# spent 292µs making 89 calls to DBI::_install_method, avg 3µs/call
500 }
501}
502
503{
5041900ns package DBI::common;
50518µs @DBI::dr::ISA = ('DBI::common');
50614µs @DBI::db::ISA = ('DBI::common');
50713µs @DBI::st::ISA = ('DBI::common');
508}
509
510# End of init code
511
512
513
# spent 132µs (83+50) within DBI::END which was called: # once (83µs+50µs) by main::RUNTIME at line 0 of xt/tapper-mcp-scheduler-with-db-longrun.t
END {
51412µs return unless defined &DBI::trace_msg; # return unless bootstrap'd ok
51516µs local ($!,$?);
516155µs15µs DBI->trace_msg(sprintf(" -- DBI::END (\$\@: %s, \$!: %s)\n", $@||'', $!||''), 2);
# spent 5µs making 1 call to DBD::_::common::trace_msg
517 # Let drivers know why we are calling disconnect_all:
51811µs $DBI::PERL_ENDING = $DBI::PERL_ENDING = 1; # avoid typo warning
519119µs145µs DBI->disconnect_all() if %DBI::installed_drh;
# spent 45µs making 1 call to DBI::disconnect_all
520}
521
522
523sub CLONE {
524 _clone_dbis() unless $DBI::PurePerl; # clone the DBIS structure
525 DBI->trace_msg("CLONE DBI for new thread\n");
526 while ( my ($driver, $drh) = each %DBI::installed_drh) {
5273753µs239µs
# spent 23µs (6+16) within DBI::BEGIN@527 which was called: # once (6µs+16µs) by DBIx::Class::Storage::DBI::__ANON__[/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/DBIx/Class/Storage/DBI.pm:1300] at line 527
no strict 'refs';
# spent 23µs making 1 call to DBI::BEGIN@527 # spent 16µs making 1 call to strict::unimport
528 next if defined &{"DBD::${driver}::CLONE"};
529 warn("$driver has no driver CLONE() function so is unsafe threaded\n");
530 }
531 %DBI::installed_drh = (); # clear loaded drivers so they have a chance to reinitialize
532}
533
534sub parse_dsn {
535 my ($class, $dsn) = @_;
536 $dsn =~ s/^(dbi):(\w*?)(?:\((.*?)\))?://i or return;
537 my ($scheme, $driver, $attr, $attr_hash) = (lc($1), $2, $3);
538 $driver ||= $ENV{DBI_DRIVER} || '';
539 $attr_hash = { split /\s*=>?\s*|\s*,\s*/, $attr, -1 } if $attr;
540 return ($scheme, $driver, $attr, $attr_hash, $dsn);
541}
542
543sub visit_handles {
544 my ($class, $code, $outer_info) = @_;
545 $outer_info = {} if not defined $outer_info;
546 my %drh = DBI->installed_drivers;
547 for my $h (values %drh) {
548 my $child_info = $code->($h, $outer_info)
549 or next;
550 $h->visit_child_handles($code, $child_info);
551 }
552 return $outer_info;
553}
554
555
556# --- The DBI->connect Front Door methods
557
558sub connect_cached {
559 # For library code using connect_cached() with mod_perl
560 # we redirect those calls to Apache::DBI::connect() as well
561 my ($class, $dsn, $user, $pass, $attr) = @_;
562 my $dbi_connect_method = ($DBI::connect_via eq "Apache::DBI::connect")
563 ? 'Apache::DBI::connect' : 'connect_cached';
564 $attr = {
565 $attr ? %$attr : (), # clone, don't modify callers data
566 dbi_connect_method => $dbi_connect_method,
567 };
568 return $class->connect($dsn, $user, $pass, $attr);
569}
570
571
# spent 7.17ms (399µs+6.77) within DBI::connect which was called 6 times, avg 1.19ms/call: # 6 times (399µs+6.77ms) by DBIx::Class::Storage::DBI::__ANON__[/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/DBIx/Class/Storage/DBI.pm:1300] at line 1249 of DBIx/Class/Storage/DBI.pm, avg 1.19ms/call
sub connect {
57265µs my $class = shift;
573629µs my ($dsn, $user, $pass, $attr, $old_driver) = my @orig_args = @_;
57463µs my $driver;
575
57667µs if ($attr and !ref($attr)) { # switch $old_driver<->$attr if called in old style
577 Carp::carp("DBI->connect using 'old-style' syntax is deprecated and will be an error in future versions");
578 ($old_driver, $attr) = ($attr, $old_driver);
579 }
580
58167µs my $connect_meth = $attr->{dbi_connect_method};
58266µs $connect_meth ||= $DBI::connect_via; # fallback to default
583
58463µs $dsn ||= $ENV{DBI_DSN} || $ENV{DBI_DBNAME} || '' unless $old_driver;
585
58663µs if ($DBI::dbi_debug) {
587 local $^W = 0;
588 pop @_ if $connect_meth ne 'connect';
589 my @args = @_; $args[2] = '****'; # hide password
590 DBI->trace_msg(" -> $class->$connect_meth(".join(", ",@args).")\n");
591 }
59268µs Carp::croak('Usage: $class->connect([$dsn [,$user [,$passwd [,\%attr]]]])')
593 if (ref $old_driver or ($attr and not ref $attr) or ref $pass);
594
595 # extract dbi:driver prefix from $dsn into $1
596684µs655µs $dsn =~ s/^dbi:(\w*?)(?:\((.*?)\))?://i
# spent 55µs making 6 calls to DBI::CORE:subst, avg 9µs/call
597 or '' =~ /()/; # ensure $1 etc are empty if match fails
598620µs my $driver_attrib_spec = $2 || '';
599
600 # Set $driver. Old style driver, if specified, overrides new dsn style.
601613µs $driver = $old_driver || $1 || $ENV{DBI_DRIVER}
602 or Carp::croak("Can't connect to data source '$dsn' "
603 ."because I can't work out what driver to use "
604 ."(it doesn't seem to contain a 'dbi:driver:' prefix "
605 ."and the DBI_DRIVER env var is not set)");
606
60762µs my $proxy;
60868µs if ($ENV{DBI_AUTOPROXY} && $driver ne 'Proxy' && $driver ne 'Sponge' && $driver ne 'Switch') {
609 my $dbi_autoproxy = $ENV{DBI_AUTOPROXY};
610 $proxy = 'Proxy';
611 if ($dbi_autoproxy =~ s/^dbi:(\w*?)(?:\((.*?)\))?://i) {
612 $proxy = $1;
613 $driver_attrib_spec = join ",",
614 ($driver_attrib_spec) ? $driver_attrib_spec : (),
615 ($2 ) ? $2 : ();
616 }
617 $dsn = "$dbi_autoproxy;dsn=dbi:$driver:$dsn";
618 $driver = $proxy;
619 DBI->trace_msg(" DBI_AUTOPROXY: dbi:$driver($driver_attrib_spec):$dsn\n");
620 }
621 # avoid recursion if proxy calls DBI->connect itself
62264µs local $ENV{DBI_AUTOPROXY} if $ENV{DBI_AUTOPROXY};
623
62463µs my %attributes; # take a copy we can delete from
625611µs if ($old_driver) {
626 %attributes = %$attr if $attr;
627 }
628 else { # new-style connect so new default semantics
629649µs %attributes = (
630 PrintError => 1,
631 AutoCommit => 1,
632 ref $attr ? %$attr : (),
633 # attributes in DSN take precedence over \%attr connect parameter
634 $driver_attrib_spec ? (split /\s*=>?\s*|\s*,\s*/, $driver_attrib_spec, -1) : (),
635 );
636 }
63764µs $attr = \%attributes; # now set $attr to refer to our local copy
638
639613µs13.91ms my $drh = $DBI::installed_drh{$driver} || $class->install_driver($driver)
# spent 3.91ms making 1 call to DBI::install_driver
640 or die "panic: $class->install_driver($driver) failed";
641
642 # attributes in DSN take precedence over \%attr connect parameter
64365µs $user = $attr->{Username} if defined $attr->{Username};
64464µs $pass = $attr->{Password} if defined $attr->{Password};
64565µs delete $attr->{Password}; # always delete Password as closure stores it securely
64663µs if ( !(defined $user && defined $pass) ) {
647 ($user, $pass) = $drh->default_user($user, $pass, $attr);
648 }
64967µs $attr->{Username} = $user; # force the Username to be the actual one used
650
651
# spent 2.79ms (486µs+2.30) within DBI::__ANON__[/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/x86_64-linux/DBI.pm:725] which was called 6 times, avg 465µs/call: # 6 times (486µs+2.30ms) by DBI::connect at line 727, avg 465µs/call
my $connect_closure = sub {
65265µs my ($old_dbh, $override_attr) = @_;
653
654 #use Data::Dumper;
655 #warn "connect_closure: ".Data::Dumper::Dumper([$attr,\%attributes, $override_attr]);
656
65762µs my $dbh;
658692µs124.32ms unless ($dbh = $drh->$connect_meth($dsn, $user, $pass, $attr)) {
# spent 2.19ms making 6 calls to DBI::dr::connect, avg 365µs/call # spent 2.13ms making 6 calls to DBD::SQLite::dr::connect, avg 355µs/call
659 $user = '' if !defined $user;
660 $dsn = '' if !defined $dsn;
661 # $drh->errstr isn't safe here because $dbh->DESTROY may not have
662 # been called yet and so the dbh errstr would not have been copied
663 # up to the drh errstr. Certainly true for connect_cached!
664 my $errstr = $DBI::errstr;
665 # Getting '(no error string)' here is a symptom of a ref loop
666 $errstr = '(no error string)' if !defined $errstr;
667 my $msg = "$class connect('$dsn','$user',...) failed: $errstr";
668 DBI->trace_msg(" $msg\n");
669 # XXX HandleWarn
670 unless ($attr->{HandleError} && $attr->{HandleError}->($msg, $drh, $dbh)) {
671 Carp::croak($msg) if $attr->{RaiseError};
672 Carp::carp ($msg) if $attr->{PrintError};
673 }
674 $! = 0; # for the daft people who do DBI->connect(...) || die "$!";
675 return $dbh; # normally undef, but HandleError could change it
676 }
677
678 # merge any attribute overrides but don't change $attr itself (for closure)
679635µs my $apply = { ($override_attr) ? (%$attr, %$override_attr ) : %$attr };
680
681 # handle basic RootClass subclassing:
682612µs my $rebless_class = $apply->{RootClass} || ($class ne 'DBI' ? $class : '');
68363µs if ($rebless_class) {
6843537µs225µs
# spent 16µs (7+9) within DBI::BEGIN@684 which was called: # once (7µs+9µs) by DBIx::Class::Storage::DBI::__ANON__[/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/DBIx/Class/Storage/DBI.pm:1300] at line 684
no strict 'refs';
# spent 16µs making 1 call to DBI::BEGIN@684 # spent 9µs making 1 call to strict::unimport
685 if ($apply->{RootClass}) { # explicit attribute (ie not static methd call class)
686 delete $apply->{RootClass};
687 DBI::_load_class($rebless_class, 0);
688 }
689 unless (@{"$rebless_class\::db::ISA"} && @{"$rebless_class\::st::ISA"}) {
690 Carp::carp("DBI subclasses '$rebless_class\::db' and ::st are not setup, RootClass ignored");
691 $rebless_class = undef;
692 $class = 'DBI';
693 }
694 else {
695 $dbh->{RootClass} = $rebless_class; # $dbh->STORE called via plain DBI::db
696 DBI::_set_isa([$rebless_class], 'DBI'); # sets up both '::db' and '::st'
697 DBI::_rebless($dbh, $rebless_class); # appends '::db'
698 }
699 }
700
70167µs if (%$apply) {
702
70364µs if ($apply->{DbTypeSubclass}) {
704 my $DbTypeSubclass = delete $apply->{DbTypeSubclass};
705 DBI::_rebless_dbtype_subclass($dbh, $rebless_class||$class, $DbTypeSubclass);
706 }
70762µs my $a;
70869µs foreach $a (qw(Profile RaiseError PrintError AutoCommit)) { # do these first
7092415µs next unless exists $apply->{$a};
71018198µs1850µs $dbh->{$a} = delete $apply->{$a};
# spent 50µs making 18 calls to DBI::common::STORE, avg 3µs/call
711 }
712648µs while ( my ($a, $v) = each %$apply) {
71332138µs1646µs eval { $dbh->{$a} = $v }; # assign in void context to avoid re-FETCH
# spent 46µs making 16 calls to DBI::common::STORE, avg 3µs/call
714166µs warn $@ if $@;
715 }
716 }
717
718 # confirm to driver (ie if subclassed) that we've connected sucessfully
719 # and finished the attribute setup. pass in the original arguments
720652µs615µs $dbh->connected(@orig_args); #if ref $dbh ne 'DBI::db' or $proxy;
# spent 15µs making 6 calls to DBI::db::connected, avg 2µs/call
721
72267µs DBI->trace_msg(" <- connect= $dbh\n") if $DBI::dbi_debug & 0xF;
723
724627µs return $dbh;
725670µs };
726
727615µs62.79ms my $dbh = &$connect_closure(undef, undef);
# spent 2.79ms making 6 calls to DBI::__ANON__[DBI.pm:725], avg 465µs/call
728
729649µs618µs $dbh->{dbi_connect_closure} = $connect_closure if $dbh;
# spent 18µs making 6 calls to DBI::common::STORE, avg 3µs/call
730
731630µs return $dbh;
732}
733
734
735
# spent 45µs (32+13) within DBI::disconnect_all which was called: # once (32µs+13µs) by DBI::END at line 519
sub disconnect_all {
73612µs keys %DBI::installed_drh; # reset iterator
737148µs113µs while ( my ($name, $drh) = each %DBI::installed_drh ) {
# spent 13µs making 1 call to DBI::dr::disconnect_all
738 $drh->disconnect_all() if ref $drh;
739 }
740}
741
742
743sub disconnect { # a regular beginners bug
744 Carp::croak("DBI->disconnect is not a DBI method (read the DBI manual)");
745}
746
747
748
# spent 3.91ms (2.46+1.45) within DBI::install_driver which was called: # once (2.46ms+1.45ms) by DBI::connect at line 639
sub install_driver { # croaks on failure
7491700ns my $class = shift;
7501800ns my($driver, $attr) = @_;
7511200ns my $drh;
752
7531300ns $driver ||= $ENV{DBI_DRIVER} || '';
754
755 # allow driver to be specified as a 'dbi:driver:' string
75613µs11µs $driver = $1 if $driver =~ s/^DBI:(.*?)://i;
# spent 1µs making 1 call to DBI::CORE:subst
757
75811µs Carp::croak("usage: $class->install_driver(\$driver [, \%attr])")
759 unless ($driver and @_<=3);
760
761 # already installed
7621500ns return $drh if $drh = $DBI::installed_drh{$driver};
763
7641500ns $class->trace_msg(" -> $class->install_driver($driver"
765 .") for $^O perl=$] pid=$$ ruid=$< euid=$>\n")
766 if $DBI::dbi_debug & 0xF;
767
768 # --- load the code
7691900ns my $driver_class = "DBD::$driver";
770171µs eval qq{package # hide from PAUSE
# spent 101µs executing statements in string eval
771 DBI::_firesafe; # just in case
772 require $driver_class; # load the driver
773 };
7741500ns if ($@) {
775 my $err = $@;
776 my $advice = "";
777 if ($err =~ /Can't find loadable object/) {
778 $advice = "Perhaps DBD::$driver was statically linked into a new perl binary."
779 ."\nIn which case you need to use that new perl binary."
780 ."\nOr perhaps only the .pm file was installed but not the shared object file."
781 }
782 elsif ($err =~ /Can't locate.*?DBD\/$driver\.pm in \@INC/) {
783 my @drv = $class->available_drivers(1);
784 $advice = "Perhaps the DBD::$driver perl module hasn't been fully installed,\n"
785 ."or perhaps the capitalisation of '$driver' isn't right.\n"
786 ."Available drivers: ".join(", ", @drv).".";
787 }
788 elsif ($err =~ /Can't load .*? for module DBD::/) {
789 $advice = "Perhaps a required shared library or dll isn't installed where expected";
790 }
791 elsif ($err =~ /Can't locate .*? in \@INC/) {
792 $advice = "Perhaps a module that DBD::$driver requires hasn't been fully installed";
793 }
794 Carp::croak("install_driver($driver) failed: $err$advice\n");
795 }
79611µs if ($DBI::dbi_debug & 0xF) {
7973196µs224µs
# spent 15µs (7+9) within DBI::BEGIN@797 which was called: # once (7µs+9µs) by DBIx::Class::Storage::DBI::__ANON__[/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/DBIx/Class/Storage/DBI.pm:1300] at line 797
no strict 'refs';
# spent 15µs making 1 call to DBI::BEGIN@797 # spent 9µs making 1 call to strict::unimport
798 (my $driver_file = $driver_class) =~ s/::/\//g;
799 my $dbd_ver = ${"$driver_class\::VERSION"} || "undef";
800 $class->trace_msg(" install_driver: $driver_class version $dbd_ver"
801 ." loaded from $INC{qq($driver_file.pm)}\n");
802 }
803
804 # --- do some behind-the-scenes checks and setups on the driver
80514µs181µs $class->setup_driver($driver_class);
# spent 81µs making 1 call to DBI::setup_driver
806
807 # --- run the driver function
80824µs1486µs $drh = eval { $driver_class->driver($attr || {}) };
# spent 486µs making 1 call to DBD::SQLite::driver
80911µs unless ($drh && ref $drh && !$@) {
810 my $advice = "";
811 $@ ||= "$driver_class->driver didn't return a handle";
812 # catch people on case in-sensitive systems using the wrong case
813 $advice = "\nPerhaps the capitalisation of DBD '$driver' isn't right."
814 if $@ =~ /locate object method/;
815 Carp::croak("$driver_class initialisation failed: $@$advice");
816 }
817
81813µs $DBI::installed_drh{$driver} = $drh;
8191700ns $class->trace_msg(" <- install_driver= $drh\n") if $DBI::dbi_debug & 0xF;
82014µs $drh;
821}
822
82311µs*driver = \&install_driver; # currently an alias, may change
824
825
826
# spent 182µs (155+27) within DBI::setup_driver which was called 3 times, avg 61µs/call: # once (73µs+10µs) by DBIx::Class::Storage::DBI::__ANON__[/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/DBIx/Class/Storage/DBI.pm:1300] at line 1293 # once (69µs+12µs) by DBI::install_driver at line 805 # once (13µs+5µs) by DBD::SQLite::driver at line 42 of DBD/SQLite.pm
sub setup_driver {
82733µs my ($class, $driver_class) = @_;
8283700ns my $h_type;
829312µs foreach $h_type (qw(dr db st)){
83098µs my $h_class = $driver_class."::$h_type";
8313167µs222µs
# spent 14µs (6+8) within DBI::BEGIN@831 which was called: # once (6µs+8µs) by DBIx::Class::Storage::DBI::__ANON__[/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/DBIx/Class/Storage/DBI.pm:1300] at line 831
no strict 'refs';
# spent 14µs making 1 call to DBI::BEGIN@831 # spent 8µs making 1 call to strict::unimport
832980µs919µs push @{"${h_class}::ISA"}, "DBD::_::$h_type"
# spent 19µs making 9 calls to UNIVERSAL::isa, avg 2µs/call
833 unless UNIVERSAL::isa($h_class, "DBD::_::$h_type");
834 # The _mem class stuff is (IIRC) a crufty hack for global destruction
835 # timing issues in early versions of perl5 and possibly no longer needed.
83694µs my $mem_class = "DBD::_mem::$h_type";
837979µs98µs push @{"${h_class}_mem::ISA"}, $mem_class
# spent 8µs making 9 calls to UNIVERSAL::isa, avg 944ns/call
838 unless UNIVERSAL::isa("${h_class}_mem", $mem_class)
839 or $DBI::PurePerl;
840 }
841}
842
843
844sub _rebless {
845 my $dbh = shift;
846 my ($outer, $inner) = DBI::_handles($dbh);
847 my $class = shift(@_).'::db';
848 bless $inner => $class;
849 bless $outer => $class; # outer last for return
850}
851
852
853sub _set_isa {
854 my ($classes, $topclass) = @_;
855 my $trace = DBI->trace_msg(" _set_isa([@$classes])\n");
856 foreach my $suffix ('::db','::st') {
857 my $previous = $topclass || 'DBI'; # trees are rooted here
858 foreach my $class (@$classes) {
859 my $base_class = $previous.$suffix;
860 my $sub_class = $class.$suffix;
861 my $sub_class_isa = "${sub_class}::ISA";
8623439µs225µs
# spent 18µs (10+8) within DBI::BEGIN@862 which was called: # once (10µs+8µs) by DBIx::Class::Storage::DBI::__ANON__[/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/DBIx/Class/Storage/DBI.pm:1300] at line 862
no strict 'refs';
# spent 18µs making 1 call to DBI::BEGIN@862 # spent 8µs making 1 call to strict::unimport
863 if (@$sub_class_isa) {
864 DBI->trace_msg(" $sub_class_isa skipped (already set to @$sub_class_isa)\n")
865 if $trace;
866 }
867 else {
868 @$sub_class_isa = ($base_class) unless @$sub_class_isa;
869 DBI->trace_msg(" $sub_class_isa = $base_class\n")
870 if $trace;
871 }
872 $previous = $class;
873 }
874 }
875}
876
877
878sub _rebless_dbtype_subclass {
879 my ($dbh, $rootclass, $DbTypeSubclass) = @_;
880 # determine the db type names for class hierarchy
881 my @hierarchy = DBI::_dbtype_names($dbh, $DbTypeSubclass);
882 # add the rootclass prefix to each ('DBI::' or 'MyDBI::' etc)
883 $_ = $rootclass.'::'.$_ foreach (@hierarchy);
884 # load the modules from the 'top down'
885 DBI::_load_class($_, 1) foreach (reverse @hierarchy);
886 # setup class hierarchy if needed, does both '::db' and '::st'
887 DBI::_set_isa(\@hierarchy, $rootclass);
888 # finally bless the handle into the subclass
889 DBI::_rebless($dbh, $hierarchy[0]);
890}
891
892
893sub _dbtype_names { # list dbtypes for hierarchy, ie Informix=>ADO=>ODBC
894 my ($dbh, $DbTypeSubclass) = @_;
895
896 if ($DbTypeSubclass && $DbTypeSubclass ne '1' && ref $DbTypeSubclass ne 'CODE') {
897 # treat $DbTypeSubclass as a comma separated list of names
898 my @dbtypes = split /\s*,\s*/, $DbTypeSubclass;
899 $dbh->trace_msg(" DbTypeSubclass($DbTypeSubclass)=@dbtypes (explicit)\n");
900 return @dbtypes;
901 }
902
903 # XXX will call $dbh->get_info(17) (=SQL_DBMS_NAME) in future?
904
905 my $driver = $dbh->{Driver}->{Name};
906 if ( $driver eq 'Proxy' ) {
907 # XXX Looking into the internals of DBD::Proxy is questionable!
908 ($driver) = $dbh->{proxy_client}->{application} =~ /^DBI:(.+?):/i
909 or die "Can't determine driver name from proxy";
910 }
911
912 my @dbtypes = (ucfirst($driver));
913 if ($driver eq 'ODBC' || $driver eq 'ADO') {
914 # XXX will move these out and make extensible later:
915 my $_dbtype_name_regexp = 'Oracle'; # eg 'Oracle|Foo|Bar'
916 my %_dbtype_name_map = (
917 'Microsoft SQL Server' => 'MSSQL',
918 'SQL Server' => 'Sybase',
919 'Adaptive Server Anywhere' => 'ASAny',
920 'ADABAS D' => 'AdabasD',
921 );
922
923 my $name;
924 $name = $dbh->func(17, 'GetInfo') # SQL_DBMS_NAME
925 if $driver eq 'ODBC';
926 $name = $dbh->{ado_conn}->Properties->Item('DBMS Name')->Value
927 if $driver eq 'ADO';
928 die "Can't determine driver name! ($DBI::errstr)\n"
929 unless $name;
930
931 my $dbtype;
932 if ($_dbtype_name_map{$name}) {
933 $dbtype = $_dbtype_name_map{$name};
934 }
935 else {
936 if ($name =~ /($_dbtype_name_regexp)/) {
937 $dbtype = lc($1);
938 }
939 else { # generic mangling for other names:
940 $dbtype = lc($name);
941 }
942 $dbtype =~ s/\b(\w)/\U$1/g;
943 $dbtype =~ s/\W+/_/g;
944 }
945 # add ODBC 'behind' ADO
946 push @dbtypes, 'ODBC' if $driver eq 'ADO';
947 # add discovered dbtype in front of ADO/ODBC
948 unshift @dbtypes, $dbtype;
949 }
950 @dbtypes = &$DbTypeSubclass($dbh, \@dbtypes)
951 if (ref $DbTypeSubclass eq 'CODE');
952 $dbh->trace_msg(" DbTypeSubclass($DbTypeSubclass)=@dbtypes\n");
953 return @dbtypes;
954}
955
956sub _load_class {
957 my ($load_class, $missing_ok) = @_;
958 DBI->trace_msg(" _load_class($load_class, $missing_ok)\n", 2);
9593430µs222µs
# spent 14µs (7+8) within DBI::BEGIN@959 which was called: # once (7µs+8µs) by DBIx::Class::Storage::DBI::__ANON__[/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/DBIx/Class/Storage/DBI.pm:1300] at line 959
no strict 'refs';
# spent 14µs making 1 call to DBI::BEGIN@959 # spent 8µs making 1 call to strict::unimport
960 return 1 if @{"$load_class\::ISA"}; # already loaded/exists
961 (my $module = $load_class) =~ s!::!/!g;
962 DBI->trace_msg(" _load_class require $module\n", 2);
963 eval { require "$module.pm"; };
964 return 1 unless $@;
965 return 0 if $missing_ok && $@ =~ /^Can't locate \Q$module.pm\E/;
966 die $@;
967}
968
969
970sub init_rootclass { # deprecated
971 return 1;
972}
973
974
9751700ns*internal = \&DBD::Switch::dr::driver;
976
977sub driver_prefix {
978 my ($class, $driver) = @_;
979 return $dbd_class_registry{$driver}->{prefix} if exists $dbd_class_registry{$driver};
980 return;
981}
982
983sub available_drivers {
984 my($quiet) = @_;
985 my(@drivers, $d, $f);
986 local(*DBI::DIR, $@);
987 my(%seen_dir, %seen_dbd);
988 my $haveFileSpec = eval { require File::Spec };
989 foreach $d (@INC){
990 chomp($d); # Perl 5 beta 3 bug in #!./perl -Ilib from Test::Harness
991 my $dbd_dir =
992 ($haveFileSpec ? File::Spec->catdir($d, 'DBD') : "$d/DBD");
993 next unless -d $dbd_dir;
994 next if $seen_dir{$d};
995 $seen_dir{$d} = 1;
996 # XXX we have a problem here with case insensitive file systems
997 # XXX since we can't tell what case must be used when loading.
998 opendir(DBI::DIR, $dbd_dir) || Carp::carp "opendir $dbd_dir: $!\n";
999 foreach $f (readdir(DBI::DIR)){
1000 next unless $f =~ s/\.pm$//;
1001 next if $f eq 'NullP';
1002 if ($seen_dbd{$f}){
1003 Carp::carp "DBD::$f in $d is hidden by DBD::$f in $seen_dbd{$f}\n"
1004 unless $quiet;
1005 } else {
1006 push(@drivers, $f);
1007 }
1008 $seen_dbd{$f} = $d;
1009 }
1010 closedir(DBI::DIR);
1011 }
1012
1013 # "return sort @drivers" will not DWIM in scalar context.
1014 return wantarray ? sort @drivers : @drivers;
1015}
1016
1017sub installed_versions {
1018 my ($class, $quiet) = @_;
1019 my %error;
1020 my %version = ( DBI => $DBI::VERSION );
1021 $version{"DBI::PurePerl"} = $DBI::PurePerl::VERSION
1022 if $DBI::PurePerl;
1023 for my $driver ($class->available_drivers($quiet)) {
1024 next if $DBI::PurePerl && grep { -d "$_/auto/DBD/$driver" } @INC;
1025 my $drh = eval {
1026 local $SIG{__WARN__} = sub {};
1027 $class->install_driver($driver);
1028 };
1029 ($error{"DBD::$driver"}=$@),next if $@;
103031.48ms227µs
# spent 18µs (10+8) within DBI::BEGIN@1030 which was called: # once (10µs+8µs) by DBIx::Class::Storage::DBI::__ANON__[/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/DBIx/Class/Storage/DBI.pm:1300] at line 1030
no strict 'refs';
# spent 18µs making 1 call to DBI::BEGIN@1030 # spent 8µs making 1 call to strict::unimport
1031 my $vers = ${"DBD::$driver" . '::VERSION'};
1032 $version{"DBD::$driver"} = $vers || '?';
1033 }
1034 if (wantarray) {
1035 return map { m/^DBD::(\w+)/ ? ($1) : () } sort keys %version;
1036 }
1037 if (!defined wantarray) { # void context
1038 require Config; # add more detail
1039 $version{OS} = "$^O\t($Config::Config{osvers})";
1040 $version{Perl} = "$]\t($Config::Config{archname})";
1041 $version{$_} = (($error{$_} =~ s/ \(\@INC.*//s),$error{$_})
1042 for keys %error;
1043 printf " %-16s: %s\n",$_,$version{$_}
1044 for reverse sort keys %version;
1045 }
1046 return \%version;
1047}
1048
1049
1050sub data_sources {
1051 my ($class, $driver, @other) = @_;
1052 my $drh = $class->install_driver($driver);
1053 my @ds = $drh->data_sources(@other);
1054 return @ds;
1055}
1056
1057
1058sub neat_list {
1059 my ($listref, $maxlen, $sep) = @_;
1060 $maxlen = 0 unless defined $maxlen; # 0 == use internal default
1061 $sep = ", " unless defined $sep;
1062 join($sep, map { neat($_,$maxlen) } @$listref);
1063}
1064
1065
1066sub dump_results { # also aliased as a method in DBD::_::st
1067 my ($sth, $maxlen, $lsep, $fsep, $fh) = @_;
1068 return 0 unless $sth;
1069 $maxlen ||= 35;
1070 $lsep ||= "\n";
1071 $fh ||= \*STDOUT;
1072 my $rows = 0;
1073 my $ref;
1074 while($ref = $sth->fetch) {
1075 print $fh $lsep if $rows++ and $lsep;
1076 my $str = neat_list($ref,$maxlen,$fsep);
1077 print $fh $str; # done on two lines to avoid 5.003 errors
1078 }
1079 print $fh "\n$rows rows".($DBI::err ? " ($DBI::err: $DBI::errstr)" : "")."\n";
1080 $rows;
1081}
1082
1083
1084sub data_diff {
1085 my ($a, $b, $logical) = @_;
1086
1087 my $diff = data_string_diff($a, $b);
1088 return "" if $logical and !$diff;
1089
1090 my $a_desc = data_string_desc($a);
1091 my $b_desc = data_string_desc($b);
1092 return "" if !$diff and $a_desc eq $b_desc;
1093
1094 $diff ||= "Strings contain the same sequence of characters"
1095 if length($a);
1096 $diff .= "\n" if $diff;
1097 return "a: $a_desc\nb: $b_desc\n$diff";
1098}
1099
1100
1101sub data_string_diff {
1102 # Compares 'logical' characters, not bytes, so a latin1 string and an
1103 # an equivalent Unicode string will compare as equal even though their
1104 # byte encodings are different.
1105 my ($a, $b) = @_;
1106 unless (defined $a and defined $b) { # one undef
1107 return ""
1108 if !defined $a and !defined $b;
1109 return "String a is undef, string b has ".length($b)." characters"
1110 if !defined $a;
1111 return "String b is undef, string a has ".length($a)." characters"
1112 if !defined $b;
1113 }
1114
1115 require utf8;
1116 # hack to cater for perl 5.6
1117 *utf8::is_utf8 = sub { (DBI::neat(shift)=~/^"/) } unless defined &utf8::is_utf8;
1118
1119 my @a_chars = (utf8::is_utf8($a)) ? unpack("U*", $a) : unpack("C*", $a);
1120 my @b_chars = (utf8::is_utf8($b)) ? unpack("U*", $b) : unpack("C*", $b);
1121 my $i = 0;
1122 while (@a_chars && @b_chars) {
1123 ++$i, shift(@a_chars), shift(@b_chars), next
1124 if $a_chars[0] == $b_chars[0];# compare ordinal values
1125 my @desc = map {
1126 $_ > 255 ? # if wide character...
1127 sprintf("\\x{%04X}", $_) : # \x{...}
1128 chr($_) =~ /[[:cntrl:]]/ ? # else if control character ...
1129 sprintf("\\x%02X", $_) : # \x..
1130 chr($_) # else as themselves
1131 } ($a_chars[0], $b_chars[0]);
1132 # highlight probable double-encoding?
1133 foreach my $c ( @desc ) {
1134 next unless $c =~ m/\\x\{08(..)}/;
1135 $c .= "='" .chr(hex($1)) ."'"
1136 }
1137 return sprintf "Strings differ at index $i: a[$i]=$desc[0], b[$i]=$desc[1]";
1138 }
1139 return "String a truncated after $i characters" if @b_chars;
1140 return "String b truncated after $i characters" if @a_chars;
1141 return "";
1142}
1143
1144
1145sub data_string_desc { # describe a data string
1146 my ($a) = @_;
1147 require bytes;
1148 require utf8;
1149
1150 # hacks to cater for perl 5.6
1151 *utf8::is_utf8 = sub { (DBI::neat(shift)=~/^"/) } unless defined &utf8::is_utf8;
1152 *utf8::valid = sub { 1 } unless defined &utf8::valid;
1153
1154 # Give sufficient info to help diagnose at least these kinds of situations:
1155 # - valid UTF8 byte sequence but UTF8 flag not set
1156 # (might be ascii so also need to check for hibit to make it worthwhile)
1157 # - UTF8 flag set but invalid UTF8 byte sequence
1158 # could do better here, but this'll do for now
1159 my $utf8 = sprintf "UTF8 %s%s",
1160 utf8::is_utf8($a) ? "on" : "off",
1161 utf8::valid($a||'') ? "" : " but INVALID encoding";
1162 return "$utf8, undef" unless defined $a;
1163 my $is_ascii = $a =~ m/^[\000-\177]*$/;
1164 return sprintf "%s, %s, %d characters %d bytes",
1165 $utf8, $is_ascii ? "ASCII" : "non-ASCII",
1166 length($a), bytes::length($a);
1167}
1168
1169
1170sub connect_test_perf {
1171 my($class, $dsn,$dbuser,$dbpass, $attr) = @_;
1172 Carp::croak("connect_test_perf needs hash ref as fourth arg") unless ref $attr;
1173 # these are non standard attributes just for this special method
1174 my $loops ||= $attr->{dbi_loops} || 5;
1175 my $par ||= $attr->{dbi_par} || 1; # parallelism
1176 my $verb ||= $attr->{dbi_verb} || 1;
1177 my $meth ||= $attr->{dbi_meth} || 'connect';
1178 print "$dsn: testing $loops sets of $par connections:\n";
1179 require "FileHandle.pm"; # don't let toke.c create empty FileHandle package
1180 local $| = 1;
1181 my $drh = $class->install_driver($dsn) or Carp::croak("Can't install $dsn driver\n");
1182 # test the connection and warm up caches etc
1183 $drh->connect($dsn,$dbuser,$dbpass) or Carp::croak("connect failed: $DBI::errstr");
1184 my $t1 = dbi_time();
1185 my $loop;
1186 for $loop (1..$loops) {
1187 my @cons;
1188 print "Connecting... " if $verb;
1189 for (1..$par) {
1190 print "$_ ";
1191 push @cons, ($drh->connect($dsn,$dbuser,$dbpass)
1192 or Carp::croak("connect failed: $DBI::errstr\n"));
1193 }
1194 print "\nDisconnecting...\n" if $verb;
1195 for (@cons) {
1196 $_->disconnect or warn "disconnect failed: $DBI::errstr"
1197 }
1198 }
1199 my $t2 = dbi_time();
1200 my $td = $t2 - $t1;
1201 printf "$meth %d and disconnect them, %d times: %.4fs / %d = %.4fs\n",
1202 $par, $loops, $td, $loops*$par, $td/($loops*$par);
1203 return $td;
1204}
1205
1206
1207# Help people doing DBI->errstr, might even document it one day
1208# XXX probably best moved to cheaper XS code if this gets documented
1209sub err { $DBI::err }
1210sub errstr { $DBI::errstr }
1211
1212
1213# --- Private Internal Function for Creating New DBI Handles
1214
1215# XXX move to PurePerl?
12161900ns*DBI::dr::TIEHASH = \&DBI::st::TIEHASH;
12171500ns*DBI::db::TIEHASH = \&DBI::st::TIEHASH;
1218
1219
1220# These three special constructors are called by the drivers
1221# The way they are called is likely to change.
1222
12231200nsour $shared_profile;
1224
1225
# spent 63µs (23+39) within DBI::_new_drh which was called: # once (23µs+39µs) by DBD::SQLite::driver at line 63 of DBD/SQLite.pm
sub _new_drh { # called by DBD::<drivername>::driver()
12261900ns my ($class, $initial_attr, $imp_data) = @_;
1227 # Provide default storage for State,Err and Errstr.
1228 # Note that these are shared by all child handles by default! XXX
1229 # State must be undef to get automatic faking in DBI::var::FETCH
123011µs my ($h_state_store, $h_err_store, $h_errstr_store) = (undef, 0, '');
123116µs my $attr = {
1232 # these attributes get copied down to child handles by default
1233 'State' => \$h_state_store, # Holder for DBI::state
1234 'Err' => \$h_err_store, # Holder for DBI::err
1235 'Errstr' => \$h_errstr_store, # Holder for DBI::errstr
1236 'TraceLevel' => 0,
1237 FetchHashKeyName=> 'NAME',
1238 %$initial_attr,
1239 };
1240150µs139µs my ($h, $i) = _new_handle('DBI::dr', '', $attr, $imp_data, $class);
# spent 39µs making 1 call to DBI::_new_handle
1241
1242 # XXX DBI_PROFILE unless DBI::PurePerl because for some reason
1243 # it kills the t/zz_*_pp.t tests (they silently exit early)
124412µs if (($ENV{DBI_PROFILE} && !$DBI::PurePerl) || $shared_profile) {
1245 # The profile object created here when the first driver is loaded
1246 # is shared by all drivers so we end up with just one set of profile
1247 # data and thus the 'total time in DBI' is really the true total.
1248 if (!$shared_profile) { # first time
1249 $h->{Profile} = $ENV{DBI_PROFILE}; # write string
1250 $shared_profile = $h->{Profile}; # read and record object
1251 }
1252 else {
1253 $h->{Profile} = $shared_profile;
1254 }
1255 }
125614µs return $h unless wantarray;
1257 ($h, $i);
1258}
1259
1260
# spent 292µs (111+181) within DBI::_new_dbh which was called 6 times, avg 49µs/call: # 6 times (111µs+181µs) by DBD::SQLite::dr::connect at line 87 of DBD/SQLite.pm, avg 49µs/call
sub _new_dbh { # called by DBD::<drivername>::dr::connect()
126166µs my ($drh, $attr, $imp_data) = @_;
126269µs my $imp_class = $drh->{ImplementorClass}
1263 or Carp::croak("DBI _new_dbh: $drh has no ImplementorClass");
1264622µs substr($imp_class,-4,4) = '::db';
126566µs my $app_class = ref $drh;
126668µs substr($app_class,-4,4) = '::db';
126768µs $attr->{Err} ||= \my $err;
126867µs $attr->{Errstr} ||= \my $errstr;
126967µs $attr->{State} ||= \my $state;
12706221µs6181µs _new_handle($app_class, $drh, $attr, $imp_data, $imp_class);
# spent 181µs making 6 calls to DBI::_new_handle, avg 30µs/call
1271}
1272
1273
# spent 10.8ms (3.66+7.12) within DBI::_new_sth which was called 145 times, avg 74µs/call: # 145 times (3.66ms+7.12ms) by DBD::SQLite::db::prepare at line 190 of DBD/SQLite.pm, avg 74µs/call
sub _new_sth { # called by DBD::<drivername>::db::prepare)
1274145227µs my ($dbh, $attr, $imp_data) = @_;
1275145385µs my $imp_class = $dbh->{ImplementorClass}
1276 or Carp::croak("DBI _new_sth: $dbh has no ImplementorClass");
1277145819µs substr($imp_class,-4,4) = '::st';
1278145250µs my $app_class = ref $dbh;
1279145332µs substr($app_class,-4,4) = '::st';
12801459.04ms1457.12ms _new_handle($app_class, $dbh, $attr, $imp_data, $imp_class);
# spent 7.12ms making 145 calls to DBI::_new_handle, avg 49µs/call
1281}
1282
1283
1284# end of DBI package
1285
- -
1288# --------------------------------------------------------------------
1289# === The internal DBI Switch pseudo 'driver' class ===
1290
12911200ns{ package # hide from PAUSE
1292 DBD::Switch::dr;
129313µs183µs DBI->setup_driver('DBD::Switch'); # sets up @ISA
# spent 83µs making 1 call to DBI::setup_driver
1294
12951300ns $DBD::Switch::dr::imp_data_size = 0;
12961200ns $DBD::Switch::dr::imp_data_size = 0; # avoid typo warning
12971300ns my $drh;
1298
1299 sub driver {
1300 return $drh if $drh; # a package global
1301
1302 my $inner;
1303 ($drh, $inner) = DBI::_new_drh('DBD::Switch::dr', {
1304 'Name' => 'Switch',
1305 'Version' => $DBI::VERSION,
1306 'Attribution' => "DBI $DBI::VERSION by Tim Bunce",
1307 });
1308 Carp::croak("DBD::Switch init failed!") unless ($drh && $inner);
1309 return $drh;
1310 }
1311 sub CLONE {
1312 undef $drh;
1313 }
1314
1315 sub FETCH {
1316 my($drh, $key) = @_;
1317 return DBI->trace if $key eq 'DebugDispatch';
1318 return undef if $key eq 'DebugLog'; # not worth fetching, sorry
1319 return $drh->DBD::_::dr::FETCH($key);
1320 undef;
1321 }
1322 sub STORE {
1323 my($drh, $key, $value) = @_;
1324 if ($key eq 'DebugDispatch') {
1325 DBI->trace($value);
1326 } elsif ($key eq 'DebugLog') {
1327 DBI->trace(-1, $value);
1328 } else {
1329 $drh->DBD::_::dr::STORE($key, $value);
1330 }
1331 }
1332}
1333
1334
1335# --------------------------------------------------------------------
1336# === OPTIONAL MINIMAL BASE CLASSES FOR DBI SUBCLASSES ===
1337
1338# We only define default methods for harmless functions.
1339# We don't, for example, define a DBD::_::st::prepare()
1340
13411400ns{ package # hide from PAUSE
1342 DBD::_::common; # ====== Common base class methods ======
13433573µs217µs
# spent 14µs (10+4) within DBD::_::common::BEGIN@1343 which was called: # once (10µs+4µs) by DBIx::Class::Storage::DBI::__ANON__[/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/DBIx/Class/Storage/DBI.pm:1300] at line 1343
use strict;
# spent 14µs making 1 call to DBD::_::common::BEGIN@1343 # spent 4µs making 1 call to strict::import
1344
1345 # methods common to all handle types:
1346
1347
# spent 22µs (17+5) within DBD::_::common::_not_impl which was called 2 times, avg 11µs/call: # 2 times (17µs+5µs) by DBI::common::_not_impl at line 1714, avg 11µs/call
sub _not_impl {
134822µs my ($h, $method) = @_;
1349217µs25µs $h->trace_msg("Driver does not implement the $method method.\n");
# spent 5µs making 2 calls to DBI::common::trace_msg, avg 2µs/call
135026µs return; # empty list / undef
1351 }
1352
1353 # generic TIEHASH default methods:
1354427µs
# spent 14µs within DBD::_::common::FIRSTKEY which was called 4 times, avg 3µs/call: # 4 times (14µs+0s) by DBI::common::FIRSTKEY at line 190 of Data/Dumper.pm, avg 3µs/call
sub FIRSTKEY { }
1355 sub NEXTKEY { }
1356 sub EXISTS { defined($_[0]->FETCH($_[1])) } # XXX undef?
1357 sub CLEAR { Carp::carp "Can't CLEAR $_[0] (DBI)" }
1358
1359 sub FETCH_many { # XXX should move to C one day
1360 my $h = shift;
1361 # scalar is needed to workaround drivers that return an empty list
1362 # for some attributes
1363 return map { scalar $h->FETCH($_) } @_;
1364 }
1365
136611µs *dump_handle = \&DBI::dump_handle;
1367
1368
# spent 336µs (200+135) within DBD::_::common::install_method which was called 15 times, avg 22µs/call: # once (33µs+19µs) by DBD::SQLite::driver at line 44 of DBD/SQLite.pm # once (12µs+11µs) by DBD::SQLite::driver at line 50 of DBD/SQLite.pm # once (13µs+9µs) by DBD::SQLite::driver at line 45 of DBD/SQLite.pm # once (15µs+7µs) by DBD::SQLite::driver at line 58 of DBD/SQLite.pm # once (11µs+10µs) by DBD::SQLite::driver at line 53 of DBD/SQLite.pm # once (11µs+10µs) by DBD::SQLite::driver at line 56 of DBD/SQLite.pm # once (11µs+10µs) by DBD::SQLite::driver at line 55 of DBD/SQLite.pm # once (13µs+7µs) by DBD::SQLite::driver at line 46 of DBD/SQLite.pm # once (11µs+9µs) by DBD::SQLite::driver at line 48 of DBD/SQLite.pm # once (12µs+7µs) by DBD::SQLite::driver at line 51 of DBD/SQLite.pm # once (12µs+7µs) by DBD::SQLite::driver at line 54 of DBD/SQLite.pm # once (11µs+8µs) by DBD::SQLite::driver at line 47 of DBD/SQLite.pm # once (12µs+7µs) by DBD::SQLite::driver at line 52 of DBD/SQLite.pm # once (12µs+7µs) by DBD::SQLite::driver at line 57 of DBD/SQLite.pm # once (11µs+7µs) by DBD::SQLite::driver at line 49 of DBD/SQLite.pm
sub install_method {
1369 # special class method called directly by apps and/or drivers
1370 # to install new methods into the DBI dispatcher
1371 # DBD::Foo::db->install_method("foo_mumble", { usage => [...], options => '...' });
13721510µs my ($class, $method, $attr) = @_;
13731555µs1528µs Carp::croak("Class '$class' must begin with DBD:: and end with ::db or ::st")
# spent 28µs making 15 calls to DBD::_::common::CORE:match, avg 2µs/call
1374 unless $class =~ /^DBD::(\w+)::(dr|db|st)$/;
13751515µs my ($driver, $subtype) = ($1, $2);
13761537µs1516µs Carp::croak("invalid method name '$method'")
# spent 16µs making 15 calls to DBD::_::common::CORE:match, avg 1µs/call
1377 unless $method =~ m/^([a-z]+_)\w+$/;
1378157µs my $prefix = $1;
1379157µs my $reg_info = $dbd_prefix_registry->{$prefix};
1380152µs Carp::carp("method name prefix '$prefix' is not associated with a registered driver") unless $reg_info;
1381
1382159µs my $full_method = "DBI::${subtype}::$method";
13831516µs $DBI::installed_methods{$full_method} = $attr;
1384
13851516µs my (undef, $filename, $line) = caller;
1386 # XXX reformat $attr as needed for _install_method
13871515µs my %attr = %{$attr||{}}; # copy so we can edit
138815168µs1591µs DBI->_install_method("DBI::${subtype}::$method", "$filename at line $line", \%attr);
# spent 91µs making 15 calls to DBI::_install_method, avg 6µs/call
1389 }
1390
1391 sub parse_trace_flags {
1392 my ($h, $spec) = @_;
1393 my $level = 0;
1394 my $flags = 0;
1395 my @unknown;
1396 for my $word (split /\s*[|&,]\s*/, $spec) {
1397 if (DBI::looks_like_number($word) && $word <= 0xF && $word >= 0) {
1398 $level = $word;
1399 } elsif ($word eq 'ALL') {
1400 $flags = 0x7FFFFFFF; # XXX last bit causes negative headaches
1401 last;
1402 } elsif (my $flag = $h->parse_trace_flag($word)) {
1403 $flags |= $flag;
1404 }
1405 else {
1406 push @unknown, $word;
1407 }
1408 }
1409 if (@unknown && (ref $h ? $h->FETCH('Warn') : 1)) {
1410 Carp::carp("$h->parse_trace_flags($spec) ignored unknown trace flags: ".
1411 join(" ", map { DBI::neat($_) } @unknown));
1412 }
1413 $flags |= $level;
1414 return $flags;
1415 }
1416
1417 sub parse_trace_flag {
1418 my ($h, $name) = @_;
1419 # 0xddDDDDrL (driver, DBI, reserved, Level)
1420 return 0x00000100 if $name eq 'SQL';
1421 return 0x00000200 if $name eq 'CON';
1422 return 0x00000400 if $name eq 'ENC';
1423 return 0x00000800 if $name eq 'DBD';
1424 return 0x00001000 if $name eq 'TXN';
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
14461800ns{ package # hide from PAUSE
1447 DBD::_::dr; # ====== DRIVER ======
144817µs @DBD::_::dr::ISA = qw(DBD::_::common);
14493256µs220µs
# spent 18µs (15+2) within DBD::_::dr::BEGIN@1449 which was called: # once (15µs+2µs) by DBIx::Class::Storage::DBI::__ANON__[/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/DBIx/Class/Storage/DBI.pm:1300] at line 1449
use strict;
# spent 18µs making 1 call to DBD::_::dr::BEGIN@1449 # spent 2µ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 & 0xF) >= 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
15071700ns{ package # hide from PAUSE
1508 DBD::_::db; # ====== DATABASE ======
150916µs @DBD::_::db::ISA = qw(DBD::_::common);
151031.38ms216µs
# spent 14µs (12+2) within DBD::_::db::BEGIN@1510 which was called: # once (12µs+2µs) by DBIx::Class::Storage::DBI::__ANON__[/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/DBIx/Class/Storage/DBI.pm:1300] at line 1510
use strict;
# spent 14µs making 1 call to DBD::_::db::BEGIN@1510 # spent 2µs making 1 call to strict::import
1511
1512 sub clone {
1513 my ($old_dbh, $attr) = @_;
1514
1515 my $closure = $old_dbh->{dbi_connect_closure}
1516 or return $old_dbh->set_err($DBI::stderr, "Can't clone handle");
1517
1518 unless ($attr) { # XXX deprecated, caller should always pass a hash ref
1519 # copy attributes visible in the attribute cache
1520 keys %$old_dbh; # reset iterator
1521 while ( my ($k, $v) = each %$old_dbh ) {
1522 # ignore non-code refs, i.e., caches, handles, Err etc
1523 next if ref $v && ref $v ne 'CODE'; # HandleError etc
1524 $attr->{$k} = $v;
1525 }
1526 # explicitly set attributes which are unlikely to be in the
1527 # attribute cache, i.e., boolean's and some others
1528 $attr->{$_} = $old_dbh->FETCH($_) for (qw(
1529 AutoCommit ChopBlanks InactiveDestroy AutoInactiveDestroy
1530 LongTruncOk PrintError PrintWarn Profile RaiseError
1531 ShowErrorStatement TaintIn TaintOut
1532 ));
1533 }
1534
1535 # use Data::Dumper; warn Dumper([$old_dbh, $attr]);
1536 my $new_dbh = &$closure($old_dbh, $attr);
1537 unless ($new_dbh) {
1538 # need to copy err/errstr from driver back into $old_dbh
1539 my $drh = $old_dbh->{Driver};
1540 return $old_dbh->set_err($drh->err, $drh->errstr, $drh->state);
1541 }
1542 $new_dbh->{dbi_connect_closure} = $closure;
1543 return $new_dbh;
1544 }
1545
1546 sub quote_identifier {
1547 my ($dbh, @id) = @_;
1548 my $attr = (@id > 3 && ref($id[-1])) ? pop @id : undef;
1549
1550 my $info = $dbh->{dbi_quote_identifier_cache} ||= [
1551 $dbh->get_info(29) || '"', # SQL_IDENTIFIER_QUOTE_CHAR
1552 $dbh->get_info(41) || '.', # SQL_CATALOG_NAME_SEPARATOR
1553 $dbh->get_info(114) || 1, # SQL_CATALOG_LOCATION
1554 ];
1555
1556 my $quote = $info->[0];
1557 foreach (@id) { # quote the elements
1558 next unless defined;
1559 s/$quote/$quote$quote/g; # escape embedded quotes
1560 $_ = qq{$quote$_$quote};
1561 }
1562
1563 # strip out catalog if present for special handling
1564 my $catalog = (@id >= 3) ? shift @id : undef;
1565
1566 # join the dots, ignoring any null/undef elements (ie schema)
1567 my $quoted_id = join '.', grep { defined } @id;
1568
1569 if ($catalog) { # add catalog correctly
1570 $quoted_id = ($info->[2] == 2) # SQL_CL_END
1571 ? $quoted_id . $info->[1] . $catalog
1572 : $catalog . $info->[1] . $quoted_id;
1573 }
1574 return $quoted_id;
1575 }
1576
1577 sub quote {
1578 my ($dbh, $str, $data_type) = @_;
1579
1580 return "NULL" unless defined $str;
1581 unless ($data_type) {
1582 $str =~ s/'/''/g; # ISO SQL2
1583 return "'$str'";
1584 }
1585
1586 my $dbi_literal_quote_cache = $dbh->{'dbi_literal_quote_cache'} ||= [ {} , {} ];
1587 my ($prefixes, $suffixes) = @$dbi_literal_quote_cache;
1588
1589 my $lp = $prefixes->{$data_type};
1590 my $ls = $suffixes->{$data_type};
1591
1592 if ( ! defined $lp || ! defined $ls ) {
1593 my $ti = $dbh->type_info($data_type);
1594 $lp = $prefixes->{$data_type} = $ti ? $ti->{LITERAL_PREFIX} || "" : "'";
1595 $ls = $suffixes->{$data_type} = $ti ? $ti->{LITERAL_SUFFIX} || "" : "'";
1596 }
1597 return $str unless $lp || $ls; # no quoting required
1598
1599 # XXX don't know what the standard says about escaping
1600 # in the 'general case' (where $lp != "'").
1601 # So we just do this and hope:
1602 $str =~ s/$lp/$lp$lp/g
1603 if $lp && $lp eq $ls && ($lp eq "'" || $lp eq '"');
1604 return "$lp$str$ls";
1605 }
1606
1607 sub rows { -1 } # here so $DBI::rows 'works' after using $dbh
1608
1609 sub do {
1610 my($dbh, $statement, $attr, @params) = @_;
1611 my $sth = $dbh->prepare($statement, $attr) or return undef;
1612 $sth->execute(@params) or return undef;
1613 my $rows = $sth->rows;
1614 ($rows == 0) ? "0E0" : $rows;
1615 }
1616
1617 sub _do_selectrow {
1618 my ($method, $dbh, $stmt, $attr, @bind) = @_;
1619 my $sth = ((ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr))
1620 or return;
1621 $sth->execute(@bind)
1622 or return;
1623 my $row = $sth->$method()
1624 and $sth->finish;
1625 return $row;
1626 }
1627
1628 sub selectrow_hashref { return _do_selectrow('fetchrow_hashref', @_); }
1629
1630 # XXX selectrow_array/ref also have C implementations in Driver.xst
1631 sub selectrow_arrayref { return _do_selectrow('fetchrow_arrayref', @_); }
1632 sub selectrow_array {
1633 my $row = _do_selectrow('fetchrow_arrayref', @_) or return;
1634 return $row->[0] unless wantarray;
1635 return @$row;
1636 }
1637
1638 # XXX selectall_arrayref also has C implementation in Driver.xst
1639 # which fallsback to this if a slice is given
1640 sub selectall_arrayref {
1641 my ($dbh, $stmt, $attr, @bind) = @_;
1642 my $sth = (ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr)
1643 or return;
1644 $sth->execute(@bind) || return;
1645 my $slice = $attr->{Slice}; # typically undef, else hash or array ref
1646 if (!$slice and $slice=$attr->{Columns}) {
1647 if (ref $slice eq 'ARRAY') { # map col idx to perl array idx
1648 $slice = [ @{$attr->{Columns}} ]; # take a copy
1649 for (@$slice) { $_-- }
1650 }
1651 }
1652 my $rows = $sth->fetchall_arrayref($slice, my $MaxRows = $attr->{MaxRows});
1653 $sth->finish if defined $MaxRows;
1654 return $rows;
1655 }
1656
1657 sub selectall_hashref {
1658 my ($dbh, $stmt, $key_field, $attr, @bind) = @_;
1659 my $sth = (ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr);
1660 return unless $sth;
1661 $sth->execute(@bind) || return;
1662 return $sth->fetchall_hashref($key_field);
1663 }
1664
1665 sub selectcol_arrayref {
1666 my ($dbh, $stmt, $attr, @bind) = @_;
1667 my $sth = (ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr);
1668 return unless $sth;
1669 $sth->execute(@bind) || return;
1670 my @columns = ($attr->{Columns}) ? @{$attr->{Columns}} : (1);
1671 my @values = (undef) x @columns;
1672 my $idx = 0;
1673 for (@columns) {
1674 $sth->bind_col($_, \$values[$idx++]) || return;
1675 }
1676 my @col;
1677 if (my $max = $attr->{MaxRows}) {
1678 push @col, @values while 0 < $max-- && $sth->fetch;
1679 }
1680 else {
1681 push @col, @values while $sth->fetch;
1682 }
1683 return \@col;
1684 }
1685
1686
# spent 280ms (185+95.5) within DBD::_::db::prepare_cached which was called 8019 times, avg 35µs/call: # 8019 times (185ms+95.5ms) by DBI::db::prepare_cached at line 2252 of DBIx/Class/Storage/DBI.pm, avg 35µs/call
sub prepare_cached {
1687801910.9ms my ($dbh, $statement, $attr, $if_active) = @_;
1688
1689 # Needs support at dbh level to clear cache before complaining about
1690 # active children. The XS template code does this. Drivers not using
1691 # the template must handle clearing the cache themselves.
169280199.20ms my $cache = $dbh->{CachedKids} ||= {};
16931603842.6ms my $key = do { local $^W;
1694801967.9ms801923.7ms join "!\001", $statement, DBI::_concat_hash_sorted($attr, "=\001", ",\001", 0, 0)
# spent 23.7ms making 8019 calls to DBI::_concat_hash_sorted, avg 3µs/call
1695 };
1696801914.7ms my $sth = $cache->{$key};
1697
169880192.74ms if ($sth) {
16997945122ms794555.1ms return $sth unless $sth->FETCH('Active');
# spent 55.1ms making 7945 calls to DBI::common::FETCH, avg 7µs/call
1700 Carp::carp("prepare_cached($statement) statement handle $sth still Active")
1701 unless ($if_active ||= 0);
1702 $sth->finish if $if_active <= 1;
1703 return $sth if $if_active <= 2;
1704 }
1705
170674973µs15432.8ms $sth = $dbh->prepare($statement, $attr);
# spent 16.7ms making 74 calls to DBI::db::prepare, avg 226µs/call # spent 16.0ms making 74 calls to DBD::SQLite::db::prepare, avg 217µs/call # spent 15µs making 4 calls to DBI::common::DESTROY, avg 4µs/call # spent 6µs making 2 calls to DBD::_mem::common::DESTROY, avg 3µs/call
170774220µs $cache->{$key} = $sth if $sth;
1708
170974335µs return $sth;
1710 }
1711
1712
# spent 60µs (23+37) within DBD::_::db::ping which was called 2 times, avg 30µs/call: # 2 times (23µs+37µs) by DBI::db::ping at line 901 of DBIx/Class/Storage/DBI.pm, avg 30µs/call
sub ping {
17132800ns my $dbh = shift;
1714223µs457µs $dbh->_not_impl('ping');
# spent 35µs making 2 calls to DBI::common::_not_impl, avg 17µs/call # spent 22µs making 2 calls to DBD::_::common::_not_impl, avg 11µs/call
1715 # "0 but true" is a special kind of true 0 that is used here so
1716 # applications can check if the ping was a real ping or not
1717214µs22µs ($dbh->FETCH('Active')) ? "0 but true" : 0;
# spent 2µs making 2 calls to DBI::common::FETCH, avg 1µs/call
1718 }
1719
1720
# spent 9.39ms (4.89+4.50) within DBD::_::db::begin_work which was called 294 times, avg 32µs/call: # 294 times (4.89ms+4.50ms) by DBI::db::begin_work at line 1339 of DBIx/Class/Storage/DBI.pm, avg 32µs/call
sub begin_work {
1721294228µs my $dbh = shift;
17222944.02ms2942.36ms return $dbh->set_err($DBI::stderr, "Already in a transaction")
# spent 2.36ms making 294 calls to DBI::common::FETCH, avg 8µs/call
1723 unless $dbh->FETCH('AutoCommit');
17242942.05ms294743µs $dbh->STORE('AutoCommit', 0); # will croak if driver doesn't support it
# spent 743µs making 294 calls to DBI::common::STORE, avg 3µs/call
17252942.27ms2941.40ms $dbh->STORE('BegunWork', 1); # trigger post commit/rollback action
# spent 1.40ms making 294 calls to DBI::common::STORE, avg 5µs/call
17262941.07ms return 1;
1727 }
1728
1729 sub primary_key {
1730 my ($dbh, @args) = @_;
1731 my $sth = $dbh->primary_key_info(@args) or return;
1732 my ($row, @col);
1733 push @col, $row->[3] while ($row = $sth->fetch);
1734 Carp::croak("primary_key method not called in list context")
1735 unless wantarray; # leave us some elbow room
1736 return @col;
1737 }
1738
1739 sub tables {
1740 my ($dbh, @args) = @_;
1741 my $sth = $dbh->table_info(@args[0,1,2,3,4]) or return;
1742 my $tables = $sth->fetchall_arrayref or return;
1743 my @tables;
1744 if ($dbh->get_info(29)) { # SQL_IDENTIFIER_QUOTE_CHAR
1745 @tables = map { $dbh->quote_identifier( @{$_}[0,1,2] ) } @$tables;
1746 }
1747 else { # temporary old style hack (yeach)
1748 @tables = map {
1749 my $name = $_->[2];
1750 if ($_->[1]) {
1751 my $schema = $_->[1];
1752 # a sad hack (mostly for Informix I recall)
1753 my $quote = ($schema eq uc($schema)) ? '' : '"';
1754 $name = "$quote$schema$quote.$name"
1755 }
1756 $name;
1757 } @$tables;
1758 }
1759 return @tables;
1760 }
1761
1762 sub type_info { # this should be sufficient for all drivers
1763 my ($dbh, $data_type) = @_;
1764 my $idx_hash;
1765 my $tia = $dbh->{dbi_type_info_row_cache};
1766 if ($tia) {
1767 $idx_hash = $dbh->{dbi_type_info_idx_cache};
1768 }
1769 else {
1770 my $temp = $dbh->type_info_all;
1771 return unless $temp && @$temp;
1772 # we cache here because type_info_all may be expensive to call
1773 # (and we take a copy so the following shift can't corrupt
1774 # the data that may be returned by future calls to type_info_all)
1775 $tia = $dbh->{dbi_type_info_row_cache} = [ @$temp ];
1776 $idx_hash = $dbh->{dbi_type_info_idx_cache} = shift @$tia;
1777 }
1778
1779 my $dt_idx = $idx_hash->{DATA_TYPE} || $idx_hash->{data_type};
1780 Carp::croak("type_info_all returned non-standard DATA_TYPE index value ($dt_idx != 1)")
1781 if $dt_idx && $dt_idx != 1;
1782
1783 # --- simple DATA_TYPE match filter
1784 my @ti;
1785 my @data_type_list = (ref $data_type) ? @$data_type : ($data_type);
1786 foreach $data_type (@data_type_list) {
1787 if (defined($data_type) && $data_type != DBI::SQL_ALL_TYPES()) {
1788 push @ti, grep { $_->[$dt_idx] == $data_type } @$tia;
1789 }
1790 else { # SQL_ALL_TYPES
1791 push @ti, @$tia;
1792 }
1793 last if @ti; # found at least one match
1794 }
1795
1796 # --- format results into list of hash refs
1797 my $idx_fields = keys %$idx_hash;
1798 my @idx_names = map { uc($_) } keys %$idx_hash;
1799 my @idx_values = values %$idx_hash;
1800 Carp::croak "type_info_all result has $idx_fields keys but ".(@{$ti[0]})." fields"
1801 if @ti && @{$ti[0]} != $idx_fields;
1802 my @out = map {
1803 my %h; @h{@idx_names} = @{$_}[ @idx_values ]; \%h;
1804 } @ti;
1805 return $out[0] unless wantarray;
1806 return @out;
1807 }
1808
1809 sub data_sources {
1810 my ($dbh, @other) = @_;
1811 my $drh = $dbh->{Driver}; # XXX proxy issues?
1812 return $drh->data_sources(@other);
1813 }
1814
1815}
1816
1817
18181400ns{ package # hide from PAUSE
1819 DBD::_::st; # ====== STATEMENT ======
182015µs @DBD::_::st::ISA = qw(DBD::_::common);
182131.41ms216µs
# spent 13µs (10+3) within DBD::_::st::BEGIN@1821 which was called: # once (10µs+3µs) by DBIx::Class::Storage::DBI::__ANON__[/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/DBIx/Class/Storage/DBI.pm:1300] at line 1821
use strict;
# spent 13µs making 1 call to DBD::_::st::BEGIN@1821 # spent 3µs making 1 call to strict::import
1822
1823 sub bind_param { Carp::croak("Can't bind_param, not implement by driver") }
1824
1825#
1826# ********************************************************
1827#
1828# BEGIN ARRAY BINDING
1829#
1830# Array binding support for drivers which don't support
1831# array binding, but have sufficient interfaces to fake it.
1832# NOTE: mixing scalars and arrayrefs requires using bind_param_array
1833# for *all* params...unless we modify bind_param for the default
1834# case...
1835#
1836# 2002-Apr-10 D. Arnold
1837
1838 sub bind_param_array {
1839 my $sth = shift;
1840 my ($p_id, $value_array, $attr) = @_;
1841
1842 return $sth->set_err($DBI::stderr, "Value for parameter $p_id must be a scalar or an arrayref, not a ".ref($value_array))
1843 if defined $value_array and ref $value_array and ref $value_array ne 'ARRAY';
1844
1845 return $sth->set_err($DBI::stderr, "Can't use named placeholder '$p_id' for non-driver supported bind_param_array")
1846 unless DBI::looks_like_number($p_id); # because we rely on execute(@ary) here
1847
1848 return $sth->set_err($DBI::stderr, "Placeholder '$p_id' is out of range")
1849 if $p_id <= 0; # can't easily/reliably test for too big
1850
1851 # get/create arrayref to hold params
1852 my $hash_of_arrays = $sth->{ParamArrays} ||= { };
1853
1854 # If the bind has attribs then we rely on the driver conforming to
1855 # the DBI spec in that a single bind_param() call with those attribs
1856 # makes them 'sticky' and apply to all later execute(@values) calls.
1857 # Since we only call bind_param() if we're given attribs then
1858 # applications using drivers that don't support bind_param can still
1859 # use bind_param_array() so long as they don't pass any attribs.
1860
1861 $$hash_of_arrays{$p_id} = $value_array;
1862 return $sth->bind_param($p_id, undef, $attr)
1863 if $attr;
1864 1;
1865 }
1866
1867 sub bind_param_inout_array {
1868 my $sth = shift;
1869 # XXX not supported so we just call bind_param_array instead
1870 # and then return an error
1871 my ($p_num, $value_array, $attr) = @_;
1872 $sth->bind_param_array($p_num, $value_array, $attr);
1873 return $sth->set_err($DBI::stderr, "bind_param_inout_array not supported");
1874 }
1875
1876 sub bind_columns {
1877 my $sth = shift;
1878 my $fields = $sth->FETCH('NUM_OF_FIELDS') || 0;
1879 if ($fields <= 0 && !$sth->{Active}) {
1880 return $sth->set_err($DBI::stderr, "Statement has no result columns to bind"
1881 ." (perhaps you need to successfully call execute first)");
1882 }
1883 # Backwards compatibility for old-style call with attribute hash
1884 # ref as first arg. Skip arg if undef or a hash ref.
1885 my $attr;
1886 $attr = shift if !defined $_[0] or ref($_[0]) eq 'HASH';
1887
1888 my $idx = 0;
1889 $sth->bind_col(++$idx, shift, $attr) or return
1890 while (@_ and $idx < $fields);
1891
1892 return $sth->set_err($DBI::stderr, "bind_columns called with ".($idx+@_)." values but $fields are needed")
1893 if @_ or $idx != $fields;
1894
1895 return 1;
1896 }
1897
1898 sub execute_array {
1899 my $sth = shift;
1900 my ($attr, @array_of_arrays) = @_;
1901 my $NUM_OF_PARAMS = $sth->FETCH('NUM_OF_PARAMS'); # may be undef at this point
1902
1903 # get tuple status array or hash attribute
1904 my $tuple_sts = $attr->{ArrayTupleStatus};
1905 return $sth->set_err($DBI::stderr, "ArrayTupleStatus attribute must be an arrayref")
1906 if $tuple_sts and ref $tuple_sts ne 'ARRAY';
1907
1908 # bind all supplied arrays
1909 if (@array_of_arrays) {
1910 $sth->{ParamArrays} = { }; # clear out old params
1911 return $sth->set_err($DBI::stderr,
1912 @array_of_arrays." bind values supplied but $NUM_OF_PARAMS expected")
1913 if defined ($NUM_OF_PARAMS) && @array_of_arrays != $NUM_OF_PARAMS;
1914 $sth->bind_param_array($_, $array_of_arrays[$_-1]) or return
1915 foreach (1..@array_of_arrays);
1916 }
1917
1918 my $fetch_tuple_sub;
1919
1920 if ($fetch_tuple_sub = $attr->{ArrayTupleFetch}) { # fetch on demand
1921
1922 return $sth->set_err($DBI::stderr,
1923 "Can't use both ArrayTupleFetch and explicit bind values")
1924 if @array_of_arrays; # previous bind_param_array calls will simply be ignored
1925
1926 if (UNIVERSAL::isa($fetch_tuple_sub,'DBI::st')) {
1927 my $fetch_sth = $fetch_tuple_sub;
1928 return $sth->set_err($DBI::stderr,
1929 "ArrayTupleFetch sth is not Active, need to execute() it first")
1930 unless $fetch_sth->{Active};
1931 # check column count match to give more friendly message
1932 my $NUM_OF_FIELDS = $fetch_sth->{NUM_OF_FIELDS};
1933 return $sth->set_err($DBI::stderr,
1934 "$NUM_OF_FIELDS columns from ArrayTupleFetch sth but $NUM_OF_PARAMS expected")
1935 if defined($NUM_OF_FIELDS) && defined($NUM_OF_PARAMS)
1936 && $NUM_OF_FIELDS != $NUM_OF_PARAMS;
1937 $fetch_tuple_sub = sub { $fetch_sth->fetchrow_arrayref };
1938 }
1939 elsif (!UNIVERSAL::isa($fetch_tuple_sub,'CODE')) {
1940 return $sth->set_err($DBI::stderr, "ArrayTupleFetch '$fetch_tuple_sub' is not a code ref or statement handle");
1941 }
1942
1943 }
1944 else {
1945 my $NUM_OF_PARAMS_given = keys %{ $sth->{ParamArrays} || {} };
1946 return $sth->set_err($DBI::stderr,
1947 "$NUM_OF_PARAMS_given bind values supplied but $NUM_OF_PARAMS expected")
1948 if defined($NUM_OF_PARAMS) && $NUM_OF_PARAMS != $NUM_OF_PARAMS_given;
1949
1950 # get the length of a bound array
1951 my $maxlen;
1952 my %hash_of_arrays = %{$sth->{ParamArrays}};
1953 foreach (keys(%hash_of_arrays)) {
1954 my $ary = $hash_of_arrays{$_};
1955 next unless ref $ary eq 'ARRAY';
1956 $maxlen = @$ary if !$maxlen || @$ary > $maxlen;
1957 }
1958 # if there are no arrays then execute scalars once
1959 $maxlen = 1 unless defined $maxlen;
1960 my @bind_ids = 1..keys(%hash_of_arrays);
1961
1962 my $tuple_idx = 0;
1963 $fetch_tuple_sub = sub {
1964 return if $tuple_idx >= $maxlen;
1965 my @tuple = map {
1966 my $a = $hash_of_arrays{$_};
1967 ref($a) ? $a->[$tuple_idx] : $a
1968 } @bind_ids;
1969 ++$tuple_idx;
1970 return \@tuple;
1971 };
1972 }
1973 # pass thru the callers scalar or list context
1974 return $sth->execute_for_fetch($fetch_tuple_sub, $tuple_sts);
1975 }
1976
1977 sub execute_for_fetch {
1978 my ($sth, $fetch_tuple_sub, $tuple_status) = @_;
1979 # start with empty status array
1980 ($tuple_status) ? @$tuple_status = () : $tuple_status = [];
1981
1982 my $rc_total = 0;
1983 my $err_count;
1984 while ( my $tuple = &$fetch_tuple_sub() ) {
1985 if ( my $rc = $sth->execute(@$tuple) ) {
1986 push @$tuple_status, $rc;
1987 $rc_total = ($rc >= 0 && $rc_total >= 0) ? $rc_total + $rc : -1;
1988 }
1989 else {
1990 $err_count++;
1991 push @$tuple_status, [ $sth->err, $sth->errstr, $sth->state ];
1992 # XXX drivers implementing execute_for_fetch could opt to "last;" here
1993 # if they know the error code means no further executes will work.
1994 }
1995 }
1996 my $tuples = @$tuple_status;
1997 return $sth->set_err($DBI::stderr, "executing $tuples generated $err_count errors")
1998 if $err_count;
1999 $tuples ||= "0E0";
2000 return $tuples unless wantarray;
2001 return ($tuples, $rc_total);
2002 }
2003
2004
2005 sub fetchall_arrayref { # ALSO IN Driver.xst
2006 my ($sth, $slice, $max_rows) = @_;
2007
2008 # when batch fetching with $max_rows were very likely to try to
2009 # fetch the 'next batch' after the previous batch returned
2010 # <=$max_rows. So don't treat that as an error.
2011 return undef if $max_rows and not $sth->FETCH('Active');
2012
2013 my $mode = ref($slice) || 'ARRAY';
2014 my @rows;
2015
2016 if ($mode eq 'ARRAY') {
2017 my $row;
2018 # we copy the array here because fetch (currently) always
2019 # returns the same array ref. XXX
2020 if ($slice && @$slice) {
2021 $max_rows = -1 unless defined $max_rows;
2022 push @rows, [ @{$row}[ @$slice] ]
2023 while($max_rows-- and $row = $sth->fetch);
2024 }
2025 elsif (defined $max_rows) {
2026 push @rows, [ @$row ]
2027 while($max_rows-- and $row = $sth->fetch);
2028 }
2029 else {
2030 push @rows, [ @$row ] while($row = $sth->fetch);
2031 }
2032 return \@rows
2033 }
2034
2035 my %row;
2036 if ($mode eq 'REF' && ref($$slice) eq 'HASH') { # \{ $idx => $name }
2037 keys %$$slice; # reset the iterator
2038 while ( my ($idx, $name) = each %$$slice ) {
2039 $sth->bind_col($idx+1, \$row{$name});
2040 }
2041 }
2042 elsif ($mode eq 'HASH') {
2043 if (keys %$slice) {
2044 keys %$slice; # reset the iterator
2045 my $name2idx = $sth->FETCH('NAME_lc_hash');
2046 while ( my ($name, $unused) = each %$slice ) {
2047 my $idx = $name2idx->{lc $name};
2048 return $sth->set_err($DBI::stderr, "Invalid column name '$name' for slice")
2049 if not defined $idx;
2050 $sth->bind_col($idx+1, \$row{$name});
2051 }
2052 }
2053 else {
2054 $sth->bind_columns( \( @row{ @{$sth->FETCH($sth->FETCH('FetchHashKeyName')) } } ) );
2055 }
2056 }
2057 else {
2058 return $sth->set_err($DBI::stderr, "fetchall_arrayref($mode) invalid");
2059 }
2060
2061 if (not defined $max_rows) {
2062 push @rows, { %row } while ($sth->fetch); # full speed ahead!
2063 }
2064 else {
2065 push @rows, { %row } while ($max_rows-- and $sth->fetch);
2066 }
2067
2068 return \@rows;
2069 }
2070
2071 sub fetchall_hashref {
2072 my ($sth, $key_field) = @_;
2073
2074 my $hash_key_name = $sth->{FetchHashKeyName} || 'NAME';
2075 my $names_hash = $sth->FETCH("${hash_key_name}_hash");
2076 my @key_fields = (ref $key_field) ? @$key_field : ($key_field);
2077 my @key_indexes;
2078 my $num_of_fields = $sth->FETCH('NUM_OF_FIELDS');
2079 foreach (@key_fields) {
2080 my $index = $names_hash->{$_}; # perl index not column
2081 $index = $_ - 1 if !defined $index && DBI::looks_like_number($_) && $_>=1 && $_ <= $num_of_fields;
2082 return $sth->set_err($DBI::stderr, "Field '$_' does not exist (not one of @{[keys %$names_hash]})")
2083 unless defined $index;
2084 push @key_indexes, $index;
2085 }
2086 my $rows = {};
2087 my $NAME = $sth->FETCH($hash_key_name);
2088 my @row = (undef) x $num_of_fields;
2089 $sth->bind_columns(\(@row));
2090 while ($sth->fetch) {
2091 my $ref = $rows;
2092 $ref = $ref->{$row[$_]} ||= {} for @key_indexes;
2093 @{$ref}{@$NAME} = @row;
2094 }
2095 return $rows;
2096 }
2097
209812µs *dump_results = \&DBI::dump_results;
2099
2100 sub blob_copy_to_file { # returns length or undef on error
2101 my($self, $field, $filename_or_handleref, $blocksize) = @_;
2102 my $fh = $filename_or_handleref;
2103 my($len, $buf) = (0, "");
2104 $blocksize ||= 512; # not too ambitious
2105 local(*FH);
2106 unless(ref $fh) {
2107 open(FH, ">$fh") || return undef;
2108 $fh = \*FH;
2109 }
2110 while(defined($self->blob_read($field, $len, $blocksize, \$buf))) {
2111 print $fh $buf;
2112 $len += length $buf;
2113 }
2114 close(FH);
2115 $len;
2116 }
2117
2118 sub more_results {
2119 shift->{syb_more_results}; # handy grandfathering
2120 }
2121
2122}
2123
21241800nsunless ($DBI::PurePerl) { # See install_driver
212528µs { @DBD::_mem::dr::ISA = qw(DBD::_mem::common); }
212626µs { @DBD::_mem::db::ISA = qw(DBD::_mem::common); }
212725µs { @DBD::_mem::st::ISA = qw(DBD::_mem::common); }
2128 # DBD::_mem::common::DESTROY is implemented in DBI.xs
2129}
2130
2131199µs1;
2132__END__
 
# spent 44µs within DBD::_::common::CORE:match which was called 30 times, avg 1µs/call: # 15 times (28µs+0s) by DBD::_::common::install_method at line 1373, avg 2µs/call # 15 times (16µs+0s) by DBD::_::common::install_method at line 1376, avg 1µs/call
sub DBD::_::common::CORE:match; # opcode
# spent 5µs within DBD::_::common::trace_msg which was called: # once (5µs+0s) by DBI::END at line 516
sub DBD::_::common::trace_msg; # xsub
# spent 34µs within DBI::CORE:match which was called 127 times, avg 267ns/call: # 127 times (34µs+0s) by DBI::BEGIN@161 at line 262, avg 267ns/call
sub DBI::CORE:match; # opcode
# spent 56µs within DBI::CORE:subst which was called 7 times, avg 8µs/call: # 6 times (55µs+0s) by DBI::connect at line 596, avg 9µs/call # once (1µs+0s) by DBI::install_driver at line 756
sub DBI::CORE:subst; # opcode
# spent 500ns within DBI::SQL_BINARY which was called: # once (500ns+0s) by SQL::Translator::Schema::Table::BEGIN@44 at line 65 of SQL/Translator/Schema/Field.pm
sub DBI::SQL_BINARY; # xsub
# spent 400ns within DBI::SQL_BIT which was called: # once (400ns+0s) by SQL::Translator::Schema::Table::BEGIN@44 at line 65 of SQL/Translator/Schema/Field.pm
sub DBI::SQL_BIT; # xsub
# spent 1µs within DBI::SQL_BLOB which was called 2 times, avg 500ns/call: # 2 times (1µs+0s) by SQL::Translator::Schema::Table::BEGIN@44 at line 65 of SQL/Translator/Schema/Field.pm, avg 500ns/call
sub DBI::SQL_BLOB; # xsub
# spent 400ns within DBI::SQL_CHAR which was called: # once (400ns+0s) by SQL::Translator::Schema::Table::BEGIN@44 at line 65 of SQL/Translator/Schema/Field.pm
sub DBI::SQL_CHAR; # xsub
# spent 400ns within DBI::SQL_DATE which was called: # once (400ns+0s) by SQL::Translator::Schema::Table::BEGIN@44 at line 65 of SQL/Translator/Schema/Field.pm
sub DBI::SQL_DATE; # xsub
# spent 500ns within DBI::SQL_DATETIME which was called: # once (500ns+0s) by SQL::Translator::Schema::Table::BEGIN@44 at line 65 of SQL/Translator/Schema/Field.pm
sub DBI::SQL_DATETIME; # xsub
# spent 1µs within DBI::SQL_DECIMAL which was called 2 times, avg 500ns/call: # 2 times (1µs+0s) by SQL::Translator::Schema::Table::BEGIN@44 at line 65 of SQL/Translator/Schema/Field.pm, avg 500ns/call
sub DBI::SQL_DECIMAL; # xsub
# spent 400ns within DBI::SQL_DOUBLE which was called: # once (400ns+0s) by SQL::Translator::Schema::Table::BEGIN@44 at line 65 of SQL/Translator/Schema/Field.pm
sub DBI::SQL_DOUBLE; # xsub
# spent 21.9ms within DBI::SQL_INTEGER which was called 8998 times, avg 2µs/call: # 8989 times (21.9ms+0s) by DBIx::Class::Storage::DBI::SQLite::_dbi_attrs_for_bind at line 114 of DBIx/Class/Storage/DBI/SQLite.pm, avg 2µs/call # 7 times (16µs+0s) by DBIx::Class::Storage::DBI::SQLite::bind_attribute_by_data_type at line 95 of DBIx/Class/Storage/DBI/SQLite.pm, avg 2µs/call # 2 times (4µs+0s) by SQL::Translator::Schema::Table::BEGIN@44 at line 65 of SQL/Translator/Schema/Field.pm, avg 2µs/call
sub DBI::SQL_INTEGER; # xsub
# spent 600ns within DBI::SQL_LONGVARCHAR which was called: # once (600ns+0s) by SQL::Translator::Schema::Table::BEGIN@44 at line 65 of SQL/Translator/Schema/Field.pm
sub DBI::SQL_LONGVARCHAR; # xsub
# spent 600ns within DBI::SQL_NUMERIC which was called: # once (600ns+0s) by SQL::Translator::Schema::Table::BEGIN@44 at line 65 of SQL/Translator/Schema/Field.pm
sub DBI::SQL_NUMERIC; # xsub
# spent 500ns within DBI::SQL_SMALLINT which was called: # once (500ns+0s) by SQL::Translator::Schema::Table::BEGIN@44 at line 65 of SQL/Translator/Schema/Field.pm
sub DBI::SQL_SMALLINT; # xsub
# spent 500ns within DBI::SQL_TIME which was called: # once (500ns+0s) by SQL::Translator::Schema::Table::BEGIN@44 at line 65 of SQL/Translator/Schema/Field.pm
sub DBI::SQL_TIME; # xsub
# spent 400ns within DBI::SQL_TIMESTAMP which was called: # once (400ns+0s) by SQL::Translator::Schema::Table::BEGIN@44 at line 65 of SQL/Translator/Schema/Field.pm
sub DBI::SQL_TIMESTAMP; # xsub
# spent 14µs within DBI::SQL_UNKNOWN_TYPE which was called 8 times, avg 2µs/call: # 8 times (14µs+0s) by SQL::Translator::Schema::Field::data_type at line 167 of SQL/Translator/Schema/Field.pm, avg 2µs/call
sub DBI::SQL_UNKNOWN_TYPE; # xsub
# spent 600ns within DBI::SQL_VARBINARY which was called: # once (600ns+0s) by SQL::Translator::Schema::Table::BEGIN@44 at line 65 of SQL/Translator/Schema/Field.pm
sub DBI::SQL_VARBINARY; # xsub
# spent 500ns within DBI::SQL_VARCHAR which was called: # once (500ns+0s) by SQL::Translator::Schema::Table::BEGIN@44 at line 65 of SQL/Translator/Schema/Field.pm
sub DBI::SQL_VARCHAR; # xsub
# spent 23.7ms within DBI::_concat_hash_sorted which was called 8019 times, avg 3µs/call: # 8019 times (23.7ms+0s) by DBD::_::db::prepare_cached at line 1694, avg 3µs/call
sub DBI::_concat_hash_sorted; # xsub
# spent 383µs within DBI::_install_method which was called 104 times, avg 4µs/call: # 89 times (292µs+0s) by DBIx::Class::Storage::DBI::__ANON__[/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/DBIx/Class/Storage/DBI.pm:1300] at line 499, avg 3µs/call # 15 times (91µs+0s) by DBD::_::common::install_method at line 1388, avg 6µs/call
sub DBI::_install_method; # xsub
# spent 7.34ms within DBI::_new_handle which was called 152 times, avg 48µs/call: # 145 times (7.12ms+0s) by DBI::_new_sth at line 1280, avg 49µs/call # 6 times (181µs+0s) by DBI::_new_dbh at line 1270, avg 30µs/call # once (39µs+0s) by DBI::_new_drh at line 1240
sub DBI::_new_handle; # xsub
# spent 290µs within DBI::bootstrap which was called: # once (290µs+0s) by DynaLoader::bootstrap at line 223 of DynaLoader.pm
sub DBI::bootstrap; # xsub