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;
14 __PACKAGE__->mk_group_accessors(
16 qw/_connect_info _dbh _sql_maker _sql_maker_opts _conn_pid _conn_tid
17 disable_sth_caching cursor on_connect_do transaction_depth/
22 package DBIC::SQL::Abstract; # Would merge upstream, but nate doesn't reply :(
24 use base qw/SQL::Abstract::Limit/;
26 # This prevents the caching of $dbh in S::A::L, I believe
28 my $self = shift->SUPER::new(@_);
30 # If limit_dialect is a ref (like a $dbh), go ahead and replace
31 # it with what it resolves to:
32 $self->{limit_dialect} = $self->_find_syntax($self->{limit_dialect})
33 if ref $self->{limit_dialect};
39 my ($self, $sql, $order, $rows, $offset ) = @_;
42 my $last = $rows + $offset;
43 my ( $order_by ) = $self->_order_by( $order );
48 SELECT Q1.*, ROW_NUMBER() OVER( ) AS ROW_NUM FROM (
53 WHERE ROW_NUM BETWEEN $offset AND $last
59 # While we're at it, this should make LIMIT queries more efficient,
60 # without digging into things too deeply
61 use Scalar::Util 'blessed';
63 my ($self, $syntax) = @_;
64 my $dbhname = blessed($syntax) ? $syntax->{Driver}{Name} : $syntax;
65 if(ref($self) && $dbhname && $dbhname eq 'DB2') {
66 return 'RowNumberOver';
69 $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
73 my ($self, $table, $fields, $where, $order, @rest) = @_;
74 $table = $self->_quote($table) unless ref($table);
75 local $self->{rownum_hack_count} = 1
76 if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
77 @rest = (-1) unless defined $rest[0];
78 die "LIMIT 0 Does Not Compute" if $rest[0] == 0;
79 # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
80 local $self->{having_bind} = [];
81 my ($sql, @ret) = $self->SUPER::select(
82 $table, $self->_recurse_fields($fields), $where, $order, @rest
84 return wantarray ? ($sql, @ret, @{$self->{having_bind}}) : $sql;
90 $table = $self->_quote($table) unless ref($table);
91 $self->SUPER::insert($table, @_);
97 $table = $self->_quote($table) unless ref($table);
98 $self->SUPER::update($table, @_);
104 $table = $self->_quote($table) unless ref($table);
105 $self->SUPER::delete($table, @_);
111 return $_[1].$self->_order_by($_[2]);
113 return $self->SUPER::_emulate_limit(@_);
117 sub _recurse_fields {
118 my ($self, $fields) = @_;
119 my $ref = ref $fields;
120 return $self->_quote($fields) unless $ref;
121 return $$fields if $ref eq 'SCALAR';
123 if ($ref eq 'ARRAY') {
124 return join(', ', map {
125 $self->_recurse_fields($_)
126 .(exists $self->{rownum_hack_count}
127 ? ' AS col'.$self->{rownum_hack_count}++
130 } elsif ($ref eq 'HASH') {
131 foreach my $func (keys %$fields) {
132 return $self->_sqlcase($func)
133 .'( '.$self->_recurse_fields($fields->{$func}).' )';
142 if (ref $_[0] eq 'HASH') {
143 if (defined $_[0]->{group_by}) {
144 $ret = $self->_sqlcase(' group by ')
145 .$self->_recurse_fields($_[0]->{group_by});
147 if (defined $_[0]->{having}) {
149 ($frag, @extra) = $self->_recurse_where($_[0]->{having});
150 push(@{$self->{having_bind}}, @extra);
151 $ret .= $self->_sqlcase(' having ').$frag;
153 if (defined $_[0]->{order_by}) {
154 $ret .= $self->_order_by($_[0]->{order_by});
156 } elsif (ref $_[0] eq 'SCALAR') {
157 $ret = $self->_sqlcase(' order by ').${ $_[0] };
158 } elsif (ref $_[0] eq 'ARRAY' && @{$_[0]}) {
159 my @order = @{+shift};
160 $ret = $self->_sqlcase(' order by ')
162 my $r = $self->_order_by($_, @_);
163 $r =~ s/^ ?ORDER BY //i;
167 $ret = $self->SUPER::_order_by(@_);
172 sub _order_directions {
173 my ($self, $order) = @_;
174 $order = $order->{order_by} if ref $order eq 'HASH';
175 return $self->SUPER::_order_directions($order);
179 my ($self, $from) = @_;
180 if (ref $from eq 'ARRAY') {
181 return $self->_recurse_from(@$from);
182 } elsif (ref $from eq 'HASH') {
183 return $self->_make_as($from);
185 return $from; # would love to quote here but _table ends up getting called
186 # twice during an ->select without a limit clause due to
187 # the way S::A::Limit->select works. should maybe consider
188 # bypassing this and doing S::A::select($self, ...) in
189 # our select method above. meantime, quoting shims have
190 # been added to select/insert/update/delete here
195 my ($self, $from, @join) = @_;
197 push(@sqlf, $self->_make_as($from));
198 foreach my $j (@join) {
201 # check whether a join type exists
202 my $join_clause = '';
203 my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
204 if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
205 $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
207 $join_clause = ' JOIN ';
209 push(@sqlf, $join_clause);
211 if (ref $to eq 'ARRAY') {
212 push(@sqlf, '(', $self->_recurse_from(@$to), ')');
214 push(@sqlf, $self->_make_as($to));
216 push(@sqlf, ' ON ', $self->_join_condition($on));
218 return join('', @sqlf);
222 my ($self, $from) = @_;
223 return join(' ', map { (ref $_ eq 'SCALAR' ? $$_ : $self->_quote($_)) }
224 reverse each %{$self->_skip_options($from)});
228 my ($self, $hash) = @_;
230 $clean_hash->{$_} = $hash->{$_}
231 for grep {!/^-/} keys %$hash;
235 sub _join_condition {
236 my ($self, $cond) = @_;
237 if (ref $cond eq 'HASH') {
242 # XXX no throw_exception() in this package and croak() fails with strange results
243 Carp::croak(ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
244 if ref($v) ne 'SCALAR';
248 my $x = '= '.$self->_quote($v); $j{$_} = \$x;
251 return scalar($self->_recurse_where(\%j));
252 } elsif (ref $cond eq 'ARRAY') {
253 return join(' OR ', map { $self->_join_condition($_) } @$cond);
255 die "Can't handle this yet!";
260 my ($self, $label) = @_;
261 return '' unless defined $label;
262 return "*" if $label eq '*';
263 return $label unless $self->{quote_char};
264 if(ref $self->{quote_char} eq "ARRAY"){
265 return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
266 if !defined $self->{name_sep};
267 my $sep = $self->{name_sep};
268 return join($self->{name_sep},
269 map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
270 split(/\Q$sep\E/,$label));
272 return $self->SUPER::_quote($label);
277 $self->{limit_dialect} = shift if @_;
278 return $self->{limit_dialect};
283 $self->{quote_char} = shift if @_;
284 return $self->{quote_char};
289 $self->{name_sep} = shift if @_;
290 return $self->{name_sep};
293 } # End of BEGIN block
297 DBIx::Class::Storage::DBI - DBI storage handler
303 This class represents the connection to an RDBMS via L<DBI>. See
304 L<DBIx::Class::Storage> for general information. This pod only
305 documents DBI-specific methods and behaviors.
312 my $new = shift->next::method(@_);
314 $new->cursor("DBIx::Class::Storage::DBI::Cursor");
315 $new->transaction_depth(0);
316 $new->_sql_maker_opts({});
317 $new->{_in_dbh_do} = 0;
318 $new->{_dbh_gen} = 0;
325 The arguments of C<connect_info> are always a single array reference.
327 This is normally accessed via L<DBIx::Class::Schema/connection>, which
328 encapsulates its argument list in an arrayref before calling
329 C<connect_info> here.
331 The arrayref can either contain the same set of arguments one would
332 normally pass to L<DBI/connect>, or a lone code reference which returns
333 a connected database handle.
335 In either case, if the final argument in your connect_info happens
336 to be a hashref, C<connect_info> will look there for several
337 connection-specific options:
343 This can be set to an arrayref of literal sql statements, which will
344 be executed immediately after making the connection to the database
345 every time we [re-]connect.
347 =item disable_sth_caching
349 If set to a true value, this option will disable the caching of
350 statement handles via L<DBI/prepare_cached>.
354 Sets the limit dialect. This is useful for JDBC-bridge among others
355 where the remote SQL-dialect cannot be determined by the name of the
360 Specifies what characters to use to quote table and column names. If
361 you use this you will want to specify L<name_sep> as well.
363 quote_char expects either a single character, in which case is it is placed
364 on either side of the table/column, or an arrayref of length 2 in which case the
365 table/column name is placed between the elements.
367 For example under MySQL you'd use C<quote_char =E<gt> '`'>, and user SQL Server you'd
368 use C<quote_char =E<gt> [qw/[ ]/]>.
372 This only needs to be used in conjunction with L<quote_char>, and is used to
373 specify the charecter that seperates elements (schemas, tables, columns) from
374 each other. In most cases this is simply a C<.>.
378 These options can be mixed in with your other L<DBI> connection attributes,
379 or placed in a seperate hashref after all other normal L<DBI> connection
382 Every time C<connect_info> is invoked, any previous settings for
383 these options will be cleared before setting the new ones, regardless of
384 whether any options are specified in the new C<connect_info>.
386 Important note: DBIC expects the returned database handle provided by
387 a subref argument to have RaiseError set on it. If it doesn't, things
388 might not work very well, YMMV. If you don't use a subref, DBIC will
389 force this setting for you anyways. Setting HandleError to anything
390 other than simple exception object wrapper might cause problems too.
394 # Simple SQLite connection
395 ->connect_info([ 'dbi:SQLite:./foo.db' ]);
398 ->connect_info([ sub { DBI->connect(...) } ]);
400 # A bit more complicated
407 { quote_char => q{"}, name_sep => q{.} },
411 # Equivalent to the previous example
417 { AutoCommit => 0, quote_char => q{"}, name_sep => q{.} },
421 # Subref + DBIC-specific connection options
424 sub { DBI->connect(...) },
428 on_connect_do => ['SET search_path TO myschema,otherschema,public'],
429 disable_sth_caching => 1,
437 my ($self, $info_arg) = @_;
439 return $self->_connect_info if !$info_arg;
441 # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
442 # the new set of options
443 $self->_sql_maker(undef);
444 $self->_sql_maker_opts({});
446 my $info = [ @$info_arg ]; # copy because we can alter it
447 my $last_info = $info->[-1];
448 if(ref $last_info eq 'HASH') {
449 for my $storage_opt (qw/on_connect_do disable_sth_caching/) {
450 if(my $value = delete $last_info->{$storage_opt}) {
451 $self->$storage_opt($value);
454 for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
455 if(my $opt_val = delete $last_info->{$sql_maker_opt}) {
456 $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
460 # Get rid of any trailing empty hashref
461 pop(@$info) if !keys %$last_info;
464 $self->_connect_info($info);
469 This method is deprecated in favor of setting via L</connect_info>.
473 Arguments: $subref, @extra_coderef_args?
475 Execute the given subref using the new exception-based connection management.
477 The first two arguments will be the storage object that C<dbh_do> was called
478 on and a database handle to use. Any additional arguments will be passed
479 verbatim to the called subref as arguments 2 and onwards.
481 Using this (instead of $self->_dbh or $self->dbh) ensures correct
482 exception handling and reconnection (or failover in future subclasses).
484 Your subref should have no side-effects outside of the database, as
485 there is the potential for your subref to be partially double-executed
486 if the database connection was stale/dysfunctional.
490 my @stuff = $schema->storage->dbh_do(
492 my ($storage, $dbh, @cols) = @_;
493 my $cols = join(q{, }, @cols);
494 $dbh->selectrow_array("SELECT $cols FROM foo");
505 ref $coderef eq 'CODE' or $self->throw_exception
506 ('$coderef must be a CODE reference');
508 return $coderef->($self, $self->_dbh, @_) if $self->{_in_dbh_do};
509 local $self->{_in_dbh_do} = 1;
512 my $want_array = wantarray;
515 $self->_verify_pid if $self->_dbh;
516 $self->_populate_dbh if !$self->_dbh;
518 @result = $coderef->($self, $self->_dbh, @_);
520 elsif(defined $want_array) {
521 $result[0] = $coderef->($self, $self->_dbh, @_);
524 $coderef->($self, $self->_dbh, @_);
529 if(!$exception) { return $want_array ? @result : $result[0] }
531 $self->throw_exception($exception) if $self->connected;
533 # We were not connected - reconnect and retry, but let any
534 # exception fall right through this time
535 $self->_populate_dbh;
536 $coderef->($self, $self->_dbh, @_);
539 # This is basically a blend of dbh_do above and DBIx::Class::Storage::txn_do.
540 # It also informs dbh_do to bypass itself while under the direction of txn_do,
541 # via $self->{_in_dbh_do} (this saves some redundant eval and errorcheck, etc)
546 ref $coderef eq 'CODE' or $self->throw_exception
547 ('$coderef must be a CODE reference');
549 local $self->{_in_dbh_do} = 1;
552 my $want_array = wantarray;
557 $self->_verify_pid if $self->_dbh;
558 $self->_populate_dbh if !$self->_dbh;
562 @result = $coderef->(@_);
564 elsif(defined $want_array) {
565 $result[0] = $coderef->(@_);
574 if(!$exception) { return $want_array ? @result : $result[0] }
576 if($tried++ > 0 || $self->connected) {
577 eval { $self->txn_rollback };
578 my $rollback_exception = $@;
579 if($rollback_exception) {
580 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
581 $self->throw_exception($exception) # propagate nested rollback
582 if $rollback_exception =~ /$exception_class/;
584 $self->throw_exception(
585 "Transaction aborted: ${exception}. "
586 . "Rollback failed: ${rollback_exception}"
589 $self->throw_exception($exception)
592 # We were not connected, and was first try - reconnect and retry
594 $self->_populate_dbh;
600 Our C<disconnect> method also performs a rollback first if the
601 database is not in C<AutoCommit> mode.
608 if( $self->connected ) {
609 $self->_dbh->rollback unless $self->_dbh->{AutoCommit};
610 $self->_dbh->disconnect;
619 if(my $dbh = $self->_dbh) {
620 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
628 return ($dbh->FETCH('Active') && $dbh->ping);
634 # handle pid changes correctly
635 # NOTE: assumes $self->_dbh is a valid $dbh
639 return if $self->_conn_pid == $$;
641 $self->_dbh->{InactiveDestroy} = 1;
648 sub ensure_connected {
651 unless ($self->connected) {
652 $self->_populate_dbh;
658 Returns the dbh - a data base handle of class L<DBI>.
665 $self->ensure_connected;
669 sub _sql_maker_args {
672 return ( bindtype=>'columns', limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
677 unless ($self->_sql_maker) {
678 $self->_sql_maker(new DBIC::SQL::Abstract( $self->_sql_maker_args ));
680 return $self->_sql_maker;
685 my @info = @{$self->_connect_info || []};
686 $self->_dbh($self->_connect(@info));
688 if(ref $self eq 'DBIx::Class::Storage::DBI') {
689 my $driver = $self->_dbh->{Driver}->{Name};
690 if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
691 bless $self, "DBIx::Class::Storage::DBI::${driver}";
692 $self->_rebless() if $self->can('_rebless');
696 # if on-connect sql statements are given execute them
697 foreach my $sql_statement (@{$self->on_connect_do || []}) {
698 $self->debugobj->query_start($sql_statement) if $self->debug();
699 $self->_dbh->do($sql_statement);
700 $self->debugobj->query_end($sql_statement) if $self->debug();
703 $self->_conn_pid($$);
704 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
708 my ($self, @info) = @_;
710 $self->throw_exception("You failed to provide any connection info")
713 my ($old_connect_via, $dbh);
715 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
716 $old_connect_via = $DBI::connect_via;
717 $DBI::connect_via = 'connect';
721 if(ref $info[0] eq 'CODE') {
725 $dbh = DBI->connect(@info);
726 $dbh->{RaiseError} = 1;
727 $dbh->{PrintError} = 0;
728 $dbh->{PrintWarn} = 0;
732 $DBI::connect_via = $old_connect_via if $old_connect_via;
735 $self->throw_exception("DBI Connection failed: " . ($@ || $DBI::errstr));
742 my ($self, $dbh) = @_;
743 if ($dbh->{AutoCommit}) {
744 $self->debugobj->txn_begin()
752 $self->dbh_do($self->can('_dbh_txn_begin'))
753 if $self->{transaction_depth}++ == 0;
756 sub _dbh_txn_commit {
757 my ($self, $dbh) = @_;
758 if ($self->{transaction_depth} == 0) {
759 unless ($dbh->{AutoCommit}) {
760 $self->debugobj->txn_commit()
766 if (--$self->{transaction_depth} == 0) {
767 $self->debugobj->txn_commit()
776 $self->dbh_do($self->can('_dbh_txn_commit'));
779 sub _dbh_txn_rollback {
780 my ($self, $dbh) = @_;
781 if ($self->{transaction_depth} == 0) {
782 unless ($dbh->{AutoCommit}) {
783 $self->debugobj->txn_rollback()
789 if (--$self->{transaction_depth} == 0) {
790 $self->debugobj->txn_rollback()
795 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
803 eval { $self->dbh_do($self->can('_dbh_txn_rollback')) };
806 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
807 $error =~ /$exception_class/ and $self->throw_exception($error);
808 $self->{transaction_depth} = 0; # ensure that a failed rollback
809 $self->throw_exception($error); # resets the transaction depth
813 # This used to be the top-half of _execute. It was split out to make it
814 # easier to override in NoBindVars without duping the rest. It takes up
815 # all of _execute's args, and emits $sql, @bind.
816 sub _prep_for_execute {
817 my ($self, $op, $extra_bind, $ident, @args) = @_;
819 my ($sql, @bind) = $self->sql_maker->$op($ident, @args);
821 map { ref $_ eq 'ARRAY' ? $_ : [ '!!dummy', $_ ] } @$extra_bind)
823 @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
825 return ($sql, @bind);
829 my ($self, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
831 my ($sql, @bind) = $self->sql_maker->$op($ident, @args);
833 map { ref $_ eq 'ARRAY' ? $_ : [ '!!dummy', $_ ] } @$extra_bind)
837 map { defined ($_ && $_->[1]) ? qq{'$_->[1]'} : q{'NULL'} } @bind;
838 $self->debugobj->query_start($sql, @debug_bind);
840 my $sth = eval { $self->sth($sql,$op) };
843 $self->throw_exception(
844 'no sth generated via sql (' . ($@ || $self->_dbh->errstr) . "): $sql"
854 my $placeholder_index = 1;
856 foreach my $bound (@bind) {
859 my($column_name, @data) = @$bound;
861 if( $bind_attributes ) {
862 $attributes = $bind_attributes->{$column_name}
863 if defined $bind_attributes->{$column_name};
866 foreach my $data (@data)
868 $data = ref $data ? ''.$data : $data; # stringify args
870 $sth->bind_param($placeholder_index, $data, $attributes);
871 $placeholder_index++;
878 $self->throw_exception("Error executing '$sql': ".($@ || $sth->errstr));
881 $self->throw_exception("'$sql' did not generate a statement.");
885 map { defined ($_ && $_->[1]) ? qq{'$_->[1]'} : q{'NULL'} } @bind;
886 $self->debugobj->query_end($sql, @debug_bind);
888 return (wantarray ? ($rv, $sth, @bind) : $rv);
892 my ($self, $source, $to_insert) = @_;
894 my $ident = $source->from;
896 foreach my $column ($source->columns) {
898 my $data_type = $source->column_info($column)->{data_type} || '';
899 $bind_attributes->{$column} = $self->bind_attribute_by_data_type($data_type)
903 $self->throw_exception(
904 "Couldn't insert ".join(', ',
905 map "$_ => $to_insert->{$_}", keys %$to_insert
907 ) unless ($self->_execute('insert' => [], $ident, $bind_attributes, $to_insert));
911 ## Still not quite perfect, and EXPERIMENTAL
912 ## Currently it is assumed that all values passed will be "normal", i.e. not
913 ## scalar refs, or at least, all the same type as the first set, the statement is
914 ## only prepped once.
916 my ($self, $source, $cols, $data) = @_;
918 my $table = $source->from;
919 @colvalues{@$cols} = (0..$#$cols);
920 my ($sql, @bind) = $self->sql_maker->insert($table, \%colvalues);
923 my @debug_bind = map { defined $_->[1] ? qq{$_->[1]} : q{'NULL'} } @bind;
924 $self->debugobj->query_start($sql, @debug_bind);
926 my $sth = $self->sth($sql);
928 # @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
932 ## This must be an arrayref, else nothing works!
934 my $tuple_status = [];
937 ##print STDERR Dumper( $data, $sql, [@bind] );
945 # $sth->execute_array({
947 # ArrayTupleFetch => sub {
949 # my $values = shift @$data;
950 # return if !$values;
951 # return [ @{$values}[@bind] ];
954 # ArrayTupleStatus => $tuple_status,
958 ## Get the bind_attributes, if any exist
961 foreach my $column ($source->columns) {
963 my $data_type = $source->column_info($column)->{data_type} || '';
964 $bind_attributes->{$column} = $self->bind_attribute_by_data_type($data_type)
968 ## Bind the values and execute
972 my $placeholder_index = 1;
974 foreach my $bound (@bind) {
977 my ($column_name, $data_index) = @$bound;
979 if( $bind_attributes ) {
980 $attributes = $bind_attributes->{$column_name}
981 if defined $bind_attributes->{$column_name};
984 my @data = map { $_->[$data_index] } @$data;
986 $sth->bind_param_array( $placeholder_index, [@data], $attributes );
987 $placeholder_index++;
989 $sth->execute_array( {ArrayTupleStatus => $tuple_status} );
993 #print STDERR Dumper($tuple_status);
994 #print STDERR "RV: $rv\n";
996 if ($@ || !defined $rv) {
998 foreach my $tuple (@$tuple_status)
1000 $errors .= "\n" . $tuple->[1] if(ref $tuple);
1002 $self->throw_exception("Error executing '$sql': ".($@ || $errors));
1005 $self->throw_exception("'$sql' did not generate a statement.");
1008 my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind;
1009 $self->debugobj->query_end($sql, @debug_bind);
1011 return (wantarray ? ($rv, $sth, @bind) : $rv);
1015 my $self = shift @_;
1016 my $source = shift @_;
1018 my $bind_attributes;
1019 foreach my $column ($source->columns) {
1021 my $data_type = $source->column_info($column)->{data_type} || '';
1022 $bind_attributes->{$column} = $self->bind_attribute_by_data_type($data_type)
1026 my $ident = $source->from;
1027 return $self->_execute('update' => [], $ident, $bind_attributes, @_);
1032 my $self = shift @_;
1033 my $source = shift @_;
1035 my $bind_attrs = {}; ## If ever it's needed...
1036 my $ident = $source->from;
1038 return $self->_execute('delete' => [], $ident, $bind_attrs, @_);
1042 my ($self, $ident, $select, $condition, $attrs) = @_;
1043 my $order = $attrs->{order_by};
1044 if (ref $condition eq 'SCALAR') {
1045 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
1047 if (exists $attrs->{group_by} || $attrs->{having}) {
1049 group_by => $attrs->{group_by},
1050 having => $attrs->{having},
1051 ($order ? (order_by => $order) : ())
1054 my $bind_attrs = {}; ## Future support
1055 my @args = ('select', $attrs->{bind}, $ident, $bind_attrs, $select, $condition, $order);
1056 if ($attrs->{software_limit} ||
1057 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
1058 $attrs->{software_limit} = 1;
1060 $self->throw_exception("rows attribute must be positive if present")
1061 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
1062 push @args, $attrs->{rows}, $attrs->{offset};
1064 return $self->_execute(@args);
1071 =item Arguments: $ident, $select, $condition, $attrs
1075 Handle a SQL select statement.
1081 my ($ident, $select, $condition, $attrs) = @_;
1082 return $self->cursor->new($self, \@_, $attrs);
1087 my ($rv, $sth, @bind) = $self->_select(@_);
1088 my @row = $sth->fetchrow_array;
1089 # Need to call finish() to work round broken DBDs
1098 =item Arguments: $sql
1102 Returns a L<DBI> sth (statement handle) for the supplied SQL.
1107 my ($self, $dbh, $sql) = @_;
1109 # 3 is the if_active parameter which avoids active sth re-use
1110 my $sth = $self->disable_sth_caching
1111 ? $dbh->prepare($sql)
1112 : $dbh->prepare_cached($sql, {}, 3);
1114 $self->throw_exception(
1115 'no sth generated via sql (' . ($@ || $dbh->errstr) . "): $sql"
1122 my ($self, $sql) = @_;
1123 $self->dbh_do($self->can('_dbh_sth'), $sql);
1126 sub _dbh_columns_info_for {
1127 my ($self, $dbh, $table) = @_;
1129 if ($dbh->can('column_info')) {
1132 my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
1133 my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
1135 while ( my $info = $sth->fetchrow_hashref() ){
1137 $column_info{data_type} = $info->{TYPE_NAME};
1138 $column_info{size} = $info->{COLUMN_SIZE};
1139 $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
1140 $column_info{default_value} = $info->{COLUMN_DEF};
1141 my $col_name = $info->{COLUMN_NAME};
1142 $col_name =~ s/^\"(.*)\"$/$1/;
1144 $result{$col_name} = \%column_info;
1147 return \%result if !$@ && scalar keys %result;
1151 my $sth = $dbh->prepare("SELECT * FROM $table WHERE 1=0");
1153 my @columns = @{$sth->{NAME_lc}};
1154 for my $i ( 0 .. $#columns ){
1156 my $type_num = $sth->{TYPE}->[$i];
1158 if(defined $type_num && $dbh->can('type_info')) {
1159 my $type_info = $dbh->type_info($type_num);
1160 $type_name = $type_info->{TYPE_NAME} if $type_info;
1162 $column_info{data_type} = $type_name ? $type_name : $type_num;
1163 $column_info{size} = $sth->{PRECISION}->[$i];
1164 $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
1166 if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
1167 $column_info{data_type} = $1;
1168 $column_info{size} = $2;
1171 $result{$columns[$i]} = \%column_info;
1177 sub columns_info_for {
1178 my ($self, $table) = @_;
1179 $self->dbh_do($self->can('_dbh_columns_info_for'), $table);
1182 =head2 last_insert_id
1184 Return the row id of the last insert.
1188 sub _dbh_last_insert_id {
1189 my ($self, $dbh, $source, $col) = @_;
1190 # XXX This is a SQLite-ism as a default... is there a DBI-generic way?
1191 $dbh->func('last_insert_rowid');
1194 sub last_insert_id {
1196 $self->dbh_do($self->can('_dbh_last_insert_id'), @_);
1201 Returns the database driver name.
1205 sub sqlt_type { shift->dbh->{Driver}->{Name} }
1207 =head2 bind_attribute_by_data_type
1209 Given a datatype from column info, returns a database specific bind attribute for
1210 $dbh->bind_param($val,$attribute) or nothing if we will let the database planner
1213 Generally only needed for special case column types, like bytea in postgres.
1217 sub bind_attribute_by_data_type {
1221 =head2 create_ddl_dir (EXPERIMENTAL)
1225 =item Arguments: $schema \@databases, $version, $directory, $preversion, $sqlt_args
1229 Creates a SQL file based on the Schema, for each of the specified
1230 database types, in the given directory.
1232 Note that this feature is currently EXPERIMENTAL and may not work correctly
1233 across all databases, or fully handle complex relationships.
1239 my ($self, $schema, $databases, $version, $dir, $preversion, $sqltargs) = @_;
1241 if(!$dir || !-d $dir)
1243 warn "No directory given, using ./\n";
1246 $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
1247 $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
1248 $version ||= $schema->VERSION || '1.x';
1249 $sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} };
1251 eval "use SQL::Translator";
1252 $self->throw_exception("Can't create a ddl file without SQL::Translator: $@") if $@;
1254 my $sqlt = SQL::Translator->new({
1256 add_drop_table => 1,
1258 foreach my $db (@$databases)
1261 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
1262 # $sqlt->parser_args({'DBIx::Class' => $schema);
1263 $sqlt = $self->configure_sqlt($sqlt, $db);
1264 $sqlt->data($schema);
1265 $sqlt->producer($db);
1268 my $filename = $schema->ddl_filename($db, $dir, $version);
1271 warn("$filename already exists, skipping $db");
1275 my $output = $sqlt->translate;
1278 warn("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
1281 if(!open($file, ">$filename"))
1283 $self->throw_exception("Can't open $filename for writing ($!)");
1286 print $file $output;
1291 eval "use SQL::Translator::Diff";
1294 warn("Can't diff versions without SQL::Translator::Diff: $@");
1298 my $prefilename = $schema->ddl_filename($db, $dir, $preversion);
1299 # print "Previous version $prefilename\n";
1300 if(!-e $prefilename)
1302 warn("No previous schema file found ($prefilename)");
1305 #### We need to reparse the SQLite file we just wrote, so that
1306 ## Diff doesnt get all confoosed, and Diff is *very* confused.
1307 ## FIXME: rip Diff to pieces!
1308 # my $target_schema = $sqlt->schema;
1309 # unless ( $target_schema->name ) {
1310 # $target_schema->name( $filename );
1313 push @input, {file => $prefilename, parser => $db};
1314 push @input, {file => $filename, parser => $db};
1315 my ( $source_schema, $source_db, $target_schema, $target_db ) = map {
1316 my $file = $_->{'file'};
1317 my $parser = $_->{'parser'};
1319 my $t = SQL::Translator->new;
1322 $t->parser( $parser ) or die $t->error;
1323 my $out = $t->translate( $file ) or die $t->error;
1324 my $schema = $t->schema;
1325 unless ( $schema->name ) {
1326 $schema->name( $file );
1331 my $diff = SQL::Translator::Diff::schema_diff($source_schema, $db,
1332 $target_schema, $db,
1335 my $difffile = $schema->ddl_filename($db, $dir, $version, $preversion);
1336 print STDERR "Diff: $difffile: $db, $dir, $version, $preversion \n";
1339 warn("$difffile already exists, skipping");
1342 if(!open $file, ">$difffile")
1344 $self->throw_exception("Can't write to $difffile ($!)");
1353 sub configure_sqlt() {
1356 my $db = shift || $self->sqlt_type;
1357 if ($db eq 'PostgreSQL') {
1358 $tr->quote_table_names(0);
1359 $tr->quote_field_names(0);
1364 =head2 deployment_statements
1368 =item Arguments: $schema, $type, $version, $directory, $sqlt_args
1372 Returns the statements used by L</deploy> and L<DBIx::Class::Schema/deploy>.
1373 The database driver name is given by C<$type>, though the value from
1374 L</sqlt_type> is used if it is not specified.
1376 C<$directory> is used to return statements from files in a previously created
1377 L</create_ddl_dir> directory and is optional. The filenames are constructed
1378 from L<DBIx::Class::Schema/ddl_filename>, the schema name and the C<$version>.
1380 If no C<$directory> is specified then the statements are constructed on the
1381 fly using L<SQL::Translator> and C<$version> is ignored.
1383 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>.
1387 sub deployment_statements {
1388 my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
1389 # Need to be connected to get the correct sqlt_type
1390 $self->ensure_connected() unless $type;
1391 $type ||= $self->sqlt_type;
1392 $version ||= $schema->VERSION || '1.x';
1394 my $filename = $schema->ddl_filename($type, $dir, $version);
1398 open($file, "<$filename")
1399 or $self->throw_exception("Can't open $filename ($!)");
1402 return join('', @rows);
1405 eval "use SQL::Translator";
1408 eval "use SQL::Translator::Parser::DBIx::Class;";
1409 $self->throw_exception($@) if $@;
1410 eval "use SQL::Translator::Producer::${type};";
1411 $self->throw_exception($@) if $@;
1413 # sources needs to be a parser arg, but for simplicty allow at top level
1415 $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources}
1416 if exists $sqltargs->{sources};
1418 my $tr = SQL::Translator->new(%$sqltargs);
1419 SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
1420 return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
1423 $self->throw_exception("No SQL::Translator, and no Schema file found, aborting deploy");
1429 my ($self, $schema, $type, $sqltargs, $dir) = @_;
1430 foreach my $statement ( $self->deployment_statements($schema, $type, undef, $dir, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
1431 for ( split(";\n", $statement)) {
1432 next if($_ =~ /^--/);
1434 # next if($_ =~ /^DROP/m);
1435 next if($_ =~ /^BEGIN TRANSACTION/m);
1436 next if($_ =~ /^COMMIT/m);
1437 next if $_ =~ /^\s+$/; # skip whitespace only
1438 $self->debugobj->query_start($_) if $self->debug;
1439 $self->dbh->do($_) or warn "SQL was:\n $_"; # XXX exceptions?
1440 $self->debugobj->query_end($_) if $self->debug;
1445 =head2 datetime_parser
1447 Returns the datetime parser class
1451 sub datetime_parser {
1453 return $self->{datetime_parser} ||= $self->build_datetime_parser(@_);
1456 =head2 datetime_parser_type
1458 Defines (returns) the datetime parser class - currently hardwired to
1459 L<DateTime::Format::MySQL>
1463 sub datetime_parser_type { "DateTime::Format::MySQL"; }
1465 =head2 build_datetime_parser
1467 See L</datetime_parser>
1471 sub build_datetime_parser {
1473 my $type = $self->datetime_parser_type(@_);
1475 $self->throw_exception("Couldn't load ${type}: $@") if $@;
1481 return if !$self->_dbh;
1490 The module defines a set of methods within the DBIC::SQL::Abstract
1491 namespace. These build on L<SQL::Abstract::Limit> to provide the
1492 SQL query functions.
1494 The following methods are extended:-
1508 See L</connect_info> for details.
1509 For setting, this method is deprecated in favor of L</connect_info>.
1513 See L</connect_info> for details.
1514 For setting, this method is deprecated in favor of L</connect_info>.
1518 See L</connect_info> for details.
1519 For setting, this method is deprecated in favor of L</connect_info>.
1525 Matt S. Trout <mst@shadowcatsystems.co.uk>
1527 Andy Grundman <andy@hybridized.org>
1531 You may distribute this code under the same terms as Perl itself.