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 Disconnect the L<DBI> handle, performing a rollback first if the
468 database is not in C<AutoCommit> mode.
475 if( $self->connected ) {
476 $self->_dbh->rollback unless $self->_dbh->{AutoCommit};
477 $self->_dbh->disconnect;
484 Check if the L<DBI> handle is connected. Returns true if the handle
489 sub connected { my ($self) = @_;
491 if(my $dbh = $self->_dbh) {
492 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
493 return $self->_dbh(undef);
495 elsif($self->_conn_pid != $$) {
496 $self->_dbh->{InactiveDestroy} = 1;
497 return $self->_dbh(undef);
499 return ($dbh->FETCH('Active') && $dbh->ping);
505 =head2 ensure_connected
507 Check whether the database handle is connected - if not then make a
512 sub ensure_connected {
515 unless ($self->connected) {
516 $self->_populate_dbh;
522 Returns the dbh - a data base handle of class L<DBI>.
529 $self->ensure_connected;
533 sub _sql_maker_args {
536 return ( limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
541 Returns a C<sql_maker> object - normally an object of class
542 C<DBIC::SQL::Abstract>.
548 unless ($self->_sql_maker) {
549 $self->_sql_maker(new DBIC::SQL::Abstract( $self->_sql_maker_args ));
551 return $self->_sql_maker;
555 my ($self, $info_arg) = @_;
558 # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
559 # the new set of options
560 $self->_sql_maker(undef);
561 $self->_sql_maker_opts({});
563 my $info = [ @$info_arg ]; # copy because we can alter it
564 my $last_info = $info->[-1];
565 if(ref $last_info eq 'HASH') {
566 if(my $on_connect_do = delete $last_info->{on_connect_do}) {
567 $self->on_connect_do($on_connect_do);
569 for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
570 if(my $opt_val = delete $last_info->{$sql_maker_opt}) {
571 $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
575 # Get rid of any trailing empty hashref
576 pop(@$info) if !keys %$last_info;
579 $self->_connect_info($info);
582 $self->_connect_info;
587 my @info = @{$self->_connect_info || []};
588 $self->_dbh($self->_connect(@info));
590 if(ref $self eq 'DBIx::Class::Storage::DBI') {
591 my $driver = $self->_dbh->{Driver}->{Name};
592 if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
593 bless $self, "DBIx::Class::Storage::DBI::${driver}";
594 $self->_rebless() if $self->can('_rebless');
598 # if on-connect sql statements are given execute them
599 foreach my $sql_statement (@{$self->on_connect_do || []}) {
600 $self->debugobj->query_start($sql_statement) if $self->debug();
601 $self->_dbh->do($sql_statement);
602 $self->debugobj->query_end($sql_statement) if $self->debug();
605 $self->_conn_pid($$);
606 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
610 my ($self, @info) = @_;
612 $self->throw_exception("You failed to provide any connection info")
615 my ($old_connect_via, $dbh);
617 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
618 $old_connect_via = $DBI::connect_via;
619 $DBI::connect_via = 'connect';
623 $dbh = ref $info[0] eq 'CODE'
625 : DBI->connect(@info);
628 $DBI::connect_via = $old_connect_via if $old_connect_via;
631 $self->throw_exception("DBI Connection failed: " . ($@ || $DBI::errstr));
639 Calls begin_work on the current dbh.
641 See L<DBIx::Class::Schema> for the txn_do() method, which allows for
642 an entire code block to be executed transactionally.
648 if ($self->{transaction_depth}++ == 0) {
649 my $dbh = $self->dbh;
650 if ($dbh->{AutoCommit}) {
651 $self->debugobj->txn_begin()
660 Issues a commit against the current dbh.
666 my $dbh = $self->dbh;
667 if ($self->{transaction_depth} == 0) {
668 unless ($dbh->{AutoCommit}) {
669 $self->debugobj->txn_commit()
675 if (--$self->{transaction_depth} == 0) {
676 $self->debugobj->txn_commit()
685 Issues a rollback against the current dbh. A nested rollback will
686 throw a L<DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION> exception,
687 which allows the rollback to propagate to the outermost transaction.
695 my $dbh = $self->dbh;
696 if ($self->{transaction_depth} == 0) {
697 unless ($dbh->{AutoCommit}) {
698 $self->debugobj->txn_rollback()
704 if (--$self->{transaction_depth} == 0) {
705 $self->debugobj->txn_rollback()
710 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
717 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
718 $error =~ /$exception_class/ and $self->throw_exception($error);
719 $self->{transaction_depth} = 0; # ensure that a failed rollback
720 $self->throw_exception($error); # resets the transaction depth
725 my ($self, $op, $extra_bind, $ident, @args) = @_;
726 my ($sql, @bind) = $self->sql_maker->$op($ident, @args);
727 unshift(@bind, @$extra_bind) if $extra_bind;
729 my @debug_bind = map { defined $_ ? qq{'$_'} : q{'NULL'} } @bind;
730 $self->debugobj->query_start($sql, @debug_bind);
732 my $sth = eval { $self->sth($sql,$op) };
735 $self->throw_exception(
736 'no sth generated via sql (' . ($@ || $self->_dbh->errstr) . "): $sql"
739 @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
743 $rv = eval { $sth->execute(@bind) };
746 $self->throw_exception("Error executing '$sql': ".($@ || $sth->errstr));
749 $self->throw_exception("'$sql' did not generate a statement.");
752 my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind;
753 $self->debugobj->query_end($sql, @debug_bind);
755 return (wantarray ? ($rv, $sth, @bind) : $rv);
759 my ($self, $ident, $to_insert) = @_;
760 $self->throw_exception(
761 "Couldn't insert ".join(', ',
762 map "$_ => $to_insert->{$_}", keys %$to_insert
764 ) unless ($self->_execute('insert' => [], $ident, $to_insert));
769 return shift->_execute('update' => [], @_);
773 return shift->_execute('delete' => [], @_);
777 my ($self, $ident, $select, $condition, $attrs) = @_;
778 my $order = $attrs->{order_by};
779 if (ref $condition eq 'SCALAR') {
780 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
782 if (exists $attrs->{group_by} || $attrs->{having}) {
784 group_by => $attrs->{group_by},
785 having => $attrs->{having},
786 ($order ? (order_by => $order) : ())
789 my @args = ('select', $attrs->{bind}, $ident, $select, $condition, $order);
790 if ($attrs->{software_limit} ||
791 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
792 $attrs->{software_limit} = 1;
794 $self->throw_exception("rows attribute must be positive if present")
795 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
796 push @args, $attrs->{rows}, $attrs->{offset};
798 return $self->_execute(@args);
803 Handle a SQL select statement.
809 my ($ident, $select, $condition, $attrs) = @_;
810 return $self->cursor->new($self, \@_, $attrs);
815 Performs a select, fetch and return of data - handles a single row
820 # Need to call finish() to work round broken DBDs
824 my ($rv, $sth, @bind) = $self->_select(@_);
825 my @row = $sth->fetchrow_array;
832 Returns a L<DBI> sth (statement handle) for the supplied SQL.
837 my ($self, $sql) = @_;
838 # 3 is the if_active parameter which avoids active sth re-use
839 return $self->dbh->prepare_cached($sql, {}, 3);
842 =head2 columns_info_for
844 Returns database type info for a given table columns.
848 sub columns_info_for {
849 my ($self, $table) = @_;
851 my $dbh = $self->dbh;
853 if ($dbh->can('column_info')) {
855 my $old_raise_err = $dbh->{RaiseError};
856 my $old_print_err = $dbh->{PrintError};
857 $dbh->{RaiseError} = 1;
858 $dbh->{PrintError} = 0;
860 my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
861 my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
864 # Some error occured or there is no information:
866 die "column_info returned no rows for $schema, $tab";
869 while ( my $info = $sth->fetchrow_hashref() ){
871 $column_info{data_type} = $info->{TYPE_NAME};
872 $column_info{size} = $info->{COLUMN_SIZE};
873 $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
874 $column_info{default_value} = $info->{COLUMN_DEF};
875 my $col_name = $info->{COLUMN_NAME};
876 $col_name =~ s/^\"(.*)\"$/$1/;
878 $result{$col_name} = \%column_info;
881 $dbh->{RaiseError} = $old_raise_err;
882 $dbh->{PrintError} = $old_print_err;
883 return \%result if !$@;
887 my $sth = $dbh->prepare("SELECT * FROM $table WHERE 1=0");
889 my @columns = @{$sth->{NAME_lc}};
890 for my $i ( 0 .. $#columns ){
892 my $type_num = $sth->{TYPE}->[$i];
894 if(defined $type_num && $dbh->can('type_info')) {
895 my $type_info = $dbh->type_info($type_num);
896 $type_name = $type_info->{TYPE_NAME} if $type_info;
898 $column_info{data_type} = $type_name ? $type_name : $type_num;
899 $column_info{size} = $sth->{PRECISION}->[$i];
900 $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
902 if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
903 $column_info{data_type} = $1;
904 $column_info{size} = $2;
907 $result{$columns[$i]} = \%column_info;
913 =head2 last_insert_id
915 Return the row id of the last insert.
920 my ($self, $row) = @_;
922 return $self->dbh->func('last_insert_rowid');
928 Returns the database driver name.
932 sub sqlt_type { shift->dbh->{Driver}->{Name} }
934 =head2 create_ddl_dir (EXPERIMENTAL)
938 =item Arguments: $schema \@databases, $version, $directory, $sqlt_args
942 Creates an SQL file based on the Schema, for each of the specified
943 database types, in the given directory.
945 Note that this feature is currently EXPERIMENTAL and may not work correctly
946 across all databases, or fully handle complex relationships.
952 my ($self, $schema, $databases, $version, $dir, $sqltargs) = @_;
954 if(!$dir || !-d $dir)
956 warn "No directory given, using ./\n";
959 $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
960 $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
961 $version ||= $schema->VERSION || '1.x';
962 $sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} };
964 eval "use SQL::Translator";
965 $self->throw_exception("Can't deploy without SQL::Translator: $@") if $@;
967 my $sqlt = SQL::Translator->new($sqltargs);
968 foreach my $db (@$databases)
971 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
972 # $sqlt->parser_args({'DBIx::Class' => $schema);
973 $sqlt->data($schema);
974 $sqlt->producer($db);
977 my $filename = $schema->ddl_filename($db, $dir, $version);
980 $self->throw_exception("$filename already exists, skipping $db");
983 open($file, ">$filename")
984 or $self->throw_exception("Can't open $filename for writing ($!)");
985 my $output = $sqlt->translate;
987 # print join(":", keys %{$schema->source_registrations});
988 # print Dumper($sqlt->schema);
991 $self->throw_exception("Failed to translate to $db. (" . $sqlt->error . ")");
1000 =head2 deployment_statements
1002 Create the statements for L</deploy> and
1003 L<DBIx::Class::Schema/deploy>.
1007 sub deployment_statements {
1008 my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
1009 # Need to be connected to get the correct sqlt_type
1010 $self->ensure_connected() unless $type;
1011 $type ||= $self->sqlt_type;
1012 $version ||= $schema->VERSION || '1.x';
1014 eval "use SQL::Translator";
1017 eval "use SQL::Translator::Parser::DBIx::Class;";
1018 $self->throw_exception($@) if $@;
1019 eval "use SQL::Translator::Producer::${type};";
1020 $self->throw_exception($@) if $@;
1021 my $tr = SQL::Translator->new(%$sqltargs);
1022 SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
1023 return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
1026 my $filename = $schema->ddl_filename($type, $dir, $version);
1029 # $schema->create_ddl_dir([ $type ], $version, $dir, $sqltargs);
1030 $self->throw_exception("No SQL::Translator, and no Schema file found, aborting deploy");
1034 open($file, "<$filename")
1035 or $self->throw_exception("Can't open $filename ($!)");
1039 return join('', @rows);
1045 Sends the appropriate statements to create or modify tables to the
1046 db. This would normally be called through
1047 L<DBIx::Class::Schema/deploy>.
1052 my ($self, $schema, $type, $sqltargs) = @_;
1053 foreach my $statement ( $self->deployment_statements($schema, $type, undef, undef, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
1054 for ( split(";\n", $statement)) {
1055 next if($_ =~ /^--/);
1057 # next if($_ =~ /^DROP/m);
1058 next if($_ =~ /^BEGIN TRANSACTION/m);
1059 next if($_ =~ /^COMMIT/m);
1060 next if $_ =~ /^\s+$/; # skip whitespace only
1061 $self->debugobj->query_start($_) if $self->debug;
1062 $self->dbh->do($_) or warn "SQL was:\n $_";
1063 $self->debugobj->query_end($_) if $self->debug;
1068 =head2 datetime_parser
1070 Returns the datetime parser class
1074 sub datetime_parser {
1076 return $self->{datetime_parser} ||= $self->build_datetime_parser(@_);
1079 =head2 datetime_parser_type
1081 Defines (returns) the datetime parser class - currently hardwired to
1082 L<DateTime::Format::MySQL>
1086 sub datetime_parser_type { "DateTime::Format::MySQL"; }
1088 =head2 build_datetime_parser
1090 See L</datetime_parser>
1094 sub build_datetime_parser {
1096 my $type = $self->datetime_parser_type(@_);
1098 $self->throw_exception("Couldn't load ${type}: $@") if $@;
1102 sub DESTROY { shift->disconnect }
1108 The module defines a set of methods within the DBIC::SQL::Abstract
1109 namespace. These build on L<SQL::Abstract::Limit> to provide the
1110 SQL query functions.
1112 The following methods are extended:-
1126 See L</connect_info> for details.
1127 For setting, this method is deprecated in favor of L</connect_info>.
1131 See L</connect_info> for details.
1132 For setting, this method is deprecated in favor of L</connect_info>.
1136 See L</connect_info> for details.
1137 For setting, this method is deprecated in favor of L</connect_info>.
1141 =head1 ENVIRONMENT VARIABLES
1145 If C<DBIC_TRACE> is set then SQL trace information
1146 is produced (as when the L<debug> method is set).
1148 If the value is of the form C<1=/path/name> then the trace output is
1149 written to the file C</path/name>.
1151 This environment variable is checked when the storage object is first
1152 created (when you call connect on your schema). So, run-time changes
1153 to this environment variable will not take effect unless you also
1154 re-connect on your schema.
1156 =head2 DBIX_CLASS_STORAGE_DBI_DEBUG
1158 Old name for DBIC_TRACE
1162 Matt S. Trout <mst@shadowcatsystems.co.uk>
1164 Andy Grundman <andy@hybridized.org>
1168 You may distribute this code under the same terms as Perl itself.