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;
14 __PACKAGE__->mk_group_accessors(
16 qw/_connect_info _dbh _sql_maker _sql_maker_opts _conn_pid _conn_tid
17 cursor on_connect_do transaction_depth/
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 # print STDERR "Found DBH $syntax >$dbhname< ", $syntax->{Driver}->{Name}, "\n";
66 if(ref($self) && $dbhname && $dbhname eq 'DB2') {
67 return 'RowNumberOver';
70 $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
74 my ($self, $table, $fields, $where, $order, @rest) = @_;
75 $table = $self->_quote($table) unless ref($table);
76 local $self->{rownum_hack_count} = 1
77 if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
78 @rest = (-1) unless defined $rest[0];
79 die "LIMIT 0 Does Not Compute" if $rest[0] == 0;
80 # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
81 local $self->{having_bind} = [];
82 my ($sql, @ret) = $self->SUPER::select(
83 $table, $self->_recurse_fields($fields), $where, $order, @rest
85 return wantarray ? ($sql, @ret, @{$self->{having_bind}}) : $sql;
91 $table = $self->_quote($table) unless ref($table);
92 $self->SUPER::insert($table, @_);
98 $table = $self->_quote($table) unless ref($table);
99 $self->SUPER::update($table, @_);
105 $table = $self->_quote($table) unless ref($table);
106 $self->SUPER::delete($table, @_);
112 return $_[1].$self->_order_by($_[2]);
114 return $self->SUPER::_emulate_limit(@_);
118 sub _recurse_fields {
119 my ($self, $fields) = @_;
120 my $ref = ref $fields;
121 return $self->_quote($fields) unless $ref;
122 return $$fields if $ref eq 'SCALAR';
124 if ($ref eq 'ARRAY') {
125 return join(', ', map {
126 $self->_recurse_fields($_)
127 .(exists $self->{rownum_hack_count}
128 ? ' AS col'.$self->{rownum_hack_count}++
131 } elsif ($ref eq 'HASH') {
132 foreach my $func (keys %$fields) {
133 return $self->_sqlcase($func)
134 .'( '.$self->_recurse_fields($fields->{$func}).' )';
143 if (ref $_[0] eq 'HASH') {
144 if (defined $_[0]->{group_by}) {
145 $ret = $self->_sqlcase(' group by ')
146 .$self->_recurse_fields($_[0]->{group_by});
148 if (defined $_[0]->{having}) {
150 ($frag, @extra) = $self->_recurse_where($_[0]->{having});
151 push(@{$self->{having_bind}}, @extra);
152 $ret .= $self->_sqlcase(' having ').$frag;
154 if (defined $_[0]->{order_by}) {
155 $ret .= $self->_order_by($_[0]->{order_by});
157 } elsif (ref $_[0] eq 'SCALAR') {
158 $ret = $self->_sqlcase(' order by ').${ $_[0] };
159 } elsif (ref $_[0] eq 'ARRAY' && @{$_[0]}) {
160 my @order = @{+shift};
161 $ret = $self->_sqlcase(' order by ')
163 my $r = $self->_order_by($_, @_);
164 $r =~ s/^ ?ORDER BY //i;
168 $ret = $self->SUPER::_order_by(@_);
173 sub _order_directions {
174 my ($self, $order) = @_;
175 $order = $order->{order_by} if ref $order eq 'HASH';
176 return $self->SUPER::_order_directions($order);
180 my ($self, $from) = @_;
181 if (ref $from eq 'ARRAY') {
182 return $self->_recurse_from(@$from);
183 } elsif (ref $from eq 'HASH') {
184 return $self->_make_as($from);
186 return $from; # would love to quote here but _table ends up getting called
187 # twice during an ->select without a limit clause due to
188 # the way S::A::Limit->select works. should maybe consider
189 # bypassing this and doing S::A::select($self, ...) in
190 # our select method above. meantime, quoting shims have
191 # been added to select/insert/update/delete here
196 my ($self, $from, @join) = @_;
198 push(@sqlf, $self->_make_as($from));
199 foreach my $j (@join) {
202 # check whether a join type exists
203 my $join_clause = '';
204 my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
205 if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
206 $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
208 $join_clause = ' JOIN ';
210 push(@sqlf, $join_clause);
212 if (ref $to eq 'ARRAY') {
213 push(@sqlf, '(', $self->_recurse_from(@$to), ')');
215 push(@sqlf, $self->_make_as($to));
217 push(@sqlf, ' ON ', $self->_join_condition($on));
219 return join('', @sqlf);
223 my ($self, $from) = @_;
224 return join(' ', map { (ref $_ eq 'SCALAR' ? $$_ : $self->_quote($_)) }
225 reverse each %{$self->_skip_options($from)});
229 my ($self, $hash) = @_;
231 $clean_hash->{$_} = $hash->{$_}
232 for grep {!/^-/} keys %$hash;
236 sub _join_condition {
237 my ($self, $cond) = @_;
238 if (ref $cond eq 'HASH') {
241 my $x = '= '.$self->_quote($cond->{$_}); $j{$_} = \$x;
243 return $self->_recurse_where(\%j);
244 } elsif (ref $cond eq 'ARRAY') {
245 return join(' OR ', map { $self->_join_condition($_) } @$cond);
247 die "Can't handle this yet!";
252 my ($self, $label) = @_;
253 return '' unless defined $label;
254 return "*" if $label eq '*';
255 return $label unless $self->{quote_char};
256 if(ref $self->{quote_char} eq "ARRAY"){
257 return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
258 if !defined $self->{name_sep};
259 my $sep = $self->{name_sep};
260 return join($self->{name_sep},
261 map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
262 split(/\Q$sep\E/,$label));
264 return $self->SUPER::_quote($label);
269 $self->{limit_dialect} = shift if @_;
270 return $self->{limit_dialect};
275 $self->{quote_char} = shift if @_;
276 return $self->{quote_char};
281 $self->{name_sep} = shift if @_;
282 return $self->{name_sep};
285 } # End of BEGIN block
289 DBIx::Class::Storage::DBI - DBI storage handler
295 This class represents the connection to an RDBMS via L<DBI>. See
296 L<DBIx::Class::Storage> for general information. This pod only
297 documents DBI-specific methods and behaviors.
304 my $new = shift->next::method(@_);
306 $new->cursor("DBIx::Class::Storage::DBI::Cursor");
307 $new->transaction_depth(0);
308 $new->_sql_maker_opts({});
309 $new->{_in_dbh_do} = 0;
310 $new->{_dbh_gen} = 0;
317 The arguments of C<connect_info> are always a single array reference.
319 This is normally accessed via L<DBIx::Class::Schema/connection>, which
320 encapsulates its argument list in an arrayref before calling
321 C<connect_info> here.
323 The arrayref can either contain the same set of arguments one would
324 normally pass to L<DBI/connect>, or a lone code reference which returns
325 a connected database handle.
327 In either case, if the final argument in your connect_info happens
328 to be a hashref, C<connect_info> will look there for several
329 connection-specific options:
335 This can be set to an arrayref of literal sql statements, which will
336 be executed immediately after making the connection to the database
337 every time we [re-]connect.
341 Sets the limit dialect. This is useful for JDBC-bridge among others
342 where the remote SQL-dialect cannot be determined by the name of the
347 Specifies what characters to use to quote table and column names. If
348 you use this you will want to specify L<name_sep> as well.
350 quote_char expects either a single character, in which case is it is placed
351 on either side of the table/column, or an arrayref of length 2 in which case the
352 table/column name is placed between the elements.
354 For example under MySQL you'd use C<quote_char =E<gt> '`'>, and user SQL Server you'd
355 use C<quote_char =E<gt> [qw/[ ]/]>.
359 This only needs to be used in conjunction with L<quote_char>, and is used to
360 specify the charecter that seperates elements (schemas, tables, columns) from
361 each other. In most cases this is simply a C<.>.
365 These options can be mixed in with your other L<DBI> connection attributes,
366 or placed in a seperate hashref after all other normal L<DBI> connection
369 Every time C<connect_info> is invoked, any previous settings for
370 these options will be cleared before setting the new ones, regardless of
371 whether any options are specified in the new C<connect_info>.
373 Important note: DBIC expects the returned database handle provided by
374 a subref argument to have RaiseError set on it. If it doesn't, things
375 might not work very well, YMMV. If you don't use a subref, DBIC will
376 force this setting for you anyways. Setting HandleError to anything
377 other than simple exception object wrapper might cause problems too.
381 # Simple SQLite connection
382 ->connect_info([ 'dbi:SQLite:./foo.db' ]);
385 ->connect_info([ sub { DBI->connect(...) } ]);
387 # A bit more complicated
394 { quote_char => q{"}, name_sep => q{.} },
398 # Equivalent to the previous example
404 { AutoCommit => 0, quote_char => q{"}, name_sep => q{.} },
408 # Subref + DBIC-specific connection options
411 sub { DBI->connect(...) },
415 on_connect_do => ['SET search_path TO myschema,otherschema,public'],
423 my ($self, $info_arg) = @_;
425 return $self->_connect_info if !$info_arg;
427 # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
428 # the new set of options
429 $self->_sql_maker(undef);
430 $self->_sql_maker_opts({});
432 my $info = [ @$info_arg ]; # copy because we can alter it
433 my $last_info = $info->[-1];
434 if(ref $last_info eq 'HASH') {
435 if(my $on_connect_do = delete $last_info->{on_connect_do}) {
436 $self->on_connect_do($on_connect_do);
438 for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
439 if(my $opt_val = delete $last_info->{$sql_maker_opt}) {
440 $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
444 # Get rid of any trailing empty hashref
445 pop(@$info) if !keys %$last_info;
448 $self->_connect_info($info);
453 This method is deprecated in favor of setting via L</connect_info>.
457 Arguments: $subref, @extra_coderef_args?
459 Execute the given subref using the new exception-based connection management.
461 The first two arguments will be the storage object that C<dbh_do> was called
462 on and a database handle to use. Any additional arguments will be passed
463 verbatim to the called subref as arguments 2 and onwards.
465 Using this (instead of $self->_dbh or $self->dbh) ensures correct
466 exception handling and reconnection (or failover in future subclasses).
468 Your subref should have no side-effects outside of the database, as
469 there is the potential for your subref to be partially double-executed
470 if the database connection was stale/dysfunctional.
474 my @stuff = $schema->storage->dbh_do(
476 my ($storage, $dbh, @cols) = @_;
477 my $cols = join(q{, }, @cols);
478 $dbh->selectrow_array("SELECT $cols FROM foo");
489 ref $coderef eq 'CODE' or $self->throw_exception
490 ('$coderef must be a CODE reference');
492 return $coderef->($self, $self->_dbh, @_) if $self->{_in_dbh_do};
493 local $self->{_in_dbh_do} = 1;
496 my $want_array = wantarray;
499 $self->_verify_pid if $self->_dbh;
500 $self->_populate_dbh if !$self->_dbh;
502 @result = $coderef->($self, $self->_dbh, @_);
504 elsif(defined $want_array) {
505 $result[0] = $coderef->($self, $self->_dbh, @_);
508 $coderef->($self, $self->_dbh, @_);
513 if(!$exception) { return $want_array ? @result : $result[0] }
515 $self->throw_exception($exception) if $self->connected;
517 # We were not connected - reconnect and retry, but let any
518 # exception fall right through this time
519 $self->_populate_dbh;
520 $coderef->($self, $self->_dbh, @_);
523 # This is basically a blend of dbh_do above and DBIx::Class::Storage::txn_do.
524 # It also informs dbh_do to bypass itself while under the direction of txn_do,
525 # via $self->{_in_dbh_do} (this saves some redundant eval and errorcheck, etc)
530 ref $coderef eq 'CODE' or $self->throw_exception
531 ('$coderef must be a CODE reference');
533 local $self->{_in_dbh_do} = 1;
536 my $want_array = wantarray;
541 $self->_verify_pid if $self->_dbh;
542 $self->_populate_dbh if !$self->_dbh;
546 @result = $coderef->(@_);
548 elsif(defined $want_array) {
549 $result[0] = $coderef->(@_);
558 if(!$exception) { return $want_array ? @result : $result[0] }
560 if($tried++ > 0 || $self->connected) {
561 eval { $self->txn_rollback };
562 my $rollback_exception = $@;
563 if($rollback_exception) {
564 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
565 $self->throw_exception($exception) # propagate nested rollback
566 if $rollback_exception =~ /$exception_class/;
568 $self->throw_exception(
569 "Transaction aborted: ${exception}. "
570 . "Rollback failed: ${rollback_exception}"
573 $self->throw_exception($exception)
576 # We were not connected, and was first try - reconnect and retry
578 $self->_populate_dbh;
584 Our C<disconnect> method also performs a rollback first if the
585 database is not in C<AutoCommit> mode.
592 if( $self->connected ) {
593 $self->_dbh->rollback unless $self->_dbh->{AutoCommit};
594 $self->_dbh->disconnect;
603 if(my $dbh = $self->_dbh) {
604 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
612 return ($dbh->FETCH('Active') && $dbh->ping);
618 # handle pid changes correctly
619 # NOTE: assumes $self->_dbh is a valid $dbh
623 return if $self->_conn_pid == $$;
625 $self->_dbh->{InactiveDestroy} = 1;
632 sub ensure_connected {
635 unless ($self->connected) {
636 $self->_populate_dbh;
642 Returns the dbh - a data base handle of class L<DBI>.
649 $self->ensure_connected;
653 sub _sql_maker_args {
656 return ( limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
661 unless ($self->_sql_maker) {
662 $self->_sql_maker(new DBIC::SQL::Abstract( $self->_sql_maker_args ));
664 return $self->_sql_maker;
669 my @info = @{$self->_connect_info || []};
670 $self->_dbh($self->_connect(@info));
672 if(ref $self eq 'DBIx::Class::Storage::DBI') {
673 my $driver = $self->_dbh->{Driver}->{Name};
674 if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
675 bless $self, "DBIx::Class::Storage::DBI::${driver}";
676 $self->_rebless() if $self->can('_rebless');
680 # if on-connect sql statements are given execute them
681 foreach my $sql_statement (@{$self->on_connect_do || []}) {
682 $self->debugobj->query_start($sql_statement) if $self->debug();
683 $self->_dbh->do($sql_statement);
684 $self->debugobj->query_end($sql_statement) if $self->debug();
687 $self->_conn_pid($$);
688 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
692 my ($self, @info) = @_;
694 $self->throw_exception("You failed to provide any connection info")
697 my ($old_connect_via, $dbh);
699 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
700 $old_connect_via = $DBI::connect_via;
701 $DBI::connect_via = 'connect';
705 if(ref $info[0] eq 'CODE') {
709 $dbh = DBI->connect(@info);
710 $dbh->{RaiseError} = 1;
711 $dbh->{PrintError} = 0;
712 $dbh->{PrintWarn} = 0;
716 $DBI::connect_via = $old_connect_via if $old_connect_via;
719 $self->throw_exception("DBI Connection failed: " . ($@ || $DBI::errstr));
726 my ($self, $dbh) = @_;
727 if ($dbh->{AutoCommit}) {
728 $self->debugobj->txn_begin()
736 $self->dbh_do($self->can('_dbh_txn_begin'))
737 if $self->{transaction_depth}++ == 0;
740 sub _dbh_txn_commit {
741 my ($self, $dbh) = @_;
742 if ($self->{transaction_depth} == 0) {
743 unless ($dbh->{AutoCommit}) {
744 $self->debugobj->txn_commit()
750 if (--$self->{transaction_depth} == 0) {
751 $self->debugobj->txn_commit()
760 $self->dbh_do($self->can('_dbh_txn_commit'));
763 sub _dbh_txn_rollback {
764 my ($self, $dbh) = @_;
765 if ($self->{transaction_depth} == 0) {
766 unless ($dbh->{AutoCommit}) {
767 $self->debugobj->txn_rollback()
773 if (--$self->{transaction_depth} == 0) {
774 $self->debugobj->txn_rollback()
779 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
787 eval { $self->dbh_do($self->can('_dbh_txn_rollback')) };
790 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
791 $error =~ /$exception_class/ and $self->throw_exception($error);
792 $self->{transaction_depth} = 0; # ensure that a failed rollback
793 $self->throw_exception($error); # resets the transaction depth
797 # This used to be the top-half of _execute. It was split out to make it
798 # easier to override in NoBindVars without duping the rest. It takes up
799 # all of _execute's args, and emits $sql, @bind.
800 sub _prep_for_execute {
801 my ($self, $op, $extra_bind, $ident, @args) = @_;
803 my ($sql, @bind) = $self->sql_maker->$op($ident, @args);
804 unshift(@bind, @$extra_bind) if $extra_bind;
805 @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
807 return ($sql, @bind);
813 my ($sql, @bind) = $self->_prep_for_execute(@_);
816 my @debug_bind = map { defined $_ ? qq{'$_'} : q{'NULL'} } @bind;
817 $self->debugobj->query_start($sql, @debug_bind);
820 my $sth = $self->sth($sql);
825 $rv = eval { $sth->execute(@bind) };
828 $self->throw_exception("Error executing '$sql': ".($@ || $sth->errstr));
831 $self->throw_exception("'$sql' did not generate a statement.");
834 my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind;
835 $self->debugobj->query_end($sql, @debug_bind);
837 return (wantarray ? ($rv, $sth, @bind) : $rv);
841 my ($self, $ident, $to_insert) = @_;
842 $self->throw_exception(
843 "Couldn't insert ".join(', ',
844 map "$_ => $to_insert->{$_}", keys %$to_insert
846 ) unless ($self->_execute('insert' => [], $ident, $to_insert));
850 ## Still not quite perfect, and EXPERIMENTAL
851 ## Currently it is assumed that all values passed will be "normal", i.e. not
852 ## scalar refs, or at least, all the same type as the first set, the statement is
853 ## only prepped once.
855 my ($self, $table, $cols, $data) = @_;
857 @colvalues{@$cols} = (0..$#$cols);
858 my ($sql, @bind) = $self->sql_maker->insert($table, \%colvalues);
859 # print STDERR "BIND".Dumper(\@bind);
862 my @debug_bind = map { defined $_ ? qq{'$_'} : q{'NULL'} } @bind;
863 $self->debugobj->query_start($sql, @debug_bind);
865 my $sth = eval { $self->sth($sql,'insert') };
868 $self->throw_exception(
869 'no sth generated via sql (' . ($@ || $self->_dbh->errstr) . "): $sql"
872 # @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
875 ## This must be an arrayref, else nothing works!
876 my $tuple_status = [];
878 # print STDERR Dumper($data);
881 $rv = eval { $sth->execute_array({ ArrayTupleFetch => sub { my $values = shift @$data; return if !$values; return [ @{$values}[@bind] ]},
882 ArrayTupleStatus => $tuple_status }) };
883 # print STDERR Dumper($tuple_status);
884 # print STDERR "RV: $rv\n";
885 if ($@ || !defined $rv) {
887 foreach my $tuple (@$tuple_status)
889 $errors .= "\n" . $tuple->[1] if(ref $tuple);
891 $self->throw_exception("Error executing '$sql': ".($@ || $errors));
894 $self->throw_exception("'$sql' did not generate a statement.");
897 my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind;
898 $self->debugobj->query_end($sql, @debug_bind);
900 return (wantarray ? ($rv, $sth, @bind) : $rv);
904 return shift->_execute('update' => [], @_);
908 return shift->_execute('delete' => [], @_);
912 my ($self, $ident, $select, $condition, $attrs) = @_;
913 my $order = $attrs->{order_by};
914 if (ref $condition eq 'SCALAR') {
915 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
917 if (exists $attrs->{group_by} || $attrs->{having}) {
919 group_by => $attrs->{group_by},
920 having => $attrs->{having},
921 ($order ? (order_by => $order) : ())
924 my @args = ('select', $attrs->{bind}, $ident, $select, $condition, $order);
925 if ($attrs->{software_limit} ||
926 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
927 $attrs->{software_limit} = 1;
929 $self->throw_exception("rows attribute must be positive if present")
930 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
931 push @args, $attrs->{rows}, $attrs->{offset};
933 return $self->_execute(@args);
940 =item Arguments: $ident, $select, $condition, $attrs
944 Handle a SQL select statement.
950 my ($ident, $select, $condition, $attrs) = @_;
951 return $self->cursor->new($self, \@_, $attrs);
956 my ($rv, $sth, @bind) = $self->_select(@_);
957 my @row = $sth->fetchrow_array;
958 # Need to call finish() to work round broken DBDs
967 =item Arguments: $sql
971 Returns a L<DBI> sth (statement handle) for the supplied SQL.
976 my ($self, $dbh, $sql) = @_;
977 # 3 is the if_active parameter which avoids active sth re-use
978 $dbh->prepare_cached($sql, {}, 3) or
979 $self->throw_exception(
980 'no sth generated via sql (' . ($@ || $dbh->errstr) . "): $sql"
985 my ($self, $sql) = @_;
986 $self->dbh_do($self->can('_dbh_sth'), $sql);
989 sub _dbh_columns_info_for {
990 my ($self, $dbh, $table) = @_;
992 if ($dbh->can('column_info')) {
995 my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
996 my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
998 while ( my $info = $sth->fetchrow_hashref() ){
1000 $column_info{data_type} = $info->{TYPE_NAME};
1001 $column_info{size} = $info->{COLUMN_SIZE};
1002 $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
1003 $column_info{default_value} = $info->{COLUMN_DEF};
1004 my $col_name = $info->{COLUMN_NAME};
1005 $col_name =~ s/^\"(.*)\"$/$1/;
1007 $result{$col_name} = \%column_info;
1010 return \%result if !$@ && scalar keys %result;
1014 my $sth = $dbh->prepare("SELECT * FROM $table WHERE 1=0");
1016 my @columns = @{$sth->{NAME_lc}};
1017 for my $i ( 0 .. $#columns ){
1019 my $type_num = $sth->{TYPE}->[$i];
1021 if(defined $type_num && $dbh->can('type_info')) {
1022 my $type_info = $dbh->type_info($type_num);
1023 $type_name = $type_info->{TYPE_NAME} if $type_info;
1025 $column_info{data_type} = $type_name ? $type_name : $type_num;
1026 $column_info{size} = $sth->{PRECISION}->[$i];
1027 $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
1029 if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
1030 $column_info{data_type} = $1;
1031 $column_info{size} = $2;
1034 $result{$columns[$i]} = \%column_info;
1040 sub columns_info_for {
1041 my ($self, $table) = @_;
1042 $self->dbh_do($self->can('_dbh_columns_info_for'), $table);
1045 =head2 last_insert_id
1047 Return the row id of the last insert.
1051 sub _dbh_last_insert_id {
1052 my ($self, $dbh, $source, $col) = @_;
1053 # XXX This is a SQLite-ism as a default... is there a DBI-generic way?
1054 $dbh->func('last_insert_rowid');
1057 sub last_insert_id {
1059 $self->dbh_do($self->can('_dbh_last_insert_id'), @_);
1064 Returns the database driver name.
1068 sub sqlt_type { shift->dbh->{Driver}->{Name} }
1070 =head2 create_ddl_dir (EXPERIMENTAL)
1074 =item Arguments: $schema \@databases, $version, $directory, $sqlt_args
1078 Creates a SQL file based on the Schema, for each of the specified
1079 database types, in the given directory.
1081 Note that this feature is currently EXPERIMENTAL and may not work correctly
1082 across all databases, or fully handle complex relationships.
1088 my ($self, $schema, $databases, $version, $dir, $sqltargs) = @_;
1090 if(!$dir || !-d $dir)
1092 warn "No directory given, using ./\n";
1095 $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
1096 $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
1097 $version ||= $schema->VERSION || '1.x';
1098 $sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} };
1100 eval "use SQL::Translator";
1101 $self->throw_exception("Can't deploy without SQL::Translator: $@") if $@;
1103 my $sqlt = SQL::Translator->new($sqltargs);
1104 foreach my $db (@$databases)
1107 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
1108 # $sqlt->parser_args({'DBIx::Class' => $schema);
1109 $sqlt->data($schema);
1110 $sqlt->producer($db);
1113 my $filename = $schema->ddl_filename($db, $dir, $version);
1116 $self->throw_exception("$filename already exists, skipping $db");
1119 open($file, ">$filename")
1120 or $self->throw_exception("Can't open $filename for writing ($!)");
1121 my $output = $sqlt->translate;
1123 # print join(":", keys %{$schema->source_registrations});
1124 # print Dumper($sqlt->schema);
1127 $self->throw_exception("Failed to translate to $db. (" . $sqlt->error . ")");
1130 print $file $output;
1136 =head2 deployment_statements
1140 =item Arguments: $schema, $type, $version, $directory, $sqlt_args
1144 Returns the statements used by L</deploy> and L<DBIx::Class::Schema/deploy>.
1145 The database driver name is given by C<$type>, though the value from
1146 L</sqlt_type> is used if it is not specified.
1148 C<$directory> is used to return statements from files in a previously created
1149 L</create_ddl_dir> directory and is optional. The filenames are constructed
1150 from L<DBIx::Class::Schema/ddl_filename>, the schema name and the C<$version>.
1152 If no C<$directory> is specified then the statements are constructed on the
1153 fly using L<SQL::Translator> and C<$version> is ignored.
1155 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>.
1159 sub deployment_statements {
1160 my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
1161 # Need to be connected to get the correct sqlt_type
1162 $self->ensure_connected() unless $type;
1163 $type ||= $self->sqlt_type;
1164 $version ||= $schema->VERSION || '1.x';
1166 eval "use SQL::Translator";
1169 eval "use SQL::Translator::Parser::DBIx::Class;";
1170 $self->throw_exception($@) if $@;
1171 eval "use SQL::Translator::Producer::${type};";
1172 $self->throw_exception($@) if $@;
1173 my $tr = SQL::Translator->new(%$sqltargs);
1174 SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
1175 return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
1178 my $filename = $schema->ddl_filename($type, $dir, $version);
1181 # $schema->create_ddl_dir([ $type ], $version, $dir, $sqltargs);
1182 $self->throw_exception("No SQL::Translator, and no Schema file found, aborting deploy");
1186 open($file, "<$filename")
1187 or $self->throw_exception("Can't open $filename ($!)");
1191 return join('', @rows);
1196 my ($self, $schema, $type, $sqltargs, $dir) = @_;
1197 foreach my $statement ( $self->deployment_statements($schema, $type, undef, $dir, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
1198 for ( split(";\n", $statement)) {
1199 next if($_ =~ /^--/);
1201 # next if($_ =~ /^DROP/m);
1202 next if($_ =~ /^BEGIN TRANSACTION/m);
1203 next if($_ =~ /^COMMIT/m);
1204 next if $_ =~ /^\s+$/; # skip whitespace only
1205 $self->debugobj->query_start($_) if $self->debug;
1206 $self->dbh->do($_) or warn "SQL was:\n $_"; # XXX exceptions?
1207 $self->debugobj->query_end($_) if $self->debug;
1212 =head2 datetime_parser
1214 Returns the datetime parser class
1218 sub datetime_parser {
1220 return $self->{datetime_parser} ||= $self->build_datetime_parser(@_);
1223 =head2 datetime_parser_type
1225 Defines (returns) the datetime parser class - currently hardwired to
1226 L<DateTime::Format::MySQL>
1230 sub datetime_parser_type { "DateTime::Format::MySQL"; }
1232 =head2 build_datetime_parser
1234 See L</datetime_parser>
1238 sub build_datetime_parser {
1240 my $type = $self->datetime_parser_type(@_);
1242 $self->throw_exception("Couldn't load ${type}: $@") if $@;
1248 return if !$self->_dbh;
1257 The module defines a set of methods within the DBIC::SQL::Abstract
1258 namespace. These build on L<SQL::Abstract::Limit> to provide the
1259 SQL query functions.
1261 The following methods are extended:-
1275 See L</connect_info> for details.
1276 For setting, this method is deprecated in favor of L</connect_info>.
1280 See L</connect_info> for details.
1281 For setting, this method is deprecated in favor of L</connect_info>.
1285 See L</connect_info> for details.
1286 For setting, this method is deprecated in favor of L</connect_info>.
1292 Matt S. Trout <mst@shadowcatsystems.co.uk>
1294 Andy Grundman <andy@hybridized.org>
1298 You may distribute this code under the same terms as Perl itself.