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 # print STDERR "Found DBH $syntax >$dbhname< ", $syntax->{Driver}->{Name}, "\n";
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') {
241 my $x = '= '.$self->_quote($cond->{$_}); $j{$_} = \$x;
243 return $self->_recurse_where(\%j);
244 } elsif (ref $cond eq 'ARRAY') {
245 return join(' OR ', map { $self->_join_condition($_) } @$cond);
247 die "Can't handle this yet!";
252 my ($self, $label) = @_;
253 return '' unless defined $label;
254 return "*" if $label eq '*';
255 return $label unless $self->{quote_char};
256 if(ref $self->{quote_char} eq "ARRAY"){
257 return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
258 if !defined $self->{name_sep};
259 my $sep = $self->{name_sep};
260 return join($self->{name_sep},
261 map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
262 split(/\Q$sep\E/,$label));
264 return $self->SUPER::_quote($label);
269 $self->{limit_dialect} = shift if @_;
270 return $self->{limit_dialect};
275 $self->{quote_char} = shift if @_;
276 return $self->{quote_char};
281 $self->{name_sep} = shift if @_;
282 return $self->{name_sep};
285 } # End of BEGIN block
289 DBIx::Class::Storage::DBI - DBI storage handler
295 This class represents the connection to an RDBMS via L<DBI>. See
296 L<DBIx::Class::Storage> for general information. This pod only
297 documents DBI-specific methods and behaviors.
304 my $new = shift->next::method(@_);
306 $new->cursor("DBIx::Class::Storage::DBI::Cursor");
307 $new->transaction_depth(0);
308 $new->_sql_maker_opts({});
309 $new->{_in_dbh_do} = 0;
310 $new->{_dbh_gen} = 0;
317 The arguments of C<connect_info> are always a single array reference.
319 This is normally accessed via L<DBIx::Class::Schema/connection>, which
320 encapsulates its argument list in an arrayref before calling
321 C<connect_info> here.
323 The arrayref can either contain the same set of arguments one would
324 normally pass to L<DBI/connect>, or a lone code reference which returns
325 a connected database handle.
327 In either case, if the final argument in your connect_info happens
328 to be a hashref, C<connect_info> will look there for several
329 connection-specific options:
335 This can be set to an arrayref of literal sql statements, which will
336 be executed immediately after making the connection to the database
337 every time we [re-]connect.
339 =item disable_sth_caching
341 If set to a true value, this option will disable the caching of
342 statement handles via L<DBI/prepare_cached>.
346 Sets the limit dialect. This is useful for JDBC-bridge among others
347 where the remote SQL-dialect cannot be determined by the name of the
352 Specifies what characters to use to quote table and column names. If
353 you use this you will want to specify L<name_sep> as well.
355 quote_char expects either a single character, in which case is it is placed
356 on either side of the table/column, or an arrayref of length 2 in which case the
357 table/column name is placed between the elements.
359 For example under MySQL you'd use C<quote_char =E<gt> '`'>, and user SQL Server you'd
360 use C<quote_char =E<gt> [qw/[ ]/]>.
364 This only needs to be used in conjunction with L<quote_char>, and is used to
365 specify the charecter that seperates elements (schemas, tables, columns) from
366 each other. In most cases this is simply a C<.>.
370 These options can be mixed in with your other L<DBI> connection attributes,
371 or placed in a seperate hashref after all other normal L<DBI> connection
374 Every time C<connect_info> is invoked, any previous settings for
375 these options will be cleared before setting the new ones, regardless of
376 whether any options are specified in the new C<connect_info>.
378 Important note: DBIC expects the returned database handle provided by
379 a subref argument to have RaiseError set on it. If it doesn't, things
380 might not work very well, YMMV. If you don't use a subref, DBIC will
381 force this setting for you anyways. Setting HandleError to anything
382 other than simple exception object wrapper might cause problems too.
386 # Simple SQLite connection
387 ->connect_info([ 'dbi:SQLite:./foo.db' ]);
390 ->connect_info([ sub { DBI->connect(...) } ]);
392 # A bit more complicated
399 { quote_char => q{"}, name_sep => q{.} },
403 # Equivalent to the previous example
409 { AutoCommit => 0, quote_char => q{"}, name_sep => q{.} },
413 # Subref + DBIC-specific connection options
416 sub { DBI->connect(...) },
420 on_connect_do => ['SET search_path TO myschema,otherschema,public'],
421 disable_sth_caching => 1,
429 my ($self, $info_arg) = @_;
431 return $self->_connect_info if !$info_arg;
433 # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
434 # the new set of options
435 $self->_sql_maker(undef);
436 $self->_sql_maker_opts({});
438 my $info = [ @$info_arg ]; # copy because we can alter it
439 my $last_info = $info->[-1];
440 if(ref $last_info eq 'HASH') {
441 for my $storage_opt (qw/on_connect_do disable_sth_caching/) {
442 if(my $value = delete $last_info->{$storage_opt}) {
443 $self->$storage_opt($value);
446 for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
447 if(my $opt_val = delete $last_info->{$sql_maker_opt}) {
448 $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
452 # Get rid of any trailing empty hashref
453 pop(@$info) if !keys %$last_info;
456 $self->_connect_info($info);
461 This method is deprecated in favor of setting via L</connect_info>.
465 Arguments: $subref, @extra_coderef_args?
467 Execute the given subref using the new exception-based connection management.
469 The first two arguments will be the storage object that C<dbh_do> was called
470 on and a database handle to use. Any additional arguments will be passed
471 verbatim to the called subref as arguments 2 and onwards.
473 Using this (instead of $self->_dbh or $self->dbh) ensures correct
474 exception handling and reconnection (or failover in future subclasses).
476 Your subref should have no side-effects outside of the database, as
477 there is the potential for your subref to be partially double-executed
478 if the database connection was stale/dysfunctional.
482 my @stuff = $schema->storage->dbh_do(
484 my ($storage, $dbh, @cols) = @_;
485 my $cols = join(q{, }, @cols);
486 $dbh->selectrow_array("SELECT $cols FROM foo");
497 ref $coderef eq 'CODE' or $self->throw_exception
498 ('$coderef must be a CODE reference');
500 return $coderef->($self, $self->_dbh, @_) if $self->{_in_dbh_do};
501 local $self->{_in_dbh_do} = 1;
504 my $want_array = wantarray;
507 $self->_verify_pid if $self->_dbh;
508 $self->_populate_dbh if !$self->_dbh;
510 @result = $coderef->($self, $self->_dbh, @_);
512 elsif(defined $want_array) {
513 $result[0] = $coderef->($self, $self->_dbh, @_);
516 $coderef->($self, $self->_dbh, @_);
521 if(!$exception) { return $want_array ? @result : $result[0] }
523 $self->throw_exception($exception) if $self->connected;
525 # We were not connected - reconnect and retry, but let any
526 # exception fall right through this time
527 $self->_populate_dbh;
528 $coderef->($self, $self->_dbh, @_);
531 # This is basically a blend of dbh_do above and DBIx::Class::Storage::txn_do.
532 # It also informs dbh_do to bypass itself while under the direction of txn_do,
533 # via $self->{_in_dbh_do} (this saves some redundant eval and errorcheck, etc)
538 ref $coderef eq 'CODE' or $self->throw_exception
539 ('$coderef must be a CODE reference');
541 local $self->{_in_dbh_do} = 1;
544 my $want_array = wantarray;
549 $self->_verify_pid if $self->_dbh;
550 $self->_populate_dbh if !$self->_dbh;
554 @result = $coderef->(@_);
556 elsif(defined $want_array) {
557 $result[0] = $coderef->(@_);
566 if(!$exception) { return $want_array ? @result : $result[0] }
568 if($tried++ > 0 || $self->connected) {
569 eval { $self->txn_rollback };
570 my $rollback_exception = $@;
571 if($rollback_exception) {
572 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
573 $self->throw_exception($exception) # propagate nested rollback
574 if $rollback_exception =~ /$exception_class/;
576 $self->throw_exception(
577 "Transaction aborted: ${exception}. "
578 . "Rollback failed: ${rollback_exception}"
581 $self->throw_exception($exception)
584 # We were not connected, and was first try - reconnect and retry
586 $self->_populate_dbh;
592 Our C<disconnect> method also performs a rollback first if the
593 database is not in C<AutoCommit> mode.
600 if( $self->connected ) {
601 $self->_dbh->rollback unless $self->_dbh->{AutoCommit};
602 $self->_dbh->disconnect;
611 if(my $dbh = $self->_dbh) {
612 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
620 return ($dbh->FETCH('Active') && $dbh->ping);
626 # handle pid changes correctly
627 # NOTE: assumes $self->_dbh is a valid $dbh
631 return if $self->_conn_pid == $$;
633 $self->_dbh->{InactiveDestroy} = 1;
640 sub ensure_connected {
643 unless ($self->connected) {
644 $self->_populate_dbh;
650 Returns the dbh - a data base handle of class L<DBI>.
657 $self->ensure_connected;
661 sub _sql_maker_args {
664 return ( bindtype=>'columns', limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
669 unless ($self->_sql_maker) {
670 $self->_sql_maker(new DBIC::SQL::Abstract( $self->_sql_maker_args ));
672 return $self->_sql_maker;
677 my @info = @{$self->_connect_info || []};
678 $self->_dbh($self->_connect(@info));
680 if(ref $self eq 'DBIx::Class::Storage::DBI') {
681 my $driver = $self->_dbh->{Driver}->{Name};
682 if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
683 bless $self, "DBIx::Class::Storage::DBI::${driver}";
684 $self->_rebless() if $self->can('_rebless');
688 # if on-connect sql statements are given execute them
689 foreach my $sql_statement (@{$self->on_connect_do || []}) {
690 $self->debugobj->query_start($sql_statement) if $self->debug();
691 $self->_dbh->do($sql_statement);
692 $self->debugobj->query_end($sql_statement) if $self->debug();
695 $self->_conn_pid($$);
696 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
700 my ($self, @info) = @_;
702 $self->throw_exception("You failed to provide any connection info")
705 my ($old_connect_via, $dbh);
707 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
708 $old_connect_via = $DBI::connect_via;
709 $DBI::connect_via = 'connect';
713 if(ref $info[0] eq 'CODE') {
717 $dbh = DBI->connect(@info);
718 $dbh->{RaiseError} = 1;
719 $dbh->{PrintError} = 0;
720 $dbh->{PrintWarn} = 0;
724 $DBI::connect_via = $old_connect_via if $old_connect_via;
727 $self->throw_exception("DBI Connection failed: " . ($@ || $DBI::errstr));
734 my ($self, $dbh) = @_;
735 if ($dbh->{AutoCommit}) {
736 $self->debugobj->txn_begin()
744 $self->dbh_do($self->can('_dbh_txn_begin'))
745 if $self->{transaction_depth}++ == 0;
748 sub _dbh_txn_commit {
749 my ($self, $dbh) = @_;
750 if ($self->{transaction_depth} == 0) {
751 unless ($dbh->{AutoCommit}) {
752 $self->debugobj->txn_commit()
758 if (--$self->{transaction_depth} == 0) {
759 $self->debugobj->txn_commit()
768 $self->dbh_do($self->can('_dbh_txn_commit'));
771 sub _dbh_txn_rollback {
772 my ($self, $dbh) = @_;
773 if ($self->{transaction_depth} == 0) {
774 unless ($dbh->{AutoCommit}) {
775 $self->debugobj->txn_rollback()
781 if (--$self->{transaction_depth} == 0) {
782 $self->debugobj->txn_rollback()
787 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
795 eval { $self->dbh_do($self->can('_dbh_txn_rollback')) };
798 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
799 $error =~ /$exception_class/ and $self->throw_exception($error);
800 $self->{transaction_depth} = 0; # ensure that a failed rollback
801 $self->throw_exception($error); # resets the transaction depth
805 # This used to be the top-half of _execute. It was split out to make it
806 # easier to override in NoBindVars without duping the rest. It takes up
807 # all of _execute's args, and emits $sql, @bind.
808 sub _prep_for_execute {
809 my ($self, $op, $extra_bind, $ident, @args) = @_;
811 my ($sql, @bind) = $self->sql_maker->$op($ident, @args);
812 unshift(@bind, @$extra_bind) if $extra_bind;
813 @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
815 return ($sql, @bind);
819 my ($self, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
821 my ($sql, @bind) = $self->sql_maker->$op($ident, @args);
822 unshift(@bind, @$extra_bind) if $extra_bind;
824 my @debug_bind = map { defined ($_ && $_->[1]) ? qq{'$_->[1]'} : q{'NULL'} } @bind;
825 $self->debugobj->query_start($sql, @debug_bind);
827 my $sth = eval { $self->sth($sql,$op) };
830 $self->throw_exception(
831 'no sth generated via sql (' . ($@ || $self->_dbh->errstr) . "): $sql"
841 my $placeholder_index = 1;
843 foreach my $bound (@bind) {
846 my($column_name, $data) = @$bound;
848 if( $bind_attributes ) {
849 $attributes = $bind_attributes->{$column_name}
850 if defined $bind_attributes->{$column_name};
853 $data = ref $data ? ''.$data : $data; # stringify args
855 $sth->bind_param($placeholder_index, $data, $attributes);
856 $placeholder_index++;
862 $self->throw_exception("Error executing '$sql': ".($@ || $sth->errstr));
865 $self->throw_exception("'$sql' did not generate a statement.");
868 my @debug_bind = map { defined ($_ && $_->[1]) ? qq{'$_->[1]'} : q{'NULL'} } @bind;
869 $self->debugobj->query_end($sql, @debug_bind);
871 return (wantarray ? ($rv, $sth, @bind) : $rv);
875 my ($self, $source, $to_insert) = @_;
877 my $ident = $source->from;
879 foreach my $column ($source->columns) {
881 my $data_type = $source->column_info($column)->{data_type} || '';
882 $bind_attributes->{$column} = $self->bind_attribute_by_data_type($data_type)
886 $self->throw_exception(
887 "Couldn't insert ".join(', ',
888 map "$_ => $to_insert->{$_}", keys %$to_insert
890 ) unless ($self->_execute('insert' => [], $ident, $bind_attributes, $to_insert));
894 ## Still not quite perfect, and EXPERIMENTAL
895 ## Currently it is assumed that all values passed will be "normal", i.e. not
896 ## scalar refs, or at least, all the same type as the first set, the statement is
897 ## only prepped once.
899 my ($self, $source, $cols, $data) = @_;
901 my $table = $source->from;
902 @colvalues{@$cols} = (0..$#$cols);
903 my ($sql, @bind) = $self->sql_maker->insert($table, \%colvalues);
906 my @debug_bind = map { defined $_->[1] ? qq{$_->[1]} : q{'NULL'} } @bind;
907 $self->debugobj->query_start($sql, @debug_bind);
909 my $sth = $self->sth($sql);
911 # @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
915 ## This must be an arrayref, else nothing works!
917 my $tuple_status = [];
920 ##print STDERR Dumper( $data, $sql, [@bind] );
928 # $sth->execute_array({
930 # ArrayTupleFetch => sub {
932 # my $values = shift @$data;
933 # return if !$values;
934 # return [ @{$values}[@bind] ];
937 # ArrayTupleStatus => $tuple_status,
941 ## Get the bind_attributes, if any exist
944 foreach my $column ($source->columns) {
946 my $data_type = $source->column_info($column)->{data_type} || '';
948 $bind_attributes->{$column} = $self->bind_attribute_by_data_type($data_type)
952 ## Bind the values and execute
956 my $placeholder_index = 1;
958 foreach my $bound (@bind) {
961 my ($column_name, $data_index) = @$bound;
963 if( $bind_attributes ) {
964 $attributes = $bind_attributes->{$column_name}
965 if defined $bind_attributes->{$column_name};
968 my @data = map { $_->[$data_index] } @$data;
970 $sth->bind_param_array( $placeholder_index, [@data], $attributes );
971 $placeholder_index++;
973 $sth->execute_array( {ArrayTupleStatus => $tuple_status} );
977 #print STDERR Dumper($tuple_status);
978 #print STDERR "RV: $rv\n";
980 if ($@ || !defined $rv) {
982 foreach my $tuple (@$tuple_status)
984 $errors .= "\n" . $tuple->[1] if(ref $tuple);
986 $self->throw_exception("Error executing '$sql': ".($@ || $errors));
989 $self->throw_exception("'$sql' did not generate a statement.");
992 my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind;
993 $self->debugobj->query_end($sql, @debug_bind);
995 return (wantarray ? ($rv, $sth, @bind) : $rv);
1000 my $source = shift @_;
1002 my $bind_attributes;
1003 foreach my $column ($source->columns) {
1005 my $data_type = $source->column_info($column)->{data_type} || '';
1006 $bind_attributes->{$column} = $self->bind_attribute_by_data_type($data_type)
1010 my $ident = $source->from;
1011 return $self->_execute('update' => [], $ident, $bind_attributes, @_);
1016 my $self = shift @_;
1017 my $source = shift @_;
1019 my $bind_attrs = {}; ## If ever it's needed...
1020 my $ident = $source->from;
1022 return $self->_execute('delete' => [], $ident, $bind_attrs, @_);
1026 my ($self, $ident, $select, $condition, $attrs) = @_;
1027 my $order = $attrs->{order_by};
1028 if (ref $condition eq 'SCALAR') {
1029 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
1031 if (exists $attrs->{group_by} || $attrs->{having}) {
1033 group_by => $attrs->{group_by},
1034 having => $attrs->{having},
1035 ($order ? (order_by => $order) : ())
1038 my $bind_attrs = {}; ## Future support
1039 my @args = ('select', $attrs->{bind}, $ident, $bind_attrs, $select, $condition, $order);
1040 if ($attrs->{software_limit} ||
1041 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
1042 $attrs->{software_limit} = 1;
1044 $self->throw_exception("rows attribute must be positive if present")
1045 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
1046 push @args, $attrs->{rows}, $attrs->{offset};
1048 return $self->_execute(@args);
1055 =item Arguments: $ident, $select, $condition, $attrs
1059 Handle a SQL select statement.
1065 my ($ident, $select, $condition, $attrs) = @_;
1066 return $self->cursor->new($self, \@_, $attrs);
1071 my ($rv, $sth, @bind) = $self->_select(@_);
1072 my @row = $sth->fetchrow_array;
1073 # Need to call finish() to work round broken DBDs
1082 =item Arguments: $sql
1086 Returns a L<DBI> sth (statement handle) for the supplied SQL.
1091 my ($self, $dbh, $sql) = @_;
1093 # 3 is the if_active parameter which avoids active sth re-use
1094 my $sth = $self->disable_sth_caching
1095 ? $dbh->prepare($sql)
1096 : $dbh->prepare_cached($sql, {}, 3);
1098 $self->throw_exception(
1099 'no sth generated via sql (' . ($@ || $dbh->errstr) . "): $sql"
1106 my ($self, $sql) = @_;
1107 $self->dbh_do($self->can('_dbh_sth'), $sql);
1110 sub _dbh_columns_info_for {
1111 my ($self, $dbh, $table) = @_;
1113 if ($dbh->can('column_info')) {
1116 my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
1117 my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
1119 while ( my $info = $sth->fetchrow_hashref() ){
1121 $column_info{data_type} = $info->{TYPE_NAME};
1122 $column_info{size} = $info->{COLUMN_SIZE};
1123 $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
1124 $column_info{default_value} = $info->{COLUMN_DEF};
1125 my $col_name = $info->{COLUMN_NAME};
1126 $col_name =~ s/^\"(.*)\"$/$1/;
1128 $result{$col_name} = \%column_info;
1131 return \%result if !$@ && scalar keys %result;
1135 my $sth = $dbh->prepare("SELECT * FROM $table WHERE 1=0");
1137 my @columns = @{$sth->{NAME_lc}};
1138 for my $i ( 0 .. $#columns ){
1140 my $type_num = $sth->{TYPE}->[$i];
1142 if(defined $type_num && $dbh->can('type_info')) {
1143 my $type_info = $dbh->type_info($type_num);
1144 $type_name = $type_info->{TYPE_NAME} if $type_info;
1146 $column_info{data_type} = $type_name ? $type_name : $type_num;
1147 $column_info{size} = $sth->{PRECISION}->[$i];
1148 $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
1150 if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
1151 $column_info{data_type} = $1;
1152 $column_info{size} = $2;
1155 $result{$columns[$i]} = \%column_info;
1161 sub columns_info_for {
1162 my ($self, $table) = @_;
1163 $self->dbh_do($self->can('_dbh_columns_info_for'), $table);
1166 =head2 last_insert_id
1168 Return the row id of the last insert.
1172 sub _dbh_last_insert_id {
1173 my ($self, $dbh, $source, $col) = @_;
1174 # XXX This is a SQLite-ism as a default... is there a DBI-generic way?
1175 $dbh->func('last_insert_rowid');
1178 sub last_insert_id {
1180 $self->dbh_do($self->can('_dbh_last_insert_id'), @_);
1185 Returns the database driver name.
1189 sub sqlt_type { shift->dbh->{Driver}->{Name} }
1191 =head2 bind_attribute_by_data_type
1193 Given a datatype from column info, returns a database specific bind attribute for
1194 $dbh->bind_param($val,$attribute) or nothing if we will let the database planner
1197 Generally only needed for special case column types, like bytea in postgres.
1201 sub bind_attribute_by_data_type {
1205 =head2 create_ddl_dir (EXPERIMENTAL)
1209 =item Arguments: $schema \@databases, $version, $directory, $sqlt_args
1213 Creates a SQL file based on the Schema, for each of the specified
1214 database types, in the given directory.
1216 Note that this feature is currently EXPERIMENTAL and may not work correctly
1217 across all databases, or fully handle complex relationships.
1223 my ($self, $schema, $databases, $version, $dir, $sqltargs) = @_;
1225 if(!$dir || !-d $dir)
1227 warn "No directory given, using ./\n";
1230 $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
1231 $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
1232 $version ||= $schema->VERSION || '1.x';
1233 $sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} };
1235 eval "use SQL::Translator";
1236 $self->throw_exception("Can't deploy without SQL::Translator: $@") if $@;
1238 my $sqlt = SQL::Translator->new($sqltargs);
1239 foreach my $db (@$databases)
1242 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
1243 # $sqlt->parser_args({'DBIx::Class' => $schema);
1244 $sqlt->data($schema);
1245 $sqlt->producer($db);
1248 my $filename = $schema->ddl_filename($db, $dir, $version);
1251 $self->throw_exception("$filename already exists, skipping $db");
1254 open($file, ">$filename")
1255 or $self->throw_exception("Can't open $filename for writing ($!)");
1256 my $output = $sqlt->translate;
1258 # print join(":", keys %{$schema->source_registrations});
1259 # print Dumper($sqlt->schema);
1262 $self->throw_exception("Failed to translate to $db. (" . $sqlt->error . ")");
1265 print $file $output;
1271 =head2 deployment_statements
1275 =item Arguments: $schema, $type, $version, $directory, $sqlt_args
1279 Returns the statements used by L</deploy> and L<DBIx::Class::Schema/deploy>.
1280 The database driver name is given by C<$type>, though the value from
1281 L</sqlt_type> is used if it is not specified.
1283 C<$directory> is used to return statements from files in a previously created
1284 L</create_ddl_dir> directory and is optional. The filenames are constructed
1285 from L<DBIx::Class::Schema/ddl_filename>, the schema name and the C<$version>.
1287 If no C<$directory> is specified then the statements are constructed on the
1288 fly using L<SQL::Translator> and C<$version> is ignored.
1290 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>.
1294 sub deployment_statements {
1295 my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
1296 # Need to be connected to get the correct sqlt_type
1297 $self->ensure_connected() unless $type;
1298 $type ||= $self->sqlt_type;
1299 $version ||= $schema->VERSION || '1.x';
1301 eval "use SQL::Translator";
1304 eval "use SQL::Translator::Parser::DBIx::Class;";
1305 $self->throw_exception($@) if $@;
1306 eval "use SQL::Translator::Producer::${type};";
1307 $self->throw_exception($@) if $@;
1308 my $tr = SQL::Translator->new(%$sqltargs);
1309 SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
1310 return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
1313 my $filename = $schema->ddl_filename($type, $dir, $version);
1316 # $schema->create_ddl_dir([ $type ], $version, $dir, $sqltargs);
1317 $self->throw_exception("No SQL::Translator, and no Schema file found, aborting deploy");
1321 open($file, "<$filename")
1322 or $self->throw_exception("Can't open $filename ($!)");
1326 return join('', @rows);
1331 my ($self, $schema, $type, $sqltargs, $dir) = @_;
1332 foreach my $statement ( $self->deployment_statements($schema, $type, undef, $dir, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
1333 for ( split(";\n", $statement)) {
1334 next if($_ =~ /^--/);
1336 # next if($_ =~ /^DROP/m);
1337 next if($_ =~ /^BEGIN TRANSACTION/m);
1338 next if($_ =~ /^COMMIT/m);
1339 next if $_ =~ /^\s+$/; # skip whitespace only
1340 $self->debugobj->query_start($_) if $self->debug;
1341 $self->dbh->do($_) or warn "SQL was:\n $_"; # XXX exceptions?
1342 $self->debugobj->query_end($_) if $self->debug;
1347 =head2 datetime_parser
1349 Returns the datetime parser class
1353 sub datetime_parser {
1355 return $self->{datetime_parser} ||= $self->build_datetime_parser(@_);
1358 =head2 datetime_parser_type
1360 Defines (returns) the datetime parser class - currently hardwired to
1361 L<DateTime::Format::MySQL>
1365 sub datetime_parser_type { "DateTime::Format::MySQL"; }
1367 =head2 build_datetime_parser
1369 See L</datetime_parser>
1373 sub build_datetime_parser {
1375 my $type = $self->datetime_parser_type(@_);
1377 $self->throw_exception("Couldn't load ${type}: $@") if $@;
1383 return if !$self->_dbh;
1392 The module defines a set of methods within the DBIC::SQL::Abstract
1393 namespace. These build on L<SQL::Abstract::Limit> to provide the
1394 SQL query functions.
1396 The following methods are extended:-
1410 See L</connect_info> for details.
1411 For setting, this method is deprecated in favor of L</connect_info>.
1415 See L</connect_info> for details.
1416 For setting, this method is deprecated in favor of L</connect_info>.
1420 See L</connect_info> for details.
1421 For setting, this method is deprecated in favor of L</connect_info>.
1427 Matt S. Trout <mst@shadowcatsystems.co.uk>
1429 Andy Grundman <andy@hybridized.org>
1433 You may distribute this code under the same terms as Perl itself.