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(
17 qw/_connect_info _dbh _sql_maker _sql_maker_opts _conn_pid _conn_tid
18 disable_sth_caching cursor on_connect_do transaction_depth/
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.
336 In either case, if the final argument in your connect_info happens
337 to be a hashref, C<connect_info> will look there for several
338 connection-specific options:
344 This can be set to an arrayref of literal sql statements, which will
345 be executed immediately after making the connection to the database
346 every time we [re-]connect.
348 =item disable_sth_caching
350 If set to a true value, this option will disable the caching of
351 statement handles via L<DBI/prepare_cached>.
355 Sets the limit dialect. This is useful for JDBC-bridge among others
356 where the remote SQL-dialect cannot be determined by the name of the
361 Specifies what characters to use to quote table and column names. If
362 you use this you will want to specify L<name_sep> as well.
364 quote_char expects either a single character, in which case is it is placed
365 on either side of the table/column, or an arrayref of length 2 in which case the
366 table/column name is placed between the elements.
368 For example under MySQL you'd use C<quote_char =E<gt> '`'>, and user SQL Server you'd
369 use C<quote_char =E<gt> [qw/[ ]/]>.
373 This only needs to be used in conjunction with L<quote_char>, and is used to
374 specify the charecter that seperates elements (schemas, tables, columns) from
375 each other. In most cases this is simply a C<.>.
379 These options can be mixed in with your other L<DBI> connection attributes,
380 or placed in a seperate hashref after all other normal L<DBI> connection
383 Every time C<connect_info> is invoked, any previous settings for
384 these options will be cleared before setting the new ones, regardless of
385 whether any options are specified in the new C<connect_info>.
387 Important note: DBIC expects the returned database handle provided by
388 a subref argument to have RaiseError set on it. If it doesn't, things
389 might not work very well, YMMV. If you don't use a subref, DBIC will
390 force this setting for you anyways. Setting HandleError to anything
391 other than simple exception object wrapper might cause problems too.
395 # Simple SQLite connection
396 ->connect_info([ 'dbi:SQLite:./foo.db' ]);
399 ->connect_info([ sub { DBI->connect(...) } ]);
401 # A bit more complicated
408 { quote_char => q{"}, name_sep => q{.} },
412 # Equivalent to the previous example
418 { AutoCommit => 0, quote_char => q{"}, name_sep => q{.} },
422 # Subref + DBIC-specific connection options
425 sub { DBI->connect(...) },
429 on_connect_do => ['SET search_path TO myschema,otherschema,public'],
430 disable_sth_caching => 1,
438 my ($self, $info_arg) = @_;
440 return $self->_connect_info if !$info_arg;
442 # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
443 # the new set of options
444 $self->_sql_maker(undef);
445 $self->_sql_maker_opts({});
447 my $info = [ @$info_arg ]; # copy because we can alter it
448 my $last_info = $info->[-1];
449 if(ref $last_info eq 'HASH') {
450 for my $storage_opt (qw/on_connect_do disable_sth_caching/) {
451 if(my $value = delete $last_info->{$storage_opt}) {
452 $self->$storage_opt($value);
455 for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
456 if(my $opt_val = delete $last_info->{$sql_maker_opt}) {
457 $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
461 # Get rid of any trailing empty hashref
462 pop(@$info) if !keys %$last_info;
465 $self->_connect_info($info);
470 This method is deprecated in favor of setting via L</connect_info>.
474 Arguments: $subref, @extra_coderef_args?
476 Execute the given subref using the new exception-based connection management.
478 The first two arguments will be the storage object that C<dbh_do> was called
479 on and a database handle to use. Any additional arguments will be passed
480 verbatim to the called subref as arguments 2 and onwards.
482 Using this (instead of $self->_dbh or $self->dbh) ensures correct
483 exception handling and reconnection (or failover in future subclasses).
485 Your subref should have no side-effects outside of the database, as
486 there is the potential for your subref to be partially double-executed
487 if the database connection was stale/dysfunctional.
491 my @stuff = $schema->storage->dbh_do(
493 my ($storage, $dbh, @cols) = @_;
494 my $cols = join(q{, }, @cols);
495 $dbh->selectrow_array("SELECT $cols FROM foo");
506 ref $coderef eq 'CODE' or $self->throw_exception
507 ('$coderef must be a CODE reference');
509 return $coderef->($self, $self->_dbh, @_) if $self->{_in_dbh_do};
510 local $self->{_in_dbh_do} = 1;
513 my $want_array = wantarray;
516 $self->_verify_pid if $self->_dbh;
517 $self->_populate_dbh if !$self->_dbh;
519 @result = $coderef->($self, $self->_dbh, @_);
521 elsif(defined $want_array) {
522 $result[0] = $coderef->($self, $self->_dbh, @_);
525 $coderef->($self, $self->_dbh, @_);
530 if(!$exception) { return $want_array ? @result : $result[0] }
532 $self->throw_exception($exception) if $self->connected;
534 # We were not connected - reconnect and retry, but let any
535 # exception fall right through this time
536 $self->_populate_dbh;
537 $coderef->($self, $self->_dbh, @_);
540 # This is basically a blend of dbh_do above and DBIx::Class::Storage::txn_do.
541 # It also informs dbh_do to bypass itself while under the direction of txn_do,
542 # via $self->{_in_dbh_do} (this saves some redundant eval and errorcheck, etc)
547 ref $coderef eq 'CODE' or $self->throw_exception
548 ('$coderef must be a CODE reference');
550 local $self->{_in_dbh_do} = 1;
553 my $want_array = wantarray;
558 $self->_verify_pid if $self->_dbh;
559 $self->_populate_dbh if !$self->_dbh;
563 @result = $coderef->(@_);
565 elsif(defined $want_array) {
566 $result[0] = $coderef->(@_);
575 if(!$exception) { return $want_array ? @result : $result[0] }
577 if($tried++ > 0 || $self->connected) {
578 eval { $self->txn_rollback };
579 my $rollback_exception = $@;
580 if($rollback_exception) {
581 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
582 $self->throw_exception($exception) # propagate nested rollback
583 if $rollback_exception =~ /$exception_class/;
585 $self->throw_exception(
586 "Transaction aborted: ${exception}. "
587 . "Rollback failed: ${rollback_exception}"
590 $self->throw_exception($exception)
593 # We were not connected, and was first try - reconnect and retry
595 $self->_populate_dbh;
601 Our C<disconnect> method also performs a rollback first if the
602 database is not in C<AutoCommit> mode.
609 if( $self->connected ) {
610 $self->_dbh->rollback unless $self->_dbh->{AutoCommit};
611 $self->_dbh->disconnect;
620 if(my $dbh = $self->_dbh) {
621 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
629 return ($dbh->FETCH('Active') && $dbh->ping);
635 # handle pid changes correctly
636 # NOTE: assumes $self->_dbh is a valid $dbh
640 return if $self->_conn_pid == $$;
642 $self->_dbh->{InactiveDestroy} = 1;
649 sub ensure_connected {
652 unless ($self->connected) {
653 $self->_populate_dbh;
659 Returns the dbh - a data base handle of class L<DBI>.
666 $self->ensure_connected;
670 sub _sql_maker_args {
673 return ( bindtype=>'columns', limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
678 unless ($self->_sql_maker) {
679 $self->_sql_maker(new DBIC::SQL::Abstract( $self->_sql_maker_args ));
681 return $self->_sql_maker;
686 my @info = @{$self->_connect_info || []};
687 $self->_dbh($self->_connect(@info));
689 if(ref $self eq 'DBIx::Class::Storage::DBI') {
690 my $driver = $self->_dbh->{Driver}->{Name};
691 if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
692 bless $self, "DBIx::Class::Storage::DBI::${driver}";
693 $self->_rebless() if $self->can('_rebless');
697 # if on-connect sql statements are given execute them
698 foreach my $sql_statement (@{$self->on_connect_do || []}) {
699 $self->debugobj->query_start($sql_statement) if $self->debug();
700 $self->_dbh->do($sql_statement);
701 $self->debugobj->query_end($sql_statement) if $self->debug();
704 # Rebless after we connect to the database, so we can take advantage of
706 if(ref $self eq 'DBIx::Class::Storage::DBI') {
707 my $driver = $self->_dbh->{Driver}->{Name};
708 if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
709 bless $self, "DBIx::Class::Storage::DBI::${driver}";
710 $self->_rebless() if $self->can('_rebless');
714 $self->_conn_pid($$);
715 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
719 my ($self, @info) = @_;
721 $self->throw_exception("You failed to provide any connection info")
724 my ($old_connect_via, $dbh);
726 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
727 $old_connect_via = $DBI::connect_via;
728 $DBI::connect_via = 'connect';
732 if(ref $info[0] eq 'CODE') {
736 $dbh = DBI->connect(@info);
737 $dbh->{RaiseError} = 1;
738 $dbh->{PrintError} = 0;
739 $dbh->{PrintWarn} = 0;
743 $DBI::connect_via = $old_connect_via if $old_connect_via;
746 $self->throw_exception("DBI Connection failed: " . ($@ || $DBI::errstr));
753 my ($self, $dbh) = @_;
754 if ($dbh->{AutoCommit}) {
755 $self->debugobj->txn_begin()
763 $self->dbh_do($self->can('_dbh_txn_begin'))
764 if $self->{transaction_depth}++ == 0;
767 sub _dbh_txn_commit {
768 my ($self, $dbh) = @_;
769 if ($self->{transaction_depth} == 0) {
770 unless ($dbh->{AutoCommit}) {
771 $self->debugobj->txn_commit()
777 if (--$self->{transaction_depth} == 0) {
778 $self->debugobj->txn_commit()
787 $self->dbh_do($self->can('_dbh_txn_commit'));
790 sub _dbh_txn_rollback {
791 my ($self, $dbh) = @_;
792 if ($self->{transaction_depth} == 0) {
793 unless ($dbh->{AutoCommit}) {
794 $self->debugobj->txn_rollback()
800 if (--$self->{transaction_depth} == 0) {
801 $self->debugobj->txn_rollback()
806 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
814 eval { $self->dbh_do($self->can('_dbh_txn_rollback')) };
817 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
818 $error =~ /$exception_class/ and $self->throw_exception($error);
819 $self->{transaction_depth} = 0; # ensure that a failed rollback
820 $self->throw_exception($error); # resets the transaction depth
824 # This used to be the top-half of _execute. It was split out to make it
825 # easier to override in NoBindVars without duping the rest. It takes up
826 # all of _execute's args, and emits $sql, @bind.
827 sub _prep_for_execute {
828 my ($self, $op, $extra_bind, $ident, @args) = @_;
830 my ($sql, @bind) = $self->sql_maker->$op($ident, @args);
832 map { ref $_ eq 'ARRAY' ? $_ : [ '!!dummy', $_ ] } @$extra_bind)
834 @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
836 return ($sql, @bind);
840 my ($self, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
842 if( blessed($ident) && $ident->isa("DBIx::Class::ResultSource") )
844 $ident = $ident->from();
847 my ($sql, @bind) = $self->sql_maker->$op($ident, @args);
849 map { ref $_ eq 'ARRAY' ? $_ : [ '!!dummy', $_ ] } @$extra_bind)
853 map { defined ($_ && $_->[1]) ? qq{'$_->[1]'} : q{'NULL'} } @bind;
854 $self->debugobj->query_start($sql, @debug_bind);
856 my $sth = eval { $self->sth($sql,$op) };
859 $self->throw_exception(
860 'no sth generated via sql (' . ($@ || $self->_dbh->errstr) . "): $sql"
870 my $placeholder_index = 1;
872 foreach my $bound (@bind) {
875 my($column_name, @data) = @$bound;
877 if( $bind_attributes ) {
878 $attributes = $bind_attributes->{$column_name}
879 if defined $bind_attributes->{$column_name};
882 foreach my $data (@data)
884 $data = ref $data ? ''.$data : $data; # stringify args
886 $sth->bind_param($placeholder_index, $data, $attributes);
887 $placeholder_index++;
894 $self->throw_exception("Error executing '$sql': ".($@ || $sth->errstr));
897 $self->throw_exception("'$sql' did not generate a statement.");
901 map { defined ($_ && $_->[1]) ? qq{'$_->[1]'} : q{'NULL'} } @bind;
902 $self->debugobj->query_end($sql, @debug_bind);
904 return (wantarray ? ($rv, $sth, @bind) : $rv);
908 my ($self, $source, $to_insert) = @_;
910 my $ident = $source->from;
911 my $bind_attributes = $self->source_bind_attributes($source);
913 $self->throw_exception(
914 "Couldn't insert ".join(', ',
915 map "$_ => $to_insert->{$_}", keys %$to_insert
917 ) unless ($self->_execute('insert' => [], $source, $bind_attributes, $to_insert));
921 ## Still not quite perfect, and EXPERIMENTAL
922 ## Currently it is assumed that all values passed will be "normal", i.e. not
923 ## scalar refs, or at least, all the same type as the first set, the statement is
924 ## only prepped once.
926 my ($self, $source, $cols, $data) = @_;
928 my $table = $source->from;
929 @colvalues{@$cols} = (0..$#$cols);
930 my ($sql, @bind) = $self->sql_maker->insert($table, \%colvalues);
933 my @debug_bind = map { defined $_->[1] ? qq{$_->[1]} : q{'NULL'} } @bind;
934 $self->debugobj->query_start($sql, @debug_bind);
936 my $sth = $self->sth($sql);
938 # @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
942 ## This must be an arrayref, else nothing works!
944 my $tuple_status = [];
947 ##print STDERR Dumper( $data, $sql, [@bind] );
955 # $sth->execute_array({
957 # ArrayTupleFetch => sub {
959 # my $values = shift @$data;
960 # return if !$values;
961 # return [ @{$values}[@bind] ];
964 # ArrayTupleStatus => $tuple_status,
968 ## Get the bind_attributes, if any exist
969 my $bind_attributes = $self->source_bind_attributes($source);
971 ## Bind the values and execute
974 my $placeholder_index = 1;
976 foreach my $bound (@bind) {
979 my ($column_name, $data_index) = @$bound;
981 if( $bind_attributes ) {
982 $attributes = $bind_attributes->{$column_name}
983 if defined $bind_attributes->{$column_name};
986 my @data = map { $_->[$data_index] } @$data;
988 $sth->bind_param_array( $placeholder_index, [@data], $attributes );
989 $placeholder_index++;
991 $sth->execute_array( {ArrayTupleStatus => $tuple_status} );
995 if ($@ || !defined $rv) {
997 foreach my $tuple (@$tuple_status)
999 $errors .= "\n" . $tuple->[1] if(ref $tuple);
1001 $self->throw_exception("Error executing '$sql': ".($@ || $errors));
1004 $self->throw_exception("'$sql' did not generate a statement.");
1007 my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind;
1008 $self->debugobj->query_end($sql, @debug_bind);
1010 return (wantarray ? ($rv, $sth, @bind) : $rv);
1014 my $self = shift @_;
1015 my $source = shift @_;
1016 my $bind_attributes = $self->source_bind_attributes($source);
1018 return $self->_execute('update' => [], $source, $bind_attributes, @_);
1023 my $self = shift @_;
1024 my $source = shift @_;
1026 my $bind_attrs = {}; ## If ever it's needed...
1028 return $self->_execute('delete' => [], $source, $bind_attrs, @_);
1032 my ($self, $ident, $select, $condition, $attrs) = @_;
1033 my $order = $attrs->{order_by};
1034 if (ref $condition eq 'SCALAR') {
1035 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
1037 if (exists $attrs->{group_by} || $attrs->{having}) {
1039 group_by => $attrs->{group_by},
1040 having => $attrs->{having},
1041 ($order ? (order_by => $order) : ())
1044 my $bind_attrs = {}; ## Future support
1045 my @args = ('select', $attrs->{bind}, $ident, $bind_attrs, $select, $condition, $order);
1046 if ($attrs->{software_limit} ||
1047 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
1048 $attrs->{software_limit} = 1;
1050 $self->throw_exception("rows attribute must be positive if present")
1051 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
1052 push @args, $attrs->{rows}, $attrs->{offset};
1054 return $self->_execute(@args);
1057 sub source_bind_attributes {
1058 my ($self, $source) = @_;
1060 my $bind_attributes;
1061 foreach my $column ($source->columns) {
1063 my $data_type = $source->column_info($column)->{data_type} || '';
1064 $bind_attributes->{$column} = $self->bind_attribute_by_data_type($data_type)
1068 return $bind_attributes;
1075 =item Arguments: $ident, $select, $condition, $attrs
1079 Handle a SQL select statement.
1085 my ($ident, $select, $condition, $attrs) = @_;
1086 return $self->cursor->new($self, \@_, $attrs);
1091 my ($rv, $sth, @bind) = $self->_select(@_);
1092 my @row = $sth->fetchrow_array;
1093 # Need to call finish() to work round broken DBDs
1102 =item Arguments: $sql
1106 Returns a L<DBI> sth (statement handle) for the supplied SQL.
1111 my ($self, $dbh, $sql) = @_;
1113 # 3 is the if_active parameter which avoids active sth re-use
1114 my $sth = $self->disable_sth_caching
1115 ? $dbh->prepare($sql)
1116 : $dbh->prepare_cached($sql, {}, 3);
1118 $self->throw_exception(
1119 'no sth generated via sql (' . ($@ || $dbh->errstr) . "): $sql"
1126 my ($self, $sql) = @_;
1127 $self->dbh_do($self->can('_dbh_sth'), $sql);
1130 sub _dbh_columns_info_for {
1131 my ($self, $dbh, $table) = @_;
1133 if ($dbh->can('column_info')) {
1136 my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
1137 my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
1139 while ( my $info = $sth->fetchrow_hashref() ){
1141 $column_info{data_type} = $info->{TYPE_NAME};
1142 $column_info{size} = $info->{COLUMN_SIZE};
1143 $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
1144 $column_info{default_value} = $info->{COLUMN_DEF};
1145 my $col_name = $info->{COLUMN_NAME};
1146 $col_name =~ s/^\"(.*)\"$/$1/;
1148 $result{$col_name} = \%column_info;
1151 return \%result if !$@ && scalar keys %result;
1155 my $sth = $dbh->prepare("SELECT * FROM $table WHERE 1=0");
1157 my @columns = @{$sth->{NAME_lc}};
1158 for my $i ( 0 .. $#columns ){
1160 my $type_num = $sth->{TYPE}->[$i];
1162 if(defined $type_num && $dbh->can('type_info')) {
1163 my $type_info = $dbh->type_info($type_num);
1164 $type_name = $type_info->{TYPE_NAME} if $type_info;
1166 $column_info{data_type} = $type_name ? $type_name : $type_num;
1167 $column_info{size} = $sth->{PRECISION}->[$i];
1168 $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
1170 if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
1171 $column_info{data_type} = $1;
1172 $column_info{size} = $2;
1175 $result{$columns[$i]} = \%column_info;
1181 sub columns_info_for {
1182 my ($self, $table) = @_;
1183 $self->dbh_do($self->can('_dbh_columns_info_for'), $table);
1186 =head2 last_insert_id
1188 Return the row id of the last insert.
1192 sub _dbh_last_insert_id {
1193 my ($self, $dbh, $source, $col) = @_;
1194 # XXX This is a SQLite-ism as a default... is there a DBI-generic way?
1195 $dbh->func('last_insert_rowid');
1198 sub last_insert_id {
1200 $self->dbh_do($self->can('_dbh_last_insert_id'), @_);
1205 Returns the database driver name.
1209 sub sqlt_type { shift->dbh->{Driver}->{Name} }
1211 =head2 bind_attribute_by_data_type
1213 Given a datatype from column info, returns a database specific bind attribute for
1214 $dbh->bind_param($val,$attribute) or nothing if we will let the database planner
1217 Generally only needed for special case column types, like bytea in postgres.
1221 sub bind_attribute_by_data_type {
1225 =head2 create_ddl_dir (EXPERIMENTAL)
1229 =item Arguments: $schema \@databases, $version, $directory, $preversion, $sqlt_args
1233 Creates a SQL file based on the Schema, for each of the specified
1234 database types, in the given directory.
1236 Note that this feature is currently EXPERIMENTAL and may not work correctly
1237 across all databases, or fully handle complex relationships.
1243 my ($self, $schema, $databases, $version, $dir, $preversion, $sqltargs) = @_;
1245 if(!$dir || !-d $dir)
1247 warn "No directory given, using ./\n";
1250 $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
1251 $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
1252 $version ||= $schema->VERSION || '1.x';
1253 $sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} };
1255 eval "use SQL::Translator";
1256 $self->throw_exception("Can't create a ddl file without SQL::Translator: $@") if $@;
1258 my $sqlt = SQL::Translator->new({
1260 add_drop_table => 1,
1262 foreach my $db (@$databases)
1265 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
1266 # $sqlt->parser_args({'DBIx::Class' => $schema);
1267 $sqlt = $self->configure_sqlt($sqlt, $db);
1268 $sqlt->data($schema);
1269 $sqlt->producer($db);
1272 my $filename = $schema->ddl_filename($db, $dir, $version);
1275 warn("$filename already exists, skipping $db");
1279 my $output = $sqlt->translate;
1282 warn("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
1285 if(!open($file, ">$filename"))
1287 $self->throw_exception("Can't open $filename for writing ($!)");
1290 print $file $output;
1295 eval "use SQL::Translator::Diff";
1298 warn("Can't diff versions without SQL::Translator::Diff: $@");
1302 my $prefilename = $schema->ddl_filename($db, $dir, $preversion);
1303 # print "Previous version $prefilename\n";
1304 if(!-e $prefilename)
1306 warn("No previous schema file found ($prefilename)");
1309 #### We need to reparse the SQLite file we just wrote, so that
1310 ## Diff doesnt get all confoosed, and Diff is *very* confused.
1311 ## FIXME: rip Diff to pieces!
1312 # my $target_schema = $sqlt->schema;
1313 # unless ( $target_schema->name ) {
1314 # $target_schema->name( $filename );
1317 push @input, {file => $prefilename, parser => $db};
1318 push @input, {file => $filename, parser => $db};
1319 my ( $source_schema, $source_db, $target_schema, $target_db ) = map {
1320 my $file = $_->{'file'};
1321 my $parser = $_->{'parser'};
1323 my $t = SQL::Translator->new;
1326 $t->parser( $parser ) or die $t->error;
1327 my $out = $t->translate( $file ) or die $t->error;
1328 my $schema = $t->schema;
1329 unless ( $schema->name ) {
1330 $schema->name( $file );
1335 my $diff = SQL::Translator::Diff::schema_diff($source_schema, $db,
1336 $target_schema, $db,
1339 my $difffile = $schema->ddl_filename($db, $dir, $version, $preversion);
1340 print STDERR "Diff: $difffile: $db, $dir, $version, $preversion \n";
1343 warn("$difffile already exists, skipping");
1346 if(!open $file, ">$difffile")
1348 $self->throw_exception("Can't write to $difffile ($!)");
1357 sub configure_sqlt() {
1360 my $db = shift || $self->sqlt_type;
1361 if ($db eq 'PostgreSQL') {
1362 $tr->quote_table_names(0);
1363 $tr->quote_field_names(0);
1368 =head2 deployment_statements
1372 =item Arguments: $schema, $type, $version, $directory, $sqlt_args
1376 Returns the statements used by L</deploy> and L<DBIx::Class::Schema/deploy>.
1377 The database driver name is given by C<$type>, though the value from
1378 L</sqlt_type> is used if it is not specified.
1380 C<$directory> is used to return statements from files in a previously created
1381 L</create_ddl_dir> directory and is optional. The filenames are constructed
1382 from L<DBIx::Class::Schema/ddl_filename>, the schema name and the C<$version>.
1384 If no C<$directory> is specified then the statements are constructed on the
1385 fly using L<SQL::Translator> and C<$version> is ignored.
1387 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>.
1391 sub deployment_statements {
1392 my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
1393 # Need to be connected to get the correct sqlt_type
1394 $self->ensure_connected() unless $type;
1395 $type ||= $self->sqlt_type;
1396 $version ||= $schema->VERSION || '1.x';
1398 my $filename = $schema->ddl_filename($type, $dir, $version);
1402 open($file, "<$filename")
1403 or $self->throw_exception("Can't open $filename ($!)");
1406 return join('', @rows);
1409 eval "use SQL::Translator";
1412 eval "use SQL::Translator::Parser::DBIx::Class;";
1413 $self->throw_exception($@) if $@;
1414 eval "use SQL::Translator::Producer::${type};";
1415 $self->throw_exception($@) if $@;
1417 # sources needs to be a parser arg, but for simplicty allow at top level
1419 $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources}
1420 if exists $sqltargs->{sources};
1422 my $tr = SQL::Translator->new(%$sqltargs);
1423 SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
1424 return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
1427 $self->throw_exception("No SQL::Translator, and no Schema file found, aborting deploy");
1433 my ($self, $schema, $type, $sqltargs, $dir) = @_;
1434 foreach my $statement ( $self->deployment_statements($schema, $type, undef, $dir, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
1435 for ( split(";\n", $statement)) {
1436 next if($_ =~ /^--/);
1438 # next if($_ =~ /^DROP/m);
1439 next if($_ =~ /^BEGIN TRANSACTION/m);
1440 next if($_ =~ /^COMMIT/m);
1441 next if $_ =~ /^\s+$/; # skip whitespace only
1442 $self->debugobj->query_start($_) if $self->debug;
1443 $self->dbh->do($_) or warn "SQL was:\n $_"; # XXX exceptions?
1444 $self->debugobj->query_end($_) if $self->debug;
1449 =head2 datetime_parser
1451 Returns the datetime parser class
1455 sub datetime_parser {
1457 return $self->{datetime_parser} ||= $self->build_datetime_parser(@_);
1460 =head2 datetime_parser_type
1462 Defines (returns) the datetime parser class - currently hardwired to
1463 L<DateTime::Format::MySQL>
1467 sub datetime_parser_type { "DateTime::Format::MySQL"; }
1469 =head2 build_datetime_parser
1471 See L</datetime_parser>
1475 sub build_datetime_parser {
1477 my $type = $self->datetime_parser_type(@_);
1479 $self->throw_exception("Couldn't load ${type}: $@") if $@;
1485 return if !$self->_dbh;
1494 The module defines a set of methods within the DBIC::SQL::Abstract
1495 namespace. These build on L<SQL::Abstract::Limit> to provide the
1496 SQL query functions.
1498 The following methods are extended:-
1512 See L</connect_info> for details.
1513 For setting, this method is deprecated in favor of L</connect_info>.
1517 See L</connect_info> for details.
1518 For setting, this method is deprecated in favor of L</connect_info>.
1522 See L</connect_info> for details.
1523 For setting, this method is deprecated in favor of L</connect_info>.
1529 Matt S. Trout <mst@shadowcatsystems.co.uk>
1531 Andy Grundman <andy@hybridized.org>
1535 You may distribute this code under the same terms as Perl itself.