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({});
307 $new->{_in_dbh_do} = 0;
314 The arguments of C<connect_info> are always a single array reference.
316 This is normally accessed via L<DBIx::Class::Schema/connection>, which
317 encapsulates its argument list in an arrayref before calling
318 C<connect_info> here.
320 The arrayref can either contain the same set of arguments one would
321 normally pass to L<DBI/connect>, or a lone code reference which returns
322 a connected database handle.
324 In either case, if the final argument in your connect_info happens
325 to be a hashref, C<connect_info> will look there for several
326 connection-specific options:
332 This can be set to an arrayref of literal sql statements, which will
333 be executed immediately after making the connection to the database
334 every time we [re-]connect.
338 Sets the limit dialect. This is useful for JDBC-bridge among others
339 where the remote SQL-dialect cannot be determined by the name of the
344 Specifies what characters to use to quote table and column names. If
345 you use this you will want to specify L<name_sep> as well.
347 quote_char expects either a single character, in which case is it is placed
348 on either side of the table/column, or an arrayref of length 2 in which case the
349 table/column name is placed between the elements.
351 For example under MySQL you'd use C<quote_char =E<gt> '`'>, and user SQL Server you'd
352 use C<quote_char =E<gt> [qw/[ ]/]>.
356 This only needs to be used in conjunction with L<quote_char>, and is used to
357 specify the charecter that seperates elements (schemas, tables, columns) from
358 each other. In most cases this is simply a C<.>.
362 These options can be mixed in with your other L<DBI> connection attributes,
363 or placed in a seperate hashref after all other normal L<DBI> connection
366 Every time C<connect_info> is invoked, any previous settings for
367 these options will be cleared before setting the new ones, regardless of
368 whether any options are specified in the new C<connect_info>.
370 Important note: DBIC expects the returned database handle provided by
371 a subref argument to have RaiseError set on it. If it doesn't, things
372 might not work very well, YMMV. If you don't use a subref, DBIC will
373 force this setting for you anyways. Setting HandleError to anything
374 other than simple exception object wrapper might cause problems too.
378 # Simple SQLite connection
379 ->connect_info([ 'dbi:SQLite:./foo.db' ]);
382 ->connect_info([ sub { DBI->connect(...) } ]);
384 # A bit more complicated
391 { quote_char => q{"}, name_sep => q{.} },
395 # Equivalent to the previous example
401 { AutoCommit => 0, quote_char => q{"}, name_sep => q{.} },
405 # Subref + DBIC-specific connection options
408 sub { DBI->connect(...) },
412 on_connect_do => ['SET search_path TO myschema,otherschema,public'],
420 my ($self, $info_arg) = @_;
422 return $self->_connect_info if !$info_arg;
424 # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
425 # the new set of options
426 $self->_sql_maker(undef);
427 $self->_sql_maker_opts({});
429 my $info = [ @$info_arg ]; # copy because we can alter it
430 my $last_info = $info->[-1];
431 if(ref $last_info eq 'HASH') {
432 if(my $on_connect_do = delete $last_info->{on_connect_do}) {
433 $self->on_connect_do($on_connect_do);
435 for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
436 if(my $opt_val = delete $last_info->{$sql_maker_opt}) {
437 $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
441 # Get rid of any trailing empty hashref
442 pop(@$info) if !keys %$last_info;
445 $self->_connect_info($info);
450 This method is deprecated in favor of setting via L</connect_info>.
454 Arguments: $subref, @extra_coderef_args?
456 Execute the given subref using the new exception-based connection management.
458 The first two arguments will be the storage object that C<dbh_do> was called
459 on and a database handle to use. Any additional arguments will be passed
460 verbatim to the called subref as arguments 2 and onwards.
462 Using this (instead of $self->_dbh or $self->dbh) ensures correct
463 exception handling and reconnection (or failover in future subclasses).
465 Your subref should have no side-effects outside of the database, as
466 there is the potential for your subref to be partially double-executed
467 if the database connection was stale/dysfunctional.
471 my @stuff = $schema->storage->dbh_do(
473 my ($storage, $dbh, @cols) = @_;
474 my $cols = join(q{, }, @cols);
475 $dbh->selectrow_array("SELECT $cols FROM foo");
486 ref $coderef eq 'CODE' or $self->throw_exception
487 ('$coderef must be a CODE reference');
489 return $coderef->($self, $self->_dbh, @_) if $self->{_in_dbh_do};
490 local $self->{_in_dbh_do} = 1;
493 my $want_array = wantarray;
496 $self->_verify_pid if $self->_dbh;
497 $self->_populate_dbh if !$self->_dbh;
499 @result = $coderef->($self, $self->_dbh, @_);
501 elsif(defined $want_array) {
502 $result[0] = $coderef->($self, $self->_dbh, @_);
505 $coderef->($self, $self->_dbh, @_);
510 if(!$exception) { return $want_array ? @result : $result[0] }
512 $self->throw_exception($exception) if $self->connected;
514 # We were not connected - reconnect and retry, but let any
515 # exception fall right through this time
516 $self->_populate_dbh;
517 $coderef->($self, $self->_dbh, @_);
520 # This is basically a blend of dbh_do above and DBIx::Class::Storage::txn_do.
521 # It also informs dbh_do to bypass itself while under the direction of txn_do,
522 # via $self->{_in_dbh_do} (this saves some redundant eval and errorcheck, etc)
527 ref $coderef eq 'CODE' or $self->throw_exception
528 ('$coderef must be a CODE reference');
530 local $self->{_in_dbh_do} = 1;
533 my $want_array = wantarray;
538 $self->_verify_pid if $self->_dbh;
539 $self->_populate_dbh if !$self->_dbh;
543 @result = $coderef->(@_);
545 elsif(defined $want_array) {
546 $result[0] = $coderef->(@_);
555 if(!$exception) { return $want_array ? @result : $result[0] }
557 if($tried++ > 0 || $self->connected) {
558 eval { $self->txn_rollback };
559 my $rollback_exception = $@;
560 if($rollback_exception) {
561 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
562 $self->throw_exception($exception) # propagate nested rollback
563 if $rollback_exception =~ /$exception_class/;
565 $self->throw_exception(
566 "Transaction aborted: ${exception}. "
567 . "Rollback failed: ${rollback_exception}"
570 $self->throw_exception($exception)
573 # We were not connected, and was first try - reconnect and retry
575 $self->_populate_dbh;
581 Our C<disconnect> method also performs a rollback first if the
582 database is not in C<AutoCommit> mode.
589 if( $self->connected ) {
590 $self->_dbh->rollback unless $self->_dbh->{AutoCommit};
591 $self->_dbh->disconnect;
599 if(my $dbh = $self->_dbh) {
600 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
601 return $self->_dbh(undef);
606 return ($dbh->FETCH('Active') && $dbh->ping);
612 # handle pid changes correctly
613 # NOTE: assumes $self->_dbh is a valid $dbh
617 return if $self->_conn_pid == $$;
619 $self->_dbh->{InactiveDestroy} = 1;
625 sub ensure_connected {
628 unless ($self->connected) {
629 $self->_populate_dbh;
635 Returns the dbh - a data base handle of class L<DBI>.
642 $self->ensure_connected;
646 sub _sql_maker_args {
649 return ( limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
654 unless ($self->_sql_maker) {
655 $self->_sql_maker(new DBIC::SQL::Abstract( $self->_sql_maker_args ));
657 return $self->_sql_maker;
662 my @info = @{$self->_connect_info || []};
663 $self->_dbh($self->_connect(@info));
665 if(ref $self eq 'DBIx::Class::Storage::DBI') {
666 my $driver = $self->_dbh->{Driver}->{Name};
667 if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
668 bless $self, "DBIx::Class::Storage::DBI::${driver}";
669 $self->_rebless() if $self->can('_rebless');
673 # if on-connect sql statements are given execute them
674 foreach my $sql_statement (@{$self->on_connect_do || []}) {
675 $self->debugobj->query_start($sql_statement) if $self->debug();
676 $self->_dbh->do($sql_statement);
677 $self->debugobj->query_end($sql_statement) if $self->debug();
680 $self->_conn_pid($$);
681 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
685 my ($self, @info) = @_;
687 $self->throw_exception("You failed to provide any connection info")
690 my ($old_connect_via, $dbh);
692 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
693 $old_connect_via = $DBI::connect_via;
694 $DBI::connect_via = 'connect';
698 if(ref $info[0] eq 'CODE') {
702 $dbh = DBI->connect(@info);
703 $dbh->{RaiseError} = 1;
704 $dbh->{PrintError} = 0;
705 $dbh->{PrintWarn} = 0;
709 $DBI::connect_via = $old_connect_via if $old_connect_via;
712 $self->throw_exception("DBI Connection failed: " . ($@ || $DBI::errstr));
719 my ($self, $dbh) = @_;
720 if ($dbh->{AutoCommit}) {
721 $self->debugobj->txn_begin()
729 $self->dbh_do($self->can('_dbh_txn_begin'))
730 if $self->{transaction_depth}++ == 0;
733 sub _dbh_txn_commit {
734 my ($self, $dbh) = @_;
735 if ($self->{transaction_depth} == 0) {
736 unless ($dbh->{AutoCommit}) {
737 $self->debugobj->txn_commit()
743 if (--$self->{transaction_depth} == 0) {
744 $self->debugobj->txn_commit()
753 $self->dbh_do($self->can('_dbh_txn_commit'));
756 sub _dbh_txn_rollback {
757 my ($self, $dbh) = @_;
758 if ($self->{transaction_depth} == 0) {
759 unless ($dbh->{AutoCommit}) {
760 $self->debugobj->txn_rollback()
766 if (--$self->{transaction_depth} == 0) {
767 $self->debugobj->txn_rollback()
772 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
780 eval { $self->dbh_do($self->can('_dbh_txn_rollback')) };
783 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
784 $error =~ /$exception_class/ and $self->throw_exception($error);
785 $self->{transaction_depth} = 0; # ensure that a failed rollback
786 $self->throw_exception($error); # resets the transaction depth
790 # This used to be the top-half of _execute. It was split out to make it
791 # easier to override in NoBindVars without duping the rest. It takes up
792 # all of _execute's args, and emits $sql, @bind.
793 sub _prep_for_execute {
794 my ($self, $op, $extra_bind, $ident, @args) = @_;
796 my ($sql, @bind) = $self->sql_maker->$op($ident, @args);
797 unshift(@bind, @$extra_bind) if $extra_bind;
798 @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
800 return ($sql, @bind);
806 my ($sql, @bind) = $self->_prep_for_execute(@_);
809 my @debug_bind = map { defined $_ ? qq{'$_'} : q{'NULL'} } @bind;
810 $self->debugobj->query_start($sql, @debug_bind);
813 my $sth = $self->sth($sql);
818 $rv = eval { $sth->execute(@bind) };
821 $self->throw_exception("Error executing '$sql': ".($@ || $sth->errstr));
824 $self->throw_exception("'$sql' did not generate a statement.");
827 my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind;
828 $self->debugobj->query_end($sql, @debug_bind);
830 return (wantarray ? ($rv, $sth, @bind) : $rv);
834 my ($self, $ident, $to_insert) = @_;
835 $self->throw_exception(
836 "Couldn't insert ".join(', ',
837 map "$_ => $to_insert->{$_}", keys %$to_insert
839 ) unless ($self->_execute('insert' => [], $ident, $to_insert));
844 return shift->_execute('update' => [], @_);
848 return shift->_execute('delete' => [], @_);
852 my ($self, $ident, $select, $condition, $attrs) = @_;
853 my $order = $attrs->{order_by};
854 if (ref $condition eq 'SCALAR') {
855 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
857 if (exists $attrs->{group_by} || $attrs->{having}) {
859 group_by => $attrs->{group_by},
860 having => $attrs->{having},
861 ($order ? (order_by => $order) : ())
864 my @args = ('select', $attrs->{bind}, $ident, $select, $condition, $order);
865 if ($attrs->{software_limit} ||
866 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
867 $attrs->{software_limit} = 1;
869 $self->throw_exception("rows attribute must be positive if present")
870 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
871 push @args, $attrs->{rows}, $attrs->{offset};
873 return $self->_execute(@args);
880 =item Arguments: $ident, $select, $condition, $attrs
884 Handle a SQL select statement.
890 my ($ident, $select, $condition, $attrs) = @_;
891 return $self->cursor->new($self, \@_, $attrs);
896 my ($rv, $sth, @bind) = $self->_select(@_);
897 my @row = $sth->fetchrow_array;
898 # Need to call finish() to work round broken DBDs
907 =item Arguments: $sql
911 Returns a L<DBI> sth (statement handle) for the supplied SQL.
916 my ($self, $dbh, $sql) = @_;
917 # 3 is the if_active parameter which avoids active sth re-use
918 $dbh->prepare_cached($sql, {}, 3) or
919 $self->throw_exception(
920 'no sth generated via sql (' . ($@ || $dbh->errstr) . "): $sql"
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.