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
468 database handle as its first argument, using our
469 normal exception-based connection management. Example:
471 $schema->storage->dbh_do(sub { shift->do("blah blah") });
476 my ($self, $todo) = @_;
479 my $want_array = wantarray;
483 $self->_populate_dbh if !$self->_dbh;
484 my $dbh = $self->_dbh;
485 local $dbh->{RaiseError} = 1;
486 local $dbh->{PrintError} = 0;
488 @result = $todo->($dbh);
491 $result[0] = $todo->($dbh);
497 ? $self->throw_exception($exception)
498 : $self->_populate_dbh;
500 my $dbh = $self->_dbh;
501 local $dbh->{RaiseError} = 1;
502 local $dbh->{PrintError} = 0;
503 return $todo->($self->_dbh);
505 return $want_array ? @result : $result[0];
510 Disconnect the L<DBI> handle, performing a rollback first if the
511 database is not in C<AutoCommit> mode.
518 if( $self->connected ) {
519 $self->_dbh->rollback unless $self->_dbh->{AutoCommit};
520 $self->_dbh->disconnect;
527 Check if the L<DBI> handle is connected. Returns true if the handle
535 if(my $dbh = $self->_dbh) {
536 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
537 return $self->_dbh(undef);
540 return ($dbh->FETCH('Active') && $dbh->ping);
546 # handle pid changes correctly
550 return if !$self->_dbh || $self->_conn_pid == $$;
553 $self->_dbh->{InactiveDestroy} = 1;
558 =head2 ensure_connected
560 Check whether the database handle is connected - if not then make a
565 sub ensure_connected {
568 unless ($self->connected) {
569 $self->_populate_dbh;
575 Returns the dbh - a data base handle of class L<DBI>.
582 $self->ensure_connected;
586 sub _sql_maker_args {
589 return ( limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
594 Returns a C<sql_maker> object - normally an object of class
595 C<DBIC::SQL::Abstract>.
601 unless ($self->_sql_maker) {
602 $self->_sql_maker(new DBIC::SQL::Abstract( $self->_sql_maker_args ));
604 return $self->_sql_maker;
608 my ($self, $info_arg) = @_;
610 return $self->_connect_info if !$info_arg;
612 # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
613 # the new set of options
614 $self->_sql_maker(undef);
615 $self->_sql_maker_opts({});
617 my $info = [ @$info_arg ]; # copy because we can alter it
618 my $last_info = $info->[-1];
619 if(ref $last_info eq 'HASH') {
620 if(my $on_connect_do = delete $last_info->{on_connect_do}) {
621 $self->on_connect_do($on_connect_do);
623 for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
624 if(my $opt_val = delete $last_info->{$sql_maker_opt}) {
625 $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
629 # Get rid of any trailing empty hashref
630 pop(@$info) if !keys %$last_info;
633 $self->_connect_info($info);
638 my @info = @{$self->_connect_info || []};
639 $self->_dbh($self->_connect(@info));
641 if(ref $self eq 'DBIx::Class::Storage::DBI') {
642 my $driver = $self->_dbh->{Driver}->{Name};
643 if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
644 bless $self, "DBIx::Class::Storage::DBI::${driver}";
645 $self->_rebless() if $self->can('_rebless');
649 # if on-connect sql statements are given execute them
650 foreach my $sql_statement (@{$self->on_connect_do || []}) {
651 $self->debugobj->query_start($sql_statement) if $self->debug();
652 $self->_dbh->do($sql_statement);
653 $self->debugobj->query_end($sql_statement) if $self->debug();
656 $self->_conn_pid($$);
657 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
661 my ($self, @info) = @_;
663 $self->throw_exception("You failed to provide any connection info")
666 my ($old_connect_via, $dbh);
668 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
669 $old_connect_via = $DBI::connect_via;
670 $DBI::connect_via = 'connect';
674 $dbh = ref $info[0] eq 'CODE'
676 : DBI->connect(@info);
679 $DBI::connect_via = $old_connect_via if $old_connect_via;
682 $self->throw_exception("DBI Connection failed: " . ($@ || $DBI::errstr));
690 Calls begin_work on the current dbh.
692 See L<DBIx::Class::Schema> for the txn_do() method, which allows for
693 an entire code block to be executed transactionally.
699 if ($self->{transaction_depth}++ == 0) {
702 if ($dbh->{AutoCommit}) {
703 $self->debugobj->txn_begin()
713 Issues a commit against the current dbh.
721 if ($self->{transaction_depth} == 0) {
722 unless ($dbh->{AutoCommit}) {
723 $self->debugobj->txn_commit()
729 if (--$self->{transaction_depth} == 0) {
730 $self->debugobj->txn_commit()
740 Issues a rollback against the current dbh. A nested rollback will
741 throw a L<DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION> exception,
742 which allows the rollback to propagate to the outermost transaction.
752 if ($self->{transaction_depth} == 0) {
753 unless ($dbh->{AutoCommit}) {
754 $self->debugobj->txn_rollback()
760 if (--$self->{transaction_depth} == 0) {
761 $self->debugobj->txn_rollback()
766 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
774 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
775 $error =~ /$exception_class/ and $self->throw_exception($error);
776 $self->{transaction_depth} = 0; # ensure that a failed rollback
777 $self->throw_exception($error); # resets the transaction depth
782 my ($self, $op, $extra_bind, $ident, @args) = @_;
783 my ($sql, @bind) = $self->sql_maker->$op($ident, @args);
784 unshift(@bind, @$extra_bind) if $extra_bind;
786 my @debug_bind = map { defined $_ ? qq{'$_'} : q{'NULL'} } @bind;
787 $self->debugobj->query_start($sql, @debug_bind);
789 my $sth = eval { $self->sth($sql,$op) };
792 $self->throw_exception(
793 'no sth generated via sql (' . ($@ || $self->_dbh->errstr) . "): $sql"
796 @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
800 $rv = eval { $sth->execute(@bind) };
803 $self->throw_exception("Error executing '$sql': ".($@ || $sth->errstr));
806 $self->throw_exception("'$sql' did not generate a statement.");
809 my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind;
810 $self->debugobj->query_end($sql, @debug_bind);
812 return (wantarray ? ($rv, $sth, @bind) : $rv);
816 my ($self, $ident, $to_insert) = @_;
817 $self->throw_exception(
818 "Couldn't insert ".join(', ',
819 map "$_ => $to_insert->{$_}", keys %$to_insert
821 ) unless ($self->_execute('insert' => [], $ident, $to_insert));
826 return shift->_execute('update' => [], @_);
830 return shift->_execute('delete' => [], @_);
834 my ($self, $ident, $select, $condition, $attrs) = @_;
835 my $order = $attrs->{order_by};
836 if (ref $condition eq 'SCALAR') {
837 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
839 if (exists $attrs->{group_by} || $attrs->{having}) {
841 group_by => $attrs->{group_by},
842 having => $attrs->{having},
843 ($order ? (order_by => $order) : ())
846 my @args = ('select', $attrs->{bind}, $ident, $select, $condition, $order);
847 if ($attrs->{software_limit} ||
848 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
849 $attrs->{software_limit} = 1;
851 $self->throw_exception("rows attribute must be positive if present")
852 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
853 push @args, $attrs->{rows}, $attrs->{offset};
855 return $self->_execute(@args);
860 Handle a SQL select statement.
866 my ($ident, $select, $condition, $attrs) = @_;
867 return $self->cursor->new($self, \@_, $attrs);
872 Performs a select, fetch and return of data - handles a single row
877 # Need to call finish() to work round broken DBDs
881 my ($rv, $sth, @bind) = $self->_select(@_);
882 my @row = $sth->fetchrow_array;
889 Returns a L<DBI> sth (statement handle) for the supplied SQL.
894 my ($self, $sql) = @_;
895 # 3 is the if_active parameter which avoids active sth re-use
896 return $self->dbh_do(sub { shift->prepare_cached($sql, {}, 3) });
899 =head2 columns_info_for
901 Returns database type info for a given table columns.
905 sub columns_info_for {
906 my ($self, $table) = @_;
908 my $dbh = $self->dbh;
910 if ($dbh->can('column_info')) {
912 local $dbh->{RaiseError} = 1;
913 local $dbh->{PrintError} = 0;
915 my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
916 my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
918 while ( my $info = $sth->fetchrow_hashref() ){
920 $column_info{data_type} = $info->{TYPE_NAME};
921 $column_info{size} = $info->{COLUMN_SIZE};
922 $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
923 $column_info{default_value} = $info->{COLUMN_DEF};
924 my $col_name = $info->{COLUMN_NAME};
925 $col_name =~ s/^\"(.*)\"$/$1/;
927 $result{$col_name} = \%column_info;
930 return \%result if !$@;
934 my $sth = $dbh->prepare("SELECT * FROM $table WHERE 1=0");
936 my @columns = @{$sth->{NAME_lc}};
937 for my $i ( 0 .. $#columns ){
939 my $type_num = $sth->{TYPE}->[$i];
941 if(defined $type_num && $dbh->can('type_info')) {
942 my $type_info = $dbh->type_info($type_num);
943 $type_name = $type_info->{TYPE_NAME} if $type_info;
945 $column_info{data_type} = $type_name ? $type_name : $type_num;
946 $column_info{size} = $sth->{PRECISION}->[$i];
947 $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
949 if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
950 $column_info{data_type} = $1;
951 $column_info{size} = $2;
954 $result{$columns[$i]} = \%column_info;
960 =head2 last_insert_id
962 Return the row id of the last insert.
967 my ($self, $row) = @_;
969 $self->dbh_do(sub { shift->func('last_insert_rowid') });
974 Returns the database driver name.
978 sub sqlt_type { shift->dbh_do(sub { shift->{Driver}->{Name} }) }
980 =head2 create_ddl_dir (EXPERIMENTAL)
984 =item Arguments: $schema \@databases, $version, $directory, $sqlt_args
988 Creates an SQL file based on the Schema, for each of the specified
989 database types, in the given directory.
991 Note that this feature is currently EXPERIMENTAL and may not work correctly
992 across all databases, or fully handle complex relationships.
998 my ($self, $schema, $databases, $version, $dir, $sqltargs) = @_;
1000 if(!$dir || !-d $dir)
1002 warn "No directory given, using ./\n";
1005 $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
1006 $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
1007 $version ||= $schema->VERSION || '1.x';
1009 eval "use SQL::Translator";
1010 $self->throw_exception("Can't deploy without SQL::Translator: $@") if $@;
1012 my $sqlt = SQL::Translator->new({
1014 add_drop_table => 1,
1016 foreach my $db (@$databases)
1019 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
1020 # $sqlt->parser_args({'DBIx::Class' => $schema);
1021 $sqlt->data($schema);
1022 $sqlt->producer($db);
1025 my $filename = $schema->ddl_filename($db, $dir, $version);
1028 $self->throw_exception("$filename already exists, skipping $db");
1031 open($file, ">$filename")
1032 or $self->throw_exception("Can't open $filename for writing ($!)");
1033 my $output = $sqlt->translate;
1035 # print join(":", keys %{$schema->source_registrations});
1036 # print Dumper($sqlt->schema);
1039 $self->throw_exception("Failed to translate to $db. (" . $sqlt->error . ")");
1042 print $file $output;
1048 =head2 deployment_statements
1050 Create the statements for L</deploy> and
1051 L<DBIx::Class::Schema/deploy>.
1055 sub deployment_statements {
1056 my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
1057 # Need to be connected to get the correct sqlt_type
1058 $self->ensure_connected() unless $type;
1059 $type ||= $self->sqlt_type;
1060 $version ||= $schema->VERSION || '1.x';
1062 eval "use SQL::Translator";
1065 eval "use SQL::Translator::Parser::DBIx::Class;";
1066 $self->throw_exception($@) if $@;
1067 eval "use SQL::Translator::Producer::${type};";
1068 $self->throw_exception($@) if $@;
1069 my $tr = SQL::Translator->new(%$sqltargs);
1070 SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
1071 return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
1074 my $filename = $schema->ddl_filename($type, $dir, $version);
1077 # $schema->create_ddl_dir([ $type ], $version, $dir, $sqltargs);
1078 $self->throw_exception("No SQL::Translator, and no Schema file found, aborting deploy");
1082 open($file, "<$filename")
1083 or $self->throw_exception("Can't open $filename ($!)");
1087 return join('', @rows);
1093 Sends the appropriate statements to create or modify tables to the
1094 db. This would normally be called through
1095 L<DBIx::Class::Schema/deploy>.
1100 my ($self, $schema, $type, $sqltargs) = @_;
1101 foreach my $statement ( $self->deployment_statements($schema, $type, undef, undef, { no_comments => 1, %$sqltargs }) ) {
1102 for ( split(";\n", $statement)) {
1103 next if($_ =~ /^--/);
1105 # next if($_ =~ /^DROP/m);
1106 next if($_ =~ /^BEGIN TRANSACTION/m);
1107 next if($_ =~ /^COMMIT/m);
1108 next if $_ =~ /^\s+$/; # skip whitespace only
1109 $self->debugobj->query_start($_) if $self->debug;
1110 $self->dbh->do($_) or warn "SQL was:\n $_"; # XXX exceptions?
1111 $self->debugobj->query_end($_) if $self->debug;
1116 =head2 datetime_parser
1118 Returns the datetime parser class
1122 sub datetime_parser {
1124 return $self->{datetime_parser} ||= $self->build_datetime_parser(@_);
1127 =head2 datetime_parser_type
1129 Defines (returns) the datetime parser class - currently hardwired to
1130 L<DateTime::Format::MySQL>
1134 sub datetime_parser_type { "DateTime::Format::MySQL"; }
1136 =head2 build_datetime_parser
1138 See L</datetime_parser>
1142 sub build_datetime_parser {
1144 my $type = $self->datetime_parser_type(@_);
1146 $self->throw_exception("Couldn't load ${type}: $@") if $@;
1150 sub DESTROY { shift->disconnect }
1156 The module defines a set of methods within the DBIC::SQL::Abstract
1157 namespace. These build on L<SQL::Abstract::Limit> to provide the
1158 SQL query functions.
1160 The following methods are extended:-
1174 See L</connect_info> for details.
1175 For setting, this method is deprecated in favor of L</connect_info>.
1179 See L</connect_info> for details.
1180 For setting, this method is deprecated in favor of L</connect_info>.
1184 See L</connect_info> for details.
1185 For setting, this method is deprecated in favor of L</connect_info>.
1189 =head1 ENVIRONMENT VARIABLES
1193 If C<DBIC_TRACE> is set then SQL trace information
1194 is produced (as when the L<debug> method is set).
1196 If the value is of the form C<1=/path/name> then the trace output is
1197 written to the file C</path/name>.
1199 This environment variable is checked when the storage object is first
1200 created (when you call connect on your schema). So, run-time changes
1201 to this environment variable will not take effect unless you also
1202 re-connect on your schema.
1204 =head2 DBIX_CLASS_STORAGE_DBI_DEBUG
1206 Old name for DBIC_TRACE
1210 Matt S. Trout <mst@shadowcatsystems.co.uk>
1212 Andy Grundman <andy@hybridized.org>
1216 You may distribute this code under the same terms as Perl itself.