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
18 transaction_depth unsafe/
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 This Storage driver normally installs its own C<HandleError>, sets
386 C<RaiseError> on, and sets C<PrintError> off on all database handles,
387 including those supplied by a coderef. It does this so that it can
388 have consistent and useful error behavior.
390 If you set this option to a true value, Storage will not do its usual
391 modifications to the database handle's C<RaiseError>, C<PrintError>, and
392 C<HandleError> attributes, and instead relies on the settings in your
393 connect_info DBI options (or the values you set in your connection
394 coderef, in the case that you are connecting via coderef).
396 Note that your custom settings can cause Storage to malfunction,
397 especially if you set a C<HandleError> handler that suppresses exceptions
398 and/or disable C<RaiseError>.
402 These options can be mixed in with your other L<DBI> connection attributes,
403 or placed in a seperate hashref after all other normal L<DBI> connection
406 Every time C<connect_info> is invoked, any previous settings for
407 these options will be cleared before setting the new ones, regardless of
408 whether any options are specified in the new C<connect_info>.
410 Another Important Note:
412 DBIC can do some wonderful magic with handling exceptions,
413 disconnections, and transactions when you use C<AutoCommit => 1>
414 combined with C<txn_do> for transaction support.
416 If you set C<AutoCommit => 0> in your connect info, then you are always
417 in an assumed transaction between commits, and you're telling us you'd
418 like to manage that manually. A lot of DBIC's magic protections
419 go away. We can't protect you from exceptions due to database
420 disconnects because we don't know anything about how to restart your
421 transactions. You're on your own for handling all sorts of exceptional
422 cases if you choose the C<AutoCommit => 0> path, just as you would
427 # Simple SQLite connection
428 ->connect_info([ 'dbi:SQLite:./foo.db' ]);
431 ->connect_info([ sub { DBI->connect(...) } ]);
433 # A bit more complicated
440 { quote_char => q{"}, name_sep => q{.} },
444 # Equivalent to the previous example
450 { AutoCommit => 1, quote_char => q{"}, name_sep => q{.} },
454 # Subref + DBIC-specific connection options
457 sub { DBI->connect(...) },
461 on_connect_do => ['SET search_path TO myschema,otherschema,public'],
462 disable_sth_caching => 1,
470 my ($self, $info_arg) = @_;
472 return $self->_connect_info if !$info_arg;
474 # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
475 # the new set of options
476 $self->_sql_maker(undef);
477 $self->_sql_maker_opts({});
478 $self->_connect_info([@$info_arg]); # copy for _connect_info
480 my $dbi_info = [@$info_arg]; # copy for _dbi_connect_info
482 my $last_info = $dbi_info->[-1];
483 if(ref $last_info eq 'HASH') {
484 for my $storage_opt (qw/on_connect_do disable_sth_caching unsafe/) {
485 if(my $value = delete $last_info->{$storage_opt}) {
486 $self->$storage_opt($value);
489 for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
490 if(my $opt_val = delete $last_info->{$sql_maker_opt}) {
491 $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
495 # Get rid of any trailing empty hashref
496 pop(@$dbi_info) if !keys %$last_info;
498 $self->_dbi_connect_info($dbi_info);
500 $self->_connect_info;
505 This method is deprecated in favor of setting via L</connect_info>.
509 Arguments: $subref, @extra_coderef_args?
511 Execute the given subref using the new exception-based connection management.
513 The first two arguments will be the storage object that C<dbh_do> was called
514 on and a database handle to use. Any additional arguments will be passed
515 verbatim to the called subref as arguments 2 and onwards.
517 Using this (instead of $self->_dbh or $self->dbh) ensures correct
518 exception handling and reconnection (or failover in future subclasses).
520 Your subref should have no side-effects outside of the database, as
521 there is the potential for your subref to be partially double-executed
522 if the database connection was stale/dysfunctional.
526 my @stuff = $schema->storage->dbh_do(
528 my ($storage, $dbh, @cols) = @_;
529 my $cols = join(q{, }, @cols);
530 $dbh->selectrow_array("SELECT $cols FROM foo");
541 ref $coderef eq 'CODE' or $self->throw_exception
542 ('$coderef must be a CODE reference');
544 return $coderef->($self, $self->_dbh, @_) if $self->{_in_dbh_do}
545 || $self->{transaction_depth};
547 local $self->{_in_dbh_do} = 1;
550 my $want_array = wantarray;
553 $self->_verify_pid if $self->_dbh;
554 $self->_populate_dbh if !$self->_dbh;
556 @result = $coderef->($self, $self->_dbh, @_);
558 elsif(defined $want_array) {
559 $result[0] = $coderef->($self, $self->_dbh, @_);
562 $coderef->($self, $self->_dbh, @_);
567 if(!$exception) { return $want_array ? @result : $result[0] }
569 $self->throw_exception($exception) if $self->connected;
571 # We were not connected - reconnect and retry, but let any
572 # exception fall right through this time
573 $self->_populate_dbh;
574 $coderef->($self, $self->_dbh, @_);
577 # This is basically a blend of dbh_do above and DBIx::Class::Storage::txn_do.
578 # It also informs dbh_do to bypass itself while under the direction of txn_do,
579 # via $self->{_in_dbh_do} (this saves some redundant eval and errorcheck, etc)
584 ref $coderef eq 'CODE' or $self->throw_exception
585 ('$coderef must be a CODE reference');
587 local $self->{_in_dbh_do} = 1;
590 my $want_array = wantarray;
595 $self->_verify_pid if $self->_dbh;
596 $self->_populate_dbh if !$self->_dbh;
600 @result = $coderef->(@_);
602 elsif(defined $want_array) {
603 $result[0] = $coderef->(@_);
612 if(!$exception) { return $want_array ? @result : $result[0] }
614 if($tried++ > 0 || $self->connected) {
615 eval { $self->txn_rollback };
616 my $rollback_exception = $@;
617 if($rollback_exception) {
618 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
619 $self->throw_exception($exception) # propagate nested rollback
620 if $rollback_exception =~ /$exception_class/;
622 $self->throw_exception(
623 "Transaction aborted: ${exception}. "
624 . "Rollback failed: ${rollback_exception}"
627 $self->throw_exception($exception)
630 # We were not connected, and was first try - reconnect and retry
632 $self->_populate_dbh;
638 Our C<disconnect> method also performs a rollback first if the
639 database is not in C<AutoCommit> mode.
646 if( $self->connected ) {
647 $self->_dbh->rollback unless $self->_dbh->{AutoCommit};
648 $self->_dbh->disconnect;
657 if(my $dbh = $self->_dbh) {
658 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
666 return ($dbh->FETCH('Active') && $dbh->ping);
672 # handle pid changes correctly
673 # NOTE: assumes $self->_dbh is a valid $dbh
677 return if $self->_conn_pid == $$;
679 $self->_dbh->{InactiveDestroy} = 1;
686 sub ensure_connected {
689 unless ($self->connected) {
690 $self->_populate_dbh;
696 Returns the dbh - a data base handle of class L<DBI>.
703 $self->ensure_connected;
707 sub _sql_maker_args {
710 return ( bindtype=>'columns', limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
715 unless ($self->_sql_maker) {
716 $self->_sql_maker(new DBIC::SQL::Abstract( $self->_sql_maker_args ));
718 return $self->_sql_maker;
723 my @info = @{$self->_dbi_connect_info || []};
724 $self->_dbh($self->_connect(@info));
726 # Always set the transaction depth on connect, since
727 # there is no transaction in progress by definition
728 $self->{transaction_depth} = $self->_dbh->{AutoCommit} ? 0 : 1;
730 if(ref $self eq 'DBIx::Class::Storage::DBI') {
731 my $driver = $self->_dbh->{Driver}->{Name};
732 if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
733 bless $self, "DBIx::Class::Storage::DBI::${driver}";
734 $self->_rebless() if $self->can('_rebless');
738 # if on-connect sql statements are given execute them
739 foreach my $sql_statement (@{$self->on_connect_do || []}) {
740 $self->debugobj->query_start($sql_statement) if $self->debug();
741 $self->_dbh->do($sql_statement);
742 $self->debugobj->query_end($sql_statement) if $self->debug();
745 $self->_conn_pid($$);
746 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
750 my ($self, @info) = @_;
752 $self->throw_exception("You failed to provide any connection info")
755 my ($old_connect_via, $dbh);
757 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
758 $old_connect_via = $DBI::connect_via;
759 $DBI::connect_via = 'connect';
763 if(ref $info[0] eq 'CODE') {
767 $dbh = DBI->connect(@info);
771 $dbh->{HandleError} = sub {
772 $self->throw_exception("DBI Exception: $_[0]")
774 $dbh->{RaiseError} = 1;
775 $dbh->{PrintError} = 0;
779 $DBI::connect_via = $old_connect_via if $old_connect_via;
781 $self->throw_exception("DBI Connection failed: " . ($@||$DBI::errstr))
790 if($self->{transaction_depth}++ == 0) {
791 $self->debugobj->txn_begin()
793 # this isn't ->_dbh-> because
794 # we should reconnect on begin_work
795 # for AutoCommit users
796 $self->dbh->begin_work;
802 if ($self->{transaction_depth} == 1) {
803 my $dbh = $self->_dbh;
804 $self->debugobj->txn_commit()
807 $self->{transaction_depth} = 0
808 if $dbh->{AutoCommit};
810 elsif($self->{transaction_depth} > 1) {
811 $self->{transaction_depth}--
817 my $dbh = $self->_dbh;
820 $autocommit = $dbh->{AutoCommit};
821 if ($self->{transaction_depth} == 1) {
822 $self->debugobj->txn_rollback()
825 $self->{transaction_depth} = 0
828 elsif($self->{transaction_depth} > 1) {
829 $self->{transaction_depth}--;
832 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
837 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
838 $error =~ /$exception_class/ and $self->throw_exception($error);
839 # ensure that a failed rollback resets the transaction depth
840 $self->{transaction_depth} = $autocommit ? 0 : 1;
841 $self->throw_exception($error);
845 # This used to be the top-half of _execute. It was split out to make it
846 # easier to override in NoBindVars without duping the rest. It takes up
847 # all of _execute's args, and emits $sql, @bind.
848 sub _prep_for_execute {
849 my ($self, $op, $extra_bind, $ident, $args) = @_;
851 my ($sql, @bind) = $self->sql_maker->$op($ident, @$args);
853 map { ref $_ eq 'ARRAY' ? $_ : [ '!!dummy', $_ ] } @$extra_bind)
856 return ($sql, \@bind);
860 my ($self, $dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
862 if( blessed($ident) && $ident->isa("DBIx::Class::ResultSource") ) {
863 $ident = $ident->from();
866 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
870 map { defined ($_ && $_->[1]) ? qq{'$_->[1]'} : q{'NULL'} } @$bind;
871 $self->debugobj->query_start($sql, @debug_bind);
874 my $sth = $self->sth($sql,$op);
876 my $placeholder_index = 1;
878 foreach my $bound (@$bind) {
880 my($column_name, @data) = @$bound;
882 if ($bind_attributes) {
883 $attributes = $bind_attributes->{$column_name}
884 if defined $bind_attributes->{$column_name};
887 foreach my $data (@data) {
888 $data = ref $data ? ''.$data : $data; # stringify args
890 $sth->bind_param($placeholder_index, $data, $attributes);
891 $placeholder_index++;
895 # Can this fail without throwing an exception anyways???
896 my $rv = $sth->execute();
897 $self->throw_exception($sth->errstr) if !$rv;
901 map { defined ($_ && $_->[1]) ? qq{'$_->[1]'} : q{'NULL'} } @$bind;
902 $self->debugobj->query_end($sql, @debug_bind);
905 return (wantarray ? ($rv, $sth, @$bind) : $rv);
910 $self->dbh_do($self->can('_dbh_execute'), @_)
914 my ($self, $source, $to_insert) = @_;
916 my $ident = $source->from;
917 my $bind_attributes = $self->source_bind_attributes($source);
919 $self->_execute('insert' => [], $source, $bind_attributes, $to_insert);
924 ## Still not quite perfect, and EXPERIMENTAL
925 ## Currently it is assumed that all values passed will be "normal", i.e. not
926 ## scalar refs, or at least, all the same type as the first set, the statement is
927 ## only prepped once.
929 my ($self, $source, $cols, $data) = @_;
931 my $table = $source->from;
932 @colvalues{@$cols} = (0..$#$cols);
933 my ($sql, @bind) = $self->sql_maker->insert($table, \%colvalues);
936 my @debug_bind = map { defined $_->[1] ? qq{$_->[1]} : q{'NULL'} } @bind;
937 $self->debugobj->query_start($sql, @debug_bind);
939 my $sth = $self->sth($sql);
941 # @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
943 ## This must be an arrayref, else nothing works!
945 my $tuple_status = [];
948 ##print STDERR Dumper( $data, $sql, [@bind] );
952 ## Get the bind_attributes, if any exist
953 my $bind_attributes = $self->source_bind_attributes($source);
955 ## Bind the values and execute
956 my $placeholder_index = 1;
958 foreach my $bound (@bind) {
961 my ($column_name, $data_index) = @$bound;
963 if( $bind_attributes ) {
964 $attributes = $bind_attributes->{$column_name}
965 if defined $bind_attributes->{$column_name};
968 my @data = map { $_->[$data_index] } @$data;
970 $sth->bind_param_array( $placeholder_index, [@data], $attributes );
971 $placeholder_index++;
973 my $rv = $sth->execute_array({ArrayTupleStatus => $tuple_status});
974 $self->throw_exception($sth->errstr) if !$rv;
977 my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind;
978 $self->debugobj->query_end($sql, @debug_bind);
980 return (wantarray ? ($rv, $sth, @bind) : $rv);
985 my $source = shift @_;
986 my $bind_attributes = $self->source_bind_attributes($source);
988 return $self->_execute('update' => [], $source, $bind_attributes, @_);
994 my $source = shift @_;
996 my $bind_attrs = {}; ## If ever it's needed...
998 return $self->_execute('delete' => [], $source, $bind_attrs, @_);
1002 my ($self, $ident, $select, $condition, $attrs) = @_;
1003 my $order = $attrs->{order_by};
1004 if (ref $condition eq 'SCALAR') {
1005 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
1007 if (exists $attrs->{group_by} || $attrs->{having}) {
1009 group_by => $attrs->{group_by},
1010 having => $attrs->{having},
1011 ($order ? (order_by => $order) : ())
1014 my $bind_attrs = {}; ## Future support
1015 my @args = ('select', $attrs->{bind}, $ident, $bind_attrs, $select, $condition, $order);
1016 if ($attrs->{software_limit} ||
1017 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
1018 $attrs->{software_limit} = 1;
1020 $self->throw_exception("rows attribute must be positive if present")
1021 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
1022 push @args, $attrs->{rows}, $attrs->{offset};
1024 return $self->_execute(@args);
1027 sub source_bind_attributes {
1028 my ($self, $source) = @_;
1030 my $bind_attributes;
1031 foreach my $column ($source->columns) {
1033 my $data_type = $source->column_info($column)->{data_type} || '';
1034 $bind_attributes->{$column} = $self->bind_attribute_by_data_type($data_type)
1038 return $bind_attributes;
1045 =item Arguments: $ident, $select, $condition, $attrs
1049 Handle a SQL select statement.
1055 my ($ident, $select, $condition, $attrs) = @_;
1056 return $self->cursor->new($self, \@_, $attrs);
1061 my ($rv, $sth, @bind) = $self->_select(@_);
1062 my @row = $sth->fetchrow_array;
1063 # Need to call finish() to work round broken DBDs
1072 =item Arguments: $sql
1076 Returns a L<DBI> sth (statement handle) for the supplied SQL.
1081 my ($self, $dbh, $sql) = @_;
1083 # 3 is the if_active parameter which avoids active sth re-use
1084 my $sth = $self->disable_sth_caching
1085 ? $dbh->prepare($sql)
1086 : $dbh->prepare_cached($sql, {}, 3);
1088 # XXX You would think RaiseError would make this impossible,
1089 # but apparently that's not true :(
1090 $self->throw_exception($dbh->errstr) if !$sth;
1096 my ($self, $sql) = @_;
1097 $self->dbh_do($self->can('_dbh_sth'), $sql);
1100 sub _dbh_columns_info_for {
1101 my ($self, $dbh, $table) = @_;
1103 if ($dbh->can('column_info')) {
1106 my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
1107 my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
1109 while ( my $info = $sth->fetchrow_hashref() ){
1111 $column_info{data_type} = $info->{TYPE_NAME};
1112 $column_info{size} = $info->{COLUMN_SIZE};
1113 $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
1114 $column_info{default_value} = $info->{COLUMN_DEF};
1115 my $col_name = $info->{COLUMN_NAME};
1116 $col_name =~ s/^\"(.*)\"$/$1/;
1118 $result{$col_name} = \%column_info;
1121 return \%result if !$@ && scalar keys %result;
1125 my $sth = $dbh->prepare($self->sql_maker->select($table, undef, \'1 = 0'));
1127 my @columns = @{$sth->{NAME_lc}};
1128 for my $i ( 0 .. $#columns ){
1130 $column_info{data_type} = $sth->{TYPE}->[$i];
1131 $column_info{size} = $sth->{PRECISION}->[$i];
1132 $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
1134 if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
1135 $column_info{data_type} = $1;
1136 $column_info{size} = $2;
1139 $result{$columns[$i]} = \%column_info;
1143 foreach my $col (keys %result) {
1144 my $colinfo = $result{$col};
1145 my $type_num = $colinfo->{data_type};
1147 if(defined $type_num && $dbh->can('type_info')) {
1148 my $type_info = $dbh->type_info($type_num);
1149 $type_name = $type_info->{TYPE_NAME} if $type_info;
1150 $colinfo->{data_type} = $type_name if $type_name;
1157 sub columns_info_for {
1158 my ($self, $table) = @_;
1159 $self->dbh_do($self->can('_dbh_columns_info_for'), $table);
1162 =head2 last_insert_id
1164 Return the row id of the last insert.
1168 sub _dbh_last_insert_id {
1169 my ($self, $dbh, $source, $col) = @_;
1170 # XXX This is a SQLite-ism as a default... is there a DBI-generic way?
1171 $dbh->func('last_insert_rowid');
1174 sub last_insert_id {
1176 $self->dbh_do($self->can('_dbh_last_insert_id'), @_);
1181 Returns the database driver name.
1185 sub sqlt_type { shift->dbh->{Driver}->{Name} }
1187 =head2 bind_attribute_by_data_type
1189 Given a datatype from column info, returns a database specific bind attribute for
1190 $dbh->bind_param($val,$attribute) or nothing if we will let the database planner
1193 Generally only needed for special case column types, like bytea in postgres.
1197 sub bind_attribute_by_data_type {
1201 =head2 create_ddl_dir (EXPERIMENTAL)
1205 =item Arguments: $schema \@databases, $version, $directory, $preversion, $sqlt_args
1209 Creates a SQL file based on the Schema, for each of the specified
1210 database types, in the given directory.
1212 Note that this feature is currently EXPERIMENTAL and may not work correctly
1213 across all databases, or fully handle complex relationships.
1219 my ($self, $schema, $databases, $version, $dir, $preversion, $sqltargs) = @_;
1221 if(!$dir || !-d $dir)
1223 warn "No directory given, using ./\n";
1226 $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
1227 $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
1228 $version ||= $schema->VERSION || '1.x';
1229 $sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} };
1231 $self->throw_exception(q{Can't create a ddl file without SQL::Translator 0.08: '}
1232 . $self->_check_sqlt_message . q{'})
1233 if !$self->_check_sqlt_version;
1235 my $sqlt = SQL::Translator->new({
1237 add_drop_table => 1,
1239 foreach my $db (@$databases)
1242 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
1243 # $sqlt->parser_args({'DBIx::Class' => $schema);
1244 $sqlt = $self->configure_sqlt($sqlt, $db);
1245 $sqlt->data($schema);
1246 $sqlt->producer($db);
1249 my $filename = $schema->ddl_filename($db, $dir, $version);
1252 warn("$filename already exists, skipping $db");
1256 my $output = $sqlt->translate;
1259 warn("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
1262 if(!open($file, ">$filename"))
1264 $self->throw_exception("Can't open $filename for writing ($!)");
1267 print $file $output;
1272 require SQL::Translator::Diff;
1274 my $prefilename = $schema->ddl_filename($db, $dir, $preversion);
1275 # print "Previous version $prefilename\n";
1276 if(!-e $prefilename)
1278 warn("No previous schema file found ($prefilename)");
1281 #### We need to reparse the SQLite file we just wrote, so that
1282 ## Diff doesnt get all confoosed, and Diff is *very* confused.
1283 ## FIXME: rip Diff to pieces!
1284 # my $target_schema = $sqlt->schema;
1285 # unless ( $target_schema->name ) {
1286 # $target_schema->name( $filename );
1289 push @input, {file => $prefilename, parser => $db};
1290 push @input, {file => $filename, parser => $db};
1291 my ( $source_schema, $source_db, $target_schema, $target_db ) = map {
1292 my $file = $_->{'file'};
1293 my $parser = $_->{'parser'};
1295 my $t = SQL::Translator->new;
1298 $t->parser( $parser ) or die $t->error;
1299 my $out = $t->translate( $file ) or die $t->error;
1300 my $schema = $t->schema;
1301 unless ( $schema->name ) {
1302 $schema->name( $file );
1307 my $diff = SQL::Translator::Diff::schema_diff($source_schema, $db,
1308 $target_schema, $db,
1311 my $difffile = $schema->ddl_filename($db, $dir, $version, $preversion);
1312 print STDERR "Diff: $difffile: $db, $dir, $version, $preversion \n";
1315 warn("$difffile already exists, skipping");
1318 if(!open $file, ">$difffile")
1320 $self->throw_exception("Can't write to $difffile ($!)");
1329 sub configure_sqlt() {
1332 my $db = shift || $self->sqlt_type;
1333 if ($db eq 'PostgreSQL') {
1334 $tr->quote_table_names(0);
1335 $tr->quote_field_names(0);
1340 =head2 deployment_statements
1344 =item Arguments: $schema, $type, $version, $directory, $sqlt_args
1348 Returns the statements used by L</deploy> and L<DBIx::Class::Schema/deploy>.
1349 The database driver name is given by C<$type>, though the value from
1350 L</sqlt_type> is used if it is not specified.
1352 C<$directory> is used to return statements from files in a previously created
1353 L</create_ddl_dir> directory and is optional. The filenames are constructed
1354 from L<DBIx::Class::Schema/ddl_filename>, the schema name and the C<$version>.
1356 If no C<$directory> is specified then the statements are constructed on the
1357 fly using L<SQL::Translator> and C<$version> is ignored.
1359 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>.
1363 sub deployment_statements {
1364 my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
1365 # Need to be connected to get the correct sqlt_type
1366 $self->ensure_connected() unless $type;
1367 $type ||= $self->sqlt_type;
1368 $version ||= $schema->VERSION || '1.x';
1370 my $filename = $schema->ddl_filename($type, $dir, $version);
1374 open($file, "<$filename")
1375 or $self->throw_exception("Can't open $filename ($!)");
1378 return join('', @rows);
1381 $self->throw_exception(q{Can't deploy without SQL::Translator 0.08: '}
1382 . $self->_check_sqlt_message . q{'})
1383 if !$self->_check_sqlt_version;
1385 require SQL::Translator::Parser::DBIx::Class;
1386 eval qq{use SQL::Translator::Producer::${type}};
1387 $self->throw_exception($@) if $@;
1389 # sources needs to be a parser arg, but for simplicty allow at top level
1391 $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources}
1392 if exists $sqltargs->{sources};
1394 my $tr = SQL::Translator->new(%$sqltargs);
1395 SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
1396 return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
1403 my ($self, $schema, $type, $sqltargs, $dir) = @_;
1404 foreach my $statement ( $self->deployment_statements($schema, $type, undef, $dir, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
1405 for ( split(";\n", $statement)) {
1406 next if($_ =~ /^--/);
1408 # next if($_ =~ /^DROP/m);
1409 next if($_ =~ /^BEGIN TRANSACTION/m);
1410 next if($_ =~ /^COMMIT/m);
1411 next if $_ =~ /^\s+$/; # skip whitespace only
1412 $self->debugobj->query_start($_) if $self->debug;
1413 $self->dbh->do($_); # shouldn't be using ->dbh ?
1414 $self->debugobj->query_end($_) if $self->debug;
1419 =head2 datetime_parser
1421 Returns the datetime parser class
1425 sub datetime_parser {
1427 return $self->{datetime_parser} ||= $self->build_datetime_parser(@_);
1430 =head2 datetime_parser_type
1432 Defines (returns) the datetime parser class - currently hardwired to
1433 L<DateTime::Format::MySQL>
1437 sub datetime_parser_type { "DateTime::Format::MySQL"; }
1439 =head2 build_datetime_parser
1441 See L</datetime_parser>
1445 sub build_datetime_parser {
1447 my $type = $self->datetime_parser_type(@_);
1449 $self->throw_exception("Couldn't load ${type}: $@") if $@;
1454 my $_check_sqlt_version; # private
1455 my $_check_sqlt_message; # private
1456 sub _check_sqlt_version {
1457 return $_check_sqlt_version if defined $_check_sqlt_version;
1458 eval 'use SQL::Translator 0.08';
1459 $_check_sqlt_message = $@ ? $@ : '';
1460 $_check_sqlt_version = $@ ? 0 : 1;
1463 sub _check_sqlt_message {
1464 _check_sqlt_version if !defined $_check_sqlt_message;
1465 $_check_sqlt_message;
1471 return if !$self->_dbh;
1480 The module defines a set of methods within the DBIC::SQL::Abstract
1481 namespace. These build on L<SQL::Abstract::Limit> to provide the
1482 SQL query functions.
1484 The following methods are extended:-
1498 See L</connect_info> for details.
1499 For setting, this method is deprecated in favor of L</connect_info>.
1503 See L</connect_info> for details.
1504 For setting, this method is deprecated in favor of L</connect_info>.
1508 See L</connect_info> for details.
1509 For setting, this method is deprecated in favor of L</connect_info>.
1515 Matt S. Trout <mst@shadowcatsystems.co.uk>
1517 Andy Grundman <andy@hybridized.org>
1521 You may distribute this code under the same terms as Perl itself.