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 transaction_depth unsafe _dbh_autocommit/
20 __PACKAGE__->cursor_class('DBIx::Class::Storage::DBI::Cursor');
24 package DBIC::SQL::Abstract; # Would merge upstream, but nate doesn't reply :(
26 use base qw/SQL::Abstract::Limit/;
28 # This prevents the caching of $dbh in S::A::L, I believe
30 my $self = shift->SUPER::new(@_);
32 # If limit_dialect is a ref (like a $dbh), go ahead and replace
33 # it with what it resolves to:
34 $self->{limit_dialect} = $self->_find_syntax($self->{limit_dialect})
35 if ref $self->{limit_dialect};
41 my ($self, $sql, $order, $rows, $offset ) = @_;
44 my $last = $rows + $offset;
45 my ( $order_by ) = $self->_order_by( $order );
50 SELECT Q1.*, ROW_NUMBER() OVER( ) AS ROW_NUM FROM (
55 WHERE ROW_NUM BETWEEN $offset AND $last
61 # While we're at it, this should make LIMIT queries more efficient,
62 # without digging into things too deeply
63 use Scalar::Util 'blessed';
65 my ($self, $syntax) = @_;
66 my $dbhname = blessed($syntax) ? $syntax->{Driver}{Name} : $syntax;
67 if(ref($self) && $dbhname && $dbhname eq 'DB2') {
68 return 'RowNumberOver';
71 $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
75 my ($self, $table, $fields, $where, $order, @rest) = @_;
76 $table = $self->_quote($table) unless ref($table);
77 local $self->{rownum_hack_count} = 1
78 if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
79 @rest = (-1) unless defined $rest[0];
80 die "LIMIT 0 Does Not Compute" if $rest[0] == 0;
81 # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
82 local $self->{having_bind} = [];
83 my ($sql, @ret) = $self->SUPER::select(
84 $table, $self->_recurse_fields($fields), $where, $order, @rest
86 return wantarray ? ($sql, @ret, @{$self->{having_bind}}) : $sql;
92 $table = $self->_quote($table) unless ref($table);
93 $self->SUPER::insert($table, @_);
99 $table = $self->_quote($table) unless ref($table);
100 $self->SUPER::update($table, @_);
106 $table = $self->_quote($table) unless ref($table);
107 $self->SUPER::delete($table, @_);
113 return $_[1].$self->_order_by($_[2]);
115 return $self->SUPER::_emulate_limit(@_);
119 sub _recurse_fields {
120 my ($self, $fields, $params) = @_;
121 my $ref = ref $fields;
122 return $self->_quote($fields) unless $ref;
123 return $$fields if $ref eq 'SCALAR';
125 if ($ref eq 'ARRAY') {
126 return join(', ', map {
127 $self->_recurse_fields($_)
128 .(exists $self->{rownum_hack_count} && !($params && $params->{no_rownum_hack})
129 ? ' AS col'.$self->{rownum_hack_count}++
132 } elsif ($ref eq 'HASH') {
133 foreach my $func (keys %$fields) {
134 return $self->_sqlcase($func)
135 .'( '.$self->_recurse_fields($fields->{$func}).' )';
144 if (ref $_[0] eq 'HASH') {
145 if (defined $_[0]->{group_by}) {
146 $ret = $self->_sqlcase(' group by ')
147 .$self->_recurse_fields($_[0]->{group_by}, { no_rownum_hack => 1 });
149 if (defined $_[0]->{having}) {
151 ($frag, @extra) = $self->_recurse_where($_[0]->{having});
152 push(@{$self->{having_bind}}, @extra);
153 $ret .= $self->_sqlcase(' having ').$frag;
155 if (defined $_[0]->{order_by}) {
156 $ret .= $self->_order_by($_[0]->{order_by});
158 } elsif (ref $_[0] eq 'SCALAR') {
159 $ret = $self->_sqlcase(' order by ').${ $_[0] };
160 } elsif (ref $_[0] eq 'ARRAY' && @{$_[0]}) {
161 my @order = @{+shift};
162 $ret = $self->_sqlcase(' order by ')
164 my $r = $self->_order_by($_, @_);
165 $r =~ s/^ ?ORDER BY //i;
169 $ret = $self->SUPER::_order_by(@_);
174 sub _order_directions {
175 my ($self, $order) = @_;
176 $order = $order->{order_by} if ref $order eq 'HASH';
177 return $self->SUPER::_order_directions($order);
181 my ($self, $from) = @_;
182 if (ref $from eq 'ARRAY') {
183 return $self->_recurse_from(@$from);
184 } elsif (ref $from eq 'HASH') {
185 return $self->_make_as($from);
187 return $from; # would love to quote here but _table ends up getting called
188 # twice during an ->select without a limit clause due to
189 # the way S::A::Limit->select works. should maybe consider
190 # bypassing this and doing S::A::select($self, ...) in
191 # our select method above. meantime, quoting shims have
192 # been added to select/insert/update/delete here
197 my ($self, $from, @join) = @_;
199 push(@sqlf, $self->_make_as($from));
200 foreach my $j (@join) {
203 # check whether a join type exists
204 my $join_clause = '';
205 my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
206 if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
207 $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
209 $join_clause = ' JOIN ';
211 push(@sqlf, $join_clause);
213 if (ref $to eq 'ARRAY') {
214 push(@sqlf, '(', $self->_recurse_from(@$to), ')');
216 push(@sqlf, $self->_make_as($to));
218 push(@sqlf, ' ON ', $self->_join_condition($on));
220 return join('', @sqlf);
224 my ($self, $from) = @_;
225 return join(' ', map { (ref $_ eq 'SCALAR' ? $$_ : $self->_quote($_)) }
226 reverse each %{$self->_skip_options($from)});
230 my ($self, $hash) = @_;
232 $clean_hash->{$_} = $hash->{$_}
233 for grep {!/^-/} keys %$hash;
237 sub _join_condition {
238 my ($self, $cond) = @_;
239 if (ref $cond eq 'HASH') {
244 # XXX no throw_exception() in this package and croak() fails with strange results
245 Carp::croak(ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
246 if ref($v) ne 'SCALAR';
250 my $x = '= '.$self->_quote($v); $j{$_} = \$x;
253 return scalar($self->_recurse_where(\%j));
254 } elsif (ref $cond eq 'ARRAY') {
255 return join(' OR ', map { $self->_join_condition($_) } @$cond);
257 die "Can't handle this yet!";
262 my ($self, $label) = @_;
263 return '' unless defined $label;
264 return "*" if $label eq '*';
265 return $label unless $self->{quote_char};
266 if(ref $self->{quote_char} eq "ARRAY"){
267 return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
268 if !defined $self->{name_sep};
269 my $sep = $self->{name_sep};
270 return join($self->{name_sep},
271 map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
272 split(/\Q$sep\E/,$label));
274 return $self->SUPER::_quote($label);
279 $self->{limit_dialect} = shift if @_;
280 return $self->{limit_dialect};
285 $self->{quote_char} = shift if @_;
286 return $self->{quote_char};
291 $self->{name_sep} = shift if @_;
292 return $self->{name_sep};
295 } # End of BEGIN block
299 DBIx::Class::Storage::DBI - DBI storage handler
305 This class represents the connection to an RDBMS via L<DBI>. See
306 L<DBIx::Class::Storage> for general information. This pod only
307 documents DBI-specific methods and behaviors.
314 my $new = shift->next::method(@_);
316 $new->transaction_depth(0);
317 $new->_sql_maker_opts({});
318 $new->{_in_dbh_do} = 0;
319 $new->{_dbh_gen} = 0;
326 The arguments of C<connect_info> are always a single array reference.
328 This is normally accessed via L<DBIx::Class::Schema/connection>, which
329 encapsulates its argument list in an arrayref before calling
330 C<connect_info> here.
332 The arrayref can either contain the same set of arguments one would
333 normally pass to L<DBI/connect>, or a lone code reference which returns
334 a connected database handle. Please note that the L<DBI> docs
335 recommend that you always explicitly set C<AutoCommit> to either
336 C<0> or C<1>. L<DBIx::Class> further recommends that it be set
337 to C<1>, and that you perform transactions via our L</txn_do>
338 method. L<DBIx::Class> will set it to C<1> if you do not do explicitly
339 set it to zero. This is the default for most DBDs. See below for more
342 In either case, if the final argument in your connect_info happens
343 to be a hashref, C<connect_info> will look there for several
344 connection-specific options:
350 This can be set to an arrayref of literal sql statements, which will
351 be executed immediately after making the connection to the database
352 every time we [re-]connect.
354 =item disable_sth_caching
356 If set to a true value, this option will disable the caching of
357 statement handles via L<DBI/prepare_cached>.
361 Sets the limit dialect. This is useful for JDBC-bridge among others
362 where the remote SQL-dialect cannot be determined by the name of the
367 Specifies what characters to use to quote table and column names. If
368 you use this you will want to specify L<name_sep> as well.
370 quote_char expects either a single character, in which case is it is placed
371 on either side of the table/column, or an arrayref of length 2 in which case the
372 table/column name is placed between the elements.
374 For example under MySQL you'd use C<quote_char =E<gt> '`'>, and user SQL Server you'd
375 use C<quote_char =E<gt> [qw/[ ]/]>.
379 This only needs to be used in conjunction with L<quote_char>, and is used to
380 specify the charecter that seperates elements (schemas, tables, columns) from
381 each other. In most cases this is simply a C<.>.
385 This Storage driver normally installs its own C<HandleError>, sets
386 C<RaiseError> and C<ShowErrorStatement> on, and sets C<PrintError> off on
387 all database handles, including those supplied by a coderef. It does this
388 so that it can have consistent and useful error behavior.
390 If you set this option to a true value, Storage will not do its usual
391 modifications to the database handle's attributes, and instead relies on
392 the settings in your connect_info DBI options (or the values you set in
393 your connection coderef, in the case that you are connecting via coderef).
395 Note that your custom settings can cause Storage to malfunction,
396 especially if you set a C<HandleError> handler that suppresses exceptions
397 and/or disable C<RaiseError>.
401 These options can be mixed in with your other L<DBI> connection attributes,
402 or placed in a seperate hashref after all other normal L<DBI> connection
405 Every time C<connect_info> is invoked, any previous settings for
406 these options will be cleared before setting the new ones, regardless of
407 whether any options are specified in the new C<connect_info>.
409 Another Important Note:
411 DBIC can do some wonderful magic with handling exceptions,
412 disconnections, and transactions when you use C<AutoCommit => 1>
413 combined with C<txn_do> for transaction support.
415 If you set C<AutoCommit => 0> in your connect info, then you are always
416 in an assumed transaction between commits, and you're telling us you'd
417 like to manage that manually. A lot of DBIC's magic protections
418 go away. We can't protect you from exceptions due to database
419 disconnects because we don't know anything about how to restart your
420 transactions. You're on your own for handling all sorts of exceptional
421 cases if you choose the C<AutoCommit => 0> path, just as you would
426 # Simple SQLite connection
427 ->connect_info([ 'dbi:SQLite:./foo.db' ]);
430 ->connect_info([ sub { DBI->connect(...) } ]);
432 # A bit more complicated
439 { quote_char => q{"}, name_sep => q{.} },
443 # Equivalent to the previous example
449 { AutoCommit => 1, quote_char => q{"}, name_sep => q{.} },
453 # Subref + DBIC-specific connection options
456 sub { DBI->connect(...) },
460 on_connect_do => ['SET search_path TO myschema,otherschema,public'],
461 disable_sth_caching => 1,
469 my ($self, $info_arg) = @_;
471 return $self->_connect_info if !$info_arg;
473 # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
474 # the new set of options
475 $self->_sql_maker(undef);
476 $self->_sql_maker_opts({});
477 $self->_connect_info([@$info_arg]); # copy for _connect_info
479 my $dbi_info = [@$info_arg]; # copy for _dbi_connect_info
481 my $last_info = $dbi_info->[-1];
482 if(ref $last_info eq 'HASH') {
483 $last_info = { %$last_info }; # so delete is non-destructive
484 for my $storage_opt (
485 qw/on_connect_do disable_sth_caching unsafe cursor_class/
487 if(my $value = delete $last_info->{$storage_opt}) {
488 $self->$storage_opt($value);
491 for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
492 if(my $opt_val = delete $last_info->{$sql_maker_opt}) {
493 $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
496 # re-insert modified hashref
497 $dbi_info->[-1] = $last_info;
499 # Get rid of any trailing empty hashref
500 pop(@$dbi_info) if !keys %$last_info;
502 $self->_dbi_connect_info($dbi_info);
504 $self->_connect_info;
509 This method is deprecated in favor of setting via L</connect_info>.
513 Arguments: $subref, @extra_coderef_args?
515 Execute the given subref using the new exception-based connection management.
517 The first two arguments will be the storage object that C<dbh_do> was called
518 on and a database handle to use. Any additional arguments will be passed
519 verbatim to the called subref as arguments 2 and onwards.
521 Using this (instead of $self->_dbh or $self->dbh) ensures correct
522 exception handling and reconnection (or failover in future subclasses).
524 Your subref should have no side-effects outside of the database, as
525 there is the potential for your subref to be partially double-executed
526 if the database connection was stale/dysfunctional.
530 my @stuff = $schema->storage->dbh_do(
532 my ($storage, $dbh, @cols) = @_;
533 my $cols = join(q{, }, @cols);
534 $dbh->selectrow_array("SELECT $cols FROM foo");
545 ref $coderef eq 'CODE' or $self->throw_exception
546 ('$coderef must be a CODE reference');
548 return $coderef->($self, $self->_dbh, @_) if $self->{_in_dbh_do}
549 || $self->{transaction_depth};
551 local $self->{_in_dbh_do} = 1;
554 my $want_array = wantarray;
557 $self->_verify_pid if $self->_dbh;
558 $self->_populate_dbh if !$self->_dbh;
560 @result = $coderef->($self, $self->_dbh, @_);
562 elsif(defined $want_array) {
563 $result[0] = $coderef->($self, $self->_dbh, @_);
566 $coderef->($self, $self->_dbh, @_);
571 if(!$exception) { return $want_array ? @result : $result[0] }
573 $self->throw_exception($exception) if $self->connected;
575 # We were not connected - reconnect and retry, but let any
576 # exception fall right through this time
577 $self->_populate_dbh;
578 $coderef->($self, $self->_dbh, @_);
581 # This is basically a blend of dbh_do above and DBIx::Class::Storage::txn_do.
582 # It also informs dbh_do to bypass itself while under the direction of txn_do,
583 # via $self->{_in_dbh_do} (this saves some redundant eval and errorcheck, etc)
588 ref $coderef eq 'CODE' or $self->throw_exception
589 ('$coderef must be a CODE reference');
591 return $coderef->(@_) if $self->{transaction_depth};
593 local $self->{_in_dbh_do} = 1;
596 my $want_array = wantarray;
601 $self->_verify_pid if $self->_dbh;
602 $self->_populate_dbh if !$self->_dbh;
606 @result = $coderef->(@_);
608 elsif(defined $want_array) {
609 $result[0] = $coderef->(@_);
618 if(!$exception) { return $want_array ? @result : $result[0] }
620 if($tried++ > 0 || $self->connected) {
621 eval { $self->txn_rollback };
622 my $rollback_exception = $@;
623 if($rollback_exception) {
624 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
625 $self->throw_exception($exception) # propagate nested rollback
626 if $rollback_exception =~ /$exception_class/;
628 $self->throw_exception(
629 "Transaction aborted: ${exception}. "
630 . "Rollback failed: ${rollback_exception}"
633 $self->throw_exception($exception)
636 # We were not connected, and was first try - reconnect and retry
638 $self->_populate_dbh;
644 Our C<disconnect> method also performs a rollback first if the
645 database is not in C<AutoCommit> mode.
652 if( $self->connected ) {
653 $self->_dbh->rollback unless $self->_dbh_autocommit;
654 $self->_dbh->disconnect;
663 if(my $dbh = $self->_dbh) {
664 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
671 return 0 if !$self->_dbh;
673 return ($dbh->FETCH('Active') && $dbh->ping);
679 # handle pid changes correctly
680 # NOTE: assumes $self->_dbh is a valid $dbh
684 return if $self->_conn_pid == $$;
686 $self->_dbh->{InactiveDestroy} = 1;
693 sub ensure_connected {
696 unless ($self->connected) {
697 $self->_populate_dbh;
703 Returns the dbh - a data base handle of class L<DBI>.
710 $self->ensure_connected;
714 sub _sql_maker_args {
717 return ( bindtype=>'columns', limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
722 unless ($self->_sql_maker) {
723 $self->_sql_maker(new DBIC::SQL::Abstract( $self->_sql_maker_args ));
725 return $self->_sql_maker;
730 my @info = @{$self->_dbi_connect_info || []};
731 $self->_dbh($self->_connect(@info));
733 # Always set the transaction depth on connect, since
734 # there is no transaction in progress by definition
735 $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
737 if(ref $self eq 'DBIx::Class::Storage::DBI') {
738 my $driver = $self->_dbh->{Driver}->{Name};
739 if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
740 bless $self, "DBIx::Class::Storage::DBI::${driver}";
741 $self->_rebless() if $self->can('_rebless');
745 # if on-connect sql statements are given execute them
746 foreach my $sql_statement (@{$self->on_connect_do || []}) {
747 $self->_query_start($sql_statement);
748 $self->_dbh->do($sql_statement);
749 $self->_query_end($sql_statement);
752 $self->_conn_pid($$);
753 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
757 my ($self, @info) = @_;
759 $self->throw_exception("You failed to provide any connection info")
762 my ($old_connect_via, $dbh);
764 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
765 $old_connect_via = $DBI::connect_via;
766 $DBI::connect_via = 'connect';
770 if(ref $info[0] eq 'CODE') {
774 $dbh = DBI->connect(@info);
777 if($dbh && !$self->unsafe) {
778 my $weak_self = $self;
780 $dbh->{HandleError} = sub {
781 $weak_self->throw_exception("DBI Exception: $_[0]")
783 $dbh->{ShowErrorStatement} = 1;
784 $dbh->{RaiseError} = 1;
785 $dbh->{PrintError} = 0;
789 $DBI::connect_via = $old_connect_via if $old_connect_via;
791 $self->throw_exception("DBI Connection failed: " . ($@||$DBI::errstr))
794 $self->_dbh_autocommit($dbh->{AutoCommit});
802 $self->ensure_connected();
803 if($self->{transaction_depth} == 0) {
804 $self->debugobj->txn_begin()
806 # this isn't ->_dbh-> because
807 # we should reconnect on begin_work
808 # for AutoCommit users
809 $self->dbh->begin_work;
811 $self->{transaction_depth}++;
816 if ($self->{transaction_depth} == 1) {
817 my $dbh = $self->_dbh;
818 $self->debugobj->txn_commit()
821 $self->{transaction_depth} = 0
822 if $self->_dbh_autocommit;
824 elsif($self->{transaction_depth} > 1) {
825 $self->{transaction_depth}--
831 my $dbh = $self->_dbh;
833 if ($self->{transaction_depth} == 1) {
834 $self->debugobj->txn_rollback()
836 $self->{transaction_depth} = 0
837 if $self->_dbh_autocommit;
840 elsif($self->{transaction_depth} > 1) {
841 $self->{transaction_depth}--;
844 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
849 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
850 $error =~ /$exception_class/ and $self->throw_exception($error);
851 # ensure that a failed rollback resets the transaction depth
852 $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
853 $self->throw_exception($error);
857 # This used to be the top-half of _execute. It was split out to make it
858 # easier to override in NoBindVars without duping the rest. It takes up
859 # all of _execute's args, and emits $sql, @bind.
860 sub _prep_for_execute {
861 my ($self, $op, $extra_bind, $ident, $args) = @_;
863 my ($sql, @bind) = $self->sql_maker->$op($ident, @$args);
865 map { ref $_ eq 'ARRAY' ? $_ : [ '!!dummy', $_ ] } @$extra_bind)
868 return ($sql, \@bind);
871 sub _fix_bind_params {
872 my ($self, @bind) = @_;
874 ### Turn @bind from something like this:
875 ### ( [ "artist", 1 ], [ "cdid", 1, 3 ] )
877 ### ( "'1'", "'1'", "'3'" )
880 if ( defined( $_ && $_->[1] ) ) {
881 map { qq{'$_'}; } @{$_}[ 1 .. $#$_ ];
888 my ( $self, $sql, @bind ) = @_;
890 if ( $self->debug ) {
891 @bind = $self->_fix_bind_params(@bind);
892 $self->debugobj->query_start( $sql, @bind );
897 my ( $self, $sql, @bind ) = @_;
899 if ( $self->debug ) {
900 @bind = $self->_fix_bind_params(@bind);
901 $self->debugobj->query_end( $sql, @bind );
906 my ($self, $dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
908 if( blessed($ident) && $ident->isa("DBIx::Class::ResultSource") ) {
909 $ident = $ident->from();
912 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
914 $self->_query_start( $sql, @$bind );
916 my $sth = $self->sth($sql,$op);
918 my $placeholder_index = 1;
920 foreach my $bound (@$bind) {
922 my($column_name, @data) = @$bound;
924 if ($bind_attributes) {
925 $attributes = $bind_attributes->{$column_name}
926 if defined $bind_attributes->{$column_name};
929 foreach my $data (@data) {
930 $data = ref $data ? ''.$data : $data; # stringify args
932 $sth->bind_param($placeholder_index, $data, $attributes);
933 $placeholder_index++;
937 # Can this fail without throwing an exception anyways???
938 my $rv = $sth->execute();
939 $self->throw_exception($sth->errstr) if !$rv;
941 $self->_query_end( $sql, @$bind );
943 return (wantarray ? ($rv, $sth, @$bind) : $rv);
948 $self->dbh_do($self->can('_dbh_execute'), @_)
952 my ($self, $source, $to_insert) = @_;
954 my $ident = $source->from;
955 my $bind_attributes = $self->source_bind_attributes($source);
957 $self->_execute('insert' => [], $source, $bind_attributes, $to_insert);
962 ## Still not quite perfect, and EXPERIMENTAL
963 ## Currently it is assumed that all values passed will be "normal", i.e. not
964 ## scalar refs, or at least, all the same type as the first set, the statement is
965 ## only prepped once.
967 my ($self, $source, $cols, $data) = @_;
969 my $table = $source->from;
970 @colvalues{@$cols} = (0..$#$cols);
971 my ($sql, @bind) = $self->sql_maker->insert($table, \%colvalues);
973 $self->_query_start( $sql, @bind );
974 my $sth = $self->sth($sql);
976 # @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
978 ## This must be an arrayref, else nothing works!
980 my $tuple_status = [];
983 ##print STDERR Dumper( $data, $sql, [@bind] );
987 ## Get the bind_attributes, if any exist
988 my $bind_attributes = $self->source_bind_attributes($source);
990 ## Bind the values and execute
991 my $placeholder_index = 1;
993 foreach my $bound (@bind) {
996 my ($column_name, $data_index) = @$bound;
998 if( $bind_attributes ) {
999 $attributes = $bind_attributes->{$column_name}
1000 if defined $bind_attributes->{$column_name};
1003 my @data = map { $_->[$data_index] } @$data;
1005 $sth->bind_param_array( $placeholder_index, [@data], $attributes );
1006 $placeholder_index++;
1008 my $rv = $sth->execute_array({ArrayTupleStatus => $tuple_status});
1009 $self->throw_exception($sth->errstr) if !$rv;
1011 $self->_query_end( $sql, @bind );
1012 return (wantarray ? ($rv, $sth, @bind) : $rv);
1016 my $self = shift @_;
1017 my $source = shift @_;
1018 my $bind_attributes = $self->source_bind_attributes($source);
1020 return $self->_execute('update' => [], $source, $bind_attributes, @_);
1025 my $self = shift @_;
1026 my $source = shift @_;
1028 my $bind_attrs = {}; ## If ever it's needed...
1030 return $self->_execute('delete' => [], $source, $bind_attrs, @_);
1034 my ($self, $ident, $select, $condition, $attrs) = @_;
1035 my $order = $attrs->{order_by};
1036 if (ref $condition eq 'SCALAR') {
1037 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
1039 if (exists $attrs->{group_by} || $attrs->{having}) {
1041 group_by => $attrs->{group_by},
1042 having => $attrs->{having},
1043 ($order ? (order_by => $order) : ())
1046 my $bind_attrs = {}; ## Future support
1047 my @args = ('select', $attrs->{bind}, $ident, $bind_attrs, $select, $condition, $order);
1048 if ($attrs->{software_limit} ||
1049 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
1050 $attrs->{software_limit} = 1;
1052 $self->throw_exception("rows attribute must be positive if present")
1053 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
1054 push @args, $attrs->{rows}, $attrs->{offset};
1056 return $self->_execute(@args);
1059 sub source_bind_attributes {
1060 my ($self, $source) = @_;
1062 my $bind_attributes;
1063 foreach my $column ($source->columns) {
1065 my $data_type = $source->column_info($column)->{data_type} || '';
1066 $bind_attributes->{$column} = $self->bind_attribute_by_data_type($data_type)
1070 return $bind_attributes;
1077 =item Arguments: $ident, $select, $condition, $attrs
1081 Handle a SQL select statement.
1087 my ($ident, $select, $condition, $attrs) = @_;
1088 return $self->cursor_class->new($self, \@_, $attrs);
1093 my ($rv, $sth, @bind) = $self->_select(@_);
1094 my @row = $sth->fetchrow_array;
1095 # Need to call finish() to work round broken DBDs
1104 =item Arguments: $sql
1108 Returns a L<DBI> sth (statement handle) for the supplied SQL.
1113 my ($self, $dbh, $sql) = @_;
1115 # 3 is the if_active parameter which avoids active sth re-use
1116 my $sth = $self->disable_sth_caching
1117 ? $dbh->prepare($sql)
1118 : $dbh->prepare_cached($sql, {}, 3);
1120 # XXX You would think RaiseError would make this impossible,
1121 # but apparently that's not true :(
1122 $self->throw_exception($dbh->errstr) if !$sth;
1128 my ($self, $sql) = @_;
1129 $self->dbh_do($self->can('_dbh_sth'), $sql);
1132 sub _dbh_columns_info_for {
1133 my ($self, $dbh, $table) = @_;
1135 if ($dbh->can('column_info')) {
1138 my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
1139 my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
1141 while ( my $info = $sth->fetchrow_hashref() ){
1143 $column_info{data_type} = $info->{TYPE_NAME};
1144 $column_info{size} = $info->{COLUMN_SIZE};
1145 $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
1146 $column_info{default_value} = $info->{COLUMN_DEF};
1147 my $col_name = $info->{COLUMN_NAME};
1148 $col_name =~ s/^\"(.*)\"$/$1/;
1150 $result{$col_name} = \%column_info;
1153 return \%result if !$@ && scalar keys %result;
1157 my $sth = $dbh->prepare($self->sql_maker->select($table, undef, \'1 = 0'));
1159 my @columns = @{$sth->{NAME_lc}};
1160 for my $i ( 0 .. $#columns ){
1162 $column_info{data_type} = $sth->{TYPE}->[$i];
1163 $column_info{size} = $sth->{PRECISION}->[$i];
1164 $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
1166 if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
1167 $column_info{data_type} = $1;
1168 $column_info{size} = $2;
1171 $result{$columns[$i]} = \%column_info;
1175 foreach my $col (keys %result) {
1176 my $colinfo = $result{$col};
1177 my $type_num = $colinfo->{data_type};
1179 if(defined $type_num && $dbh->can('type_info')) {
1180 my $type_info = $dbh->type_info($type_num);
1181 $type_name = $type_info->{TYPE_NAME} if $type_info;
1182 $colinfo->{data_type} = $type_name if $type_name;
1189 sub columns_info_for {
1190 my ($self, $table) = @_;
1191 $self->dbh_do($self->can('_dbh_columns_info_for'), $table);
1194 =head2 last_insert_id
1196 Return the row id of the last insert.
1200 sub _dbh_last_insert_id {
1201 my ($self, $dbh, $source, $col) = @_;
1202 # XXX This is a SQLite-ism as a default... is there a DBI-generic way?
1203 $dbh->func('last_insert_rowid');
1206 sub last_insert_id {
1208 $self->dbh_do($self->can('_dbh_last_insert_id'), @_);
1213 Returns the database driver name.
1217 sub sqlt_type { shift->dbh->{Driver}->{Name} }
1219 =head2 bind_attribute_by_data_type
1221 Given a datatype from column info, returns a database specific bind attribute for
1222 $dbh->bind_param($val,$attribute) or nothing if we will let the database planner
1225 Generally only needed for special case column types, like bytea in postgres.
1229 sub bind_attribute_by_data_type {
1233 =head2 create_ddl_dir
1237 =item Arguments: $schema \@databases, $version, $directory, $preversion, $sqlt_args
1241 Creates a SQL file based on the Schema, for each of the specified
1242 database types, in the given directory.
1248 my ($self, $schema, $databases, $version, $dir, $preversion, $sqltargs) = @_;
1250 if(!$dir || !-d $dir)
1252 warn "No directory given, using ./\n";
1255 $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
1256 $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
1257 $version ||= $schema->VERSION || '1.x';
1258 $sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} };
1260 $self->throw_exception(q{Can't create a ddl file without SQL::Translator 0.08: '}
1261 . $self->_check_sqlt_message . q{'})
1262 if !$self->_check_sqlt_version;
1264 my $sqlt = SQL::Translator->new({
1266 add_drop_table => 1,
1268 foreach my $db (@$databases)
1271 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
1272 # $sqlt->parser_args({'DBIx::Class' => $schema);
1273 $sqlt = $self->configure_sqlt($sqlt, $db);
1274 $sqlt->data($schema);
1275 $sqlt->producer($db);
1278 my $filename = $schema->ddl_filename($db, $dir, $version);
1281 warn("$filename already exists, skipping $db");
1285 my $output = $sqlt->translate;
1288 warn("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
1291 if(!open($file, ">$filename"))
1293 $self->throw_exception("Can't open $filename for writing ($!)");
1296 print $file $output;
1301 require SQL::Translator::Diff;
1303 my $prefilename = $schema->ddl_filename($db, $dir, $preversion);
1304 # print "Previous version $prefilename\n";
1305 if(!-e $prefilename)
1307 warn("No previous schema file found ($prefilename)");
1310 #### We need to reparse the SQLite file we just wrote, so that
1311 ## Diff doesnt get all confoosed, and Diff is *very* confused.
1312 ## FIXME: rip Diff to pieces!
1313 # my $target_schema = $sqlt->schema;
1314 # unless ( $target_schema->name ) {
1315 # $target_schema->name( $filename );
1318 push @input, {file => $prefilename, parser => $db};
1319 push @input, {file => $filename, parser => $db};
1320 my ( $source_schema, $source_db, $target_schema, $target_db ) = map {
1321 my $file = $_->{'file'};
1322 my $parser = $_->{'parser'};
1324 my $t = SQL::Translator->new;
1327 $t->parser( $parser ) or die $t->error;
1328 my $out = $t->translate( $file ) or die $t->error;
1329 my $schema = $t->schema;
1330 unless ( $schema->name ) {
1331 $schema->name( $file );
1336 my $diff = SQL::Translator::Diff::schema_diff($source_schema, $db,
1337 $target_schema, $db,
1340 my $difffile = $schema->ddl_filename($db, $dir, $version, $preversion);
1341 print STDERR "Diff: $difffile: $db, $dir, $version, $preversion \n";
1344 warn("$difffile already exists, skipping");
1347 if(!open $file, ">$difffile")
1349 $self->throw_exception("Can't write to $difffile ($!)");
1358 sub configure_sqlt() {
1361 my $db = shift || $self->sqlt_type;
1362 if ($db eq 'PostgreSQL') {
1363 $tr->quote_table_names(0);
1364 $tr->quote_field_names(0);
1369 =head2 deployment_statements
1373 =item Arguments: $schema, $type, $version, $directory, $sqlt_args
1377 Returns the statements used by L</deploy> and L<DBIx::Class::Schema/deploy>.
1378 The database driver name is given by C<$type>, though the value from
1379 L</sqlt_type> is used if it is not specified.
1381 C<$directory> is used to return statements from files in a previously created
1382 L</create_ddl_dir> directory and is optional. The filenames are constructed
1383 from L<DBIx::Class::Schema/ddl_filename>, the schema name and the C<$version>.
1385 If no C<$directory> is specified then the statements are constructed on the
1386 fly using L<SQL::Translator> and C<$version> is ignored.
1388 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>.
1392 sub deployment_statements {
1393 my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
1394 # Need to be connected to get the correct sqlt_type
1395 $self->ensure_connected() unless $type;
1396 $type ||= $self->sqlt_type;
1397 $version ||= $schema->VERSION || '1.x';
1399 my $filename = $schema->ddl_filename($type, $dir, $version);
1403 open($file, "<$filename")
1404 or $self->throw_exception("Can't open $filename ($!)");
1407 return join('', @rows);
1410 $self->throw_exception(q{Can't deploy without SQL::Translator 0.08: '}
1411 . $self->_check_sqlt_message . q{'})
1412 if !$self->_check_sqlt_version;
1414 require SQL::Translator::Parser::DBIx::Class;
1415 eval qq{use SQL::Translator::Producer::${type}};
1416 $self->throw_exception($@) if $@;
1418 # sources needs to be a parser arg, but for simplicty allow at top level
1420 $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources}
1421 if exists $sqltargs->{sources};
1423 my $tr = SQL::Translator->new(%$sqltargs);
1424 SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
1425 return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
1432 my ($self, $schema, $type, $sqltargs, $dir) = @_;
1433 foreach my $statement ( $self->deployment_statements($schema, $type, undef, $dir, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
1434 foreach my $line ( split(";\n", $statement)) {
1435 next if($line =~ /^--/);
1437 # next if($line =~ /^DROP/m);
1438 next if($line =~ /^BEGIN TRANSACTION/m);
1439 next if($line =~ /^COMMIT/m);
1440 next if $line =~ /^\s+$/; # skip whitespace only
1441 $self->_query_start($line);
1443 $self->dbh->do($line); # shouldn't be using ->dbh ?
1446 warn qq{$@ (running "${line}")};
1448 $self->_query_end($line);
1453 =head2 datetime_parser
1455 Returns the datetime parser class
1459 sub datetime_parser {
1461 return $self->{datetime_parser} ||= do {
1462 $self->ensure_connected;
1463 $self->build_datetime_parser(@_);
1467 =head2 datetime_parser_type
1469 Defines (returns) the datetime parser class - currently hardwired to
1470 L<DateTime::Format::MySQL>
1474 sub datetime_parser_type { "DateTime::Format::MySQL"; }
1476 =head2 build_datetime_parser
1478 See L</datetime_parser>
1482 sub build_datetime_parser {
1484 my $type = $self->datetime_parser_type(@_);
1486 $self->throw_exception("Couldn't load ${type}: $@") if $@;
1491 my $_check_sqlt_version; # private
1492 my $_check_sqlt_message; # private
1493 sub _check_sqlt_version {
1494 return $_check_sqlt_version if defined $_check_sqlt_version;
1495 eval 'use SQL::Translator 0.08';
1496 $_check_sqlt_message = $@ ? $@ : '';
1497 $_check_sqlt_version = $@ ? 0 : 1;
1500 sub _check_sqlt_message {
1501 _check_sqlt_version if !defined $_check_sqlt_message;
1502 $_check_sqlt_message;
1508 return if !$self->_dbh;
1517 The module defines a set of methods within the DBIC::SQL::Abstract
1518 namespace. These build on L<SQL::Abstract::Limit> to provide the
1519 SQL query functions.
1521 The following methods are extended:-
1535 See L</connect_info> for details.
1536 For setting, this method is deprecated in favor of L</connect_info>.
1540 See L</connect_info> for details.
1541 For setting, this method is deprecated in favor of L</connect_info>.
1545 See L</connect_info> for details.
1546 For setting, this method is deprecated in favor of L</connect_info>.
1552 Matt S. Trout <mst@shadowcatsystems.co.uk>
1554 Andy Grundman <andy@hybridized.org>
1558 You may distribute this code under the same terms as Perl itself.