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;
308 $new->{_dbh_gen} = 0;
315 The arguments of C<connect_info> are always a single array reference.
317 This is normally accessed via L<DBIx::Class::Schema/connection>, which
318 encapsulates its argument list in an arrayref before calling
319 C<connect_info> here.
321 The arrayref can either contain the same set of arguments one would
322 normally pass to L<DBI/connect>, or a lone code reference which returns
323 a connected database handle.
325 In either case, if the final argument in your connect_info happens
326 to be a hashref, C<connect_info> will look there for several
327 connection-specific options:
333 This can be set to an arrayref of literal sql statements, which will
334 be executed immediately after making the connection to the database
335 every time we [re-]connect.
339 Sets the limit dialect. This is useful for JDBC-bridge among others
340 where the remote SQL-dialect cannot be determined by the name of the
345 Specifies what characters to use to quote table and column names. If
346 you use this you will want to specify L<name_sep> as well.
348 quote_char expects either a single character, in which case is it is placed
349 on either side of the table/column, or an arrayref of length 2 in which case the
350 table/column name is placed between the elements.
352 For example under MySQL you'd use C<quote_char =E<gt> '`'>, and user SQL Server you'd
353 use C<quote_char =E<gt> [qw/[ ]/]>.
357 This only needs to be used in conjunction with L<quote_char>, and is used to
358 specify the charecter that seperates elements (schemas, tables, columns) from
359 each other. In most cases this is simply a C<.>.
363 These options can be mixed in with your other L<DBI> connection attributes,
364 or placed in a seperate hashref after all other normal L<DBI> connection
367 Every time C<connect_info> is invoked, any previous settings for
368 these options will be cleared before setting the new ones, regardless of
369 whether any options are specified in the new C<connect_info>.
371 Important note: DBIC expects the returned database handle provided by
372 a subref argument to have RaiseError set on it. If it doesn't, things
373 might not work very well, YMMV. If you don't use a subref, DBIC will
374 force this setting for you anyways. Setting HandleError to anything
375 other than simple exception object wrapper might cause problems too.
379 # Simple SQLite connection
380 ->connect_info([ 'dbi:SQLite:./foo.db' ]);
383 ->connect_info([ sub { DBI->connect(...) } ]);
385 # A bit more complicated
392 { quote_char => q{"}, name_sep => q{.} },
396 # Equivalent to the previous example
402 { AutoCommit => 0, quote_char => q{"}, name_sep => q{.} },
406 # Subref + DBIC-specific connection options
409 sub { DBI->connect(...) },
413 on_connect_do => ['SET search_path TO myschema,otherschema,public'],
421 my ($self, $info_arg) = @_;
423 return $self->_connect_info if !$info_arg;
425 # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
426 # the new set of options
427 $self->_sql_maker(undef);
428 $self->_sql_maker_opts({});
430 my $info = [ @$info_arg ]; # copy because we can alter it
431 my $last_info = $info->[-1];
432 if(ref $last_info eq 'HASH') {
433 if(my $on_connect_do = delete $last_info->{on_connect_do}) {
434 $self->on_connect_do($on_connect_do);
436 for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
437 if(my $opt_val = delete $last_info->{$sql_maker_opt}) {
438 $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
442 # Get rid of any trailing empty hashref
443 pop(@$info) if !keys %$last_info;
446 $self->_connect_info($info);
451 This method is deprecated in favor of setting via L</connect_info>.
455 Arguments: $subref, @extra_coderef_args?
457 Execute the given subref using the new exception-based connection management.
459 The first two arguments will be the storage object that C<dbh_do> was called
460 on and a database handle to use. Any additional arguments will be passed
461 verbatim to the called subref as arguments 2 and onwards.
463 Using this (instead of $self->_dbh or $self->dbh) ensures correct
464 exception handling and reconnection (or failover in future subclasses).
466 Your subref should have no side-effects outside of the database, as
467 there is the potential for your subref to be partially double-executed
468 if the database connection was stale/dysfunctional.
472 my @stuff = $schema->storage->dbh_do(
474 my ($storage, $dbh, @cols) = @_;
475 my $cols = join(q{, }, @cols);
476 $dbh->selectrow_array("SELECT $cols FROM foo");
487 ref $coderef eq 'CODE' or $self->throw_exception
488 ('$coderef must be a CODE reference');
490 return $coderef->($self, $self->_dbh, @_) if $self->{_in_dbh_do};
491 local $self->{_in_dbh_do} = 1;
494 my $want_array = wantarray;
497 $self->_verify_pid if $self->_dbh;
498 $self->_populate_dbh if !$self->_dbh;
500 @result = $coderef->($self, $self->_dbh, @_);
502 elsif(defined $want_array) {
503 $result[0] = $coderef->($self, $self->_dbh, @_);
506 $coderef->($self, $self->_dbh, @_);
511 if(!$exception) { return $want_array ? @result : $result[0] }
513 $self->throw_exception($exception) if $self->connected;
515 # We were not connected - reconnect and retry, but let any
516 # exception fall right through this time
517 $self->_populate_dbh;
518 $coderef->($self, $self->_dbh, @_);
521 # This is basically a blend of dbh_do above and DBIx::Class::Storage::txn_do.
522 # It also informs dbh_do to bypass itself while under the direction of txn_do,
523 # via $self->{_in_dbh_do} (this saves some redundant eval and errorcheck, etc)
528 ref $coderef eq 'CODE' or $self->throw_exception
529 ('$coderef must be a CODE reference');
531 local $self->{_in_dbh_do} = 1;
534 my $want_array = wantarray;
539 $self->_verify_pid if $self->_dbh;
540 $self->_populate_dbh if !$self->_dbh;
544 @result = $coderef->(@_);
546 elsif(defined $want_array) {
547 $result[0] = $coderef->(@_);
556 if(!$exception) { return $want_array ? @result : $result[0] }
558 if($tried++ > 0 || $self->connected) {
559 eval { $self->txn_rollback };
560 my $rollback_exception = $@;
561 if($rollback_exception) {
562 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
563 $self->throw_exception($exception) # propagate nested rollback
564 if $rollback_exception =~ /$exception_class/;
566 $self->throw_exception(
567 "Transaction aborted: ${exception}. "
568 . "Rollback failed: ${rollback_exception}"
571 $self->throw_exception($exception)
574 # We were not connected, and was first try - reconnect and retry
576 $self->_populate_dbh;
582 Our C<disconnect> method also performs a rollback first if the
583 database is not in C<AutoCommit> mode.
590 if( $self->connected ) {
591 $self->_dbh->rollback unless $self->_dbh->{AutoCommit};
592 $self->_dbh->disconnect;
601 if(my $dbh = $self->_dbh) {
602 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
610 return ($dbh->FETCH('Active') && $dbh->ping);
616 # handle pid changes correctly
617 # NOTE: assumes $self->_dbh is a valid $dbh
621 return if $self->_conn_pid == $$;
623 $self->_dbh->{InactiveDestroy} = 1;
630 sub ensure_connected {
633 unless ($self->connected) {
634 $self->_populate_dbh;
640 Returns the dbh - a data base handle of class L<DBI>.
647 $self->ensure_connected;
651 sub _sql_maker_args {
654 return ( limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
659 unless ($self->_sql_maker) {
660 $self->_sql_maker(new DBIC::SQL::Abstract( $self->_sql_maker_args ));
662 return $self->_sql_maker;
667 my @info = @{$self->_connect_info || []};
668 $self->_dbh($self->_connect(@info));
670 if(ref $self eq 'DBIx::Class::Storage::DBI') {
671 my $driver = $self->_dbh->{Driver}->{Name};
672 if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
673 bless $self, "DBIx::Class::Storage::DBI::${driver}";
674 $self->_rebless() if $self->can('_rebless');
678 # if on-connect sql statements are given execute them
679 foreach my $sql_statement (@{$self->on_connect_do || []}) {
680 $self->debugobj->query_start($sql_statement) if $self->debug();
681 $self->_dbh->do($sql_statement);
682 $self->debugobj->query_end($sql_statement) if $self->debug();
685 $self->_conn_pid($$);
686 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
690 my ($self, @info) = @_;
692 $self->throw_exception("You failed to provide any connection info")
695 my ($old_connect_via, $dbh);
697 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
698 $old_connect_via = $DBI::connect_via;
699 $DBI::connect_via = 'connect';
703 if(ref $info[0] eq 'CODE') {
707 $dbh = DBI->connect(@info);
708 $dbh->{RaiseError} = 1;
709 $dbh->{PrintError} = 0;
710 $dbh->{PrintWarn} = 0;
714 $DBI::connect_via = $old_connect_via if $old_connect_via;
717 $self->throw_exception("DBI Connection failed: " . ($@ || $DBI::errstr));
724 my ($self, $dbh) = @_;
725 if ($dbh->{AutoCommit}) {
726 $self->debugobj->txn_begin()
734 $self->dbh_do($self->can('_dbh_txn_begin'))
735 if $self->{transaction_depth}++ == 0;
738 sub _dbh_txn_commit {
739 my ($self, $dbh) = @_;
740 if ($self->{transaction_depth} == 0) {
741 unless ($dbh->{AutoCommit}) {
742 $self->debugobj->txn_commit()
748 if (--$self->{transaction_depth} == 0) {
749 $self->debugobj->txn_commit()
758 $self->dbh_do($self->can('_dbh_txn_commit'));
761 sub _dbh_txn_rollback {
762 my ($self, $dbh) = @_;
763 if ($self->{transaction_depth} == 0) {
764 unless ($dbh->{AutoCommit}) {
765 $self->debugobj->txn_rollback()
771 if (--$self->{transaction_depth} == 0) {
772 $self->debugobj->txn_rollback()
777 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
785 eval { $self->dbh_do($self->can('_dbh_txn_rollback')) };
788 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
789 $error =~ /$exception_class/ and $self->throw_exception($error);
790 $self->{transaction_depth} = 0; # ensure that a failed rollback
791 $self->throw_exception($error); # resets the transaction depth
795 # This used to be the top-half of _execute. It was split out to make it
796 # easier to override in NoBindVars without duping the rest. It takes up
797 # all of _execute's args, and emits $sql, @bind.
798 sub _prep_for_execute {
799 my ($self, $op, $extra_bind, $ident, @args) = @_;
801 my ($sql, @bind) = $self->sql_maker->$op($ident, @args);
802 unshift(@bind, @$extra_bind) if $extra_bind;
803 @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
805 return ($sql, @bind);
811 my ($sql, @bind) = $self->_prep_for_execute(@_);
814 my @debug_bind = map { defined $_ ? qq{'$_'} : q{'NULL'} } @bind;
815 $self->debugobj->query_start($sql, @debug_bind);
818 my $sth = $self->sth($sql);
823 $rv = eval { $sth->execute(@bind) };
826 $self->throw_exception("Error executing '$sql': ".($@ || $sth->errstr));
829 $self->throw_exception("'$sql' did not generate a statement.");
832 my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind;
833 $self->debugobj->query_end($sql, @debug_bind);
835 return (wantarray ? ($rv, $sth, @bind) : $rv);
839 my ($self, $ident, $to_insert) = @_;
840 $self->throw_exception(
841 "Couldn't insert ".join(', ',
842 map "$_ => $to_insert->{$_}", keys %$to_insert
844 ) unless ($self->_execute('insert' => [], $ident, $to_insert));
849 return shift->_execute('update' => [], @_);
853 return shift->_execute('delete' => [], @_);
857 my ($self, $ident, $select, $condition, $attrs) = @_;
858 my $order = $attrs->{order_by};
859 if (ref $condition eq 'SCALAR') {
860 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
862 if (exists $attrs->{group_by} || $attrs->{having}) {
864 group_by => $attrs->{group_by},
865 having => $attrs->{having},
866 ($order ? (order_by => $order) : ())
869 my @args = ('select', $attrs->{bind}, $ident, $select, $condition, $order);
870 if ($attrs->{software_limit} ||
871 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
872 $attrs->{software_limit} = 1;
874 $self->throw_exception("rows attribute must be positive if present")
875 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
876 push @args, $attrs->{rows}, $attrs->{offset};
878 return $self->_execute(@args);
885 =item Arguments: $ident, $select, $condition, $attrs
889 Handle a SQL select statement.
895 my ($ident, $select, $condition, $attrs) = @_;
896 return $self->cursor->new($self, \@_, $attrs);
901 my ($rv, $sth, @bind) = $self->_select(@_);
902 my @row = $sth->fetchrow_array;
903 # Need to call finish() to work round broken DBDs
912 =item Arguments: $sql
916 Returns a L<DBI> sth (statement handle) for the supplied SQL.
921 my ($self, $dbh, $sql) = @_;
922 # 3 is the if_active parameter which avoids active sth re-use
923 $dbh->prepare_cached($sql, {}, 3) or
924 $self->throw_exception(
925 'no sth generated via sql (' . ($@ || $dbh->errstr) . "): $sql"
930 my ($self, $sql) = @_;
931 $self->dbh_do($self->can('_dbh_sth'), $sql);
934 sub _dbh_columns_info_for {
935 my ($self, $dbh, $table) = @_;
937 if ($dbh->can('column_info')) {
940 my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
941 my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
943 while ( my $info = $sth->fetchrow_hashref() ){
945 $column_info{data_type} = $info->{TYPE_NAME};
946 $column_info{size} = $info->{COLUMN_SIZE};
947 $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
948 $column_info{default_value} = $info->{COLUMN_DEF};
949 my $col_name = $info->{COLUMN_NAME};
950 $col_name =~ s/^\"(.*)\"$/$1/;
952 $result{$col_name} = \%column_info;
955 return \%result if !$@ && scalar keys %result;
959 my $sth = $dbh->prepare("SELECT * FROM $table WHERE 1=0");
961 my @columns = @{$sth->{NAME_lc}};
962 for my $i ( 0 .. $#columns ){
964 my $type_num = $sth->{TYPE}->[$i];
966 if(defined $type_num && $dbh->can('type_info')) {
967 my $type_info = $dbh->type_info($type_num);
968 $type_name = $type_info->{TYPE_NAME} if $type_info;
970 $column_info{data_type} = $type_name ? $type_name : $type_num;
971 $column_info{size} = $sth->{PRECISION}->[$i];
972 $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
974 if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
975 $column_info{data_type} = $1;
976 $column_info{size} = $2;
979 $result{$columns[$i]} = \%column_info;
985 sub columns_info_for {
986 my ($self, $table) = @_;
987 $self->dbh_do($self->can('_dbh_columns_info_for'), $table);
990 =head2 last_insert_id
992 Return the row id of the last insert.
996 sub _dbh_last_insert_id {
997 my ($self, $dbh, $source, $col) = @_;
998 # XXX This is a SQLite-ism as a default... is there a DBI-generic way?
999 $dbh->func('last_insert_rowid');
1002 sub last_insert_id {
1004 $self->dbh_do($self->can('_dbh_last_insert_id'), @_);
1009 Returns the database driver name.
1013 sub sqlt_type { shift->dbh->{Driver}->{Name} }
1015 =head2 create_ddl_dir (EXPERIMENTAL)
1019 =item Arguments: $schema \@databases, $version, $directory, $sqlt_args
1023 Creates a SQL file based on the Schema, for each of the specified
1024 database types, in the given directory.
1026 Note that this feature is currently EXPERIMENTAL and may not work correctly
1027 across all databases, or fully handle complex relationships.
1033 my ($self, $schema, $databases, $version, $dir, $sqltargs) = @_;
1035 if(!$dir || !-d $dir)
1037 warn "No directory given, using ./\n";
1040 $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
1041 $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
1042 $version ||= $schema->VERSION || '1.x';
1043 $sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} };
1045 eval "use SQL::Translator";
1046 $self->throw_exception("Can't deploy without SQL::Translator: $@") if $@;
1048 my $sqlt = SQL::Translator->new($sqltargs);
1049 foreach my $db (@$databases)
1052 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
1053 # $sqlt->parser_args({'DBIx::Class' => $schema);
1054 $sqlt->data($schema);
1055 $sqlt->producer($db);
1058 my $filename = $schema->ddl_filename($db, $dir, $version);
1061 $self->throw_exception("$filename already exists, skipping $db");
1064 open($file, ">$filename")
1065 or $self->throw_exception("Can't open $filename for writing ($!)");
1066 my $output = $sqlt->translate;
1068 # print join(":", keys %{$schema->source_registrations});
1069 # print Dumper($sqlt->schema);
1072 $self->throw_exception("Failed to translate to $db. (" . $sqlt->error . ")");
1075 print $file $output;
1081 =head2 deployment_statements
1085 =item Arguments: $schema, $type, $version, $directory, $sqlt_args
1089 Returns the statements used by L</deploy> and L<DBIx::Class::Schema/deploy>.
1090 The database driver name is given by C<$type>, though the value from
1091 L</sqlt_type> is used if it is not specified.
1093 C<$directory> is used to return statements from files in a previously created
1094 L</create_ddl_dir> directory and is optional. The filenames are constructed
1095 from L<DBIx::Class::Schema/ddl_filename>, the schema name and the C<$version>.
1097 If no C<$directory> is specified then the statements are constructed on the
1098 fly using L<SQL::Translator> and C<$version> is ignored.
1100 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>.
1104 sub deployment_statements {
1105 my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
1106 # Need to be connected to get the correct sqlt_type
1107 $self->ensure_connected() unless $type;
1108 $type ||= $self->sqlt_type;
1109 $version ||= $schema->VERSION || '1.x';
1111 eval "use SQL::Translator";
1114 eval "use SQL::Translator::Parser::DBIx::Class;";
1115 $self->throw_exception($@) if $@;
1116 eval "use SQL::Translator::Producer::${type};";
1117 $self->throw_exception($@) if $@;
1118 my $tr = SQL::Translator->new(%$sqltargs);
1119 SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
1120 return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
1123 my $filename = $schema->ddl_filename($type, $dir, $version);
1126 # $schema->create_ddl_dir([ $type ], $version, $dir, $sqltargs);
1127 $self->throw_exception("No SQL::Translator, and no Schema file found, aborting deploy");
1131 open($file, "<$filename")
1132 or $self->throw_exception("Can't open $filename ($!)");
1136 return join('', @rows);
1141 my ($self, $schema, $type, $sqltargs, $dir) = @_;
1142 foreach my $statement ( $self->deployment_statements($schema, $type, undef, $dir, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
1143 for ( split(";\n", $statement)) {
1144 next if($_ =~ /^--/);
1146 # next if($_ =~ /^DROP/m);
1147 next if($_ =~ /^BEGIN TRANSACTION/m);
1148 next if($_ =~ /^COMMIT/m);
1149 next if $_ =~ /^\s+$/; # skip whitespace only
1150 $self->debugobj->query_start($_) if $self->debug;
1151 $self->dbh->do($_) or warn "SQL was:\n $_"; # XXX exceptions?
1152 $self->debugobj->query_end($_) if $self->debug;
1157 =head2 datetime_parser
1159 Returns the datetime parser class
1163 sub datetime_parser {
1165 return $self->{datetime_parser} ||= $self->build_datetime_parser(@_);
1168 =head2 datetime_parser_type
1170 Defines (returns) the datetime parser class - currently hardwired to
1171 L<DateTime::Format::MySQL>
1175 sub datetime_parser_type { "DateTime::Format::MySQL"; }
1177 =head2 build_datetime_parser
1179 See L</datetime_parser>
1183 sub build_datetime_parser {
1185 my $type = $self->datetime_parser_type(@_);
1187 $self->throw_exception("Couldn't load ${type}: $@") if $@;
1193 return if !$self->_dbh;
1202 The module defines a set of methods within the DBIC::SQL::Abstract
1203 namespace. These build on L<SQL::Abstract::Limit> to provide the
1204 SQL query functions.
1206 The following methods are extended:-
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>.
1230 See L</connect_info> for details.
1231 For setting, this method is deprecated in favor of L</connect_info>.
1237 Matt S. Trout <mst@shadowcatsystems.co.uk>
1239 Andy Grundman <andy@hybridized.org>
1243 You may distribute this code under the same terms as Perl itself.