← Index
Performance Profile   « block view • line view • sub view »
For /wise/base/deliv/dev/bin/getfix
  Run on Thu May 20 15:30:03 2010
Reported on Thu May 20 16:25:22 2010

File/wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/Storage/DBI.pm
Statements Executed835483
Total Time486.251098999978 seconds

Subroutines — ordered by exclusive time
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
55487321.54721565.08812DBIx::Class::Storage::DBI::dbh_do
55480310.439161.73587DBIx::Class::Storage::DBI::_verify_pid
4110.00272483.44178DBIx::Class::Storage::DBI::_dbh_execute
217320.001700.00170DBIC::SQL::Abstract::_quote
29310.000400.00063DBIC::SQL::Abstract::_recurse_fields
4110.000210.00032DBIx::Class::Storage::DBI::_query_end
4110.000190.06192DBIC::SQL::Abstract::select
5220.000150.00030DBIC::SQL::Abstract::_find_syntax
12310.000140.00118DBIx::Class::Storage::DBI::sql_maker
4110.000110.06216DBIx::Class::Storage::DBI::_prep_for_execute
1110.000110.01774DBIx::Class::Storage::DBI::_populate_dbh
4110.000110.00500DBIx::Class::Storage::DBI::_dbh_sth
4119.9e-50.00025DBIC::SQL::Abstract::_make_as
4229.6e-50.00016DBIC::SQL::Abstract::_order_by
1119.0e-50.00029DBIx::Class::Storage::DBI::new
4118.5e-58.5e-5DBIC::SQL::Abstract::_skip_options
4118.2e-50.00016DBIx::Class::Storage::DBI::_query_start
8228.1e-50.00040DBIC::SQL::Abstract::_table
4117.9e-50.00037DBIx::Class::Storage::DBI::select
4116.4e-50.00032DBIC::SQL::Abstract::_recurse_from
1116.0e-50.01204DBIx::Class::Storage::DBI::_connect
4115.8e-50.00031DBIC::SQL::Abstract::_emulate_limit
4115.0e-5483.44196DBIx::Class::Storage::DBI::_execute
4114.9e-50.00518DBIx::Class::Storage::DBI::sth
1114.0e-50.00028DBIC::SQL::Abstract::new
1113.5e-50.00011DBIx::Class::Storage::DBI::connect_info
1112.9e-50.00023DBIx::Class::Storage::DBI::connected
1112.4e-50.00031DBIx::Class::Storage::DBI::_sql_maker_args
1111.5e-50.00024DBIx::Class::Storage::DBI::ensure_connected
1111.4e-50.00027DBIx::Class::Storage::DBI::dbh
00000DBIC::SQL::Abstract::BEGIN
00000DBIC::SQL::Abstract::_RowNumberOver
00000DBIC::SQL::Abstract::_join_condition
00000DBIC::SQL::Abstract::_order_directions
00000DBIC::SQL::Abstract::delete
00000DBIC::SQL::Abstract::insert
00000DBIC::SQL::Abstract::limit_dialect
00000DBIC::SQL::Abstract::name_sep
00000DBIC::SQL::Abstract::quote_char
00000DBIC::SQL::Abstract::update
00000DBIx::Class::Storage::DBI::BEGIN
00000DBIx::Class::Storage::DBI::DESTROY
00000DBIx::Class::Storage::DBI::__ANON__[:847]
00000DBIx::Class::Storage::DBI::_check_sqlt_message
00000DBIx::Class::Storage::DBI::_check_sqlt_version
00000DBIx::Class::Storage::DBI::_dbh_columns_info_for
00000DBIx::Class::Storage::DBI::_dbh_last_insert_id
00000DBIx::Class::Storage::DBI::_do_connection_actions
00000DBIx::Class::Storage::DBI::_do_query
00000DBIx::Class::Storage::DBI::_fix_bind_params
00000DBIx::Class::Storage::DBI::_select
00000DBIx::Class::Storage::DBI::bind_attribute_by_data_type
00000DBIx::Class::Storage::DBI::build_datetime_parser
00000DBIx::Class::Storage::DBI::columns_info_for
00000DBIx::Class::Storage::DBI::configure_sqlt
00000DBIx::Class::Storage::DBI::create_ddl_dir
00000DBIx::Class::Storage::DBI::datetime_parser
00000DBIx::Class::Storage::DBI::datetime_parser_type
00000DBIx::Class::Storage::DBI::delete
00000DBIx::Class::Storage::DBI::deploy
00000DBIx::Class::Storage::DBI::deployment_statements
00000DBIx::Class::Storage::DBI::disconnect
00000DBIx::Class::Storage::DBI::insert
00000DBIx::Class::Storage::DBI::insert_bulk
00000DBIx::Class::Storage::DBI::last_insert_id
00000DBIx::Class::Storage::DBI::select_single
00000DBIx::Class::Storage::DBI::source_bind_attributes
00000DBIx::Class::Storage::DBI::sqlt_type
00000DBIx::Class::Storage::DBI::txn_begin
00000DBIx::Class::Storage::DBI::txn_commit
00000DBIx::Class::Storage::DBI::txn_do
00000DBIx::Class::Storage::DBI::txn_rollback
00000DBIx::Class::Storage::DBI::update

LineStmts.Exclusive
Time		Avg.Code
1package DBIx::Class::Storage::DBI;
2# -*- mode: cperl; cperl-indent-level: 2 -*-
3
434.5e-51.5e-5use base 'DBIx::Class::Storage';
# spent 3.23ms making 1 call to base::import
5
632.6e-58.7e-6use strict;
# spent 9µs making 1 call to strict::import
732.5e-58.3e-6use warnings;
# spent 18µs making 1 call to warnings::import
830.000650.00022use DBI;
# spent 45µs making 1 call to Exporter::import
930.002020.00067use SQL::Abstract::Limit;
# spent 5µs making 1 call to import
1030.001130.00038use DBIx::Class::Storage::DBI::Cursor;
# spent 5µs making 1 call to import
1130.000640.00021use DBIx::Class::Storage::Statistics;
# spent 4µs making 1 call to import
1238.2e-52.7e-5use Scalar::Util qw/blessed weaken/;
# spent 60µs making 1 call to Exporter::import
13
1412.6e-52.6e-5__PACKAGE__->mk_group_accessors('simple' =>
# spent 1.33ms making 1 call to Class::Accessor::Grouped::mk_group_accessors
15 qw/_connect_info _dbi_connect_info _dbh _sql_maker _sql_maker_opts
16 _conn_pid _conn_tid disable_sth_caching on_connect_do
17 on_disconnect_do transaction_depth unsafe _dbh_autocommit/
18);
19
2011.2e-51.2e-5__PACKAGE__->cursor_class('DBIx::Class::Storage::DBI::Cursor');
# spent 37µs making 1 call to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8]
21
2217.0e-67.0e-6__PACKAGE__->mk_group_accessors('inherited' => qw/sql_maker_class/);
# spent 119µs making 1 call to Class::Accessor::Grouped::mk_group_accessors
2318.0e-68.0e-6__PACKAGE__->sql_maker_class('DBIC::SQL::Abstract');
# spent 24µs making 1 call to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8]
24
25100BEGIN {
26
27package DBIC::SQL::Abstract; # Would merge upstream, but nate doesn't reply :(
28
2930.000165.4e-5use base qw/SQL::Abstract::Limit/;
# spent 74µs making 1 call to base::import
30
31# This prevents the caching of $dbh in S::A::L, I believe
32
# spent 284µs (40+244) within DBIC::SQL::Abstract::new which was called # once (40µs+244µs) by DBIx::Class::Storage::DBI::sql_maker at line 761
sub new {
3338.4e-52.8e-5 my $self = shift->SUPER::new(@_);
# spent 32µs making 1 call to SQL::Abstract::new
34
35 # If limit_dialect is a ref (like a $dbh), go ahead and replace
36 # it with what it resolves to:
37 $self->{limit_dialect} = $self->_find_syntax($self->{limit_dialect})
# spent 212µs making 1 call to DBIC::SQL::Abstract::_find_syntax
38 if ref $self->{limit_dialect};
39
40 $self;
41}
42
43sub _RowNumberOver {
44 my ($self, $sql, $order, $rows, $offset ) = @_;
45
46 $offset += 1;
47 my $last = $rows + $offset;
48 my ( $order_by ) = $self->_order_by( $order );
49
50 $sql = <<"";
51SELECT * FROM
52(
53 SELECT Q1.*, ROW_NUMBER() OVER( ) AS ROW_NUM FROM (
54 $sql
55 $order_by
56 ) Q1
57) Q2
58WHERE ROW_NUM BETWEEN $offset AND $last
59
60 return $sql;
61}
62
63
64# While we're at it, this should make LIMIT queries more efficient,
65# without digging into things too deeply
6630.001630.00054use Scalar::Util 'blessed';
# spent 60µs making 1 call to Exporter::import
67
# spent 302µs (147+155) within DBIC::SQL::Abstract::_find_syntax which was called 5 times, avg 60µs/call: # 4 times (71µs+19µs) by SQL::Abstract::Limit::select at line 172 of /wise/base/static/lib/perl5/site_perl/5.10.0/SQL/Abstract/Limit.pm, avg 22µs/call # once (76µs+136µs) by DBIC::SQL::Abstract::new or DBIx::Class::Storage::DBI::BEGIN at line 37
sub _find_syntax {
68200.000125.9e-6 my ($self, $syntax) = @_;
69 my $dbhname = blessed($syntax) ? $syntax->{Driver}{Name} : $syntax;
# spent 25µs making 5 calls to Scalar::Util::blessed, avg 5µs/call # spent 12µs making 2 calls to DBI::common::FETCH, avg 6µs/call
70 if(ref($self) && $dbhname && $dbhname eq 'DB2') {
71 return 'RowNumberOver';
72 }
73
74 $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
# spent 118µs making 1 call to SQL::Abstract::Limit::_find_syntax
75}
76
77
# spent 61.9ms (195µs+61.7) within DBIC::SQL::Abstract::select which was called 4 times, avg 15.5ms/call: # 4 times (195µs+61.7ms) by DBIx::Class::Storage::DBI::_prep_for_execute at line 928, avg 15.5ms/call
sub select {
78360.000215.9e-6 my ($self, $table, $fields, $where, $order, @rest) = @_;
79 $table = $self->_quote($table) unless ref($table);
80 local $self->{rownum_hack_count} = 1
81 if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
82 @rest = (-1) unless defined $rest[0];
83 die "LIMIT 0 Does Not Compute" if $rest[0] == 0;
84 # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
85 local $self->{having_bind} = [];
86 my ($sql, @ret) = $self->SUPER::select(
# spent 61.1ms making 4 calls to SQL::Abstract::Limit::select, avg 15.3ms/call # spent 628µs making 4 calls to DBIC::SQL::Abstract::_recurse_fields, avg 157µs/call
87 $table, $self->_recurse_fields($fields), $where, $order, @rest
88 );
89 $sql .=
90 $self->{for} ?
91 (
92 $self->{for} eq 'update' ? ' FOR UPDATE' :
93 $self->{for} eq 'shared' ? ' FOR SHARE' :
94 ''
95 ) :
96 ''
97 ;
98 return wantarray ? ($sql, @ret, @{$self->{having_bind}}) : $sql;
99}
100
101sub insert {
102 my $self = shift;
103 my $table = shift;
104 $table = $self->_quote($table) unless ref($table);
105 $self->SUPER::insert($table, @_);
106}
107
108sub update {
109 my $self = shift;
110 my $table = shift;
111 $table = $self->_quote($table) unless ref($table);
112 $self->SUPER::update($table, @_);
113}
114
115sub delete {
116 my $self = shift;
117 my $table = shift;
118 $table = $self->_quote($table) unless ref($table);
119 $self->SUPER::delete($table, @_);
120}
121
122
# spent 311µs (58+253) within DBIC::SQL::Abstract::_emulate_limit which was called 4 times, avg 78µs/call: # 4 times (58µs+253µs) by SQL::Abstract::Limit::select at line 174 of /wise/base/static/lib/perl5/site_perl/5.10.0/SQL/Abstract/Limit.pm, avg 78µs/call
sub _emulate_limit {
12395.7e-56.3e-6 my $self = shift;
124 if ($_[3] == -1) {
# spent 127µs making 3 calls to DBIC::SQL::Abstract::_order_by, avg 42µs/call
125 return $_[1].$self->_order_by($_[2]);
126 } else {
127 return $self->SUPER::_emulate_limit(@_);
# spent 126µs making 1 call to SQL::Abstract::Limit::_emulate_limit
128 }
129}
130
131
# spent 628µs (404+224) within DBIC::SQL::Abstract::_recurse_fields which was called 29 times, avg 22µs/call: # 23 times (217µs+-217000ns) by DBIx::Class::Storage::DBI::BEGIN or DBIC::SQL::Abstract::_recurse_fields at line 138, avg 0/call # 4 times (162µs+466µs) by DBIC::SQL::Abstract::select or DBIx::Class::Storage::DBI::BEGIN at line 86, avg 157µs/call # 2 times (25µs+-25000ns) by DBIx::Class::Storage::DBI::BEGIN or DBIC::SQL::Abstract::_recurse_fields at line 146, avg 0/call
sub _recurse_fields {
1321280.000453.5e-6 my ($self, $fields, $params) = @_;
133 my $ref = ref $fields;
134 return $self->_quote($fields) unless $ref;
# spent 199µs making 23 calls to DBIC::SQL::Abstract::_quote, avg 9µs/call
135 return $$fields if $ref eq 'SCALAR';
136
137 if ($ref eq 'ARRAY') {
138 return join(', ', map {
# spent 466µs making 23 calls to DBIC::SQL::Abstract::_recurse_fields, avg 0/call, max recursion depth 1
139 $self->_recurse_fields($_)
140 .(exists $self->{rownum_hack_count} && !($params && $params->{no_rownum_hack})
141 ? ' AS col'.$self->{rownum_hack_count}++
142 : '')
143 } @$fields);
144 } elsif ($ref eq 'HASH') {
145 foreach my $func (keys %$fields) {
146 return $self->_sqlcase($func)
# spent 25µs making 2 calls to SQL::Abstract::_sqlcase, avg 12µs/call # spent 42µs making 2 calls to DBIC::SQL::Abstract::_recurse_fields, avg 0/call, max recursion depth 2
147 .'( '.$self->_recurse_fields($fields->{$func}).' )';
148 }
149 }
150}
151
152
# spent 162µs (96+66) within DBIC::SQL::Abstract::_order_by which was called 4 times, avg 40µs/call: # 3 times (73µs+54µs) by DBIx::Class::Storage::DBI::BEGIN or DBIC::SQL::Abstract::_emulate_limit at line 124, avg 42µs/call # once (23µs+12µs) by SQL::Abstract::Limit::_LimitOffset at line 521 of /wise/base/static/lib/perl5/site_perl/5.10.0/SQL/Abstract/Limit.pm
sub _order_by {
153249.6e-54.0e-6 my $self = shift;
154 my $ret = '';
155 my @extra;
156 if (ref $_[0] eq 'HASH') {
157 if (defined $_[0]->{group_by}) {
158 $ret = $self->_sqlcase(' group by ')
159 .$self->_recurse_fields($_[0]->{group_by}, { no_rownum_hack => 1 });
160 }
161 if (defined $_[0]->{having}) {
162 my $frag;
163 ($frag, @extra) = $self->_recurse_where($_[0]->{having});
164 push(@{$self->{having_bind}}, @extra);
165 $ret .= $self->_sqlcase(' having ').$frag;
166 }
167 if (defined $_[0]->{order_by}) {
168 $ret .= $self->_order_by($_[0]->{order_by});
169 }
170 } elsif (ref $_[0] eq 'SCALAR') {
171 $ret = $self->_sqlcase(' order by ').${ $_[0] };
172 } elsif (ref $_[0] eq 'ARRAY' && @{$_[0]}) {
173 my @order = @{+shift};
174 $ret = $self->_sqlcase(' order by ')
175 .join(', ', map {
176 my $r = $self->_order_by($_, @_);
177 $r =~ s/^ ?ORDER BY //i;
178 $r;
179 } @order);
180 } else {
181 $ret = $self->SUPER::_order_by(@_);
# spent 66µs making 4 calls to SQL::Abstract::_order_by, avg 16µs/call
182 }
183 return $ret;
184}
185
186sub _order_directions {
187 my ($self, $order) = @_;
188 $order = $order->{order_by} if ref $order eq 'HASH';
189 return $self->SUPER::_order_directions($order);
190}
191
192
# spent 397µs (81+316) within DBIC::SQL::Abstract::_table which was called 8 times, avg 50µs/call: # 4 times (46µs+316µs) by SQL::Abstract::Limit::select at line 157 of /wise/base/static/lib/perl5/site_perl/5.10.0/SQL/Abstract/Limit.pm, avg 90µs/call # 4 times (35µs+0) by SQL::Abstract::select at line 532 of /wise/base/static/lib/perl5/site_perl/5.10.0/SQL/Abstract.pm, avg 9µs/call
sub _table {
193208.8e-54.4e-6 my ($self, $from) = @_;
194 if (ref $from eq 'ARRAY') {
# spent 316µs making 4 calls to DBIC::SQL::Abstract::_recurse_from, avg 79µs/call
195 return $self->_recurse_from(@$from);
196 } elsif (ref $from eq 'HASH') {
197 return $self->_make_as($from);
198 } else {
199 return $from; # would love to quote here but _table ends up getting called
200 # twice during an ->select without a limit clause due to
201 # the way S::A::Limit->select works. should maybe consider
202 # bypassing this and doing S::A::select($self, ...) in
203 # our select method above. meantime, quoting shims have
204 # been added to select/insert/update/delete here
205 }
206}
207
208
# spent 316µs (64+252) within DBIC::SQL::Abstract::_recurse_from which was called 4 times, avg 79µs/call: # 4 times (64µs+252µs) by DBIC::SQL::Abstract::_table or DBIx::Class::Storage::DBI::BEGIN at line 194, avg 79µs/call
sub _recurse_from {
209206.4e-53.2e-6 my ($self, $from, @join) = @_;
210 my @sqlf;
211 push(@sqlf, $self->_make_as($from));
# spent 252µs making 4 calls to DBIC::SQL::Abstract::_make_as, avg 63µs/call
212 foreach my $j (@join) {
213 my ($to, $on) = @$j;
214
215 # check whether a join type exists
216 my $join_clause = '';
217 my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
218 if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
219 $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
220 } else {
221 $join_clause = ' JOIN ';
222 }
223 push(@sqlf, $join_clause);
224
225 if (ref $to eq 'ARRAY') {
226 push(@sqlf, '(', $self->_recurse_from(@$to), ')');
227 } else {
228 push(@sqlf, $self->_make_as($to));
229 }
230 push(@sqlf, ' ON ', $self->_join_condition($on));
231 }
232 return join('', @sqlf);
233}
234
235
# spent 252µs (99+153) within DBIC::SQL::Abstract::_make_as which was called 4 times, avg 63µs/call: # 4 times (99µs+153µs) by DBIx::Class::Storage::DBI::BEGIN or DBIC::SQL::Abstract::_recurse_from at line 211, avg 63µs/call
sub _make_as {
236160.000137.9e-6 my ($self, $from) = @_;
237 return join(' ', map { (ref $_ eq 'SCALAR' ? $$_ : $self->_quote($_)) }
# spent 68µs making 8 calls to DBIC::SQL::Abstract::_quote, avg 8µs/call
238 reverse each %{$self->_skip_options($from)});
# spent 85µs making 4 calls to DBIC::SQL::Abstract::_skip_options, avg 21µs/call
239}
240
241
# spent 85µs within DBIC::SQL::Abstract::_skip_options which was called 4 times, avg 21µs/call: # 4 times (85µs+0) by DBIC::SQL::Abstract::_make_as or DBIx::Class::Storage::DBI::BEGIN at line 238, avg 21µs/call
sub _skip_options {
242247.1e-53.0e-6 my ($self, $hash) = @_;
243 my $clean_hash = {};
244 $clean_hash->{$_} = $hash->{$_}
245 for grep {!/^-/} keys %$hash;
246 return $clean_hash;
247}
248
249sub _join_condition {
250 my ($self, $cond) = @_;
251 if (ref $cond eq 'HASH') {
252 my %j;
253 for (keys %$cond) {
254 my $v = $cond->{$_};
255 if (ref $v) {
256 # XXX no throw_exception() in this package and croak() fails with strange results
257 Carp::croak(ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
258 if ref($v) ne 'SCALAR';
259 $j{$_} = $v;
260 }
261 else {
262 my $x = '= '.$self->_quote($v); $j{$_} = \$x;
263 }
264 };
265 return scalar($self->_recurse_where(\%j));
266 } elsif (ref $cond eq 'ARRAY') {
267 return join(' OR ', map { $self->_join_condition($_) } @$cond);
268 } else {
269 die "Can't handle this yet!";
270 }
271}
272
273
# spent 1.70ms within DBIC::SQL::Abstract::_quote which was called 217 times, avg 8µs/call: # 186 times (1.44ms+0) by SQL::Abstract::_recurse_where at line 650 of /wise/base/static/lib/perl5/site_perl/5.10.0/SQL/Abstract.pm, avg 8µs/call # 23 times (199µs+0) by DBIx::Class::Storage::DBI::BEGIN or DBIC::SQL::Abstract::_recurse_fields at line 134, avg 9µs/call # 8 times (68µs+0) by DBIC::SQL::Abstract::_make_as or DBIx::Class::Storage::DBI::BEGIN at line 237, avg 8µs/call
sub _quote {
2748660.001111.3e-6 my ($self, $label) = @_;
275 return '' unless defined $label;
276 return "*" if $label eq '*';
277 return $label unless $self->{quote_char};
278 if(ref $self->{quote_char} eq "ARRAY"){
279 return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
280 if !defined $self->{name_sep};
281 my $sep = $self->{name_sep};
282 return join($self->{name_sep},
283 map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
284 split(/\Q$sep\E/,$label));
285 }
286 return $self->SUPER::_quote($label);
287}
288
289sub limit_dialect {
290 my $self = shift;
291 $self->{limit_dialect} = shift if @_;
292 return $self->{limit_dialect};
293}
294
295sub quote_char {
296 my $self = shift;
297 $self->{quote_char} = shift if @_;
298 return $self->{quote_char};
299}
300
301sub name_sep {
302 my $self = shift;
303 $self->{name_sep} = shift if @_;
304 return $self->{name_sep};
305}
306
30710.005290.00529} # End of BEGIN block
308
309=head1 NAME
310
311DBIx::Class::Storage::DBI - DBI storage handler
312
313=head1 SYNOPSIS
314
315=head1 DESCRIPTION
316
317This class represents the connection to an RDBMS via L<DBI>. See
318L<DBIx::Class::Storage> for general information. This pod only
319documents DBI-specific methods and behaviors.
320
321=head1 METHODS
322
323=cut
324
325
# spent 288µs (90+198) within DBIx::Class::Storage::DBI::new which was called # once (90µs+198µs) by DBIx::Class::Schema::connection at line 685 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/Schema.pm
sub new {
32662.8e-54.7e-6 my $new = shift->next::method(@_);
# spent 42µs making 1 call to next::method
327
328 $new->transaction_depth(0);
# spent 15µs making 1 call to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8]
329 $new->_sql_maker_opts({});
# spent 14µs making 1 call to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8]
330 $new->{_in_dbh_do} = 0;
331 $new->{_dbh_gen} = 0;
332
333 $new;
334}
335
336=head2 connect_info
337
338The arguments of C<connect_info> are always a single array reference.
339
340This is normally accessed via L<DBIx::Class::Schema/connection>, which
341encapsulates its argument list in an arrayref before calling
342C<connect_info> here.
343
344The arrayref can either contain the same set of arguments one would
345normally pass to L<DBI/connect>, or a lone code reference which returns
346a connected database handle. Please note that the L<DBI> docs
347recommend that you always explicitly set C<AutoCommit> to either
348C<0> or C<1>. L<DBIx::Class> further recommends that it be set
349to C<1>, and that you perform transactions via our L</txn_do>
350method. L<DBIx::Class> will set it to C<1> if you do not do explicitly
351set it to zero. This is the default for most DBDs. See below for more
352details.
353
354In either case, if the final argument in your connect_info happens
355to be a hashref, C<connect_info> will look there for several
356connection-specific options:
357
358=over 4
359
360=item on_connect_do
361
362Specifies things to do immediately after connecting or re-connecting to
363the database. Its value may contain:
364
365=over
366
367=item an array reference
368
369This contains SQL statements to execute in order. Each element contains
370a string or a code reference that returns a string.
371
372=item a code reference
373
374This contains some code to execute. Unlike code references within an
375array reference, its return value is ignored.
376
377=back
378
379=item on_disconnect_do
380
381Takes arguments in the same form as L<on_connect_do> and executes them
382immediately before disconnecting from the database.
383
384Note, this only runs if you explicitly call L<disconnect> on the
385storage object.
386
387=item disable_sth_caching
388
389If set to a true value, this option will disable the caching of
390statement handles via L<DBI/prepare_cached>.
391
392=item limit_dialect
393
394Sets the limit dialect. This is useful for JDBC-bridge among others
395where the remote SQL-dialect cannot be determined by the name of the
396driver alone.
397
398=item quote_char
399
400Specifies what characters to use to quote table and column names. If
401you use this you will want to specify L<name_sep> as well.
402
403quote_char expects either a single character, in which case is it is placed
404on either side of the table/column, or an arrayref of length 2 in which case the
405table/column name is placed between the elements.
406
407For example under MySQL you'd use C<quote_char =E<gt> '`'>, and user SQL Server you'd
408use C<quote_char =E<gt> [qw/[ ]/]>.
409
410=item name_sep
411
412This only needs to be used in conjunction with L<quote_char>, and is used to
413specify the charecter that seperates elements (schemas, tables, columns) from
414each other. In most cases this is simply a C<.>.
415
416=item unsafe
417
418This Storage driver normally installs its own C<HandleError>, sets
419C<RaiseError> and C<ShowErrorStatement> on, and sets C<PrintError> off on
420all database handles, including those supplied by a coderef. It does this
421so that it can have consistent and useful error behavior.
422
423If you set this option to a true value, Storage will not do its usual
424modifications to the database handle's attributes, and instead relies on
425the settings in your connect_info DBI options (or the values you set in
426your connection coderef, in the case that you are connecting via coderef).
427
428Note that your custom settings can cause Storage to malfunction,
429especially if you set a C<HandleError> handler that suppresses exceptions
430and/or disable C<RaiseError>.
431
432=back
433
434These options can be mixed in with your other L<DBI> connection attributes,
435or placed in a seperate hashref after all other normal L<DBI> connection
436arguments.
437
438Every time C<connect_info> is invoked, any previous settings for
439these options will be cleared before setting the new ones, regardless of
440whether any options are specified in the new C<connect_info>.
441
442Another Important Note:
443
444DBIC can do some wonderful magic with handling exceptions,
445disconnections, and transactions when you use C<AutoCommit =&gt; 1>
446combined with C<txn_do> for transaction support.
447
448If you set C<AutoCommit =&gt; 0> in your connect info, then you are always
449in an assumed transaction between commits, and you're telling us you'd
450like to manage that manually. A lot of DBIC's magic protections
451go away. We can't protect you from exceptions due to database
452disconnects because we don't know anything about how to restart your
453transactions. You're on your own for handling all sorts of exceptional
454cases if you choose the C<AutoCommit =&gt 0> path, just as you would
455be with raw DBI.
456
457Examples:
458
459 # Simple SQLite connection
460 ->connect_info([ 'dbi:SQLite:./foo.db' ]);
461
462 # Connect via subref
463 ->connect_info([ sub { DBI->connect(...) } ]);
464
465 # A bit more complicated
466 ->connect_info(
467 [
468 'dbi:Pg:dbname=foo',
469 'postgres',
470 'my_pg_password',
471 { AutoCommit => 1 },
472 { quote_char => q{"}, name_sep => q{.} },
473 ]
474 );
475
476 # Equivalent to the previous example
477 ->connect_info(
478 [
479 'dbi:Pg:dbname=foo',
480 'postgres',
481 'my_pg_password',
482 { AutoCommit => 1, quote_char => q{"}, name_sep => q{.} },
483 ]
484 );
485
486 # Subref + DBIC-specific connection options
487 ->connect_info(
488 [
489 sub { DBI->connect(...) },
490 {
491 quote_char => q{`},
492 name_sep => q{@},
493 on_connect_do => ['SET search_path TO myschema,otherschema,public'],
494 disable_sth_caching => 1,
495 },
496 ]
497 );
498
499=cut
500
501
# spent 114µs (35+79) within DBIx::Class::Storage::DBI::connect_info which was called # once (35µs+79µs) by DBIx::Class::Schema::connection at line 686 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/Schema.pm
sub connect_info {
502105.4e-55.4e-6 my ($self, $info_arg) = @_;
503
504 return $self->_connect_info if !$info_arg;
505
506 # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
507 # the new set of options
508 $self->_sql_maker(undef);
# spent 15µs making 1 call to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8]
509 $self->_sql_maker_opts({});
# spent 11µs making 1 call to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8]
510 $self->_connect_info([@$info_arg]); # copy for _connect_info
# spent 15µs making 1 call to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8]
511
512 my $dbi_info = [@$info_arg]; # copy for _dbi_connect_info
513
514 my $last_info = $dbi_info->[-1];
515 if(ref $last_info eq 'HASH') {
516 $last_info = { %$last_info }; # so delete is non-destructive
517 my @storage_option = qw(
518 on_connect_do on_disconnect_do disable_sth_caching unsafe cursor_class
519 );
520 for my $storage_opt (@storage_option) {
521 if(my $value = delete $last_info->{$storage_opt}) {
522 $self->$storage_opt($value);
523 }
524 }
525 for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
526 if(my $opt_val = delete $last_info->{$sql_maker_opt}) {
527 $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
528 }
529 }
530 # re-insert modified hashref
531 $dbi_info->[-1] = $last_info;
532
533 # Get rid of any trailing empty hashref
534 pop(@$dbi_info) if !keys %$last_info;
535 }
536 $self->_dbi_connect_info($dbi_info);
# spent 13µs making 1 call to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8]
537
538 $self->_connect_info;
# spent 25µs making 1 call to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8]
539}
540
541=head2 on_connect_do
542
543This method is deprecated in favor of setting via L</connect_info>.
544
545=head2 dbh_do
546
547Arguments: $subref, @extra_coderef_args?
548
549Execute the given subref using the new exception-based connection management.
550
551The first two arguments will be the storage object that C<dbh_do> was called
552on and a database handle to use. Any additional arguments will be passed
553verbatim to the called subref as arguments 2 and onwards.
554
555Using this (instead of $self->_dbh or $self->dbh) ensures correct
556exception handling and reconnection (or failover in future subclasses).
557
558Your subref should have no side-effects outside of the database, as
559there is the potential for your subref to be partially double-executed
560if the database connection was stale/dysfunctional.
561
562Example:
563
564 my @stuff = $schema->storage->dbh_do(
565 sub {
566 my ($storage, $dbh, @cols) = @_;
567 my $cols = join(q{, }, @cols);
568 $dbh->selectrow_array("SELECT $cols FROM foo");
569 },
570 @column_list
571 );
572
573=cut
574
575
# spent 565s (1.55+564) within DBIx::Class::Storage::DBI::dbh_do which was called 55487 times, avg 10.2ms/call: # 55479 times (1.55s+564s) by DBIx::Class::Storage::DBI::Cursor::next at line 97 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/Storage/DBI/Cursor.pm, avg 10.2ms/call # 4 times (54µs+-54000ns) by DBIx::Class::Storage::DBI::_execute at line 1013, avg 0/call # 4 times (49µs+-49000ns) by DBIx::Class::Storage::DBI::sth at line 1201, avg 0/call
sub dbh_do {
5767212592.236593.1e-6 my $self = shift;
577 my $coderef = shift;
578
579 ref $coderef eq 'CODE' or $self->throw_exception
580 ('$coderef must be a CODE reference');
581
582 return $coderef->($self, $self->_dbh, @_) if $self->{_in_dbh_do}
# spent 483s making 4 calls to DBIx::Class::Storage::DBI::_dbh_execute, avg 121s/call # spent 5.00ms making 4 calls to DBIx::Class::Storage::DBI::_dbh_sth, avg 1.25ms/call # spent 112µs making 8 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 14µs/call
583 || $self->{transaction_depth};
584
585 local $self->{_in_dbh_do} = 1;
586
587 my @result;
588 my $want_array = wantarray;
589
590 eval {
591 $self->_verify_pid if $self->_dbh;
# spent 1.74s making 55478 calls to DBIx::Class::Storage::DBI::_verify_pid, avg 31µs/call # spent 706ms making 55479 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 13µs/call
592 $self->_populate_dbh if !$self->_dbh;
# spent 634ms making 55479 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 11µs/call # spent 17.7ms making 1 call to DBIx::Class::Storage::DBI::_populate_dbh
593 if($want_array) {
# spent 560s making 55479 calls to DBIx::Class::Storage::DBI::Cursor::_dbh_next, avg 10.1ms/call # spent 625ms making 55479 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 11µs/call
594 @result = $coderef->($self, $self->_dbh, @_);
595 }
596 elsif(defined $want_array) {
597 $result[0] = $coderef->($self, $self->_dbh, @_);
598 }
599 else {
600 $coderef->($self, $self->_dbh, @_);
601 }
602 };
603
604 my $exception = $@;
605 if(!$exception) { return $want_array ? @result : $result[0] }
606
607 $self->throw_exception($exception) if $self->connected;
608
609 # We were not connected - reconnect and retry, but let any
610 # exception fall right through this time
611 $self->_populate_dbh;
612 $coderef->($self, $self->_dbh, @_);
613}
614
615# This is basically a blend of dbh_do above and DBIx::Class::Storage::txn_do.
616# It also informs dbh_do to bypass itself while under the direction of txn_do,
617# via $self->{_in_dbh_do} (this saves some redundant eval and errorcheck, etc)
618sub txn_do {
619 my $self = shift;
620 my $coderef = shift;
621
622 ref $coderef eq 'CODE' or $self->throw_exception
623 ('$coderef must be a CODE reference');
624
625 return $coderef->(@_) if $self->{transaction_depth};
626
627 local $self->{_in_dbh_do} = 1;
628
629 my @result;
630 my $want_array = wantarray;
631
632 my $tried = 0;
633 while(1) {
634 eval {
635 $self->_verify_pid if $self->_dbh;
636 $self->_populate_dbh if !$self->_dbh;
637
638 $self->txn_begin;
639 if($want_array) {
640 @result = $coderef->(@_);
641 }
642 elsif(defined $want_array) {
643 $result[0] = $coderef->(@_);
644 }
645 else {
646 $coderef->(@_);
647 }
648 $self->txn_commit;
649 };
650
651 my $exception = $@;
652 if(!$exception) { return $want_array ? @result : $result[0] }
653
654 if($tried++ > 0 || $self->connected) {
655 eval { $self->txn_rollback };
656 my $rollback_exception = $@;
657 if($rollback_exception) {
658 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
659 $self->throw_exception($exception) # propagate nested rollback
660 if $rollback_exception =~ /$exception_class/;
661
662 $self->throw_exception(
663 "Transaction aborted: ${exception}. "
664 . "Rollback failed: ${rollback_exception}"
665 );
666 }
667 $self->throw_exception($exception)
668 }
669
670 # We were not connected, and was first try - reconnect and retry
671 # via the while loop
672 $self->_populate_dbh;
673 }
674}
675
676=head2 disconnect
677
678Our C<disconnect> method also performs a rollback first if the
679database is not in C<AutoCommit> mode.
680
681=cut
682
683sub disconnect {
684 my ($self) = @_;
685
686 if( $self->connected ) {
687 my $connection_do = $self->on_disconnect_do;
688 $self->_do_connection_actions($connection_do) if ref($connection_do);
689
690 $self->_dbh->rollback unless $self->_dbh_autocommit;
691 $self->_dbh->disconnect;
692 $self->_dbh(undef);
693 $self->{_dbh_gen}++;
694 }
695}
696
697
# spent 226µs (29+197) within DBIx::Class::Storage::DBI::connected which was called # once (29µs+197µs) by DBIx::Class::Storage::DBI::ensure_connected at line 733
sub connected {
69867.9e-51.3e-5 my ($self) = @_;
699
700 if(my $dbh = $self->_dbh) {
# spent 11µs making 1 call to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8]
701 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
# spent 20µs making 1 call to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8]
702 $self->_dbh(undef);
703 $self->{_dbh_gen}++;
704 return;
705 }
706 else {
707 $self->_verify_pid;
# spent 40µs making 1 call to DBIx::Class::Storage::DBI::_verify_pid
708 return 0 if !$self->_dbh;
# spent 13µs making 1 call to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8]
709 }
71011.0e-51.0e-5 return ($dbh->FETCH('Active') && $dbh->ping);
# spent 97µs making 1 call to DBI::db::ping # spent 16µs making 1 call to DBI::common::FETCH
711 }
712
713 return 0;
714}
715
716# handle pid changes correctly
717# NOTE: assumes $self->_dbh is a valid $dbh
718
# spent 1.74s (439ms+1.30) within DBIx::Class::Storage::DBI::_verify_pid which was called 55480 times, avg 31µs/call: # 55478 times (439ms+1.30s) by DBIx::Class::Storage::DBI::dbh_do at line 591, avg 31µs/call # once (16µs+26µs) by DBIx::Class::Storage::DBI::DESTROY at line 1581 # once (14µs+26µs) by DBIx::Class::Storage::DBI::connected at line 707
sub _verify_pid {
7191109600.624235.6e-6 my ($self) = @_;
720
721 return if defined $self->_conn_pid && $self->_conn_pid == $$;
# spent 1.30s making 110960 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 12µs/call
722
723 $self->_dbh->{InactiveDestroy} = 1;
724 $self->_dbh(undef);
725 $self->{_dbh_gen}++;
726
727 return;
728}
729
730
# spent 241µs (15+226) within DBIx::Class::Storage::DBI::ensure_connected which was called # once (15µs+226µs) by DBIx::Class::Storage::DBI::dbh at line 747
sub ensure_connected {
73121.3e-56.5e-6 my ($self) = @_;
732
733 unless ($self->connected) {
# spent 226µs making 1 call to DBIx::Class::Storage::DBI::connected
734 $self->_populate_dbh;
735 }
736}
737
738=head2 dbh
739
740Returns the dbh - a data base handle of class L<DBI>.
741
742=cut
743
744
# spent 272µs (14+258) within DBIx::Class::Storage::DBI::dbh which was called # once (14µs+258µs) by DBIx::Class::Storage::DBI::_sql_maker_args at line 754
sub dbh {
74532.1e-57.0e-6 my ($self) = @_;
746
747 $self->ensure_connected;
# spent 241µs making 1 call to DBIx::Class::Storage::DBI::ensure_connected
748 return $self->_dbh;
# spent 17µs making 1 call to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8]
749}
750
751
# spent 314µs (24+290) within DBIx::Class::Storage::DBI::_sql_maker_args which was called # once (24µs+290µs) by DBIx::Class::Storage::DBI::sql_maker at line 761
sub _sql_maker_args {
75222.9e-51.5e-5 my ($self) = @_;
753
754 return ( bindtype=>'columns', limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
# spent 272µs making 1 call to DBIx::Class::Storage::DBI::dbh # spent 18µs making 1 call to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8]
755}
756
757
# spent 1.18ms (141µs+1.04) within DBIx::Class::Storage::DBI::sql_maker which was called 12 times, avg 99µs/call: # 4 times (66µs+863µs) by DBIx::Class::Storage::DBI::_select at line 1107, avg 232µs/call # 4 times (38µs+89µs) by DBIx::Class::Storage::DBI::_select at line 1119, avg 32µs/call # 4 times (37µs+89µs) by DBIx::Class::Storage::DBI::_prep_for_execute at line 928, avg 32µs/call
sub sql_maker {
758380.000215.5e-6 my ($self) = @_;
759 unless ($self->_sql_maker) {
# spent 180µs making 12 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 15µs/call
760 my $sql_maker_class = $self->sql_maker_class;
# spent 114µs making 1 call to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8]
761 $self->_sql_maker($sql_maker_class->new( $self->_sql_maker_args ));
# spent 314µs making 1 call to DBIx::Class::Storage::DBI::_sql_maker_args # spent 284µs making 1 call to DBIC::SQL::Abstract::new # spent 14µs making 1 call to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8]
762 }
763 return $self->_sql_maker;
# spent 135µs making 12 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 11µs/call
764}
765
766
# spent 17.7ms (108µs+17.6) within DBIx::Class::Storage::DBI::_populate_dbh which was called # once (108µs+17.6ms) by DBIx::Class::Storage::DBI::dbh_do at line 592
sub _populate_dbh {
767130.000181.4e-5 my ($self) = @_;
768 my @info = @{$self->_dbi_connect_info || []};
# spent 16µs making 1 call to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8]
769 $self->_dbh($self->_connect(@info));
# spent 12.0ms making 1 call to DBIx::Class::Storage::DBI::_connect # spent 18µs making 1 call to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8]
770
771 # Always set the transaction depth on connect, since
772 # there is no transaction in progress by definition
773 $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
# spent 23µs making 1 call to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8]
774
775 if(ref $self eq 'DBIx::Class::Storage::DBI') {
776 my $driver = $self->_dbh->{Driver}->{Name};
# spent 15µs making 1 call to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8] # spent 14µs making 2 calls to DBI::common::FETCH, avg 7µs/call
777 if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
# spent 5.42ms making 1 call to DBIx::Class::Componentised::load_optional_class
778 bless $self, "DBIx::Class::Storage::DBI::${driver}";
779 $self->_rebless() if $self->can('_rebless');
# spent 15µs making 1 call to UNIVERSAL::can
780 }
781 }
782
783 my $connection_do = $self->on_connect_do;
# spent 29µs making 1 call to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8]
784 $self->_do_connection_actions($connection_do) if ref($connection_do);
785
786 $self->_conn_pid($$);
# spent 31µs making 1 call to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8]
787 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
788}
789
790sub _do_connection_actions {
791 my $self = shift;
792 my $connection_do = shift;
793
794 if (ref $connection_do eq 'ARRAY') {
795 $self->_do_query($_) foreach @$connection_do;
796 }
797 elsif (ref $connection_do eq 'CODE') {
798 $connection_do->();
799 }
800
801 return $self;
802}
803
804sub _do_query {
805 my ($self, $action) = @_;
806
807 if (ref $action eq 'CODE') {
808 $action = $action->($self);
809 $self->_do_query($_) foreach @$action;
810 }
811 else {
812 my @to_run = (ref $action eq 'ARRAY') ? (@$action) : ($action);
813 $self->_query_start(@to_run);
814 $self->_dbh->do(@to_run);
815 $self->_query_end(@to_run);
816 }
817
818 return $self;
819}
820
821
# spent 12.0ms (60µs+12.0) within DBIx::Class::Storage::DBI::_connect which was called # once (60µs+12.0ms) by DBIx::Class::Storage::DBI::_populate_dbh at line 769
sub _connect {
822180.000221.2e-5 my ($self, @info) = @_;
823
824 $self->throw_exception("You failed to provide any connection info")
825 if !@info;
826
827 my ($old_connect_via, $dbh);
828
829 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
830 $old_connect_via = $DBI::connect_via;
831 $DBI::connect_via = 'connect';
832 }
833
834 eval {
835 if(ref $info[0] eq 'CODE') {
836 $dbh = &{$info[0]}
837 }
838 else {
839 $dbh = DBI->connect(@info);
# spent 11.8ms making 1 call to DBI::connect
840 }
841
842 if($dbh && !$self->unsafe) {
# spent 47µs making 1 call to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8]
843 my $weak_self = $self;
844 weaken($weak_self);
# spent 10µs making 1 call to Scalar::Util::weaken
845 $dbh->{HandleError} = sub {
846 $weak_self->throw_exception("DBI Exception: $_[0]")
847 };
# spent 65µs making 1 call to DBI::common::STORE
848 $dbh->{ShowErrorStatement} = 1;
# spent 8µs making 1 call to DBI::common::STORE
849 $dbh->{RaiseError} = 1;
# spent 31µs making 1 call to DBI::common::STORE
850 $dbh->{PrintError} = 0;
# spent 9µs making 1 call to DBI::common::STORE
851 }
852 };
853
854 $DBI::connect_via = $old_connect_via if $old_connect_via;
855
856 $self->throw_exception("DBI Connection failed: " . ($@||$DBI::errstr))
857 if !$dbh || $@;
858
859 $self->_dbh_autocommit($dbh->{AutoCommit});
# spent 56µs making 1 call to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8]
860
861 $dbh;
862}
863
864
865sub txn_begin {
866 my $self = shift;
867 $self->ensure_connected();
868 if($self->{transaction_depth} == 0) {
869 $self->debugobj->txn_begin()
870 if $self->debug;
871 # this isn't ->_dbh-> because
872 # we should reconnect on begin_work
873 # for AutoCommit users
874 $self->dbh->begin_work;
875 }
876 $self->{transaction_depth}++;
877}
878
879sub txn_commit {
880 my $self = shift;
881 if ($self->{transaction_depth} == 1) {
882 my $dbh = $self->_dbh;
883 $self->debugobj->txn_commit()
884 if ($self->debug);
885 $dbh->commit;
886 $self->{transaction_depth} = 0
887 if $self->_dbh_autocommit;
888 }
889 elsif($self->{transaction_depth} > 1) {
890 $self->{transaction_depth}--
891 }
892}
893
894sub txn_rollback {
895 my $self = shift;
896 my $dbh = $self->_dbh;
897 eval {
898 if ($self->{transaction_depth} == 1) {
899 $self->debugobj->txn_rollback()
900 if ($self->debug);
901 $self->{transaction_depth} = 0
902 if $self->_dbh_autocommit;
903 $dbh->rollback;
904 }
905 elsif($self->{transaction_depth} > 1) {
906 $self->{transaction_depth}--;
907 }
908 else {
909 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
910 }
911 };
912 if ($@) {
913 my $error = $@;
914 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
915 $error =~ /$exception_class/ and $self->throw_exception($error);
916 # ensure that a failed rollback resets the transaction depth
917 $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
918 $self->throw_exception($error);
919 }
920}
921
922# This used to be the top-half of _execute. It was split out to make it
923# easier to override in NoBindVars without duping the rest. It takes up
924# all of _execute's args, and emits $sql, @bind.
925
# spent 62.2ms (113µs+62.0) within DBIx::Class::Storage::DBI::_prep_for_execute which was called 4 times, avg 15.5ms/call: # 4 times (113µs+62.0ms) by DBIx::Class::Storage::DBI::_dbh_execute at line 977, avg 15.5ms/call
sub _prep_for_execute {
926160.000127.5e-6 my ($self, $op, $extra_bind, $ident, $args) = @_;
927
928 my ($sql, @bind) = $self->sql_maker->$op($ident, @$args);
# spent 61.9ms making 4 calls to DBIC::SQL::Abstract::select, avg 15.5ms/call # spent 126µs making 4 calls to DBIx::Class::Storage::DBI::sql_maker, avg 32µs/call
929 unshift(@bind,
930 map { ref $_ eq 'ARRAY' ? $_ : [ '!!dummy', $_ ] } @$extra_bind)
931 if $extra_bind;
932
933 return ($sql, \@bind);
934}
935
936sub _fix_bind_params {
937 my ($self, @bind) = @_;
938
939 ### Turn @bind from something like this:
940 ### ( [ "artist", 1 ], [ "cdid", 1, 3 ] )
941 ### to this:
942 ### ( "'1'", "'1'", "'3'" )
943 return
944 map {
945 if ( defined( $_ && $_->[1] ) ) {
946 map { qq{'$_'}; } @{$_}[ 1 .. $#$_ ];
947 }
948 else { q{'NULL'}; }
949 } @bind;
950}
951
952
# spent 156µs (82+74) within DBIx::Class::Storage::DBI::_query_start which was called 4 times, avg 39µs/call: # 4 times (82µs+74µs) by DBIx::Class::Storage::DBI::_dbh_execute at line 979, avg 39µs/call
sub _query_start {
95388.1e-51.0e-5 my ( $self, $sql, @bind ) = @_;
954
955 if ( $self->debug ) {
# spent 74µs making 4 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 18µs/call
956 @bind = $self->_fix_bind_params(@bind);
957 $self->debugobj->query_start( $sql, @bind );
958 }
959}
960
961
# spent 316µs (212+104) within DBIx::Class::Storage::DBI::_query_end which was called 4 times, avg 79µs/call: # 4 times (212µs+104µs) by DBIx::Class::Storage::DBI::_dbh_execute at line 1006, avg 79µs/call
sub _query_end {
96280.000192.4e-5 my ( $self, $sql, @bind ) = @_;
963
964 if ( $self->debug ) {
# spent 104µs making 4 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 26µs/call
965 @bind = $self->_fix_bind_params(@bind);
966 $self->debugobj->query_end( $sql, @bind );
967 }
968}
969
970
# spent 483s (2.72ms+483) within DBIx::Class::Storage::DBI::_dbh_execute which was called 4 times, avg 121s/call: # 4 times (2.72ms+483s) by DBIx::Class::Storage::DBI::dbh_do at line 582, avg 121s/call
sub _dbh_execute {
9711826483.374060.26472 my ($self, $dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
972
973 if( blessed($ident) && $ident->isa("DBIx::Class::ResultSource") ) {
# spent 18µs making 4 calls to Scalar::Util::blessed, avg 4µs/call
974 $ident = $ident->from();
975 }
976
977 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
# spent 62.2ms making 4 calls to DBIx::Class::Storage::DBI::_prep_for_execute, avg 15.5ms/call
978
979 $self->_query_start( $sql, @$bind );
# spent 156µs making 4 calls to DBIx::Class::Storage::DBI::_query_start, avg 39µs/call
980
981 my $sth = $self->sth($sql,$op);
# spent 5.18ms making 4 calls to DBIx::Class::Storage::DBI::sth, avg 1.29ms/call
982
983 my $placeholder_index = 1;
984
985 foreach my $bound (@$bind) {
986 my $attributes = {};
987 my($column_name, @data) = @$bound;
988
989 if ($bind_attributes) {
990 $attributes = $bind_attributes->{$column_name}
991 if defined $bind_attributes->{$column_name};
992 }
993
994 foreach my $data (@data) {
995 $data = ref $data ? ''.$data : $data; # stringify args
996
997 $sth->bind_param($placeholder_index, $data, $attributes);
# spent 2.02ms making 354 calls to DBI::st::bind_param, avg 6µs/call
998 $placeholder_index++;
999 }
1000 }
1001
1002 # Can this fail without throwing an exception anyways???
1003 my $rv = $sth->execute();
# spent 483s making 4 calls to DBI::st::execute, avg 121s/call
1004 $self->throw_exception($sth->errstr) if !$rv;
1005
1006 $self->_query_end( $sql, @$bind );
# spent 316µs making 4 calls to DBIx::Class::Storage::DBI::_query_end, avg 79µs/call
1007
1008 return (wantarray ? ($rv, $sth, @$bind) : $rv);
1009}
1010
1011
# spent 483s (50µs+483) within DBIx::Class::Storage::DBI::_execute which was called 4 times, avg 121s/call: # 4 times (50µs+483s) by DBIx::Class::Storage::DBI::_select at line 1128, avg 121s/call
sub _execute {
101287.6e-59.5e-6 my $self = shift;
1013 $self->dbh_do($self->can('_dbh_execute'), @_)
# spent 25µs making 4 calls to UNIVERSAL::can, avg 6µs/call # spent 483s making 4 calls to DBIx::Class::Storage::DBI::dbh_do, avg 0/call, max recursion depth 1
1014}
1015
1016sub insert {
1017 my ($self, $source, $to_insert) = @_;
1018
1019 my $ident = $source->from;
1020 my $bind_attributes = $self->source_bind_attributes($source);
1021
1022 $self->_execute('insert' => [], $source, $bind_attributes, $to_insert);
1023
1024 return $to_insert;
1025}
1026
1027## Still not quite perfect, and EXPERIMENTAL
1028## Currently it is assumed that all values passed will be "normal", i.e. not
1029## scalar refs, or at least, all the same type as the first set, the statement is
1030## only prepped once.
1031sub insert_bulk {
1032 my ($self, $source, $cols, $data) = @_;
1033 my %colvalues;
1034 my $table = $source->from;
1035 @colvalues{@$cols} = (0..$#$cols);
1036 my ($sql, @bind) = $self->sql_maker->insert($table, \%colvalues);
1037
1038 $self->_query_start( $sql, @bind );
1039 my $sth = $self->sth($sql);
1040
1041# @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
1042
1043 ## This must be an arrayref, else nothing works!
1044
1045 my $tuple_status = [];
1046
1047 ##use Data::Dumper;
1048 ##print STDERR Dumper( $data, $sql, [@bind] );
1049
1050 my $time = time();
1051
1052 ## Get the bind_attributes, if any exist
1053 my $bind_attributes = $self->source_bind_attributes($source);
1054
1055 ## Bind the values and execute
1056 my $placeholder_index = 1;
1057
1058 foreach my $bound (@bind) {
1059
1060 my $attributes = {};
1061 my ($column_name, $data_index) = @$bound;
1062
1063 if( $bind_attributes ) {
1064 $attributes = $bind_attributes->{$column_name}
1065 if defined $bind_attributes->{$column_name};
1066 }
1067
1068 my @data = map { $_->[$data_index] } @$data;
1069
1070 $sth->bind_param_array( $placeholder_index, [@data], $attributes );
1071 $placeholder_index++;
1072 }
1073 my $rv = $sth->execute_array({ArrayTupleStatus => $tuple_status});
1074 $self->throw_exception($sth->errstr) if !$rv;
1075
1076 $self->_query_end( $sql, @bind );
1077 return (wantarray ? ($rv, $sth, @bind) : $rv);
1078}
1079
1080sub update {
1081 my $self = shift @_;
1082 my $source = shift @_;
1083 my $bind_attributes = $self->source_bind_attributes($source);
1084
1085 return $self->_execute('update' => [], $source, $bind_attributes, @_);
1086}
1087
1088
1089sub delete {
1090 my $self = shift @_;
1091 my $source = shift @_;
1092
1093 my $bind_attrs = {}; ## If ever it's needed...
1094
1095 return $self->_execute('delete' => [], $source, $bind_attrs, @_);
1096}
1097
1098sub _select {
1099520.000234.5e-6 my ($self, $ident, $select, $condition, $attrs) = @_;
1100 my $order = $attrs->{order_by};
1101
1102 if (ref $condition eq 'SCALAR') {
1103 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
1104 }
1105
1106 my $for = delete $attrs->{for};
1107 my $sql_maker = $self->sql_maker;
# spent 929µs making 4 calls to DBIx::Class::Storage::DBI::sql_maker, avg 232µs/call
1108 local $sql_maker->{for} = $for;
1109
1110 if (exists $attrs->{group_by} || $attrs->{having}) {
1111 $order = {
1112 group_by => $attrs->{group_by},
1113 having => $attrs->{having},
1114 ($order ? (order_by => $order) : ())
1115 };
1116 }
1117 my $bind_attrs = {}; ## Future support
1118 my @args = ('select', $attrs->{bind}, $ident, $bind_attrs, $select, $condition, $order);
1119 if ($attrs->{software_limit} ||
# spent 127µs making 4 calls to DBIx::Class::Storage::DBI::sql_maker, avg 32µs/call # spent 31µs making 4 calls to SQL::Abstract::Limit::_default_limit_syntax, avg 8µs/call
1120 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
1121 $attrs->{software_limit} = 1;
1122 } else {
1123 $self->throw_exception("rows attribute must be positive if present")
1124 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
1125 push @args, $attrs->{rows}, $attrs->{offset};
1126 }
1127
1128 return $self->_execute(@args);
# spent 483s making 4 calls to DBIx::Class::Storage::DBI::_execute, avg 121s/call
1129}
1130
1131sub source_bind_attributes {
1132 my ($self, $source) = @_;
1133
1134 my $bind_attributes;
1135 foreach my $column ($source->columns) {
1136
1137 my $data_type = $source->column_info($column)->{data_type} || '';
1138 $bind_attributes->{$column} = $self->bind_attribute_by_data_type($data_type)
1139 if $data_type;
1140 }
1141
1142 return $bind_attributes;
1143}
1144
1145=head2 select
1146
1147=over 4
1148
1149=item Arguments: $ident, $select, $condition, $attrs
1150
1151=back
1152
1153Handle a SQL select statement.
1154
1155=cut
1156
1157
# spent 371µs (79+292) within DBIx::Class::Storage::DBI::select which was called 4 times, avg 93µs/call: # 4 times (79µs+292µs) by DBIx::Class::ResultSet::cursor at line 514 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/ResultSet.pm, avg 93µs/call
sub select {
1158120.000119.1e-6 my $self = shift;
1159 my ($ident, $select, $condition, $attrs) = @_;
1160 return $self->cursor_class->new($self, \@_, $attrs);
# spent 209µs making 4 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 52µs/call # spent 83µs making 4 calls to DBIx::Class::Storage::DBI::Cursor::new, avg 21µs/call
1161}
1162
1163sub select_single {
1164 my $self = shift;
1165 my ($rv, $sth, @bind) = $self->_select(@_);
1166 my @row = $sth->fetchrow_array;
1167 # Need to call finish() to work round broken DBDs
1168 $sth->finish();
1169 return @row;
1170}
1171
1172=head2 sth
1173
1174=over 4
1175
1176=item Arguments: $sql
1177
1178=back
1179
1180Returns a L<DBI> sth (statement handle) for the supplied SQL.
1181
1182=cut
1183
1184
# spent 5.00ms (107µs+4.89) within DBIx::Class::Storage::DBI::_dbh_sth which was called 4 times, avg 1.25ms/call: # 4 times (107µs+4.89ms) by DBIx::Class::Storage::DBI::dbh_do at line 582, avg 1.25ms/call
sub _dbh_sth {
1185160.000159.4e-6 my ($self, $dbh, $sql) = @_;
1186
1187 # 3 is the if_active parameter which avoids active sth re-use
118813.0e-53.0e-5 my $sth = $self->disable_sth_caching
# spent 4.83ms making 4 calls to DBI::db::prepare_cached, avg 1.21ms/call # spent 63µs making 4 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 16µs/call
1189 ? $dbh->prepare($sql)
1190 : $dbh->prepare_cached($sql, {}, 3);
1191
1192 # XXX You would think RaiseError would make this impossible,
1193 # but apparently that's not true :(
1194 $self->throw_exception($dbh->errstr) if !$sth;
1195
1196 $sth;
1197}
1198
1199
# spent 5.18ms (49µs+5.13) within DBIx::Class::Storage::DBI::sth which was called 4 times, avg 1.29ms/call: # 4 times (49µs+5.13ms) by DBIx::Class::Storage::DBI::_dbh_execute at line 981, avg 1.29ms/call
sub sth {
120087.2e-59.0e-6 my ($self, $sql) = @_;
1201 $self->dbh_do($self->can('_dbh_sth'), $sql);
# spent 21µs making 4 calls to UNIVERSAL::can, avg 5µs/call # spent 5.11ms making 4 calls to DBIx::Class::Storage::DBI::dbh_do, avg 0/call, max recursion depth 2
1202}
1203
1204sub _dbh_columns_info_for {
1205 my ($self, $dbh, $table) = @_;
1206
1207 if ($dbh->can('column_info')) {
1208 my %result;
1209 eval {
1210 my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
1211 my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
1212 $sth->execute();
1213 while ( my $info = $sth->fetchrow_hashref() ){
1214 my %column_info;
1215 $column_info{data_type} = $info->{TYPE_NAME};
1216 $column_info{size} = $info->{COLUMN_SIZE};
1217 $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
1218 $column_info{default_value} = $info->{COLUMN_DEF};
1219 my $col_name = $info->{COLUMN_NAME};
1220 $col_name =~ s/^\"(.*)\"$/$1/;
1221
1222 $result{$col_name} = \%column_info;
1223 }
1224 };
1225 return \%result if !$@ && scalar keys %result;
1226 }
1227
1228 my %result;
1229 my $sth = $dbh->prepare($self->sql_maker->select($table, undef, \'1 = 0'));
1230 $sth->execute;
1231 my @columns = @{$sth->{NAME_lc}};
1232 for my $i ( 0 .. $#columns ){
1233 my %column_info;
1234 $column_info{data_type} = $sth->{TYPE}->[$i];
1235 $column_info{size} = $sth->{PRECISION}->[$i];
1236 $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
1237
1238 if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
1239 $column_info{data_type} = $1;
1240 $column_info{size} = $2;
1241 }
1242
1243 $result{$columns[$i]} = \%column_info;
1244 }
1245 $sth->finish;
1246
1247 foreach my $col (keys %result) {
1248 my $colinfo = $result{$col};
1249 my $type_num = $colinfo->{data_type};
1250 my $type_name;
1251 if(defined $type_num && $dbh->can('type_info')) {
1252 my $type_info = $dbh->type_info($type_num);
1253 $type_name = $type_info->{TYPE_NAME} if $type_info;
1254 $colinfo->{data_type} = $type_name if $type_name;
1255 }
1256 }
1257
1258 return \%result;
1259}
1260
1261sub columns_info_for {
1262 my ($self, $table) = @_;
1263 $self->dbh_do($self->can('_dbh_columns_info_for'), $table);
1264}
1265
1266=head2 last_insert_id
1267
1268Return the row id of the last insert.
1269
1270=cut
1271
1272sub _dbh_last_insert_id {
1273 my ($self, $dbh, $source, $col) = @_;
1274 # XXX This is a SQLite-ism as a default... is there a DBI-generic way?
1275 $dbh->func('last_insert_rowid');
1276}
1277
1278sub last_insert_id {
1279 my $self = shift;
1280 $self->dbh_do($self->can('_dbh_last_insert_id'), @_);
1281}
1282
1283=head2 sqlt_type
1284
1285Returns the database driver name.
1286
1287=cut
1288
1289sub sqlt_type { shift->dbh->{Driver}->{Name} }
1290
1291=head2 bind_attribute_by_data_type
1292
1293Given a datatype from column info, returns a database specific bind attribute for
1294$dbh->bind_param($val,$attribute) or nothing if we will let the database planner
1295just handle it.
1296
1297Generally only needed for special case column types, like bytea in postgres.
1298
1299=cut
1300
1301sub bind_attribute_by_data_type {
1302 return;
1303}
1304
1305=head2 create_ddl_dir
1306
1307=over 4
1308
1309=item Arguments: $schema \@databases, $version, $directory, $preversion, $sqlt_args
1310
1311=back
1312
1313Creates a SQL file based on the Schema, for each of the specified
1314database types, in the given directory.
1315
1316=cut
1317
1318sub create_ddl_dir
1319{
1320 my ($self, $schema, $databases, $version, $dir, $preversion, $sqltargs) = @_;
1321
1322 if(!$dir || !-d $dir)
1323 {
1324 warn "No directory given, using ./\n";
1325 $dir = "./";
1326 }
1327 $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
1328 $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
1329 $version ||= $schema->VERSION || '1.x';
1330 $sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} };
1331
1332 $self->throw_exception(q{Can't create a ddl file without SQL::Translator 0.08: '}
1333 . $self->_check_sqlt_message . q{'})
1334 if !$self->_check_sqlt_version;
1335
1336 my $sqlt = SQL::Translator->new({
1337# debug => 1,
1338 add_drop_table => 1,
1339 });
1340 foreach my $db (@$databases)
1341 {
1342 $sqlt->reset();
1343 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
1344# $sqlt->parser_args({'DBIx::Class' => $schema);
1345 $sqlt = $self->configure_sqlt($sqlt, $db);
1346 $sqlt->data($schema);
1347 $sqlt->producer($db);
1348
1349 my $file;
1350 my $filename = $schema->ddl_filename($db, $dir, $version);
1351 if(-e $filename)
1352 {
1353 warn("$filename already exists, skipping $db");
1354 next;
1355 }
1356
1357 my $output = $sqlt->translate;
1358 if(!$output)
1359 {
1360 warn("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
1361 next;
1362 }
1363 if(!open($file, ">$filename"))
1364 {
1365 $self->throw_exception("Can't open $filename for writing ($!)");
1366 next;
1367 }
1368 print $file $output;
1369 close($file);
1370
1371 if($preversion)
1372 {
1373 require SQL::Translator::Diff;
1374
1375 my $prefilename = $schema->ddl_filename($db, $dir, $preversion);
1376# print "Previous version $prefilename\n";
1377 if(!-e $prefilename)
1378 {
1379 warn("No previous schema file found ($prefilename)");
1380 next;
1381 }
1382 #### We need to reparse the SQLite file we just wrote, so that
1383 ## Diff doesnt get all confoosed, and Diff is *very* confused.
1384 ## FIXME: rip Diff to pieces!
1385# my $target_schema = $sqlt->schema;
1386# unless ( $target_schema->name ) {
1387# $target_schema->name( $filename );
1388# }
1389 my @input;
1390 push @input, {file => $prefilename, parser => $db};
1391 push @input, {file => $filename, parser => $db};
1392 my ( $source_schema, $source_db, $target_schema, $target_db ) = map {
1393 my $file = $_->{'file'};
1394 my $parser = $_->{'parser'};
1395
1396 my $t = SQL::Translator->new;
1397 $t->debug( 0 );
1398 $t->trace( 0 );
1399 $t->parser( $parser ) or die $t->error;
1400 my $out = $t->translate( $file ) or die $t->error;
1401 my $schema = $t->schema;
1402 unless ( $schema->name ) {
1403 $schema->name( $file );
1404 }
1405 ($schema, $parser);
1406 } @input;
1407
1408 my $diff = SQL::Translator::Diff::schema_diff($source_schema, $db,
1409 $target_schema, $db,
1410 {}
1411 );
1412 my $difffile = $schema->ddl_filename($db, $dir, $version, $preversion);
1413 print STDERR "Diff: $difffile: $db, $dir, $version, $preversion \n";
1414 if(-e $difffile)
1415 {
1416 warn("$difffile already exists, skipping");
1417 next;
1418 }
1419 if(!open $file, ">$difffile")
1420 {
1421 $self->throw_exception("Can't write to $difffile ($!)");
1422 next;
1423 }
1424 print $file $diff;
1425 close($file);
1426 }
1427 }
1428}
1429
1430sub configure_sqlt() {
1431 my $self = shift;
1432 my $tr = shift;
1433 my $db = shift || $self->sqlt_type;
1434 if ($db eq 'PostgreSQL') {
1435 $tr->quote_table_names(0);
1436 $tr->quote_field_names(0);
1437 }
1438 return $tr;
1439}
1440
1441=head2 deployment_statements
1442
1443=over 4
1444
1445=item Arguments: $schema, $type, $version, $directory, $sqlt_args
1446
1447=back
1448
1449Returns the statements used by L</deploy> and L<DBIx::Class::Schema/deploy>.
1450The database driver name is given by C<$type>, though the value from
1451L</sqlt_type> is used if it is not specified.
1452
1453C<$directory> is used to return statements from files in a previously created
1454L</create_ddl_dir> directory and is optional. The filenames are constructed
1455from L<DBIx::Class::Schema/ddl_filename>, the schema name and the C<$version>.
1456
1457If no C<$directory> is specified then the statements are constructed on the
1458fly using L<SQL::Translator> and C<$version> is ignored.
1459
1460See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>.
1461
1462=cut
1463
1464sub deployment_statements {
1465 my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
1466 # Need to be connected to get the correct sqlt_type
1467 $self->ensure_connected() unless $type;
1468 $type ||= $self->sqlt_type;
1469 $version ||= $schema->VERSION || '1.x';
1470 $dir ||= './';
1471 my $filename = $schema->ddl_filename($type, $dir, $version);
1472 if(-f $filename)
1473 {
1474 my $file;
1475 open($file, "<$filename")
1476 or $self->throw_exception("Can't open $filename ($!)");
1477 my @rows = <$file>;
1478 close($file);
1479 return join('', @rows);
1480 }
1481
1482 $self->throw_exception(q{Can't deploy without SQL::Translator 0.08: '}
1483 . $self->_check_sqlt_message . q{'})
1484 if !$self->_check_sqlt_version;
1485
1486 require SQL::Translator::Parser::DBIx::Class;
1487 eval qq{use SQL::Translator::Producer::${type}};
1488 $self->throw_exception($@) if $@;
1489
1490 # sources needs to be a parser arg, but for simplicty allow at top level
1491 # coming in
1492 $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources}
1493 if exists $sqltargs->{sources};
1494
1495 my $tr = SQL::Translator->new(%$sqltargs);
1496 SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
1497 return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
1498
1499 return;
1500
1501}
1502
1503sub deploy {
1504 my ($self, $schema, $type, $sqltargs, $dir) = @_;
1505 foreach my $statement ( $self->deployment_statements($schema, $type, undef, $dir, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
1506 foreach my $line ( split(";\n", $statement)) {
1507 next if($line =~ /^--/);
1508 next if(!$line);
1509# next if($line =~ /^DROP/m);
1510 next if($line =~ /^BEGIN TRANSACTION/m);
1511 next if($line =~ /^COMMIT/m);
1512 next if $line =~ /^\s+$/; # skip whitespace only
1513 $self->_query_start($line);
1514 eval {
1515 $self->dbh->do($line); # shouldn't be using ->dbh ?
1516 };
1517 if ($@) {
1518 warn qq{$@ (running "${line}")};
1519 }
1520 $self->_query_end($line);
1521 }
1522 }
1523}
1524
1525=head2 datetime_parser
1526
1527Returns the datetime parser class
1528
1529=cut
1530
1531sub datetime_parser {
1532 my $self = shift;
1533 return $self->{datetime_parser} ||= do {
1534 $self->ensure_connected;
1535 $self->build_datetime_parser(@_);
1536 };
1537}
1538
1539=head2 datetime_parser_type
1540
1541Defines (returns) the datetime parser class - currently hardwired to
1542L<DateTime::Format::MySQL>
1543
1544=cut
1545
1546sub datetime_parser_type { "DateTime::Format::MySQL"; }
1547
1548=head2 build_datetime_parser
1549
1550See L</datetime_parser>
1551
1552=cut
1553
1554sub build_datetime_parser {
1555 my $self = shift;
1556 my $type = $self->datetime_parser_type(@_);
1557 eval "use ${type}";
1558 $self->throw_exception("Couldn't load ${type}: $@") if $@;
1559 return $type;
1560}
1561
1562{
156322.0e-61.0e-6 my $_check_sqlt_version; # private
1564100 my $_check_sqlt_message; # private
1565 sub _check_sqlt_version {
1566 return $_check_sqlt_version if defined $_check_sqlt_version;
1567 eval 'use SQL::Translator 0.08';
1568 $_check_sqlt_message = $@ ? $@ : '';
1569 $_check_sqlt_version = $@ ? 0 : 1;
1570 }
1571
1572 sub _check_sqlt_message {
1573 _check_sqlt_version if !defined $_check_sqlt_message;
1574 $_check_sqlt_message;
1575 }
1576}
1577
1578sub DESTROY {
157945.2e-51.3e-5 my $self = shift;
1580 return if !$self->_dbh;
# spent 51µs making 1 call to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8]
1581 $self->_verify_pid;
# spent 42µs making 1 call to DBIx::Class::Storage::DBI::_verify_pid
1582 $self->_dbh(undef);
# spent 18µs making 1 call to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8]
1583}
1584
158519.0e-69.0e-61;
1586
1587=head1 SQL METHODS
1588
1589The module defines a set of methods within the DBIC::SQL::Abstract
1590namespace. These build on L<SQL::Abstract::Limit> to provide the
1591SQL query functions.
1592
1593The following methods are extended:-
1594
1595=over 4
1596
1597=item delete
1598
1599=item insert
1600
1601=item select
1602
1603=item update
1604
1605=item limit_dialect
1606
1607See L</connect_info> for details.
1608For setting, this method is deprecated in favor of L</connect_info>.
1609
1610=item quote_char
1611
1612See L</connect_info> for details.
1613For setting, this method is deprecated in favor of L</connect_info>.
1614
1615=item name_sep
1616
1617See L</connect_info> for details.
1618For setting, this method is deprecated in favor of L</connect_info>.
1619
1620=back
1621
1622=head1 AUTHORS
1623
1624Matt S. Trout <mst@shadowcatsystems.co.uk>
1625
1626Andy Grundman <andy@hybridized.org>
1627
1628=head1 LICENSE
1629
1630You may distribute this code under the same terms as Perl itself.
1631
1632=cut

Report produced by the NYTProf 2.07 Perl profiler, developed by Tim Bunce and Adam Kaplan.