← Index
NYTProf Performance Profile   « line view »
For svc/members/upsert
  Run on Tue Jan 13 11:50:22 2015
Reported on Tue Jan 13 12:09:46 2015

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