1 package DBIx::Class::Storage::DBI;
2 # -*- mode: cperl; cperl-indent-level: 2 -*-
4 use base 'DBIx::Class::Storage';
9 use SQL::Abstract::Limit;
10 use DBIx::Class::Storage::DBI::Cursor;
11 use DBIx::Class::Storage::Statistics;
12 use Scalar::Util qw/blessed weaken/;
14 __PACKAGE__->mk_group_accessors('simple' =>
15 qw/_connect_info _dbi_connect_info _dbh _sql_maker _sql_maker_opts
16 _conn_pid _conn_tid disable_sth_caching on_connect_do
17 on_disconnect_do transaction_depth unsafe _dbh_autocommit/
20 __PACKAGE__->cursor_class('DBIx::Class::Storage::DBI::Cursor');
24 package DBIC::SQL::Abstract; # Would merge upstream, but nate doesn't reply :(
26 use base qw/SQL::Abstract::Limit/;
28 # This prevents the caching of $dbh in S::A::L, I believe
30 my $self = shift->SUPER::new(@_);
32 # If limit_dialect is a ref (like a $dbh), go ahead and replace
33 # it with what it resolves to:
34 $self->{limit_dialect} = $self->_find_syntax($self->{limit_dialect})
35 if ref $self->{limit_dialect};
41 my ($self, $sql, $order, $rows, $offset ) = @_;
44 my $last = $rows + $offset;
45 my ( $order_by ) = $self->_order_by( $order );
50 SELECT Q1.*, ROW_NUMBER() OVER( ) AS ROW_NUM FROM (
55 WHERE ROW_NUM BETWEEN $offset AND $last
61 # While we're at it, this should make LIMIT queries more efficient,
62 # without digging into things too deeply
63 use Scalar::Util 'blessed';
65 my ($self, $syntax) = @_;
66 my $dbhname = blessed($syntax) ? $syntax->{Driver}{Name} : $syntax;
67 if(ref($self) && $dbhname && $dbhname eq 'DB2') {
68 return 'RowNumberOver';
71 $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
75 my ($self, $table, $fields, $where, $order, @rest) = @_;
76 $table = $self->_quote($table) unless ref($table);
77 local $self->{rownum_hack_count} = 1
78 if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
79 @rest = (-1) unless defined $rest[0];
80 die "LIMIT 0 Does Not Compute" if $rest[0] == 0;
81 # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
82 local $self->{having_bind} = [];
83 my ($sql, @ret) = $self->SUPER::select(
84 $table, $self->_recurse_fields($fields), $where, $order, @rest
86 return wantarray ? ($sql, @ret, @{$self->{having_bind}}) : $sql;
92 $table = $self->_quote($table) unless ref($table);
93 $self->SUPER::insert($table, @_);
99 $table = $self->_quote($table) unless ref($table);
100 $self->SUPER::update($table, @_);
106 $table = $self->_quote($table) unless ref($table);
107 $self->SUPER::delete($table, @_);
113 return $_[1].$self->_order_by($_[2]);
115 return $self->SUPER::_emulate_limit(@_);
119 sub _recurse_fields {
120 my ($self, $fields, $params) = @_;
121 my $ref = ref $fields;
122 return $self->_quote($fields) unless $ref;
123 return $$fields if $ref eq 'SCALAR';
125 if ($ref eq 'ARRAY') {
126 return join(', ', map {
127 $self->_recurse_fields($_)
128 .(exists $self->{rownum_hack_count} && !($params && $params->{no_rownum_hack})
129 ? ' AS col'.$self->{rownum_hack_count}++
132 } elsif ($ref eq 'HASH') {
133 foreach my $func (keys %$fields) {
134 return $self->_sqlcase($func)
135 .'( '.$self->_recurse_fields($fields->{$func}).' )';
144 if (ref $_[0] eq 'HASH') {
145 if (defined $_[0]->{group_by}) {
146 $ret = $self->_sqlcase(' group by ')
147 .$self->_recurse_fields($_[0]->{group_by}, { no_rownum_hack => 1 });
149 if (defined $_[0]->{having}) {
151 ($frag, @extra) = $self->_recurse_where($_[0]->{having});
152 push(@{$self->{having_bind}}, @extra);
153 $ret .= $self->_sqlcase(' having ').$frag;
155 if (defined $_[0]->{order_by}) {
156 $ret .= $self->_order_by($_[0]->{order_by});
158 } elsif (ref $_[0] eq 'SCALAR') {
159 $ret = $self->_sqlcase(' order by ').${ $_[0] };
160 } elsif (ref $_[0] eq 'ARRAY' && @{$_[0]}) {
161 my @order = @{+shift};
162 $ret = $self->_sqlcase(' order by ')
164 my $r = $self->_order_by($_, @_);
165 $r =~ s/^ ?ORDER BY //i;
169 $ret = $self->SUPER::_order_by(@_);
174 sub _order_directions {
175 my ($self, $order) = @_;
176 $order = $order->{order_by} if ref $order eq 'HASH';
177 return $self->SUPER::_order_directions($order);
181 my ($self, $from) = @_;
182 if (ref $from eq 'ARRAY') {
183 return $self->_recurse_from(@$from);
184 } elsif (ref $from eq 'HASH') {
185 return $self->_make_as($from);
187 return $from; # would love to quote here but _table ends up getting called
188 # twice during an ->select without a limit clause due to
189 # the way S::A::Limit->select works. should maybe consider
190 # bypassing this and doing S::A::select($self, ...) in
191 # our select method above. meantime, quoting shims have
192 # been added to select/insert/update/delete here
197 my ($self, $from, @join) = @_;
199 push(@sqlf, $self->_make_as($from));
200 foreach my $j (@join) {
203 # check whether a join type exists
204 my $join_clause = '';
205 my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
206 if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
207 $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
209 $join_clause = ' JOIN ';
211 push(@sqlf, $join_clause);
213 if (ref $to eq 'ARRAY') {
214 push(@sqlf, '(', $self->_recurse_from(@$to), ')');
216 push(@sqlf, $self->_make_as($to));
218 push(@sqlf, ' ON ', $self->_join_condition($on));
220 return join('', @sqlf);
224 my ($self, $from) = @_;
225 return join(' ', map { (ref $_ eq 'SCALAR' ? $$_ : $self->_quote($_)) }
226 reverse each %{$self->_skip_options($from)});
230 my ($self, $hash) = @_;
232 $clean_hash->{$_} = $hash->{$_}
233 for grep {!/^-/} keys %$hash;
237 sub _join_condition {
238 my ($self, $cond) = @_;
239 if (ref $cond eq 'HASH') {
244 # XXX no throw_exception() in this package and croak() fails with strange results
245 Carp::croak(ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
246 if ref($v) ne 'SCALAR';
250 my $x = '= '.$self->_quote($v); $j{$_} = \$x;
253 return scalar($self->_recurse_where(\%j));
254 } elsif (ref $cond eq 'ARRAY') {
255 return join(' OR ', map { $self->_join_condition($_) } @$cond);
257 die "Can't handle this yet!";
262 my ($self, $label) = @_;
263 return '' unless defined $label;
264 return "*" if $label eq '*';
265 return $label unless $self->{quote_char};
266 if(ref $self->{quote_char} eq "ARRAY"){
267 return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
268 if !defined $self->{name_sep};
269 my $sep = $self->{name_sep};
270 return join($self->{name_sep},
271 map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
272 split(/\Q$sep\E/,$label));
274 return $self->SUPER::_quote($label);
279 $self->{limit_dialect} = shift if @_;
280 return $self->{limit_dialect};
285 $self->{quote_char} = shift if @_;
286 return $self->{quote_char};
291 $self->{name_sep} = shift if @_;
292 return $self->{name_sep};
295 } # End of BEGIN block
299 DBIx::Class::Storage::DBI - DBI storage handler
305 This class represents the connection to an RDBMS via L<DBI>. See
306 L<DBIx::Class::Storage> for general information. This pod only
307 documents DBI-specific methods and behaviors.
314 my $new = shift->next::method(@_);
316 $new->transaction_depth(0);
317 $new->_sql_maker_opts({});
318 $new->{_in_dbh_do} = 0;
319 $new->{_dbh_gen} = 0;
326 The arguments of C<connect_info> are always a single array reference.
328 This is normally accessed via L<DBIx::Class::Schema/connection>, which
329 encapsulates its argument list in an arrayref before calling
330 C<connect_info> here.
332 The arrayref can either contain the same set of arguments one would
333 normally pass to L<DBI/connect>, or a lone code reference which returns
334 a connected database handle. Please note that the L<DBI> docs
335 recommend that you always explicitly set C<AutoCommit> to either
336 C<0> or C<1>. L<DBIx::Class> further recommends that it be set
337 to C<1>, and that you perform transactions via our L</txn_do>
338 method. L<DBIx::Class> will set it to C<1> if you do not do explicitly
339 set it to zero. This is the default for most DBDs. See below for more
342 In either case, if the final argument in your connect_info happens
343 to be a hashref, C<connect_info> will look there for several
344 connection-specific options:
350 Specifies things to do immediately after connecting or re-connecting to
351 the database. Its value may contain:
355 =item an array reference
357 This contains SQL statements to execute in order. Each element contains
358 a string or a code reference that returns a string.
360 =item a code reference
362 This contains some code to execute. Unlike code references within an
363 array reference, its return value is ignored.
367 =item on_disconnect_do
369 Takes arguments in the same form as L<on_connect_do> and executes them
370 immediately before disconnecting from the database.
372 Note, this only runs if you explicitly call L<disconnect> on the
375 =item disable_sth_caching
377 If set to a true value, this option will disable the caching of
378 statement handles via L<DBI/prepare_cached>.
382 Sets the limit dialect. This is useful for JDBC-bridge among others
383 where the remote SQL-dialect cannot be determined by the name of the
388 Specifies what characters to use to quote table and column names. If
389 you use this you will want to specify L<name_sep> as well.
391 quote_char expects either a single character, in which case is it is placed
392 on either side of the table/column, or an arrayref of length 2 in which case the
393 table/column name is placed between the elements.
395 For example under MySQL you'd use C<quote_char =E<gt> '`'>, and user SQL Server you'd
396 use C<quote_char =E<gt> [qw/[ ]/]>.
400 This only needs to be used in conjunction with L<quote_char>, and is used to
401 specify the charecter that seperates elements (schemas, tables, columns) from
402 each other. In most cases this is simply a C<.>.
406 This Storage driver normally installs its own C<HandleError>, sets
407 C<RaiseError> and C<ShowErrorStatement> on, and sets C<PrintError> off on
408 all database handles, including those supplied by a coderef. It does this
409 so that it can have consistent and useful error behavior.
411 If you set this option to a true value, Storage will not do its usual
412 modifications to the database handle's attributes, and instead relies on
413 the settings in your connect_info DBI options (or the values you set in
414 your connection coderef, in the case that you are connecting via coderef).
416 Note that your custom settings can cause Storage to malfunction,
417 especially if you set a C<HandleError> handler that suppresses exceptions
418 and/or disable C<RaiseError>.
422 These options can be mixed in with your other L<DBI> connection attributes,
423 or placed in a seperate hashref after all other normal L<DBI> connection
426 Every time C<connect_info> is invoked, any previous settings for
427 these options will be cleared before setting the new ones, regardless of
428 whether any options are specified in the new C<connect_info>.
430 Another Important Note:
432 DBIC can do some wonderful magic with handling exceptions,
433 disconnections, and transactions when you use C<AutoCommit => 1>
434 combined with C<txn_do> for transaction support.
436 If you set C<AutoCommit => 0> in your connect info, then you are always
437 in an assumed transaction between commits, and you're telling us you'd
438 like to manage that manually. A lot of DBIC's magic protections
439 go away. We can't protect you from exceptions due to database
440 disconnects because we don't know anything about how to restart your
441 transactions. You're on your own for handling all sorts of exceptional
442 cases if you choose the C<AutoCommit => 0> path, just as you would
447 # Simple SQLite connection
448 ->connect_info([ 'dbi:SQLite:./foo.db' ]);
451 ->connect_info([ sub { DBI->connect(...) } ]);
453 # A bit more complicated
460 { quote_char => q{"}, name_sep => q{.} },
464 # Equivalent to the previous example
470 { AutoCommit => 1, quote_char => q{"}, name_sep => q{.} },
474 # Subref + DBIC-specific connection options
477 sub { DBI->connect(...) },
481 on_connect_do => ['SET search_path TO myschema,otherschema,public'],
482 disable_sth_caching => 1,
490 my ($self, $info_arg) = @_;
492 return $self->_connect_info if !$info_arg;
494 # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
495 # the new set of options
496 $self->_sql_maker(undef);
497 $self->_sql_maker_opts({});
498 $self->_connect_info([@$info_arg]); # copy for _connect_info
500 my $dbi_info = [@$info_arg]; # copy for _dbi_connect_info
502 my $last_info = $dbi_info->[-1];
503 if(ref $last_info eq 'HASH') {
504 $last_info = { %$last_info }; # so delete is non-destructive
505 my @storage_option = qw(
506 on_connect_do on_disconnect_do disable_sth_caching unsafe cursor_class
508 for my $storage_opt (@storage_option) {
509 if(my $value = delete $last_info->{$storage_opt}) {
510 $self->$storage_opt($value);
513 for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
514 if(my $opt_val = delete $last_info->{$sql_maker_opt}) {
515 $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
518 # re-insert modified hashref
519 $dbi_info->[-1] = $last_info;
521 # Get rid of any trailing empty hashref
522 pop(@$dbi_info) if !keys %$last_info;
524 $self->_dbi_connect_info($dbi_info);
526 $self->_connect_info;
531 This method is deprecated in favor of setting via L</connect_info>.
535 Arguments: $subref, @extra_coderef_args?
537 Execute the given subref using the new exception-based connection management.
539 The first two arguments will be the storage object that C<dbh_do> was called
540 on and a database handle to use. Any additional arguments will be passed
541 verbatim to the called subref as arguments 2 and onwards.
543 Using this (instead of $self->_dbh or $self->dbh) ensures correct
544 exception handling and reconnection (or failover in future subclasses).
546 Your subref should have no side-effects outside of the database, as
547 there is the potential for your subref to be partially double-executed
548 if the database connection was stale/dysfunctional.
552 my @stuff = $schema->storage->dbh_do(
554 my ($storage, $dbh, @cols) = @_;
555 my $cols = join(q{, }, @cols);
556 $dbh->selectrow_array("SELECT $cols FROM foo");
567 ref $coderef eq 'CODE' or $self->throw_exception
568 ('$coderef must be a CODE reference');
570 return $coderef->($self, $self->_dbh, @_) if $self->{_in_dbh_do}
571 || $self->{transaction_depth};
573 local $self->{_in_dbh_do} = 1;
576 my $want_array = wantarray;
579 $self->_verify_pid if $self->_dbh;
580 $self->_populate_dbh if !$self->_dbh;
582 @result = $coderef->($self, $self->_dbh, @_);
584 elsif(defined $want_array) {
585 $result[0] = $coderef->($self, $self->_dbh, @_);
588 $coderef->($self, $self->_dbh, @_);
593 if(!$exception) { return $want_array ? @result : $result[0] }
595 $self->throw_exception($exception) if $self->connected;
597 # We were not connected - reconnect and retry, but let any
598 # exception fall right through this time
599 $self->_populate_dbh;
600 $coderef->($self, $self->_dbh, @_);
603 # This is basically a blend of dbh_do above and DBIx::Class::Storage::txn_do.
604 # It also informs dbh_do to bypass itself while under the direction of txn_do,
605 # via $self->{_in_dbh_do} (this saves some redundant eval and errorcheck, etc)
610 ref $coderef eq 'CODE' or $self->throw_exception
611 ('$coderef must be a CODE reference');
613 return $coderef->(@_) if $self->{transaction_depth};
615 local $self->{_in_dbh_do} = 1;
618 my $want_array = wantarray;
623 $self->_verify_pid if $self->_dbh;
624 $self->_populate_dbh if !$self->_dbh;
628 @result = $coderef->(@_);
630 elsif(defined $want_array) {
631 $result[0] = $coderef->(@_);
640 if(!$exception) { return $want_array ? @result : $result[0] }
642 if($tried++ > 0 || $self->connected) {
643 eval { $self->txn_rollback };
644 my $rollback_exception = $@;
645 if($rollback_exception) {
646 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
647 $self->throw_exception($exception) # propagate nested rollback
648 if $rollback_exception =~ /$exception_class/;
650 $self->throw_exception(
651 "Transaction aborted: ${exception}. "
652 . "Rollback failed: ${rollback_exception}"
655 $self->throw_exception($exception)
658 # We were not connected, and was first try - reconnect and retry
660 $self->_populate_dbh;
666 Our C<disconnect> method also performs a rollback first if the
667 database is not in C<AutoCommit> mode.
674 if( $self->connected ) {
675 my $connection_do = $self->on_disconnect_do;
676 $self->_do_connection_actions($connection_do) if ref($connection_do);
678 $self->_dbh->rollback unless $self->_dbh_autocommit;
679 $self->_dbh->disconnect;
688 if(my $dbh = $self->_dbh) {
689 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
696 return 0 if !$self->_dbh;
698 return ($dbh->FETCH('Active') && $dbh->ping);
704 # handle pid changes correctly
705 # NOTE: assumes $self->_dbh is a valid $dbh
709 return if $self->_conn_pid == $$;
711 $self->_dbh->{InactiveDestroy} = 1;
718 sub ensure_connected {
721 unless ($self->connected) {
722 $self->_populate_dbh;
728 Returns the dbh - a data base handle of class L<DBI>.
735 $self->ensure_connected;
739 sub _sql_maker_args {
742 return ( bindtype=>'columns', limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
747 unless ($self->_sql_maker) {
748 $self->_sql_maker(new DBIC::SQL::Abstract( $self->_sql_maker_args ));
750 return $self->_sql_maker;
755 my @info = @{$self->_dbi_connect_info || []};
756 $self->_dbh($self->_connect(@info));
758 # Always set the transaction depth on connect, since
759 # there is no transaction in progress by definition
760 $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
762 if(ref $self eq 'DBIx::Class::Storage::DBI') {
763 my $driver = $self->_dbh->{Driver}->{Name};
764 if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
765 bless $self, "DBIx::Class::Storage::DBI::${driver}";
766 $self->_rebless() if $self->can('_rebless');
770 my $connection_do = $self->on_connect_do;
771 $self->_do_connection_actions($connection_do) if ref($connection_do);
773 $self->_conn_pid($$);
774 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
777 sub _do_connection_actions {
779 my $connection_do = shift;
781 if (ref $connection_do eq 'ARRAY') {
782 $self->_do_query($_) foreach @$connection_do;
784 elsif (ref $connection_do eq 'CODE') {
792 my ($self, $action) = @_;
794 if (ref $action eq 'CODE') {
795 $action = $action->($self);
796 $self->_do_query($_) foreach @$action;
799 my @to_run = (ref $action eq 'ARRAY') ? (@$action) : ($action);
800 $self->_query_start(@to_run);
801 $self->_dbh->do(@to_run);
802 $self->_query_end(@to_run);
809 my ($self, @info) = @_;
811 $self->throw_exception("You failed to provide any connection info")
814 my ($old_connect_via, $dbh);
816 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
817 $old_connect_via = $DBI::connect_via;
818 $DBI::connect_via = 'connect';
822 if(ref $info[0] eq 'CODE') {
826 $dbh = DBI->connect(@info);
829 if($dbh && !$self->unsafe) {
830 my $weak_self = $self;
832 $dbh->{HandleError} = sub {
833 $weak_self->throw_exception("DBI Exception: $_[0]")
835 $dbh->{ShowErrorStatement} = 1;
836 $dbh->{RaiseError} = 1;
837 $dbh->{PrintError} = 0;
841 $DBI::connect_via = $old_connect_via if $old_connect_via;
843 $self->throw_exception("DBI Connection failed: " . ($@||$DBI::errstr))
846 $self->_dbh_autocommit($dbh->{AutoCommit});
854 $self->ensure_connected();
855 if($self->{transaction_depth} == 0) {
856 $self->debugobj->txn_begin()
858 # this isn't ->_dbh-> because
859 # we should reconnect on begin_work
860 # for AutoCommit users
861 $self->dbh->begin_work;
863 $self->{transaction_depth}++;
868 if ($self->{transaction_depth} == 1) {
869 my $dbh = $self->_dbh;
870 $self->debugobj->txn_commit()
873 $self->{transaction_depth} = 0
874 if $self->_dbh_autocommit;
876 elsif($self->{transaction_depth} > 1) {
877 $self->{transaction_depth}--
883 my $dbh = $self->_dbh;
885 if ($self->{transaction_depth} == 1) {
886 $self->debugobj->txn_rollback()
888 $self->{transaction_depth} = 0
889 if $self->_dbh_autocommit;
892 elsif($self->{transaction_depth} > 1) {
893 $self->{transaction_depth}--;
896 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
901 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
902 $error =~ /$exception_class/ and $self->throw_exception($error);
903 # ensure that a failed rollback resets the transaction depth
904 $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
905 $self->throw_exception($error);
909 # This used to be the top-half of _execute. It was split out to make it
910 # easier to override in NoBindVars without duping the rest. It takes up
911 # all of _execute's args, and emits $sql, @bind.
912 sub _prep_for_execute {
913 my ($self, $op, $extra_bind, $ident, $args) = @_;
915 my ($sql, @bind) = $self->sql_maker->$op($ident, @$args);
917 map { ref $_ eq 'ARRAY' ? $_ : [ '!!dummy', $_ ] } @$extra_bind)
920 return ($sql, \@bind);
923 sub _fix_bind_params {
924 my ($self, @bind) = @_;
926 ### Turn @bind from something like this:
927 ### ( [ "artist", 1 ], [ "cdid", 1, 3 ] )
929 ### ( "'1'", "'1'", "'3'" )
932 if ( defined( $_ && $_->[1] ) ) {
933 map { qq{'$_'}; } @{$_}[ 1 .. $#$_ ];
940 my ( $self, $sql, @bind ) = @_;
942 if ( $self->debug ) {
943 @bind = $self->_fix_bind_params(@bind);
944 $self->debugobj->query_start( $sql, @bind );
949 my ( $self, $sql, @bind ) = @_;
951 if ( $self->debug ) {
952 @bind = $self->_fix_bind_params(@bind);
953 $self->debugobj->query_end( $sql, @bind );
958 my ($self, $dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
960 if( blessed($ident) && $ident->isa("DBIx::Class::ResultSource") ) {
961 $ident = $ident->from();
964 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
966 $self->_query_start( $sql, @$bind );
968 my $sth = $self->sth($sql,$op);
970 my $placeholder_index = 1;
972 foreach my $bound (@$bind) {
974 my($column_name, @data) = @$bound;
976 if ($bind_attributes) {
977 $attributes = $bind_attributes->{$column_name}
978 if defined $bind_attributes->{$column_name};
981 foreach my $data (@data) {
982 $data = ref $data ? ''.$data : $data; # stringify args
984 $sth->bind_param($placeholder_index, $data, $attributes);
985 $placeholder_index++;
989 # Can this fail without throwing an exception anyways???
990 my $rv = $sth->execute();
991 $self->throw_exception($sth->errstr) if !$rv;
993 $self->_query_end( $sql, @$bind );
995 return (wantarray ? ($rv, $sth, @$bind) : $rv);
1000 $self->dbh_do($self->can('_dbh_execute'), @_)
1004 my ($self, $source, $to_insert) = @_;
1006 my $ident = $source->from;
1007 my $bind_attributes = $self->source_bind_attributes($source);
1009 $self->_execute('insert' => [], $source, $bind_attributes, $to_insert);
1014 ## Still not quite perfect, and EXPERIMENTAL
1015 ## Currently it is assumed that all values passed will be "normal", i.e. not
1016 ## scalar refs, or at least, all the same type as the first set, the statement is
1017 ## only prepped once.
1019 my ($self, $source, $cols, $data) = @_;
1021 my $table = $source->from;
1022 @colvalues{@$cols} = (0..$#$cols);
1023 my ($sql, @bind) = $self->sql_maker->insert($table, \%colvalues);
1025 $self->_query_start( $sql, @bind );
1026 my $sth = $self->sth($sql);
1028 # @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
1030 ## This must be an arrayref, else nothing works!
1032 my $tuple_status = [];
1035 ##print STDERR Dumper( $data, $sql, [@bind] );
1039 ## Get the bind_attributes, if any exist
1040 my $bind_attributes = $self->source_bind_attributes($source);
1042 ## Bind the values and execute
1043 my $placeholder_index = 1;
1045 foreach my $bound (@bind) {
1047 my $attributes = {};
1048 my ($column_name, $data_index) = @$bound;
1050 if( $bind_attributes ) {
1051 $attributes = $bind_attributes->{$column_name}
1052 if defined $bind_attributes->{$column_name};
1055 my @data = map { $_->[$data_index] } @$data;
1057 $sth->bind_param_array( $placeholder_index, [@data], $attributes );
1058 $placeholder_index++;
1060 my $rv = $sth->execute_array({ArrayTupleStatus => $tuple_status});
1061 $self->throw_exception($sth->errstr) if !$rv;
1063 $self->_query_end( $sql, @bind );
1064 return (wantarray ? ($rv, $sth, @bind) : $rv);
1068 my $self = shift @_;
1069 my $source = shift @_;
1070 my $bind_attributes = $self->source_bind_attributes($source);
1072 return $self->_execute('update' => [], $source, $bind_attributes, @_);
1077 my $self = shift @_;
1078 my $source = shift @_;
1080 my $bind_attrs = {}; ## If ever it's needed...
1082 return $self->_execute('delete' => [], $source, $bind_attrs, @_);
1086 my ($self, $ident, $select, $condition, $attrs) = @_;
1087 my $order = $attrs->{order_by};
1088 if (ref $condition eq 'SCALAR') {
1089 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
1091 if (exists $attrs->{group_by} || $attrs->{having}) {
1093 group_by => $attrs->{group_by},
1094 having => $attrs->{having},
1095 ($order ? (order_by => $order) : ())
1098 my $bind_attrs = {}; ## Future support
1099 my @args = ('select', $attrs->{bind}, $ident, $bind_attrs, $select, $condition, $order);
1100 if ($attrs->{software_limit} ||
1101 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
1102 $attrs->{software_limit} = 1;
1104 $self->throw_exception("rows attribute must be positive if present")
1105 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
1106 push @args, $attrs->{rows}, $attrs->{offset};
1108 return $self->_execute(@args);
1111 sub source_bind_attributes {
1112 my ($self, $source) = @_;
1114 my $bind_attributes;
1115 foreach my $column ($source->columns) {
1117 my $data_type = $source->column_info($column)->{data_type} || '';
1118 $bind_attributes->{$column} = $self->bind_attribute_by_data_type($data_type)
1122 return $bind_attributes;
1129 =item Arguments: $ident, $select, $condition, $attrs
1133 Handle a SQL select statement.
1139 my ($ident, $select, $condition, $attrs) = @_;
1140 return $self->cursor_class->new($self, \@_, $attrs);
1145 my ($rv, $sth, @bind) = $self->_select(@_);
1146 my @row = $sth->fetchrow_array;
1147 # Need to call finish() to work round broken DBDs
1156 =item Arguments: $sql
1160 Returns a L<DBI> sth (statement handle) for the supplied SQL.
1165 my ($self, $dbh, $sql) = @_;
1167 # 3 is the if_active parameter which avoids active sth re-use
1168 my $sth = $self->disable_sth_caching
1169 ? $dbh->prepare($sql)
1170 : $dbh->prepare_cached($sql, {}, 3);
1172 # XXX You would think RaiseError would make this impossible,
1173 # but apparently that's not true :(
1174 $self->throw_exception($dbh->errstr) if !$sth;
1180 my ($self, $sql) = @_;
1181 $self->dbh_do($self->can('_dbh_sth'), $sql);
1184 sub _dbh_columns_info_for {
1185 my ($self, $dbh, $table) = @_;
1187 if ($dbh->can('column_info')) {
1190 my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
1191 my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
1193 while ( my $info = $sth->fetchrow_hashref() ){
1195 $column_info{data_type} = $info->{TYPE_NAME};
1196 $column_info{size} = $info->{COLUMN_SIZE};
1197 $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
1198 $column_info{default_value} = $info->{COLUMN_DEF};
1199 my $col_name = $info->{COLUMN_NAME};
1200 $col_name =~ s/^\"(.*)\"$/$1/;
1202 $result{$col_name} = \%column_info;
1205 return \%result if !$@ && scalar keys %result;
1209 my $sth = $dbh->prepare($self->sql_maker->select($table, undef, \'1 = 0'));
1211 my @columns = @{$sth->{NAME_lc}};
1212 for my $i ( 0 .. $#columns ){
1214 $column_info{data_type} = $sth->{TYPE}->[$i];
1215 $column_info{size} = $sth->{PRECISION}->[$i];
1216 $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
1218 if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
1219 $column_info{data_type} = $1;
1220 $column_info{size} = $2;
1223 $result{$columns[$i]} = \%column_info;
1227 foreach my $col (keys %result) {
1228 my $colinfo = $result{$col};
1229 my $type_num = $colinfo->{data_type};
1231 if(defined $type_num && $dbh->can('type_info')) {
1232 my $type_info = $dbh->type_info($type_num);
1233 $type_name = $type_info->{TYPE_NAME} if $type_info;
1234 $colinfo->{data_type} = $type_name if $type_name;
1241 sub columns_info_for {
1242 my ($self, $table) = @_;
1243 $self->dbh_do($self->can('_dbh_columns_info_for'), $table);
1246 =head2 last_insert_id
1248 Return the row id of the last insert.
1252 sub _dbh_last_insert_id {
1253 my ($self, $dbh, $source, $col) = @_;
1254 # XXX This is a SQLite-ism as a default... is there a DBI-generic way?
1255 $dbh->func('last_insert_rowid');
1258 sub last_insert_id {
1260 $self->dbh_do($self->can('_dbh_last_insert_id'), @_);
1265 Returns the database driver name.
1269 sub sqlt_type { shift->dbh->{Driver}->{Name} }
1271 =head2 bind_attribute_by_data_type
1273 Given a datatype from column info, returns a database specific bind attribute for
1274 $dbh->bind_param($val,$attribute) or nothing if we will let the database planner
1277 Generally only needed for special case column types, like bytea in postgres.
1281 sub bind_attribute_by_data_type {
1285 =head2 create_ddl_dir
1289 =item Arguments: $schema \@databases, $version, $directory, $preversion, $sqlt_args
1293 Creates a SQL file based on the Schema, for each of the specified
1294 database types, in the given directory.
1300 my ($self, $schema, $databases, $version, $dir, $preversion, $sqltargs) = @_;
1302 if(!$dir || !-d $dir)
1304 warn "No directory given, using ./\n";
1307 $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
1308 $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
1309 $version ||= $schema->VERSION || '1.x';
1310 $sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} };
1312 $self->throw_exception(q{Can't create a ddl file without SQL::Translator 0.08: '}
1313 . $self->_check_sqlt_message . q{'})
1314 if !$self->_check_sqlt_version;
1316 my $sqlt = SQL::Translator->new({
1318 add_drop_table => 1,
1320 foreach my $db (@$databases)
1323 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
1324 # $sqlt->parser_args({'DBIx::Class' => $schema);
1325 $sqlt = $self->configure_sqlt($sqlt, $db);
1326 $sqlt->data($schema);
1327 $sqlt->producer($db);
1330 my $filename = $schema->ddl_filename($db, $dir, $version);
1333 warn("$filename already exists, skipping $db");
1337 my $output = $sqlt->translate;
1340 warn("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
1343 if(!open($file, ">$filename"))
1345 $self->throw_exception("Can't open $filename for writing ($!)");
1348 print $file $output;
1353 require SQL::Translator::Diff;
1355 my $prefilename = $schema->ddl_filename($db, $dir, $preversion);
1356 # print "Previous version $prefilename\n";
1357 if(!-e $prefilename)
1359 warn("No previous schema file found ($prefilename)");
1362 #### We need to reparse the SQLite file we just wrote, so that
1363 ## Diff doesnt get all confoosed, and Diff is *very* confused.
1364 ## FIXME: rip Diff to pieces!
1365 # my $target_schema = $sqlt->schema;
1366 # unless ( $target_schema->name ) {
1367 # $target_schema->name( $filename );
1370 push @input, {file => $prefilename, parser => $db};
1371 push @input, {file => $filename, parser => $db};
1372 my ( $source_schema, $source_db, $target_schema, $target_db ) = map {
1373 my $file = $_->{'file'};
1374 my $parser = $_->{'parser'};
1376 my $t = SQL::Translator->new;
1379 $t->parser( $parser ) or die $t->error;
1380 my $out = $t->translate( $file ) or die $t->error;
1381 my $schema = $t->schema;
1382 unless ( $schema->name ) {
1383 $schema->name( $file );
1388 my $diff = SQL::Translator::Diff::schema_diff($source_schema, $db,
1389 $target_schema, $db,
1392 my $difffile = $schema->ddl_filename($db, $dir, $version, $preversion);
1393 print STDERR "Diff: $difffile: $db, $dir, $version, $preversion \n";
1396 warn("$difffile already exists, skipping");
1399 if(!open $file, ">$difffile")
1401 $self->throw_exception("Can't write to $difffile ($!)");
1410 sub configure_sqlt() {
1413 my $db = shift || $self->sqlt_type;
1414 if ($db eq 'PostgreSQL') {
1415 $tr->quote_table_names(0);
1416 $tr->quote_field_names(0);
1421 =head2 deployment_statements
1425 =item Arguments: $schema, $type, $version, $directory, $sqlt_args
1429 Returns the statements used by L</deploy> and L<DBIx::Class::Schema/deploy>.
1430 The database driver name is given by C<$type>, though the value from
1431 L</sqlt_type> is used if it is not specified.
1433 C<$directory> is used to return statements from files in a previously created
1434 L</create_ddl_dir> directory and is optional. The filenames are constructed
1435 from L<DBIx::Class::Schema/ddl_filename>, the schema name and the C<$version>.
1437 If no C<$directory> is specified then the statements are constructed on the
1438 fly using L<SQL::Translator> and C<$version> is ignored.
1440 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>.
1444 sub deployment_statements {
1445 my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
1446 # Need to be connected to get the correct sqlt_type
1447 $self->ensure_connected() unless $type;
1448 $type ||= $self->sqlt_type;
1449 $version ||= $schema->VERSION || '1.x';
1451 my $filename = $schema->ddl_filename($type, $dir, $version);
1455 open($file, "<$filename")
1456 or $self->throw_exception("Can't open $filename ($!)");
1459 return join('', @rows);
1462 $self->throw_exception(q{Can't deploy without SQL::Translator 0.08: '}
1463 . $self->_check_sqlt_message . q{'})
1464 if !$self->_check_sqlt_version;
1466 require SQL::Translator::Parser::DBIx::Class;
1467 eval qq{use SQL::Translator::Producer::${type}};
1468 $self->throw_exception($@) if $@;
1470 # sources needs to be a parser arg, but for simplicty allow at top level
1472 $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources}
1473 if exists $sqltargs->{sources};
1475 my $tr = SQL::Translator->new(%$sqltargs);
1476 SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
1477 return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
1484 my ($self, $schema, $type, $sqltargs, $dir) = @_;
1485 foreach my $statement ( $self->deployment_statements($schema, $type, undef, $dir, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
1486 foreach my $line ( split(";\n", $statement)) {
1487 next if($line =~ /^--/);
1489 # next if($line =~ /^DROP/m);
1490 next if($line =~ /^BEGIN TRANSACTION/m);
1491 next if($line =~ /^COMMIT/m);
1492 next if $line =~ /^\s+$/; # skip whitespace only
1493 $self->_query_start($line);
1495 $self->dbh->do($line); # shouldn't be using ->dbh ?
1498 warn qq{$@ (running "${line}")};
1500 $self->_query_end($line);
1505 =head2 datetime_parser
1507 Returns the datetime parser class
1511 sub datetime_parser {
1513 return $self->{datetime_parser} ||= do {
1514 $self->ensure_connected;
1515 $self->build_datetime_parser(@_);
1519 =head2 datetime_parser_type
1521 Defines (returns) the datetime parser class - currently hardwired to
1522 L<DateTime::Format::MySQL>
1526 sub datetime_parser_type { "DateTime::Format::MySQL"; }
1528 =head2 build_datetime_parser
1530 See L</datetime_parser>
1534 sub build_datetime_parser {
1536 my $type = $self->datetime_parser_type(@_);
1538 $self->throw_exception("Couldn't load ${type}: $@") if $@;
1543 my $_check_sqlt_version; # private
1544 my $_check_sqlt_message; # private
1545 sub _check_sqlt_version {
1546 return $_check_sqlt_version if defined $_check_sqlt_version;
1547 eval 'use SQL::Translator 0.08';
1548 $_check_sqlt_message = $@ ? $@ : '';
1549 $_check_sqlt_version = $@ ? 0 : 1;
1552 sub _check_sqlt_message {
1553 _check_sqlt_version if !defined $_check_sqlt_message;
1554 $_check_sqlt_message;
1560 return if !$self->_dbh;
1569 The module defines a set of methods within the DBIC::SQL::Abstract
1570 namespace. These build on L<SQL::Abstract::Limit> to provide the
1571 SQL query functions.
1573 The following methods are extended:-
1587 See L</connect_info> for details.
1588 For setting, this method is deprecated in favor of L</connect_info>.
1592 See L</connect_info> for details.
1593 For setting, this method is deprecated in favor of L</connect_info>.
1597 See L</connect_info> for details.
1598 For setting, this method is deprecated in favor of L</connect_info>.
1604 Matt S. Trout <mst@shadowcatsystems.co.uk>
1606 Andy Grundman <andy@hybridized.org>
1610 You may distribute this code under the same terms as Perl itself.