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
62 my ($self, $syntax) = @_;
63 my $dbhname = ref $syntax eq 'HASH' ? $syntax->{Driver}{Name} : '';
64 if(ref($self) && $dbhname && $dbhname eq 'DB2') {
65 return 'RowNumberOver';
68 $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
72 my ($self, $table, $fields, $where, $order, @rest) = @_;
73 $table = $self->_quote($table) unless ref($table);
74 local $self->{rownum_hack_count} = 1
75 if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
76 @rest = (-1) unless defined $rest[0];
77 die "LIMIT 0 Does Not Compute" if $rest[0] == 0;
78 # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
79 local $self->{having_bind} = [];
80 my ($sql, @ret) = $self->SUPER::select(
81 $table, $self->_recurse_fields($fields), $where, $order, @rest
83 return wantarray ? ($sql, @ret, @{$self->{having_bind}}) : $sql;
89 $table = $self->_quote($table) unless ref($table);
90 $self->SUPER::insert($table, @_);
96 $table = $self->_quote($table) unless ref($table);
97 $self->SUPER::update($table, @_);
103 $table = $self->_quote($table) unless ref($table);
104 $self->SUPER::delete($table, @_);
110 return $_[1].$self->_order_by($_[2]);
112 return $self->SUPER::_emulate_limit(@_);
116 sub _recurse_fields {
117 my ($self, $fields) = @_;
118 my $ref = ref $fields;
119 return $self->_quote($fields) unless $ref;
120 return $$fields if $ref eq 'SCALAR';
122 if ($ref eq 'ARRAY') {
123 return join(', ', map {
124 $self->_recurse_fields($_)
125 .(exists $self->{rownum_hack_count}
126 ? ' AS col'.$self->{rownum_hack_count}++
129 } elsif ($ref eq 'HASH') {
130 foreach my $func (keys %$fields) {
131 return $self->_sqlcase($func)
132 .'( '.$self->_recurse_fields($fields->{$func}).' )';
141 if (ref $_[0] eq 'HASH') {
142 if (defined $_[0]->{group_by}) {
143 $ret = $self->_sqlcase(' group by ')
144 .$self->_recurse_fields($_[0]->{group_by});
146 if (defined $_[0]->{having}) {
148 ($frag, @extra) = $self->_recurse_where($_[0]->{having});
149 push(@{$self->{having_bind}}, @extra);
150 $ret .= $self->_sqlcase(' having ').$frag;
152 if (defined $_[0]->{order_by}) {
153 $ret .= $self->_order_by($_[0]->{order_by});
155 } elsif (ref $_[0] eq 'SCALAR') {
156 $ret = $self->_sqlcase(' order by ').${ $_[0] };
157 } elsif (ref $_[0] eq 'ARRAY' && @{$_[0]}) {
158 my @order = @{+shift};
159 $ret = $self->_sqlcase(' order by ')
161 my $r = $self->_order_by($_, @_);
162 $r =~ s/^ ?ORDER BY //i;
166 $ret = $self->SUPER::_order_by(@_);
171 sub _order_directions {
172 my ($self, $order) = @_;
173 $order = $order->{order_by} if ref $order eq 'HASH';
174 return $self->SUPER::_order_directions($order);
178 my ($self, $from) = @_;
179 if (ref $from eq 'ARRAY') {
180 return $self->_recurse_from(@$from);
181 } elsif (ref $from eq 'HASH') {
182 return $self->_make_as($from);
184 return $from; # would love to quote here but _table ends up getting called
185 # twice during an ->select without a limit clause due to
186 # the way S::A::Limit->select works. should maybe consider
187 # bypassing this and doing S::A::select($self, ...) in
188 # our select method above. meantime, quoting shims have
189 # been added to select/insert/update/delete here
194 my ($self, $from, @join) = @_;
196 push(@sqlf, $self->_make_as($from));
197 foreach my $j (@join) {
200 # check whether a join type exists
201 my $join_clause = '';
202 my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
203 if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
204 $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
206 $join_clause = ' JOIN ';
208 push(@sqlf, $join_clause);
210 if (ref $to eq 'ARRAY') {
211 push(@sqlf, '(', $self->_recurse_from(@$to), ')');
213 push(@sqlf, $self->_make_as($to));
215 push(@sqlf, ' ON ', $self->_join_condition($on));
217 return join('', @sqlf);
221 my ($self, $from) = @_;
222 return join(' ', map { (ref $_ eq 'SCALAR' ? $$_ : $self->_quote($_)) }
223 reverse each %{$self->_skip_options($from)});
227 my ($self, $hash) = @_;
229 $clean_hash->{$_} = $hash->{$_}
230 for grep {!/^-/} keys %$hash;
234 sub _join_condition {
235 my ($self, $cond) = @_;
236 if (ref $cond eq 'HASH') {
239 my $x = '= '.$self->_quote($cond->{$_}); $j{$_} = \$x;
241 return $self->_recurse_where(\%j);
242 } elsif (ref $cond eq 'ARRAY') {
243 return join(' OR ', map { $self->_join_condition($_) } @$cond);
245 die "Can't handle this yet!";
250 my ($self, $label) = @_;
251 return '' unless defined $label;
252 return "*" if $label eq '*';
253 return $label unless $self->{quote_char};
254 if(ref $self->{quote_char} eq "ARRAY"){
255 return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
256 if !defined $self->{name_sep};
257 my $sep = $self->{name_sep};
258 return join($self->{name_sep},
259 map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
260 split(/\Q$sep\E/,$label));
262 return $self->SUPER::_quote($label);
267 $self->{limit_dialect} = shift if @_;
268 return $self->{limit_dialect};
273 $self->{quote_char} = shift if @_;
274 return $self->{quote_char};
279 $self->{name_sep} = shift if @_;
280 return $self->{name_sep};
283 } # End of BEGIN block
287 DBIx::Class::Storage::DBI - DBI storage handler
293 This class represents the connection to an RDBMS via L<DBI>. See
294 L<DBIx::Class::Storage> for general information. This pod only
295 documents DBI-specific methods and behaviors.
302 my $new = shift->next::method(@_);
304 $new->cursor("DBIx::Class::Storage::DBI::Cursor");
305 $new->transaction_depth(0);
306 $new->_sql_maker_opts({});
313 The arguments of C<connect_info> are always a single array reference.
315 This is normally accessed via L<DBIx::Class::Schema/connection>, which
316 encapsulates its argument list in an arrayref before calling
317 C<connect_info> here.
319 The arrayref can either contain the same set of arguments one would
320 normally pass to L<DBI/connect>, or a lone code reference which returns
321 a connected database handle.
323 In either case, if the final argument in your connect_info happens
324 to be a hashref, C<connect_info> will look there for several
325 connection-specific options:
331 This can be set to an arrayref of literal sql statements, which will
332 be executed immediately after making the connection to the database
333 every time we [re-]connect.
337 Sets the limit dialect. This is useful for JDBC-bridge among others
338 where the remote SQL-dialect cannot be determined by the name of the
343 Specifies what characters to use to quote table and column names. If
344 you use this you will want to specify L<name_sep> as well.
346 quote_char expects either a single character, in which case is it is placed
347 on either side of the table/column, or an arrayref of length 2 in which case the
348 table/column name is placed between the elements.
350 For example under MySQL you'd use C<quote_char =E<gt> '`'>, and user SQL Server you'd
351 use C<quote_char =E<gt> [qw/[ ]/]>.
355 This only needs to be used in conjunction with L<quote_char>, and is used to
356 specify the charecter that seperates elements (schemas, tables, columns) from
357 each other. In most cases this is simply a C<.>.
361 These options can be mixed in with your other L<DBI> connection attributes,
362 or placed in a seperate hashref after all other normal L<DBI> connection
365 Every time C<connect_info> is invoked, any previous settings for
366 these options will be cleared before setting the new ones, regardless of
367 whether any options are specified in the new C<connect_info>.
369 Important note: DBIC expects the returned database handle provided by
370 a subref argument to have RaiseError set on it. If it doesn't, things
371 might not work very well, YMMV. If you don't use a subref, DBIC will
372 force this setting for you anyways. Setting HandleError to anything
373 other than simple exception object wrapper might cause problems too.
377 # Simple SQLite connection
378 ->connect_info([ 'dbi:SQLite:./foo.db' ]);
381 ->connect_info([ sub { DBI->connect(...) } ]);
383 # A bit more complicated
390 { quote_char => q{"}, name_sep => q{.} },
394 # Equivalent to the previous example
400 { AutoCommit => 0, quote_char => q{"}, name_sep => q{.} },
404 # Subref + DBIC-specific connection options
407 sub { DBI->connect(...) },
411 on_connect_do => ['SET search_path TO myschema,otherschema,public'],
419 my ($self, $info_arg) = @_;
421 return $self->_connect_info if !$info_arg;
423 # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
424 # the new set of options
425 $self->_sql_maker(undef);
426 $self->_sql_maker_opts({});
428 my $info = [ @$info_arg ]; # copy because we can alter it
429 my $last_info = $info->[-1];
430 if(ref $last_info eq 'HASH') {
431 if(my $on_connect_do = delete $last_info->{on_connect_do}) {
432 $self->on_connect_do($on_connect_do);
434 for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
435 if(my $opt_val = delete $last_info->{$sql_maker_opt}) {
436 $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
440 # Get rid of any trailing empty hashref
441 pop(@$info) if !keys %$last_info;
444 $self->_connect_info($info);
449 This method is deprecated in favor of setting via L</connect_info>.
453 Arguments: $subref, @extra_coderef_args?
455 Execute the given subref using the new exception-based connection management.
457 The first two arguments will be the storage object that C<dbh_do> was called
458 on and a database handle to use. Any additional arguments will be passed
459 verbatim to the called subref as arguments 2 and onwards.
461 Using this (instead of $self->_dbh or $self->dbh) ensures correct
462 exception handling and reconnection (or failover in future subclasses).
464 Your subref should have no side-effects outside of the database, as
465 there is the potential for your subref to be partially double-executed
466 if the database connection was stale/dysfunctional.
470 my @stuff = $schema->storage->dbh_do(
472 my ($storage, $dbh, @cols) = @_;
473 my $cols = join(q{, }, @cols);
474 $dbh->selectrow_array("SELECT $cols FROM foo");
485 return $coderef->($self, $self->_dbh, @_) if $self->{_in_txn_do};
487 ref $coderef eq 'CODE' or $self->throw_exception
488 ('$coderef must be a CODE reference');
491 my $want_array = wantarray;
494 $self->_verify_pid if $self->_dbh;
495 $self->_populate_dbh if !$self->_dbh;
497 @result = $coderef->($self, $self->_dbh, @_);
499 elsif(defined $want_array) {
500 $result[0] = $coderef->($self, $self->_dbh, @_);
503 $coderef->($self, $self->_dbh, @_);
508 if(!$exception) { return $want_array ? @result : $result[0] }
510 $self->throw_exception($exception) if $self->connected;
512 # We were not connected - reconnect and retry, but let any
513 # exception fall right through this time
514 $self->_populate_dbh;
515 $coderef->($self, $self->_dbh, @_);
518 # This is basically a blend of dbh_do above and DBIx::Class::Storage::txn_do.
519 # It also informs dbh_do to bypass itself while under the direction of txn_do,
520 # via $self->{_in_txn_do} (this saves some redundant eval and errorcheck, etc)
525 ref $coderef eq 'CODE' or $self->throw_exception
526 ('$coderef must be a CODE reference');
528 local $self->{_in_txn_do} = 1;
531 my $want_array = wantarray;
536 $self->_verify_pid if $self->_dbh;
537 $self->_populate_dbh if !$self->_dbh;
541 @result = $coderef->(@_);
543 elsif(defined $want_array) {
544 $result[0] = $coderef->(@_);
553 if(!$exception) { return $want_array ? @result : $result[0] }
555 if($tried++ > 0 || $self->connected) {
556 eval { $self->txn_rollback };
557 my $rollback_exception = $@;
558 if($rollback_exception) {
559 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
560 $self->throw_exception($exception) # propagate nested rollback
561 if $rollback_exception =~ /$exception_class/;
563 $self->throw_exception(
564 "Transaction aborted: ${exception}. "
565 . "Rollback failed: ${rollback_exception}"
568 $self->throw_exception($exception)
571 # We were not connected, and was first try - reconnect and retry
573 $self->_populate_dbh;
579 Our C<disconnect> method also performs a rollback first if the
580 database is not in C<AutoCommit> mode.
587 if( $self->connected ) {
588 $self->_dbh->rollback unless $self->_dbh->{AutoCommit};
589 $self->_dbh->disconnect;
597 if(my $dbh = $self->_dbh) {
598 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
599 return $self->_dbh(undef);
604 return ($dbh->FETCH('Active') && $dbh->ping);
610 # handle pid changes correctly
611 # NOTE: assumes $self->_dbh is a valid $dbh
615 return if $self->_conn_pid == $$;
617 $self->_dbh->{InactiveDestroy} = 1;
623 sub ensure_connected {
626 unless ($self->connected) {
627 $self->_populate_dbh;
633 Returns the dbh - a data base handle of class L<DBI>.
640 $self->ensure_connected;
644 sub _sql_maker_args {
647 return ( limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
652 unless ($self->_sql_maker) {
653 $self->_sql_maker(new DBIC::SQL::Abstract( $self->_sql_maker_args ));
655 return $self->_sql_maker;
660 my @info = @{$self->_connect_info || []};
661 $self->_dbh($self->_connect(@info));
663 if(ref $self eq 'DBIx::Class::Storage::DBI') {
664 my $driver = $self->_dbh->{Driver}->{Name};
665 if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
666 bless $self, "DBIx::Class::Storage::DBI::${driver}";
667 $self->_rebless() if $self->can('_rebless');
671 # if on-connect sql statements are given execute them
672 foreach my $sql_statement (@{$self->on_connect_do || []}) {
673 $self->debugobj->query_start($sql_statement) if $self->debug();
674 $self->_dbh->do($sql_statement);
675 $self->debugobj->query_end($sql_statement) if $self->debug();
678 $self->_conn_pid($$);
679 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
683 my ($self, @info) = @_;
685 $self->throw_exception("You failed to provide any connection info")
688 my ($old_connect_via, $dbh);
690 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
691 $old_connect_via = $DBI::connect_via;
692 $DBI::connect_via = 'connect';
696 if(ref $info[0] eq 'CODE') {
700 $dbh = DBI->connect(@info);
701 $dbh->{RaiseError} = 1;
702 $dbh->{PrintError} = 0;
706 $DBI::connect_via = $old_connect_via if $old_connect_via;
709 $self->throw_exception("DBI Connection failed: " . ($@ || $DBI::errstr));
716 my ($self, $dbh) = @_;
717 if ($dbh->{AutoCommit}) {
718 $self->debugobj->txn_begin()
726 $self->dbh_do($self->can('_dbh_txn_begin'))
727 if $self->{transaction_depth}++ == 0;
730 sub _dbh_txn_commit {
731 my ($self, $dbh) = @_;
732 if ($self->{transaction_depth} == 0) {
733 unless ($dbh->{AutoCommit}) {
734 $self->debugobj->txn_commit()
740 if (--$self->{transaction_depth} == 0) {
741 $self->debugobj->txn_commit()
750 $self->dbh_do($self->can('_dbh_txn_commit'));
753 sub _dbh_txn_rollback {
754 my ($self, $dbh) = @_;
755 if ($self->{transaction_depth} == 0) {
756 unless ($dbh->{AutoCommit}) {
757 $self->debugobj->txn_rollback()
763 if (--$self->{transaction_depth} == 0) {
764 $self->debugobj->txn_rollback()
769 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
777 eval { $self->dbh_do($self->can('_dbh_txn_rollback')) };
780 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
781 $error =~ /$exception_class/ and $self->throw_exception($error);
782 $self->{transaction_depth} = 0; # ensure that a failed rollback
783 $self->throw_exception($error); # resets the transaction depth
787 # This used to be the top-half of _execute. It was split out to make it
788 # easier to override in NoBindVars without duping the rest. It takes up
789 # all of _execute's args, and emits $sql, @bind.
790 sub _prep_for_execute {
791 my ($self, $op, $extra_bind, $ident, @args) = @_;
793 my ($sql, @bind) = $self->sql_maker->$op($ident, @args);
794 unshift(@bind, @$extra_bind) if $extra_bind;
795 @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
797 return ($sql, @bind);
803 my ($sql, @bind) = $self->_prep_for_execute(@_);
806 my @debug_bind = map { defined $_ ? qq{'$_'} : q{'NULL'} } @bind;
807 $self->debugobj->query_start($sql, @debug_bind);
810 my $sth = eval { $self->sth($sql) };
813 $self->throw_exception(
814 'no sth generated via sql (' . ($@ || $self->_dbh->errstr) . "): $sql"
821 $rv = eval { $sth->execute(@bind) };
824 $self->throw_exception("Error executing '$sql': ".($@ || $sth->errstr));
827 $self->throw_exception("'$sql' did not generate a statement.");
830 my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind;
831 $self->debugobj->query_end($sql, @debug_bind);
833 return (wantarray ? ($rv, $sth, @bind) : $rv);
837 my ($self, $ident, $to_insert) = @_;
838 $self->throw_exception(
839 "Couldn't insert ".join(', ',
840 map "$_ => $to_insert->{$_}", keys %$to_insert
842 ) unless ($self->_execute('insert' => [], $ident, $to_insert));
847 return shift->_execute('update' => [], @_);
851 return shift->_execute('delete' => [], @_);
855 my ($self, $ident, $select, $condition, $attrs) = @_;
856 my $order = $attrs->{order_by};
857 if (ref $condition eq 'SCALAR') {
858 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
860 if (exists $attrs->{group_by} || $attrs->{having}) {
862 group_by => $attrs->{group_by},
863 having => $attrs->{having},
864 ($order ? (order_by => $order) : ())
867 my @args = ('select', $attrs->{bind}, $ident, $select, $condition, $order);
868 if ($attrs->{software_limit} ||
869 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
870 $attrs->{software_limit} = 1;
872 $self->throw_exception("rows attribute must be positive if present")
873 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
874 push @args, $attrs->{rows}, $attrs->{offset};
876 return $self->_execute(@args);
883 =item Arguments: $ident, $select, $condition, $attrs
887 Handle a SQL select statement.
893 my ($ident, $select, $condition, $attrs) = @_;
894 return $self->cursor->new($self, \@_, $attrs);
899 my ($rv, $sth, @bind) = $self->_select(@_);
900 my @row = $sth->fetchrow_array;
901 # Need to call finish() to work round broken DBDs
910 =item Arguments: $sql
914 Returns a L<DBI> sth (statement handle) for the supplied SQL.
919 my ($self, $dbh, $sql) = @_;
920 # 3 is the if_active parameter which avoids active sth re-use
921 $dbh->prepare_cached($sql, {}, 3);
925 my ($self, $sql) = @_;
926 $self->dbh_do($self->can('_dbh_sth'), $sql);
929 sub _dbh_columns_info_for {
930 my ($self, $dbh, $table) = @_;
932 if ($dbh->can('column_info')) {
935 my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
936 my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
938 while ( my $info = $sth->fetchrow_hashref() ){
940 $column_info{data_type} = $info->{TYPE_NAME};
941 $column_info{size} = $info->{COLUMN_SIZE};
942 $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
943 $column_info{default_value} = $info->{COLUMN_DEF};
944 my $col_name = $info->{COLUMN_NAME};
945 $col_name =~ s/^\"(.*)\"$/$1/;
947 $result{$col_name} = \%column_info;
950 return \%result if !$@ && scalar keys %result;
954 my $sth = $dbh->prepare("SELECT * FROM $table WHERE 1=0");
956 my @columns = @{$sth->{NAME_lc}};
957 for my $i ( 0 .. $#columns ){
959 my $type_num = $sth->{TYPE}->[$i];
961 if(defined $type_num && $dbh->can('type_info')) {
962 my $type_info = $dbh->type_info($type_num);
963 $type_name = $type_info->{TYPE_NAME} if $type_info;
965 $column_info{data_type} = $type_name ? $type_name : $type_num;
966 $column_info{size} = $sth->{PRECISION}->[$i];
967 $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
969 if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
970 $column_info{data_type} = $1;
971 $column_info{size} = $2;
974 $result{$columns[$i]} = \%column_info;
980 sub columns_info_for {
981 my ($self, $table) = @_;
982 $self->dbh_do($self->can('_dbh_columns_info_for'), $table);
985 =head2 last_insert_id
987 Return the row id of the last insert.
991 sub _dbh_last_insert_id {
992 my ($self, $dbh, $source, $col) = @_;
993 # XXX This is a SQLite-ism as a default... is there a DBI-generic way?
994 $dbh->func('last_insert_rowid');
999 $self->dbh_do($self->can('_dbh_last_insert_id'), @_);
1004 Returns the database driver name.
1008 sub sqlt_type { shift->dbh->{Driver}->{Name} }
1010 =head2 create_ddl_dir (EXPERIMENTAL)
1014 =item Arguments: $schema \@databases, $version, $directory, $sqlt_args
1018 Creates a SQL file based on the Schema, for each of the specified
1019 database types, in the given directory.
1021 Note that this feature is currently EXPERIMENTAL and may not work correctly
1022 across all databases, or fully handle complex relationships.
1028 my ($self, $schema, $databases, $version, $dir, $sqltargs) = @_;
1030 if(!$dir || !-d $dir)
1032 warn "No directory given, using ./\n";
1035 $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
1036 $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
1037 $version ||= $schema->VERSION || '1.x';
1038 $sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} };
1040 eval "use SQL::Translator";
1041 $self->throw_exception("Can't deploy without SQL::Translator: $@") if $@;
1043 my $sqlt = SQL::Translator->new($sqltargs);
1044 foreach my $db (@$databases)
1047 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
1048 # $sqlt->parser_args({'DBIx::Class' => $schema);
1049 $sqlt->data($schema);
1050 $sqlt->producer($db);
1053 my $filename = $schema->ddl_filename($db, $dir, $version);
1056 $self->throw_exception("$filename already exists, skipping $db");
1059 open($file, ">$filename")
1060 or $self->throw_exception("Can't open $filename for writing ($!)");
1061 my $output = $sqlt->translate;
1063 # print join(":", keys %{$schema->source_registrations});
1064 # print Dumper($sqlt->schema);
1067 $self->throw_exception("Failed to translate to $db. (" . $sqlt->error . ")");
1070 print $file $output;
1076 =head2 deployment_statements
1080 =item Arguments: $schema, $type, $version, $directory, $sqlt_args
1084 Returns the statements used by L</deploy> and L<DBIx::Class::Schema/deploy>.
1085 The database driver name is given by C<$type>, though the value from
1086 L</sqlt_type> is used if it is not specified.
1088 C<$directory> is used to return statements from files in a previously created
1089 L</create_ddl_dir> directory and is optional. The filenames are constructed
1090 from L<DBIx::Class::Schema/ddl_filename>, the schema name and the C<$version>.
1092 If no C<$directory> is specified then the statements are constructed on the
1093 fly using L<SQL::Translator> and C<$version> is ignored.
1095 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>.
1099 sub deployment_statements {
1100 my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
1101 # Need to be connected to get the correct sqlt_type
1102 $self->ensure_connected() unless $type;
1103 $type ||= $self->sqlt_type;
1104 $version ||= $schema->VERSION || '1.x';
1106 eval "use SQL::Translator";
1109 eval "use SQL::Translator::Parser::DBIx::Class;";
1110 $self->throw_exception($@) if $@;
1111 eval "use SQL::Translator::Producer::${type};";
1112 $self->throw_exception($@) if $@;
1113 my $tr = SQL::Translator->new(%$sqltargs);
1114 SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
1115 return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
1118 my $filename = $schema->ddl_filename($type, $dir, $version);
1121 # $schema->create_ddl_dir([ $type ], $version, $dir, $sqltargs);
1122 $self->throw_exception("No SQL::Translator, and no Schema file found, aborting deploy");
1126 open($file, "<$filename")
1127 or $self->throw_exception("Can't open $filename ($!)");
1131 return join('', @rows);
1136 my ($self, $schema, $type, $sqltargs, $dir) = @_;
1137 foreach my $statement ( $self->deployment_statements($schema, $type, undef, $dir, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
1138 for ( split(";\n", $statement)) {
1139 next if($_ =~ /^--/);
1141 # next if($_ =~ /^DROP/m);
1142 next if($_ =~ /^BEGIN TRANSACTION/m);
1143 next if($_ =~ /^COMMIT/m);
1144 next if $_ =~ /^\s+$/; # skip whitespace only
1145 $self->debugobj->query_start($_) if $self->debug;
1146 $self->dbh->do($_) or warn "SQL was:\n $_"; # XXX exceptions?
1147 $self->debugobj->query_end($_) if $self->debug;
1152 =head2 datetime_parser
1154 Returns the datetime parser class
1158 sub datetime_parser {
1160 return $self->{datetime_parser} ||= $self->build_datetime_parser(@_);
1163 =head2 datetime_parser_type
1165 Defines (returns) the datetime parser class - currently hardwired to
1166 L<DateTime::Format::MySQL>
1170 sub datetime_parser_type { "DateTime::Format::MySQL"; }
1172 =head2 build_datetime_parser
1174 See L</datetime_parser>
1178 sub build_datetime_parser {
1180 my $type = $self->datetime_parser_type(@_);
1182 $self->throw_exception("Couldn't load ${type}: $@") if $@;
1188 return if !$self->_dbh;
1197 The module defines a set of methods within the DBIC::SQL::Abstract
1198 namespace. These build on L<SQL::Abstract::Limit> to provide the
1199 SQL query functions.
1201 The following methods are extended:-
1215 See L</connect_info> for details.
1216 For setting, this method is deprecated in favor of L</connect_info>.
1220 See L</connect_info> for details.
1221 For setting, this method is deprecated in favor of L</connect_info>.
1225 See L</connect_info> for details.
1226 For setting, this method is deprecated in favor of L</connect_info>.
1232 Matt S. Trout <mst@shadowcatsystems.co.uk>
1234 Andy Grundman <andy@hybridized.org>
1238 You may distribute this code under the same terms as Perl itself.