1 package DBIx::Class::Storage::DBI;
2 # -*- mode: cperl; cperl-indent-level: 2 -*-
4 use base 'DBIx::Class::Storage';
9 use SQL::Abstract::Limit;
10 use DBIx::Class::Storage::DBI::Cursor;
11 use DBIx::Class::Storage::Statistics;
12 use Scalar::Util qw/blessed weaken/;
14 __PACKAGE__->mk_group_accessors('simple' =>
15 qw/_connect_info _dbi_connect_info _dbh _sql_maker _sql_maker_opts
16 _conn_pid _conn_tid disable_sth_caching cursor on_connect_do
17 on_disconnect_do transaction_depth unsafe _dbh_autocommit/
22 package DBIC::SQL::Abstract; # Would merge upstream, but nate doesn't reply :(
24 use base qw/SQL::Abstract::Limit/;
26 # This prevents the caching of $dbh in S::A::L, I believe
28 my $self = shift->SUPER::new(@_);
30 # If limit_dialect is a ref (like a $dbh), go ahead and replace
31 # it with what it resolves to:
32 $self->{limit_dialect} = $self->_find_syntax($self->{limit_dialect})
33 if ref $self->{limit_dialect};
39 my ($self, $sql, $order, $rows, $offset ) = @_;
42 my $last = $rows + $offset;
43 my ( $order_by ) = $self->_order_by( $order );
48 SELECT Q1.*, ROW_NUMBER() OVER( ) AS ROW_NUM FROM (
53 WHERE ROW_NUM BETWEEN $offset AND $last
59 # While we're at it, this should make LIMIT queries more efficient,
60 # without digging into things too deeply
61 use Scalar::Util 'blessed';
63 my ($self, $syntax) = @_;
64 my $dbhname = blessed($syntax) ? $syntax->{Driver}{Name} : $syntax;
65 if(ref($self) && $dbhname && $dbhname eq 'DB2') {
66 return 'RowNumberOver';
69 $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
73 my ($self, $table, $fields, $where, $order, @rest) = @_;
74 $table = $self->_quote($table) unless ref($table);
75 local $self->{rownum_hack_count} = 1
76 if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
77 @rest = (-1) unless defined $rest[0];
78 die "LIMIT 0 Does Not Compute" if $rest[0] == 0;
79 # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
80 local $self->{having_bind} = [];
81 my ($sql, @ret) = $self->SUPER::select(
82 $table, $self->_recurse_fields($fields), $where, $order, @rest
84 return wantarray ? ($sql, @ret, @{$self->{having_bind}}) : $sql;
90 $table = $self->_quote($table) unless ref($table);
91 $self->SUPER::insert($table, @_);
97 $table = $self->_quote($table) unless ref($table);
98 $self->SUPER::update($table, @_);
104 $table = $self->_quote($table) unless ref($table);
105 $self->SUPER::delete($table, @_);
111 return $_[1].$self->_order_by($_[2]);
113 return $self->SUPER::_emulate_limit(@_);
117 sub _recurse_fields {
118 my ($self, $fields, $params) = @_;
119 my $ref = ref $fields;
120 return $self->_quote($fields) unless $ref;
121 return $$fields if $ref eq 'SCALAR';
123 if ($ref eq 'ARRAY') {
124 return join(', ', map {
125 $self->_recurse_fields($_)
126 .(exists $self->{rownum_hack_count} && !($params && $params->{no_rownum_hack})
127 ? ' AS col'.$self->{rownum_hack_count}++
130 } elsif ($ref eq 'HASH') {
131 foreach my $func (keys %$fields) {
132 return $self->_sqlcase($func)
133 .'( '.$self->_recurse_fields($fields->{$func}).' )';
142 if (ref $_[0] eq 'HASH') {
143 if (defined $_[0]->{group_by}) {
144 $ret = $self->_sqlcase(' group by ')
145 .$self->_recurse_fields($_[0]->{group_by}, { no_rownum_hack => 1 });
147 if (defined $_[0]->{having}) {
149 ($frag, @extra) = $self->_recurse_where($_[0]->{having});
150 push(@{$self->{having_bind}}, @extra);
151 $ret .= $self->_sqlcase(' having ').$frag;
153 if (defined $_[0]->{order_by}) {
154 $ret .= $self->_order_by($_[0]->{order_by});
156 } elsif (ref $_[0] eq 'SCALAR') {
157 $ret = $self->_sqlcase(' order by ').${ $_[0] };
158 } elsif (ref $_[0] eq 'ARRAY' && @{$_[0]}) {
159 my @order = @{+shift};
160 $ret = $self->_sqlcase(' order by ')
162 my $r = $self->_order_by($_, @_);
163 $r =~ s/^ ?ORDER BY //i;
167 $ret = $self->SUPER::_order_by(@_);
172 sub _order_directions {
173 my ($self, $order) = @_;
174 $order = $order->{order_by} if ref $order eq 'HASH';
175 return $self->SUPER::_order_directions($order);
179 my ($self, $from) = @_;
180 if (ref $from eq 'ARRAY') {
181 return $self->_recurse_from(@$from);
182 } elsif (ref $from eq 'HASH') {
183 return $self->_make_as($from);
185 return $from; # would love to quote here but _table ends up getting called
186 # twice during an ->select without a limit clause due to
187 # the way S::A::Limit->select works. should maybe consider
188 # bypassing this and doing S::A::select($self, ...) in
189 # our select method above. meantime, quoting shims have
190 # been added to select/insert/update/delete here
195 my ($self, $from, @join) = @_;
197 push(@sqlf, $self->_make_as($from));
198 foreach my $j (@join) {
201 # check whether a join type exists
202 my $join_clause = '';
203 my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
204 if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
205 $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
207 $join_clause = ' JOIN ';
209 push(@sqlf, $join_clause);
211 if (ref $to eq 'ARRAY') {
212 push(@sqlf, '(', $self->_recurse_from(@$to), ')');
214 push(@sqlf, $self->_make_as($to));
216 push(@sqlf, ' ON ', $self->_join_condition($on));
218 return join('', @sqlf);
222 my ($self, $from) = @_;
223 return join(' ', map { (ref $_ eq 'SCALAR' ? $$_ : $self->_quote($_)) }
224 reverse each %{$self->_skip_options($from)});
228 my ($self, $hash) = @_;
230 $clean_hash->{$_} = $hash->{$_}
231 for grep {!/^-/} keys %$hash;
235 sub _join_condition {
236 my ($self, $cond) = @_;
237 if (ref $cond eq 'HASH') {
242 # XXX no throw_exception() in this package and croak() fails with strange results
243 Carp::croak(ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
244 if ref($v) ne 'SCALAR';
248 my $x = '= '.$self->_quote($v); $j{$_} = \$x;
251 return scalar($self->_recurse_where(\%j));
252 } elsif (ref $cond eq 'ARRAY') {
253 return join(' OR ', map { $self->_join_condition($_) } @$cond);
255 die "Can't handle this yet!";
260 my ($self, $label) = @_;
261 return '' unless defined $label;
262 return "*" if $label eq '*';
263 return $label unless $self->{quote_char};
264 if(ref $self->{quote_char} eq "ARRAY"){
265 return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
266 if !defined $self->{name_sep};
267 my $sep = $self->{name_sep};
268 return join($self->{name_sep},
269 map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
270 split(/\Q$sep\E/,$label));
272 return $self->SUPER::_quote($label);
277 $self->{limit_dialect} = shift if @_;
278 return $self->{limit_dialect};
283 $self->{quote_char} = shift if @_;
284 return $self->{quote_char};
289 $self->{name_sep} = shift if @_;
290 return $self->{name_sep};
293 } # End of BEGIN block
297 DBIx::Class::Storage::DBI - DBI storage handler
303 This class represents the connection to an RDBMS via L<DBI>. See
304 L<DBIx::Class::Storage> for general information. This pod only
305 documents DBI-specific methods and behaviors.
312 my $new = shift->next::method(@_);
314 $new->cursor("DBIx::Class::Storage::DBI::Cursor");
315 $new->transaction_depth(0);
316 $new->_sql_maker_opts({});
317 $new->{_in_dbh_do} = 0;
318 $new->{_dbh_gen} = 0;
325 The arguments of C<connect_info> are always a single array reference.
327 This is normally accessed via L<DBIx::Class::Schema/connection>, which
328 encapsulates its argument list in an arrayref before calling
329 C<connect_info> here.
331 The arrayref can either contain the same set of arguments one would
332 normally pass to L<DBI/connect>, or a lone code reference which returns
333 a connected database handle. Please note that the L<DBI> docs
334 recommend that you always explicitly set C<AutoCommit> to either
335 C<0> or C<1>. L<DBIx::Class> further recommends that it be set
336 to C<1>, and that you perform transactions via our L</txn_do>
337 method. L<DBIx::Class> will set it to C<1> if you do not do explicitly
338 set it to zero. This is the default for most DBDs. See below for more
341 In either case, if the final argument in your connect_info happens
342 to be a hashref, C<connect_info> will look there for several
343 connection-specific options:
349 This can be set to an arrayref containing literal sql statements and
350 code references, which will be executed immediately after making the
351 connection to the database every time we [re-]connect.
353 =item on_disconnect_do
355 As with L<on_connect_do>, this takes an arrayref of literal sql
356 statements and code references, but these statements execute immediately
357 before disconnecting from the database.
359 Note, this only runs if you explicitly call L<disconnect> on the
362 =item disable_sth_caching
364 If set to a true value, this option will disable the caching of
365 statement handles via L<DBI/prepare_cached>.
369 Sets the limit dialect. This is useful for JDBC-bridge among others
370 where the remote SQL-dialect cannot be determined by the name of the
375 Specifies what characters to use to quote table and column names. If
376 you use this you will want to specify L<name_sep> as well.
378 quote_char expects either a single character, in which case is it is placed
379 on either side of the table/column, or an arrayref of length 2 in which case the
380 table/column name is placed between the elements.
382 For example under MySQL you'd use C<quote_char =E<gt> '`'>, and user SQL Server you'd
383 use C<quote_char =E<gt> [qw/[ ]/]>.
387 This only needs to be used in conjunction with L<quote_char>, and is used to
388 specify the charecter that seperates elements (schemas, tables, columns) from
389 each other. In most cases this is simply a C<.>.
393 This Storage driver normally installs its own C<HandleError>, sets
394 C<RaiseError> and C<ShowErrorStatement> on, and sets C<PrintError> off on
395 all database handles, including those supplied by a coderef. It does this
396 so that it can have consistent and useful error behavior.
398 If you set this option to a true value, Storage will not do its usual
399 modifications to the database handle's attributes, and instead relies on
400 the settings in your connect_info DBI options (or the values you set in
401 your connection coderef, in the case that you are connecting via coderef).
403 Note that your custom settings can cause Storage to malfunction,
404 especially if you set a C<HandleError> handler that suppresses exceptions
405 and/or disable C<RaiseError>.
409 These options can be mixed in with your other L<DBI> connection attributes,
410 or placed in a seperate hashref after all other normal L<DBI> connection
413 Every time C<connect_info> is invoked, any previous settings for
414 these options will be cleared before setting the new ones, regardless of
415 whether any options are specified in the new C<connect_info>.
417 Another Important Note:
419 DBIC can do some wonderful magic with handling exceptions,
420 disconnections, and transactions when you use C<AutoCommit => 1>
421 combined with C<txn_do> for transaction support.
423 If you set C<AutoCommit => 0> in your connect info, then you are always
424 in an assumed transaction between commits, and you're telling us you'd
425 like to manage that manually. A lot of DBIC's magic protections
426 go away. We can't protect you from exceptions due to database
427 disconnects because we don't know anything about how to restart your
428 transactions. You're on your own for handling all sorts of exceptional
429 cases if you choose the C<AutoCommit => 0> path, just as you would
434 # Simple SQLite connection
435 ->connect_info([ 'dbi:SQLite:./foo.db' ]);
438 ->connect_info([ sub { DBI->connect(...) } ]);
440 # A bit more complicated
447 { quote_char => q{"}, name_sep => q{.} },
451 # Equivalent to the previous example
457 { AutoCommit => 1, quote_char => q{"}, name_sep => q{.} },
461 # Subref + DBIC-specific connection options
464 sub { DBI->connect(...) },
468 on_connect_do => ['SET search_path TO myschema,otherschema,public'],
469 disable_sth_caching => 1,
477 my ($self, $info_arg) = @_;
479 return $self->_connect_info if !$info_arg;
481 # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
482 # the new set of options
483 $self->_sql_maker(undef);
484 $self->_sql_maker_opts({});
485 $self->_connect_info([@$info_arg]); # copy for _connect_info
487 my $dbi_info = [@$info_arg]; # copy for _dbi_connect_info
489 my $last_info = $dbi_info->[-1];
490 if(ref $last_info eq 'HASH') {
491 $last_info = { %$last_info }; # so delete is non-destructive
493 qw/on_connect_do on_disconnect_do disable_sth_caching unsafe/;
494 for my $storage_opt (@storage_option) {
495 if(my $value = delete $last_info->{$storage_opt}) {
496 $self->$storage_opt($value);
499 for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
500 if(my $opt_val = delete $last_info->{$sql_maker_opt}) {
501 $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
504 # re-insert modified hashref
505 $dbi_info->[-1] = $last_info;
507 # Get rid of any trailing empty hashref
508 pop(@$dbi_info) if !keys %$last_info;
510 $self->_dbi_connect_info($dbi_info);
512 $self->_connect_info;
517 This method is deprecated in favor of setting via L</connect_info>.
521 Arguments: $subref, @extra_coderef_args?
523 Execute the given subref using the new exception-based connection management.
525 The first two arguments will be the storage object that C<dbh_do> was called
526 on and a database handle to use. Any additional arguments will be passed
527 verbatim to the called subref as arguments 2 and onwards.
529 Using this (instead of $self->_dbh or $self->dbh) ensures correct
530 exception handling and reconnection (or failover in future subclasses).
532 Your subref should have no side-effects outside of the database, as
533 there is the potential for your subref to be partially double-executed
534 if the database connection was stale/dysfunctional.
538 my @stuff = $schema->storage->dbh_do(
540 my ($storage, $dbh, @cols) = @_;
541 my $cols = join(q{, }, @cols);
542 $dbh->selectrow_array("SELECT $cols FROM foo");
553 ref $coderef eq 'CODE' or $self->throw_exception
554 ('$coderef must be a CODE reference');
556 return $coderef->($self, $self->_dbh, @_) if $self->{_in_dbh_do}
557 || $self->{transaction_depth};
559 local $self->{_in_dbh_do} = 1;
562 my $want_array = wantarray;
565 $self->_verify_pid if $self->_dbh;
566 $self->_populate_dbh if !$self->_dbh;
568 @result = $coderef->($self, $self->_dbh, @_);
570 elsif(defined $want_array) {
571 $result[0] = $coderef->($self, $self->_dbh, @_);
574 $coderef->($self, $self->_dbh, @_);
579 if(!$exception) { return $want_array ? @result : $result[0] }
581 $self->throw_exception($exception) if $self->connected;
583 # We were not connected - reconnect and retry, but let any
584 # exception fall right through this time
585 $self->_populate_dbh;
586 $coderef->($self, $self->_dbh, @_);
589 # This is basically a blend of dbh_do above and DBIx::Class::Storage::txn_do.
590 # It also informs dbh_do to bypass itself while under the direction of txn_do,
591 # via $self->{_in_dbh_do} (this saves some redundant eval and errorcheck, etc)
596 ref $coderef eq 'CODE' or $self->throw_exception
597 ('$coderef must be a CODE reference');
599 return $coderef->(@_) if $self->{transaction_depth};
601 local $self->{_in_dbh_do} = 1;
604 my $want_array = wantarray;
609 $self->_verify_pid if $self->_dbh;
610 $self->_populate_dbh if !$self->_dbh;
614 @result = $coderef->(@_);
616 elsif(defined $want_array) {
617 $result[0] = $coderef->(@_);
626 if(!$exception) { return $want_array ? @result : $result[0] }
628 if($tried++ > 0 || $self->connected) {
629 eval { $self->txn_rollback };
630 my $rollback_exception = $@;
631 if($rollback_exception) {
632 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
633 $self->throw_exception($exception) # propagate nested rollback
634 if $rollback_exception =~ /$exception_class/;
636 $self->throw_exception(
637 "Transaction aborted: ${exception}. "
638 . "Rollback failed: ${rollback_exception}"
641 $self->throw_exception($exception)
644 # We were not connected, and was first try - reconnect and retry
646 $self->_populate_dbh;
652 Our C<disconnect> method also performs a rollback first if the
653 database is not in C<AutoCommit> mode.
660 if( $self->connected ) {
661 foreach (@{$self->on_disconnect_do || []}) {
662 $self->_do_query($_);
664 $self->_dbh->rollback unless $self->_dbh_autocommit;
665 $self->_dbh->disconnect;
674 if(my $dbh = $self->_dbh) {
675 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
683 return ($dbh->FETCH('Active') && $dbh->ping);
689 # handle pid changes correctly
690 # NOTE: assumes $self->_dbh is a valid $dbh
694 return if $self->_conn_pid == $$;
696 $self->_dbh->{InactiveDestroy} = 1;
703 sub ensure_connected {
706 unless ($self->connected) {
707 $self->_populate_dbh;
713 Returns the dbh - a data base handle of class L<DBI>.
720 $self->ensure_connected;
724 sub _sql_maker_args {
727 return ( bindtype=>'columns', limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
732 unless ($self->_sql_maker) {
733 $self->_sql_maker(new DBIC::SQL::Abstract( $self->_sql_maker_args ));
735 return $self->_sql_maker;
740 my @info = @{$self->_dbi_connect_info || []};
741 $self->_dbh($self->_connect(@info));
743 # Always set the transaction depth on connect, since
744 # there is no transaction in progress by definition
745 $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
747 if(ref $self eq 'DBIx::Class::Storage::DBI') {
748 my $driver = $self->_dbh->{Driver}->{Name};
749 if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
750 bless $self, "DBIx::Class::Storage::DBI::${driver}";
751 $self->_rebless() if $self->can('_rebless');
755 foreach (@{$self->on_connect_do || []}) {
756 $self->_do_query($_);
759 $self->_conn_pid($$);
760 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
764 my ($self, $action) = @_;
766 # $action contains either an SQL string or a code ref
771 $self->debugobj->query_start($action) if $self->debug();
772 $self->_dbh->do($action);
773 $self->debugobj->query_end($action) if $self->debug();
780 my ($self, @info) = @_;
782 $self->throw_exception("You failed to provide any connection info")
785 my ($old_connect_via, $dbh);
787 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
788 $old_connect_via = $DBI::connect_via;
789 $DBI::connect_via = 'connect';
793 if(ref $info[0] eq 'CODE') {
797 $dbh = DBI->connect(@info);
801 my $weak_self = $self;
803 $dbh->{HandleError} = sub {
804 $weak_self->throw_exception("DBI Exception: $_[0]")
806 $dbh->{ShowErrorStatement} = 1;
807 $dbh->{RaiseError} = 1;
808 $dbh->{PrintError} = 0;
812 $DBI::connect_via = $old_connect_via if $old_connect_via;
814 $self->throw_exception("DBI Connection failed: " . ($@||$DBI::errstr))
817 $self->_dbh_autocommit($dbh->{AutoCommit});
825 $self->ensure_connected();
826 if($self->{transaction_depth} == 0) {
827 $self->debugobj->txn_begin()
829 # this isn't ->_dbh-> because
830 # we should reconnect on begin_work
831 # for AutoCommit users
832 $self->dbh->begin_work;
834 $self->{transaction_depth}++;
839 if ($self->{transaction_depth} == 1) {
840 my $dbh = $self->_dbh;
841 $self->debugobj->txn_commit()
844 $self->{transaction_depth} = 0
845 if $self->_dbh_autocommit;
847 elsif($self->{transaction_depth} > 1) {
848 $self->{transaction_depth}--
854 my $dbh = $self->_dbh;
856 if ($self->{transaction_depth} == 1) {
857 $self->debugobj->txn_rollback()
859 $self->{transaction_depth} = 0
860 if $self->_dbh_autocommit;
863 elsif($self->{transaction_depth} > 1) {
864 $self->{transaction_depth}--;
867 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
872 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
873 $error =~ /$exception_class/ and $self->throw_exception($error);
874 # ensure that a failed rollback resets the transaction depth
875 $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
876 $self->throw_exception($error);
880 # This used to be the top-half of _execute. It was split out to make it
881 # easier to override in NoBindVars without duping the rest. It takes up
882 # all of _execute's args, and emits $sql, @bind.
883 sub _prep_for_execute {
884 my ($self, $op, $extra_bind, $ident, $args) = @_;
886 my ($sql, @bind) = $self->sql_maker->$op($ident, @$args);
888 map { ref $_ eq 'ARRAY' ? $_ : [ '!!dummy', $_ ] } @$extra_bind)
891 return ($sql, \@bind);
895 my ($self, $dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
897 if( blessed($ident) && $ident->isa("DBIx::Class::ResultSource") ) {
898 $ident = $ident->from();
901 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
905 map { defined ($_ && $_->[1]) ? qq{'$_->[1]'} : q{'NULL'} } @$bind;
906 $self->debugobj->query_start($sql, @debug_bind);
909 my $sth = $self->sth($sql,$op);
911 my $placeholder_index = 1;
913 foreach my $bound (@$bind) {
915 my($column_name, @data) = @$bound;
917 if ($bind_attributes) {
918 $attributes = $bind_attributes->{$column_name}
919 if defined $bind_attributes->{$column_name};
922 foreach my $data (@data) {
923 $data = ref $data ? ''.$data : $data; # stringify args
925 $sth->bind_param($placeholder_index, $data, $attributes);
926 $placeholder_index++;
930 # Can this fail without throwing an exception anyways???
931 my $rv = $sth->execute();
932 $self->throw_exception($sth->errstr) if !$rv;
936 map { defined ($_ && $_->[1]) ? qq{'$_->[1]'} : q{'NULL'} } @$bind;
937 $self->debugobj->query_end($sql, @debug_bind);
940 return (wantarray ? ($rv, $sth, @$bind) : $rv);
945 $self->dbh_do($self->can('_dbh_execute'), @_)
949 my ($self, $source, $to_insert) = @_;
951 my $ident = $source->from;
952 my $bind_attributes = $self->source_bind_attributes($source);
954 $self->_execute('insert' => [], $source, $bind_attributes, $to_insert);
959 ## Still not quite perfect, and EXPERIMENTAL
960 ## Currently it is assumed that all values passed will be "normal", i.e. not
961 ## scalar refs, or at least, all the same type as the first set, the statement is
962 ## only prepped once.
964 my ($self, $source, $cols, $data) = @_;
966 my $table = $source->from;
967 @colvalues{@$cols} = (0..$#$cols);
968 my ($sql, @bind) = $self->sql_maker->insert($table, \%colvalues);
971 my @debug_bind = map { defined $_->[1] ? qq{$_->[1]} : q{'NULL'} } @bind;
972 $self->debugobj->query_start($sql, @debug_bind);
974 my $sth = $self->sth($sql);
976 # @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
978 ## This must be an arrayref, else nothing works!
980 my $tuple_status = [];
983 ##print STDERR Dumper( $data, $sql, [@bind] );
987 ## Get the bind_attributes, if any exist
988 my $bind_attributes = $self->source_bind_attributes($source);
990 ## Bind the values and execute
991 my $placeholder_index = 1;
993 foreach my $bound (@bind) {
996 my ($column_name, $data_index) = @$bound;
998 if( $bind_attributes ) {
999 $attributes = $bind_attributes->{$column_name}
1000 if defined $bind_attributes->{$column_name};
1003 my @data = map { $_->[$data_index] } @$data;
1005 $sth->bind_param_array( $placeholder_index, [@data], $attributes );
1006 $placeholder_index++;
1008 my $rv = $sth->execute_array({ArrayTupleStatus => $tuple_status});
1009 $self->throw_exception($sth->errstr) if !$rv;
1012 my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind;
1013 $self->debugobj->query_end($sql, @debug_bind);
1015 return (wantarray ? ($rv, $sth, @bind) : $rv);
1019 my $self = shift @_;
1020 my $source = shift @_;
1021 my $bind_attributes = $self->source_bind_attributes($source);
1023 return $self->_execute('update' => [], $source, $bind_attributes, @_);
1028 my $self = shift @_;
1029 my $source = shift @_;
1031 my $bind_attrs = {}; ## If ever it's needed...
1033 return $self->_execute('delete' => [], $source, $bind_attrs, @_);
1037 my ($self, $ident, $select, $condition, $attrs) = @_;
1038 my $order = $attrs->{order_by};
1039 if (ref $condition eq 'SCALAR') {
1040 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
1042 if (exists $attrs->{group_by} || $attrs->{having}) {
1044 group_by => $attrs->{group_by},
1045 having => $attrs->{having},
1046 ($order ? (order_by => $order) : ())
1049 my $bind_attrs = {}; ## Future support
1050 my @args = ('select', $attrs->{bind}, $ident, $bind_attrs, $select, $condition, $order);
1051 if ($attrs->{software_limit} ||
1052 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
1053 $attrs->{software_limit} = 1;
1055 $self->throw_exception("rows attribute must be positive if present")
1056 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
1057 push @args, $attrs->{rows}, $attrs->{offset};
1059 return $self->_execute(@args);
1062 sub source_bind_attributes {
1063 my ($self, $source) = @_;
1065 my $bind_attributes;
1066 foreach my $column ($source->columns) {
1068 my $data_type = $source->column_info($column)->{data_type} || '';
1069 $bind_attributes->{$column} = $self->bind_attribute_by_data_type($data_type)
1073 return $bind_attributes;
1080 =item Arguments: $ident, $select, $condition, $attrs
1084 Handle a SQL select statement.
1090 my ($ident, $select, $condition, $attrs) = @_;
1091 return $self->cursor->new($self, \@_, $attrs);
1096 my ($rv, $sth, @bind) = $self->_select(@_);
1097 my @row = $sth->fetchrow_array;
1098 # Need to call finish() to work round broken DBDs
1107 =item Arguments: $sql
1111 Returns a L<DBI> sth (statement handle) for the supplied SQL.
1116 my ($self, $dbh, $sql) = @_;
1118 # 3 is the if_active parameter which avoids active sth re-use
1119 my $sth = $self->disable_sth_caching
1120 ? $dbh->prepare($sql)
1121 : $dbh->prepare_cached($sql, {}, 3);
1123 # XXX You would think RaiseError would make this impossible,
1124 # but apparently that's not true :(
1125 $self->throw_exception($dbh->errstr) if !$sth;
1131 my ($self, $sql) = @_;
1132 $self->dbh_do($self->can('_dbh_sth'), $sql);
1135 sub _dbh_columns_info_for {
1136 my ($self, $dbh, $table) = @_;
1138 if ($dbh->can('column_info')) {
1141 my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
1142 my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
1144 while ( my $info = $sth->fetchrow_hashref() ){
1146 $column_info{data_type} = $info->{TYPE_NAME};
1147 $column_info{size} = $info->{COLUMN_SIZE};
1148 $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
1149 $column_info{default_value} = $info->{COLUMN_DEF};
1150 my $col_name = $info->{COLUMN_NAME};
1151 $col_name =~ s/^\"(.*)\"$/$1/;
1153 $result{$col_name} = \%column_info;
1156 return \%result if !$@ && scalar keys %result;
1160 my $sth = $dbh->prepare($self->sql_maker->select($table, undef, \'1 = 0'));
1162 my @columns = @{$sth->{NAME_lc}};
1163 for my $i ( 0 .. $#columns ){
1165 $column_info{data_type} = $sth->{TYPE}->[$i];
1166 $column_info{size} = $sth->{PRECISION}->[$i];
1167 $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
1169 if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
1170 $column_info{data_type} = $1;
1171 $column_info{size} = $2;
1174 $result{$columns[$i]} = \%column_info;
1178 foreach my $col (keys %result) {
1179 my $colinfo = $result{$col};
1180 my $type_num = $colinfo->{data_type};
1182 if(defined $type_num && $dbh->can('type_info')) {
1183 my $type_info = $dbh->type_info($type_num);
1184 $type_name = $type_info->{TYPE_NAME} if $type_info;
1185 $colinfo->{data_type} = $type_name if $type_name;
1192 sub columns_info_for {
1193 my ($self, $table) = @_;
1194 $self->dbh_do($self->can('_dbh_columns_info_for'), $table);
1197 =head2 last_insert_id
1199 Return the row id of the last insert.
1203 sub _dbh_last_insert_id {
1204 my ($self, $dbh, $source, $col) = @_;
1205 # XXX This is a SQLite-ism as a default... is there a DBI-generic way?
1206 $dbh->func('last_insert_rowid');
1209 sub last_insert_id {
1211 $self->dbh_do($self->can('_dbh_last_insert_id'), @_);
1216 Returns the database driver name.
1220 sub sqlt_type { shift->dbh->{Driver}->{Name} }
1222 =head2 bind_attribute_by_data_type
1224 Given a datatype from column info, returns a database specific bind attribute for
1225 $dbh->bind_param($val,$attribute) or nothing if we will let the database planner
1228 Generally only needed for special case column types, like bytea in postgres.
1232 sub bind_attribute_by_data_type {
1236 =head2 create_ddl_dir
1240 =item Arguments: $schema \@databases, $version, $directory, $preversion, $sqlt_args
1244 Creates a SQL file based on the Schema, for each of the specified
1245 database types, in the given directory.
1251 my ($self, $schema, $databases, $version, $dir, $preversion, $sqltargs) = @_;
1253 if(!$dir || !-d $dir)
1255 warn "No directory given, using ./\n";
1258 $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
1259 $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
1260 $version ||= $schema->VERSION || '1.x';
1261 $sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} };
1263 $self->throw_exception(q{Can't create a ddl file without SQL::Translator 0.08: '}
1264 . $self->_check_sqlt_message . q{'})
1265 if !$self->_check_sqlt_version;
1267 my $sqlt = SQL::Translator->new({
1269 add_drop_table => 1,
1271 foreach my $db (@$databases)
1274 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
1275 # $sqlt->parser_args({'DBIx::Class' => $schema);
1276 $sqlt = $self->configure_sqlt($sqlt, $db);
1277 $sqlt->data($schema);
1278 $sqlt->producer($db);
1281 my $filename = $schema->ddl_filename($db, $dir, $version);
1284 warn("$filename already exists, skipping $db");
1288 my $output = $sqlt->translate;
1291 warn("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
1294 if(!open($file, ">$filename"))
1296 $self->throw_exception("Can't open $filename for writing ($!)");
1299 print $file $output;
1304 require SQL::Translator::Diff;
1306 my $prefilename = $schema->ddl_filename($db, $dir, $preversion);
1307 # print "Previous version $prefilename\n";
1308 if(!-e $prefilename)
1310 warn("No previous schema file found ($prefilename)");
1313 #### We need to reparse the SQLite file we just wrote, so that
1314 ## Diff doesnt get all confoosed, and Diff is *very* confused.
1315 ## FIXME: rip Diff to pieces!
1316 # my $target_schema = $sqlt->schema;
1317 # unless ( $target_schema->name ) {
1318 # $target_schema->name( $filename );
1321 push @input, {file => $prefilename, parser => $db};
1322 push @input, {file => $filename, parser => $db};
1323 my ( $source_schema, $source_db, $target_schema, $target_db ) = map {
1324 my $file = $_->{'file'};
1325 my $parser = $_->{'parser'};
1327 my $t = SQL::Translator->new;
1330 $t->parser( $parser ) or die $t->error;
1331 my $out = $t->translate( $file ) or die $t->error;
1332 my $schema = $t->schema;
1333 unless ( $schema->name ) {
1334 $schema->name( $file );
1339 my $diff = SQL::Translator::Diff::schema_diff($source_schema, $db,
1340 $target_schema, $db,
1343 my $difffile = $schema->ddl_filename($db, $dir, $version, $preversion);
1344 print STDERR "Diff: $difffile: $db, $dir, $version, $preversion \n";
1347 warn("$difffile already exists, skipping");
1350 if(!open $file, ">$difffile")
1352 $self->throw_exception("Can't write to $difffile ($!)");
1361 sub configure_sqlt() {
1364 my $db = shift || $self->sqlt_type;
1365 if ($db eq 'PostgreSQL') {
1366 $tr->quote_table_names(0);
1367 $tr->quote_field_names(0);
1372 =head2 deployment_statements
1376 =item Arguments: $schema, $type, $version, $directory, $sqlt_args
1380 Returns the statements used by L</deploy> and L<DBIx::Class::Schema/deploy>.
1381 The database driver name is given by C<$type>, though the value from
1382 L</sqlt_type> is used if it is not specified.
1384 C<$directory> is used to return statements from files in a previously created
1385 L</create_ddl_dir> directory and is optional. The filenames are constructed
1386 from L<DBIx::Class::Schema/ddl_filename>, the schema name and the C<$version>.
1388 If no C<$directory> is specified then the statements are constructed on the
1389 fly using L<SQL::Translator> and C<$version> is ignored.
1391 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>.
1395 sub deployment_statements {
1396 my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
1397 # Need to be connected to get the correct sqlt_type
1398 $self->ensure_connected() unless $type;
1399 $type ||= $self->sqlt_type;
1400 $version ||= $schema->VERSION || '1.x';
1402 my $filename = $schema->ddl_filename($type, $dir, $version);
1406 open($file, "<$filename")
1407 or $self->throw_exception("Can't open $filename ($!)");
1410 return join('', @rows);
1413 $self->throw_exception(q{Can't deploy without SQL::Translator 0.08: '}
1414 . $self->_check_sqlt_message . q{'})
1415 if !$self->_check_sqlt_version;
1417 require SQL::Translator::Parser::DBIx::Class;
1418 eval qq{use SQL::Translator::Producer::${type}};
1419 $self->throw_exception($@) if $@;
1421 # sources needs to be a parser arg, but for simplicty allow at top level
1423 $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources}
1424 if exists $sqltargs->{sources};
1426 my $tr = SQL::Translator->new(%$sqltargs);
1427 SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
1428 return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
1435 my ($self, $schema, $type, $sqltargs, $dir) = @_;
1436 foreach my $statement ( $self->deployment_statements($schema, $type, undef, $dir, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
1437 foreach my $line ( split(";\n", $statement)) {
1438 next if($line =~ /^--/);
1440 # next if($line =~ /^DROP/m);
1441 next if($line =~ /^BEGIN TRANSACTION/m);
1442 next if($line =~ /^COMMIT/m);
1443 next if $line =~ /^\s+$/; # skip whitespace only
1444 $self->debugobj->query_start($line) if $self->debug;
1446 $self->dbh->do($line); # shouldn't be using ->dbh ?
1449 warn qq{$@ (running "${line}")};
1451 $self->debugobj->query_end($line) if $self->debug;
1456 =head2 datetime_parser
1458 Returns the datetime parser class
1462 sub datetime_parser {
1464 return $self->{datetime_parser} ||= do {
1465 $self->ensure_connected;
1466 $self->build_datetime_parser(@_);
1470 =head2 datetime_parser_type
1472 Defines (returns) the datetime parser class - currently hardwired to
1473 L<DateTime::Format::MySQL>
1477 sub datetime_parser_type { "DateTime::Format::MySQL"; }
1479 =head2 build_datetime_parser
1481 See L</datetime_parser>
1485 sub build_datetime_parser {
1487 my $type = $self->datetime_parser_type(@_);
1489 $self->throw_exception("Couldn't load ${type}: $@") if $@;
1494 my $_check_sqlt_version; # private
1495 my $_check_sqlt_message; # private
1496 sub _check_sqlt_version {
1497 return $_check_sqlt_version if defined $_check_sqlt_version;
1498 eval 'use SQL::Translator 0.08';
1499 $_check_sqlt_message = $@ ? $@ : '';
1500 $_check_sqlt_version = $@ ? 0 : 1;
1503 sub _check_sqlt_message {
1504 _check_sqlt_version if !defined $_check_sqlt_message;
1505 $_check_sqlt_message;
1511 return if !$self->_dbh;
1520 The module defines a set of methods within the DBIC::SQL::Abstract
1521 namespace. These build on L<SQL::Abstract::Limit> to provide the
1522 SQL query functions.
1524 The following methods are extended:-
1538 See L</connect_info> for details.
1539 For setting, this method is deprecated in favor of L</connect_info>.
1543 See L</connect_info> for details.
1544 For setting, this method is deprecated in favor of L</connect_info>.
1548 See L</connect_info> for details.
1549 For setting, this method is deprecated in favor of L</connect_info>.
1555 Matt S. Trout <mst@shadowcatsystems.co.uk>
1557 Andy Grundman <andy@hybridized.org>
1561 You may distribute this code under the same terms as Perl itself.