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;
13 use Scalar::Util 'blessed';
15 __PACKAGE__->mk_group_accessors('simple' =>
16 qw/_connect_info _dbi_connect_info _dbh _sql_maker _sql_maker_opts
17 _conn_pid _conn_tid disable_sth_caching cursor on_connect_do
23 package DBIC::SQL::Abstract; # Would merge upstream, but nate doesn't reply :(
25 use base qw/SQL::Abstract::Limit/;
27 # This prevents the caching of $dbh in S::A::L, I believe
29 my $self = shift->SUPER::new(@_);
31 # If limit_dialect is a ref (like a $dbh), go ahead and replace
32 # it with what it resolves to:
33 $self->{limit_dialect} = $self->_find_syntax($self->{limit_dialect})
34 if ref $self->{limit_dialect};
40 my ($self, $sql, $order, $rows, $offset ) = @_;
43 my $last = $rows + $offset;
44 my ( $order_by ) = $self->_order_by( $order );
49 SELECT Q1.*, ROW_NUMBER() OVER( ) AS ROW_NUM FROM (
54 WHERE ROW_NUM BETWEEN $offset AND $last
60 # While we're at it, this should make LIMIT queries more efficient,
61 # without digging into things too deeply
62 use Scalar::Util 'blessed';
64 my ($self, $syntax) = @_;
65 my $dbhname = blessed($syntax) ? $syntax->{Driver}{Name} : $syntax;
66 if(ref($self) && $dbhname && $dbhname eq 'DB2') {
67 return 'RowNumberOver';
70 $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
74 my ($self, $table, $fields, $where, $order, @rest) = @_;
75 $table = $self->_quote($table) unless ref($table);
76 local $self->{rownum_hack_count} = 1
77 if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
78 @rest = (-1) unless defined $rest[0];
79 die "LIMIT 0 Does Not Compute" if $rest[0] == 0;
80 # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
81 local $self->{having_bind} = [];
82 my ($sql, @ret) = $self->SUPER::select(
83 $table, $self->_recurse_fields($fields), $where, $order, @rest
85 return wantarray ? ($sql, @ret, @{$self->{having_bind}}) : $sql;
91 $table = $self->_quote($table) unless ref($table);
92 $self->SUPER::insert($table, @_);
98 $table = $self->_quote($table) unless ref($table);
99 $self->SUPER::update($table, @_);
105 $table = $self->_quote($table) unless ref($table);
106 $self->SUPER::delete($table, @_);
112 return $_[1].$self->_order_by($_[2]);
114 return $self->SUPER::_emulate_limit(@_);
118 sub _recurse_fields {
119 my ($self, $fields) = @_;
120 my $ref = ref $fields;
121 return $self->_quote($fields) unless $ref;
122 return $$fields if $ref eq 'SCALAR';
124 if ($ref eq 'ARRAY') {
125 return join(', ', map {
126 $self->_recurse_fields($_)
127 .(exists $self->{rownum_hack_count}
128 ? ' AS col'.$self->{rownum_hack_count}++
131 } elsif ($ref eq 'HASH') {
132 foreach my $func (keys %$fields) {
133 return $self->_sqlcase($func)
134 .'( '.$self->_recurse_fields($fields->{$func}).' )';
143 if (ref $_[0] eq 'HASH') {
144 if (defined $_[0]->{group_by}) {
145 $ret = $self->_sqlcase(' group by ')
146 .$self->_recurse_fields($_[0]->{group_by});
148 if (defined $_[0]->{having}) {
150 ($frag, @extra) = $self->_recurse_where($_[0]->{having});
151 push(@{$self->{having_bind}}, @extra);
152 $ret .= $self->_sqlcase(' having ').$frag;
154 if (defined $_[0]->{order_by}) {
155 $ret .= $self->_order_by($_[0]->{order_by});
157 } elsif (ref $_[0] eq 'SCALAR') {
158 $ret = $self->_sqlcase(' order by ').${ $_[0] };
159 } elsif (ref $_[0] eq 'ARRAY' && @{$_[0]}) {
160 my @order = @{+shift};
161 $ret = $self->_sqlcase(' order by ')
163 my $r = $self->_order_by($_, @_);
164 $r =~ s/^ ?ORDER BY //i;
168 $ret = $self->SUPER::_order_by(@_);
173 sub _order_directions {
174 my ($self, $order) = @_;
175 $order = $order->{order_by} if ref $order eq 'HASH';
176 return $self->SUPER::_order_directions($order);
180 my ($self, $from) = @_;
181 if (ref $from eq 'ARRAY') {
182 return $self->_recurse_from(@$from);
183 } elsif (ref $from eq 'HASH') {
184 return $self->_make_as($from);
186 return $from; # would love to quote here but _table ends up getting called
187 # twice during an ->select without a limit clause due to
188 # the way S::A::Limit->select works. should maybe consider
189 # bypassing this and doing S::A::select($self, ...) in
190 # our select method above. meantime, quoting shims have
191 # been added to select/insert/update/delete here
196 my ($self, $from, @join) = @_;
198 push(@sqlf, $self->_make_as($from));
199 foreach my $j (@join) {
202 # check whether a join type exists
203 my $join_clause = '';
204 my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
205 if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
206 $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
208 $join_clause = ' JOIN ';
210 push(@sqlf, $join_clause);
212 if (ref $to eq 'ARRAY') {
213 push(@sqlf, '(', $self->_recurse_from(@$to), ')');
215 push(@sqlf, $self->_make_as($to));
217 push(@sqlf, ' ON ', $self->_join_condition($on));
219 return join('', @sqlf);
223 my ($self, $from) = @_;
224 return join(' ', map { (ref $_ eq 'SCALAR' ? $$_ : $self->_quote($_)) }
225 reverse each %{$self->_skip_options($from)});
229 my ($self, $hash) = @_;
231 $clean_hash->{$_} = $hash->{$_}
232 for grep {!/^-/} keys %$hash;
236 sub _join_condition {
237 my ($self, $cond) = @_;
238 if (ref $cond eq 'HASH') {
243 # XXX no throw_exception() in this package and croak() fails with strange results
244 Carp::croak(ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
245 if ref($v) ne 'SCALAR';
249 my $x = '= '.$self->_quote($v); $j{$_} = \$x;
252 return scalar($self->_recurse_where(\%j));
253 } elsif (ref $cond eq 'ARRAY') {
254 return join(' OR ', map { $self->_join_condition($_) } @$cond);
256 die "Can't handle this yet!";
261 my ($self, $label) = @_;
262 return '' unless defined $label;
263 return "*" if $label eq '*';
264 return $label unless $self->{quote_char};
265 if(ref $self->{quote_char} eq "ARRAY"){
266 return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
267 if !defined $self->{name_sep};
268 my $sep = $self->{name_sep};
269 return join($self->{name_sep},
270 map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
271 split(/\Q$sep\E/,$label));
273 return $self->SUPER::_quote($label);
278 $self->{limit_dialect} = shift if @_;
279 return $self->{limit_dialect};
284 $self->{quote_char} = shift if @_;
285 return $self->{quote_char};
290 $self->{name_sep} = shift if @_;
291 return $self->{name_sep};
294 } # End of BEGIN block
298 DBIx::Class::Storage::DBI - DBI storage handler
304 This class represents the connection to an RDBMS via L<DBI>. See
305 L<DBIx::Class::Storage> for general information. This pod only
306 documents DBI-specific methods and behaviors.
313 my $new = shift->next::method(@_);
315 $new->cursor("DBIx::Class::Storage::DBI::Cursor");
316 $new->transaction_depth(0);
317 $new->_sql_maker_opts({});
318 $new->{_in_dbh_do} = 0;
319 $new->{_dbh_gen} = 0;
326 The arguments of C<connect_info> are always a single array reference.
328 This is normally accessed via L<DBIx::Class::Schema/connection>, which
329 encapsulates its argument list in an arrayref before calling
330 C<connect_info> here.
332 The arrayref can either contain the same set of arguments one would
333 normally pass to L<DBI/connect>, or a lone code reference which returns
334 a connected database handle. Please note that the L<DBI> docs
335 recommend that you always explicitly set C<AutoCommit> to either
336 C<0> or C<1>. L<DBIx::Class> further recommends that it be set
337 to C<1>, and that you perform transactions via our L</txn_do>
338 method. L<DBIx::Class> will set it to C<1> if you do not do explicitly
339 set it to zero. This is the default for most DBDs. See below for more
342 In either case, if the final argument in your connect_info happens
343 to be a hashref, C<connect_info> will look there for several
344 connection-specific options:
350 This can be set to an arrayref of literal sql statements, which will
351 be executed immediately after making the connection to the database
352 every time we [re-]connect.
354 =item disable_sth_caching
356 If set to a true value, this option will disable the caching of
357 statement handles via L<DBI/prepare_cached>.
361 Sets the limit dialect. This is useful for JDBC-bridge among others
362 where the remote SQL-dialect cannot be determined by the name of the
367 Specifies what characters to use to quote table and column names. If
368 you use this you will want to specify L<name_sep> as well.
370 quote_char expects either a single character, in which case is it is placed
371 on either side of the table/column, or an arrayref of length 2 in which case the
372 table/column name is placed between the elements.
374 For example under MySQL you'd use C<quote_char =E<gt> '`'>, and user SQL Server you'd
375 use C<quote_char =E<gt> [qw/[ ]/]>.
379 This only needs to be used in conjunction with L<quote_char>, and is used to
380 specify the charecter that seperates elements (schemas, tables, columns) from
381 each other. In most cases this is simply a C<.>.
385 These options can be mixed in with your other L<DBI> connection attributes,
386 or placed in a seperate hashref after all other normal L<DBI> connection
389 Every time C<connect_info> is invoked, any previous settings for
390 these options will be cleared before setting the new ones, regardless of
391 whether any options are specified in the new C<connect_info>.
393 Important note: DBIC expects the returned database handle provided by
394 a subref argument to have RaiseError set on it. If it doesn't, things
395 might not work very well, YMMV. If you don't use a subref, DBIC will
396 force this setting for you anyways. Setting HandleError to anything
397 other than simple exception object wrapper might cause problems too.
399 Another Important Note:
401 DBIC can do some wonderful magic with handling exceptions,
402 disconnections, and transactions when you use C<AutoCommit => 1>
403 combined with C<txn_do> for transaction support.
405 If you set C<AutoCommit => 0> in your connect info, then you are always
406 in an assumed transaction between commits, and you're telling us you'd
407 like to manage that manually. A lot of DBIC's magic protections
408 go away. We can't protect you from exceptions due to database
409 disconnects because we don't know anything about how to restart your
410 transactions. You're on your own for handling all sorts of exceptional
411 cases if you choose the C<AutoCommit => 0> path, just as you would
416 # Simple SQLite connection
417 ->connect_info([ 'dbi:SQLite:./foo.db' ]);
420 ->connect_info([ sub { DBI->connect(...) } ]);
422 # A bit more complicated
429 { quote_char => q{"}, name_sep => q{.} },
433 # Equivalent to the previous example
439 { AutoCommit => 1, quote_char => q{"}, name_sep => q{.} },
443 # Subref + DBIC-specific connection options
446 sub { DBI->connect(...) },
450 on_connect_do => ['SET search_path TO myschema,otherschema,public'],
451 disable_sth_caching => 1,
459 my ($self, $info_arg) = @_;
461 return $self->_connect_info if !$info_arg;
463 # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
464 # the new set of options
465 $self->_sql_maker(undef);
466 $self->_sql_maker_opts({});
467 $self->_connect_info($info_arg);
469 my $dbi_info = [@$info_arg]; # copy for DBI
470 my $last_info = $dbi_info->[-1];
471 if(ref $last_info eq 'HASH') {
472 for my $storage_opt (qw/on_connect_do disable_sth_caching/) {
473 if(my $value = delete $last_info->{$storage_opt}) {
474 $self->$storage_opt($value);
477 for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
478 if(my $opt_val = delete $last_info->{$sql_maker_opt}) {
479 $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
483 # Get rid of any trailing empty hashref
484 pop(@$dbi_info) if !keys %$last_info;
487 $self->_dbi_connect_info($dbi_info);
489 if(ref $dbi_info->[0] ne 'CODE') {
490 # Extend to 3 arguments with undefs, if necessary
491 while(scalar(@$dbi_info) < 3) { push(@$dbi_info, undef) }
493 # Complain if 4th argument is defined and is not a HASH
494 if(defined $dbi_info->[3] && ref $dbi_info->[3] ne 'HASH') {
495 warn "4th argument of DBI connect info is defined "
496 . " but is not a hashref!";
499 # Set AutoCommit to 1 if not specified manually
501 $dbi_info->[3] ||= {};
502 if(!defined $dbi_info->[3]->{AutoCommit}) {
503 $dbi_info->[3]->{AutoCommit} = 1;
508 $self->_connect_info;
513 This method is deprecated in favor of setting via L</connect_info>.
517 Arguments: $subref, @extra_coderef_args?
519 Execute the given subref using the new exception-based connection management.
521 The first two arguments will be the storage object that C<dbh_do> was called
522 on and a database handle to use. Any additional arguments will be passed
523 verbatim to the called subref as arguments 2 and onwards.
525 Using this (instead of $self->_dbh or $self->dbh) ensures correct
526 exception handling and reconnection (or failover in future subclasses).
528 Your subref should have no side-effects outside of the database, as
529 there is the potential for your subref to be partially double-executed
530 if the database connection was stale/dysfunctional.
534 my @stuff = $schema->storage->dbh_do(
536 my ($storage, $dbh, @cols) = @_;
537 my $cols = join(q{, }, @cols);
538 $dbh->selectrow_array("SELECT $cols FROM foo");
549 ref $coderef eq 'CODE' or $self->throw_exception
550 ('$coderef must be a CODE reference');
552 return $coderef->($self, $self->_dbh, @_) if $self->{_in_dbh_do}
553 || $self->{transaction_depth};
555 local $self->{_in_dbh_do} = 1;
558 my $want_array = wantarray;
561 $self->_verify_pid if $self->_dbh;
562 $self->_populate_dbh if !$self->_dbh;
564 @result = $coderef->($self, $self->_dbh, @_);
566 elsif(defined $want_array) {
567 $result[0] = $coderef->($self, $self->_dbh, @_);
570 $coderef->($self, $self->_dbh, @_);
575 if(!$exception) { return $want_array ? @result : $result[0] }
577 $self->throw_exception($exception) if $self->connected;
579 # We were not connected - reconnect and retry, but let any
580 # exception fall right through this time
581 $self->_populate_dbh;
582 $coderef->($self, $self->_dbh, @_);
585 # This is basically a blend of dbh_do above and DBIx::Class::Storage::txn_do.
586 # It also informs dbh_do to bypass itself while under the direction of txn_do,
587 # via $self->{_in_dbh_do} (this saves some redundant eval and errorcheck, etc)
592 ref $coderef eq 'CODE' or $self->throw_exception
593 ('$coderef must be a CODE reference');
595 local $self->{_in_dbh_do} = 1;
598 my $want_array = wantarray;
603 $self->_verify_pid if $self->_dbh;
604 $self->_populate_dbh if !$self->_dbh;
608 @result = $coderef->(@_);
610 elsif(defined $want_array) {
611 $result[0] = $coderef->(@_);
620 if(!$exception) { return $want_array ? @result : $result[0] }
622 if($tried++ > 0 || $self->connected) {
623 eval { $self->txn_rollback };
624 my $rollback_exception = $@;
625 if($rollback_exception) {
626 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
627 $self->throw_exception($exception) # propagate nested rollback
628 if $rollback_exception =~ /$exception_class/;
630 $self->throw_exception(
631 "Transaction aborted: ${exception}. "
632 . "Rollback failed: ${rollback_exception}"
635 $self->throw_exception($exception)
638 # We were not connected, and was first try - reconnect and retry
640 $self->_populate_dbh;
646 Our C<disconnect> method also performs a rollback first if the
647 database is not in C<AutoCommit> mode.
654 if( $self->connected ) {
655 $self->_dbh->rollback unless $self->_dbh->{AutoCommit};
656 $self->_dbh->disconnect;
665 if(my $dbh = $self->_dbh) {
666 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
674 return ($dbh->FETCH('Active') && $dbh->ping);
680 # handle pid changes correctly
681 # NOTE: assumes $self->_dbh is a valid $dbh
685 return if $self->_conn_pid == $$;
687 $self->_dbh->{InactiveDestroy} = 1;
694 sub ensure_connected {
697 unless ($self->connected) {
698 $self->_populate_dbh;
704 Returns the dbh - a data base handle of class L<DBI>.
711 $self->ensure_connected;
715 sub _sql_maker_args {
718 return ( bindtype=>'columns', limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
723 unless ($self->_sql_maker) {
724 $self->_sql_maker(new DBIC::SQL::Abstract( $self->_sql_maker_args ));
726 return $self->_sql_maker;
731 my @info = @{$self->_dbi_connect_info || []};
732 $self->_dbh($self->_connect(@info));
734 # Always set the transaction depth on connect, since
735 # there is no transaction in progress by definition
736 $self->{transaction_depth} = $self->_dbh->{AutoCommit} ? 0 : 1;
738 if(ref $self eq 'DBIx::Class::Storage::DBI') {
739 my $driver = $self->_dbh->{Driver}->{Name};
740 if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
741 bless $self, "DBIx::Class::Storage::DBI::${driver}";
742 $self->_rebless() if $self->can('_rebless');
746 # if on-connect sql statements are given execute them
747 foreach my $sql_statement (@{$self->on_connect_do || []}) {
748 $self->debugobj->query_start($sql_statement) if $self->debug();
749 $self->_dbh->do($sql_statement);
750 $self->debugobj->query_end($sql_statement) if $self->debug();
753 $self->_conn_pid($$);
754 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
758 my ($self, @info) = @_;
760 $self->throw_exception("You failed to provide any connection info")
763 my ($old_connect_via, $dbh);
765 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
766 $old_connect_via = $DBI::connect_via;
767 $DBI::connect_via = 'connect';
771 if(ref $info[0] eq 'CODE') {
775 $dbh = DBI->connect(@info);
776 $dbh->{RaiseError} = 1;
777 $dbh->{PrintError} = 0;
778 $dbh->{PrintWarn} = 0;
782 $DBI::connect_via = $old_connect_via if $old_connect_via;
785 $self->throw_exception("DBI Connection failed: " . ($@ || $DBI::errstr));
794 if($self->{transaction_depth}++ == 0) {
795 $self->debugobj->txn_begin()
797 # this isn't ->_dbh-> because
798 # we should reconnect on begin_work
799 # for AutoCommit users
800 $self->dbh->begin_work;
806 if ($self->{transaction_depth} == 1) {
807 my $dbh = $self->_dbh;
808 $self->debugobj->txn_commit()
811 $self->{transaction_depth} = 0
812 if $dbh->{AutoCommit};
814 elsif($self->{transaction_depth} > 1) {
815 $self->{transaction_depth}--
821 my $dbh = $self->_dbh;
824 $autocommit = $dbh->{AutoCommit};
825 if ($self->{transaction_depth} == 1) {
826 $self->debugobj->txn_rollback()
829 $self->{transaction_depth} = 0
832 elsif($self->{transaction_depth} > 1) {
833 $self->{transaction_depth}--;
836 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
841 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
842 $error =~ /$exception_class/ and $self->throw_exception($error);
843 # ensure that a failed rollback resets the transaction depth
844 $self->{transaction_depth} = $autocommit ? 0 : 1;
845 $self->throw_exception($error);
849 # This used to be the top-half of _execute. It was split out to make it
850 # easier to override in NoBindVars without duping the rest. It takes up
851 # all of _execute's args, and emits $sql, @bind.
852 sub _prep_for_execute {
853 my ($self, $op, $extra_bind, $ident, @args) = @_;
855 my ($sql, @bind) = $self->sql_maker->$op($ident, @args);
857 map { ref $_ eq 'ARRAY' ? $_ : [ '!!dummy', $_ ] } @$extra_bind)
859 @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
861 return ($sql, @bind);
865 my ($self, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
867 if( blessed($ident) && $ident->isa("DBIx::Class::ResultSource") ) {
868 $ident = $ident->from();
871 my ($sql, @bind) = $self->sql_maker->$op($ident, @args);
873 map { ref $_ eq 'ARRAY' ? $_ : [ '!!dummy', $_ ] } @$extra_bind)
877 map { defined ($_ && $_->[1]) ? qq{'$_->[1]'} : q{'NULL'} } @bind;
878 $self->debugobj->query_start($sql, @debug_bind);
883 $sth = eval { $self->sth($sql,$op) };
886 $self->throw_exception(
887 'no sth generated via sql (' . ($@ || $self->_dbh->errstr) . "): $sql"
894 my $placeholder_index = 1;
896 foreach my $bound (@bind) {
899 my($column_name, @data) = @$bound;
901 if( $bind_attributes ) {
902 $attributes = $bind_attributes->{$column_name}
903 if defined $bind_attributes->{$column_name};
906 foreach my $data (@data)
908 $data = ref $data ? ''.$data : $data; # stringify args
910 $sth->bind_param($placeholder_index, $data, $attributes);
911 $placeholder_index++;
918 $self->throw_exception("Error executing '$sql': ".($@ || $sth->errstr))
920 $self->_populate_dbh;
925 $self->throw_exception("'$sql' did not generate a statement.");
927 } # While(1) to retry if disconencted
931 map { defined ($_ && $_->[1]) ? qq{'$_->[1]'} : q{'NULL'} } @bind;
932 $self->debugobj->query_end($sql, @debug_bind);
934 return (wantarray ? ($rv, $sth, @bind) : $rv);
938 my ($self, $source, $to_insert) = @_;
940 my $ident = $source->from;
941 my $bind_attributes = $self->source_bind_attributes($source);
943 $self->throw_exception(
944 "Couldn't insert ".join(', ',
945 map "$_ => $to_insert->{$_}", keys %$to_insert
947 ) unless ($self->_execute('insert' => [], $source, $bind_attributes, $to_insert));
951 ## Still not quite perfect, and EXPERIMENTAL
952 ## Currently it is assumed that all values passed will be "normal", i.e. not
953 ## scalar refs, or at least, all the same type as the first set, the statement is
954 ## only prepped once.
956 my ($self, $source, $cols, $data) = @_;
958 my $table = $source->from;
959 @colvalues{@$cols} = (0..$#$cols);
960 my ($sql, @bind) = $self->sql_maker->insert($table, \%colvalues);
963 my @debug_bind = map { defined $_->[1] ? qq{$_->[1]} : q{'NULL'} } @bind;
964 $self->debugobj->query_start($sql, @debug_bind);
966 my $sth = $self->sth($sql);
968 # @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
972 ## This must be an arrayref, else nothing works!
974 my $tuple_status = [];
977 ##print STDERR Dumper( $data, $sql, [@bind] );
983 ## Get the bind_attributes, if any exist
984 my $bind_attributes = $self->source_bind_attributes($source);
986 ## Bind the values and execute
989 my $placeholder_index = 1;
991 foreach my $bound (@bind) {
994 my ($column_name, $data_index) = @$bound;
996 if( $bind_attributes ) {
997 $attributes = $bind_attributes->{$column_name}
998 if defined $bind_attributes->{$column_name};
1001 my @data = map { $_->[$data_index] } @$data;
1003 $sth->bind_param_array( $placeholder_index, [@data], $attributes );
1004 $placeholder_index++;
1006 $sth->execute_array( {ArrayTupleStatus => $tuple_status} );
1010 if ($@ || !defined $rv) {
1012 foreach my $tuple (@$tuple_status) {
1013 $errors .= "\n" . $tuple->[1] if(ref $tuple);
1015 $self->throw_exception("Error executing '$sql': ".($@ || $errors));
1018 $self->throw_exception("'$sql' did not generate a statement.");
1021 my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind;
1022 $self->debugobj->query_end($sql, @debug_bind);
1024 return (wantarray ? ($rv, $sth, @bind) : $rv);
1028 my $self = shift @_;
1029 my $source = shift @_;
1030 my $bind_attributes = $self->source_bind_attributes($source);
1032 return $self->_execute('update' => [], $source, $bind_attributes, @_);
1037 my $self = shift @_;
1038 my $source = shift @_;
1040 my $bind_attrs = {}; ## If ever it's needed...
1042 return $self->_execute('delete' => [], $source, $bind_attrs, @_);
1046 my ($self, $ident, $select, $condition, $attrs) = @_;
1047 my $order = $attrs->{order_by};
1048 if (ref $condition eq 'SCALAR') {
1049 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
1051 if (exists $attrs->{group_by} || $attrs->{having}) {
1053 group_by => $attrs->{group_by},
1054 having => $attrs->{having},
1055 ($order ? (order_by => $order) : ())
1058 my $bind_attrs = {}; ## Future support
1059 my @args = ('select', $attrs->{bind}, $ident, $bind_attrs, $select, $condition, $order);
1060 if ($attrs->{software_limit} ||
1061 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
1062 $attrs->{software_limit} = 1;
1064 $self->throw_exception("rows attribute must be positive if present")
1065 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
1066 push @args, $attrs->{rows}, $attrs->{offset};
1068 return $self->_execute(@args);
1071 sub source_bind_attributes {
1072 my ($self, $source) = @_;
1074 my $bind_attributes;
1075 foreach my $column ($source->columns) {
1077 my $data_type = $source->column_info($column)->{data_type} || '';
1078 $bind_attributes->{$column} = $self->bind_attribute_by_data_type($data_type)
1082 return $bind_attributes;
1089 =item Arguments: $ident, $select, $condition, $attrs
1093 Handle a SQL select statement.
1099 my ($ident, $select, $condition, $attrs) = @_;
1100 return $self->cursor->new($self, \@_, $attrs);
1105 my ($rv, $sth, @bind) = $self->_select(@_);
1106 my @row = $sth->fetchrow_array;
1107 # Need to call finish() to work round broken DBDs
1116 =item Arguments: $sql
1120 Returns a L<DBI> sth (statement handle) for the supplied SQL.
1125 my ($self, $dbh, $sql) = @_;
1127 # 3 is the if_active parameter which avoids active sth re-use
1128 my $sth = $self->disable_sth_caching
1129 ? $dbh->prepare($sql)
1130 : $dbh->prepare_cached($sql, {}, 3);
1132 $self->throw_exception(
1133 'no sth generated via sql (' . ($@ || $dbh->errstr) . "): $sql"
1140 my ($self, $sql) = @_;
1141 $self->dbh_do($self->can('_dbh_sth'), $sql);
1144 sub _dbh_columns_info_for {
1145 my ($self, $dbh, $table) = @_;
1147 if ($dbh->can('column_info')) {
1150 my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
1151 my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
1153 while ( my $info = $sth->fetchrow_hashref() ){
1155 $column_info{data_type} = $info->{TYPE_NAME};
1156 $column_info{size} = $info->{COLUMN_SIZE};
1157 $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
1158 $column_info{default_value} = $info->{COLUMN_DEF};
1159 my $col_name = $info->{COLUMN_NAME};
1160 $col_name =~ s/^\"(.*)\"$/$1/;
1162 $result{$col_name} = \%column_info;
1165 return \%result if !$@ && scalar keys %result;
1169 my $sth = $dbh->prepare($self->sql_maker->select($table, undef, \'1 = 0'));
1171 my @columns = @{$sth->{NAME_lc}};
1172 for my $i ( 0 .. $#columns ){
1174 $column_info{data_type} = $sth->{TYPE}->[$i];
1175 $column_info{size} = $sth->{PRECISION}->[$i];
1176 $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
1178 if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
1179 $column_info{data_type} = $1;
1180 $column_info{size} = $2;
1183 $result{$columns[$i]} = \%column_info;
1187 foreach my $col (keys %result) {
1188 my $colinfo = $result{$col};
1189 my $type_num = $colinfo->{data_type};
1191 if(defined $type_num && $dbh->can('type_info')) {
1192 my $type_info = $dbh->type_info($type_num);
1193 $type_name = $type_info->{TYPE_NAME} if $type_info;
1194 $colinfo->{data_type} = $type_name if $type_name;
1201 sub columns_info_for {
1202 my ($self, $table) = @_;
1203 $self->dbh_do($self->can('_dbh_columns_info_for'), $table);
1206 =head2 last_insert_id
1208 Return the row id of the last insert.
1212 sub _dbh_last_insert_id {
1213 my ($self, $dbh, $source, $col) = @_;
1214 # XXX This is a SQLite-ism as a default... is there a DBI-generic way?
1215 $dbh->func('last_insert_rowid');
1218 sub last_insert_id {
1220 $self->dbh_do($self->can('_dbh_last_insert_id'), @_);
1225 Returns the database driver name.
1229 sub sqlt_type { shift->dbh->{Driver}->{Name} }
1231 =head2 bind_attribute_by_data_type
1233 Given a datatype from column info, returns a database specific bind attribute for
1234 $dbh->bind_param($val,$attribute) or nothing if we will let the database planner
1237 Generally only needed for special case column types, like bytea in postgres.
1241 sub bind_attribute_by_data_type {
1245 =head2 create_ddl_dir (EXPERIMENTAL)
1249 =item Arguments: $schema \@databases, $version, $directory, $preversion, $sqlt_args
1253 Creates a SQL file based on the Schema, for each of the specified
1254 database types, in the given directory.
1256 Note that this feature is currently EXPERIMENTAL and may not work correctly
1257 across all databases, or fully handle complex relationships.
1263 my ($self, $schema, $databases, $version, $dir, $preversion, $sqltargs) = @_;
1265 if(!$dir || !-d $dir)
1267 warn "No directory given, using ./\n";
1270 $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
1271 $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
1272 $version ||= $schema->VERSION || '1.x';
1273 $sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} };
1275 eval "use SQL::Translator";
1276 $self->throw_exception("Can't create a ddl file without SQL::Translator: $@") if $@;
1278 my $sqlt = SQL::Translator->new({
1280 add_drop_table => 1,
1282 foreach my $db (@$databases)
1285 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
1286 # $sqlt->parser_args({'DBIx::Class' => $schema);
1287 $sqlt = $self->configure_sqlt($sqlt, $db);
1288 $sqlt->data($schema);
1289 $sqlt->producer($db);
1292 my $filename = $schema->ddl_filename($db, $dir, $version);
1295 warn("$filename already exists, skipping $db");
1299 my $output = $sqlt->translate;
1302 warn("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
1305 if(!open($file, ">$filename"))
1307 $self->throw_exception("Can't open $filename for writing ($!)");
1310 print $file $output;
1315 eval "use SQL::Translator::Diff";
1318 warn("Can't diff versions without SQL::Translator::Diff: $@");
1322 my $prefilename = $schema->ddl_filename($db, $dir, $preversion);
1323 # print "Previous version $prefilename\n";
1324 if(!-e $prefilename)
1326 warn("No previous schema file found ($prefilename)");
1329 #### We need to reparse the SQLite file we just wrote, so that
1330 ## Diff doesnt get all confoosed, and Diff is *very* confused.
1331 ## FIXME: rip Diff to pieces!
1332 # my $target_schema = $sqlt->schema;
1333 # unless ( $target_schema->name ) {
1334 # $target_schema->name( $filename );
1337 push @input, {file => $prefilename, parser => $db};
1338 push @input, {file => $filename, parser => $db};
1339 my ( $source_schema, $source_db, $target_schema, $target_db ) = map {
1340 my $file = $_->{'file'};
1341 my $parser = $_->{'parser'};
1343 my $t = SQL::Translator->new;
1346 $t->parser( $parser ) or die $t->error;
1347 my $out = $t->translate( $file ) or die $t->error;
1348 my $schema = $t->schema;
1349 unless ( $schema->name ) {
1350 $schema->name( $file );
1355 my $diff = SQL::Translator::Diff::schema_diff($source_schema, $db,
1356 $target_schema, $db,
1359 my $difffile = $schema->ddl_filename($db, $dir, $version, $preversion);
1360 print STDERR "Diff: $difffile: $db, $dir, $version, $preversion \n";
1363 warn("$difffile already exists, skipping");
1366 if(!open $file, ">$difffile")
1368 $self->throw_exception("Can't write to $difffile ($!)");
1377 sub configure_sqlt() {
1380 my $db = shift || $self->sqlt_type;
1381 if ($db eq 'PostgreSQL') {
1382 $tr->quote_table_names(0);
1383 $tr->quote_field_names(0);
1388 =head2 deployment_statements
1392 =item Arguments: $schema, $type, $version, $directory, $sqlt_args
1396 Returns the statements used by L</deploy> and L<DBIx::Class::Schema/deploy>.
1397 The database driver name is given by C<$type>, though the value from
1398 L</sqlt_type> is used if it is not specified.
1400 C<$directory> is used to return statements from files in a previously created
1401 L</create_ddl_dir> directory and is optional. The filenames are constructed
1402 from L<DBIx::Class::Schema/ddl_filename>, the schema name and the C<$version>.
1404 If no C<$directory> is specified then the statements are constructed on the
1405 fly using L<SQL::Translator> and C<$version> is ignored.
1407 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>.
1411 sub deployment_statements {
1412 my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
1413 # Need to be connected to get the correct sqlt_type
1414 $self->ensure_connected() unless $type;
1415 $type ||= $self->sqlt_type;
1416 $version ||= $schema->VERSION || '1.x';
1418 my $filename = $schema->ddl_filename($type, $dir, $version);
1422 open($file, "<$filename")
1423 or $self->throw_exception("Can't open $filename ($!)");
1426 return join('', @rows);
1429 eval "use SQL::Translator";
1432 eval "use SQL::Translator::Parser::DBIx::Class;";
1433 $self->throw_exception($@) if $@;
1434 eval "use SQL::Translator::Producer::${type};";
1435 $self->throw_exception($@) if $@;
1437 # sources needs to be a parser arg, but for simplicty allow at top level
1439 $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources}
1440 if exists $sqltargs->{sources};
1442 my $tr = SQL::Translator->new(%$sqltargs);
1443 SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
1444 return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
1447 $self->throw_exception("No SQL::Translator, and no Schema file found, aborting deploy");
1453 my ($self, $schema, $type, $sqltargs, $dir) = @_;
1454 foreach my $statement ( $self->deployment_statements($schema, $type, undef, $dir, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
1455 for ( split(";\n", $statement)) {
1456 next if($_ =~ /^--/);
1458 # next if($_ =~ /^DROP/m);
1459 next if($_ =~ /^BEGIN TRANSACTION/m);
1460 next if($_ =~ /^COMMIT/m);
1461 next if $_ =~ /^\s+$/; # skip whitespace only
1462 $self->debugobj->query_start($_) if $self->debug;
1463 $self->dbh->do($_) or warn "SQL was:\n $_"; # XXX exceptions?
1464 $self->debugobj->query_end($_) if $self->debug;
1469 =head2 datetime_parser
1471 Returns the datetime parser class
1475 sub datetime_parser {
1477 return $self->{datetime_parser} ||= $self->build_datetime_parser(@_);
1480 =head2 datetime_parser_type
1482 Defines (returns) the datetime parser class - currently hardwired to
1483 L<DateTime::Format::MySQL>
1487 sub datetime_parser_type { "DateTime::Format::MySQL"; }
1489 =head2 build_datetime_parser
1491 See L</datetime_parser>
1495 sub build_datetime_parser {
1497 my $type = $self->datetime_parser_type(@_);
1499 $self->throw_exception("Couldn't load ${type}: $@") if $@;
1505 return if !$self->_dbh;
1514 The module defines a set of methods within the DBIC::SQL::Abstract
1515 namespace. These build on L<SQL::Abstract::Limit> to provide the
1516 SQL query functions.
1518 The following methods are extended:-
1532 See L</connect_info> for details.
1533 For setting, this method is deprecated in favor of L</connect_info>.
1537 See L</connect_info> for details.
1538 For setting, this method is deprecated in favor of L</connect_info>.
1542 See L</connect_info> for details.
1543 For setting, this method is deprecated in favor of L</connect_info>.
1549 Matt S. Trout <mst@shadowcatsystems.co.uk>
1551 Andy Grundman <andy@hybridized.org>
1555 You may distribute this code under the same terms as Perl itself.