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