← Index
Performance Profile   « block view • line view • sub view »
For opac/opac-main.pl
  Run on Thu Jul 17 22:22:09 2008
Reported on Thu Jul 17 22:22:19 2008

File/usr/lib/perl5/DBI.pm
Statements Executed2748
Total Time0.0126789999999996 seconds

Subroutines — ordered by inclusive time then name
CallsInclusive
Time		Subroutine
4550.01554DBI::_new_sth
10.00007DBD::_::st::fetchall_arrayref
10.00004DBI::disconnect_all
00DBD::Switch::dr::CLONE
00DBD::Switch::dr::FETCH
00DBD::Switch::dr::STORE
00DBD::Switch::dr::driver
00DBD::_::common::BEGIN
00DBD::_::common::CLEAR
00DBD::_::common::EXISTS
00DBD::_::common::FETCH_many
00DBD::_::common::FIRSTKEY
00DBD::_::common::NEXTKEY
00DBD::_::common::_not_impl
00DBD::_::common::install_method
00DBD::_::common::parse_trace_flag
00DBD::_::common::parse_trace_flags
00DBD::_::common::private_attribute_info
00DBD::_::db::BEGIN
00DBD::_::db::_do_selectrow
00DBD::_::db::begin_work
00DBD::_::db::clone
00DBD::_::db::data_sources
00DBD::_::db::do
00DBD::_::db::ping
00DBD::_::db::prepare_cached
00DBD::_::db::primary_key
00DBD::_::db::quote
00DBD::_::db::quote_identifier
00DBD::_::db::rows
00DBD::_::db::selectall_arrayref
00DBD::_::db::selectall_hashref
00DBD::_::db::selectcol_arrayref
00DBD::_::db::selectrow_array
00DBD::_::db::selectrow_arrayref
00DBD::_::db::selectrow_hashref
00DBD::_::db::tables
00DBD::_::db::type_info
00DBD::_::dr::BEGIN
00DBD::_::dr::connect
00DBD::_::dr::connect_cached
00DBD::_::dr::default_user
00DBD::_::st::BEGIN
00DBD::_::st::__ANON__[:1884]
00DBD::_::st::__ANON__[:1918]
00DBD::_::st::bind_columns
00DBD::_::st::bind_param
00DBD::_::st::bind_param_array
00DBD::_::st::bind_param_inout_array
00DBD::_::st::blob_copy_to_file
00DBD::_::st::execute_array
00DBD::_::st::execute_for_fetch
00DBD::_::st::fetchall_hashref
00DBD::_::st::more_results
00DBI::BEGIN
00DBI::CLONE
00DBI::DBI_tie::STORE
00DBI::DBI_tie::TIEHASH
00DBI::END
00DBI::__ANON__[:1090]
00DBI::__ANON__[:1124]
00DBI::__ANON__[:1125]
00DBI::__ANON__[:705]
00DBI::__ANON__[:999]
00DBI::_dbtype_names
00DBI::_load_class
00DBI::_new_dbh
00DBI::_new_drh
00DBI::_rebless
00DBI::_rebless_dbtype_subclass
00DBI::_set_isa
00DBI::available_drivers
00DBI::connect
00DBI::connect_cached
00DBI::connect_test_perf
00DBI::data_diff
00DBI::data_sources
00DBI::data_string_desc
00DBI::data_string_diff
00DBI::disconnect
00DBI::dump_dbd_registry
00DBI::dump_results
00DBI::err
00DBI::errstr
00DBI::init_rootclass
00DBI::install_driver
00DBI::installed_drivers
00DBI::installed_methods
00DBI::installed_versions
00DBI::neat_list
00DBI::parse_dsn
00DBI::setup_driver
00DBI::var::STORE
00DBI::var::TIESCALAR

LineStmts.Exclusive
Time		Avg.Code
1# $Id: DBI.pm 10087 2007-10-16 12:42:37Z timbo $
2# vim: ts=8:sw=4
3#
4# Copyright (c) 1994-2007 Tim Bunce Ireland
5#
6# See COPYRIGHT section in pod text below for usage and distribution rights.
7#
8
9require 5.006_00;
10
11BEGIN {
12$DBI::VERSION = "1.601"; # ==> ALSO update the version in the pod text below!
13}
14
15=head1 NAME
16
17DBI - Database independent interface for Perl
18
19=head1 SYNOPSIS
20
21 use DBI;
22
23 @driver_names = DBI->available_drivers;
24 %drivers = DBI->installed_drivers;
25 @data_sources = DBI->data_sources($driver_name, \%attr);
26
27 $dbh = DBI->connect($data_source, $username, $auth, \%attr);
28
29 $rv = $dbh->do($statement);
30 $rv = $dbh->do($statement, \%attr);
31 $rv = $dbh->do($statement, \%attr, @bind_values);
32
33 $ary_ref = $dbh->selectall_arrayref($statement);
34 $hash_ref = $dbh->selectall_hashref($statement, $key_field);
35
36 $ary_ref = $dbh->selectcol_arrayref($statement);
37 $ary_ref = $dbh->selectcol_arrayref($statement, \%attr);
38
39 @row_ary = $dbh->selectrow_array($statement);
40 $ary_ref = $dbh->selectrow_arrayref($statement);
41 $hash_ref = $dbh->selectrow_hashref($statement);
42
43 $sth = $dbh->prepare($statement);
44 $sth = $dbh->prepare_cached($statement);
45
46 $rc = $sth->bind_param($p_num, $bind_value);
47 $rc = $sth->bind_param($p_num, $bind_value, $bind_type);
48 $rc = $sth->bind_param($p_num, $bind_value, \%attr);
49
50 $rv = $sth->execute;
51 $rv = $sth->execute(@bind_values);
52 $rv = $sth->execute_array(\%attr, ...);
53
54 $rc = $sth->bind_col($col_num, \$col_variable);
55 $rc = $sth->bind_columns(@list_of_refs_to_vars_to_bind);
56
57 @row_ary = $sth->fetchrow_array;
58 $ary_ref = $sth->fetchrow_arrayref;
59 $hash_ref = $sth->fetchrow_hashref;
60
61 $ary_ref = $sth->fetchall_arrayref;
62 $ary_ref = $sth->fetchall_arrayref( $slice, $max_rows );
63
64 $hash_ref = $sth->fetchall_hashref( $key_field );
65
66 $rv = $sth->rows;
67
68 $rc = $dbh->begin_work;
69 $rc = $dbh->commit;
70 $rc = $dbh->rollback;
71
72 $quoted_string = $dbh->quote($string);
73
74 $rc = $h->err;
75 $str = $h->errstr;
76 $rv = $h->state;
77
78 $rc = $dbh->disconnect;
79
80I<The synopsis above only lists the major methods and parameters.>
81
82
83=head2 GETTING HELP
84
85If you have questions about DBI, or DBD driver modules, you can get
86help from the I<dbi-users@perl.org> mailing list. You don't have to subscribe
87to the list in order to post, though I'd recommend it. You can get help on
88subscribing and using the list by emailing I<dbi-users-help@perl.org>.
89
90I don't recommend the DBI cpanform (at http://www.cpanforum.com/dist/DBI)
91because relatively few people read it compared with dbi-users@perl.org.
92
93To help you make the best use of the dbi-users mailing list,
94and any other lists or forums you may use, I I<strongly>
95recommend that you read "How To Ask Questions The Smart Way"
96by Eric Raymond: L<http://www.catb.org/~esr/faqs/smart-questions.html>.
97
98If you think you've found a bug then please also read
99"How to Report Bugs Effectively" by Simon Tatham:
100L<http://www.chiark.greenend.org.uk/~sgtatham/bugs.html>.
101
102The DBI home page at L<http://dbi.perl.org/> is always worth a visit
103and includes an FAQ and links to other resources.
104
105Before asking any questions, reread this document, consult the
106archives and read the DBI FAQ. The archives are listed
107at the end of this document and on the DBI home page.
108An FAQ is installed as a L<DBI::FAQ> module so
109you can read it by executing C<perldoc DBI::FAQ>.
110However the DBI::FAQ module is currently (2004) outdated relative
111to the online FAQ on the DBI home page.
112
113This document often uses terms like I<references>, I<objects>,
114I<methods>. If you're not familar with those terms then it would
115be a good idea to read at least the following perl manuals first:
116L<perlreftut>, L<perldsc>, L<perllol>, and L<perlboot>.
117
118Please note that Tim Bunce does not maintain the mailing lists or the
119web page (generous volunteers do that). So please don't send mail
120directly to him; he just doesn't have the time to answer questions
121personally. The I<dbi-users> mailing list has lots of experienced
122people who should be able to help you if you need it. If you do email
123Tim he's very likely to just forward it to the mailing list.
124
125=head2 NOTES
126
127This is the DBI specification that corresponds to the DBI version 1.601
128($Revision: 10087 $).
129
130The DBI is evolving at a steady pace, so it's good to check that
131you have the latest copy.
132
133The significant user-visible changes in each release are documented
134in the L<DBI::Changes> module so you can read them by executing
135C<perldoc DBI::Changes>.
136
137Some DBI changes require changes in the drivers, but the drivers
138can take some time to catch up. Newer versions of the DBI have
139added features that may not yet be supported by the drivers you
140use. Talk to the authors of your drivers if you need a new feature
141that's not yet supported.
142
143Features added after DBI 1.21 (February 2002) are marked in the
144text with the version number of the DBI release they first appeared in.
145
146Extensions to the DBI API often use the C<DBIx::*> namespace.
147See L</Naming Conventions and Name Space>. DBI extension modules
148can be found at L<http://search.cpan.org/search?mode=module&query=DBIx>.
149And all modules related to the DBI can be found at
150L<http://search.cpan.org/search?query=DBI&mode=all>.
151
152=cut
153
154# The POD text continues at the end of the file.
155
156
157package DBI;
158
159use Carp();
160use DynaLoader ();
161use Exporter ();
162
163BEGIN {
164@ISA = qw(Exporter DynaLoader);
165
166# Make some utility functions available if asked for
167@EXPORT = (); # we export nothing by default
168@EXPORT_OK = qw(%DBI %DBI_methods hash); # also populated by export_ok_tags:
169%EXPORT_TAGS = (
170 sql_types => [ qw(
171 SQL_GUID
172 SQL_WLONGVARCHAR
173 SQL_WVARCHAR
174 SQL_WCHAR
175 SQL_BIGINT
176 SQL_BIT
177 SQL_TINYINT
178 SQL_LONGVARBINARY
179 SQL_VARBINARY
180 SQL_BINARY
181 SQL_LONGVARCHAR
182 SQL_UNKNOWN_TYPE
183 SQL_ALL_TYPES
184 SQL_CHAR
185 SQL_NUMERIC
186 SQL_DECIMAL
187 SQL_INTEGER
188 SQL_SMALLINT
189 SQL_FLOAT
190 SQL_REAL
191 SQL_DOUBLE
192 SQL_DATETIME
193 SQL_DATE
194 SQL_INTERVAL
195 SQL_TIME
196 SQL_TIMESTAMP
197 SQL_VARCHAR
198 SQL_BOOLEAN
199 SQL_UDT
200 SQL_UDT_LOCATOR
201 SQL_ROW
202 SQL_REF
203 SQL_BLOB
204 SQL_BLOB_LOCATOR
205 SQL_CLOB
206 SQL_CLOB_LOCATOR
207 SQL_ARRAY
208 SQL_ARRAY_LOCATOR
209 SQL_MULTISET
210 SQL_MULTISET_LOCATOR
211 SQL_TYPE_DATE
212 SQL_TYPE_TIME
213 SQL_TYPE_TIMESTAMP
214 SQL_TYPE_TIME_WITH_TIMEZONE
215 SQL_TYPE_TIMESTAMP_WITH_TIMEZONE
216 SQL_INTERVAL_YEAR
217 SQL_INTERVAL_MONTH
218 SQL_INTERVAL_DAY
219 SQL_INTERVAL_HOUR
220 SQL_INTERVAL_MINUTE
221 SQL_INTERVAL_SECOND
222 SQL_INTERVAL_YEAR_TO_MONTH
223 SQL_INTERVAL_DAY_TO_HOUR
224 SQL_INTERVAL_DAY_TO_MINUTE
225 SQL_INTERVAL_DAY_TO_SECOND
226 SQL_INTERVAL_HOUR_TO_MINUTE
227 SQL_INTERVAL_HOUR_TO_SECOND
228 SQL_INTERVAL_MINUTE_TO_SECOND
229 ) ],
230 sql_cursor_types => [ qw(
231 SQL_CURSOR_FORWARD_ONLY
232 SQL_CURSOR_KEYSET_DRIVEN
233 SQL_CURSOR_DYNAMIC
234 SQL_CURSOR_STATIC
235 SQL_CURSOR_TYPE_DEFAULT
236 ) ], # for ODBC cursor types
237 utils => [ qw(
238 neat neat_list $neat_maxlen dump_results looks_like_number
239 data_string_diff data_string_desc data_diff
240 ) ],
241 profile => [ qw(
242 dbi_profile dbi_profile_merge dbi_profile_merge_nodes dbi_time
243 ) ], # notionally "in" DBI::Profile and normally imported from there
244);
245
246$DBI::dbi_debug = 0;
247$DBI::neat_maxlen = 400;
248$DBI::stderr = 2_000_000_000; # a very round number below 2**31
249
250# If you get an error here like "Can't find loadable object ..."
251# then you haven't installed the DBI correctly. Read the README
252# then install it again.
253if ( $ENV{DBI_PUREPERL} ) {
254 eval { bootstrap DBI } if $ENV{DBI_PUREPERL} == 1;
255 require DBI::PurePerl if $@ or $ENV{DBI_PUREPERL} >= 2;
256 $DBI::PurePerl ||= 0; # just to silence "only used once" warnings
257}
258else {
259 bootstrap DBI;
260}
261
262$EXPORT_TAGS{preparse_flags} = [ grep { /^DBIpp_\w\w_/ } keys %{__PACKAGE__."::"} ];
263
264Exporter::export_ok_tags(keys %EXPORT_TAGS);
265
266}
267
268# Alias some handle methods to also be DBI class methods
269for (qw(trace_msg set_err parse_trace_flag parse_trace_flags)) {
270 no strict;
271 *$_ = \&{"DBD::_::common::$_"};
272}
273
274use strict;
275
276DBI->trace(split /=/, $ENV{DBI_TRACE}, 2) if $ENV{DBI_TRACE};
277
278$DBI::connect_via ||= "connect";
279
280# check if user wants a persistent database connection ( Apache + mod_perl )
281if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
282 $DBI::connect_via = "Apache::DBI::connect";
283 DBI->trace_msg("DBI connect via $DBI::connect_via in $INC{'Apache/DBI.pm'}\n");
284}
285
286# check for weaken support, used by ChildHandles
287my $HAS_WEAKEN = eval {
288 require Scalar::Util;
289 # this will croak() if this Scalar::Util doesn't have a working weaken().
290 Scalar::Util::weaken( \my $test ); # same test as in t/72childhandles.t
291 1;
292};
293
294%DBI::installed_drh = (); # maps driver names to installed driver handles
295sub installed_drivers { %DBI::installed_drh }
296%DBI::installed_methods = (); # XXX undocumented, may change
297sub installed_methods { %DBI::installed_methods }
298
299# Setup special DBI dynamic variables. See DBI::var::FETCH for details.
300# These are dynamically associated with the last handle used.
301tie $DBI::err, 'DBI::var', '*err'; # special case: referenced via IHA list
302tie $DBI::state, 'DBI::var', '"state'; # special case: referenced via IHA list
303tie $DBI::lasth, 'DBI::var', '!lasth'; # special case: return boolean
304tie $DBI::errstr, 'DBI::var', '&errstr'; # call &errstr in last used pkg
305tie $DBI::rows, 'DBI::var', '&rows'; # call &rows in last used pkg
306sub DBI::var::TIESCALAR{ my $var = $_[1]; bless \$var, 'DBI::var'; }
307sub DBI::var::STORE { Carp::croak("Can't modify \$DBI::${$_[0]} special variable") }
308
309{ # used to catch DBI->{Attrib} mistake
310 sub DBI::DBI_tie::TIEHASH { bless {} }
311 sub DBI::DBI_tie::STORE { Carp::carp("DBI->{$_[1]} is invalid syntax (you probably want \$h->{$_[1]})");}
312 *DBI::DBI_tie::FETCH = \&DBI::DBI_tie::STORE;
313}
314tie %DBI::DBI => 'DBI::DBI_tie';
315
316# --- Driver Specific Prefix Registry ---
317
318my $dbd_prefix_registry = {
319 ad_ => { class => 'DBD::AnyData', },
320 ado_ => { class => 'DBD::ADO', },
321 amzn_ => { class => 'DBD::Amazon', },
322 best_ => { class => 'DBD::BestWins', },
323 csv_ => { class => 'DBD::CSV', },
324 db2_ => { class => 'DBD::DB2', },
325 dbi_ => { class => 'DBI', },
326 dbm_ => { class => 'DBD::DBM', },
327 df_ => { class => 'DBD::DF', },
328 f_ => { class => 'DBD::File', },
329 file_ => { class => 'DBD::TextFile', },
330 go_ => { class => 'DBD::Gofer', },
331 ib_ => { class => 'DBD::InterBase', },
332 ing_ => { class => 'DBD::Ingres', },
333 ix_ => { class => 'DBD::Informix', },
334 jdbc_ => { class => 'DBD::JDBC', },
335 monetdb_ => { class => 'DBD::monetdb', },
336 msql_ => { class => 'DBD::mSQL', },
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 plb_ => { class => 'DBD::Plibdata', },
344 proxy_ => { class => 'DBD::Proxy', },
345 rdb_ => { class => 'DBD::RDB', },
346 sapdb_ => { class => 'DBD::SAP_DB', },
347 solid_ => { class => 'DBD::Solid', },
348 sponge_ => { class => 'DBD::Sponge', },
349 sql_ => { class => 'SQL::Statement', },
350 syb_ => { class => 'DBD::Sybase', },
351 tdat_ => { class => 'DBD::Teradata', },
352 tmpl_ => { class => 'DBD::Template', },
353 tmplss_ => { class => 'DBD::TemplateSS', },
354 tuber_ => { class => 'DBD::Tuber', },
355 uni_ => { class => 'DBD::Unify', },
356 vt_ => { class => 'DBD::Vt', },
357 wmi_ => { class => 'DBD::WMI', },
358 x_ => { }, # for private use
359 xbase_ => { class => 'DBD::XBase', },
360 xl_ => { class => 'DBD::Excel', },
361 yaswi_ => { class => 'DBD::Yaswi', },
362};
363
364sub dump_dbd_registry {
365 require Data::Dumper;
366 local $Data::Dumper::Sortkeys=1;
367 local $Data::Dumper::Indent=1;
368 print Data::Dumper->Dump([$dbd_prefix_registry], [qw($dbd_prefix_registry)]);
369}
370
371# --- Dynamically create the DBI Standard Interface
372
373my $keeperr = { O=>0x0004 };
374
375%DBI::DBI_methods = ( # Define the DBI interface methods per class:
376
377 common => { # Interface methods common to all DBI handle classes
378 'DESTROY' => { O=>0x004|0x10000 },
379 'CLEAR' => $keeperr,
380 'EXISTS' => $keeperr,
381 'FETCH' => { O=>0x0404 },
382 'FETCH_many' => { O=>0x0404 },
383 'FIRSTKEY' => $keeperr,
384 'NEXTKEY' => $keeperr,
385 'STORE' => { O=>0x0418 | 0x4 },
386 _not_impl => undef,
387 can => { O=>0x0100 }, # special case, see dispatch
388 debug => { U =>[1,2,'[$debug_level]'], O=>0x0004 }, # old name for trace
389 dump_handle => { U =>[1,3,'[$message [, $level]]'], O=>0x0004 },
390 err => $keeperr,
391 errstr => $keeperr,
392 state => $keeperr,
393 func => { O=>0x0006 },
394 parse_trace_flag => { U =>[2,2,'$name'], O=>0x0404, T=>8 },
395 parse_trace_flags => { U =>[2,2,'$flags'], O=>0x0404, T=>8 },
396 private_data => { U =>[1,1], O=>0x0004 },
397 set_err => { U =>[3,6,'$err, $errmsg [, $state, $method, $rv]'], O=>0x0010 },
398 trace => { U =>[1,3,'[$trace_level, [$filename]]'], O=>0x0004 },
399 trace_msg => { U =>[2,3,'$message_text [, $min_level ]' ], O=>0x0004, T=>8 },
400 swap_inner_handle => { U =>[2,3,'$h [, $allow_reparent ]'] },
401 private_attribute_info => { },
402 },
403 dr => { # Database Driver Interface
404 'connect' => { U =>[1,5,'[$db [,$user [,$passwd [,\%attr]]]]'], H=>3, O=>0x8000 },
405 'connect_cached'=>{U=>[1,5,'[$db [,$user [,$passwd [,\%attr]]]]'], H=>3, O=>0x8000 },
406 'disconnect_all'=>{ U =>[1,1], O=>0x0800 },
407 data_sources => { U =>[1,2,'[\%attr]' ], O=>0x0800 },
408 default_user => { U =>[3,4,'$user, $pass [, \%attr]' ] },
409 },
410 db => { # Database Session Class Interface
411 data_sources => { U =>[1,2,'[\%attr]' ], O=>0x0200 },
412 take_imp_data => { U =>[1,1], O=>0x10000 },
413 clone => { U =>[1,2,'[\%attr]'] },
414 connected => { U =>[1,0], O => 0x0004 },
415 begin_work => { U =>[1,2,'[ \%attr ]'], O=>0x0400 },
416 commit => { U =>[1,1], O=>0x0480|0x0800 },
417 rollback => { U =>[1,1], O=>0x0480|0x0800 },
418 'do' => { U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x3200 },
419 last_insert_id => { U =>[5,6,'$catalog, $schema, $table_name, $field_name [, \%attr ]'], O=>0x2800 },
420 preparse => { }, # XXX
421 prepare => { U =>[2,3,'$statement [, \%attr]'], O=>0xA200 },
422 prepare_cached => { U =>[2,4,'$statement [, \%attr [, $if_active ] ]'], O=>0xA200 },
423 selectrow_array => { U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
424 selectrow_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
425 selectrow_hashref=>{ U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
426 selectall_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
427 selectall_hashref=>{ U =>[3,0,'$statement, $keyfield [, \%attr [, @bind_params ] ]'], O=>0x2000 },
428 selectcol_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
429 ping => { U =>[1,1], O=>0x0404 },
430 disconnect => { U =>[1,1], O=>0x0400|0x0800|0x10000 },
431 quote => { U =>[2,3, '$string [, $data_type ]' ], O=>0x0430 },
432 quote_identifier=> { U =>[2,6, '$name [, ...] [, \%attr ]' ], O=>0x0430 },
433 rows => $keeperr,
434
435 tables => { U =>[1,6,'$catalog, $schema, $table, $type [, \%attr ]' ], O=>0x2200 },
436 table_info => { U =>[1,6,'$catalog, $schema, $table, $type [, \%attr ]' ], O=>0x2200|0x8800 },
437 column_info => { U =>[5,6,'$catalog, $schema, $table, $column [, \%attr ]'],O=>0x2200|0x8800 },
438 primary_key_info=> { U =>[4,5,'$catalog, $schema, $table [, \%attr ]' ], O=>0x2200|0x8800 },
439 primary_key => { U =>[4,5,'$catalog, $schema, $table [, \%attr ]' ], O=>0x2200 },
440 foreign_key_info=> { U =>[7,8,'$pk_catalog, $pk_schema, $pk_table, $fk_catalog, $fk_schema, $fk_table [, \%attr ]' ], O=>0x2200|0x8800 },
441 statistics_info => { U =>[6,7,'$catalog, $schema, $table, $unique_only, $quick, [, \%attr ]' ], O=>0x2200|0x8800 },
442 type_info_all => { U =>[1,1], O=>0x2200|0x0800 },
443 type_info => { U =>[1,2,'$data_type'], O=>0x2200 },
444 get_info => { U =>[2,2,'$info_type'], O=>0x2200|0x0800 },
445 },
446 st => { # Statement Class Interface
447 bind_col => { U =>[3,4,'$column, \\$var [, \%attr]'] },
448 bind_columns => { U =>[2,0,'\\$var1 [, \\$var2, ...]'] },
449 bind_param => { U =>[3,4,'$parameter, $var [, \%attr]'] },
450 bind_param_inout=> { U =>[4,5,'$parameter, \\$var, $maxlen, [, \%attr]'] },
451 execute => { U =>[1,0,'[@args]'], O=>0x1040 },
452
453 bind_param_array => { U =>[3,4,'$parameter, $var [, \%attr]'] },
454 bind_param_inout_array => { U =>[4,5,'$parameter, \\@var, $maxlen, [, \%attr]'] },
455 execute_array => { U =>[2,0,'\\%attribs [, @args]'], O=>0x1040|0x4000 },
456 execute_for_fetch => { U =>[2,3,'$fetch_sub [, $tuple_status]'], O=>0x1040|0x4000 },
457
458 fetch => undef, # alias for fetchrow_arrayref
459 fetchrow_arrayref => undef,
460 fetchrow_hashref => undef,
461 fetchrow_array => undef,
462 fetchrow => undef, # old alias for fetchrow_array
463
464 fetchall_arrayref => { U =>[1,3, '[ $slice [, $max_rows]]'] },
465 fetchall_hashref => { U =>[2,2,'$key_field'] },
466
467 blob_read => { U =>[4,5,'$field, $offset, $len [, \\$buf [, $bufoffset]]'] },
468 blob_copy_to_file => { U =>[3,3,'$field, $filename_or_handleref'] },
469 dump_results => { U =>[1,5,'$maxfieldlen, $linesep, $fieldsep, $filehandle'] },
470 more_results => { U =>[1,1] },
471 finish => { U =>[1,1] },
472 cancel => { U =>[1,1], O=>0x0800 },
473 rows => $keeperr,
474
475 _get_fbav => undef,
476 _set_fbav => { T=>6 },
477 },
478);
479
480while ( my ($class, $meths) = each %DBI::DBI_methods ) {
481 my $ima_trace = 0+($ENV{DBI_IMA_TRACE}||0);
482 while ( my ($method, $info) = each %$meths ) {
483 my $fullmeth = "DBI::${class}::$method";
484 if ($DBI::dbi_debug >= 15) { # quick hack to list DBI methods
485 # and optionally filter by IMA flags
486 my $O = $info->{O}||0;
487 printf "0x%04x %-20s\n", $O, $fullmeth
488 unless $ima_trace && !($O & $ima_trace);
489 }
490 DBI->_install_method($fullmeth, 'DBI.pm', $info);
491 }
492}
493
494{
495 package DBI::common;
496 @DBI::dr::ISA = ('DBI::common');
497 @DBI::db::ISA = ('DBI::common');
498 @DBI::st::ISA = ('DBI::common');
499}
500
501# End of init code
502
503
504END {
50550.000048e-06 return unless defined &DBI::trace_msg; # return unless bootstrap'd ok
506 local ($!,$?);
507 DBI->trace_msg(sprintf(" -- DBI::END (\$\@: %s, \$!: %s)\n", $@||'', $!||''), 2);
# spent 0.00001s making 1 calls to DBD::_::common::trace_msg
508 # Let drivers know why we are calling disconnect_all:
509 $DBI::PERL_ENDING = $DBI::PERL_ENDING = 1; # avoid typo warning
510 DBI->disconnect_all() if %DBI::installed_drh;
# spent 0.00004s making 1 calls to DBI::disconnect_all
511}
512
513
514sub CLONE {
515 my $olddbis = $DBI::_dbistate;
516 _clone_dbis() unless $DBI::PurePerl; # clone the DBIS structure
517 DBI->trace_msg(sprintf "CLONE DBI for new thread %s\n",
518 $DBI::PurePerl ? "" : sprintf("(dbis %x -> %x)",$olddbis, $DBI::_dbistate));
519 while ( my ($driver, $drh) = each %DBI::installed_drh) {
520 no strict 'refs';
521 next if defined &{"DBD::${driver}::CLONE"};
522 warn("$driver has no driver CLONE() function so is unsafe threaded\n");
523 }
524 %DBI::installed_drh = (); # clear loaded drivers so they have a chance to reinitialize
525}
526
527sub parse_dsn {
528 my ($class, $dsn) = @_;
529 $dsn =~ s/^(dbi):(\w*?)(?:\((.*?)\))?://i or return;
530 my ($scheme, $driver, $attr, $attr_hash) = (lc($1), $2, $3);
531 $driver ||= $ENV{DBI_DRIVER} || '';
532 $attr_hash = { split /\s*=>?\s*|\s*,\s*/, $attr, -1 } if $attr;
533 return ($scheme, $driver, $attr, $attr_hash, $dsn);
534}
535
536
537# --- The DBI->connect Front Door methods
538
539sub connect_cached {
540 # For library code using connect_cached() with mod_perl
541 # we redirect those calls to Apache::DBI::connect() as well
542 my ($class, $dsn, $user, $pass, $attr) = @_;
543 my $dbi_connect_method = ($DBI::connect_via eq "Apache::DBI::connect")
544 ? 'Apache::DBI::connect' : 'connect_cached';
545 $attr = {
546 $attr ? %$attr : (), # clone, don't modify callers data
547 dbi_connect_method => $dbi_connect_method,
548 };
549 return $class->connect($dsn, $user, $pass, $attr);
550}
551
552sub connect {
553 my $class = shift;
554 my ($dsn, $user, $pass, $attr, $old_driver) = my @orig_args = @_;
555 my $driver;
556
557 if ($attr and !ref($attr)) { # switch $old_driver<->$attr if called in old style
558 Carp::carp("DBI->connect using 'old-style' syntax is deprecated and will be an error in future versions");
559 ($old_driver, $attr) = ($attr, $old_driver);
560 }
561
562 my $connect_meth = $attr->{dbi_connect_method};
563 $connect_meth ||= $DBI::connect_via; # fallback to default
564
565 $dsn ||= $ENV{DBI_DSN} || $ENV{DBI_DBNAME} || '' unless $old_driver;
566
567 if ($DBI::dbi_debug) {
568 local $^W = 0;
569 pop @_ if $connect_meth ne 'connect';
570 my @args = @_; $args[2] = '****'; # hide password
571 DBI->trace_msg(" -> $class->$connect_meth(".join(", ",@args).")\n");
572 }
573 Carp::croak('Usage: $class->connect([$dsn [,$user [,$passwd [,\%attr]]]])')
574 if (ref $old_driver or ($attr and not ref $attr) or ref $pass);
575
576 # extract dbi:driver prefix from $dsn into $1
577 $dsn =~ s/^dbi:(\w*?)(?:\((.*?)\))?://i
578 or '' =~ /()/; # ensure $1 etc are empty if match fails
579 my $driver_attrib_spec = $2 || '';
580
581 # Set $driver. Old style driver, if specified, overrides new dsn style.
582 $driver = $old_driver || $1 || $ENV{DBI_DRIVER}
583 or Carp::croak("Can't connect to data source '$dsn' "
584 ."because I can't work out what driver to use "
585 ."(it doesn't seem to contain a 'dbi:driver:' prefix "
586 ."and the DBI_DRIVER env var is not set)");
587
588 my $proxy;
589 if ($ENV{DBI_AUTOPROXY} && $driver ne 'Proxy' && $driver ne 'Sponge' && $driver ne 'Switch') {
590 my $dbi_autoproxy = $ENV{DBI_AUTOPROXY};
591 $proxy = 'Proxy';
592 if ($dbi_autoproxy =~ s/^dbi:(\w*?)(?:\((.*?)\))?://i) {
593 $proxy = $1;
594 $driver_attrib_spec = join ",",
595 ($driver_attrib_spec) ? $driver_attrib_spec : (),
596 ($2 ) ? $2 : ();
597 }
598 $dsn = "$dbi_autoproxy;dsn=dbi:$driver:$dsn";
599 $driver = $proxy;
600 DBI->trace_msg(" DBI_AUTOPROXY: dbi:$driver($driver_attrib_spec):$dsn\n");
601 }
602 # avoid recursion if proxy calls DBI->connect itself
603 local $ENV{DBI_AUTOPROXY};
604
605 my %attributes; # take a copy we can delete from
606 if ($old_driver) {
607 %attributes = %$attr if $attr;
608 }
609 else { # new-style connect so new default semantics
610 %attributes = (
611 PrintError => 1,
612 AutoCommit => 1,
613 ref $attr ? %$attr : (),
614 # attributes in DSN take precedence over \%attr connect parameter
615 $driver_attrib_spec ? (split /\s*=>?\s*|\s*,\s*/, $driver_attrib_spec, -1) : (),
616 );
617 }
618 $attr = \%attributes; # now set $attr to refer to our local copy
619
620 my $drh = $DBI::installed_drh{$driver} || $class->install_driver($driver)
621 or die "panic: $class->install_driver($driver) failed";
622
623 # attributes in DSN take precedence over \%attr connect parameter
624 $user = $attr->{Username} if defined $attr->{Username};
625 $pass = $attr->{Password} if defined $attr->{Password};
626 delete $attr->{Password}; # always delete Password as closure stores it securely
627 if ( !(defined $user && defined $pass) ) {
628 ($user, $pass) = $drh->default_user($user, $pass, $attr);
629 }
630 $attr->{Username} = $user; # force the Username to be the actual one used
631
632 my $connect_closure = sub {
633 my ($old_dbh, $override_attr) = @_;
634
635 #use Data::Dumper;
636 #warn "connect_closure: ".Data::Dumper::Dumper([$attr,\%attributes, $override_attr]);
637
638 my $dbh;
639 unless ($dbh = $drh->$connect_meth($dsn, $user, $pass, $attr)) {
640 $user = '' if !defined $user;
641 $dsn = '' if !defined $dsn;
642 # $drh->errstr isn't safe here because $dbh->DESTROY may not have
643 # been called yet and so the dbh errstr would not have been copied
644 # up to the drh errstr. Certainly true for connect_cached!
645 my $errstr = $DBI::errstr;
646 # Getting '(no error string)' here is a symptom of a ref loop
647 $errstr = '(no error string)' if !defined $errstr;
648 my $msg = "$class connect('$dsn','$user',...) failed: $errstr";
649 DBI->trace_msg(" $msg\n");
650 # XXX HandleWarn
651 unless ($attr->{HandleError} && $attr->{HandleError}->($msg, $drh, $dbh)) {
652 Carp::croak($msg) if $attr->{RaiseError};
653 Carp::carp ($msg) if $attr->{PrintError};
654 }
655 $! = 0; # for the daft people who do DBI->connect(...) || die "$!";
656 return $dbh; # normally undef, but HandleError could change it
657 }
658
659 # merge any attribute overrides but don't change $attr itself (for closure)
660 my $apply = { ($override_attr) ? (%$attr, %$override_attr ) : %$attr };
661
662 # handle basic RootClass subclassing:
663 my $rebless_class = $apply->{RootClass} || ($class ne 'DBI' ? $class : '');
664 if ($rebless_class) {
665 no strict 'refs';
666 if ($apply->{RootClass}) { # explicit attribute (ie not static methd call class)
667 delete $apply->{RootClass};
668 DBI::_load_class($rebless_class, 0);
669 }
670 unless (@{"$rebless_class\::db::ISA"} && @{"$rebless_class\::st::ISA"}) {
671 Carp::carp("DBI subclasses '$rebless_class\::db' and ::st are not setup, RootClass ignored");
672 $rebless_class = undef;
673 $class = 'DBI';
674 }
675 else {
676 $dbh->{RootClass} = $rebless_class; # $dbh->STORE called via plain DBI::db
677 DBI::_set_isa([$rebless_class], 'DBI'); # sets up both '::db' and '::st'
678 DBI::_rebless($dbh, $rebless_class); # appends '::db'
679 }
680 }
681
682 if (%$apply) {
683
684 if ($apply->{DbTypeSubclass}) {
685 my $DbTypeSubclass = delete $apply->{DbTypeSubclass};
686 DBI::_rebless_dbtype_subclass($dbh, $rebless_class||$class, $DbTypeSubclass);
687 }
688 my $a;
689 foreach $a (qw(Profile RaiseError PrintError AutoCommit)) { # do these first
690 next unless exists $apply->{$a};
691 $dbh->{$a} = delete $apply->{$a};
692 }
693 while ( my ($a, $v) = each %$apply) {
694 eval { $dbh->{$a} = $v } or $@ && warn $@;
695 }
696 }
697
698 # confirm to driver (ie if subclassed) that we've connected sucessfully
699 # and finished the attribute setup. pass in the original arguments
700 $dbh->connected(@orig_args); #if ref $dbh ne 'DBI::db' or $proxy;
701
702 DBI->trace_msg(" <- connect= $dbh\n") if $DBI::dbi_debug;
703
704 return $dbh;
705 };
706
707 my $dbh = &$connect_closure(undef, undef);
708
709 $dbh->{dbi_connect_closure} = $connect_closure if $dbh;
710
711 return $dbh;
712}
713
714
715
# spent 0.00004s within DBI::disconnect_all which was called: # 1 times (0.00004s) by DBI::END at line 510 of /usr/lib/perl5/DBI.pm
sub disconnect_all {
71626e-063e-06 keys %DBI::installed_drh; # reset iterator
717 while ( my ($name, $drh) = each %DBI::installed_drh ) {
71810.000030.00003 $drh->disconnect_all() if ref $drh;
# spent 0.00002s making 1 calls to DBI::dr::disconnect_all
719 }
720}
721
722
723sub disconnect { # a regular beginners bug
724 Carp::croak("DBI->disconnect is not a DBI method (read the DBI manual)");
725}
726
727
728sub install_driver { # croaks on failure
729 my $class = shift;
730 my($driver, $attr) = @_;
731 my $drh;
732
733 $driver ||= $ENV{DBI_DRIVER} || '';
734
735 # allow driver to be specified as a 'dbi:driver:' string
736 $driver = $1 if $driver =~ s/^DBI:(.*?)://i;
737
738 Carp::croak("usage: $class->install_driver(\$driver [, \%attr])")
739 unless ($driver and @_<=3);
740
741 # already installed
742 return $drh if $drh = $DBI::installed_drh{$driver};
743
744 $class->trace_msg(" -> $class->install_driver($driver"
745 .") for $^O perl=$] pid=$$ ruid=$< euid=$>\n")
746 if $DBI::dbi_debug;
747
748 # --- load the code
749 my $driver_class = "DBD::$driver";
750 eval qq{package # hide from PAUSE
751 DBI::_firesafe; # just in case
752 require $driver_class; # load the driver
753 };
754 if ($@) {
755 my $err = $@;
756 my $advice = "";
757 if ($err =~ /Can't find loadable object/) {
758 $advice = "Perhaps DBD::$driver was statically linked into a new perl binary."
759 ."\nIn which case you need to use that new perl binary."
760 ."\nOr perhaps only the .pm file was installed but not the shared object file."
761 }
762 elsif ($err =~ /Can't locate.*?DBD\/$driver\.pm in \@INC/) {
763 my @drv = $class->available_drivers(1);
764 $advice = "Perhaps the DBD::$driver perl module hasn't been fully installed,\n"
765 ."or perhaps the capitalisation of '$driver' isn't right.\n"
766 ."Available drivers: ".join(", ", @drv).".";
767 }
768 elsif ($err =~ /Can't load .*? for module DBD::/) {
769 $advice = "Perhaps a required shared library or dll isn't installed where expected";
770 }
771 elsif ($err =~ /Can't locate .*? in \@INC/) {
772 $advice = "Perhaps a module that DBD::$driver requires hasn't been fully installed";
773 }
774