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 transaction_depth unsafe/
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) = @_;
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}
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});
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 of literal sql statements, which will
350 be executed immediately after making the connection to the database
351 every time we [re-]connect.
353 =item disable_sth_caching
355 If set to a true value, this option will disable the caching of
356 statement handles via L<DBI/prepare_cached>.
360 Sets the limit dialect. This is useful for JDBC-bridge among others
361 where the remote SQL-dialect cannot be determined by the name of the
366 Specifies what characters to use to quote table and column names. If
367 you use this you will want to specify L<name_sep> as well.
369 quote_char expects either a single character, in which case is it is placed
370 on either side of the table/column, or an arrayref of length 2 in which case the
371 table/column name is placed between the elements.
373 For example under MySQL you'd use C<quote_char =E<gt> '`'>, and user SQL Server you'd
374 use C<quote_char =E<gt> [qw/[ ]/]>.
378 This only needs to be used in conjunction with L<quote_char>, and is used to
379 specify the charecter that seperates elements (schemas, tables, columns) from
380 each other. In most cases this is simply a C<.>.
384 This Storage driver normally installs its own C<HandleError>, sets
385 C<RaiseError> on, and sets C<PrintError> off on all database handles,
386 including those supplied by a coderef. It does this so that it can
387 have consistent and useful error behavior.
389 If you set this option to a true value, Storage will not do its usual
390 modifications to the database handle's C<RaiseError>, C<PrintError>, and
391 C<HandleError> attributes, and instead relies on the settings in your
392 connect_info DBI options (or the values you set in your connection
393 coderef, in the case that you are connecting via coderef).
395 Note that your custom settings can cause Storage to malfunction,
396 especially if you set a C<HandleError> handler that suppresses exceptions
397 and/or disable C<RaiseError>.
401 These options can be mixed in with your other L<DBI> connection attributes,
402 or placed in a seperate hashref after all other normal L<DBI> connection
405 Every time C<connect_info> is invoked, any previous settings for
406 these options will be cleared before setting the new ones, regardless of
407 whether any options are specified in the new C<connect_info>.
409 Another Important Note:
411 DBIC can do some wonderful magic with handling exceptions,
412 disconnections, and transactions when you use C<AutoCommit => 1>
413 combined with C<txn_do> for transaction support.
415 If you set C<AutoCommit => 0> in your connect info, then you are always
416 in an assumed transaction between commits, and you're telling us you'd
417 like to manage that manually. A lot of DBIC's magic protections
418 go away. We can't protect you from exceptions due to database
419 disconnects because we don't know anything about how to restart your
420 transactions. You're on your own for handling all sorts of exceptional
421 cases if you choose the C<AutoCommit => 0> path, just as you would
426 # Simple SQLite connection
427 ->connect_info([ 'dbi:SQLite:./foo.db' ]);
430 ->connect_info([ sub { DBI->connect(...) } ]);
432 # A bit more complicated
439 { quote_char => q{"}, name_sep => q{.} },
443 # Equivalent to the previous example
449 { AutoCommit => 1, quote_char => q{"}, name_sep => q{.} },
453 # Subref + DBIC-specific connection options
456 sub { DBI->connect(...) },
460 on_connect_do => ['SET search_path TO myschema,otherschema,public'],
461 disable_sth_caching => 1,
469 my ($self, $info_arg) = @_;
471 return $self->_connect_info if !$info_arg;
473 # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
474 # the new set of options
475 $self->_sql_maker(undef);
476 $self->_sql_maker_opts({});
477 $self->_connect_info([@$info_arg]); # copy for _connect_info
479 my $dbi_info = [@$info_arg]; # copy for _dbi_connect_info
481 my $last_info = $dbi_info->[-1];
482 if(ref $last_info eq 'HASH') {
483 for my $storage_opt (qw/on_connect_do disable_sth_caching unsafe/) {
484 if(my $value = delete $last_info->{$storage_opt}) {
485 $self->$storage_opt($value);
488 for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
489 if(my $opt_val = delete $last_info->{$sql_maker_opt}) {
490 $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
494 # Get rid of any trailing empty hashref
495 pop(@$dbi_info) if !keys %$last_info;
497 $self->_dbi_connect_info($dbi_info);
499 $self->_connect_info;
504 This method is deprecated in favor of setting via L</connect_info>.
508 Arguments: $subref, @extra_coderef_args?
510 Execute the given subref using the new exception-based connection management.
512 The first two arguments will be the storage object that C<dbh_do> was called
513 on and a database handle to use. Any additional arguments will be passed
514 verbatim to the called subref as arguments 2 and onwards.
516 Using this (instead of $self->_dbh or $self->dbh) ensures correct
517 exception handling and reconnection (or failover in future subclasses).
519 Your subref should have no side-effects outside of the database, as
520 there is the potential for your subref to be partially double-executed
521 if the database connection was stale/dysfunctional.
525 my @stuff = $schema->storage->dbh_do(
527 my ($storage, $dbh, @cols) = @_;
528 my $cols = join(q{, }, @cols);
529 $dbh->selectrow_array("SELECT $cols FROM foo");
540 ref $coderef eq 'CODE' or $self->throw_exception
541 ('$coderef must be a CODE reference');
543 return $coderef->($self, $self->_dbh, @_) if $self->{_in_dbh_do}
544 || $self->{transaction_depth};
546 local $self->{_in_dbh_do} = 1;
549 my $want_array = wantarray;
552 $self->_verify_pid if $self->_dbh;
553 $self->_populate_dbh if !$self->_dbh;
555 @result = $coderef->($self, $self->_dbh, @_);
557 elsif(defined $want_array) {
558 $result[0] = $coderef->($self, $self->_dbh, @_);
561 $coderef->($self, $self->_dbh, @_);
566 if(!$exception) { return $want_array ? @result : $result[0] }
568 $self->throw_exception($exception) if $self->connected;
570 # We were not connected - reconnect and retry, but let any
571 # exception fall right through this time
572 $self->_populate_dbh;
573 $coderef->($self, $self->_dbh, @_);
576 # This is basically a blend of dbh_do above and DBIx::Class::Storage::txn_do.
577 # It also informs dbh_do to bypass itself while under the direction of txn_do,
578 # via $self->{_in_dbh_do} (this saves some redundant eval and errorcheck, etc)
583 ref $coderef eq 'CODE' or $self->throw_exception
584 ('$coderef must be a CODE reference');
586 local $self->{_in_dbh_do} = 1;
589 my $want_array = wantarray;
594 $self->_verify_pid if $self->_dbh;
595 $self->_populate_dbh if !$self->_dbh;
599 @result = $coderef->(@_);
601 elsif(defined $want_array) {
602 $result[0] = $coderef->(@_);
611 if(!$exception) { return $want_array ? @result : $result[0] }
613 if($tried++ > 0 || $self->connected) {
614 eval { $self->txn_rollback };
615 my $rollback_exception = $@;
616 if($rollback_exception) {
617 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
618 $self->throw_exception($exception) # propagate nested rollback
619 if $rollback_exception =~ /$exception_class/;
621 $self->throw_exception(
622 "Transaction aborted: ${exception}. "
623 . "Rollback failed: ${rollback_exception}"
626 $self->throw_exception($exception)
629 # We were not connected, and was first try - reconnect and retry
631 $self->_populate_dbh;
637 Our C<disconnect> method also performs a rollback first if the
638 database is not in C<AutoCommit> mode.
645 if( $self->connected ) {
646 $self->_dbh->rollback unless $self->_dbh->{AutoCommit};
647 $self->_dbh->disconnect;
656 if(my $dbh = $self->_dbh) {
657 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
665 return ($dbh->FETCH('Active') && $dbh->ping);
671 # handle pid changes correctly
672 # NOTE: assumes $self->_dbh is a valid $dbh
676 return if $self->_conn_pid == $$;
678 $self->_dbh->{InactiveDestroy} = 1;
685 sub ensure_connected {
688 unless ($self->connected) {
689 $self->_populate_dbh;
695 Returns the dbh - a data base handle of class L<DBI>.
702 $self->ensure_connected;
706 sub _sql_maker_args {
709 return ( bindtype=>'columns', limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
714 unless ($self->_sql_maker) {
715 $self->_sql_maker(new DBIC::SQL::Abstract( $self->_sql_maker_args ));
717 return $self->_sql_maker;
722 my @info = @{$self->_dbi_connect_info || []};
723 $self->_dbh($self->_connect(@info));
725 # Always set the transaction depth on connect, since
726 # there is no transaction in progress by definition
727 $self->{transaction_depth} = $self->_dbh->{AutoCommit} ? 0 : 1;
729 if(ref $self eq 'DBIx::Class::Storage::DBI') {
730 my $driver = $self->_dbh->{Driver}->{Name};
731 if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
732 bless $self, "DBIx::Class::Storage::DBI::${driver}";
733 $self->_rebless() if $self->can('_rebless');
737 # if on-connect sql statements are given execute them
738 foreach my $sql_statement (@{$self->on_connect_do || []}) {
739 $self->debugobj->query_start($sql_statement) if $self->debug();
740 $self->_dbh->do($sql_statement);
741 $self->debugobj->query_end($sql_statement) if $self->debug();
744 $self->_conn_pid($$);
745 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
749 my ($self, @info) = @_;
751 $self->throw_exception("You failed to provide any connection info")
754 my ($old_connect_via, $dbh);
756 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
757 $old_connect_via = $DBI::connect_via;
758 $DBI::connect_via = 'connect';
762 if(ref $info[0] eq 'CODE') {
766 $dbh = DBI->connect(@info);
770 my $weak_self = $self;
772 $dbh->{HandleError} = sub {
773 $weak_self->throw_exception("DBI Exception: $_[0]")
775 $dbh->{RaiseError} = 1;
776 $dbh->{PrintError} = 0;
780 $DBI::connect_via = $old_connect_via if $old_connect_via;
782 $self->throw_exception("DBI Connection failed: " . ($@||$DBI::errstr))
791 if($self->{transaction_depth}++ == 0) {
792 $self->debugobj->txn_begin()
794 # this isn't ->_dbh-> because
795 # we should reconnect on begin_work
796 # for AutoCommit users
797 $self->dbh->begin_work;
803 if ($self->{transaction_depth} == 1) {
804 my $dbh = $self->_dbh;
805 $self->debugobj->txn_commit()
808 $self->{transaction_depth} = 0
809 if $dbh->{AutoCommit};
811 elsif($self->{transaction_depth} > 1) {
812 $self->{transaction_depth}--
818 my $dbh = $self->_dbh;
821 $autocommit = $dbh->{AutoCommit};
822 if ($self->{transaction_depth} == 1) {
823 $self->debugobj->txn_rollback()
826 $self->{transaction_depth} = 0
829 elsif($self->{transaction_depth} > 1) {
830 $self->{transaction_depth}--;
833 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
838 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
839 $error =~ /$exception_class/ and $self->throw_exception($error);
840 # ensure that a failed rollback resets the transaction depth
841 $self->{transaction_depth} = $autocommit ? 0 : 1;
842 $self->throw_exception($error);
846 # This used to be the top-half of _execute. It was split out to make it
847 # easier to override in NoBindVars without duping the rest. It takes up
848 # all of _execute's args, and emits $sql, @bind.
849 sub _prep_for_execute {
850 my ($self, $op, $extra_bind, $ident, $args) = @_;
852 my ($sql, @bind) = $self->sql_maker->$op($ident, @$args);
854 map { ref $_ eq 'ARRAY' ? $_ : [ '!!dummy', $_ ] } @$extra_bind)
857 return ($sql, \@bind);
861 my ($self, $dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
863 if( blessed($ident) && $ident->isa("DBIx::Class::ResultSource") ) {
864 $ident = $ident->from();
867 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
871 map { defined ($_ && $_->[1]) ? qq{'$_->[1]'} : q{'NULL'} } @$bind;
872 $self->debugobj->query_start($sql, @debug_bind);
875 my $sth = $self->sth($sql,$op);
877 my $placeholder_index = 1;
879 foreach my $bound (@$bind) {
881 my($column_name, @data) = @$bound;
883 if ($bind_attributes) {
884 $attributes = $bind_attributes->{$column_name}
885 if defined $bind_attributes->{$column_name};
888 foreach my $data (@data) {
889 $data = ref $data ? ''.$data : $data; # stringify args
891 $sth->bind_param($placeholder_index, $data, $attributes);
892 $placeholder_index++;
896 # Can this fail without throwing an exception anyways???
897 my $rv = $sth->execute();
898 $self->throw_exception($sth->errstr) if !$rv;
902 map { defined ($_ && $_->[1]) ? qq{'$_->[1]'} : q{'NULL'} } @$bind;
903 $self->debugobj->query_end($sql, @debug_bind);
906 return (wantarray ? ($rv, $sth, @$bind) : $rv);
911 $self->dbh_do($self->can('_dbh_execute'), @_)
915 my ($self, $source, $to_insert) = @_;
917 my $ident = $source->from;
918 my $bind_attributes = $self->source_bind_attributes($source);
920 $self->_execute('insert' => [], $source, $bind_attributes, $to_insert);
925 ## Still not quite perfect, and EXPERIMENTAL
926 ## Currently it is assumed that all values passed will be "normal", i.e. not
927 ## scalar refs, or at least, all the same type as the first set, the statement is
928 ## only prepped once.
930 my ($self, $source, $cols, $data) = @_;
932 my $table = $source->from;
933 @colvalues{@$cols} = (0..$#$cols);
934 my ($sql, @bind) = $self->sql_maker->insert($table, \%colvalues);
937 my @debug_bind = map { defined $_->[1] ? qq{$_->[1]} : q{'NULL'} } @bind;
938 $self->debugobj->query_start($sql, @debug_bind);
940 my $sth = $self->sth($sql);
942 # @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
944 ## This must be an arrayref, else nothing works!
946 my $tuple_status = [];
949 ##print STDERR Dumper( $data, $sql, [@bind] );
953 ## Get the bind_attributes, if any exist
954 my $bind_attributes = $self->source_bind_attributes($source);
956 ## Bind the values and execute
957 my $placeholder_index = 1;
959 foreach my $bound (@bind) {
962 my ($column_name, $data_index) = @$bound;
964 if( $bind_attributes ) {
965 $attributes = $bind_attributes->{$column_name}
966 if defined $bind_attributes->{$column_name};
969 my @data = map { $_->[$data_index] } @$data;
971 $sth->bind_param_array( $placeholder_index, [@data], $attributes );
972 $placeholder_index++;
974 my $rv = $sth->execute_array({ArrayTupleStatus => $tuple_status});
975 $self->throw_exception($sth->errstr) if !$rv;
978 my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind;
979 $self->debugobj->query_end($sql, @debug_bind);
981 return (wantarray ? ($rv, $sth, @bind) : $rv);
986 my $source = shift @_;
987 my $bind_attributes = $self->source_bind_attributes($source);
989 return $self->_execute('update' => [], $source, $bind_attributes, @_);
995 my $source = shift @_;
997 my $bind_attrs = {}; ## If ever it's needed...
999 return $self->_execute('delete' => [], $source, $bind_attrs, @_);
1003 my ($self, $ident, $select, $condition, $attrs) = @_;
1004 my $order = $attrs->{order_by};
1005 if (ref $condition eq 'SCALAR') {
1006 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
1008 if (exists $attrs->{group_by} || $attrs->{having}) {
1010 group_by => $attrs->{group_by},
1011 having => $attrs->{having},
1012 ($order ? (order_by => $order) : ())
1015 my $bind_attrs = {}; ## Future support
1016 my @args = ('select', $attrs->{bind}, $ident, $bind_attrs, $select, $condition, $order);
1017 if ($attrs->{software_limit} ||
1018 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
1019 $attrs->{software_limit} = 1;
1021 $self->throw_exception("rows attribute must be positive if present")
1022 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
1023 push @args, $attrs->{rows}, $attrs->{offset};
1025 return $self->_execute(@args);
1028 sub source_bind_attributes {
1029 my ($self, $source) = @_;
1031 my $bind_attributes;
1032 foreach my $column ($source->columns) {
1034 my $data_type = $source->column_info($column)->{data_type} || '';
1035 $bind_attributes->{$column} = $self->bind_attribute_by_data_type($data_type)
1039 return $bind_attributes;
1046 =item Arguments: $ident, $select, $condition, $attrs
1050 Handle a SQL select statement.
1056 my ($ident, $select, $condition, $attrs) = @_;
1057 return $self->cursor->new($self, \@_, $attrs);
1062 my ($rv, $sth, @bind) = $self->_select(@_);
1063 my @row = $sth->fetchrow_array;
1064 # Need to call finish() to work round broken DBDs
1073 =item Arguments: $sql
1077 Returns a L<DBI> sth (statement handle) for the supplied SQL.
1082 my ($self, $dbh, $sql) = @_;
1084 # 3 is the if_active parameter which avoids active sth re-use
1085 my $sth = $self->disable_sth_caching
1086 ? $dbh->prepare($sql)
1087 : $dbh->prepare_cached($sql, {}, 3);
1089 # XXX You would think RaiseError would make this impossible,
1090 # but apparently that's not true :(
1091 $self->throw_exception($dbh->errstr) if !$sth;
1097 my ($self, $sql) = @_;
1098 $self->dbh_do($self->can('_dbh_sth'), $sql);
1101 sub _dbh_columns_info_for {
1102 my ($self, $dbh, $table) = @_;
1104 if ($dbh->can('column_info')) {
1107 my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
1108 my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
1110 while ( my $info = $sth->fetchrow_hashref() ){
1112 $column_info{data_type} = $info->{TYPE_NAME};
1113 $column_info{size} = $info->{COLUMN_SIZE};
1114 $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
1115 $column_info{default_value} = $info->{COLUMN_DEF};
1116 my $col_name = $info->{COLUMN_NAME};
1117 $col_name =~ s/^\"(.*)\"$/$1/;
1119 $result{$col_name} = \%column_info;
1122 return \%result if !$@ && scalar keys %result;
1126 my $sth = $dbh->prepare($self->sql_maker->select($table, undef, \'1 = 0'));
1128 my @columns = @{$sth->{NAME_lc}};
1129 for my $i ( 0 .. $#columns ){
1131 $column_info{data_type} = $sth->{TYPE}->[$i];
1132 $column_info{size} = $sth->{PRECISION}->[$i];
1133 $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
1135 if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
1136 $column_info{data_type} = $1;
1137 $column_info{size} = $2;
1140 $result{$columns[$i]} = \%column_info;
1144 foreach my $col (keys %result) {
1145 my $colinfo = $result{$col};
1146 my $type_num = $colinfo->{data_type};
1148 if(defined $type_num && $dbh->can('type_info')) {
1149 my $type_info = $dbh->type_info($type_num);
1150 $type_name = $type_info->{TYPE_NAME} if $type_info;
1151 $colinfo->{data_type} = $type_name if $type_name;
1158 sub columns_info_for {
1159 my ($self, $table) = @_;
1160 $self->dbh_do($self->can('_dbh_columns_info_for'), $table);
1163 =head2 last_insert_id
1165 Return the row id of the last insert.
1169 sub _dbh_last_insert_id {
1170 my ($self, $dbh, $source, $col) = @_;
1171 # XXX This is a SQLite-ism as a default... is there a DBI-generic way?
1172 $dbh->func('last_insert_rowid');
1175 sub last_insert_id {
1177 $self->dbh_do($self->can('_dbh_last_insert_id'), @_);
1182 Returns the database driver name.
1186 sub sqlt_type { shift->dbh->{Driver}->{Name} }
1188 =head2 bind_attribute_by_data_type
1190 Given a datatype from column info, returns a database specific bind attribute for
1191 $dbh->bind_param($val,$attribute) or nothing if we will let the database planner
1194 Generally only needed for special case column types, like bytea in postgres.
1198 sub bind_attribute_by_data_type {
1202 =head2 create_ddl_dir (EXPERIMENTAL)
1206 =item Arguments: $schema \@databases, $version, $directory, $preversion, $sqlt_args
1210 Creates a SQL file based on the Schema, for each of the specified
1211 database types, in the given directory.
1213 Note that this feature is currently EXPERIMENTAL and may not work correctly
1214 across all databases, or fully handle complex relationships.
1220 my ($self, $schema, $databases, $version, $dir, $preversion, $sqltargs) = @_;
1222 if(!$dir || !-d $dir)
1224 warn "No directory given, using ./\n";
1227 $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
1228 $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
1229 $version ||= $schema->VERSION || '1.x';
1230 $sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} };
1232 $self->throw_exception(q{Can't create a ddl file without SQL::Translator 0.08: '}
1233 . $self->_check_sqlt_message . q{'})
1234 if !$self->_check_sqlt_version;
1236 my $sqlt = SQL::Translator->new({
1238 add_drop_table => 1,
1240 foreach my $db (@$databases)
1243 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
1244 # $sqlt->parser_args({'DBIx::Class' => $schema);
1245 $sqlt = $self->configure_sqlt($sqlt, $db);
1246 $sqlt->data($schema);
1247 $sqlt->producer($db);
1250 my $filename = $schema->ddl_filename($db, $dir, $version);
1253 warn("$filename already exists, skipping $db");
1257 my $output = $sqlt->translate;
1260 warn("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
1263 if(!open($file, ">$filename"))
1265 $self->throw_exception("Can't open $filename for writing ($!)");
1268 print $file $output;
1273 require SQL::Translator::Diff;
1275 my $prefilename = $schema->ddl_filename($db, $dir, $preversion);
1276 # print "Previous version $prefilename\n";
1277 if(!-e $prefilename)
1279 warn("No previous schema file found ($prefilename)");
1282 #### We need to reparse the SQLite file we just wrote, so that
1283 ## Diff doesnt get all confoosed, and Diff is *very* confused.
1284 ## FIXME: rip Diff to pieces!
1285 # my $target_schema = $sqlt->schema;
1286 # unless ( $target_schema->name ) {
1287 # $target_schema->name( $filename );
1290 push @input, {file => $prefilename, parser => $db};
1291 push @input, {file => $filename, parser => $db};
1292 my ( $source_schema, $source_db, $target_schema, $target_db ) = map {
1293 my $file = $_->{'file'};
1294 my $parser = $_->{'parser'};
1296 my $t = SQL::Translator->new;
1299 $t->parser( $parser ) or die $t->error;
1300 my $out = $t->translate( $file ) or die $t->error;
1301 my $schema = $t->schema;
1302 unless ( $schema->name ) {
1303 $schema->name( $file );
1308 my $diff = SQL::Translator::Diff::schema_diff($source_schema, $db,
1309 $target_schema, $db,
1312 my $difffile = $schema->ddl_filename($db, $dir, $version, $preversion);
1313 print STDERR "Diff: $difffile: $db, $dir, $version, $preversion \n";
1316 warn("$difffile already exists, skipping");
1319 if(!open $file, ">$difffile")
1321 $self->throw_exception("Can't write to $difffile ($!)");
1330 sub configure_sqlt() {
1333 my $db = shift || $self->sqlt_type;
1334 if ($db eq 'PostgreSQL') {
1335 $tr->quote_table_names(0);
1336 $tr->quote_field_names(0);
1341 =head2 deployment_statements
1345 =item Arguments: $schema, $type, $version, $directory, $sqlt_args
1349 Returns the statements used by L</deploy> and L<DBIx::Class::Schema/deploy>.
1350 The database driver name is given by C<$type>, though the value from
1351 L</sqlt_type> is used if it is not specified.
1353 C<$directory> is used to return statements from files in a previously created
1354 L</create_ddl_dir> directory and is optional. The filenames are constructed
1355 from L<DBIx::Class::Schema/ddl_filename>, the schema name and the C<$version>.
1357 If no C<$directory> is specified then the statements are constructed on the
1358 fly using L<SQL::Translator> and C<$version> is ignored.
1360 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>.
1364 sub deployment_statements {
1365 my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
1366 # Need to be connected to get the correct sqlt_type
1367 $self->ensure_connected() unless $type;
1368 $type ||= $self->sqlt_type;
1369 $version ||= $schema->VERSION || '1.x';
1371 my $filename = $schema->ddl_filename($type, $dir, $version);
1375 open($file, "<$filename")
1376 or $self->throw_exception("Can't open $filename ($!)");
1379 return join('', @rows);
1382 $self->throw_exception(q{Can't deploy without SQL::Translator 0.08: '}
1383 . $self->_check_sqlt_message . q{'})
1384 if !$self->_check_sqlt_version;
1386 require SQL::Translator::Parser::DBIx::Class;
1387 eval qq{use SQL::Translator::Producer::${type}};
1388 $self->throw_exception($@) if $@;
1390 # sources needs to be a parser arg, but for simplicty allow at top level
1392 $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources}
1393 if exists $sqltargs->{sources};
1395 my $tr = SQL::Translator->new(%$sqltargs);
1396 SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
1397 return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
1404 my ($self, $schema, $type, $sqltargs, $dir) = @_;
1405 foreach my $statement ( $self->deployment_statements($schema, $type, undef, $dir, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
1406 for ( split(";\n", $statement)) {
1407 next if($_ =~ /^--/);
1409 # next if($_ =~ /^DROP/m);
1410 next if($_ =~ /^BEGIN TRANSACTION/m);
1411 next if($_ =~ /^COMMIT/m);
1412 next if $_ =~ /^\s+$/; # skip whitespace only
1413 $self->debugobj->query_start($_) if $self->debug;
1414 $self->dbh->do($_); # shouldn't be using ->dbh ?
1415 $self->debugobj->query_end($_) if $self->debug;
1420 =head2 datetime_parser
1422 Returns the datetime parser class
1426 sub datetime_parser {
1428 return $self->{datetime_parser} ||= $self->build_datetime_parser(@_);
1431 =head2 datetime_parser_type
1433 Defines (returns) the datetime parser class - currently hardwired to
1434 L<DateTime::Format::MySQL>
1438 sub datetime_parser_type { "DateTime::Format::MySQL"; }
1440 =head2 build_datetime_parser
1442 See L</datetime_parser>
1446 sub build_datetime_parser {
1448 my $type = $self->datetime_parser_type(@_);
1450 $self->throw_exception("Couldn't load ${type}: $@") if $@;
1455 my $_check_sqlt_version; # private
1456 my $_check_sqlt_message; # private
1457 sub _check_sqlt_version {
1458 return $_check_sqlt_version if defined $_check_sqlt_version;
1459 eval 'use SQL::Translator 0.08';
1460 $_check_sqlt_message = $@ ? $@ : '';
1461 $_check_sqlt_version = $@ ? 0 : 1;
1464 sub _check_sqlt_message {
1465 _check_sqlt_version if !defined $_check_sqlt_message;
1466 $_check_sqlt_message;
1472 return if !$self->_dbh;
1481 The module defines a set of methods within the DBIC::SQL::Abstract
1482 namespace. These build on L<SQL::Abstract::Limit> to provide the
1483 SQL query functions.
1485 The following methods are extended:-
1499 See L</connect_info> for details.
1500 For setting, this method is deprecated in favor of L</connect_info>.
1504 See L</connect_info> for details.
1505 For setting, this method is deprecated in favor of L</connect_info>.
1509 See L</connect_info> for details.
1510 For setting, this method is deprecated in favor of L</connect_info>.
1516 Matt S. Trout <mst@shadowcatsystems.co.uk>
1518 Andy Grundman <andy@hybridized.org>
1522 You may distribute this code under the same terms as Perl itself.