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 cursor on_connect_do
17 on_disconnect_do transaction_depth unsafe _dbh_autocommit/
22 package DBIC::SQL::Abstract; # Would merge upstream, but nate doesn't reply :(
24 use base qw/SQL::Abstract::Limit/;
26 # This prevents the caching of $dbh in S::A::L, I believe
28 my $self = shift->SUPER::new(@_);
30 # If limit_dialect is a ref (like a $dbh), go ahead and replace
31 # it with what it resolves to:
32 $self->{limit_dialect} = $self->_find_syntax($self->{limit_dialect})
33 if ref $self->{limit_dialect};
39 my ($self, $sql, $order, $rows, $offset ) = @_;
42 my $last = $rows + $offset;
43 my ( $order_by ) = $self->_order_by( $order );
48 SELECT Q1.*, ROW_NUMBER() OVER( ) AS ROW_NUM FROM (
53 WHERE ROW_NUM BETWEEN $offset AND $last
59 # While we're at it, this should make LIMIT queries more efficient,
60 # without digging into things too deeply
61 use Scalar::Util 'blessed';
63 my ($self, $syntax) = @_;
64 my $dbhname = blessed($syntax) ? $syntax->{Driver}{Name} : $syntax;
65 if(ref($self) && $dbhname && $dbhname eq 'DB2') {
66 return 'RowNumberOver';
69 $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
73 my ($self, $table, $fields, $where, $order, @rest) = @_;
74 $table = $self->_quote($table) unless ref($table);
75 local $self->{rownum_hack_count} = 1
76 if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
77 @rest = (-1) unless defined $rest[0];
78 die "LIMIT 0 Does Not Compute" if $rest[0] == 0;
79 # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
80 local $self->{having_bind} = [];
81 my ($sql, @ret) = $self->SUPER::select(
82 $table, $self->_recurse_fields($fields), $where, $order, @rest
84 return wantarray ? ($sql, @ret, @{$self->{having_bind}}) : $sql;
90 $table = $self->_quote($table) unless ref($table);
91 $self->SUPER::insert($table, @_);
97 $table = $self->_quote($table) unless ref($table);
98 $self->SUPER::update($table, @_);
104 $table = $self->_quote($table) unless ref($table);
105 $self->SUPER::delete($table, @_);
111 return $_[1].$self->_order_by($_[2]);
113 return $self->SUPER::_emulate_limit(@_);
117 sub _recurse_fields {
118 my ($self, $fields, $params) = @_;
119 my $ref = ref $fields;
120 return $self->_quote($fields) unless $ref;
121 return $$fields if $ref eq 'SCALAR';
123 if ($ref eq 'ARRAY') {
124 return join(', ', map {
125 $self->_recurse_fields($_)
126 .(exists $self->{rownum_hack_count} && !($params && $params->{no_rownum_hack})
127 ? ' AS col'.$self->{rownum_hack_count}++
130 } elsif ($ref eq 'HASH') {
131 foreach my $func (keys %$fields) {
132 return $self->_sqlcase($func)
133 .'( '.$self->_recurse_fields($fields->{$func}).' )';
142 if (ref $_[0] eq 'HASH') {
143 if (defined $_[0]->{group_by}) {
144 $ret = $self->_sqlcase(' group by ')
145 .$self->_recurse_fields($_[0]->{group_by}, { no_rownum_hack => 1 });
147 if (defined $_[0]->{having}) {
149 ($frag, @extra) = $self->_recurse_where($_[0]->{having});
150 push(@{$self->{having_bind}}, @extra);
151 $ret .= $self->_sqlcase(' having ').$frag;
153 if (defined $_[0]->{order_by}) {
154 $ret .= $self->_order_by($_[0]->{order_by});
156 } elsif (ref $_[0] eq 'SCALAR') {
157 $ret = $self->_sqlcase(' order by ').${ $_[0] };
158 } elsif (ref $_[0] eq 'ARRAY' && @{$_[0]}) {
159 my @order = @{+shift};
160 $ret = $self->_sqlcase(' order by ')
162 my $r = $self->_order_by($_, @_);
163 $r =~ s/^ ?ORDER BY //i;
167 $ret = $self->SUPER::_order_by(@_);
172 sub _order_directions {
173 my ($self, $order) = @_;
174 $order = $order->{order_by} if ref $order eq 'HASH';
175 return $self->SUPER::_order_directions($order);
179 my ($self, $from) = @_;
180 if (ref $from eq 'ARRAY') {
181 return $self->_recurse_from(@$from);
182 } elsif (ref $from eq 'HASH') {
183 return $self->_make_as($from);
185 return $from; # would love to quote here but _table ends up getting called
186 # twice during an ->select without a limit clause due to
187 # the way S::A::Limit->select works. should maybe consider
188 # bypassing this and doing S::A::select($self, ...) in
189 # our select method above. meantime, quoting shims have
190 # been added to select/insert/update/delete here
195 my ($self, $from, @join) = @_;
197 push(@sqlf, $self->_make_as($from));
198 foreach my $j (@join) {
201 # check whether a join type exists
202 my $join_clause = '';
203 my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
204 if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
205 $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
207 $join_clause = ' JOIN ';
209 push(@sqlf, $join_clause);
211 if (ref $to eq 'ARRAY') {
212 push(@sqlf, '(', $self->_recurse_from(@$to), ')');
214 push(@sqlf, $self->_make_as($to));
216 push(@sqlf, ' ON ', $self->_join_condition($on));
218 return join('', @sqlf);
222 my ($self, $from) = @_;
223 return join(' ', map { (ref $_ eq 'SCALAR' ? $$_ : $self->_quote($_)) }
224 reverse each %{$self->_skip_options($from)});
228 my ($self, $hash) = @_;
230 $clean_hash->{$_} = $hash->{$_}
231 for grep {!/^-/} keys %$hash;
235 sub _join_condition {
236 my ($self, $cond) = @_;
237 if (ref $cond eq 'HASH') {
242 # XXX no throw_exception() in this package and croak() fails with strange results
243 Carp::croak(ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
244 if ref($v) ne 'SCALAR';
248 my $x = '= '.$self->_quote($v); $j{$_} = \$x;
251 return scalar($self->_recurse_where(\%j));
252 } elsif (ref $cond eq 'ARRAY') {
253 return join(' OR ', map { $self->_join_condition($_) } @$cond);
255 die "Can't handle this yet!";
260 my ($self, $label) = @_;
261 return '' unless defined $label;
262 return "*" if $label eq '*';
263 return $label unless $self->{quote_char};
264 if(ref $self->{quote_char} eq "ARRAY"){
265 return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
266 if !defined $self->{name_sep};
267 my $sep = $self->{name_sep};
268 return join($self->{name_sep},
269 map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
270 split(/\Q$sep\E/,$label));
272 return $self->SUPER::_quote($label);
277 $self->{limit_dialect} = shift if @_;
278 return $self->{limit_dialect};
283 $self->{quote_char} = shift if @_;
284 return $self->{quote_char};
289 $self->{name_sep} = shift if @_;
290 return $self->{name_sep};
293 } # End of BEGIN block
297 DBIx::Class::Storage::DBI - DBI storage handler
303 This class represents the connection to an RDBMS via L<DBI>. See
304 L<DBIx::Class::Storage> for general information. This pod only
305 documents DBI-specific methods and behaviors.
312 my $new = shift->next::method(@_);
314 $new->cursor("DBIx::Class::Storage::DBI::Cursor");
315 $new->transaction_depth(0);
316 $new->_sql_maker_opts({});
317 $new->{_in_dbh_do} = 0;
318 $new->{_dbh_gen} = 0;
325 The arguments of C<connect_info> are always a single array reference.
327 This is normally accessed via L<DBIx::Class::Schema/connection>, which
328 encapsulates its argument list in an arrayref before calling
329 C<connect_info> here.
331 The arrayref can either contain the same set of arguments one would
332 normally pass to L<DBI/connect>, or a lone code reference which returns
333 a connected database handle. Please note that the L<DBI> docs
334 recommend that you always explicitly set C<AutoCommit> to either
335 C<0> or C<1>. L<DBIx::Class> further recommends that it be set
336 to C<1>, and that you perform transactions via our L</txn_do>
337 method. L<DBIx::Class> will set it to C<1> if you do not do explicitly
338 set it to zero. This is the default for most DBDs. See below for more
341 In either case, if the final argument in your connect_info happens
342 to be a hashref, C<connect_info> will look there for several
343 connection-specific options:
349 Specifies things to do immediately after connecting or re-connecting to
350 the database. Its value may contain:
354 =item an array reference
356 This contains SQL statements to execute in order. Each element contains
357 a string or a code reference that returns a string.
359 =item a code reference
361 This contains some code to execute. Unlike code references within an
362 array reference, its return value is ignored.
366 =item on_disconnect_do
368 Takes arguments in the same for as L<on_connect_do> and executes them
369 immediately before disconnecting from the database.
371 Note, this only runs if you explicitly call L<disconnect> on the
374 =item disable_sth_caching
376 If set to a true value, this option will disable the caching of
377 statement handles via L<DBI/prepare_cached>.
381 Sets the limit dialect. This is useful for JDBC-bridge among others
382 where the remote SQL-dialect cannot be determined by the name of the
387 Specifies what characters to use to quote table and column names. If
388 you use this you will want to specify L<name_sep> as well.
390 quote_char expects either a single character, in which case is it is placed
391 on either side of the table/column, or an arrayref of length 2 in which case the
392 table/column name is placed between the elements.
394 For example under MySQL you'd use C<quote_char =E<gt> '`'>, and user SQL Server you'd
395 use C<quote_char =E<gt> [qw/[ ]/]>.
399 This only needs to be used in conjunction with L<quote_char>, and is used to
400 specify the charecter that seperates elements (schemas, tables, columns) from
401 each other. In most cases this is simply a C<.>.
405 This Storage driver normally installs its own C<HandleError>, sets
406 C<RaiseError> and C<ShowErrorStatement> on, and sets C<PrintError> off on
407 all database handles, including those supplied by a coderef. It does this
408 so that it can have consistent and useful error behavior.
410 If you set this option to a true value, Storage will not do its usual
411 modifications to the database handle's attributes, and instead relies on
412 the settings in your connect_info DBI options (or the values you set in
413 your connection coderef, in the case that you are connecting via coderef).
415 Note that your custom settings can cause Storage to malfunction,
416 especially if you set a C<HandleError> handler that suppresses exceptions
417 and/or disable C<RaiseError>.
421 These options can be mixed in with your other L<DBI> connection attributes,
422 or placed in a seperate hashref after all other normal L<DBI> connection
425 Every time C<connect_info> is invoked, any previous settings for
426 these options will be cleared before setting the new ones, regardless of
427 whether any options are specified in the new C<connect_info>.
429 Another Important Note:
431 DBIC can do some wonderful magic with handling exceptions,
432 disconnections, and transactions when you use C<AutoCommit => 1>
433 combined with C<txn_do> for transaction support.
435 If you set C<AutoCommit => 0> in your connect info, then you are always
436 in an assumed transaction between commits, and you're telling us you'd
437 like to manage that manually. A lot of DBIC's magic protections
438 go away. We can't protect you from exceptions due to database
439 disconnects because we don't know anything about how to restart your
440 transactions. You're on your own for handling all sorts of exceptional
441 cases if you choose the C<AutoCommit => 0> path, just as you would
446 # Simple SQLite connection
447 ->connect_info([ 'dbi:SQLite:./foo.db' ]);
450 ->connect_info([ sub { DBI->connect(...) } ]);
452 # A bit more complicated
459 { quote_char => q{"}, name_sep => q{.} },
463 # Equivalent to the previous example
469 { AutoCommit => 1, quote_char => q{"}, name_sep => q{.} },
473 # Subref + DBIC-specific connection options
476 sub { DBI->connect(...) },
480 on_connect_do => ['SET search_path TO myschema,otherschema,public'],
481 disable_sth_caching => 1,
489 my ($self, $info_arg) = @_;
491 return $self->_connect_info if !$info_arg;
493 # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
494 # the new set of options
495 $self->_sql_maker(undef);
496 $self->_sql_maker_opts({});
497 $self->_connect_info([@$info_arg]); # copy for _connect_info
499 my $dbi_info = [@$info_arg]; # copy for _dbi_connect_info
501 my $last_info = $dbi_info->[-1];
502 if(ref $last_info eq 'HASH') {
503 $last_info = { %$last_info }; # so delete is non-destructive
505 qw/on_connect_do on_disconnect_do disable_sth_caching unsafe/;
506 for my $storage_opt (@storage_option) {
507 if(my $value = delete $last_info->{$storage_opt}) {
508 $self->$storage_opt($value);
511 for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
512 if(my $opt_val = delete $last_info->{$sql_maker_opt}) {
513 $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
516 # re-insert modified hashref
517 $dbi_info->[-1] = $last_info;
519 # Get rid of any trailing empty hashref
520 pop(@$dbi_info) if !keys %$last_info;
522 $self->_dbi_connect_info($dbi_info);
524 $self->_connect_info;
529 This method is deprecated in favor of setting via L</connect_info>.
533 Arguments: $subref, @extra_coderef_args?
535 Execute the given subref using the new exception-based connection management.
537 The first two arguments will be the storage object that C<dbh_do> was called
538 on and a database handle to use. Any additional arguments will be passed
539 verbatim to the called subref as arguments 2 and onwards.
541 Using this (instead of $self->_dbh or $self->dbh) ensures correct
542 exception handling and reconnection (or failover in future subclasses).
544 Your subref should have no side-effects outside of the database, as
545 there is the potential for your subref to be partially double-executed
546 if the database connection was stale/dysfunctional.
550 my @stuff = $schema->storage->dbh_do(
552 my ($storage, $dbh, @cols) = @_;
553 my $cols = join(q{, }, @cols);
554 $dbh->selectrow_array("SELECT $cols FROM foo");
565 ref $coderef eq 'CODE' or $self->throw_exception
566 ('$coderef must be a CODE reference');
568 return $coderef->($self, $self->_dbh, @_) if $self->{_in_dbh_do}
569 || $self->{transaction_depth};
571 local $self->{_in_dbh_do} = 1;
574 my $want_array = wantarray;
577 $self->_verify_pid if $self->_dbh;
578 $self->_populate_dbh if !$self->_dbh;
580 @result = $coderef->($self, $self->_dbh, @_);
582 elsif(defined $want_array) {
583 $result[0] = $coderef->($self, $self->_dbh, @_);
586 $coderef->($self, $self->_dbh, @_);
591 if(!$exception) { return $want_array ? @result : $result[0] }
593 $self->throw_exception($exception) if $self->connected;
595 # We were not connected - reconnect and retry, but let any
596 # exception fall right through this time
597 $self->_populate_dbh;
598 $coderef->($self, $self->_dbh, @_);
601 # This is basically a blend of dbh_do above and DBIx::Class::Storage::txn_do.
602 # It also informs dbh_do to bypass itself while under the direction of txn_do,
603 # via $self->{_in_dbh_do} (this saves some redundant eval and errorcheck, etc)
608 ref $coderef eq 'CODE' or $self->throw_exception
609 ('$coderef must be a CODE reference');
611 return $coderef->(@_) if $self->{transaction_depth};
613 local $self->{_in_dbh_do} = 1;
616 my $want_array = wantarray;
621 $self->_verify_pid if $self->_dbh;
622 $self->_populate_dbh if !$self->_dbh;
626 @result = $coderef->(@_);
628 elsif(defined $want_array) {
629 $result[0] = $coderef->(@_);
638 if(!$exception) { return $want_array ? @result : $result[0] }
640 if($tried++ > 0 || $self->connected) {
641 eval { $self->txn_rollback };
642 my $rollback_exception = $@;
643 if($rollback_exception) {
644 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
645 $self->throw_exception($exception) # propagate nested rollback
646 if $rollback_exception =~ /$exception_class/;
648 $self->throw_exception(
649 "Transaction aborted: ${exception}. "
650 . "Rollback failed: ${rollback_exception}"
653 $self->throw_exception($exception)
656 # We were not connected, and was first try - reconnect and retry
658 $self->_populate_dbh;
664 Our C<disconnect> method also performs a rollback first if the
665 database is not in C<AutoCommit> mode.
672 if( $self->connected ) {
673 my $connection_do = $self->on_disconnect_do;
674 $self->_do_connection_actions($connection_do) if ref($connection_do);
676 $self->_dbh->rollback unless $self->_dbh_autocommit;
677 $self->_dbh->disconnect;
686 if(my $dbh = $self->_dbh) {
687 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
695 return ($dbh->FETCH('Active') && $dbh->ping);
701 # handle pid changes correctly
702 # NOTE: assumes $self->_dbh is a valid $dbh
706 return if $self->_conn_pid == $$;
708 $self->_dbh->{InactiveDestroy} = 1;
715 sub ensure_connected {
718 unless ($self->connected) {
719 $self->_populate_dbh;
725 Returns the dbh - a data base handle of class L<DBI>.
732 $self->ensure_connected;
736 sub _sql_maker_args {
739 return ( bindtype=>'columns', limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
744 unless ($self->_sql_maker) {
745 $self->_sql_maker(new DBIC::SQL::Abstract( $self->_sql_maker_args ));
747 return $self->_sql_maker;
752 my @info = @{$self->_dbi_connect_info || []};
753 $self->_dbh($self->_connect(@info));
755 # Always set the transaction depth on connect, since
756 # there is no transaction in progress by definition
757 $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
759 if(ref $self eq 'DBIx::Class::Storage::DBI') {
760 my $driver = $self->_dbh->{Driver}->{Name};
761 if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
762 bless $self, "DBIx::Class::Storage::DBI::${driver}";
763 $self->_rebless() if $self->can('_rebless');
767 my $connection_do = $self->on_connect_do;
768 $self->_do_connection_actions($connection_do) if ref($connection_do);
770 $self->_conn_pid($$);
771 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
774 sub _do_connection_actions {
776 my $connection_do = shift;
778 if (ref $connection_do eq 'ARRAY') {
779 $self->_do_query($_) foreach @$connection_do;
781 elsif (ref $connection_do eq 'CODE') {
789 my ($self, $action) = @_;
791 if (ref $action eq 'CODE') {
795 $self->debugobj->query_start($action) if $self->debug();
796 $self->_dbh->do($action);
797 $self->debugobj->query_end($action) if $self->debug();
804 my ($self, @info) = @_;
806 $self->throw_exception("You failed to provide any connection info")
809 my ($old_connect_via, $dbh);
811 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
812 $old_connect_via = $DBI::connect_via;
813 $DBI::connect_via = 'connect';
817 if(ref $info[0] eq 'CODE') {
821 $dbh = DBI->connect(@info);
825 my $weak_self = $self;
827 $dbh->{HandleError} = sub {
828 $weak_self->throw_exception("DBI Exception: $_[0]")
830 $dbh->{ShowErrorStatement} = 1;
831 $dbh->{RaiseError} = 1;
832 $dbh->{PrintError} = 0;
836 $DBI::connect_via = $old_connect_via if $old_connect_via;
838 $self->throw_exception("DBI Connection failed: " . ($@||$DBI::errstr))
841 $self->_dbh_autocommit($dbh->{AutoCommit});
849 $self->ensure_connected();
850 if($self->{transaction_depth} == 0) {
851 $self->debugobj->txn_begin()
853 # this isn't ->_dbh-> because
854 # we should reconnect on begin_work
855 # for AutoCommit users
856 $self->dbh->begin_work;
858 $self->{transaction_depth}++;
863 if ($self->{transaction_depth} == 1) {
864 my $dbh = $self->_dbh;
865 $self->debugobj->txn_commit()
868 $self->{transaction_depth} = 0
869 if $self->_dbh_autocommit;
871 elsif($self->{transaction_depth} > 1) {
872 $self->{transaction_depth}--
878 my $dbh = $self->_dbh;
880 if ($self->{transaction_depth} == 1) {
881 $self->debugobj->txn_rollback()
883 $self->{transaction_depth} = 0
884 if $self->_dbh_autocommit;
887 elsif($self->{transaction_depth} > 1) {
888 $self->{transaction_depth}--;
891 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
896 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
897 $error =~ /$exception_class/ and $self->throw_exception($error);
898 # ensure that a failed rollback resets the transaction depth
899 $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
900 $self->throw_exception($error);
904 # This used to be the top-half of _execute. It was split out to make it
905 # easier to override in NoBindVars without duping the rest. It takes up
906 # all of _execute's args, and emits $sql, @bind.
907 sub _prep_for_execute {
908 my ($self, $op, $extra_bind, $ident, $args) = @_;
910 my ($sql, @bind) = $self->sql_maker->$op($ident, @$args);
912 map { ref $_ eq 'ARRAY' ? $_ : [ '!!dummy', $_ ] } @$extra_bind)
915 return ($sql, \@bind);
919 my ($self, $dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
921 if( blessed($ident) && $ident->isa("DBIx::Class::ResultSource") ) {
922 $ident = $ident->from();
925 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
929 map { defined ($_ && $_->[1]) ? qq{'$_->[1]'} : q{'NULL'} } @$bind;
930 $self->debugobj->query_start($sql, @debug_bind);
933 my $sth = $self->sth($sql,$op);
935 my $placeholder_index = 1;
937 foreach my $bound (@$bind) {
939 my($column_name, @data) = @$bound;
941 if ($bind_attributes) {
942 $attributes = $bind_attributes->{$column_name}
943 if defined $bind_attributes->{$column_name};
946 foreach my $data (@data) {
947 $data = ref $data ? ''.$data : $data; # stringify args
949 $sth->bind_param($placeholder_index, $data, $attributes);
950 $placeholder_index++;
954 # Can this fail without throwing an exception anyways???
955 my $rv = $sth->execute();
956 $self->throw_exception($sth->errstr) if !$rv;
960 map { defined ($_ && $_->[1]) ? qq{'$_->[1]'} : q{'NULL'} } @$bind;
961 $self->debugobj->query_end($sql, @debug_bind);
964 return (wantarray ? ($rv, $sth, @$bind) : $rv);
969 $self->dbh_do($self->can('_dbh_execute'), @_)
973 my ($self, $source, $to_insert) = @_;
975 my $ident = $source->from;
976 my $bind_attributes = $self->source_bind_attributes($source);
978 $self->_execute('insert' => [], $source, $bind_attributes, $to_insert);
983 ## Still not quite perfect, and EXPERIMENTAL
984 ## Currently it is assumed that all values passed will be "normal", i.e. not
985 ## scalar refs, or at least, all the same type as the first set, the statement is
986 ## only prepped once.
988 my ($self, $source, $cols, $data) = @_;
990 my $table = $source->from;
991 @colvalues{@$cols} = (0..$#$cols);
992 my ($sql, @bind) = $self->sql_maker->insert($table, \%colvalues);
995 my @debug_bind = map { defined $_->[1] ? qq{$_->[1]} : q{'NULL'} } @bind;
996 $self->debugobj->query_start($sql, @debug_bind);
998 my $sth = $self->sth($sql);
1000 # @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
1002 ## This must be an arrayref, else nothing works!
1004 my $tuple_status = [];
1007 ##print STDERR Dumper( $data, $sql, [@bind] );
1011 ## Get the bind_attributes, if any exist
1012 my $bind_attributes = $self->source_bind_attributes($source);
1014 ## Bind the values and execute
1015 my $placeholder_index = 1;
1017 foreach my $bound (@bind) {
1019 my $attributes = {};
1020 my ($column_name, $data_index) = @$bound;
1022 if( $bind_attributes ) {
1023 $attributes = $bind_attributes->{$column_name}
1024 if defined $bind_attributes->{$column_name};
1027 my @data = map { $_->[$data_index] } @$data;
1029 $sth->bind_param_array( $placeholder_index, [@data], $attributes );
1030 $placeholder_index++;
1032 my $rv = $sth->execute_array({ArrayTupleStatus => $tuple_status});
1033 $self->throw_exception($sth->errstr) if !$rv;
1036 my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind;
1037 $self->debugobj->query_end($sql, @debug_bind);
1039 return (wantarray ? ($rv, $sth, @bind) : $rv);
1043 my $self = shift @_;
1044 my $source = shift @_;
1045 my $bind_attributes = $self->source_bind_attributes($source);
1047 return $self->_execute('update' => [], $source, $bind_attributes, @_);
1052 my $self = shift @_;
1053 my $source = shift @_;
1055 my $bind_attrs = {}; ## If ever it's needed...
1057 return $self->_execute('delete' => [], $source, $bind_attrs, @_);
1061 my ($self, $ident, $select, $condition, $attrs) = @_;
1062 my $order = $attrs->{order_by};
1063 if (ref $condition eq 'SCALAR') {
1064 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
1066 if (exists $attrs->{group_by} || $attrs->{having}) {
1068 group_by => $attrs->{group_by},
1069 having => $attrs->{having},
1070 ($order ? (order_by => $order) : ())
1073 my $bind_attrs = {}; ## Future support
1074 my @args = ('select', $attrs->{bind}, $ident, $bind_attrs, $select, $condition, $order);
1075 if ($attrs->{software_limit} ||
1076 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
1077 $attrs->{software_limit} = 1;
1079 $self->throw_exception("rows attribute must be positive if present")
1080 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
1081 push @args, $attrs->{rows}, $attrs->{offset};
1083 return $self->_execute(@args);
1086 sub source_bind_attributes {
1087 my ($self, $source) = @_;
1089 my $bind_attributes;
1090 foreach my $column ($source->columns) {
1092 my $data_type = $source->column_info($column)->{data_type} || '';
1093 $bind_attributes->{$column} = $self->bind_attribute_by_data_type($data_type)
1097 return $bind_attributes;
1104 =item Arguments: $ident, $select, $condition, $attrs
1108 Handle a SQL select statement.
1114 my ($ident, $select, $condition, $attrs) = @_;
1115 return $self->cursor->new($self, \@_, $attrs);
1120 my ($rv, $sth, @bind) = $self->_select(@_);
1121 my @row = $sth->fetchrow_array;
1122 # Need to call finish() to work round broken DBDs
1131 =item Arguments: $sql
1135 Returns a L<DBI> sth (statement handle) for the supplied SQL.
1140 my ($self, $dbh, $sql) = @_;
1142 # 3 is the if_active parameter which avoids active sth re-use
1143 my $sth = $self->disable_sth_caching
1144 ? $dbh->prepare($sql)
1145 : $dbh->prepare_cached($sql, {}, 3);
1147 # XXX You would think RaiseError would make this impossible,
1148 # but apparently that's not true :(
1149 $self->throw_exception($dbh->errstr) if !$sth;
1155 my ($self, $sql) = @_;
1156 $self->dbh_do($self->can('_dbh_sth'), $sql);
1159 sub _dbh_columns_info_for {
1160 my ($self, $dbh, $table) = @_;
1162 if ($dbh->can('column_info')) {
1165 my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
1166 my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
1168 while ( my $info = $sth->fetchrow_hashref() ){
1170 $column_info{data_type} = $info->{TYPE_NAME};
1171 $column_info{size} = $info->{COLUMN_SIZE};
1172 $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
1173 $column_info{default_value} = $info->{COLUMN_DEF};
1174 my $col_name = $info->{COLUMN_NAME};
1175 $col_name =~ s/^\"(.*)\"$/$1/;
1177 $result{$col_name} = \%column_info;
1180 return \%result if !$@ && scalar keys %result;
1184 my $sth = $dbh->prepare($self->sql_maker->select($table, undef, \'1 = 0'));
1186 my @columns = @{$sth->{NAME_lc}};
1187 for my $i ( 0 .. $#columns ){
1189 $column_info{data_type} = $sth->{TYPE}->[$i];
1190 $column_info{size} = $sth->{PRECISION}->[$i];
1191 $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
1193 if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
1194 $column_info{data_type} = $1;
1195 $column_info{size} = $2;
1198 $result{$columns[$i]} = \%column_info;
1202 foreach my $col (keys %result) {
1203 my $colinfo = $result{$col};
1204 my $type_num = $colinfo->{data_type};
1206 if(defined $type_num && $dbh->can('type_info')) {
1207 my $type_info = $dbh->type_info($type_num);
1208 $type_name = $type_info->{TYPE_NAME} if $type_info;
1209 $colinfo->{data_type} = $type_name if $type_name;
1216 sub columns_info_for {
1217 my ($self, $table) = @_;
1218 $self->dbh_do($self->can('_dbh_columns_info_for'), $table);
1221 =head2 last_insert_id
1223 Return the row id of the last insert.
1227 sub _dbh_last_insert_id {
1228 my ($self, $dbh, $source, $col) = @_;
1229 # XXX This is a SQLite-ism as a default... is there a DBI-generic way?
1230 $dbh->func('last_insert_rowid');
1233 sub last_insert_id {
1235 $self->dbh_do($self->can('_dbh_last_insert_id'), @_);
1240 Returns the database driver name.
1244 sub sqlt_type { shift->dbh->{Driver}->{Name} }
1246 =head2 bind_attribute_by_data_type
1248 Given a datatype from column info, returns a database specific bind attribute for
1249 $dbh->bind_param($val,$attribute) or nothing if we will let the database planner
1252 Generally only needed for special case column types, like bytea in postgres.
1256 sub bind_attribute_by_data_type {
1260 =head2 create_ddl_dir
1264 =item Arguments: $schema \@databases, $version, $directory, $preversion, $sqlt_args
1268 Creates a SQL file based on the Schema, for each of the specified
1269 database types, in the given directory.
1275 my ($self, $schema, $databases, $version, $dir, $preversion, $sqltargs) = @_;
1277 if(!$dir || !-d $dir)
1279 warn "No directory given, using ./\n";
1282 $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
1283 $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
1284 $version ||= $schema->VERSION || '1.x';
1285 $sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} };
1287 $self->throw_exception(q{Can't create a ddl file without SQL::Translator 0.08: '}
1288 . $self->_check_sqlt_message . q{'})
1289 if !$self->_check_sqlt_version;
1291 my $sqlt = SQL::Translator->new({
1293 add_drop_table => 1,
1295 foreach my $db (@$databases)
1298 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
1299 # $sqlt->parser_args({'DBIx::Class' => $schema);
1300 $sqlt = $self->configure_sqlt($sqlt, $db);
1301 $sqlt->data($schema);
1302 $sqlt->producer($db);
1305 my $filename = $schema->ddl_filename($db, $dir, $version);
1308 warn("$filename already exists, skipping $db");
1312 my $output = $sqlt->translate;
1315 warn("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
1318 if(!open($file, ">$filename"))
1320 $self->throw_exception("Can't open $filename for writing ($!)");
1323 print $file $output;
1328 require SQL::Translator::Diff;
1330 my $prefilename = $schema->ddl_filename($db, $dir, $preversion);
1331 # print "Previous version $prefilename\n";
1332 if(!-e $prefilename)
1334 warn("No previous schema file found ($prefilename)");
1337 #### We need to reparse the SQLite file we just wrote, so that
1338 ## Diff doesnt get all confoosed, and Diff is *very* confused.
1339 ## FIXME: rip Diff to pieces!
1340 # my $target_schema = $sqlt->schema;
1341 # unless ( $target_schema->name ) {
1342 # $target_schema->name( $filename );
1345 push @input, {file => $prefilename, parser => $db};
1346 push @input, {file => $filename, parser => $db};
1347 my ( $source_schema, $source_db, $target_schema, $target_db ) = map {
1348 my $file = $_->{'file'};
1349 my $parser = $_->{'parser'};
1351 my $t = SQL::Translator->new;
1354 $t->parser( $parser ) or die $t->error;
1355 my $out = $t->translate( $file ) or die $t->error;
1356 my $schema = $t->schema;
1357 unless ( $schema->name ) {
1358 $schema->name( $file );
1363 my $diff = SQL::Translator::Diff::schema_diff($source_schema, $db,
1364 $target_schema, $db,
1367 my $difffile = $schema->ddl_filename($db, $dir, $version, $preversion);
1368 print STDERR "Diff: $difffile: $db, $dir, $version, $preversion \n";
1371 warn("$difffile already exists, skipping");
1374 if(!open $file, ">$difffile")
1376 $self->throw_exception("Can't write to $difffile ($!)");
1385 sub configure_sqlt() {
1388 my $db = shift || $self->sqlt_type;
1389 if ($db eq 'PostgreSQL') {
1390 $tr->quote_table_names(0);
1391 $tr->quote_field_names(0);
1396 =head2 deployment_statements
1400 =item Arguments: $schema, $type, $version, $directory, $sqlt_args
1404 Returns the statements used by L</deploy> and L<DBIx::Class::Schema/deploy>.
1405 The database driver name is given by C<$type>, though the value from
1406 L</sqlt_type> is used if it is not specified.
1408 C<$directory> is used to return statements from files in a previously created
1409 L</create_ddl_dir> directory and is optional. The filenames are constructed
1410 from L<DBIx::Class::Schema/ddl_filename>, the schema name and the C<$version>.
1412 If no C<$directory> is specified then the statements are constructed on the
1413 fly using L<SQL::Translator> and C<$version> is ignored.
1415 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>.
1419 sub deployment_statements {
1420 my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
1421 # Need to be connected to get the correct sqlt_type
1422 $self->ensure_connected() unless $type;
1423 $type ||= $self->sqlt_type;
1424 $version ||= $schema->VERSION || '1.x';
1426 my $filename = $schema->ddl_filename($type, $dir, $version);
1430 open($file, "<$filename")
1431 or $self->throw_exception("Can't open $filename ($!)");
1434 return join('', @rows);
1437 $self->throw_exception(q{Can't deploy without SQL::Translator 0.08: '}
1438 . $self->_check_sqlt_message . q{'})
1439 if !$self->_check_sqlt_version;
1441 require SQL::Translator::Parser::DBIx::Class;
1442 eval qq{use SQL::Translator::Producer::${type}};
1443 $self->throw_exception($@) if $@;
1445 # sources needs to be a parser arg, but for simplicty allow at top level
1447 $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources}
1448 if exists $sqltargs->{sources};
1450 my $tr = SQL::Translator->new(%$sqltargs);
1451 SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
1452 return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
1459 my ($self, $schema, $type, $sqltargs, $dir) = @_;
1460 foreach my $statement ( $self->deployment_statements($schema, $type, undef, $dir, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
1461 foreach my $line ( split(";\n", $statement)) {
1462 next if($line =~ /^--/);
1464 # next if($line =~ /^DROP/m);
1465 next if($line =~ /^BEGIN TRANSACTION/m);
1466 next if($line =~ /^COMMIT/m);
1467 next if $line =~ /^\s+$/; # skip whitespace only
1468 $self->debugobj->query_start($line) if $self->debug;
1470 $self->dbh->do($line); # shouldn't be using ->dbh ?
1473 warn qq{$@ (running "${line}")};
1475 $self->debugobj->query_end($line) if $self->debug;
1480 =head2 datetime_parser
1482 Returns the datetime parser class
1486 sub datetime_parser {
1488 return $self->{datetime_parser} ||= do {
1489 $self->ensure_connected;
1490 $self->build_datetime_parser(@_);
1494 =head2 datetime_parser_type
1496 Defines (returns) the datetime parser class - currently hardwired to
1497 L<DateTime::Format::MySQL>
1501 sub datetime_parser_type { "DateTime::Format::MySQL"; }
1503 =head2 build_datetime_parser
1505 See L</datetime_parser>
1509 sub build_datetime_parser {
1511 my $type = $self->datetime_parser_type(@_);
1513 $self->throw_exception("Couldn't load ${type}: $@") if $@;
1518 my $_check_sqlt_version; # private
1519 my $_check_sqlt_message; # private
1520 sub _check_sqlt_version {
1521 return $_check_sqlt_version if defined $_check_sqlt_version;
1522 eval 'use SQL::Translator 0.08';
1523 $_check_sqlt_message = $@ ? $@ : '';
1524 $_check_sqlt_version = $@ ? 0 : 1;
1527 sub _check_sqlt_message {
1528 _check_sqlt_version if !defined $_check_sqlt_message;
1529 $_check_sqlt_message;
1535 return if !$self->_dbh;
1544 The module defines a set of methods within the DBIC::SQL::Abstract
1545 namespace. These build on L<SQL::Abstract::Limit> to provide the
1546 SQL query functions.
1548 The following methods are extended:-
1562 See L</connect_info> for details.
1563 For setting, this method is deprecated in favor of L</connect_info>.
1567 See L</connect_info> for details.
1568 For setting, this method is deprecated in favor of L</connect_info>.
1572 See L</connect_info> for details.
1573 For setting, this method is deprecated in favor of L</connect_info>.
1579 Matt S. Trout <mst@shadowcatsystems.co.uk>
1581 Andy Grundman <andy@hybridized.org>
1585 You may distribute this code under the same terms as Perl itself.