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};
32 # While we're at it, this should make LIMIT queries more efficient,
33 # without digging into things too deeply
35 my ($self, $syntax) = @_;
36 $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
40 my ($self, $table, $fields, $where, $order, @rest) = @_;
41 $table = $self->_quote($table) unless ref($table);
42 local $self->{rownum_hack_count} = 1
43 if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
44 @rest = (-1) unless defined $rest[0];
45 die "LIMIT 0 Does Not Compute" if $rest[0] == 0;
46 # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
47 local $self->{having_bind} = [];
48 my ($sql, @ret) = $self->SUPER::select(
49 $table, $self->_recurse_fields($fields), $where, $order, @rest
51 return wantarray ? ($sql, @ret, @{$self->{having_bind}}) : $sql;
57 $table = $self->_quote($table) unless ref($table);
58 $self->SUPER::insert($table, @_);
64 $table = $self->_quote($table) unless ref($table);
65 $self->SUPER::update($table, @_);
71 $table = $self->_quote($table) unless ref($table);
72 $self->SUPER::delete($table, @_);
78 return $_[1].$self->_order_by($_[2]);
80 return $self->SUPER::_emulate_limit(@_);
85 my ($self, $fields) = @_;
86 my $ref = ref $fields;
87 return $self->_quote($fields) unless $ref;
88 return $$fields if $ref eq 'SCALAR';
90 if ($ref eq 'ARRAY') {
91 return join(', ', map {
92 $self->_recurse_fields($_)
93 .(exists $self->{rownum_hack_count}
94 ? ' AS col'.$self->{rownum_hack_count}++
97 } elsif ($ref eq 'HASH') {
98 foreach my $func (keys %$fields) {
99 return $self->_sqlcase($func)
100 .'( '.$self->_recurse_fields($fields->{$func}).' )';
109 if (ref $_[0] eq 'HASH') {
110 if (defined $_[0]->{group_by}) {
111 $ret = $self->_sqlcase(' group by ')
112 .$self->_recurse_fields($_[0]->{group_by});
114 if (defined $_[0]->{having}) {
116 ($frag, @extra) = $self->_recurse_where($_[0]->{having});
117 push(@{$self->{having_bind}}, @extra);
118 $ret .= $self->_sqlcase(' having ').$frag;
120 if (defined $_[0]->{order_by}) {
121 $ret .= $self->_order_by($_[0]->{order_by});
123 } elsif (ref $_[0] eq 'SCALAR') {
124 $ret = $self->_sqlcase(' order by ').${ $_[0] };
125 } elsif (ref $_[0] eq 'ARRAY' && @{$_[0]}) {
126 my @order = @{+shift};
127 $ret = $self->_sqlcase(' order by ')
129 my $r = $self->_order_by($_, @_);
130 $r =~ s/^ ?ORDER BY //i;
134 $ret = $self->SUPER::_order_by(@_);
139 sub _order_directions {
140 my ($self, $order) = @_;
141 $order = $order->{order_by} if ref $order eq 'HASH';
142 return $self->SUPER::_order_directions($order);
146 my ($self, $from) = @_;
147 if (ref $from eq 'ARRAY') {
148 return $self->_recurse_from(@$from);
149 } elsif (ref $from eq 'HASH') {
150 return $self->_make_as($from);
152 return $from; # would love to quote here but _table ends up getting called
153 # twice during an ->select without a limit clause due to
154 # the way S::A::Limit->select works. should maybe consider
155 # bypassing this and doing S::A::select($self, ...) in
156 # our select method above. meantime, quoting shims have
157 # been added to select/insert/update/delete here
162 my ($self, $from, @join) = @_;
164 push(@sqlf, $self->_make_as($from));
165 foreach my $j (@join) {
168 # check whether a join type exists
169 my $join_clause = '';
170 my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
171 if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
172 $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
174 $join_clause = ' JOIN ';
176 push(@sqlf, $join_clause);
178 if (ref $to eq 'ARRAY') {
179 push(@sqlf, '(', $self->_recurse_from(@$to), ')');
181 push(@sqlf, $self->_make_as($to));
183 push(@sqlf, ' ON ', $self->_join_condition($on));
185 return join('', @sqlf);
189 my ($self, $from) = @_;
190 return join(' ', map { (ref $_ eq 'SCALAR' ? $$_ : $self->_quote($_)) }
191 reverse each %{$self->_skip_options($from)});
195 my ($self, $hash) = @_;
197 $clean_hash->{$_} = $hash->{$_}
198 for grep {!/^-/} keys %$hash;
202 sub _join_condition {
203 my ($self, $cond) = @_;
204 if (ref $cond eq 'HASH') {
207 my $x = '= '.$self->_quote($cond->{$_}); $j{$_} = \$x;
209 return $self->_recurse_where(\%j);
210 } elsif (ref $cond eq 'ARRAY') {
211 return join(' OR ', map { $self->_join_condition($_) } @$cond);
213 die "Can't handle this yet!";
218 my ($self, $label) = @_;
219 return '' unless defined $label;
220 return "*" if $label eq '*';
221 return $label unless $self->{quote_char};
222 if(ref $self->{quote_char} eq "ARRAY"){
223 return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
224 if !defined $self->{name_sep};
225 my $sep = $self->{name_sep};
226 return join($self->{name_sep},
227 map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
228 split(/\Q$sep\E/,$label));
230 return $self->SUPER::_quote($label);
235 $self->{limit_dialect} = shift if @_;
236 return $self->{limit_dialect};
241 $self->{quote_char} = shift if @_;
242 return $self->{quote_char};
247 $self->{name_sep} = shift if @_;
248 return $self->{name_sep};
251 } # End of BEGIN block
253 use base qw/DBIx::Class/;
255 __PACKAGE__->load_components(qw/AccessorGroup/);
257 __PACKAGE__->mk_group_accessors('simple' =>
258 qw/_connect_info _dbh _sql_maker _sql_maker_opts _conn_pid _conn_tid
259 debug debugobj cursor on_connect_do transaction_depth/);
263 DBIx::Class::Storage::DBI - DBI storage handler
269 This class represents the connection to the database
278 my $new = bless({}, ref $_[0] || $_[0]);
279 $new->cursor("DBIx::Class::Storage::DBI::Cursor");
280 $new->transaction_depth(0);
282 $new->debugobj(new DBIx::Class::Storage::Statistics());
286 my $debug_env = $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG}
289 if (defined($debug_env) && ($debug_env =~ /=(.+)$/)) {
290 $fh = IO::File->new($1, 'w')
291 or $new->throw_exception("Cannot open trace file $1");
293 $fh = IO::File->new('>&STDERR');
296 $new->debug(1) if $debug_env;
297 $new->_sql_maker_opts({});
301 =head2 throw_exception
303 Throws an exception - croaks.
307 sub throw_exception {
308 my ($self, $msg) = @_;
314 The arguments of C<connect_info> are always a single array reference.
316 This is normally accessed via L<DBIx::Class::Schema/connection>, which
317 encapsulates its argument list in an arrayref before calling
318 C<connect_info> here.
320 The arrayref can either contain the same set of arguments one would
321 normally pass to L<DBI/connect>, or a lone code reference which returns
322 a connected database handle.
324 In either case, if the final argument in your connect_info happens
325 to be a hashref, C<connect_info> will look there for several
326 connection-specific options:
332 This can be set to an arrayref of literal sql statements, which will
333 be executed immediately after making the connection to the database
334 every time we [re-]connect.
338 Sets the limit dialect. This is useful for JDBC-bridge among others
339 where the remote SQL-dialect cannot be determined by the name of the
344 Specifies what characters to use to quote table and column names. If
345 you use this you will want to specify L<name_sep> as well.
347 quote_char expects either a single character, in which case is it is placed
348 on either side of the table/column, or an arrayref of length 2 in which case the
349 table/column name is placed between the elements.
351 For example under MySQL you'd use C<quote_char =E<gt> '`'>, and user SQL Server you'd
352 use C<quote_char =E<gt> [qw/[ ]/]>.
356 This only needs to be used in conjunction with L<quote_char>, and is used to
357 specify the charecter that seperates elements (schemas, tables, columns) from
358 each other. In most cases this is simply a C<.>.
362 These options can be mixed in with your other L<DBI> connection attributes,
363 or placed in a seperate hashref after all other normal L<DBI> connection
366 Every time C<connect_info> is invoked, any previous settings for
367 these options will be cleared before setting the new ones, regardless of
368 whether any options are specified in the new C<connect_info>.
372 # Simple SQLite connection
373 ->connect_info([ 'dbi:SQLite:./foo.db' ]);
376 ->connect_info([ sub { DBI->connect(...) } ]);
378 # A bit more complicated
385 { quote_char => q{"}, name_sep => q{.} },
389 # Equivalent to the previous example
395 { AutoCommit => 0, quote_char => q{"}, name_sep => q{.} },
399 # Subref + DBIC-specific connection options
402 sub { DBI->connect(...) },
406 on_connect_do => ['SET search_path TO myschema,otherschema,public'],
413 This method is deprecated in favor of setting via L</connect_info>.
417 Causes SQL trace information to be emitted on the C<debugobj> object.
418 (or C<STDERR> if C<debugobj> has not specifically been set).
420 This is the equivalent to setting L</DBIC_TRACE> in your
425 Set or retrieve the filehandle used for trace/debug output. This should be
426 an IO::Handle compatible ojbect (only the C<print> method is used. Initially
427 set to be STDERR - although see information on the
428 L<DBIC_TRACE> environment variable.
435 if ($self->debugobj->can('debugfh')) {
436 return $self->debugobj->debugfh(@_);
442 Sets or retrieves the object used for metric collection. Defaults to an instance
443 of L<DBIx::Class::Storage::Statistics> that is campatible with the original
444 method of using a coderef as a callback. See the aforementioned Statistics
445 class for more information.
449 Sets a callback to be executed each time a statement is run; takes a sub
450 reference. Callback is executed as $sub->($op, $info) where $op is
451 SELECT/INSERT/UPDATE/DELETE and $info is what would normally be printed.
453 See L<debugobj> for a better way.
460 if ($self->debugobj->can('callback')) {
461 return $self->debugobj->callback(@_);
467 Execute the given subref with the underlying database handle as its
468 first argument, using the new exception-based connection management.
471 my @stuff = $schema->storage->dbh_do(
473 shift->selectrow_array("SELECT * FROM foo")
480 my ($self, $todo) = @_;
483 my $want_array = wantarray;
486 $self->_verify_pid if $self->_dbh;
487 $self->_populate_dbh if !$self->_dbh;
488 my $dbh = $self->_dbh;
489 local $dbh->{RaiseError} = 1;
490 local $dbh->{PrintError} = 0;
492 @result = $todo->($dbh);
494 elsif(defined $want_array) {
495 $result[0] = $todo->($dbh);
505 ? $self->throw_exception($exception)
506 : $self->_populate_dbh;
508 my $dbh = $self->_dbh;
509 local $dbh->{RaiseError} = 1;
510 local $dbh->{PrintError} = 0;
511 return $todo->($dbh);
514 return $want_array ? @result : $result[0];
519 Disconnect the L<DBI> handle, performing a rollback first if the
520 database is not in C<AutoCommit> mode.
527 if( $self->connected ) {
528 $self->_dbh->rollback unless $self->_dbh->{AutoCommit};
529 $self->_dbh->disconnect;
536 Check if the L<DBI> handle is connected. Returns true if the handle
544 if(my $dbh = $self->_dbh) {
545 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
546 return $self->_dbh(undef);
551 return ($dbh->FETCH('Active') && $dbh->ping);
557 # handle pid changes correctly
558 # NOTE: assumes $self->_dbh is a valid $dbh
562 return if $self->_conn_pid == $$;
564 $self->_dbh->{InactiveDestroy} = 1;
570 =head2 ensure_connected
572 Check whether the database handle is connected - if not then make a
577 sub ensure_connected {
580 unless ($self->connected) {
581 $self->_populate_dbh;
587 Returns the dbh - a data base handle of class L<DBI>.
594 $self->ensure_connected;
598 sub _sql_maker_args {
601 return ( limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
606 Returns a C<sql_maker> object - normally an object of class
607 C<DBIC::SQL::Abstract>.
613 unless ($self->_sql_maker) {
614 $self->_sql_maker(new DBIC::SQL::Abstract( $self->_sql_maker_args ));
616 return $self->_sql_maker;
620 my ($self, $info_arg) = @_;
622 return $self->_connect_info if !$info_arg;
624 # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
625 # the new set of options
626 $self->_sql_maker(undef);
627 $self->_sql_maker_opts({});
629 my $info = [ @$info_arg ]; # copy because we can alter it
630 my $last_info = $info->[-1];
631 if(ref $last_info eq 'HASH') {
632 if(my $on_connect_do = delete $last_info->{on_connect_do}) {
633 $self->on_connect_do($on_connect_do);
635 for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
636 if(my $opt_val = delete $last_info->{$sql_maker_opt}) {
637 $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
641 # Get rid of any trailing empty hashref
642 pop(@$info) if !keys %$last_info;
645 $self->_connect_info($info);
650 my @info = @{$self->_connect_info || []};
651 $self->_dbh($self->_connect(@info));
653 if(ref $self eq 'DBIx::Class::Storage::DBI') {
654 my $driver = $self->_dbh->{Driver}->{Name};
655 if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
656 bless $self, "DBIx::Class::Storage::DBI::${driver}";
657 $self->_rebless() if $self->can('_rebless');
661 # if on-connect sql statements are given execute them
662 foreach my $sql_statement (@{$self->on_connect_do || []}) {
663 $self->debugobj->query_start($sql_statement) if $self->debug();
664 $self->_dbh->do($sql_statement);
665 $self->debugobj->query_end($sql_statement) if $self->debug();
668 $self->_conn_pid($$);
669 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
673 my ($self, @info) = @_;
675 $self->throw_exception("You failed to provide any connection info")
678 my ($old_connect_via, $dbh);
680 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
681 $old_connect_via = $DBI::connect_via;
682 $DBI::connect_via = 'connect';
686 $dbh = ref $info[0] eq 'CODE'
688 : DBI->connect(@info);
691 $DBI::connect_via = $old_connect_via if $old_connect_via;
694 $self->throw_exception("DBI Connection failed: " . ($@ || $DBI::errstr));
702 Calls begin_work on the current dbh.
704 See L<DBIx::Class::Schema> for the txn_do() method, which allows for
705 an entire code block to be executed transactionally.
711 if ($self->{transaction_depth}++ == 0) {
714 if ($dbh->{AutoCommit}) {
715 $self->debugobj->txn_begin()
725 Issues a commit against the current dbh.
733 if ($self->{transaction_depth} == 0) {
734 unless ($dbh->{AutoCommit}) {
735 $self->debugobj->txn_commit()
741 if (--$self->{transaction_depth} == 0) {
742 $self->debugobj->txn_commit()
752 Issues a rollback against the current dbh. A nested rollback will
753 throw a L<DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION> exception,
754 which allows the rollback to propagate to the outermost transaction.
764 if ($self->{transaction_depth} == 0) {
765 unless ($dbh->{AutoCommit}) {
766 $self->debugobj->txn_rollback()
772 if (--$self->{transaction_depth} == 0) {
773 $self->debugobj->txn_rollback()
778 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
786 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
787 $error =~ /$exception_class/ and $self->throw_exception($error);
788 $self->{transaction_depth} = 0; # ensure that a failed rollback
789 $self->throw_exception($error); # resets the transaction depth
794 my ($self, $op, $extra_bind, $ident, @args) = @_;
795 my ($sql, @bind) = $self->sql_maker->$op($ident, @args);
796 unshift(@bind, @$extra_bind) if $extra_bind;
798 my @debug_bind = map { defined $_ ? qq{'$_'} : q{'NULL'} } @bind;
799 $self->debugobj->query_start($sql, @debug_bind);
801 my $sth = eval { $self->sth($sql,$op) };
804 $self->throw_exception(
805 'no sth generated via sql (' . ($@ || $self->_dbh->errstr) . "): $sql"
808 @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
812 $rv = eval { $sth->execute(@bind) };
815 $self->throw_exception("Error executing '$sql': ".($@ || $sth->errstr));
818 $self->throw_exception("'$sql' did not generate a statement.");
821 my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind;
822 $self->debugobj->query_end($sql, @debug_bind);
824 return (wantarray ? ($rv, $sth, @bind) : $rv);
828 my ($self, $ident, $to_insert) = @_;
829 $self->throw_exception(
830 "Couldn't insert ".join(', ',
831 map "$_ => $to_insert->{$_}", keys %$to_insert
833 ) unless ($self->_execute('insert' => [], $ident, $to_insert));
838 return shift->_execute('update' => [], @_);
842 return shift->_execute('delete' => [], @_);
846 my ($self, $ident, $select, $condition, $attrs) = @_;
847 my $order = $attrs->{order_by};
848 if (ref $condition eq 'SCALAR') {
849 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
851 if (exists $attrs->{group_by} || $attrs->{having}) {
853 group_by => $attrs->{group_by},
854 having => $attrs->{having},
855 ($order ? (order_by => $order) : ())
858 my @args = ('select', $attrs->{bind}, $ident, $select, $condition, $order);
859 if ($attrs->{software_limit} ||
860 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
861 $attrs->{software_limit} = 1;
863 $self->throw_exception("rows attribute must be positive if present")
864 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
865 push @args, $attrs->{rows}, $attrs->{offset};
867 return $self->_execute(@args);
872 Handle a SQL select statement.
878 my ($ident, $select, $condition, $attrs) = @_;
879 return $self->cursor->new($self, \@_, $attrs);
884 Performs a select, fetch and return of data - handles a single row
889 # Need to call finish() to work round broken DBDs
893 my ($rv, $sth, @bind) = $self->_select(@_);
894 my @row = $sth->fetchrow_array;
901 Returns a L<DBI> sth (statement handle) for the supplied SQL.
906 my ($self, $sql) = @_;
907 # 3 is the if_active parameter which avoids active sth re-use
908 return $self->dbh_do(sub { shift->prepare_cached($sql, {}, 3) });
911 =head2 columns_info_for
913 Returns database type info for a given table columns.
917 sub columns_info_for {
918 my ($self, $table) = @_;
923 if ($dbh->can('column_info')) {
926 my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
927 my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
929 while ( my $info = $sth->fetchrow_hashref() ){
931 $column_info{data_type} = $info->{TYPE_NAME};
932 $column_info{size} = $info->{COLUMN_SIZE};
933 $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
934 $column_info{default_value} = $info->{COLUMN_DEF};
935 my $col_name = $info->{COLUMN_NAME};
936 $col_name =~ s/^\"(.*)\"$/$1/;
938 $result{$col_name} = \%column_info;
941 return \%result if !$@;
945 my $sth = $dbh->prepare("SELECT * FROM $table WHERE 1=0");
947 my @columns = @{$sth->{NAME_lc}};
948 for my $i ( 0 .. $#columns ){
950 my $type_num = $sth->{TYPE}->[$i];
952 if(defined $type_num && $dbh->can('type_info')) {
953 my $type_info = $dbh->type_info($type_num);
954 $type_name = $type_info->{TYPE_NAME} if $type_info;
956 $column_info{data_type} = $type_name ? $type_name : $type_num;
957 $column_info{size} = $sth->{PRECISION}->[$i];
958 $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
960 if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
961 $column_info{data_type} = $1;
962 $column_info{size} = $2;
965 $result{$columns[$i]} = \%column_info;
972 =head2 last_insert_id
974 Return the row id of the last insert.
979 my ($self, $row) = @_;
981 $self->dbh_do(sub { shift->func('last_insert_rowid') });
986 Returns the database driver name.
990 sub sqlt_type { shift->dbh_do(sub { shift->{Driver}->{Name} }) }
992 =head2 create_ddl_dir (EXPERIMENTAL)
996 =item Arguments: $schema \@databases, $version, $directory, $sqlt_args
1000 Creates an SQL file based on the Schema, for each of the specified
1001 database types, in the given directory.
1003 Note that this feature is currently EXPERIMENTAL and may not work correctly
1004 across all databases, or fully handle complex relationships.
1010 my ($self, $schema, $databases, $version, $dir, $sqltargs) = @_;
1012 if(!$dir || !-d $dir)
1014 warn "No directory given, using ./\n";
1017 $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
1018 $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
1019 $version ||= $schema->VERSION || '1.x';
1020 $sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} };
1022 eval "use SQL::Translator";
1023 $self->throw_exception("Can't deploy without SQL::Translator: $@") if $@;
1025 my $sqlt = SQL::Translator->new($sqltargs);
1026 foreach my $db (@$databases)
1029 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
1030 # $sqlt->parser_args({'DBIx::Class' => $schema);
1031 $sqlt->data($schema);
1032 $sqlt->producer($db);
1035 my $filename = $schema->ddl_filename($db, $dir, $version);
1038 $self->throw_exception("$filename already exists, skipping $db");
1041 open($file, ">$filename")
1042 or $self->throw_exception("Can't open $filename for writing ($!)");
1043 my $output = $sqlt->translate;
1045 # print join(":", keys %{$schema->source_registrations});
1046 # print Dumper($sqlt->schema);
1049 $self->throw_exception("Failed to translate to $db. (" . $sqlt->error . ")");
1052 print $file $output;
1058 =head2 deployment_statements
1060 Create the statements for L</deploy> and
1061 L<DBIx::Class::Schema/deploy>.
1065 sub deployment_statements {
1066 my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
1067 # Need to be connected to get the correct sqlt_type
1068 $self->ensure_connected() unless $type;
1069 $type ||= $self->sqlt_type;
1070 $version ||= $schema->VERSION || '1.x';
1072 eval "use SQL::Translator";
1075 eval "use SQL::Translator::Parser::DBIx::Class;";
1076 $self->throw_exception($@) if $@;
1077 eval "use SQL::Translator::Producer::${type};";
1078 $self->throw_exception($@) if $@;
1079 my $tr = SQL::Translator->new(%$sqltargs);
1080 SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
1081 return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
1084 my $filename = $schema->ddl_filename($type, $dir, $version);
1087 # $schema->create_ddl_dir([ $type ], $version, $dir, $sqltargs);
1088 $self->throw_exception("No SQL::Translator, and no Schema file found, aborting deploy");
1092 open($file, "<$filename")
1093 or $self->throw_exception("Can't open $filename ($!)");
1097 return join('', @rows);
1103 Sends the appropriate statements to create or modify tables to the
1104 db. This would normally be called through
1105 L<DBIx::Class::Schema/deploy>.
1110 my ($self, $schema, $type, $sqltargs) = @_;
1111 foreach my $statement ( $self->deployment_statements($schema, $type, undef, undef, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
1112 for ( split(";\n", $statement)) {
1113 next if($_ =~ /^--/);
1115 # next if($_ =~ /^DROP/m);
1116 next if($_ =~ /^BEGIN TRANSACTION/m);
1117 next if($_ =~ /^COMMIT/m);
1118 next if $_ =~ /^\s+$/; # skip whitespace only
1119 $self->debugobj->query_start($_) if $self->debug;
1120 $self->dbh->do($_) or warn "SQL was:\n $_"; # XXX exceptions?
1121 $self->debugobj->query_end($_) if $self->debug;
1126 =head2 datetime_parser
1128 Returns the datetime parser class
1132 sub datetime_parser {
1134 return $self->{datetime_parser} ||= $self->build_datetime_parser(@_);
1137 =head2 datetime_parser_type
1139 Defines (returns) the datetime parser class - currently hardwired to
1140 L<DateTime::Format::MySQL>
1144 sub datetime_parser_type { "DateTime::Format::MySQL"; }
1146 =head2 build_datetime_parser
1148 See L</datetime_parser>
1152 sub build_datetime_parser {
1154 my $type = $self->datetime_parser_type(@_);
1156 $self->throw_exception("Couldn't load ${type}: $@") if $@;
1160 sub DESTROY { shift->_dbh(undef) }
1166 The module defines a set of methods within the DBIC::SQL::Abstract
1167 namespace. These build on L<SQL::Abstract::Limit> to provide the
1168 SQL query functions.
1170 The following methods are extended:-
1184 See L</connect_info> for details.
1185 For setting, this method is deprecated in favor of L</connect_info>.
1189 See L</connect_info> for details.
1190 For setting, this method is deprecated in favor of L</connect_info>.
1194 See L</connect_info> for details.
1195 For setting, this method is deprecated in favor of L</connect_info>.
1199 =head1 ENVIRONMENT VARIABLES
1203 If C<DBIC_TRACE> is set then SQL trace information
1204 is produced (as when the L<debug> method is set).
1206 If the value is of the form C<1=/path/name> then the trace output is
1207 written to the file C</path/name>.
1209 This environment variable is checked when the storage object is first
1210 created (when you call connect on your schema). So, run-time changes
1211 to this environment variable will not take effect unless you also
1212 re-connect on your schema.
1214 =head2 DBIX_CLASS_STORAGE_DBI_DEBUG
1216 Old name for DBIC_TRACE
1220 Matt S. Trout <mst@shadowcatsystems.co.uk>
1222 Andy Grundman <andy@hybridized.org>
1226 You may distribute this code under the same terms as Perl itself.