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;
13 use Carp::Clan qw/DBIx::Class/;
16 package DBIC::SQL::Abstract; # Would merge upstream, but nate doesn't reply :(
18 use base qw/SQL::Abstract::Limit/;
20 # This prevents the caching of $dbh in S::A::L, I believe
22 my $self = shift->SUPER::new(@_);
24 # If limit_dialect is a ref (like a $dbh), go ahead and replace
25 # it with what it resolves to:
26 $self->{limit_dialect} = $self->_find_syntax($self->{limit_dialect})
27 if ref $self->{limit_dialect};
33 my ($self, $sql, $order, $rows, $offset ) = @_;
36 my $last = $rows + $offset;
37 my ( $order_by ) = $self->_order_by( $order );
42 SELECT Q1.*, ROW_NUMBER() OVER( ) AS ROW_NUM FROM (
47 WHERE ROW_NUM BETWEEN $offset AND $last
53 # While we're at it, this should make LIMIT queries more efficient,
54 # without digging into things too deeply
55 use Scalar::Util 'blessed';
57 my ($self, $syntax) = @_;
58 my $dbhname = blessed($syntax) ? $syntax->{Driver}{Name} : $syntax;
59 # print STDERR "Found DBH $syntax >$dbhname< ", $syntax->{Driver}->{Name}, "\n";
60 if(ref($self) && $dbhname && $dbhname eq 'DB2') {
61 return 'RowNumberOver';
64 $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
68 my ($self, $table, $fields, $where, $order, @rest) = @_;
69 $table = $self->_quote($table) unless ref($table);
70 local $self->{rownum_hack_count} = 1
71 if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
72 @rest = (-1) unless defined $rest[0];
73 die "LIMIT 0 Does Not Compute" if $rest[0] == 0;
74 # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
75 local $self->{having_bind} = [];
76 my ($sql, @ret) = $self->SUPER::select(
77 $table, $self->_recurse_fields($fields), $where, $order, @rest
79 return wantarray ? ($sql, @ret, @{$self->{having_bind}}) : $sql;
85 $table = $self->_quote($table) unless ref($table);
86 $self->SUPER::insert($table, @_);
92 $table = $self->_quote($table) unless ref($table);
93 $self->SUPER::update($table, @_);
99 $table = $self->_quote($table) unless ref($table);
100 $self->SUPER::delete($table, @_);
106 return $_[1].$self->_order_by($_[2]);
108 return $self->SUPER::_emulate_limit(@_);
112 sub _recurse_fields {
113 my ($self, $fields) = @_;
114 my $ref = ref $fields;
115 return $self->_quote($fields) unless $ref;
116 return $$fields if $ref eq 'SCALAR';
118 if ($ref eq 'ARRAY') {
119 return join(', ', map {
120 $self->_recurse_fields($_)
121 .(exists $self->{rownum_hack_count}
122 ? ' AS col'.$self->{rownum_hack_count}++
125 } elsif ($ref eq 'HASH') {
126 foreach my $func (keys %$fields) {
127 return $self->_sqlcase($func)
128 .'( '.$self->_recurse_fields($fields->{$func}).' )';
137 if (ref $_[0] eq 'HASH') {
138 if (defined $_[0]->{group_by}) {
139 $ret = $self->_sqlcase(' group by ')
140 .$self->_recurse_fields($_[0]->{group_by});
142 if (defined $_[0]->{having}) {
144 ($frag, @extra) = $self->_recurse_where($_[0]->{having});
145 push(@{$self->{having_bind}}, @extra);
146 $ret .= $self->_sqlcase(' having ').$frag;
148 if (defined $_[0]->{order_by}) {
149 $ret .= $self->_order_by($_[0]->{order_by});
151 } elsif (ref $_[0] eq 'SCALAR') {
152 $ret = $self->_sqlcase(' order by ').${ $_[0] };
153 } elsif (ref $_[0] eq 'ARRAY' && @{$_[0]}) {
154 my @order = @{+shift};
155 $ret = $self->_sqlcase(' order by ')
157 my $r = $self->_order_by($_, @_);
158 $r =~ s/^ ?ORDER BY //i;
162 $ret = $self->SUPER::_order_by(@_);
167 sub _order_directions {
168 my ($self, $order) = @_;
169 $order = $order->{order_by} if ref $order eq 'HASH';
170 return $self->SUPER::_order_directions($order);
174 my ($self, $from) = @_;
175 if (ref $from eq 'ARRAY') {
176 return $self->_recurse_from(@$from);
177 } elsif (ref $from eq 'HASH') {
178 return $self->_make_as($from);
180 return $from; # would love to quote here but _table ends up getting called
181 # twice during an ->select without a limit clause due to
182 # the way S::A::Limit->select works. should maybe consider
183 # bypassing this and doing S::A::select($self, ...) in
184 # our select method above. meantime, quoting shims have
185 # been added to select/insert/update/delete here
190 my ($self, $from, @join) = @_;
192 push(@sqlf, $self->_make_as($from));
193 foreach my $j (@join) {
196 # check whether a join type exists
197 my $join_clause = '';
198 my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
199 if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
200 $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
202 $join_clause = ' JOIN ';
204 push(@sqlf, $join_clause);
206 if (ref $to eq 'ARRAY') {
207 push(@sqlf, '(', $self->_recurse_from(@$to), ')');
209 push(@sqlf, $self->_make_as($to));
211 push(@sqlf, ' ON ', $self->_join_condition($on));
213 return join('', @sqlf);
217 my ($self, $from) = @_;
218 return join(' ', map { (ref $_ eq 'SCALAR' ? $$_ : $self->_quote($_)) }
219 reverse each %{$self->_skip_options($from)});
223 my ($self, $hash) = @_;
225 $clean_hash->{$_} = $hash->{$_}
226 for grep {!/^-/} keys %$hash;
230 sub _join_condition {
231 my ($self, $cond) = @_;
232 if (ref $cond eq 'HASH') {
235 my $x = '= '.$self->_quote($cond->{$_}); $j{$_} = \$x;
237 return $self->_recurse_where(\%j);
238 } elsif (ref $cond eq 'ARRAY') {
239 return join(' OR ', map { $self->_join_condition($_) } @$cond);
241 die "Can't handle this yet!";
246 my ($self, $label) = @_;
247 return '' unless defined $label;
248 return "*" if $label eq '*';
249 return $label unless $self->{quote_char};
250 if(ref $self->{quote_char} eq "ARRAY"){
251 return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
252 if !defined $self->{name_sep};
253 my $sep = $self->{name_sep};
254 return join($self->{name_sep},
255 map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
256 split(/\Q$sep\E/,$label));
258 return $self->SUPER::_quote($label);
263 $self->{limit_dialect} = shift if @_;
264 return $self->{limit_dialect};
269 $self->{quote_char} = shift if @_;
270 return $self->{quote_char};
275 $self->{name_sep} = shift if @_;
276 return $self->{name_sep};
279 } # End of BEGIN block
281 use base qw/DBIx::Class/;
283 __PACKAGE__->load_components(qw/AccessorGroup/);
285 __PACKAGE__->mk_group_accessors('simple' =>
286 qw/_connect_info _dbh _sql_maker _sql_maker_opts _conn_pid _conn_tid
287 debug debugobj cursor on_connect_do transaction_depth/);
291 DBIx::Class::Storage::DBI - DBI storage handler
297 This class represents the connection to the database
307 bless $new, (ref $_[0] || $_[0]);
309 $new->cursor("DBIx::Class::Storage::DBI::Cursor");
310 $new->transaction_depth(0);
312 $new->debugobj(new DBIx::Class::Storage::Statistics());
316 my $debug_env = $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG}
319 if (defined($debug_env) && ($debug_env =~ /=(.+)$/)) {
320 $fh = IO::File->new($1, 'w')
321 or $new->throw_exception("Cannot open trace file $1");
323 $fh = IO::File->new('>&STDERR');
326 $new->debug(1) if $debug_env;
327 $new->_sql_maker_opts({});
331 =head2 throw_exception
333 Throws an exception - croaks.
337 sub throw_exception {
338 my ($self, $msg) = @_;
344 The arguments of C<connect_info> are always a single array reference.
346 This is normally accessed via L<DBIx::Class::Schema/connection>, which
347 encapsulates its argument list in an arrayref before calling
348 C<connect_info> here.
350 The arrayref can either contain the same set of arguments one would
351 normally pass to L<DBI/connect>, or a lone code reference which returns
352 a connected database handle.
354 In either case, if the final argument in your connect_info happens
355 to be a hashref, C<connect_info> will look there for several
356 connection-specific options:
362 This can be set to an arrayref of literal sql statements, which will
363 be executed immediately after making the connection to the database
364 every time we [re-]connect.
368 Sets the limit dialect. This is useful for JDBC-bridge among others
369 where the remote SQL-dialect cannot be determined by the name of the
374 Specifies what characters to use to quote table and column names. If
375 you use this you will want to specify L<name_sep> as well.
377 quote_char expects either a single character, in which case is it is placed
378 on either side of the table/column, or an arrayref of length 2 in which case the
379 table/column name is placed between the elements.
381 For example under MySQL you'd use C<quote_char =E<gt> '`'>, and user SQL Server you'd
382 use C<quote_char =E<gt> [qw/[ ]/]>.
386 This only needs to be used in conjunction with L<quote_char>, and is used to
387 specify the charecter that seperates elements (schemas, tables, columns) from
388 each other. In most cases this is simply a C<.>.
392 These options can be mixed in with your other L<DBI> connection attributes,
393 or placed in a seperate hashref after all other normal L<DBI> connection
396 Every time C<connect_info> is invoked, any previous settings for
397 these options will be cleared before setting the new ones, regardless of
398 whether any options are specified in the new C<connect_info>.
402 # Simple SQLite connection
403 ->connect_info([ 'dbi:SQLite:./foo.db' ]);
406 ->connect_info([ sub { DBI->connect(...) } ]);
408 # A bit more complicated
415 { quote_char => q{"}, name_sep => q{.} },
419 # Equivalent to the previous example
425 { AutoCommit => 0, quote_char => q{"}, name_sep => q{.} },
429 # Subref + DBIC-specific connection options
432 sub { DBI->connect(...) },
436 on_connect_do => ['SET search_path TO myschema,otherschema,public'],
443 This method is deprecated in favor of setting via L</connect_info>.
447 Causes SQL trace information to be emitted on the C<debugobj> object.
448 (or C<STDERR> if C<debugobj> has not specifically been set).
450 This is the equivalent to setting L</DBIC_TRACE> in your
455 Set or retrieve the filehandle used for trace/debug output. This should be
456 an IO::Handle compatible ojbect (only the C<print> method is used. Initially
457 set to be STDERR - although see information on the
458 L<DBIC_TRACE> environment variable.
465 if ($self->debugobj->can('debugfh')) {
466 return $self->debugobj->debugfh(@_);
472 Sets or retrieves the object used for metric collection. Defaults to an instance
473 of L<DBIx::Class::Storage::Statistics> that is campatible with the original
474 method of using a coderef as a callback. See the aforementioned Statistics
475 class for more information.
479 Sets a callback to be executed each time a statement is run; takes a sub
480 reference. Callback is executed as $sub->($op, $info) where $op is
481 SELECT/INSERT/UPDATE/DELETE and $info is what would normally be printed.
483 See L<debugobj> for a better way.
490 if ($self->debugobj->can('callback')) {
491 return $self->debugobj->callback(@_);
497 Disconnect the L<DBI> handle, performing a rollback first if the
498 database is not in C<AutoCommit> mode.
505 if( $self->connected ) {
506 $self->_dbh->rollback unless $self->_dbh->{AutoCommit};
507 $self->_dbh->disconnect;
514 Check if the L<DBI> handle is connected. Returns true if the handle
519 sub connected { my ($self) = @_;
521 if(my $dbh = $self->_dbh) {
522 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
523 return $self->_dbh(undef);
525 elsif($self->_conn_pid != $$) {
526 $self->_dbh->{InactiveDestroy} = 1;
527 return $self->_dbh(undef);
529 return ($dbh->FETCH('Active') && $dbh->ping);
535 =head2 ensure_connected
537 Check whether the database handle is connected - if not then make a
542 sub ensure_connected {
545 unless ($self->connected) {
546 $self->_populate_dbh;
552 Returns the dbh - a data base handle of class L<DBI>.
559 $self->ensure_connected;
563 sub _sql_maker_args {
566 return ( limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
571 Returns a C<sql_maker> object - normally an object of class
572 C<DBIC::SQL::Abstract>.
578 unless ($self->_sql_maker) {
579 $self->_sql_maker(new DBIC::SQL::Abstract( $self->_sql_maker_args ));
581 return $self->_sql_maker;
585 my ($self, $info_arg) = @_;
588 # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
589 # the new set of options
590 $self->_sql_maker(undef);
591 $self->_sql_maker_opts({});
593 my $info = [ @$info_arg ]; # copy because we can alter it
594 my $last_info = $info->[-1];
595 if(ref $last_info eq 'HASH') {
596 if(my $on_connect_do = delete $last_info->{on_connect_do}) {
597 $self->on_connect_do($on_connect_do);
599 for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
600 if(my $opt_val = delete $last_info->{$sql_maker_opt}) {
601 $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
605 # Get rid of any trailing empty hashref
606 pop(@$info) if !keys %$last_info;
609 $self->_connect_info($info);
612 $self->_connect_info;
617 my @info = @{$self->_connect_info || []};
618 $self->_dbh($self->_connect(@info));
620 if(ref $self eq 'DBIx::Class::Storage::DBI') {
621 my $driver = $self->_dbh->{Driver}->{Name};
622 if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
623 bless $self, "DBIx::Class::Storage::DBI::${driver}";
624 $self->_rebless() if $self->can('_rebless');
628 # if on-connect sql statements are given execute them
629 foreach my $sql_statement (@{$self->on_connect_do || []}) {
630 $self->debugobj->query_start($sql_statement) if $self->debug();
631 $self->_dbh->do($sql_statement);
632 $self->debugobj->query_end($sql_statement) if $self->debug();
635 $self->_conn_pid($$);
636 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
640 my ($self, @info) = @_;
642 $self->throw_exception("You failed to provide any connection info")
645 my ($old_connect_via, $dbh);
647 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
648 $old_connect_via = $DBI::connect_via;
649 $DBI::connect_via = 'connect';
653 $dbh = ref $info[0] eq 'CODE'
655 : DBI->connect(@info);
658 $DBI::connect_via = $old_connect_via if $old_connect_via;
661 $self->throw_exception("DBI Connection failed: " . ($@ || $DBI::errstr));
669 Calls begin_work on the current dbh.
671 See L<DBIx::Class::Schema> for the txn_do() method, which allows for
672 an entire code block to be executed transactionally.
678 if ($self->{transaction_depth}++ == 0) {
679 my $dbh = $self->dbh;
680 if ($dbh->{AutoCommit}) {
681 $self->debugobj->txn_begin()
690 Issues a commit against the current dbh.
696 my $dbh = $self->dbh;
697 if ($self->{transaction_depth} == 0) {
698 unless ($dbh->{AutoCommit}) {
699 $self->debugobj->txn_commit()
705 if (--$self->{transaction_depth} == 0) {
706 $self->debugobj->txn_commit()
715 Issues a rollback against the current dbh. A nested rollback will
716 throw a L<DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION> exception,
717 which allows the rollback to propagate to the outermost transaction.
725 my $dbh = $self->dbh;
726 if ($self->{transaction_depth} == 0) {
727 unless ($dbh->{AutoCommit}) {
728 $self->debugobj->txn_rollback()
734 if (--$self->{transaction_depth} == 0) {
735 $self->debugobj->txn_rollback()
740 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
747 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
748 $error =~ /$exception_class/ and $self->throw_exception($error);
749 $self->{transaction_depth} = 0; # ensure that a failed rollback
750 $self->throw_exception($error); # resets the transaction depth
755 my ($self, $op, $extra_bind, $ident, @args) = @_;
756 my ($sql, @bind) = $self->sql_maker->$op($ident, @args);
757 unshift(@bind, @$extra_bind) if $extra_bind;
759 my @debug_bind = map { defined $_ ? qq{'$_'} : q{'NULL'} } @bind;
760 $self->debugobj->query_start($sql, @debug_bind);
762 my $sth = eval { $self->sth($sql,$op) };
765 $self->throw_exception(
766 'no sth generated via sql (' . ($@ || $self->_dbh->errstr) . "): $sql"
769 @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
773 $rv = eval { $sth->execute(@bind) };
776 $self->throw_exception("Error executing '$sql': ".($@ || $sth->errstr));
779 $self->throw_exception("'$sql' did not generate a statement.");
782 my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind;
783 $self->debugobj->query_end($sql, @debug_bind);
785 return (wantarray ? ($rv, $sth, @bind) : $rv);
789 my ($self, $ident, $to_insert) = @_;
790 $self->throw_exception(
791 "Couldn't insert ".join(', ',
792 map "$_ => $to_insert->{$_}", keys %$to_insert
794 ) unless ($self->_execute('insert' => [], $ident, $to_insert));
799 return shift->_execute('update' => [], @_);
803 return shift->_execute('delete' => [], @_);
807 my ($self, $ident, $select, $condition, $attrs) = @_;
808 my $order = $attrs->{order_by};
809 if (ref $condition eq 'SCALAR') {
810 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
812 if (exists $attrs->{group_by} || $attrs->{having}) {
814 group_by => $attrs->{group_by},
815 having => $attrs->{having},
816 ($order ? (order_by => $order) : ())
819 my @args = ('select', $attrs->{bind}, $ident, $select, $condition, $order);
820 if ($attrs->{software_limit} ||
821 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
822 $attrs->{software_limit} = 1;
824 $self->throw_exception("rows attribute must be positive if present")
825 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
826 push @args, $attrs->{rows}, $attrs->{offset};
828 return $self->_execute(@args);
835 =item Arguments: $ident, $select, $condition, $attrs
839 Handle a SQL select statement.
845 my ($ident, $select, $condition, $attrs) = @_;
846 return $self->cursor->new($self, \@_, $attrs);
851 Performs a select, fetch and return of data - handles a single row
856 # Need to call finish() to work round broken DBDs
860 my ($rv, $sth, @bind) = $self->_select(@_);
861 my @row = $sth->fetchrow_array;
870 =item Arguments: $sql
874 Returns a L<DBI> sth (statement handle) for the supplied SQL.
879 my ($self, $sql) = @_;
880 # 3 is the if_active parameter which avoids active sth re-use
881 return $self->dbh->prepare_cached($sql, {}, 3);
884 =head2 columns_info_for
886 Returns database type info for a given table column.
890 sub columns_info_for {
891 my ($self, $table) = @_;
893 my $dbh = $self->dbh;
895 if ($dbh->can('column_info')) {
897 local $dbh->{RaiseError} = 1;
898 local $dbh->{PrintError} = 0;
900 my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
901 my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
904 while ( my $info = $sth->fetchrow_hashref() ){
906 $column_info{data_type} = $info->{TYPE_NAME};
907 $column_info{size} = $info->{COLUMN_SIZE};
908 $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
909 $column_info{default_value} = $info->{COLUMN_DEF};
910 my $col_name = $info->{COLUMN_NAME};
911 $col_name =~ s/^\"(.*)\"$/$1/;
913 $result{$col_name} = \%column_info;
916 return \%result if !$@ && scalar keys %result;
920 my $sth = $dbh->prepare("SELECT * FROM $table WHERE 1=0");
922 my @columns = @{$sth->{NAME_lc}};
923 for my $i ( 0 .. $#columns ){
925 my $type_num = $sth->{TYPE}->[$i];
927 if(defined $type_num && $dbh->can('type_info')) {
928 my $type_info = $dbh->type_info($type_num);
929 $type_name = $type_info->{TYPE_NAME} if $type_info;
931 $column_info{data_type} = $type_name ? $type_name : $type_num;
932 $column_info{size} = $sth->{PRECISION}->[$i];
933 $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
935 if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
936 $column_info{data_type} = $1;
937 $column_info{size} = $2;
940 $result{$columns[$i]} = \%column_info;
946 =head2 last_insert_id
948 Return the row id of the last insert.
953 my ($self, $row) = @_;
955 return $self->dbh->func('last_insert_rowid');
961 Returns the database driver name.
965 sub sqlt_type { shift->dbh->{Driver}->{Name} }
967 =head2 create_ddl_dir (EXPERIMENTAL)
971 =item Arguments: $schema \@databases, $version, $directory, $sqlt_args
975 Creates a SQL file based on the Schema, for each of the specified
976 database types, in the given directory.
978 Note that this feature is currently EXPERIMENTAL and may not work correctly
979 across all databases, or fully handle complex relationships.
985 my ($self, $schema, $databases, $version, $dir, $sqltargs) = @_;
987 if(!$dir || !-d $dir)
989 warn "No directory given, using ./\n";
992 $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
993 $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
994 $version ||= $schema->VERSION || '1.x';
995 $sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} };
997 eval "use SQL::Translator";
998 $self->throw_exception("Can't deploy without SQL::Translator: $@") if $@;
1000 my $sqlt = SQL::Translator->new($sqltargs);
1001 foreach my $db (@$databases)
1004 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
1005 # $sqlt->parser_args({'DBIx::Class' => $schema);
1006 $sqlt->data($schema);
1007 $sqlt->producer($db);
1010 my $filename = $schema->ddl_filename($db, $dir, $version);
1013 $self->throw_exception("$filename already exists, skipping $db");
1016 open($file, ">$filename")
1017 or $self->throw_exception("Can't open $filename for writing ($!)");
1018 my $output = $sqlt->translate;
1020 # print join(":", keys %{$schema->source_registrations});
1021 # print Dumper($sqlt->schema);
1024 $self->throw_exception("Failed to translate to $db. (" . $sqlt->error . ")");
1027 print $file $output;
1033 =head2 deployment_statements
1037 =item Arguments: $schema, $type, $version, $directory, $sqlt_args
1041 Returns the statements used by L</deploy> and L<DBIx::Class::Schema/deploy>.
1042 The database driver name is given by C<$type>, though the value from
1043 L</sqlt_type> is used if it is not specified.
1045 C<$directory> is used to return statements from files in a previously created
1046 L</create_ddl_dir> directory and is optional. The filenames are constructed
1047 from L<DBIx::Class::Schema/ddl_filename>, the schema name and the C<$version>.
1049 If no C<$directory> is specified then the statements are constructed on the
1050 fly using L<SQL::Translator> and C<$version> is ignored.
1052 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>.
1056 sub deployment_statements {
1057 my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
1058 # Need to be connected to get the correct sqlt_type
1059 $self->ensure_connected() unless $type;
1060 $type ||= $self->sqlt_type;
1061 $version ||= $schema->VERSION || '1.x';
1063 eval "use SQL::Translator";
1066 eval "use SQL::Translator::Parser::DBIx::Class;";
1067 $self->throw_exception($@) if $@;
1068 eval "use SQL::Translator::Producer::${type};";
1069 $self->throw_exception($@) if $@;
1070 my $tr = SQL::Translator->new(%$sqltargs);
1071 SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
1072 return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
1075 my $filename = $schema->ddl_filename($type, $dir, $version);
1078 # $schema->create_ddl_dir([ $type ], $version, $dir, $sqltargs);
1079 $self->throw_exception("No SQL::Translator, and no Schema file found, aborting deploy");
1083 open($file, "<$filename")
1084 or $self->throw_exception("Can't open $filename ($!)");
1088 return join('', @rows);
1094 Sends the appropriate statements to create or modify tables to the
1095 db. This would normally be called through
1096 L<DBIx::Class::Schema/deploy>.
1101 my ($self, $schema, $type, $sqltargs, $dir) = @_;
1102 my @statements = $self->deployment_statements($schema, $type, undef, $dir, { no_comments => 1, %{ $sqltargs || {} } } );
1104 if (scalar @statements == 1) {
1105 @statements = split(";\n", $statements[0]);
1106 $type ||= $self->sqlt_type;
1107 # If we got more stmts out from splitting, display a warning
1108 carp "SQL::Translator::Producer:${type}->produce only returned a single scalar for multiple statements.\n"
1109 if (scalar @statements != 1);
1112 foreach (@statements) {
1113 next if($_ =~ /^\s*$/s);
1114 next if($_ =~ /^BEGIN TRANSACTION/m);
1115 next if($_ =~ /^COMMIT/m);
1116 $self->debugobj->query_start($_) if $self->debug;
1117 $self->dbh->do($_) or warn "SQL was:\n $_";
1118 $self->debugobj->query_end($_) if $self->debug;
1122 =head2 datetime_parser
1124 Returns the datetime parser class
1128 sub datetime_parser {
1130 return $self->{datetime_parser} ||= $self->build_datetime_parser(@_);
1133 =head2 datetime_parser_type
1135 Defines (returns) the datetime parser class - currently hardwired to
1136 L<DateTime::Format::MySQL>
1140 sub datetime_parser_type { "DateTime::Format::MySQL"; }
1142 =head2 build_datetime_parser
1144 See L</datetime_parser>
1148 sub build_datetime_parser {
1150 my $type = $self->datetime_parser_type(@_);
1152 $self->throw_exception("Couldn't load ${type}: $@") if $@;
1157 # NOTE: if there's a merge conflict here when -current is pushed
1158 # back to trunk, take -current's version and ignore this trunk one :)
1161 if($self->_dbh && $self->_conn_pid != $$) {
1162 $self->_dbh->{InactiveDestroy} = 1;
1172 The module defines a set of methods within the DBIC::SQL::Abstract
1173 namespace. These build on L<SQL::Abstract::Limit> to provide the
1174 SQL query functions.
1176 The following methods are extended:-
1190 See L</connect_info> for details.
1191 For setting, this method is deprecated in favor of L</connect_info>.
1195 See L</connect_info> for details.
1196 For setting, this method is deprecated in favor of L</connect_info>.
1200 See L</connect_info> for details.
1201 For setting, this method is deprecated in favor of L</connect_info>.
1205 =head1 ENVIRONMENT VARIABLES
1209 If C<DBIC_TRACE> is set then SQL trace information
1210 is produced (as when the L<debug> method is set).
1212 If the value is of the form C<1=/path/name> then the trace output is
1213 written to the file C</path/name>.
1215 This environment variable is checked when the storage object is first
1216 created (when you call connect on your schema). So, run-time changes
1217 to this environment variable will not take effect unless you also
1218 re-connect on your schema.
1220 =head2 DBIX_CLASS_STORAGE_DBI_DEBUG
1222 Old name for DBIC_TRACE
1226 Matt S. Trout <mst@shadowcatsystems.co.uk>
1228 Andy Grundman <andy@hybridized.org>
1232 You may distribute this code under the same terms as Perl itself.