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 with the underlying database handle as its
456 first argument, using the new exception-based connection management.
458 Any additional arguments will be passed verbatim to the called subref
459 as arguments 2 and onwards.
463 my @stuff = $schema->storage->dbh_do(
466 my $cols = join(q{, }, @_);
467 shift->selectrow_array("SELECT $cols FROM foo")
478 return $coderef->($self->_dbh, @_) if $self->{_in_txn_do};
480 ref $coderef eq 'CODE' or $self->throw_exception
481 ('$coderef must be a CODE reference');
484 my $want_array = wantarray;
487 $self->_verify_pid if $self->_dbh;
488 $self->_populate_dbh if !$self->_dbh;
490 @result = $coderef->($self->_dbh, @_);
492 elsif(defined $want_array) {
493 $result[0] = $coderef->($self->_dbh, @_);
496 $coderef->($self->_dbh, @_);
501 if(!$exception) { return $want_array ? @result : $result[0] }
503 $self->throw_exception($exception) if $self->connected;
505 # We were not connected - reconnect and retry, but let any
506 # exception fall right through this time
507 $self->_populate_dbh;
508 $coderef->($self->_dbh, @_);
511 # This is basically a blend of dbh_do above and DBIx::Class::Storage::txn_do.
512 # It also informs dbh_do to bypass itself while under the direction of txn_do,
513 # via $self->{_in_txn_do} (this saves some redundant eval and errorcheck, etc)
518 ref $coderef eq 'CODE' or $self->throw_exception
519 ('$coderef must be a CODE reference');
521 local $self->{_in_txn_do} = 1;
526 my $want_array = wantarray;
529 $self->_verify_pid if $self->_dbh;
530 $self->_populate_dbh if !$self->_dbh;
534 @result = $coderef->(@_);
536 elsif(defined $want_array) {
537 $result[0] = $coderef->(@_);
546 if(!$exception) { return $want_array ? @result : $result[0] }
548 if($tried++ > 0 || $self->connected) {
549 eval { $self->txn_rollback };
550 my $rollback_exception = $@;
551 if($rollback_exception) {
552 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
553 $self->throw_exception($exception) # propagate nested rollback
554 if $rollback_exception =~ /$exception_class/;
556 $self->throw_exception(
557 "Transaction aborted: ${exception}. "
558 . "Rollback failed: ${rollback_exception}"
561 $self->throw_exception($exception)
564 # We were not connected, and was first try - reconnect and retry
565 # XXX I know, gotos are evil. If you can find a better way
566 # to write this that doesn't duplicate a lot of code/structure,
567 # and behaves identically, feel free...
569 $self->_populate_dbh;
575 Our C<disconnect> method also performs a rollback first if the
576 database is not in C<AutoCommit> mode.
583 if( $self->connected ) {
584 $self->_dbh->rollback unless $self->_dbh->{AutoCommit};
585 $self->_dbh->disconnect;
593 if(my $dbh = $self->_dbh) {
594 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
595 return $self->_dbh(undef);
600 return ($dbh->FETCH('Active') && $dbh->ping);
606 # handle pid changes correctly
607 # NOTE: assumes $self->_dbh is a valid $dbh
611 return if $self->_conn_pid == $$;
613 $self->_dbh->{InactiveDestroy} = 1;
619 sub ensure_connected {
622 unless ($self->connected) {
623 $self->_populate_dbh;
629 Returns the dbh - a data base handle of class L<DBI>.
636 $self->ensure_connected;
640 sub _sql_maker_args {
643 return ( limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
648 unless ($self->_sql_maker) {
649 $self->_sql_maker(new DBIC::SQL::Abstract( $self->_sql_maker_args ));
651 return $self->_sql_maker;
656 my @info = @{$self->_connect_info || []};
657 $self->_dbh($self->_connect(@info));
659 if(ref $self eq 'DBIx::Class::Storage::DBI') {
660 my $driver = $self->_dbh->{Driver}->{Name};
661 if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
662 bless $self, "DBIx::Class::Storage::DBI::${driver}";
663 $self->_rebless() if $self->can('_rebless');
667 # if on-connect sql statements are given execute them
668 foreach my $sql_statement (@{$self->on_connect_do || []}) {
669 $self->debugobj->query_start($sql_statement) if $self->debug();
670 $self->_dbh->do($sql_statement);
671 $self->debugobj->query_end($sql_statement) if $self->debug();
674 $self->_conn_pid($$);
675 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
679 my ($self, @info) = @_;
681 $self->throw_exception("You failed to provide any connection info")
684 my ($old_connect_via, $dbh);
686 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
687 $old_connect_via = $DBI::connect_via;
688 $DBI::connect_via = 'connect';
692 if(ref $info[0] eq 'CODE') {
696 $dbh = DBI->connect(@info);
697 $dbh->{RaiseError} = 1;
698 $dbh->{PrintError} = 0;
702 $DBI::connect_via = $old_connect_via if $old_connect_via;
705 $self->throw_exception("DBI Connection failed: " . ($@ || $DBI::errstr));
712 my ($dbh, $self) = @_;
713 if ($dbh->{AutoCommit}) {
714 $self->debugobj->txn_begin()
722 $self->dbh_do(\&__txn_begin, $self)
723 if $self->{transaction_depth}++ == 0;
727 my ($dbh, $self) = @_;
728 if ($self->{transaction_depth} == 0) {
729 unless ($dbh->{AutoCommit}) {
730 $self->debugobj->txn_commit()
736 if (--$self->{transaction_depth} == 0) {
737 $self->debugobj->txn_commit()
746 $self->dbh_do(\&__txn_commit, $self);
750 my ($dbh, $self) = @_;
751 if ($self->{transaction_depth} == 0) {
752 unless ($dbh->{AutoCommit}) {
753 $self->debugobj->txn_rollback()
759 if (--$self->{transaction_depth} == 0) {
760 $self->debugobj->txn_rollback()
765 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
772 eval { $self->dbh_do(\&__txn_rollback, $self) };
775 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
776 $error =~ /$exception_class/ and $self->throw_exception($error);
777 $self->{transaction_depth} = 0; # ensure that a failed rollback
778 $self->throw_exception($error); # resets the transaction depth
783 my ($self, $op, $extra_bind, $ident, @args) = @_;
784 my ($sql, @bind) = $self->sql_maker->$op($ident, @args);
785 unshift(@bind, @$extra_bind) if $extra_bind;
787 my @debug_bind = map { defined $_ ? qq{'$_'} : q{'NULL'} } @bind;
788 $self->debugobj->query_start($sql, @debug_bind);
790 my $sth = eval { $self->sth($sql,$op) };
793 $self->throw_exception(
794 'no sth generated via sql (' . ($@ || $self->_dbh->errstr) . "): $sql"
797 @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
801 $rv = eval { $sth->execute(@bind) };
804 $self->throw_exception("Error executing '$sql': ".($@ || $sth->errstr));
807 $self->throw_exception("'$sql' did not generate a statement.");
810 my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind;
811 $self->debugobj->query_end($sql, @debug_bind);
813 return (wantarray ? ($rv, $sth, @bind) : $rv);
817 my ($self, $ident, $to_insert) = @_;
818 $self->throw_exception(
819 "Couldn't insert ".join(', ',
820 map "$_ => $to_insert->{$_}", keys %$to_insert
822 ) unless ($self->_execute('insert' => [], $ident, $to_insert));
827 return shift->_execute('update' => [], @_);
831 return shift->_execute('delete' => [], @_);
835 my ($self, $ident, $select, $condition, $attrs) = @_;
836 my $order = $attrs->{order_by};
837 if (ref $condition eq 'SCALAR') {
838 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
840 if (exists $attrs->{group_by} || $attrs->{having}) {
842 group_by => $attrs->{group_by},
843 having => $attrs->{having},
844 ($order ? (order_by => $order) : ())
847 my @args = ('select', $attrs->{bind}, $ident, $select, $condition, $order);
848 if ($attrs->{software_limit} ||
849 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
850 $attrs->{software_limit} = 1;
852 $self->throw_exception("rows attribute must be positive if present")
853 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
854 push @args, $attrs->{rows}, $attrs->{offset};
856 return $self->_execute(@args);
863 =item Arguments: $ident, $select, $condition, $attrs
867 Handle a SQL select statement.
873 my ($ident, $select, $condition, $attrs) = @_;
874 return $self->cursor->new($self, \@_, $attrs);
879 my ($rv, $sth, @bind) = $self->_select(@_);
880 my @row = $sth->fetchrow_array;
881 # Need to call finish() to work round broken DBDs
890 =item Arguments: $sql
894 Returns a L<DBI> sth (statement handle) for the supplied SQL.
899 my ($dbh, $sql) = @_;
900 # 3 is the if_active parameter which avoids active sth re-use
901 $dbh->prepare_cached($sql, {}, 3);
905 my ($self, $sql) = @_;
906 $self->dbh_do(\&__sth, $sql);
910 sub __columns_info_for {
911 my ($dbh, $self, $table) = @_;
913 if ($dbh->can('column_info')) {
916 my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
917 my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
919 while ( my $info = $sth->fetchrow_hashref() ){
921 $column_info{data_type} = $info->{TYPE_NAME};
922 $column_info{size} = $info->{COLUMN_SIZE};
923 $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
924 $column_info{default_value} = $info->{COLUMN_DEF};
925 my $col_name = $info->{COLUMN_NAME};
926 $col_name =~ s/^\"(.*)\"$/$1/;
928 $result{$col_name} = \%column_info;
931 return \%result if !$@ && scalar keys %result;
935 my $sth = $dbh->prepare("SELECT * FROM $table WHERE 1=0");
937 my @columns = @{$sth->{NAME_lc}};
938 for my $i ( 0 .. $#columns ){
940 my $type_num = $sth->{TYPE}->[$i];
942 if(defined $type_num && $dbh->can('type_info')) {
943 my $type_info = $dbh->type_info($type_num);
944 $type_name = $type_info->{TYPE_NAME} if $type_info;
946 $column_info{data_type} = $type_name ? $type_name : $type_num;
947 $column_info{size} = $sth->{PRECISION}->[$i];
948 $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
950 if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
951 $column_info{data_type} = $1;
952 $column_info{size} = $2;
955 $result{$columns[$i]} = \%column_info;
961 sub columns_info_for {
962 my ($self, $table) = @_;
963 $self->dbh_do(\&__columns_info_for, $self, $table);
966 =head2 last_insert_id
968 Return the row id of the last insert.
973 my ($self, $row) = @_;
975 $self->dbh_do(sub { shift->func('last_insert_rowid') });
980 Returns the database driver name.
984 sub sqlt_type { shift->dbh_do(sub { shift->{Driver}->{Name} }) }
986 =head2 create_ddl_dir (EXPERIMENTAL)
990 =item Arguments: $schema \@databases, $version, $directory, $sqlt_args
994 Creates a SQL file based on the Schema, for each of the specified
995 database types, in the given directory.
997 Note that this feature is currently EXPERIMENTAL and may not work correctly
998 across all databases, or fully handle complex relationships.
1004 my ($self, $schema, $databases, $version, $dir, $sqltargs) = @_;
1006 if(!$dir || !-d $dir)
1008 warn "No directory given, using ./\n";
1011 $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
1012 $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
1013 $version ||= $schema->VERSION || '1.x';
1014 $sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} };
1016 eval "use SQL::Translator";
1017 $self->throw_exception("Can't deploy without SQL::Translator: $@") if $@;
1019 my $sqlt = SQL::Translator->new($sqltargs);
1020 foreach my $db (@$databases)
1023 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
1024 # $sqlt->parser_args({'DBIx::Class' => $schema);
1025 $sqlt->data($schema);
1026 $sqlt->producer($db);
1029 my $filename = $schema->ddl_filename($db, $dir, $version);
1032 $self->throw_exception("$filename already exists, skipping $db");
1035 open($file, ">$filename")
1036 or $self->throw_exception("Can't open $filename for writing ($!)");
1037 my $output = $sqlt->translate;
1039 # print join(":", keys %{$schema->source_registrations});
1040 # print Dumper($sqlt->schema);
1043 $self->throw_exception("Failed to translate to $db. (" . $sqlt->error . ")");
1046 print $file $output;
1052 =head2 deployment_statements
1056 =item Arguments: $schema, $type, $version, $directory, $sqlt_args
1060 Returns the statements used by L</deploy> and L<DBIx::Class::Schema/deploy>.
1061 The database driver name is given by C<$type>, though the value from
1062 L</sqlt_type> is used if it is not specified.
1064 C<$directory> is used to return statements from files in a previously created
1065 L</create_ddl_dir> directory and is optional. The filenames are constructed
1066 from L<DBIx::Class::Schema/ddl_filename>, the schema name and the C<$version>.
1068 If no C<$directory> is specified then the statements are constructed on the
1069 fly using L<SQL::Translator> and C<$version> is ignored.
1071 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>.
1075 sub deployment_statements {
1076 my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
1077 # Need to be connected to get the correct sqlt_type
1078 $self->ensure_connected() unless $type;
1079 $type ||= $self->sqlt_type;
1080 $version ||= $schema->VERSION || '1.x';
1082 eval "use SQL::Translator";
1085 eval "use SQL::Translator::Parser::DBIx::Class;";
1086 $self->throw_exception($@) if $@;
1087 eval "use SQL::Translator::Producer::${type};";
1088 $self->throw_exception($@) if $@;
1089 my $tr = SQL::Translator->new(%$sqltargs);
1090 SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
1091 return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
1094 my $filename = $schema->ddl_filename($type, $dir, $version);
1097 # $schema->create_ddl_dir([ $type ], $version, $dir, $sqltargs);
1098 $self->throw_exception("No SQL::Translator, and no Schema file found, aborting deploy");
1102 open($file, "<$filename")
1103 or $self->throw_exception("Can't open $filename ($!)");
1107 return join('', @rows);
1112 my ($self, $schema, $type, $sqltargs, $dir) = @_;
1113 foreach my $statement ( $self->deployment_statements($schema, $type, undef, $dir, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
1114 for ( split(";\n", $statement)) {
1115 next if($_ =~ /^--/);
1117 # next if($_ =~ /^DROP/m);
1118 next if($_ =~ /^BEGIN TRANSACTION/m);
1119 next if($_ =~ /^COMMIT/m);
1120 next if $_ =~ /^\s+$/; # skip whitespace only
1121 $self->debugobj->query_start($_) if $self->debug;
1122 $self->dbh->do($_) or warn "SQL was:\n $_"; # XXX exceptions?
1123 $self->debugobj->query_end($_) if $self->debug;
1128 =head2 datetime_parser
1130 Returns the datetime parser class
1134 sub datetime_parser {
1136 return $self->{datetime_parser} ||= $self->build_datetime_parser(@_);
1139 =head2 datetime_parser_type
1141 Defines (returns) the datetime parser class - currently hardwired to
1142 L<DateTime::Format::MySQL>
1146 sub datetime_parser_type { "DateTime::Format::MySQL"; }
1148 =head2 build_datetime_parser
1150 See L</datetime_parser>
1154 sub build_datetime_parser {
1156 my $type = $self->datetime_parser_type(@_);
1158 $self->throw_exception("Couldn't load ${type}: $@") if $@;
1164 return if !$self->_dbh;
1173 The module defines a set of methods within the DBIC::SQL::Abstract
1174 namespace. These build on L<SQL::Abstract::Limit> to provide the
1175 SQL query functions.
1177 The following methods are extended:-
1191 See L</connect_info> for details.
1192 For setting, this method is deprecated in favor of L</connect_info>.
1196 See L</connect_info> for details.
1197 For setting, this method is deprecated in favor of L</connect_info>.
1201 See L</connect_info> for details.
1202 For setting, this method is deprecated in favor of L</connect_info>.
1208 Matt S. Trout <mst@shadowcatsystems.co.uk>
1210 Andy Grundman <andy@hybridized.org>
1214 You may distribute this code under the same terms as Perl itself.