← Index
NYTProf Performance Profile   « block view • line view • sub view »
For /usr/share/koha/opac/cgi-bin/opac/opac-search.pl
  Run on Tue Oct 15 17:10:45 2013
Reported on Tue Oct 15 17:11:22 2013

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