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');
22 __PACKAGE__->mk_group_accessors('inherited' => qw/sql_maker_class/);
23 __PACKAGE__->sql_maker_class('DBIC::SQL::Abstract');
27 package DBIC::SQL::Abstract; # Would merge upstream, but nate doesn't reply :(
29 use base qw/SQL::Abstract::Limit/;
31 # This prevents the caching of $dbh in S::A::L, I believe
33 my $self = shift->SUPER::new(@_);
35 # If limit_dialect is a ref (like a $dbh), go ahead and replace
36 # it with what it resolves to:
37 $self->{limit_dialect} = $self->_find_syntax($self->{limit_dialect})
38 if ref $self->{limit_dialect};
44 my ($self, $sql, $order, $rows, $offset ) = @_;
47 my $last = $rows + $offset;
48 my ( $order_by ) = $self->_order_by( $order );
53 SELECT Q1.*, ROW_NUMBER() OVER( ) AS ROW_NUM FROM (
58 WHERE ROW_NUM BETWEEN $offset AND $last
64 # While we're at it, this should make LIMIT queries more efficient,
65 # without digging into things too deeply
66 use Scalar::Util 'blessed';
68 my ($self, $syntax) = @_;
69 my $dbhname = blessed($syntax) ? $syntax->{Driver}{Name} : $syntax;
70 if(ref($self) && $dbhname && $dbhname eq 'DB2') {
71 return 'RowNumberOver';
74 $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
78 my ($self, $table, $fields, $where, $order, @rest) = @_;
79 $table = $self->_quote($table) unless ref($table);
80 local $self->{rownum_hack_count} = 1
81 if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
82 @rest = (-1) unless defined $rest[0];
83 die "LIMIT 0 Does Not Compute" if $rest[0] == 0;
84 # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
85 local $self->{having_bind} = [];
86 my ($sql, @ret) = $self->SUPER::select(
87 $table, $self->_recurse_fields($fields), $where, $order, @rest
92 $self->{for} eq 'update' ? ' FOR UPDATE' :
93 $self->{for} eq 'shared' ? ' FOR SHARE' :
98 return wantarray ? ($sql, @ret, @{$self->{having_bind}}) : $sql;
104 $table = $self->_quote($table) unless ref($table);
105 $self->SUPER::insert($table, @_);
111 $table = $self->_quote($table) unless ref($table);
112 $self->SUPER::update($table, @_);
118 $table = $self->_quote($table) unless ref($table);
119 $self->SUPER::delete($table, @_);
125 return $_[1].$self->_order_by($_[2]);
127 return $self->SUPER::_emulate_limit(@_);
131 sub _recurse_fields {
132 my ($self, $fields, $params) = @_;
133 my $ref = ref $fields;
134 return $self->_quote($fields) unless $ref;
135 return $$fields if $ref eq 'SCALAR';
137 if ($ref eq 'ARRAY') {
138 return join(', ', map {
139 $self->_recurse_fields($_)
140 .(exists $self->{rownum_hack_count} && !($params && $params->{no_rownum_hack})
141 ? ' AS col'.$self->{rownum_hack_count}++
144 } elsif ($ref eq 'HASH') {
145 foreach my $func (keys %$fields) {
146 return $self->_sqlcase($func)
147 .'( '.$self->_recurse_fields($fields->{$func}).' )';
156 if (ref $_[0] eq 'HASH') {
157 if (defined $_[0]->{group_by}) {
158 $ret = $self->_sqlcase(' group by ')
159 .$self->_recurse_fields($_[0]->{group_by}, { no_rownum_hack => 1 });
161 if (defined $_[0]->{having}) {
163 ($frag, @extra) = $self->_recurse_where($_[0]->{having});
164 push(@{$self->{having_bind}}, @extra);
165 $ret .= $self->_sqlcase(' having ').$frag;
167 if (defined $_[0]->{order_by}) {
168 $ret .= $self->_order_by($_[0]->{order_by});
170 } elsif (ref $_[0] eq 'SCALAR') {
171 $ret = $self->_sqlcase(' order by ').${ $_[0] };
172 } elsif (ref $_[0] eq 'ARRAY' && @{$_[0]}) {
173 my @order = @{+shift};
174 $ret = $self->_sqlcase(' order by ')
176 my $r = $self->_order_by($_, @_);
177 $r =~ s/^ ?ORDER BY //i;
181 $ret = $self->SUPER::_order_by(@_);
186 sub _order_directions {
187 my ($self, $order) = @_;
188 $order = $order->{order_by} if ref $order eq 'HASH';
189 return $self->SUPER::_order_directions($order);
193 my ($self, $from) = @_;
194 if (ref $from eq 'ARRAY') {
195 return $self->_recurse_from(@$from);
196 } elsif (ref $from eq 'HASH') {
197 return $self->_make_as($from);
199 return $from; # would love to quote here but _table ends up getting called
200 # twice during an ->select without a limit clause due to
201 # the way S::A::Limit->select works. should maybe consider
202 # bypassing this and doing S::A::select($self, ...) in
203 # our select method above. meantime, quoting shims have
204 # been added to select/insert/update/delete here
209 my ($self, $from, @join) = @_;
211 push(@sqlf, $self->_make_as($from));
212 foreach my $j (@join) {
215 # check whether a join type exists
216 my $join_clause = '';
217 my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
218 if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
219 $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
221 $join_clause = ' JOIN ';
223 push(@sqlf, $join_clause);
225 if (ref $to eq 'ARRAY') {
226 push(@sqlf, '(', $self->_recurse_from(@$to), ')');
228 push(@sqlf, $self->_make_as($to));
230 push(@sqlf, ' ON ', $self->_join_condition($on));
232 return join('', @sqlf);
236 my ($self, $from) = @_;
237 return join(' ', map { (ref $_ eq 'SCALAR' ? $$_ : $self->_quote($_)) }
238 reverse each %{$self->_skip_options($from)});
242 my ($self, $hash) = @_;
244 $clean_hash->{$_} = $hash->{$_}
245 for grep {!/^-/} keys %$hash;
249 sub _join_condition {
250 my ($self, $cond) = @_;
251 if (ref $cond eq 'HASH') {
256 # XXX no throw_exception() in this package and croak() fails with strange results
257 Carp::croak(ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
258 if ref($v) ne 'SCALAR';
262 my $x = '= '.$self->_quote($v); $j{$_} = \$x;
265 return scalar($self->_recurse_where(\%j));
266 } elsif (ref $cond eq 'ARRAY') {
267 return join(' OR ', map { $self->_join_condition($_) } @$cond);
269 die "Can't handle this yet!";
274 my ($self, $label) = @_;
275 return '' unless defined $label;
276 return "*" if $label eq '*';
277 return $label unless $self->{quote_char};
278 if(ref $self->{quote_char} eq "ARRAY"){
279 return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
280 if !defined $self->{name_sep};
281 my $sep = $self->{name_sep};
282 return join($self->{name_sep},
283 map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
284 split(/\Q$sep\E/,$label));
286 return $self->SUPER::_quote($label);
291 $self->{limit_dialect} = shift if @_;
292 return $self->{limit_dialect};
297 $self->{quote_char} = shift if @_;
298 return $self->{quote_char};
303 $self->{name_sep} = shift if @_;
304 return $self->{name_sep};
307 } # End of BEGIN block
311 DBIx::Class::Storage::DBI - DBI storage handler
317 This class represents the connection to an RDBMS via L<DBI>. See
318 L<DBIx::Class::Storage> for general information. This pod only
319 documents DBI-specific methods and behaviors.
326 my $new = shift->next::method(@_);
328 $new->transaction_depth(0);
329 $new->_sql_maker_opts({});
330 $new->{_in_dbh_do} = 0;
331 $new->{_dbh_gen} = 0;
338 The arguments of C<connect_info> are always a single array reference.
340 This is normally accessed via L<DBIx::Class::Schema/connection>, which
341 encapsulates its argument list in an arrayref before calling
342 C<connect_info> here.
344 The arrayref can either contain the same set of arguments one would
345 normally pass to L<DBI/connect>, or a lone code reference which returns
346 a connected database handle. Please note that the L<DBI> docs
347 recommend that you always explicitly set C<AutoCommit> to either
348 C<0> or C<1>. L<DBIx::Class> further recommends that it be set
349 to C<1>, and that you perform transactions via our L</txn_do>
350 method. L<DBIx::Class> will set it to C<1> if you do not do explicitly
351 set it to zero. This is the default for most DBDs. See below for more
354 In either case, if the final argument in your connect_info happens
355 to be a hashref, C<connect_info> will look there for several
356 connection-specific options:
362 Specifies things to do immediately after connecting or re-connecting to
363 the database. Its value may contain:
367 =item an array reference
369 This contains SQL statements to execute in order. Each element contains
370 a string or a code reference that returns a string.
372 =item a code reference
374 This contains some code to execute. Unlike code references within an
375 array reference, its return value is ignored.
379 =item on_disconnect_do
381 Takes arguments in the same form as L<on_connect_do> and executes them
382 immediately before disconnecting from the database.
384 Note, this only runs if you explicitly call L<disconnect> on the
387 =item disable_sth_caching
389 If set to a true value, this option will disable the caching of
390 statement handles via L<DBI/prepare_cached>.
394 Sets the limit dialect. This is useful for JDBC-bridge among others
395 where the remote SQL-dialect cannot be determined by the name of the
400 Specifies what characters to use to quote table and column names. If
401 you use this you will want to specify L<name_sep> as well.
403 quote_char expects either a single character, in which case is it is placed
404 on either side of the table/column, or an arrayref of length 2 in which case the
405 table/column name is placed between the elements.
407 For example under MySQL you'd use C<quote_char =E<gt> '`'>, and user SQL Server you'd
408 use C<quote_char =E<gt> [qw/[ ]/]>.
412 This only needs to be used in conjunction with L<quote_char>, and is used to
413 specify the charecter that seperates elements (schemas, tables, columns) from
414 each other. In most cases this is simply a C<.>.
418 This Storage driver normally installs its own C<HandleError>, sets
419 C<RaiseError> and C<ShowErrorStatement> on, and sets C<PrintError> off on
420 all database handles, including those supplied by a coderef. It does this
421 so that it can have consistent and useful error behavior.
423 If you set this option to a true value, Storage will not do its usual
424 modifications to the database handle's attributes, and instead relies on
425 the settings in your connect_info DBI options (or the values you set in
426 your connection coderef, in the case that you are connecting via coderef).
428 Note that your custom settings can cause Storage to malfunction,
429 especially if you set a C<HandleError> handler that suppresses exceptions
430 and/or disable C<RaiseError>.
434 These options can be mixed in with your other L<DBI> connection attributes,
435 or placed in a seperate hashref after all other normal L<DBI> connection
438 Every time C<connect_info> is invoked, any previous settings for
439 these options will be cleared before setting the new ones, regardless of
440 whether any options are specified in the new C<connect_info>.
442 Another Important Note:
444 DBIC can do some wonderful magic with handling exceptions,
445 disconnections, and transactions when you use C<< AutoCommit => 1 >>
446 combined with C<txn_do> for transaction support.
448 If you set C<< AutoCommit => 0 >> in your connect info, then you are always
449 in an assumed transaction between commits, and you're telling us you'd
450 like to manage that manually. A lot of DBIC's magic protections
451 go away. We can't protect you from exceptions due to database
452 disconnects because we don't know anything about how to restart your
453 transactions. You're on your own for handling all sorts of exceptional
454 cases if you choose the C<< AutoCommit => 0 >> path, just as you would
459 # Simple SQLite connection
460 ->connect_info([ 'dbi:SQLite:./foo.db' ]);
463 ->connect_info([ sub { DBI->connect(...) } ]);
465 # A bit more complicated
472 { quote_char => q{"}, name_sep => q{.} },
476 # Equivalent to the previous example
482 { AutoCommit => 1, quote_char => q{"}, name_sep => q{.} },
486 # Subref + DBIC-specific connection options
489 sub { DBI->connect(...) },
493 on_connect_do => ['SET search_path TO myschema,otherschema,public'],
494 disable_sth_caching => 1,
502 my ($self, $info_arg) = @_;
504 return $self->_connect_info if !$info_arg;
506 # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
507 # the new set of options
508 $self->_sql_maker(undef);
509 $self->_sql_maker_opts({});
510 $self->_connect_info([@$info_arg]); # copy for _connect_info
512 my $dbi_info = [@$info_arg]; # copy for _dbi_connect_info
514 my $last_info = $dbi_info->[-1];
515 if(ref $last_info eq 'HASH') {
516 $last_info = { %$last_info }; # so delete is non-destructive
517 my @storage_option = qw(
518 on_connect_do on_disconnect_do disable_sth_caching unsafe cursor_class
520 for my $storage_opt (@storage_option) {
521 if(my $value = delete $last_info->{$storage_opt}) {
522 $self->$storage_opt($value);
525 for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
526 if(my $opt_val = delete $last_info->{$sql_maker_opt}) {
527 $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
530 # re-insert modified hashref
531 $dbi_info->[-1] = $last_info;
533 # Get rid of any trailing empty hashref
534 pop(@$dbi_info) if !keys %$last_info;
536 $self->_dbi_connect_info($dbi_info);
538 $self->_connect_info;
543 This method is deprecated in favor of setting via L</connect_info>.
547 Arguments: ($subref | $method_name), @extra_coderef_args?
549 Execute the given $subref or $method_name using the new exception-based
550 connection management.
552 The first two arguments will be the storage object that C<dbh_do> was called
553 on and a database handle to use. Any additional arguments will be passed
554 verbatim to the called subref as arguments 2 and onwards.
556 Using this (instead of $self->_dbh or $self->dbh) ensures correct
557 exception handling and reconnection (or failover in future subclasses).
559 Your subref should have no side-effects outside of the database, as
560 there is the potential for your subref to be partially double-executed
561 if the database connection was stale/dysfunctional.
565 my @stuff = $schema->storage->dbh_do(
567 my ($storage, $dbh, @cols) = @_;
568 my $cols = join(q{, }, @cols);
569 $dbh->selectrow_array("SELECT $cols FROM foo");
580 my $dbh = $self->_dbh;
582 return $self->$code($dbh, @_) if $self->{_in_dbh_do}
583 || $self->{transaction_depth};
585 local $self->{_in_dbh_do} = 1;
588 my $want_array = wantarray;
591 $self->_verify_pid if $dbh;
593 $self->_populate_dbh;
598 @result = $self->$code($dbh, @_);
600 elsif(defined $want_array) {
601 $result[0] = $self->$code($dbh, @_);
604 $self->$code($dbh, @_);
609 if(!$exception) { return $want_array ? @result : $result[0] }
611 $self->throw_exception($exception) if $self->connected;
613 # We were not connected - reconnect and retry, but let any
614 # exception fall right through this time
615 $self->_populate_dbh;
616 $self->$code($self->_dbh, @_);
619 # This is basically a blend of dbh_do above and DBIx::Class::Storage::txn_do.
620 # It also informs dbh_do to bypass itself while under the direction of txn_do,
621 # via $self->{_in_dbh_do} (this saves some redundant eval and errorcheck, etc)
626 ref $coderef eq 'CODE' or $self->throw_exception
627 ('$coderef must be a CODE reference');
629 return $coderef->(@_) if $self->{transaction_depth};
631 local $self->{_in_dbh_do} = 1;
634 my $want_array = wantarray;
639 $self->_verify_pid if $self->_dbh;
640 $self->_populate_dbh if !$self->_dbh;
644 @result = $coderef->(@_);
646 elsif(defined $want_array) {
647 $result[0] = $coderef->(@_);
656 if(!$exception) { return $want_array ? @result : $result[0] }
658 if($tried++ > 0 || $self->connected) {
659 eval { $self->txn_rollback };
660 my $rollback_exception = $@;
661 if($rollback_exception) {
662 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
663 $self->throw_exception($exception) # propagate nested rollback
664 if $rollback_exception =~ /$exception_class/;
666 $self->throw_exception(
667 "Transaction aborted: ${exception}. "
668 . "Rollback failed: ${rollback_exception}"
671 $self->throw_exception($exception)
674 # We were not connected, and was first try - reconnect and retry
676 $self->_populate_dbh;
682 Our C<disconnect> method also performs a rollback first if the
683 database is not in C<AutoCommit> mode.
690 if( $self->connected ) {
691 my $connection_do = $self->on_disconnect_do;
692 $self->_do_connection_actions($connection_do) if ref($connection_do);
694 $self->_dbh->rollback unless $self->_dbh_autocommit;
695 $self->_dbh->disconnect;
704 if(my $dbh = $self->_dbh) {
705 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
712 return 0 if !$self->_dbh;
714 return ($dbh->FETCH('Active') && $dbh->ping);
720 # handle pid changes correctly
721 # NOTE: assumes $self->_dbh is a valid $dbh
725 return if defined $self->_conn_pid && $self->_conn_pid == $$;
727 $self->_dbh->{InactiveDestroy} = 1;
734 sub ensure_connected {
737 unless ($self->connected) {
738 $self->_populate_dbh;
744 Returns the dbh - a data base handle of class L<DBI>.
751 $self->ensure_connected;
755 sub _sql_maker_args {
758 return ( bindtype=>'columns', limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
763 unless ($self->_sql_maker) {
764 my $sql_maker_class = $self->sql_maker_class;
765 $self->_sql_maker($sql_maker_class->new( $self->_sql_maker_args ));
767 return $self->_sql_maker;
774 my @info = @{$self->_dbi_connect_info || []};
775 $self->_dbh($self->_connect(@info));
777 # Always set the transaction depth on connect, since
778 # there is no transaction in progress by definition
779 $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
781 if(ref $self eq 'DBIx::Class::Storage::DBI') {
782 my $driver = $self->_dbh->{Driver}->{Name};
783 if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
784 bless $self, "DBIx::Class::Storage::DBI::${driver}";
789 my $connection_do = $self->on_connect_do;
790 $self->_do_connection_actions($connection_do) if ref($connection_do);
792 $self->_conn_pid($$);
793 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
796 sub _do_connection_actions {
798 my $connection_do = shift;
800 if (ref $connection_do eq 'ARRAY') {
801 $self->_do_query($_) foreach @$connection_do;
803 elsif (ref $connection_do eq 'CODE') {
811 my ($self, $action) = @_;
813 if (ref $action eq 'CODE') {
814 $action = $action->($self);
815 $self->_do_query($_) foreach @$action;
818 my @to_run = (ref $action eq 'ARRAY') ? (@$action) : ($action);
819 $self->_query_start(@to_run);
820 $self->_dbh->do(@to_run);
821 $self->_query_end(@to_run);
828 my ($self, @info) = @_;
830 $self->throw_exception("You failed to provide any connection info")
833 my ($old_connect_via, $dbh);
835 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
836 $old_connect_via = $DBI::connect_via;
837 $DBI::connect_via = 'connect';
841 if(ref $info[0] eq 'CODE') {
845 $dbh = DBI->connect(@info);
848 if($dbh && !$self->unsafe) {
849 my $weak_self = $self;
851 $dbh->{HandleError} = sub {
852 $weak_self->throw_exception("DBI Exception: $_[0]")
854 $dbh->{ShowErrorStatement} = 1;
855 $dbh->{RaiseError} = 1;
856 $dbh->{PrintError} = 0;
860 $DBI::connect_via = $old_connect_via if $old_connect_via;
862 $self->throw_exception("DBI Connection failed: " . ($@||$DBI::errstr))
865 $self->_dbh_autocommit($dbh->{AutoCommit});
871 my ($self, $name) = @_;
873 $self->throw_exception("You failed to provide a savepoint name!") if !$name;
875 if($self->{transaction_depth} == 0) {
876 warn("Can't use savepoints without a transaction.");
880 if(!$self->can('_svp_begin')) {
881 warn("Your Storage implementation doesn't support savepoints!");
884 $self->debugobj->svp_begin($name) if $self->debug;
885 $self->_svp_begin($self->dbh(), $name);
889 my ($self, $name) = @_;
891 $self->throw_exception("You failed to provide a savepoint name!") if !$name;
893 if($self->{transaction_depth} == 0) {
894 warn("Can't use savepoints without a transaction.");
898 if(!$self->can('_svp_release')) {
899 warn("Your Storage implementation doesn't support savepoint releasing!");
902 $self->debugobj->svp_release($name) if $self->debug;
903 $self->_svp_release($self->dbh(), $name);
907 my ($self, $name) = @_;
909 $self->throw_exception("You failed to provide a savepoint name!") if !$name;
911 if($self->{transaction_depth} == 0) {
912 warn("Can't use savepoints without a transaction.");
916 if(!$self->can('_svp_rollback')) {
917 warn("Your Storage implementation doesn't support savepoints!");
920 $self->debugobj->svp_rollback($name) if $self->debug;
921 $self->_svp_rollback($self->dbh(), $name);
926 $self->ensure_connected();
927 if($self->{transaction_depth} == 0) {
928 $self->debugobj->txn_begin()
930 # this isn't ->_dbh-> because
931 # we should reconnect on begin_work
932 # for AutoCommit users
933 $self->dbh->begin_work;
935 $self->{transaction_depth}++;
940 if ($self->{transaction_depth} == 1) {
941 my $dbh = $self->_dbh;
942 $self->debugobj->txn_commit()
945 $self->{transaction_depth} = 0
946 if $self->_dbh_autocommit;
948 elsif($self->{transaction_depth} > 1) {
949 $self->{transaction_depth}--
955 my $dbh = $self->_dbh;
957 if ($self->{transaction_depth} == 1) {
958 $self->debugobj->txn_rollback()
960 $self->{transaction_depth} = 0
961 if $self->_dbh_autocommit;
964 elsif($self->{transaction_depth} > 1) {
965 $self->{transaction_depth}--;
968 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
973 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
974 $error =~ /$exception_class/ and $self->throw_exception($error);
975 # ensure that a failed rollback resets the transaction depth
976 $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
977 $self->throw_exception($error);
981 # This used to be the top-half of _execute. It was split out to make it
982 # easier to override in NoBindVars without duping the rest. It takes up
983 # all of _execute's args, and emits $sql, @bind.
984 sub _prep_for_execute {
985 my ($self, $op, $extra_bind, $ident, $args) = @_;
987 my ($sql, @bind) = $self->sql_maker->$op($ident, @$args);
989 map { ref $_ eq 'ARRAY' ? $_ : [ '!!dummy', $_ ] } @$extra_bind)
992 return ($sql, \@bind);
995 sub _fix_bind_params {
996 my ($self, @bind) = @_;
998 ### Turn @bind from something like this:
999 ### ( [ "artist", 1 ], [ "cdid", 1, 3 ] )
1001 ### ( "'1'", "'1'", "'3'" )
1004 if ( defined( $_ && $_->[1] ) ) {
1005 map { qq{'$_'}; } @{$_}[ 1 .. $#$_ ];
1012 my ( $self, $sql, @bind ) = @_;
1014 if ( $self->debug ) {
1015 @bind = $self->_fix_bind_params(@bind);
1016 $self->debugobj->query_start( $sql, @bind );
1021 my ( $self, $sql, @bind ) = @_;
1023 if ( $self->debug ) {
1024 @bind = $self->_fix_bind_params(@bind);
1025 $self->debugobj->query_end( $sql, @bind );
1030 my ($self, $dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
1032 if( blessed($ident) && $ident->isa("DBIx::Class::ResultSource") ) {
1033 $ident = $ident->from();
1036 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
1038 $self->_query_start( $sql, @$bind );
1040 my $sth = $self->sth($sql,$op);
1042 my $placeholder_index = 1;
1044 foreach my $bound (@$bind) {
1045 my $attributes = {};
1046 my($column_name, @data) = @$bound;
1048 if ($bind_attributes) {
1049 $attributes = $bind_attributes->{$column_name}
1050 if defined $bind_attributes->{$column_name};
1053 foreach my $data (@data) {
1054 $data = ref $data ? ''.$data : $data; # stringify args
1056 $sth->bind_param($placeholder_index, $data, $attributes);
1057 $placeholder_index++;
1061 # Can this fail without throwing an exception anyways???
1062 my $rv = $sth->execute();
1063 $self->throw_exception($sth->errstr) if !$rv;
1065 $self->_query_end( $sql, @$bind );
1067 return (wantarray ? ($rv, $sth, @$bind) : $rv);
1072 $self->dbh_do('_dbh_execute', @_)
1076 my ($self, $source, $to_insert) = @_;
1078 my $ident = $source->from;
1079 my $bind_attributes = $self->source_bind_attributes($source);
1081 foreach my $col ( $source->columns ) {
1082 if ( !defined $to_insert->{$col} ) {
1083 my $col_info = $source->column_info($col);
1085 if ( $col_info->{auto_nextval} ) {
1086 $self->ensure_connected;
1087 $to_insert->{$col} = $self->_sequence_fetch( 'nextval', $col_info->{sequence} || $self->_dbh_get_autoinc_seq($self->dbh, $source) );
1092 $self->_execute('insert' => [], $source, $bind_attributes, $to_insert);
1097 ## Still not quite perfect, and EXPERIMENTAL
1098 ## Currently it is assumed that all values passed will be "normal", i.e. not
1099 ## scalar refs, or at least, all the same type as the first set, the statement is
1100 ## only prepped once.
1102 my ($self, $source, $cols, $data) = @_;
1104 my $table = $source->from;
1105 @colvalues{@$cols} = (0..$#$cols);
1106 my ($sql, @bind) = $self->sql_maker->insert($table, \%colvalues);
1108 $self->_query_start( $sql, @bind );
1109 my $sth = $self->sth($sql);
1111 # @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
1113 ## This must be an arrayref, else nothing works!
1115 my $tuple_status = [];
1118 ##print STDERR Dumper( $data, $sql, [@bind] );
1122 ## Get the bind_attributes, if any exist
1123 my $bind_attributes = $self->source_bind_attributes($source);
1125 ## Bind the values and execute
1126 my $placeholder_index = 1;
1128 foreach my $bound (@bind) {
1130 my $attributes = {};
1131 my ($column_name, $data_index) = @$bound;
1133 if( $bind_attributes ) {
1134 $attributes = $bind_attributes->{$column_name}
1135 if defined $bind_attributes->{$column_name};
1138 my @data = map { $_->[$data_index] } @$data;
1140 $sth->bind_param_array( $placeholder_index, [@data], $attributes );
1141 $placeholder_index++;
1143 my $rv = $sth->execute_array({ArrayTupleStatus => $tuple_status});
1144 $self->throw_exception($sth->errstr) if !$rv;
1146 $self->_query_end( $sql, @bind );
1147 return (wantarray ? ($rv, $sth, @bind) : $rv);
1151 my $self = shift @_;
1152 my $source = shift @_;
1153 my $bind_attributes = $self->source_bind_attributes($source);
1155 return $self->_execute('update' => [], $source, $bind_attributes, @_);
1160 my $self = shift @_;
1161 my $source = shift @_;
1163 my $bind_attrs = {}; ## If ever it's needed...
1165 return $self->_execute('delete' => [], $source, $bind_attrs, @_);
1169 my ($self, $ident, $select, $condition, $attrs) = @_;
1170 my $order = $attrs->{order_by};
1172 if (ref $condition eq 'SCALAR') {
1173 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
1176 my $for = delete $attrs->{for};
1177 my $sql_maker = $self->sql_maker;
1178 local $sql_maker->{for} = $for;
1180 if (exists $attrs->{group_by} || $attrs->{having}) {
1182 group_by => $attrs->{group_by},
1183 having => $attrs->{having},
1184 ($order ? (order_by => $order) : ())
1187 my $bind_attrs = {}; ## Future support
1188 my @args = ('select', $attrs->{bind}, $ident, $bind_attrs, $select, $condition, $order);
1189 if ($attrs->{software_limit} ||
1190 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
1191 $attrs->{software_limit} = 1;
1193 $self->throw_exception("rows attribute must be positive if present")
1194 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
1196 # MySQL actually recommends this approach. I cringe.
1197 $attrs->{rows} = 2**48 if not defined $attrs->{rows} and defined $attrs->{offset};
1198 push @args, $attrs->{rows}, $attrs->{offset};
1201 return $self->_execute(@args);
1204 sub source_bind_attributes {
1205 my ($self, $source) = @_;
1207 my $bind_attributes;
1208 foreach my $column ($source->columns) {
1210 my $data_type = $source->column_info($column)->{data_type} || '';
1211 $bind_attributes->{$column} = $self->bind_attribute_by_data_type($data_type)
1215 return $bind_attributes;
1222 =item Arguments: $ident, $select, $condition, $attrs
1226 Handle a SQL select statement.
1232 my ($ident, $select, $condition, $attrs) = @_;
1233 return $self->cursor_class->new($self, \@_, $attrs);
1238 my ($rv, $sth, @bind) = $self->_select(@_);
1239 my @row = $sth->fetchrow_array;
1240 # Need to call finish() to work round broken DBDs
1249 =item Arguments: $sql
1253 Returns a L<DBI> sth (statement handle) for the supplied SQL.
1258 my ($self, $dbh, $sql) = @_;
1260 # 3 is the if_active parameter which avoids active sth re-use
1261 my $sth = $self->disable_sth_caching
1262 ? $dbh->prepare($sql)
1263 : $dbh->prepare_cached($sql, {}, 3);
1265 # XXX You would think RaiseError would make this impossible,
1266 # but apparently that's not true :(
1267 $self->throw_exception($dbh->errstr) if !$sth;
1273 my ($self, $sql) = @_;
1274 $self->dbh_do('_dbh_sth', $sql);
1277 sub _dbh_columns_info_for {
1278 my ($self, $dbh, $table) = @_;
1280 if ($dbh->can('column_info')) {
1283 my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
1284 my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
1286 while ( my $info = $sth->fetchrow_hashref() ){
1288 $column_info{data_type} = $info->{TYPE_NAME};
1289 $column_info{size} = $info->{COLUMN_SIZE};
1290 $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
1291 $column_info{default_value} = $info->{COLUMN_DEF};
1292 my $col_name = $info->{COLUMN_NAME};
1293 $col_name =~ s/^\"(.*)\"$/$1/;
1295 $result{$col_name} = \%column_info;
1298 return \%result if !$@ && scalar keys %result;
1302 my $sth = $dbh->prepare($self->sql_maker->select($table, undef, \'1 = 0'));
1304 my @columns = @{$sth->{NAME_lc}};
1305 for my $i ( 0 .. $#columns ){
1307 $column_info{data_type} = $sth->{TYPE}->[$i];
1308 $column_info{size} = $sth->{PRECISION}->[$i];
1309 $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
1311 if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
1312 $column_info{data_type} = $1;
1313 $column_info{size} = $2;
1316 $result{$columns[$i]} = \%column_info;
1320 foreach my $col (keys %result) {
1321 my $colinfo = $result{$col};
1322 my $type_num = $colinfo->{data_type};
1324 if(defined $type_num && $dbh->can('type_info')) {
1325 my $type_info = $dbh->type_info($type_num);
1326 $type_name = $type_info->{TYPE_NAME} if $type_info;
1327 $colinfo->{data_type} = $type_name if $type_name;
1334 sub columns_info_for {
1335 my ($self, $table) = @_;
1336 $self->dbh_do('_dbh_columns_info_for', $table);
1339 =head2 last_insert_id
1341 Return the row id of the last insert.
1345 sub _dbh_last_insert_id {
1346 my ($self, $dbh, $source, $col) = @_;
1347 # XXX This is a SQLite-ism as a default... is there a DBI-generic way?
1348 $dbh->func('last_insert_rowid');
1351 sub last_insert_id {
1353 $self->dbh_do('_dbh_last_insert_id', @_);
1358 Returns the database driver name.
1362 sub sqlt_type { shift->dbh->{Driver}->{Name} }
1364 =head2 bind_attribute_by_data_type
1366 Given a datatype from column info, returns a database specific bind attribute for
1367 $dbh->bind_param($val,$attribute) or nothing if we will let the database planner
1370 Generally only needed for special case column types, like bytea in postgres.
1374 sub bind_attribute_by_data_type {
1378 =head2 create_ddl_dir
1382 =item Arguments: $schema \@databases, $version, $directory, $preversion, $sqlt_args
1386 Creates a SQL file based on the Schema, for each of the specified
1387 database types, in the given directory.
1393 my ($self, $schema, $databases, $version, $dir, $preversion, $sqltargs) = @_;
1395 if(!$dir || !-d $dir)
1397 warn "No directory given, using ./\n";
1400 $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
1401 $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
1402 $version ||= $schema->VERSION || '1.x';
1403 $sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} };
1405 $self->throw_exception(q{Can't create a ddl file without SQL::Translator 0.09: '}
1406 . $self->_check_sqlt_message . q{'})
1407 if !$self->_check_sqlt_version;
1409 my $sqlt = SQL::Translator->new( $sqltargs );
1411 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
1412 my $sqlt_schema = $sqlt->translate({ data => $schema }) or die $sqlt->error;
1414 foreach my $db (@$databases)
1417 $sqlt = $self->configure_sqlt($sqlt, $db);
1418 $sqlt->{schema} = $sqlt_schema;
1419 $sqlt->producer($db);
1422 my $filename = $schema->ddl_filename($db, $dir, $version);
1425 warn("$filename already exists, skipping $db");
1426 next unless ($preversion);
1428 my $output = $sqlt->translate;
1431 warn("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
1434 if(!open($file, ">$filename"))
1436 $self->throw_exception("Can't open $filename for writing ($!)");
1439 print $file $output;
1444 require SQL::Translator::Diff;
1446 my $prefilename = $schema->ddl_filename($db, $dir, $preversion);
1447 # print "Previous version $prefilename\n";
1448 if(!-e $prefilename)
1450 warn("No previous schema file found ($prefilename)");
1454 my $difffile = $schema->ddl_filename($db, $dir, $version, $preversion);
1455 print STDERR "Diff: $difffile: $db, $dir, $version, $preversion \n";
1458 warn("$difffile already exists, skipping");
1464 my $t = SQL::Translator->new($sqltargs);
1467 $t->parser( $db ) or die $t->error;
1468 $t = $self->configure_sqlt($t, $db);
1469 my $out = $t->translate( $prefilename ) or die $t->error;
1470 $source_schema = $t->schema;
1471 unless ( $source_schema->name ) {
1472 $source_schema->name( $prefilename );
1476 # The "new" style of producers have sane normalization and can support
1477 # diffing a SQL file against a DBIC->SQLT schema. Old style ones don't
1478 # And we have to diff parsed SQL against parsed SQL.
1479 my $dest_schema = $sqlt_schema;
1481 unless ( "SQL::Translator::Producer::$db"->can('preprocess_schema') ) {
1482 my $t = SQL::Translator->new($sqltargs);
1485 $t->parser( $db ) or die $t->error;
1486 $t = $self->configure_sqlt($t, $db);
1487 my $out = $t->translate( $filename ) or die $t->error;
1488 $dest_schema = $t->schema;
1489 $dest_schema->name( $filename )
1490 unless $dest_schema->name;
1493 my $diff = SQL::Translator::Diff::schema_diff($source_schema, $db,
1497 if(!open $file, ">$difffile")
1499 $self->throw_exception("Can't write to $difffile ($!)");
1508 sub configure_sqlt() {
1511 my $db = shift || $self->sqlt_type;
1512 if ($db eq 'PostgreSQL') {
1513 $tr->quote_table_names(0);
1514 $tr->quote_field_names(0);
1519 =head2 deployment_statements
1523 =item Arguments: $schema, $type, $version, $directory, $sqlt_args
1527 Returns the statements used by L</deploy> and L<DBIx::Class::Schema/deploy>.
1528 The database driver name is given by C<$type>, though the value from
1529 L</sqlt_type> is used if it is not specified.
1531 C<$directory> is used to return statements from files in a previously created
1532 L</create_ddl_dir> directory and is optional. The filenames are constructed
1533 from L<DBIx::Class::Schema/ddl_filename>, the schema name and the C<$version>.
1535 If no C<$directory> is specified then the statements are constructed on the
1536 fly using L<SQL::Translator> and C<$version> is ignored.
1538 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>.
1542 sub deployment_statements {
1543 my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
1544 # Need to be connected to get the correct sqlt_type
1545 $self->ensure_connected() unless $type;
1546 $type ||= $self->sqlt_type;
1547 $version ||= $schema->VERSION || '1.x';
1549 my $filename = $schema->ddl_filename($type, $dir, $version);
1553 open($file, "<$filename")
1554 or $self->throw_exception("Can't open $filename ($!)");
1557 return join('', @rows);
1560 $self->throw_exception(q{Can't deploy without SQL::Translator 0.09: '}
1561 . $self->_check_sqlt_message . q{'})
1562 if !$self->_check_sqlt_version;
1564 require SQL::Translator::Parser::DBIx::Class;
1565 eval qq{use SQL::Translator::Producer::${type}};
1566 $self->throw_exception($@) if $@;
1568 # sources needs to be a parser arg, but for simplicty allow at top level
1570 $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources}
1571 if exists $sqltargs->{sources};
1573 my $tr = SQL::Translator->new(%$sqltargs);
1574 SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
1575 return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
1582 my ($self, $schema, $type, $sqltargs, $dir) = @_;
1583 foreach my $statement ( $self->deployment_statements($schema, $type, undef, $dir, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
1584 foreach my $line ( split(";\n", $statement)) {
1585 next if($line =~ /^--/);
1587 # next if($line =~ /^DROP/m);
1588 next if($line =~ /^BEGIN TRANSACTION/m);
1589 next if($line =~ /^COMMIT/m);
1590 next if $line =~ /^\s+$/; # skip whitespace only
1591 $self->_query_start($line);
1593 $self->dbh->do($line); # shouldn't be using ->dbh ?
1596 warn qq{$@ (running "${line}")};
1598 $self->_query_end($line);
1603 =head2 datetime_parser
1605 Returns the datetime parser class
1609 sub datetime_parser {
1611 return $self->{datetime_parser} ||= do {
1612 $self->ensure_connected;
1613 $self->build_datetime_parser(@_);
1617 =head2 datetime_parser_type
1619 Defines (returns) the datetime parser class - currently hardwired to
1620 L<DateTime::Format::MySQL>
1624 sub datetime_parser_type { "DateTime::Format::MySQL"; }
1626 =head2 build_datetime_parser
1628 See L</datetime_parser>
1632 sub build_datetime_parser {
1634 my $type = $self->datetime_parser_type(@_);
1636 $self->throw_exception("Couldn't load ${type}: $@") if $@;
1641 my $_check_sqlt_version; # private
1642 my $_check_sqlt_message; # private
1643 sub _check_sqlt_version {
1644 return $_check_sqlt_version if defined $_check_sqlt_version;
1645 eval 'use SQL::Translator "0.09"';
1646 $_check_sqlt_message = $@ || '';
1647 $_check_sqlt_version = !$@;
1650 sub _check_sqlt_message {
1651 _check_sqlt_version if !defined $_check_sqlt_message;
1652 $_check_sqlt_message;
1658 return if !$self->_dbh;
1667 The module defines a set of methods within the DBIC::SQL::Abstract
1668 namespace. These build on L<SQL::Abstract::Limit> to provide the
1669 SQL query functions.
1671 The following methods are extended:-
1685 See L</connect_info> for details.
1686 For setting, this method is deprecated in favor of L</connect_info>.
1690 See L</connect_info> for details.
1691 For setting, this method is deprecated in favor of L</connect_info>.
1695 See L</connect_info> for details.
1696 For setting, this method is deprecated in favor of L</connect_info>.
1702 Matt S. Trout <mst@shadowcatsystems.co.uk>
1704 Andy Grundman <andy@hybridized.org>
1708 You may distribute this code under the same terms as Perl itself.