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 foreach my $statement ( $self->deployment_statements($schema, $type, undef, $dir, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
1103 for ( split(";\n", $statement)) {
1104 next if($_ =~ /^--/);
1106 # next if($_ =~ /^DROP/m);
1107 next if($_ =~ /^BEGIN TRANSACTION/m);
1108 next if($_ =~ /^COMMIT/m);
1109 next if $_ =~ /^\s+$/; # skip whitespace only
1110 $self->debugobj->query_start($_) if $self->debug;
1111 $self->dbh->do($_) or warn "SQL was:\n $_";
1112 $self->debugobj->query_end($_) if $self->debug;
1117 =head2 datetime_parser
1119 Returns the datetime parser class
1123 sub datetime_parser {
1125 return $self->{datetime_parser} ||= $self->build_datetime_parser(@_);
1128 =head2 datetime_parser_type
1130 Defines (returns) the datetime parser class - currently hardwired to
1131 L<DateTime::Format::MySQL>
1135 sub datetime_parser_type { "DateTime::Format::MySQL"; }
1137 =head2 build_datetime_parser
1139 See L</datetime_parser>
1143 sub build_datetime_parser {
1145 my $type = $self->datetime_parser_type(@_);
1147 $self->throw_exception("Couldn't load ${type}: $@") if $@;
1152 # NOTE: if there's a merge conflict here when -current is pushed
1153 # back to trunk, take -current's version and ignore this trunk one :)
1156 if($self->_dbh && $self->_conn_pid != $$) {
1157 $self->_dbh->{InactiveDestroy} = 1;
1167 The module defines a set of methods within the DBIC::SQL::Abstract
1168 namespace. These build on L<SQL::Abstract::Limit> to provide the
1169 SQL query functions.
1171 The following methods are extended:-
1185 See L</connect_info> for details.
1186 For setting, this method is deprecated in favor of L</connect_info>.
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 =head1 ENVIRONMENT VARIABLES
1204 If C<DBIC_TRACE> is set then SQL trace information
1205 is produced (as when the L<debug> method is set).
1207 If the value is of the form C<1=/path/name> then the trace output is
1208 written to the file C</path/name>.
1210 This environment variable is checked when the storage object is first
1211 created (when you call connect on your schema). So, run-time changes
1212 to this environment variable will not take effect unless you also
1213 re-connect on your schema.
1215 =head2 DBIX_CLASS_STORAGE_DBI_DEBUG
1217 Old name for DBIC_TRACE
1221 Matt S. Trout <mst@shadowcatsystems.co.uk>
1223 Andy Grundman <andy@hybridized.org>
1227 You may distribute this code under the same terms as Perl itself.