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
21 __PACKAGE__->cursor_class('DBIx::Class::Storage::DBI::Cursor');
23 __PACKAGE__->mk_group_accessors('inherited' => qw/sql_maker_class/);
24 __PACKAGE__->sql_maker_class('DBIC::SQL::Abstract');
28 package DBIC::SQL::Abstract; # Would merge upstream, but nate doesn't reply :(
30 use base qw/SQL::Abstract::Limit/;
32 # This prevents the caching of $dbh in S::A::L, I believe
34 my $self = shift->SUPER::new(@_);
36 # If limit_dialect is a ref (like a $dbh), go ahead and replace
37 # it with what it resolves to:
38 $self->{limit_dialect} = $self->_find_syntax($self->{limit_dialect})
39 if ref $self->{limit_dialect};
45 my ($self, $sql, $order, $rows, $offset ) = @_;
48 my $last = $rows + $offset;
49 my ( $order_by ) = $self->_order_by( $order );
54 SELECT Q1.*, ROW_NUMBER() OVER( ) AS ROW_NUM FROM (
59 WHERE ROW_NUM BETWEEN $offset AND $last
65 # While we're at it, this should make LIMIT queries more efficient,
66 # without digging into things too deeply
67 use Scalar::Util 'blessed';
69 my ($self, $syntax) = @_;
70 my $dbhname = blessed($syntax) ? $syntax->{Driver}{Name} : $syntax;
71 if(ref($self) && $dbhname && $dbhname eq 'DB2') {
72 return 'RowNumberOver';
75 $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
79 my ($self, $table, $fields, $where, $order, @rest) = @_;
80 $table = $self->_quote($table) unless ref($table);
81 local $self->{rownum_hack_count} = 1
82 if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
83 @rest = (-1) unless defined $rest[0];
84 die "LIMIT 0 Does Not Compute" if $rest[0] == 0;
85 # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
86 local $self->{having_bind} = [];
87 my ($sql, @ret) = $self->SUPER::select(
88 $table, $self->_recurse_fields($fields), $where, $order, @rest
93 $self->{for} eq 'update' ? ' FOR UPDATE' :
94 $self->{for} eq 'shared' ? ' FOR SHARE' :
99 return wantarray ? ($sql, @ret, @{$self->{having_bind}}) : $sql;
105 $table = $self->_quote($table) unless ref($table);
106 $self->SUPER::insert($table, @_);
112 $table = $self->_quote($table) unless ref($table);
113 $self->SUPER::update($table, @_);
119 $table = $self->_quote($table) unless ref($table);
120 $self->SUPER::delete($table, @_);
126 return $_[1].$self->_order_by($_[2]);
128 return $self->SUPER::_emulate_limit(@_);
132 sub _recurse_fields {
133 my ($self, $fields, $params) = @_;
134 my $ref = ref $fields;
135 return $self->_quote($fields) unless $ref;
136 return $$fields if $ref eq 'SCALAR';
138 if ($ref eq 'ARRAY') {
139 return join(', ', map {
140 $self->_recurse_fields($_)
141 .(exists $self->{rownum_hack_count} && !($params && $params->{no_rownum_hack})
142 ? ' AS col'.$self->{rownum_hack_count}++
145 } elsif ($ref eq 'HASH') {
146 foreach my $func (keys %$fields) {
147 return $self->_sqlcase($func)
148 .'( '.$self->_recurse_fields($fields->{$func}).' )';
157 if (ref $_[0] eq 'HASH') {
158 if (defined $_[0]->{group_by}) {
159 $ret = $self->_sqlcase(' group by ')
160 .$self->_recurse_fields($_[0]->{group_by}, { no_rownum_hack => 1 });
162 if (defined $_[0]->{having}) {
164 ($frag, @extra) = $self->_recurse_where($_[0]->{having});
165 push(@{$self->{having_bind}}, @extra);
166 $ret .= $self->_sqlcase(' having ').$frag;
168 if (defined $_[0]->{order_by}) {
169 $ret .= $self->_order_by($_[0]->{order_by});
171 } elsif (ref $_[0] eq 'SCALAR') {
172 $ret = $self->_sqlcase(' order by ').${ $_[0] };
173 } elsif (ref $_[0] eq 'ARRAY' && @{$_[0]}) {
174 my @order = @{+shift};
175 $ret = $self->_sqlcase(' order by ')
177 my $r = $self->_order_by($_, @_);
178 $r =~ s/^ ?ORDER BY //i;
182 $ret = $self->SUPER::_order_by(@_);
187 sub _order_directions {
188 my ($self, $order) = @_;
189 $order = $order->{order_by} if ref $order eq 'HASH';
190 return $self->SUPER::_order_directions($order);
194 my ($self, $from) = @_;
195 if (ref $from eq 'ARRAY') {
196 return $self->_recurse_from(@$from);
197 } elsif (ref $from eq 'HASH') {
198 return $self->_make_as($from);
200 return $from; # would love to quote here but _table ends up getting called
201 # twice during an ->select without a limit clause due to
202 # the way S::A::Limit->select works. should maybe consider
203 # bypassing this and doing S::A::select($self, ...) in
204 # our select method above. meantime, quoting shims have
205 # been added to select/insert/update/delete here
210 my ($self, $from, @join) = @_;
212 push(@sqlf, $self->_make_as($from));
213 foreach my $j (@join) {
216 # check whether a join type exists
217 my $join_clause = '';
218 my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
219 if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
220 $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
222 $join_clause = ' JOIN ';
224 push(@sqlf, $join_clause);
226 if (ref $to eq 'ARRAY') {
227 push(@sqlf, '(', $self->_recurse_from(@$to), ')');
229 push(@sqlf, $self->_make_as($to));
231 push(@sqlf, ' ON ', $self->_join_condition($on));
233 return join('', @sqlf);
237 my ($self, $from) = @_;
238 return join(' ', map { (ref $_ eq 'SCALAR' ? $$_ : $self->_quote($_)) }
239 reverse each %{$self->_skip_options($from)});
243 my ($self, $hash) = @_;
245 $clean_hash->{$_} = $hash->{$_}
246 for grep {!/^-/} keys %$hash;
250 sub _join_condition {
251 my ($self, $cond) = @_;
252 if (ref $cond eq 'HASH') {
257 # XXX no throw_exception() in this package and croak() fails with strange results
258 Carp::croak(ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
259 if ref($v) ne 'SCALAR';
263 my $x = '= '.$self->_quote($v); $j{$_} = \$x;
266 return scalar($self->_recurse_where(\%j));
267 } elsif (ref $cond eq 'ARRAY') {
268 return join(' OR ', map { $self->_join_condition($_) } @$cond);
270 die "Can't handle this yet!";
275 my ($self, $label) = @_;
276 return '' unless defined $label;
277 return "*" if $label eq '*';
278 return $label unless $self->{quote_char};
279 if(ref $self->{quote_char} eq "ARRAY"){
280 return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
281 if !defined $self->{name_sep};
282 my $sep = $self->{name_sep};
283 return join($self->{name_sep},
284 map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
285 split(/\Q$sep\E/,$label));
287 return $self->SUPER::_quote($label);
292 $self->{limit_dialect} = shift if @_;
293 return $self->{limit_dialect};
298 $self->{quote_char} = shift if @_;
299 return $self->{quote_char};
304 $self->{name_sep} = shift if @_;
305 return $self->{name_sep};
308 } # End of BEGIN block
312 DBIx::Class::Storage::DBI - DBI storage handler
318 This class represents the connection to an RDBMS via L<DBI>. See
319 L<DBIx::Class::Storage> for general information. This pod only
320 documents DBI-specific methods and behaviors.
327 my $new = shift->next::method(@_);
329 $new->transaction_depth(0);
330 $new->_sql_maker_opts({});
331 $new->{_in_dbh_do} = 0;
332 $new->{_dbh_gen} = 0;
339 The arguments of C<connect_info> are always a single array reference.
341 This is normally accessed via L<DBIx::Class::Schema/connection>, which
342 encapsulates its argument list in an arrayref before calling
343 C<connect_info> here.
345 The arrayref can either contain the same set of arguments one would
346 normally pass to L<DBI/connect>, or a lone code reference which returns
347 a connected database handle. Please note that the L<DBI> docs
348 recommend that you always explicitly set C<AutoCommit> to either
349 C<0> or C<1>. L<DBIx::Class> further recommends that it be set
350 to C<1>, and that you perform transactions via our L</txn_do>
351 method. L<DBIx::Class> will set it to C<1> if you do not do explicitly
352 set it to zero. This is the default for most DBDs. See below for more
355 In either case, if the final argument in your connect_info happens
356 to be a hashref, C<connect_info> will look there for several
357 connection-specific options:
363 Specifies things to do immediately after connecting or re-connecting to
364 the database. Its value may contain:
368 =item an array reference
370 This contains SQL statements to execute in order. Each element contains
371 a string or a code reference that returns a string.
373 =item a code reference
375 This contains some code to execute. Unlike code references within an
376 array reference, its return value is ignored.
380 =item on_disconnect_do
382 Takes arguments in the same form as L<on_connect_do> and executes them
383 immediately before disconnecting from the database.
385 Note, this only runs if you explicitly call L<disconnect> on the
388 =item disable_sth_caching
390 If set to a true value, this option will disable the caching of
391 statement handles via L<DBI/prepare_cached>.
395 Sets the limit dialect. This is useful for JDBC-bridge among others
396 where the remote SQL-dialect cannot be determined by the name of the
401 Specifies what characters to use to quote table and column names. If
402 you use this you will want to specify L<name_sep> as well.
404 quote_char expects either a single character, in which case is it is placed
405 on either side of the table/column, or an arrayref of length 2 in which case the
406 table/column name is placed between the elements.
408 For example under MySQL you'd use C<quote_char =E<gt> '`'>, and user SQL Server you'd
409 use C<quote_char =E<gt> [qw/[ ]/]>.
413 This only needs to be used in conjunction with L<quote_char>, and is used to
414 specify the charecter that seperates elements (schemas, tables, columns) from
415 each other. In most cases this is simply a C<.>.
419 This Storage driver normally installs its own C<HandleError>, sets
420 C<RaiseError> and C<ShowErrorStatement> on, and sets C<PrintError> off on
421 all database handles, including those supplied by a coderef. It does this
422 so that it can have consistent and useful error behavior.
424 If you set this option to a true value, Storage will not do its usual
425 modifications to the database handle's attributes, and instead relies on
426 the settings in your connect_info DBI options (or the values you set in
427 your connection coderef, in the case that you are connecting via coderef).
429 Note that your custom settings can cause Storage to malfunction,
430 especially if you set a C<HandleError> handler that suppresses exceptions
431 and/or disable C<RaiseError>.
435 If this option is true, L<DBIx::Class> will use savepoints when nesting
436 transactions, making it possible to recover from failure in the inner
437 transaction without having to abort all outer transactions.
441 These options can be mixed in with your other L<DBI> connection attributes,
442 or placed in a seperate hashref after all other normal L<DBI> connection
445 Every time C<connect_info> is invoked, any previous settings for
446 these options will be cleared before setting the new ones, regardless of
447 whether any options are specified in the new C<connect_info>.
449 Another Important Note:
451 DBIC can do some wonderful magic with handling exceptions,
452 disconnections, and transactions when you use C<< AutoCommit => 1 >>
453 combined with C<txn_do> for transaction support.
455 If you set C<< AutoCommit => 0 >> in your connect info, then you are always
456 in an assumed transaction between commits, and you're telling us you'd
457 like to manage that manually. A lot of DBIC's magic protections
458 go away. We can't protect you from exceptions due to database
459 disconnects because we don't know anything about how to restart your
460 transactions. You're on your own for handling all sorts of exceptional
461 cases if you choose the C<< AutoCommit => 0 >> path, just as you would
466 # Simple SQLite connection
467 ->connect_info([ 'dbi:SQLite:./foo.db' ]);
470 ->connect_info([ sub { DBI->connect(...) } ]);
472 # A bit more complicated
479 { quote_char => q{"}, name_sep => q{.} },
483 # Equivalent to the previous example
489 { AutoCommit => 1, quote_char => q{"}, name_sep => q{.} },
493 # Subref + DBIC-specific connection options
496 sub { DBI->connect(...) },
500 on_connect_do => ['SET search_path TO myschema,otherschema,public'],
501 disable_sth_caching => 1,
509 my ($self, $info_arg) = @_;
511 return $self->_connect_info if !$info_arg;
513 # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
514 # the new set of options
515 $self->_sql_maker(undef);
516 $self->_sql_maker_opts({});
517 $self->_connect_info([@$info_arg]); # copy for _connect_info
519 my $dbi_info = [@$info_arg]; # copy for _dbi_connect_info
521 my $last_info = $dbi_info->[-1];
522 if(ref $last_info eq 'HASH') {
523 $last_info = { %$last_info }; # so delete is non-destructive
524 my @storage_option = qw(
525 on_connect_do on_disconnect_do disable_sth_caching unsafe cursor_class
528 for my $storage_opt (@storage_option) {
529 if(my $value = delete $last_info->{$storage_opt}) {
530 $self->$storage_opt($value);
533 for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
534 if(my $opt_val = delete $last_info->{$sql_maker_opt}) {
535 $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
538 # re-insert modified hashref
539 $dbi_info->[-1] = $last_info;
541 # Get rid of any trailing empty hashref
542 pop(@$dbi_info) if !keys %$last_info;
544 $self->_dbi_connect_info($dbi_info);
546 $self->_connect_info;
551 This method is deprecated in favor of setting via L</connect_info>.
555 Arguments: ($subref | $method_name), @extra_coderef_args?
557 Execute the given $subref or $method_name using the new exception-based
558 connection management.
560 The first two arguments will be the storage object that C<dbh_do> was called
561 on and a database handle to use. Any additional arguments will be passed
562 verbatim to the called subref as arguments 2 and onwards.
564 Using this (instead of $self->_dbh or $self->dbh) ensures correct
565 exception handling and reconnection (or failover in future subclasses).
567 Your subref should have no side-effects outside of the database, as
568 there is the potential for your subref to be partially double-executed
569 if the database connection was stale/dysfunctional.
573 my @stuff = $schema->storage->dbh_do(
575 my ($storage, $dbh, @cols) = @_;
576 my $cols = join(q{, }, @cols);
577 $dbh->selectrow_array("SELECT $cols FROM foo");
588 my $dbh = $self->_dbh;
590 return $self->$code($dbh, @_) if $self->{_in_dbh_do}
591 || $self->{transaction_depth};
593 local $self->{_in_dbh_do} = 1;
596 my $want_array = wantarray;
599 $self->_verify_pid if $dbh;
601 $self->_populate_dbh;
606 @result = $self->$code($dbh, @_);
608 elsif(defined $want_array) {
609 $result[0] = $self->$code($dbh, @_);
612 $self->$code($dbh, @_);
617 if(!$exception) { return $want_array ? @result : $result[0] }
619 $self->throw_exception($exception) if $self->connected;
621 # We were not connected - reconnect and retry, but let any
622 # exception fall right through this time
623 $self->_populate_dbh;
624 $self->$code($self->_dbh, @_);
627 # This is basically a blend of dbh_do above and DBIx::Class::Storage::txn_do.
628 # It also informs dbh_do to bypass itself while under the direction of txn_do,
629 # via $self->{_in_dbh_do} (this saves some redundant eval and errorcheck, etc)
634 ref $coderef eq 'CODE' or $self->throw_exception
635 ('$coderef must be a CODE reference');
637 return $coderef->(@_) if $self->{transaction_depth} && ! $self->auto_savepoint;
639 local $self->{_in_dbh_do} = 1;
642 my $want_array = wantarray;
647 $self->_verify_pid if $self->_dbh;
648 $self->_populate_dbh if !$self->_dbh;
652 @result = $coderef->(@_);
654 elsif(defined $want_array) {
655 $result[0] = $coderef->(@_);
664 if(!$exception) { return $want_array ? @result : $result[0] }
666 if($tried++ > 0 || $self->connected) {
667 eval { $self->txn_rollback };
668 my $rollback_exception = $@;
669 if($rollback_exception) {
670 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
671 $self->throw_exception($exception) # propagate nested rollback
672 if $rollback_exception =~ /$exception_class/;
674 $self->throw_exception(
675 "Transaction aborted: ${exception}. "
676 . "Rollback failed: ${rollback_exception}"
679 $self->throw_exception($exception)
682 # We were not connected, and was first try - reconnect and retry
684 $self->_populate_dbh;
690 Our C<disconnect> method also performs a rollback first if the
691 database is not in C<AutoCommit> mode.
698 if( $self->connected ) {
699 my $connection_do = $self->on_disconnect_do;
700 $self->_do_connection_actions($connection_do) if ref($connection_do);
702 $self->_dbh->rollback unless $self->_dbh_autocommit;
703 $self->_dbh->disconnect;
712 if(my $dbh = $self->_dbh) {
713 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
720 return 0 if !$self->_dbh;
722 return ($dbh->FETCH('Active') && $dbh->ping);
728 # handle pid changes correctly
729 # NOTE: assumes $self->_dbh is a valid $dbh
733 return if defined $self->_conn_pid && $self->_conn_pid == $$;
735 $self->_dbh->{InactiveDestroy} = 1;
742 sub ensure_connected {
745 unless ($self->connected) {
746 $self->_populate_dbh;
752 Returns the dbh - a data base handle of class L<DBI>.
759 $self->ensure_connected;
763 sub _sql_maker_args {
766 return ( bindtype=>'columns', limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
771 unless ($self->_sql_maker) {
772 my $sql_maker_class = $self->sql_maker_class;
773 $self->_sql_maker($sql_maker_class->new( $self->_sql_maker_args ));
775 return $self->_sql_maker;
782 my @info = @{$self->_dbi_connect_info || []};
783 $self->_dbh($self->_connect(@info));
785 # Always set the transaction depth on connect, since
786 # there is no transaction in progress by definition
787 $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
789 if(ref $self eq 'DBIx::Class::Storage::DBI') {
790 my $driver = $self->_dbh->{Driver}->{Name};
791 if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
792 bless $self, "DBIx::Class::Storage::DBI::${driver}";
797 my $connection_do = $self->on_connect_do;
798 $self->_do_connection_actions($connection_do) if ref($connection_do);
800 $self->_conn_pid($$);
801 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
804 sub _do_connection_actions {
806 my $connection_do = shift;
808 if (ref $connection_do eq 'ARRAY') {
809 $self->_do_query($_) foreach @$connection_do;
811 elsif (ref $connection_do eq 'CODE') {
819 my ($self, $action) = @_;
821 if (ref $action eq 'CODE') {
822 $action = $action->($self);
823 $self->_do_query($_) foreach @$action;
826 my @to_run = (ref $action eq 'ARRAY') ? (@$action) : ($action);
827 $self->_query_start(@to_run);
828 $self->_dbh->do(@to_run);
829 $self->_query_end(@to_run);
836 my ($self, @info) = @_;
838 $self->throw_exception("You failed to provide any connection info")
841 my ($old_connect_via, $dbh);
843 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
844 $old_connect_via = $DBI::connect_via;
845 $DBI::connect_via = 'connect';
849 if(ref $info[0] eq 'CODE') {
853 $dbh = DBI->connect(@info);
856 if($dbh && !$self->unsafe) {
857 my $weak_self = $self;
859 $dbh->{HandleError} = sub {
860 $weak_self->throw_exception("DBI Exception: $_[0]")
862 $dbh->{ShowErrorStatement} = 1;
863 $dbh->{RaiseError} = 1;
864 $dbh->{PrintError} = 0;
868 $DBI::connect_via = $old_connect_via if $old_connect_via;
870 $self->throw_exception("DBI Connection failed: " . ($@||$DBI::errstr))
873 $self->_dbh_autocommit($dbh->{AutoCommit});
879 my ($self, $name) = @_;
881 $self->throw_exception("You failed to provide a savepoint name!") if !$name;
883 if($self->{transaction_depth} == 0) {
884 warn("Can't use savepoints without a transaction.");
888 if(!$self->can('_svp_begin')) {
889 warn("Your Storage implementation doesn't support savepoints!");
892 $self->debugobj->svp_begin($name) if $self->debug;
893 $self->_svp_begin($name);
897 my ($self, $name) = @_;
899 $self->throw_exception("You failed to provide a savepoint name!") if !$name;
901 if($self->{transaction_depth} == 0) {
902 warn("Can't use savepoints without a transaction.");
906 if(!$self->can('_svp_release')) {
907 warn("Your Storage implementation doesn't support savepoint releasing!");
910 $self->debugobj->svp_release($name) if $self->debug;
911 $self->_svp_release($name);
915 my ($self, $name) = @_;
917 $self->throw_exception("You failed to provide a savepoint name!") if !$name;
919 if($self->{transaction_depth} == 0) {
920 warn("Can't use savepoints without a transaction.");
924 if(!$self->can('_svp_rollback')) {
925 warn("Your Storage implementation doesn't support savepoints!");
928 $self->debugobj->svp_rollback($name) if $self->debug;
929 $self->_svp_rollback($name);
934 $self->ensure_connected();
935 if($self->{transaction_depth} == 0) {
936 $self->debugobj->txn_begin()
938 # this isn't ->_dbh-> because
939 # we should reconnect on begin_work
940 # for AutoCommit users
941 $self->dbh->begin_work;
942 } elsif ($self->auto_savepoint) {
943 $self->svp_begin ("savepoint_$self->{transaction_depth}");
945 $self->{transaction_depth}++;
950 if ($self->{transaction_depth} == 1) {
951 my $dbh = $self->_dbh;
952 $self->debugobj->txn_commit()
955 $self->{transaction_depth} = 0
956 if $self->_dbh_autocommit;
958 elsif($self->{transaction_depth} > 1) {
959 $self->{transaction_depth}--;
960 $self->svp_release ("savepoint_$self->{transaction_depth}")
961 if $self->auto_savepoint;
967 my $dbh = $self->_dbh;
969 if ($self->{transaction_depth} == 1) {
970 $self->debugobj->txn_rollback()
972 $self->{transaction_depth} = 0
973 if $self->_dbh_autocommit;
976 elsif($self->{transaction_depth} > 1) {
977 $self->{transaction_depth}--;
978 if ($self->auto_savepoint) {
979 $self->svp_rollback ("savepoint_$self->{transaction_depth}");
980 $self->svp_release ("savepoint_$self->{transaction_depth}");
984 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
989 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
990 $error =~ /$exception_class/ and $self->throw_exception($error);
991 # ensure that a failed rollback resets the transaction depth
992 $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
993 $self->throw_exception($error);
997 # This used to be the top-half of _execute. It was split out to make it
998 # easier to override in NoBindVars without duping the rest. It takes up
999 # all of _execute's args, and emits $sql, @bind.
1000 sub _prep_for_execute {
1001 my ($self, $op, $extra_bind, $ident, $args) = @_;
1003 my ($sql, @bind) = $self->sql_maker->$op($ident, @$args);
1005 map { ref $_ eq 'ARRAY' ? $_ : [ '!!dummy', $_ ] } @$extra_bind)
1008 return ($sql, \@bind);
1011 sub _fix_bind_params {
1012 my ($self, @bind) = @_;
1014 ### Turn @bind from something like this:
1015 ### ( [ "artist", 1 ], [ "cdid", 1, 3 ] )
1017 ### ( "'1'", "'1'", "'3'" )
1020 if ( defined( $_ && $_->[1] ) ) {
1021 map { qq{'$_'}; } @{$_}[ 1 .. $#$_ ];
1028 my ( $self, $sql, @bind ) = @_;
1030 if ( $self->debug ) {
1031 @bind = $self->_fix_bind_params(@bind);
1032 $self->debugobj->query_start( $sql, @bind );
1037 my ( $self, $sql, @bind ) = @_;
1039 if ( $self->debug ) {
1040 @bind = $self->_fix_bind_params(@bind);
1041 $self->debugobj->query_end( $sql, @bind );
1046 my ($self, $dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
1048 if( blessed($ident) && $ident->isa("DBIx::Class::ResultSource") ) {
1049 $ident = $ident->from();
1052 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
1054 $self->_query_start( $sql, @$bind );
1056 my $sth = $self->sth($sql,$op);
1058 my $placeholder_index = 1;
1060 foreach my $bound (@$bind) {
1061 my $attributes = {};
1062 my($column_name, @data) = @$bound;
1064 if ($bind_attributes) {
1065 $attributes = $bind_attributes->{$column_name}
1066 if defined $bind_attributes->{$column_name};
1069 foreach my $data (@data) {
1070 $data = ref $data ? ''.$data : $data; # stringify args
1072 $sth->bind_param($placeholder_index, $data, $attributes);
1073 $placeholder_index++;
1077 # Can this fail without throwing an exception anyways???
1078 my $rv = $sth->execute();
1079 $self->throw_exception($sth->errstr) if !$rv;
1081 $self->_query_end( $sql, @$bind );
1083 return (wantarray ? ($rv, $sth, @$bind) : $rv);
1088 $self->dbh_do('_dbh_execute', @_)
1092 my ($self, $source, $to_insert) = @_;
1094 my $ident = $source->from;
1095 my $bind_attributes = $self->source_bind_attributes($source);
1097 foreach my $col ( $source->columns ) {
1098 if ( !defined $to_insert->{$col} ) {
1099 my $col_info = $source->column_info($col);
1101 if ( $col_info->{auto_nextval} ) {
1102 $self->ensure_connected;
1103 $to_insert->{$col} = $self->_sequence_fetch( 'nextval', $col_info->{sequence} || $self->_dbh_get_autoinc_seq($self->dbh, $source) );
1108 $self->_execute('insert' => [], $source, $bind_attributes, $to_insert);
1113 ## Still not quite perfect, and EXPERIMENTAL
1114 ## Currently it is assumed that all values passed will be "normal", i.e. not
1115 ## scalar refs, or at least, all the same type as the first set, the statement is
1116 ## only prepped once.
1118 my ($self, $source, $cols, $data) = @_;
1120 my $table = $source->from;
1121 @colvalues{@$cols} = (0..$#$cols);
1122 my ($sql, @bind) = $self->sql_maker->insert($table, \%colvalues);
1124 $self->_query_start( $sql, @bind );
1125 my $sth = $self->sth($sql);
1127 # @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
1129 ## This must be an arrayref, else nothing works!
1131 my $tuple_status = [];
1134 ##print STDERR Dumper( $data, $sql, [@bind] );
1138 ## Get the bind_attributes, if any exist
1139 my $bind_attributes = $self->source_bind_attributes($source);
1141 ## Bind the values and execute
1142 my $placeholder_index = 1;
1144 foreach my $bound (@bind) {
1146 my $attributes = {};
1147 my ($column_name, $data_index) = @$bound;
1149 if( $bind_attributes ) {
1150 $attributes = $bind_attributes->{$column_name}
1151 if defined $bind_attributes->{$column_name};
1154 my @data = map { $_->[$data_index] } @$data;
1156 $sth->bind_param_array( $placeholder_index, [@data], $attributes );
1157 $placeholder_index++;
1159 my $rv = $sth->execute_array({ArrayTupleStatus => $tuple_status});
1160 $self->throw_exception($sth->errstr) if !$rv;
1162 $self->_query_end( $sql, @bind );
1163 return (wantarray ? ($rv, $sth, @bind) : $rv);
1167 my $self = shift @_;
1168 my $source = shift @_;
1169 my $bind_attributes = $self->source_bind_attributes($source);
1171 return $self->_execute('update' => [], $source, $bind_attributes, @_);
1176 my $self = shift @_;
1177 my $source = shift @_;
1179 my $bind_attrs = {}; ## If ever it's needed...
1181 return $self->_execute('delete' => [], $source, $bind_attrs, @_);
1185 my ($self, $ident, $select, $condition, $attrs) = @_;
1186 my $order = $attrs->{order_by};
1188 if (ref $condition eq 'SCALAR') {
1189 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
1192 my $for = delete $attrs->{for};
1193 my $sql_maker = $self->sql_maker;
1194 local $sql_maker->{for} = $for;
1196 if (exists $attrs->{group_by} || $attrs->{having}) {
1198 group_by => $attrs->{group_by},
1199 having => $attrs->{having},
1200 ($order ? (order_by => $order) : ())
1203 my $bind_attrs = {}; ## Future support
1204 my @args = ('select', $attrs->{bind}, $ident, $bind_attrs, $select, $condition, $order);
1205 if ($attrs->{software_limit} ||
1206 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
1207 $attrs->{software_limit} = 1;
1209 $self->throw_exception("rows attribute must be positive if present")
1210 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
1212 # MySQL actually recommends this approach. I cringe.
1213 $attrs->{rows} = 2**48 if not defined $attrs->{rows} and defined $attrs->{offset};
1214 push @args, $attrs->{rows}, $attrs->{offset};
1217 return $self->_execute(@args);
1220 sub source_bind_attributes {
1221 my ($self, $source) = @_;
1223 my $bind_attributes;
1224 foreach my $column ($source->columns) {
1226 my $data_type = $source->column_info($column)->{data_type} || '';
1227 $bind_attributes->{$column} = $self->bind_attribute_by_data_type($data_type)
1231 return $bind_attributes;
1238 =item Arguments: $ident, $select, $condition, $attrs
1242 Handle a SQL select statement.
1248 my ($ident, $select, $condition, $attrs) = @_;
1249 return $self->cursor_class->new($self, \@_, $attrs);
1254 my ($rv, $sth, @bind) = $self->_select(@_);
1255 my @row = $sth->fetchrow_array;
1256 # Need to call finish() to work round broken DBDs
1265 =item Arguments: $sql
1269 Returns a L<DBI> sth (statement handle) for the supplied SQL.
1274 my ($self, $dbh, $sql) = @_;
1276 # 3 is the if_active parameter which avoids active sth re-use
1277 my $sth = $self->disable_sth_caching
1278 ? $dbh->prepare($sql)
1279 : $dbh->prepare_cached($sql, {}, 3);
1281 # XXX You would think RaiseError would make this impossible,
1282 # but apparently that's not true :(
1283 $self->throw_exception($dbh->errstr) if !$sth;
1289 my ($self, $sql) = @_;
1290 $self->dbh_do('_dbh_sth', $sql);
1293 sub _dbh_columns_info_for {
1294 my ($self, $dbh, $table) = @_;
1296 if ($dbh->can('column_info')) {
1299 my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
1300 my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
1302 while ( my $info = $sth->fetchrow_hashref() ){
1304 $column_info{data_type} = $info->{TYPE_NAME};
1305 $column_info{size} = $info->{COLUMN_SIZE};
1306 $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
1307 $column_info{default_value} = $info->{COLUMN_DEF};
1308 my $col_name = $info->{COLUMN_NAME};
1309 $col_name =~ s/^\"(.*)\"$/$1/;
1311 $result{$col_name} = \%column_info;
1314 return \%result if !$@ && scalar keys %result;
1318 my $sth = $dbh->prepare($self->sql_maker->select($table, undef, \'1 = 0'));
1320 my @columns = @{$sth->{NAME_lc}};
1321 for my $i ( 0 .. $#columns ){
1323 $column_info{data_type} = $sth->{TYPE}->[$i];
1324 $column_info{size} = $sth->{PRECISION}->[$i];
1325 $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
1327 if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
1328 $column_info{data_type} = $1;
1329 $column_info{size} = $2;
1332 $result{$columns[$i]} = \%column_info;
1336 foreach my $col (keys %result) {
1337 my $colinfo = $result{$col};
1338 my $type_num = $colinfo->{data_type};
1340 if(defined $type_num && $dbh->can('type_info')) {
1341 my $type_info = $dbh->type_info($type_num);
1342 $type_name = $type_info->{TYPE_NAME} if $type_info;
1343 $colinfo->{data_type} = $type_name if $type_name;
1350 sub columns_info_for {
1351 my ($self, $table) = @_;
1352 $self->dbh_do('_dbh_columns_info_for', $table);
1355 =head2 last_insert_id
1357 Return the row id of the last insert.
1361 sub _dbh_last_insert_id {
1362 my ($self, $dbh, $source, $col) = @_;
1363 # XXX This is a SQLite-ism as a default... is there a DBI-generic way?
1364 $dbh->func('last_insert_rowid');
1367 sub last_insert_id {
1369 $self->dbh_do('_dbh_last_insert_id', @_);
1374 Returns the database driver name.
1378 sub sqlt_type { shift->dbh->{Driver}->{Name} }
1380 =head2 bind_attribute_by_data_type
1382 Given a datatype from column info, returns a database specific bind attribute for
1383 $dbh->bind_param($val,$attribute) or nothing if we will let the database planner
1386 Generally only needed for special case column types, like bytea in postgres.
1390 sub bind_attribute_by_data_type {
1394 =head2 create_ddl_dir
1398 =item Arguments: $schema \@databases, $version, $directory, $preversion, $sqlt_args
1402 Creates a SQL file based on the Schema, for each of the specified
1403 database types, in the given directory.
1409 my ($self, $schema, $databases, $version, $dir, $preversion, $sqltargs) = @_;
1411 if(!$dir || !-d $dir)
1413 warn "No directory given, using ./\n";
1416 $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
1417 $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
1418 $version ||= $schema->VERSION || '1.x';
1419 $sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} };
1421 $self->throw_exception(q{Can't create a ddl file without SQL::Translator 0.09: '}
1422 . $self->_check_sqlt_message . q{'})
1423 if !$self->_check_sqlt_version;
1425 my $sqlt = SQL::Translator->new( $sqltargs );
1427 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
1428 my $sqlt_schema = $sqlt->translate({ data => $schema }) or die $sqlt->error;
1430 foreach my $db (@$databases)
1433 $sqlt = $self->configure_sqlt($sqlt, $db);
1434 $sqlt->{schema} = $sqlt_schema;
1435 $sqlt->producer($db);
1438 my $filename = $schema->ddl_filename($db, $dir, $version);
1441 warn("$filename already exists, skipping $db");
1442 next unless ($preversion);
1444 my $output = $sqlt->translate;
1447 warn("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
1450 if(!open($file, ">$filename"))
1452 $self->throw_exception("Can't open $filename for writing ($!)");
1455 print $file $output;
1460 require SQL::Translator::Diff;
1462 my $prefilename = $schema->ddl_filename($db, $dir, $preversion);
1463 # print "Previous version $prefilename\n";
1464 if(!-e $prefilename)
1466 warn("No previous schema file found ($prefilename)");
1470 my $difffile = $schema->ddl_filename($db, $dir, $version, $preversion);
1471 print STDERR "Diff: $difffile: $db, $dir, $version, $preversion \n";
1474 warn("$difffile already exists, skipping");
1480 my $t = SQL::Translator->new($sqltargs);
1483 $t->parser( $db ) or die $t->error;
1484 $t = $self->configure_sqlt($t, $db);
1485 my $out = $t->translate( $prefilename ) or die $t->error;
1486 $source_schema = $t->schema;
1487 unless ( $source_schema->name ) {
1488 $source_schema->name( $prefilename );
1492 # The "new" style of producers have sane normalization and can support
1493 # diffing a SQL file against a DBIC->SQLT schema. Old style ones don't
1494 # And we have to diff parsed SQL against parsed SQL.
1495 my $dest_schema = $sqlt_schema;
1497 unless ( "SQL::Translator::Producer::$db"->can('preprocess_schema') ) {
1498 my $t = SQL::Translator->new($sqltargs);
1501 $t->parser( $db ) or die $t->error;
1502 $t = $self->configure_sqlt($t, $db);
1503 my $out = $t->translate( $filename ) or die $t->error;
1504 $dest_schema = $t->schema;
1505 $dest_schema->name( $filename )
1506 unless $dest_schema->name;
1509 my $diff = SQL::Translator::Diff::schema_diff($source_schema, $db,
1513 if(!open $file, ">$difffile")
1515 $self->throw_exception("Can't write to $difffile ($!)");
1524 sub configure_sqlt() {
1527 my $db = shift || $self->sqlt_type;
1528 if ($db eq 'PostgreSQL') {
1529 $tr->quote_table_names(0);
1530 $tr->quote_field_names(0);
1535 =head2 deployment_statements
1539 =item Arguments: $schema, $type, $version, $directory, $sqlt_args
1543 Returns the statements used by L</deploy> and L<DBIx::Class::Schema/deploy>.
1544 The database driver name is given by C<$type>, though the value from
1545 L</sqlt_type> is used if it is not specified.
1547 C<$directory> is used to return statements from files in a previously created
1548 L</create_ddl_dir> directory and is optional. The filenames are constructed
1549 from L<DBIx::Class::Schema/ddl_filename>, the schema name and the C<$version>.
1551 If no C<$directory> is specified then the statements are constructed on the
1552 fly using L<SQL::Translator> and C<$version> is ignored.
1554 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>.
1558 sub deployment_statements {
1559 my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
1560 # Need to be connected to get the correct sqlt_type
1561 $self->ensure_connected() unless $type;
1562 $type ||= $self->sqlt_type;
1563 $version ||= $schema->VERSION || '1.x';
1565 my $filename = $schema->ddl_filename($type, $dir, $version);
1569 open($file, "<$filename")
1570 or $self->throw_exception("Can't open $filename ($!)");
1573 return join('', @rows);
1576 $self->throw_exception(q{Can't deploy without SQL::Translator 0.09: '}
1577 . $self->_check_sqlt_message . q{'})
1578 if !$self->_check_sqlt_version;
1580 require SQL::Translator::Parser::DBIx::Class;
1581 eval qq{use SQL::Translator::Producer::${type}};
1582 $self->throw_exception($@) if $@;
1584 # sources needs to be a parser arg, but for simplicty allow at top level
1586 $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources}
1587 if exists $sqltargs->{sources};
1589 my $tr = SQL::Translator->new(%$sqltargs);
1590 SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
1591 return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
1598 my ($self, $schema, $type, $sqltargs, $dir) = @_;
1599 foreach my $statement ( $self->deployment_statements($schema, $type, undef, $dir, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
1600 foreach my $line ( split(";\n", $statement)) {
1601 next if($line =~ /^--/);
1603 # next if($line =~ /^DROP/m);
1604 next if($line =~ /^BEGIN TRANSACTION/m);
1605 next if($line =~ /^COMMIT/m);
1606 next if $line =~ /^\s+$/; # skip whitespace only
1607 $self->_query_start($line);
1609 $self->dbh->do($line); # shouldn't be using ->dbh ?
1612 warn qq{$@ (running "${line}")};
1614 $self->_query_end($line);
1619 =head2 datetime_parser
1621 Returns the datetime parser class
1625 sub datetime_parser {
1627 return $self->{datetime_parser} ||= do {
1628 $self->ensure_connected;
1629 $self->build_datetime_parser(@_);
1633 =head2 datetime_parser_type
1635 Defines (returns) the datetime parser class - currently hardwired to
1636 L<DateTime::Format::MySQL>
1640 sub datetime_parser_type { "DateTime::Format::MySQL"; }
1642 =head2 build_datetime_parser
1644 See L</datetime_parser>
1648 sub build_datetime_parser {
1650 my $type = $self->datetime_parser_type(@_);
1652 $self->throw_exception("Couldn't load ${type}: $@") if $@;
1657 my $_check_sqlt_version; # private
1658 my $_check_sqlt_message; # private
1659 sub _check_sqlt_version {
1660 return $_check_sqlt_version if defined $_check_sqlt_version;
1661 eval 'use SQL::Translator "0.09"';
1662 $_check_sqlt_message = $@ || '';
1663 $_check_sqlt_version = !$@;
1666 sub _check_sqlt_message {
1667 _check_sqlt_version if !defined $_check_sqlt_message;
1668 $_check_sqlt_message;
1674 return if !$self->_dbh;
1683 The module defines a set of methods within the DBIC::SQL::Abstract
1684 namespace. These build on L<SQL::Abstract::Limit> to provide the
1685 SQL query functions.
1687 The following methods are extended:-
1701 See L</connect_info> for details.
1702 For setting, this method is deprecated in favor of L</connect_info>.
1706 See L</connect_info> for details.
1707 For setting, this method is deprecated in favor of L</connect_info>.
1711 See L</connect_info> for details.
1712 For setting, this method is deprecated in favor of L</connect_info>.
1718 Matt S. Trout <mst@shadowcatsystems.co.uk>
1720 Andy Grundman <andy@hybridized.org>
1724 You may distribute this code under the same terms as Perl itself.