Profile of DBI.pm

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

Filename | /2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/x86_64-linux/DBI.pm
Statements | Executed 67843 statements in 305ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
8019 | 1 | 1 | 185ms | 280ms | DBD::_::db::::prepare_cached DBD::_::db::prepare_cached
8019 | 1 | 1 | 23.7ms | 23.7ms | DBI::::_concat_hash_sorted DBI::_concat_hash_sorted (xsub)
8998 | 3 | 2 | 21.9ms | 21.9ms | DBI::::SQL_INTEGER DBI::SQL_INTEGER (xsub)
152 | 3 | 1 | 7.34ms | 7.34ms | DBI::::_new_handle DBI::_new_handle (xsub)
294 | 1 | 1 | 4.89ms | 9.39ms | DBD::_::db::::begin_work DBD::_::db::begin_work
145 | 1 | 1 | 3.66ms | 10.8ms | DBI::::_new_sth DBI::_new_sth
1 | 1 | 1 | 2.46ms | 3.91ms | DBI::::install_driver DBI::install_driver
6 | 1 | 1 | 486µs | 2.79ms | DBI::::__ANON__[:725] DBI::__ANON__[:725]
6 | 1 | 1 | 399µs | 7.17ms | DBI::::connect DBI::connect
104 | 2 | 1 | 383µs | 383µs | DBI::::_install_method DBI::_install_method (xsub)
1 | 1 | 1 | 290µs | 290µs | DBI::::bootstrap DBI::bootstrap (xsub)
1 | 1 | 1 | 282µs | 949µs | DBI::::BEGIN@161 DBI::BEGIN@161
15 | 15 | 1 | 200µs | 336µs | DBD::_::common::::install_method DBD::_::common::install_method
3 | 3 | 2 | 155µs | 182µs | DBI::::setup_driver DBI::setup_driver
6 | 1 | 1 | 111µs | 292µs | DBI::::_new_dbh DBI::_new_dbh
1 | 1 | 1 | 83µs | 132µs | DBI::::END DBI::END
7 | 2 | 1 | 56µs | 56µs | DBI::::CORE:subst DBI::CORE:subst (opcode)
30 | 2 | 1 | 44µs | 44µs | DBD::_::common::::CORE:match DBD::_::common::CORE:match (opcode)
127 | 1 | 1 | 34µs | 34µs | DBI::::CORE:match DBI::CORE:match (opcode)
1 | 1 | 1 | 32µs | 45µs | DBI::::disconnect_all DBI::disconnect_all
1 | 1 | 1 | 23µs | 63µs | DBI::::_new_drh DBI::_new_drh
2 | 1 | 1 | 23µs | 60µs | DBD::_::db::::ping DBD::_::db::ping
5 | 5 | 1 | 17µs | 17µs | DBI::var::::TIESCALAR DBI::var::TIESCALAR
2 | 1 | 1 | 17µs | 22µs | DBD::_::common::::_not_impl DBD::_::common::_not_impl
1 | 1 | 1 | 16µs | 16µs | DBI::::BEGIN@13 DBI::BEGIN@13
1 | 1 | 1 | 15µs | 18µs | DBD::_::dr::::BEGIN@1449 DBD::_::dr::BEGIN@1449
8 | 1 | 1 | 14µs | 14µs | DBI::::SQL_UNKNOWN_TYPE DBI::SQL_UNKNOWN_TYPE (xsub)
4 | 1 | 1 | 14µs | 14µs | DBD::_::common::::FIRSTKEY DBD::_::common::FIRSTKEY
1 | 1 | 1 | 12µs | 14µs | DBD::_::db::::BEGIN@1510 DBD::_::db::BEGIN@1510
1 | 1 | 1 | 11µs | 17µs | DBI::::BEGIN@270 DBI::BEGIN@270
1 | 1 | 1 | 10µs | 18µs | DBI::::BEGIN@1030 DBI::BEGIN@1030
1 | 1 | 1 | 10µs | 18µs | DBI::::BEGIN@862 DBI::BEGIN@862
1 | 1 | 1 | 10µs | 14µs | DBD::_::common::::BEGIN@1343 DBD::_::common::BEGIN@1343
1 | 1 | 1 | 10µs | 13µs | DBD::_::st::::BEGIN@1821 DBD::_::st::BEGIN@1821
1 | 1 | 1 | 9µs | 12µs | DBI::::BEGIN@274 DBI::BEGIN@274
1 | 1 | 1 | 7µs | 16µs | DBI::::BEGIN@684 DBI::BEGIN@684
1 | 1 | 1 | 7µs | 14µs | DBI::::BEGIN@959 DBI::BEGIN@959
1 | 1 | 1 | 7µs | 15µs | DBI::::BEGIN@797 DBI::BEGIN@797
1 | 1 | 1 | 6µs | 23µs | DBI::::BEGIN@527 DBI::BEGIN@527
1 | 1 | 1 | 6µs | 14µs | DBI::::BEGIN@831 DBI::BEGIN@831
1 | 1 | 1 | 5µs | 5µs | DBD::_::common::::trace_msg DBD::_::common::trace_msg (xsub)
1 | 1 | 1 | 3µs | 3µs | DBI::::BEGIN@157 DBI::BEGIN@157
1 | 1 | 1 | 3µs | 3µs | DBI::::BEGIN@159 DBI::BEGIN@159
1 | 1 | 1 | 3µs | 3µs | DBI::::BEGIN@158 DBI::BEGIN@158
2 | 1 | 1 | 1µs | 1µs | DBI::::SQL_BLOB DBI::SQL_BLOB (xsub)
2 | 1 | 1 | 1µs | 1µs | DBI::::SQL_DECIMAL DBI::SQL_DECIMAL (xsub)
1 | 1 | 1 | 600ns | 600ns | DBI::::SQL_LONGVARCHAR DBI::SQL_LONGVARCHAR (xsub)
1 | 1 | 1 | 600ns | 600ns | DBI::::SQL_NUMERIC DBI::SQL_NUMERIC (xsub)
1 | 1 | 1 | 600ns | 600ns | DBI::::SQL_VARBINARY DBI::SQL_VARBINARY (xsub)
1 | 1 | 1 | 500ns | 500ns | DBI::::SQL_BINARY DBI::SQL_BINARY (xsub)
1 | 1 | 1 | 500ns | 500ns | DBI::::SQL_DATETIME DBI::SQL_DATETIME (xsub)
1 | 1 | 1 | 500ns | 500ns | DBI::::SQL_SMALLINT DBI::SQL_SMALLINT (xsub)
1 | 1 | 1 | 500ns | 500ns | DBI::::SQL_TIME DBI::SQL_TIME (xsub)
1 | 1 | 1 | 500ns | 500ns | DBI::::SQL_VARCHAR DBI::SQL_VARCHAR (xsub)
1 | 1 | 1 | 400ns | 400ns | DBI::::SQL_BIT DBI::SQL_BIT (xsub)
1 | 1 | 1 | 400ns | 400ns | DBI::::SQL_CHAR DBI::SQL_CHAR (xsub)
1 | 1 | 1 | 400ns | 400ns | DBI::::SQL_DATE DBI::SQL_DATE (xsub)
1 | 1 | 1 | 400ns | 400ns | DBI::::SQL_DOUBLE DBI::SQL_DOUBLE (xsub)
1 | 1 | 1 | 400ns | 400ns | DBI::::SQL_TIMESTAMP DBI::SQL_TIMESTAMP (xsub)
0 | 0 | 0 | 0s | 0s | DBD::Switch::dr::::CLONEDBD::Switch::dr::CLONE
0 | 0 | 0 | 0s | 0s | DBD::Switch::dr::::FETCHDBD::Switch::dr::FETCH
0 | 0 | 0 | 0s | 0s | DBD::Switch::dr::::STOREDBD::Switch::dr::STORE
0 | 0 | 0 | 0s | 0s | DBD::Switch::dr::::driverDBD::Switch::dr::driver
0 | 0 | 0 | 0s | 0s | DBD::_::common::::CLEAR DBD::_::common::CLEAR
0 | 0 | 0 | 0s | 0s | DBD::_::common::::EXISTS DBD::_::common::EXISTS
0 | 0 | 0 | 0s | 0s | DBD::_::common::::FETCH_many DBD::_::common::FETCH_many
0 | 0 | 0 | 0s | 0s | DBD::_::common::::NEXTKEY DBD::_::common::NEXTKEY
0 | 0 | 0 | 0s | 0s | DBD::_::common::::parse_trace_flag DBD::_::common::parse_trace_flag
0 | 0 | 0 | 0s | 0s | DBD::_::common::::parse_trace_flags DBD::_::common::parse_trace_flags
0 | 0 | 0 | 0s | 0s | DBD::_::common::::private_attribute_info DBD::_::common::private_attribute_info
0 | 0 | 0 | 0s | 0s | DBD::_::common::::visit_child_handles DBD::_::common::visit_child_handles
0 | 0 | 0 | 0s | 0s | DBD::_::db::::_do_selectrow DBD::_::db::_do_selectrow
0 | 0 | 0 | 0s | 0s | DBD::_::db::::clone DBD::_::db::clone
0 | 0 | 0 | 0s | 0s | DBD::_::db::::data_sources DBD::_::db::data_sources
0 | 0 | 0 | 0s | 0s | DBD::_::db::::do DBD::_::db::do
0 | 0 | 0 | 0s | 0s | DBD::_::db::::primary_key DBD::_::db::primary_key
0 | 0 | 0 | 0s | 0s | DBD::_::db::::quote DBD::_::db::quote
0 | 0 | 0 | 0s | 0s | DBD::_::db::::quote_identifier DBD::_::db::quote_identifier
0 | 0 | 0 | 0s | 0s | DBD::_::db::::rows DBD::_::db::rows
0 | 0 | 0 | 0s | 0s | DBD::_::db::::selectall_arrayref DBD::_::db::selectall_arrayref
0 | 0 | 0 | 0s | 0s | DBD::_::db::::selectall_hashref DBD::_::db::selectall_hashref
0 | 0 | 0 | 0s | 0s | DBD::_::db::::selectcol_arrayref DBD::_::db::selectcol_arrayref
0 | 0 | 0 | 0s | 0s | DBD::_::db::::selectrow_array DBD::_::db::selectrow_array
0 | 0 | 0 | 0s | 0s | DBD::_::db::::selectrow_arrayref DBD::_::db::selectrow_arrayref
0 | 0 | 0 | 0s | 0s | DBD::_::db::::selectrow_hashref DBD::_::db::selectrow_hashref
0 | 0 | 0 | 0s | 0s | DBD::_::db::::tables DBD::_::db::tables
0 | 0 | 0 | 0s | 0s | DBD::_::db::::type_info DBD::_::db::type_info
0 | 0 | 0 | 0s | 0s | DBD::_::dr::::connect DBD::_::dr::connect
0 | 0 | 0 | 0s | 0s | DBD::_::dr::::connect_cached DBD::_::dr::connect_cached
0 | 0 | 0 | 0s | 0s | DBD::_::dr::::default_user DBD::_::dr::default_user
0 | 0 | 0 | 0s | 0s | DBD::_::st::::__ANON__[:1937] DBD::_::st::__ANON__[:1937]
0 | 0 | 0 | 0s | 0s | DBD::_::st::::__ANON__[:1971] DBD::_::st::__ANON__[:1971]
0 | 0 | 0 | 0s | 0s | DBD::_::st::::bind_columns DBD::_::st::bind_columns
0 | 0 | 0 | 0s | 0s | DBD::_::st::::bind_param DBD::_::st::bind_param
0 | 0 | 0 | 0s | 0s | DBD::_::st::::bind_param_array DBD::_::st::bind_param_array
0 | 0 | 0 | 0s | 0s | DBD::_::st::::bind_param_inout_array DBD::_::st::bind_param_inout_array
0 | 0 | 0 | 0s | 0s | DBD::_::st::::blob_copy_to_file DBD::_::st::blob_copy_to_file
0 | 0 | 0 | 0s | 0s | DBD::_::st::::execute_array DBD::_::st::execute_array
0 | 0 | 0 | 0s | 0s | DBD::_::st::::execute_for_fetch DBD::_::st::execute_for_fetch
0 | 0 | 0 | 0s | 0s | DBD::_::st::::fetchall_arrayref DBD::_::st::fetchall_arrayref
0 | 0 | 0 | 0s | 0s | DBD::_::st::::fetchall_hashref DBD::_::st::fetchall_hashref
0 | 0 | 0 | 0s | 0s | DBD::_::st::::more_results DBD::_::st::more_results
0 | 0 | 0 | 0s | 0s | DBI::::CLONE DBI::CLONE
0 | 0 | 0 | 0s | 0s | DBI::::__ANON__[:1026] DBI::__ANON__[:1026]
0 | 0 | 0 | 0s | 0s | DBI::::__ANON__[:1117] DBI::__ANON__[:1117]
0 | 0 | 0 | 0s | 0s | DBI::::__ANON__[:1151] DBI::__ANON__[:1151]
0 | 0 | 0 | 0s | 0s | DBI::::__ANON__[:1152] DBI::__ANON__[:1152]
0 | 0 | 0 | 0s | 0s | DBI::::_dbtype_names DBI::_dbtype_names
0 | 0 | 0 | 0s | 0s | DBI::::_load_class DBI::_load_class
0 | 0 | 0 | 0s | 0s | DBI::::_rebless DBI::_rebless
0 | 0 | 0 | 0s | 0s | DBI::::_rebless_dbtype_subclass DBI::_rebless_dbtype_subclass
0 | 0 | 0 | 0s | 0s | DBI::::_set_isa DBI::_set_isa
0 | 0 | 0 | 0s | 0s | DBI::::available_drivers DBI::available_drivers
0 | 0 | 0 | 0s | 0s | DBI::::connect_cached DBI::connect_cached
0 | 0 | 0 | 0s | 0s | DBI::::connect_test_perf DBI::connect_test_perf
0 | 0 | 0 | 0s | 0s | DBI::::data_diff DBI::data_diff
0 | 0 | 0 | 0s | 0s | DBI::::data_sources DBI::data_sources
0 | 0 | 0 | 0s | 0s | DBI::::data_string_desc DBI::data_string_desc
0 | 0 | 0 | 0s | 0s | DBI::::data_string_diff DBI::data_string_diff
0 | 0 | 0 | 0s | 0s | DBI::::disconnect DBI::disconnect
0 | 0 | 0 | 0s | 0s | DBI::::driver_prefix DBI::driver_prefix
0 | 0 | 0 | 0s | 0s | DBI::::dump_dbd_registry DBI::dump_dbd_registry
0 | 0 | 0 | 0s | 0s | DBI::::dump_results DBI::dump_results
0 | 0 | 0 | 0s | 0s | DBI::::err DBI::err
0 | 0 | 0 | 0s | 0s | DBI::::errstr DBI::errstr
0 | 0 | 0 | 0s | 0s | DBI::::init_rootclass DBI::init_rootclass
0 | 0 | 0 | 0s | 0s | DBI::::installed_drivers DBI::installed_drivers
0 | 0 | 0 | 0s | 0s | DBI::::installed_methods DBI::installed_methods
0 | 0 | 0 | 0s | 0s | DBI::::installed_versions DBI::installed_versions
0 | 0 | 0 | 0s | 0s | DBI::::neat_list DBI::neat_list
0 | 0 | 0 | 0s | 0s | DBI::::parse_dsn DBI::parse_dsn
0 | 0 | 0 | 0s | 0s | DBI::var::::STORE DBI::var::STORE
0 | 0 | 0 | 0s | 0s | DBI::::visit_handles DBI::visit_handles

Call graph for these subroutines as a Graphviz dot language file.

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