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 _dbh_autocommit/
22 package DBIC::SQL::Abstract; # Would merge upstream, but nate doesn't reply :(
24 use base qw/SQL::Abstract::Limit/;
26 # This prevents the caching of $dbh in S::A::L, I believe
28 my $self = shift->SUPER::new(@_);
30 # If limit_dialect is a ref (like a $dbh), go ahead and replace
31 # it with what it resolves to:
32 $self->{limit_dialect} = $self->_find_syntax($self->{limit_dialect})
33 if ref $self->{limit_dialect};
39 my ($self, $sql, $order, $rows, $offset ) = @_;
42 my $last = $rows + $offset;
43 my ( $order_by ) = $self->_order_by( $order );
48 SELECT Q1.*, ROW_NUMBER() OVER( ) AS ROW_NUM FROM (
53 WHERE ROW_NUM BETWEEN $offset AND $last
59 # While we're at it, this should make LIMIT queries more efficient,
60 # without digging into things too deeply
61 use Scalar::Util 'blessed';
63 my ($self, $syntax) = @_;
64 my $dbhname = blessed($syntax) ? $syntax->{Driver}{Name} : $syntax;
65 if(ref($self) && $dbhname && $dbhname eq 'DB2') {
66 return 'RowNumberOver';
69 $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
73 my ($self, $table, $fields, $where, $order, @rest) = @_;
74 $table = $self->_quote($table) unless ref($table);
75 local $self->{rownum_hack_count} = 1
76 if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
77 @rest = (-1) unless defined $rest[0];
78 die "LIMIT 0 Does Not Compute" if $rest[0] == 0;
79 # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
80 local $self->{having_bind} = [];
81 my ($sql, @ret) = $self->SUPER::select(
82 $table, $self->_recurse_fields($fields), $where, $order, @rest
84 return wantarray ? ($sql, @ret, @{$self->{having_bind}}) : $sql;
90 $table = $self->_quote($table) unless ref($table);
91 $self->SUPER::insert($table, @_);
97 $table = $self->_quote($table) unless ref($table);
98 $self->SUPER::update($table, @_);
104 $table = $self->_quote($table) unless ref($table);
105 $self->SUPER::delete($table, @_);
111 return $_[1].$self->_order_by($_[2]);
113 return $self->SUPER::_emulate_limit(@_);
117 sub _recurse_fields {
118 my ($self, $fields, $params) = @_;
119 my $ref = ref $fields;
120 return $self->_quote($fields) unless $ref;
121 return $$fields if $ref eq 'SCALAR';
123 if ($ref eq 'ARRAY') {
124 return join(', ', map {
125 $self->_recurse_fields($_)
126 .(exists $self->{rownum_hack_count} && !($params && $params->{no_rownum_hack})
127 ? ' AS col'.$self->{rownum_hack_count}++
130 } elsif ($ref eq 'HASH') {
131 foreach my $func (keys %$fields) {
132 return $self->_sqlcase($func)
133 .'( '.$self->_recurse_fields($fields->{$func}).' )';
142 if (ref $_[0] eq 'HASH') {
143 if (defined $_[0]->{group_by}) {
144 $ret = $self->_sqlcase(' group by ')
145 .$self->_recurse_fields($_[0]->{group_by}, { no_rownum_hack => 1 });
147 if (defined $_[0]->{having}) {
149 ($frag, @extra) = $self->_recurse_where($_[0]->{having});
150 push(@{$self->{having_bind}}, @extra);
151 $ret .= $self->_sqlcase(' having ').$frag;
153 if (defined $_[0]->{order_by}) {
154 $ret .= $self->_order_by($_[0]->{order_by});
156 } elsif (ref $_[0] eq 'SCALAR') {
157 $ret = $self->_sqlcase(' order by ').${ $_[0] };
158 } elsif (ref $_[0] eq 'ARRAY' && @{$_[0]}) {
159 my @order = @{+shift};
160 $ret = $self->_sqlcase(' order by ')
162 my $r = $self->_order_by($_, @_);
163 $r =~ s/^ ?ORDER BY //i;
167 $ret = $self->SUPER::_order_by(@_);
172 sub _order_directions {
173 my ($self, $order) = @_;
174 $order = $order->{order_by} if ref $order eq 'HASH';
175 return $self->SUPER::_order_directions($order);
179 my ($self, $from) = @_;
180 if (ref $from eq 'ARRAY') {
181 return $self->_recurse_from(@$from);
182 } elsif (ref $from eq 'HASH') {
183 return $self->_make_as($from);
185 return $from; # would love to quote here but _table ends up getting called
186 # twice during an ->select without a limit clause due to
187 # the way S::A::Limit->select works. should maybe consider
188 # bypassing this and doing S::A::select($self, ...) in
189 # our select method above. meantime, quoting shims have
190 # been added to select/insert/update/delete here
195 my ($self, $from, @join) = @_;
197 push(@sqlf, $self->_make_as($from));
198 foreach my $j (@join) {
201 # check whether a join type exists
202 my $join_clause = '';
203 my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
204 if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
205 $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
207 $join_clause = ' JOIN ';
209 push(@sqlf, $join_clause);
211 if (ref $to eq 'ARRAY') {
212 push(@sqlf, '(', $self->_recurse_from(@$to), ')');
214 push(@sqlf, $self->_make_as($to));
216 push(@sqlf, ' ON ', $self->_join_condition($on));
218 return join('', @sqlf);
222 my ($self, $from) = @_;
223 return join(' ', map { (ref $_ eq 'SCALAR' ? $$_ : $self->_quote($_)) }
224 reverse each %{$self->_skip_options($from)});
228 my ($self, $hash) = @_;
230 $clean_hash->{$_} = $hash->{$_}
231 for grep {!/^-/} keys %$hash;
235 sub _join_condition {
236 my ($self, $cond) = @_;
237 if (ref $cond eq 'HASH') {
242 # XXX no throw_exception() in this package and croak() fails with strange results
243 Carp::croak(ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
244 if ref($v) ne 'SCALAR';
248 my $x = '= '.$self->_quote($v); $j{$_} = \$x;
251 return scalar($self->_recurse_where(\%j));
252 } elsif (ref $cond eq 'ARRAY') {
253 return join(' OR ', map { $self->_join_condition($_) } @$cond);
255 die "Can't handle this yet!";
260 my ($self, $label) = @_;
261 return '' unless defined $label;
262 return "*" if $label eq '*';
263 return $label unless $self->{quote_char};
264 if(ref $self->{quote_char} eq "ARRAY"){
265 return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
266 if !defined $self->{name_sep};
267 my $sep = $self->{name_sep};
268 return join($self->{name_sep},
269 map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
270 split(/\Q$sep\E/,$label));
272 return $self->SUPER::_quote($label);
277 $self->{limit_dialect} = shift if @_;
278 return $self->{limit_dialect};
283 $self->{quote_char} = shift if @_;
284 return $self->{quote_char};
289 $self->{name_sep} = shift if @_;
290 return $self->{name_sep};
293 } # End of BEGIN block
297 DBIx::Class::Storage::DBI - DBI storage handler
303 This class represents the connection to an RDBMS via L<DBI>. See
304 L<DBIx::Class::Storage> for general information. This pod only
305 documents DBI-specific methods and behaviors.
312 my $new = shift->next::method(@_);
314 $new->cursor("DBIx::Class::Storage::DBI::Cursor");
315 $new->transaction_depth(0);
316 $new->_sql_maker_opts({});
317 $new->{_in_dbh_do} = 0;
318 $new->{_dbh_gen} = 0;
325 The arguments of C<connect_info> are always a single array reference.
327 This is normally accessed via L<DBIx::Class::Schema/connection>, which
328 encapsulates its argument list in an arrayref before calling
329 C<connect_info> here.
331 The arrayref can either contain the same set of arguments one would
332 normally pass to L<DBI/connect>, or a lone code reference which returns
333 a connected database handle. Please note that the L<DBI> docs
334 recommend that you always explicitly set C<AutoCommit> to either
335 C<0> or C<1>. L<DBIx::Class> further recommends that it be set
336 to C<1>, and that you perform transactions via our L</txn_do>
337 method. L<DBIx::Class> will set it to C<1> if you do not do explicitly
338 set it to zero. This is the default for most DBDs. See below for more
341 In either case, if the final argument in your connect_info happens
342 to be a hashref, C<connect_info> will look there for several
343 connection-specific options:
349 This can be set to an arrayref 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> and C<ShowErrorStatement> on, and sets C<PrintError> off on
386 all database handles, including those supplied by a coderef. It does this
387 so that it can 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 attributes, and instead relies on
391 the settings in your connect_info DBI options (or the values you set in
392 your connection coderef, in the case that you are connecting via coderef).
394 Note that your custom settings can cause Storage to malfunction,
395 especially if you set a C<HandleError> handler that suppresses exceptions
396 and/or disable C<RaiseError>.
400 These options can be mixed in with your other L<DBI> connection attributes,
401 or placed in a seperate hashref after all other normal L<DBI> connection
404 Every time C<connect_info> is invoked, any previous settings for
405 these options will be cleared before setting the new ones, regardless of
406 whether any options are specified in the new C<connect_info>.
408 Another Important Note:
410 DBIC can do some wonderful magic with handling exceptions,
411 disconnections, and transactions when you use C<AutoCommit => 1>
412 combined with C<txn_do> for transaction support.
414 If you set C<AutoCommit => 0> in your connect info, then you are always
415 in an assumed transaction between commits, and you're telling us you'd
416 like to manage that manually. A lot of DBIC's magic protections
417 go away. We can't protect you from exceptions due to database
418 disconnects because we don't know anything about how to restart your
419 transactions. You're on your own for handling all sorts of exceptional
420 cases if you choose the C<AutoCommit => 0> path, just as you would
425 # Simple SQLite connection
426 ->connect_info([ 'dbi:SQLite:./foo.db' ]);
429 ->connect_info([ sub { DBI->connect(...) } ]);
431 # A bit more complicated
438 { quote_char => q{"}, name_sep => q{.} },
442 # Equivalent to the previous example
448 { AutoCommit => 1, quote_char => q{"}, name_sep => q{.} },
452 # Subref + DBIC-specific connection options
455 sub { DBI->connect(...) },
459 on_connect_do => ['SET search_path TO myschema,otherschema,public'],
460 disable_sth_caching => 1,
468 my ($self, $info_arg) = @_;
470 return $self->_connect_info if !$info_arg;
472 # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
473 # the new set of options
474 $self->_sql_maker(undef);
475 $self->_sql_maker_opts({});
476 $self->_connect_info([@$info_arg]); # copy for _connect_info
478 my $dbi_info = [@$info_arg]; # copy for _dbi_connect_info
480 my $last_info = $dbi_info->[-1];
481 if(ref $last_info eq 'HASH') {
482 $last_info = { %$last_info }; # so delete is non-destructive
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;
493 # re-insert modified hashref
494 $dbi_info->[-1] = $last_info;
496 # Get rid of any trailing empty hashref
497 pop(@$dbi_info) if !keys %$last_info;
499 $self->_dbi_connect_info($dbi_info);
501 $self->_connect_info;
506 This method is deprecated in favor of setting via L</connect_info>.
510 Arguments: $subref, @extra_coderef_args?
512 Execute the given subref using the new exception-based connection management.
514 The first two arguments will be the storage object that C<dbh_do> was called
515 on and a database handle to use. Any additional arguments will be passed
516 verbatim to the called subref as arguments 2 and onwards.
518 Using this (instead of $self->_dbh or $self->dbh) ensures correct
519 exception handling and reconnection (or failover in future subclasses).
521 Your subref should have no side-effects outside of the database, as
522 there is the potential for your subref to be partially double-executed
523 if the database connection was stale/dysfunctional.
527 my @stuff = $schema->storage->dbh_do(
529 my ($storage, $dbh, @cols) = @_;
530 my $cols = join(q{, }, @cols);
531 $dbh->selectrow_array("SELECT $cols FROM foo");
542 ref $coderef eq 'CODE' or $self->throw_exception
543 ('$coderef must be a CODE reference');
545 return $coderef->($self, $self->_dbh, @_) if $self->{_in_dbh_do}
546 || $self->{transaction_depth};
548 local $self->{_in_dbh_do} = 1;
551 my $want_array = wantarray;
554 $self->_verify_pid if $self->_dbh;
555 $self->_populate_dbh if !$self->_dbh;
557 @result = $coderef->($self, $self->_dbh, @_);
559 elsif(defined $want_array) {
560 $result[0] = $coderef->($self, $self->_dbh, @_);
563 $coderef->($self, $self->_dbh, @_);
568 if(!$exception) { return $want_array ? @result : $result[0] }
570 $self->throw_exception($exception) if $self->connected;
572 # We were not connected - reconnect and retry, but let any
573 # exception fall right through this time
574 $self->_populate_dbh;
575 $coderef->($self, $self->_dbh, @_);
578 # This is basically a blend of dbh_do above and DBIx::Class::Storage::txn_do.
579 # It also informs dbh_do to bypass itself while under the direction of txn_do,
580 # via $self->{_in_dbh_do} (this saves some redundant eval and errorcheck, etc)
585 ref $coderef eq 'CODE' or $self->throw_exception
586 ('$coderef must be a CODE reference');
588 return $coderef->(@_) if $self->{transaction_depth};
590 local $self->{_in_dbh_do} = 1;
593 my $want_array = wantarray;
598 $self->_verify_pid if $self->_dbh;
599 $self->_populate_dbh if !$self->_dbh;
603 @result = $coderef->(@_);
605 elsif(defined $want_array) {
606 $result[0] = $coderef->(@_);
615 if(!$exception) { return $want_array ? @result : $result[0] }
617 if($tried++ > 0 || $self->connected) {
618 eval { $self->txn_rollback };
619 my $rollback_exception = $@;
620 if($rollback_exception) {
621 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
622 $self->throw_exception($exception) # propagate nested rollback
623 if $rollback_exception =~ /$exception_class/;
625 $self->throw_exception(
626 "Transaction aborted: ${exception}. "
627 . "Rollback failed: ${rollback_exception}"
630 $self->throw_exception($exception)
633 # We were not connected, and was first try - reconnect and retry
635 $self->_populate_dbh;
641 Our C<disconnect> method also performs a rollback first if the
642 database is not in C<AutoCommit> mode.
649 if( $self->connected ) {
650 $self->_dbh->rollback unless $self->_dbh_autocommit;
651 $self->_dbh->disconnect;
660 if(my $dbh = $self->_dbh) {
661 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
669 return ($dbh->FETCH('Active') && $dbh->ping);
675 # handle pid changes correctly
676 # NOTE: assumes $self->_dbh is a valid $dbh
680 return if $self->_conn_pid == $$;
682 $self->_dbh->{InactiveDestroy} = 1;
689 sub ensure_connected {
692 unless ($self->connected) {
693 $self->_populate_dbh;
699 Returns the dbh - a data base handle of class L<DBI>.
706 $self->ensure_connected;
710 sub _sql_maker_args {
713 return ( bindtype=>'columns', limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
718 unless ($self->_sql_maker) {
719 $self->_sql_maker(new DBIC::SQL::Abstract( $self->_sql_maker_args ));
721 return $self->_sql_maker;
726 my @info = @{$self->_dbi_connect_info || []};
727 $self->_dbh($self->_connect(@info));
729 # Always set the transaction depth on connect, since
730 # there is no transaction in progress by definition
731 $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
733 if(ref $self eq 'DBIx::Class::Storage::DBI') {
734 my $driver = $self->_dbh->{Driver}->{Name};
735 if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
736 bless $self, "DBIx::Class::Storage::DBI::${driver}";
737 $self->_rebless() if $self->can('_rebless');
741 # if on-connect sql statements are given execute them
742 foreach my $sql_statement (@{$self->on_connect_do || []}) {
743 $self->debugobj->query_start($sql_statement) if $self->debug();
744 $self->_dbh->do($sql_statement);
745 $self->debugobj->query_end($sql_statement) if $self->debug();
748 $self->_conn_pid($$);
749 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
753 my ($self, @info) = @_;
755 $self->throw_exception("You failed to provide any connection info")
758 my ($old_connect_via, $dbh);
760 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
761 $old_connect_via = $DBI::connect_via;
762 $DBI::connect_via = 'connect';
766 if(ref $info[0] eq 'CODE') {
770 $dbh = DBI->connect(@info);
774 my $weak_self = $self;
776 $dbh->{HandleError} = sub {
777 $weak_self->throw_exception("DBI Exception: $_[0]")
779 $dbh->{ShowErrorStatement} = 1;
780 $dbh->{RaiseError} = 1;
781 $dbh->{PrintError} = 0;
785 $DBI::connect_via = $old_connect_via if $old_connect_via;
787 $self->throw_exception("DBI Connection failed: " . ($@||$DBI::errstr))
790 $self->_dbh_autocommit($dbh->{AutoCommit});
798 $self->ensure_connected();
799 if($self->{transaction_depth} == 0) {
800 $self->debugobj->txn_begin()
802 # this isn't ->_dbh-> because
803 # we should reconnect on begin_work
804 # for AutoCommit users
805 $self->dbh->begin_work;
807 $self->{transaction_depth}++;
812 if ($self->{transaction_depth} == 1) {
813 my $dbh = $self->_dbh;
814 $self->debugobj->txn_commit()
817 $self->{transaction_depth} = 0
818 if $self->_dbh_autocommit;
820 elsif($self->{transaction_depth} > 1) {
821 $self->{transaction_depth}--
827 my $dbh = $self->_dbh;
829 if ($self->{transaction_depth} == 1) {
830 $self->debugobj->txn_rollback()
832 $self->{transaction_depth} = 0
833 if $self->_dbh_autocommit;
836 elsif($self->{transaction_depth} > 1) {
837 $self->{transaction_depth}--;
840 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
845 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
846 $error =~ /$exception_class/ and $self->throw_exception($error);
847 # ensure that a failed rollback resets the transaction depth
848 $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
849 $self->throw_exception($error);
853 # This used to be the top-half of _execute. It was split out to make it
854 # easier to override in NoBindVars without duping the rest. It takes up
855 # all of _execute's args, and emits $sql, @bind.
856 sub _prep_for_execute {
857 my ($self, $op, $extra_bind, $ident, $args) = @_;
859 my ($sql, @bind) = $self->sql_maker->$op($ident, @$args);
861 map { ref $_ eq 'ARRAY' ? $_ : [ '!!dummy', $_ ] } @$extra_bind)
864 return ($sql, \@bind);
868 my ($self, $dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
870 if( blessed($ident) && $ident->isa("DBIx::Class::ResultSource") ) {
871 $ident = $ident->from();
874 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
878 map { defined ($_ && $_->[1]) ? qq{'$_->[1]'} : q{'NULL'} } @$bind;
879 $self->debugobj->query_start($sql, @debug_bind);
882 my $sth = $self->sth($sql,$op);
884 my $placeholder_index = 1;
886 foreach my $bound (@$bind) {
888 my($column_name, @data) = @$bound;
890 if ($bind_attributes) {
891 $attributes = $bind_attributes->{$column_name}
892 if defined $bind_attributes->{$column_name};
895 foreach my $data (@data) {
896 $data = ref $data ? ''.$data : $data; # stringify args
898 $sth->bind_param($placeholder_index, $data, $attributes);
899 $placeholder_index++;
903 # Can this fail without throwing an exception anyways???
904 my $rv = $sth->execute();
905 $self->throw_exception($sth->errstr) if !$rv;
909 map { defined ($_ && $_->[1]) ? qq{'$_->[1]'} : q{'NULL'} } @$bind;
910 $self->debugobj->query_end($sql, @debug_bind);
913 return (wantarray ? ($rv, $sth, @$bind) : $rv);
918 $self->dbh_do($self->can('_dbh_execute'), @_)
922 my ($self, $source, $to_insert) = @_;
924 my $ident = $source->from;
925 my $bind_attributes = $self->source_bind_attributes($source);
927 $self->_execute('insert' => [], $source, $bind_attributes, $to_insert);
932 ## Still not quite perfect, and EXPERIMENTAL
933 ## Currently it is assumed that all values passed will be "normal", i.e. not
934 ## scalar refs, or at least, all the same type as the first set, the statement is
935 ## only prepped once.
937 my ($self, $source, $cols, $data) = @_;
939 my $table = $source->from;
940 @colvalues{@$cols} = (0..$#$cols);
941 my ($sql, @bind) = $self->sql_maker->insert($table, \%colvalues);
944 my @debug_bind = map { defined $_->[1] ? qq{$_->[1]} : q{'NULL'} } @bind;
945 $self->debugobj->query_start($sql, @debug_bind);
947 my $sth = $self->sth($sql);
949 # @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
951 ## This must be an arrayref, else nothing works!
953 my $tuple_status = [];
956 ##print STDERR Dumper( $data, $sql, [@bind] );
960 ## Get the bind_attributes, if any exist
961 my $bind_attributes = $self->source_bind_attributes($source);
963 ## Bind the values and execute
964 my $placeholder_index = 1;
966 foreach my $bound (@bind) {
969 my ($column_name, $data_index) = @$bound;
971 if( $bind_attributes ) {
972 $attributes = $bind_attributes->{$column_name}
973 if defined $bind_attributes->{$column_name};
976 my @data = map { $_->[$data_index] } @$data;
978 $sth->bind_param_array( $placeholder_index, [@data], $attributes );
979 $placeholder_index++;
981 my $rv = $sth->execute_array({ArrayTupleStatus => $tuple_status});
982 $self->throw_exception($sth->errstr) if !$rv;
985 my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind;
986 $self->debugobj->query_end($sql, @debug_bind);
988 return (wantarray ? ($rv, $sth, @bind) : $rv);
993 my $source = shift @_;
994 my $bind_attributes = $self->source_bind_attributes($source);
996 return $self->_execute('update' => [], $source, $bind_attributes, @_);
1001 my $self = shift @_;
1002 my $source = shift @_;
1004 my $bind_attrs = {}; ## If ever it's needed...
1006 return $self->_execute('delete' => [], $source, $bind_attrs, @_);
1010 my ($self, $ident, $select, $condition, $attrs) = @_;
1011 my $order = $attrs->{order_by};
1012 if (ref $condition eq 'SCALAR') {
1013 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
1015 if (exists $attrs->{group_by} || $attrs->{having}) {
1017 group_by => $attrs->{group_by},
1018 having => $attrs->{having},
1019 ($order ? (order_by => $order) : ())
1022 my $bind_attrs = {}; ## Future support
1023 my @args = ('select', $attrs->{bind}, $ident, $bind_attrs, $select, $condition, $order);
1024 if ($attrs->{software_limit} ||
1025 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
1026 $attrs->{software_limit} = 1;
1028 $self->throw_exception("rows attribute must be positive if present")
1029 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
1030 push @args, $attrs->{rows}, $attrs->{offset};
1032 return $self->_execute(@args);
1035 sub source_bind_attributes {
1036 my ($self, $source) = @_;
1038 my $bind_attributes;
1039 foreach my $column ($source->columns) {
1041 my $data_type = $source->column_info($column)->{data_type} || '';
1042 $bind_attributes->{$column} = $self->bind_attribute_by_data_type($data_type)
1046 return $bind_attributes;
1053 =item Arguments: $ident, $select, $condition, $attrs
1057 Handle a SQL select statement.
1063 my ($ident, $select, $condition, $attrs) = @_;
1064 return $self->cursor->new($self, \@_, $attrs);
1069 my ($rv, $sth, @bind) = $self->_select(@_);
1070 my @row = $sth->fetchrow_array;
1071 # Need to call finish() to work round broken DBDs
1080 =item Arguments: $sql
1084 Returns a L<DBI> sth (statement handle) for the supplied SQL.
1089 my ($self, $dbh, $sql) = @_;
1091 # 3 is the if_active parameter which avoids active sth re-use
1092 my $sth = $self->disable_sth_caching
1093 ? $dbh->prepare($sql)
1094 : $dbh->prepare_cached($sql, {}, 3);
1096 # XXX You would think RaiseError would make this impossible,
1097 # but apparently that's not true :(
1098 $self->throw_exception($dbh->errstr) if !$sth;
1104 my ($self, $sql) = @_;
1105 $self->dbh_do($self->can('_dbh_sth'), $sql);
1108 sub _dbh_columns_info_for {
1109 my ($self, $dbh, $table) = @_;
1111 if ($dbh->can('column_info')) {
1114 my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
1115 my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
1117 while ( my $info = $sth->fetchrow_hashref() ){
1119 $column_info{data_type} = $info->{TYPE_NAME};
1120 $column_info{size} = $info->{COLUMN_SIZE};
1121 $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
1122 $column_info{default_value} = $info->{COLUMN_DEF};
1123 my $col_name = $info->{COLUMN_NAME};
1124 $col_name =~ s/^\"(.*)\"$/$1/;
1126 $result{$col_name} = \%column_info;
1129 return \%result if !$@ && scalar keys %result;
1133 my $sth = $dbh->prepare($self->sql_maker->select($table, undef, \'1 = 0'));
1135 my @columns = @{$sth->{NAME_lc}};
1136 for my $i ( 0 .. $#columns ){
1138 $column_info{data_type} = $sth->{TYPE}->[$i];
1139 $column_info{size} = $sth->{PRECISION}->[$i];
1140 $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
1142 if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
1143 $column_info{data_type} = $1;
1144 $column_info{size} = $2;
1147 $result{$columns[$i]} = \%column_info;
1151 foreach my $col (keys %result) {
1152 my $colinfo = $result{$col};
1153 my $type_num = $colinfo->{data_type};
1155 if(defined $type_num && $dbh->can('type_info')) {
1156 my $type_info = $dbh->type_info($type_num);
1157 $type_name = $type_info->{TYPE_NAME} if $type_info;
1158 $colinfo->{data_type} = $type_name if $type_name;
1165 sub columns_info_for {
1166 my ($self, $table) = @_;
1167 $self->dbh_do($self->can('_dbh_columns_info_for'), $table);
1170 =head2 last_insert_id
1172 Return the row id of the last insert.
1176 sub _dbh_last_insert_id {
1177 my ($self, $dbh, $source, $col) = @_;
1178 # XXX This is a SQLite-ism as a default... is there a DBI-generic way?
1179 $dbh->func('last_insert_rowid');
1182 sub last_insert_id {
1184 $self->dbh_do($self->can('_dbh_last_insert_id'), @_);
1189 Returns the database driver name.
1193 sub sqlt_type { shift->dbh->{Driver}->{Name} }
1195 =head2 bind_attribute_by_data_type
1197 Given a datatype from column info, returns a database specific bind attribute for
1198 $dbh->bind_param($val,$attribute) or nothing if we will let the database planner
1201 Generally only needed for special case column types, like bytea in postgres.
1205 sub bind_attribute_by_data_type {
1209 =head2 create_ddl_dir
1213 =item Arguments: $schema \@databases, $version, $directory, $preversion, $sqlt_args
1217 Creates a SQL file based on the Schema, for each of the specified
1218 database types, in the given directory.
1224 my ($self, $schema, $databases, $version, $dir, $preversion, $sqltargs) = @_;
1226 if(!$dir || !-d $dir)
1228 warn "No directory given, using ./\n";
1231 $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
1232 $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
1233 $version ||= $schema->VERSION || '1.x';
1234 $sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} };
1236 $self->throw_exception(q{Can't create a ddl file without SQL::Translator 0.08: '}
1237 . $self->_check_sqlt_message . q{'})
1238 if !$self->_check_sqlt_version;
1240 my $sqlt = SQL::Translator->new({
1242 add_drop_table => 1,
1244 foreach my $db (@$databases)
1247 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
1248 # $sqlt->parser_args({'DBIx::Class' => $schema);
1249 $sqlt = $self->configure_sqlt($sqlt, $db);
1250 $sqlt->data($schema);
1251 $sqlt->producer($db);
1254 my $filename = $schema->ddl_filename($db, $dir, $version);
1257 warn("$filename already exists, skipping $db");
1261 my $output = $sqlt->translate;
1264 warn("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
1267 if(!open($file, ">$filename"))
1269 $self->throw_exception("Can't open $filename for writing ($!)");
1272 print $file $output;
1277 require SQL::Translator::Diff;
1279 my $prefilename = $schema->ddl_filename($db, $dir, $preversion);
1280 # print "Previous version $prefilename\n";
1281 if(!-e $prefilename)
1283 warn("No previous schema file found ($prefilename)");
1286 #### We need to reparse the SQLite file we just wrote, so that
1287 ## Diff doesnt get all confoosed, and Diff is *very* confused.
1288 ## FIXME: rip Diff to pieces!
1289 # my $target_schema = $sqlt->schema;
1290 # unless ( $target_schema->name ) {
1291 # $target_schema->name( $filename );
1294 push @input, {file => $prefilename, parser => $db};
1295 push @input, {file => $filename, parser => $db};
1296 my ( $source_schema, $source_db, $target_schema, $target_db ) = map {
1297 my $file = $_->{'file'};
1298 my $parser = $_->{'parser'};
1300 my $t = SQL::Translator->new;
1303 $t->parser( $parser ) or die $t->error;
1304 my $out = $t->translate( $file ) or die $t->error;
1305 my $schema = $t->schema;
1306 unless ( $schema->name ) {
1307 $schema->name( $file );
1312 my $diff = SQL::Translator::Diff::schema_diff($source_schema, $db,
1313 $target_schema, $db,
1316 my $difffile = $schema->ddl_filename($db, $dir, $version, $preversion);
1317 print STDERR "Diff: $difffile: $db, $dir, $version, $preversion \n";
1320 warn("$difffile already exists, skipping");
1323 if(!open $file, ">$difffile")
1325 $self->throw_exception("Can't write to $difffile ($!)");
1334 sub configure_sqlt() {
1337 my $db = shift || $self->sqlt_type;
1338 if ($db eq 'PostgreSQL') {
1339 $tr->quote_table_names(0);
1340 $tr->quote_field_names(0);
1345 =head2 deployment_statements
1349 =item Arguments: $schema, $type, $version, $directory, $sqlt_args
1353 Returns the statements used by L</deploy> and L<DBIx::Class::Schema/deploy>.
1354 The database driver name is given by C<$type>, though the value from
1355 L</sqlt_type> is used if it is not specified.
1357 C<$directory> is used to return statements from files in a previously created
1358 L</create_ddl_dir> directory and is optional. The filenames are constructed
1359 from L<DBIx::Class::Schema/ddl_filename>, the schema name and the C<$version>.
1361 If no C<$directory> is specified then the statements are constructed on the
1362 fly using L<SQL::Translator> and C<$version> is ignored.
1364 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>.
1368 sub deployment_statements {
1369 my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
1370 # Need to be connected to get the correct sqlt_type
1371 $self->ensure_connected() unless $type;
1372 $type ||= $self->sqlt_type;
1373 $version ||= $schema->VERSION || '1.x';
1375 my $filename = $schema->ddl_filename($type, $dir, $version);
1379 open($file, "<$filename")
1380 or $self->throw_exception("Can't open $filename ($!)");
1383 return join('', @rows);
1386 $self->throw_exception(q{Can't deploy without SQL::Translator 0.08: '}
1387 . $self->_check_sqlt_message . q{'})
1388 if !$self->_check_sqlt_version;
1390 require SQL::Translator::Parser::DBIx::Class;
1391 eval qq{use SQL::Translator::Producer::${type}};
1392 $self->throw_exception($@) if $@;
1394 # sources needs to be a parser arg, but for simplicty allow at top level
1396 $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources}
1397 if exists $sqltargs->{sources};
1399 my $tr = SQL::Translator->new(%$sqltargs);
1400 SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
1401 return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
1408 my ($self, $schema, $type, $sqltargs, $dir) = @_;
1409 foreach my $statement ( $self->deployment_statements($schema, $type, undef, $dir, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
1410 foreach my $line ( split(";\n", $statement)) {
1411 next if($line =~ /^--/);
1413 # next if($line =~ /^DROP/m);
1414 next if($line =~ /^BEGIN TRANSACTION/m);
1415 next if($line =~ /^COMMIT/m);
1416 next if $line =~ /^\s+$/; # skip whitespace only
1417 $self->debugobj->query_start($line) if $self->debug;
1419 $self->dbh->do($line); # shouldn't be using ->dbh ?
1422 warn qq{$@ (running "${line}")};
1424 $self->debugobj->query_end($line) if $self->debug;
1429 =head2 datetime_parser
1431 Returns the datetime parser class
1435 sub datetime_parser {
1437 return $self->{datetime_parser} ||= do {
1438 $self->ensure_connected;
1439 $self->build_datetime_parser(@_);
1443 =head2 datetime_parser_type
1445 Defines (returns) the datetime parser class - currently hardwired to
1446 L<DateTime::Format::MySQL>
1450 sub datetime_parser_type { "DateTime::Format::MySQL"; }
1452 =head2 build_datetime_parser
1454 See L</datetime_parser>
1458 sub build_datetime_parser {
1460 my $type = $self->datetime_parser_type(@_);
1462 $self->throw_exception("Couldn't load ${type}: $@") if $@;
1467 my $_check_sqlt_version; # private
1468 my $_check_sqlt_message; # private
1469 sub _check_sqlt_version {
1470 return $_check_sqlt_version if defined $_check_sqlt_version;
1471 eval 'use SQL::Translator 0.08';
1472 $_check_sqlt_message = $@ ? $@ : '';
1473 $_check_sqlt_version = $@ ? 0 : 1;
1476 sub _check_sqlt_message {
1477 _check_sqlt_version if !defined $_check_sqlt_message;
1478 $_check_sqlt_message;
1484 return if !$self->_dbh;
1493 The module defines a set of methods within the DBIC::SQL::Abstract
1494 namespace. These build on L<SQL::Abstract::Limit> to provide the
1495 SQL query functions.
1497 The following methods are extended:-
1511 See L</connect_info> for details.
1512 For setting, this method is deprecated in favor of L</connect_info>.
1516 See L</connect_info> for details.
1517 For setting, this method is deprecated in favor of L</connect_info>.
1521 See L</connect_info> for details.
1522 For setting, this method is deprecated in favor of L</connect_info>.
1528 Matt S. Trout <mst@shadowcatsystems.co.uk>
1530 Andy Grundman <andy@hybridized.org>
1534 You may distribute this code under the same terms as Perl itself.