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