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
56 my ($self, $syntax) = @_;
57 my $dbhname = ref $syntax eq 'HASH' ? $syntax->{Driver}{Name} : '';
58 if(ref($self) && $dbhname && $dbhname eq 'DB2') {
59 return 'RowNumberOver';
62 $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
66 my ($self, $table, $fields, $where, $order, @rest) = @_;
67 $table = $self->_quote($table) unless ref($table);
68 local $self->{rownum_hack_count} = 1
69 if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
70 @rest = (-1) unless defined $rest[0];
71 die "LIMIT 0 Does Not Compute" if $rest[0] == 0;
72 # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
73 local $self->{having_bind} = [];
74 my ($sql, @ret) = $self->SUPER::select(
75 $table, $self->_recurse_fields($fields), $where, $order, @rest
77 return wantarray ? ($sql, @ret, @{$self->{having_bind}}) : $sql;
83 $table = $self->_quote($table) unless ref($table);
84 $self->SUPER::insert($table, @_);
90 $table = $self->_quote($table) unless ref($table);
91 $self->SUPER::update($table, @_);
97 $table = $self->_quote($table) unless ref($table);
98 $self->SUPER::delete($table, @_);
104 return $_[1].$self->_order_by($_[2]);
106 return $self->SUPER::_emulate_limit(@_);
110 sub _recurse_fields {
111 my ($self, $fields) = @_;
112 my $ref = ref $fields;
113 return $self->_quote($fields) unless $ref;
114 return $$fields if $ref eq 'SCALAR';
116 if ($ref eq 'ARRAY') {
117 return join(', ', map {
118 $self->_recurse_fields($_)
119 .(exists $self->{rownum_hack_count}
120 ? ' AS col'.$self->{rownum_hack_count}++
123 } elsif ($ref eq 'HASH') {
124 foreach my $func (keys %$fields) {
125 return $self->_sqlcase($func)
126 .'( '.$self->_recurse_fields($fields->{$func}).' )';
135 if (ref $_[0] eq 'HASH') {
136 if (defined $_[0]->{group_by}) {
137 $ret = $self->_sqlcase(' group by ')
138 .$self->_recurse_fields($_[0]->{group_by});
140 if (defined $_[0]->{having}) {
142 ($frag, @extra) = $self->_recurse_where($_[0]->{having});
143 push(@{$self->{having_bind}}, @extra);
144 $ret .= $self->_sqlcase(' having ').$frag;
146 if (defined $_[0]->{order_by}) {
147 $ret .= $self->_order_by($_[0]->{order_by});
149 } elsif (ref $_[0] eq 'SCALAR') {
150 $ret = $self->_sqlcase(' order by ').${ $_[0] };
151 } elsif (ref $_[0] eq 'ARRAY' && @{$_[0]}) {
152 my @order = @{+shift};
153 $ret = $self->_sqlcase(' order by ')
155 my $r = $self->_order_by($_, @_);
156 $r =~ s/^ ?ORDER BY //i;
160 $ret = $self->SUPER::_order_by(@_);
165 sub _order_directions {
166 my ($self, $order) = @_;
167 $order = $order->{order_by} if ref $order eq 'HASH';
168 return $self->SUPER::_order_directions($order);
172 my ($self, $from) = @_;
173 if (ref $from eq 'ARRAY') {
174 return $self->_recurse_from(@$from);
175 } elsif (ref $from eq 'HASH') {
176 return $self->_make_as($from);
178 return $from; # would love to quote here but _table ends up getting called
179 # twice during an ->select without a limit clause due to
180 # the way S::A::Limit->select works. should maybe consider
181 # bypassing this and doing S::A::select($self, ...) in
182 # our select method above. meantime, quoting shims have
183 # been added to select/insert/update/delete here
188 my ($self, $from, @join) = @_;
190 push(@sqlf, $self->_make_as($from));
191 foreach my $j (@join) {
194 # check whether a join type exists
195 my $join_clause = '';
196 my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
197 if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
198 $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
200 $join_clause = ' JOIN ';
202 push(@sqlf, $join_clause);
204 if (ref $to eq 'ARRAY') {
205 push(@sqlf, '(', $self->_recurse_from(@$to), ')');
207 push(@sqlf, $self->_make_as($to));
209 push(@sqlf, ' ON ', $self->_join_condition($on));
211 return join('', @sqlf);
215 my ($self, $from) = @_;
216 return join(' ', map { (ref $_ eq 'SCALAR' ? $$_ : $self->_quote($_)) }
217 reverse each %{$self->_skip_options($from)});
221 my ($self, $hash) = @_;
223 $clean_hash->{$_} = $hash->{$_}
224 for grep {!/^-/} keys %$hash;
228 sub _join_condition {
229 my ($self, $cond) = @_;
230 if (ref $cond eq 'HASH') {
233 my $x = '= '.$self->_quote($cond->{$_}); $j{$_} = \$x;
235 return $self->_recurse_where(\%j);
236 } elsif (ref $cond eq 'ARRAY') {
237 return join(' OR ', map { $self->_join_condition($_) } @$cond);
239 die "Can't handle this yet!";
244 my ($self, $label) = @_;
245 return '' unless defined $label;
246 return "*" if $label eq '*';
247 return $label unless $self->{quote_char};
248 if(ref $self->{quote_char} eq "ARRAY"){
249 return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
250 if !defined $self->{name_sep};
251 my $sep = $self->{name_sep};
252 return join($self->{name_sep},
253 map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
254 split(/\Q$sep\E/,$label));
256 return $self->SUPER::_quote($label);
261 $self->{limit_dialect} = shift if @_;
262 return $self->{limit_dialect};
267 $self->{quote_char} = shift if @_;
268 return $self->{quote_char};
273 $self->{name_sep} = shift if @_;
274 return $self->{name_sep};
277 } # End of BEGIN block
279 use base qw/DBIx::Class/;
281 __PACKAGE__->load_components(qw/AccessorGroup/);
283 __PACKAGE__->mk_group_accessors('simple' =>
284 qw/_connect_info _dbh _sql_maker _sql_maker_opts _conn_pid _conn_tid
285 debug debugobj cursor on_connect_do transaction_depth/);
289 DBIx::Class::Storage::DBI - DBI storage handler
295 This class represents the connection to the database
305 bless $new, (ref $_[0] || $_[0]);
307 $new->cursor("DBIx::Class::Storage::DBI::Cursor");
308 $new->transaction_depth(0);
310 $new->debugobj(new DBIx::Class::Storage::Statistics());
314 my $debug_env = $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG}
317 if (defined($debug_env) && ($debug_env =~ /=(.+)$/)) {
318 $fh = IO::File->new($1, 'w')
319 or $new->throw_exception("Cannot open trace file $1");
321 $fh = IO::File->new('>&STDERR');
324 $new->debug(1) if $debug_env;
325 $new->_sql_maker_opts({});
329 =head2 throw_exception
331 Throws an exception - croaks.
335 sub throw_exception {
336 my ($self, $msg) = @_;
342 The arguments of C<connect_info> are always a single array reference.
344 This is normally accessed via L<DBIx::Class::Schema/connection>, which
345 encapsulates its argument list in an arrayref before calling
346 C<connect_info> here.
348 The arrayref can either contain the same set of arguments one would
349 normally pass to L<DBI/connect>, or a lone code reference which returns
350 a connected database handle.
352 In either case, if the final argument in your connect_info happens
353 to be a hashref, C<connect_info> will look there for several
354 connection-specific options:
360 This can be set to an arrayref of literal sql statements, which will
361 be executed immediately after making the connection to the database
362 every time we [re-]connect.
366 Sets the limit dialect. This is useful for JDBC-bridge among others
367 where the remote SQL-dialect cannot be determined by the name of the
372 Specifies what characters to use to quote table and column names. If
373 you use this you will want to specify L<name_sep> as well.
375 quote_char expects either a single character, in which case is it is placed
376 on either side of the table/column, or an arrayref of length 2 in which case the
377 table/column name is placed between the elements.
379 For example under MySQL you'd use C<quote_char =E<gt> '`'>, and user SQL Server you'd
380 use C<quote_char =E<gt> [qw/[ ]/]>.
384 This only needs to be used in conjunction with L<quote_char>, and is used to
385 specify the charecter that seperates elements (schemas, tables, columns) from
386 each other. In most cases this is simply a C<.>.
390 These options can be mixed in with your other L<DBI> connection attributes,
391 or placed in a seperate hashref after all other normal L<DBI> connection
394 Every time C<connect_info> is invoked, any previous settings for
395 these options will be cleared before setting the new ones, regardless of
396 whether any options are specified in the new C<connect_info>.
400 # Simple SQLite connection
401 ->connect_info([ 'dbi:SQLite:./foo.db' ]);
404 ->connect_info([ sub { DBI->connect(...) } ]);
406 # A bit more complicated
413 { quote_char => q{"}, name_sep => q{.} },
417 # Equivalent to the previous example
423 { AutoCommit => 0, quote_char => q{"}, name_sep => q{.} },
427 # Subref + DBIC-specific connection options
430 sub { DBI->connect(...) },
434 on_connect_do => ['SET search_path TO myschema,otherschema,public'],
441 This method is deprecated in favor of setting via L</connect_info>.
445 Causes SQL trace information to be emitted on the C<debugobj> object.
446 (or C<STDERR> if C<debugobj> has not specifically been set).
448 This is the equivalent to setting L</DBIC_TRACE> in your
453 Set or retrieve the filehandle used for trace/debug output. This should be
454 an IO::Handle compatible ojbect (only the C<print> method is used. Initially
455 set to be STDERR - although see information on the
456 L<DBIC_TRACE> environment variable.
463 if ($self->debugobj->can('debugfh')) {
464 return $self->debugobj->debugfh(@_);
470 Sets or retrieves the object used for metric collection. Defaults to an instance
471 of L<DBIx::Class::Storage::Statistics> that is campatible with the original
472 method of using a coderef as a callback. See the aforementioned Statistics
473 class for more information.
477 Sets a callback to be executed each time a statement is run; takes a sub
478 reference. Callback is executed as $sub->($op, $info) where $op is
479 SELECT/INSERT/UPDATE/DELETE and $info is what would normally be printed.
481 See L<debugobj> for a better way.
488 if ($self->debugobj->can('callback')) {
489 return $self->debugobj->callback(@_);
495 Disconnect the L<DBI> handle, performing a rollback first if the
496 database is not in C<AutoCommit> mode.
503 if( $self->connected ) {
504 $self->_dbh->rollback unless $self->_dbh->{AutoCommit};
505 $self->_dbh->disconnect;
512 Check if the L<DBI> handle is connected. Returns true if the handle
517 sub connected { my ($self) = @_;
519 if(my $dbh = $self->_dbh) {
520 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
521 return $self->_dbh(undef);
523 elsif($self->_conn_pid != $$) {
524 $self->_dbh->{InactiveDestroy} = 1;
525 return $self->_dbh(undef);
527 return ($dbh->FETCH('Active') && $dbh->ping);
533 =head2 ensure_connected
535 Check whether the database handle is connected - if not then make a
540 sub ensure_connected {
543 unless ($self->connected) {
544 $self->_populate_dbh;
550 Returns the dbh - a data base handle of class L<DBI>.
557 $self->ensure_connected;
561 sub _sql_maker_args {
564 return ( limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
569 Returns a C<sql_maker> object - normally an object of class
570 C<DBIC::SQL::Abstract>.
576 unless ($self->_sql_maker) {
577 $self->_sql_maker(new DBIC::SQL::Abstract( $self->_sql_maker_args ));
579 return $self->_sql_maker;
583 my ($self, $info_arg) = @_;
586 # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
587 # the new set of options
588 $self->_sql_maker(undef);
589 $self->_sql_maker_opts({});
591 my $info = [ @$info_arg ]; # copy because we can alter it
592 my $last_info = $info->[-1];
593 if(ref $last_info eq 'HASH') {
594 if(my $on_connect_do = delete $last_info->{on_connect_do}) {
595 $self->on_connect_do($on_connect_do);
597 for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
598 if(my $opt_val = delete $last_info->{$sql_maker_opt}) {
599 $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
603 # Get rid of any trailing empty hashref
604 pop(@$info) if !keys %$last_info;
607 $self->_connect_info($info);
610 $self->_connect_info;
615 my @info = @{$self->_connect_info || []};
616 $self->_dbh($self->_connect(@info));
618 if(ref $self eq 'DBIx::Class::Storage::DBI') {
619 my $driver = $self->_dbh->{Driver}->{Name};
620 if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
621 bless $self, "DBIx::Class::Storage::DBI::${driver}";
622 $self->_rebless() if $self->can('_rebless');
626 # if on-connect sql statements are given execute them
627 foreach my $sql_statement (@{$self->on_connect_do || []}) {
628 $self->debugobj->query_start($sql_statement) if $self->debug();
629 $self->_dbh->do($sql_statement);
630 $self->debugobj->query_end($sql_statement) if $self->debug();
633 $self->_conn_pid($$);
634 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
638 my ($self, @info) = @_;
640 $self->throw_exception("You failed to provide any connection info")
643 my ($old_connect_via, $dbh);
645 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
646 $old_connect_via = $DBI::connect_via;
647 $DBI::connect_via = 'connect';
651 $dbh = ref $info[0] eq 'CODE'
653 : DBI->connect(@info);
656 $DBI::connect_via = $old_connect_via if $old_connect_via;
659 $self->throw_exception("DBI Connection failed: " . ($@ || $DBI::errstr));
667 Calls begin_work on the current dbh.
669 See L<DBIx::Class::Schema> for the txn_do() method, which allows for
670 an entire code block to be executed transactionally.
676 if ($self->{transaction_depth}++ == 0) {
677 my $dbh = $self->dbh;
678 if ($dbh->{AutoCommit}) {
679 $self->debugobj->txn_begin()
688 Issues a commit against the current dbh.
694 my $dbh = $self->dbh;
695 if ($self->{transaction_depth} == 0) {
696 unless ($dbh->{AutoCommit}) {
697 $self->debugobj->txn_commit()
703 if (--$self->{transaction_depth} == 0) {
704 $self->debugobj->txn_commit()
713 Issues a rollback against the current dbh. A nested rollback will
714 throw a L<DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION> exception,
715 which allows the rollback to propagate to the outermost transaction.
723 my $dbh = $self->dbh;
724 if ($self->{transaction_depth} == 0) {
725 unless ($dbh->{AutoCommit}) {
726 $self->debugobj->txn_rollback()
732 if (--$self->{transaction_depth} == 0) {
733 $self->debugobj->txn_rollback()
738 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
745 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
746 $error =~ /$exception_class/ and $self->throw_exception($error);
747 $self->{transaction_depth} = 0; # ensure that a failed rollback
748 $self->throw_exception($error); # resets the transaction depth
753 my ($self, $op, $extra_bind, $ident, @args) = @_;
754 my ($sql, @bind) = $self->sql_maker->$op($ident, @args);
755 unshift(@bind, @$extra_bind) if $extra_bind;
757 my @debug_bind = map { defined $_ ? qq{'$_'} : q{'NULL'} } @bind;
758 $self->debugobj->query_start($sql, @debug_bind);
760 my $sth = eval { $self->sth($sql,$op) };
763 $self->throw_exception(
764 'no sth generated via sql (' . ($@ || $self->_dbh->errstr) . "): $sql"
767 @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
771 $rv = eval { $sth->execute(@bind) };
774 $self->throw_exception("Error executing '$sql': ".($@ || $sth->errstr));
777 $self->throw_exception("'$sql' did not generate a statement.");
780 my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind;
781 $self->debugobj->query_end($sql, @debug_bind);
783 return (wantarray ? ($rv, $sth, @bind) : $rv);
787 my ($self, $ident, $to_insert) = @_;
788 $self->throw_exception(
789 "Couldn't insert ".join(', ',
790 map "$_ => $to_insert->{$_}", keys %$to_insert
792 ) unless ($self->_execute('insert' => [], $ident, $to_insert));
797 return shift->_execute('update' => [], @_);
801 return shift->_execute('delete' => [], @_);
805 my ($self, $ident, $select, $condition, $attrs) = @_;
806 my $order = $attrs->{order_by};
807 if (ref $condition eq 'SCALAR') {
808 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
810 if (exists $attrs->{group_by} || $attrs->{having}) {
812 group_by => $attrs->{group_by},
813 having => $attrs->{having},
814 ($order ? (order_by => $order) : ())
817 my @args = ('select', $attrs->{bind}, $ident, $select, $condition, $order);
818 if ($attrs->{software_limit} ||
819 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
820 $attrs->{software_limit} = 1;
822 $self->throw_exception("rows attribute must be positive if present")
823 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
824 push @args, $attrs->{rows}, $attrs->{offset};
826 return $self->_execute(@args);
833 =item Arguments: $ident, $select, $condition, $attrs
837 Handle a SQL select statement.
843 my ($ident, $select, $condition, $attrs) = @_;
844 return $self->cursor->new($self, \@_, $attrs);
849 Performs a select, fetch and return of data - handles a single row
854 # Need to call finish() to work round broken DBDs
858 my ($rv, $sth, @bind) = $self->_select(@_);
859 my @row = $sth->fetchrow_array;
868 =item Arguments: $sql
872 Returns a L<DBI> sth (statement handle) for the supplied SQL.
877 my ($self, $sql) = @_;
878 # 3 is the if_active parameter which avoids active sth re-use
879 return $self->dbh->prepare_cached($sql, {}, 3);
882 =head2 columns_info_for
884 Returns database type info for a given table column.
888 sub columns_info_for {
889 my ($self, $table) = @_;
891 my $dbh = $self->dbh;
893 if ($dbh->can('column_info')) {
895 local $dbh->{RaiseError} = 1;
896 local $dbh->{PrintError} = 0;
898 my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
899 my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
902 while ( my $info = $sth->fetchrow_hashref() ){
904 $column_info{data_type} = $info->{TYPE_NAME};
905 $column_info{size} = $info->{COLUMN_SIZE};
906 $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
907 $column_info{default_value} = $info->{COLUMN_DEF};
908 my $col_name = $info->{COLUMN_NAME};
909 $col_name =~ s/^\"(.*)\"$/$1/;
911 $result{$col_name} = \%column_info;
914 return \%result if !$@ && scalar keys %result;
918 my $sth = $dbh->prepare("SELECT * FROM $table WHERE 1=0");
920 my @columns = @{$sth->{NAME_lc}};
921 for my $i ( 0 .. $#columns ){
923 my $type_num = $sth->{TYPE}->[$i];
925 if(defined $type_num && $dbh->can('type_info')) {
926 my $type_info = $dbh->type_info($type_num);
927 $type_name = $type_info->{TYPE_NAME} if $type_info;
929 $column_info{data_type} = $type_name ? $type_name : $type_num;
930 $column_info{size} = $sth->{PRECISION}->[$i];
931 $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
933 if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
934 $column_info{data_type} = $1;
935 $column_info{size} = $2;
938 $result{$columns[$i]} = \%column_info;
944 =head2 last_insert_id
946 Return the row id of the last insert.
951 my ($self, $row) = @_;
953 return $self->dbh->func('last_insert_rowid');
959 Returns the database driver name.
963 sub sqlt_type { shift->dbh->{Driver}->{Name} }
965 =head2 create_ddl_dir (EXPERIMENTAL)
969 =item Arguments: $schema \@databases, $version, $directory, $sqlt_args
973 Creates a SQL file based on the Schema, for each of the specified
974 database types, in the given directory.
976 Note that this feature is currently EXPERIMENTAL and may not work correctly
977 across all databases, or fully handle complex relationships.
983 my ($self, $schema, $databases, $version, $dir, $sqltargs) = @_;
985 if(!$dir || !-d $dir)
987 warn "No directory given, using ./\n";
990 $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
991 $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
992 $version ||= $schema->VERSION || '1.x';
993 $sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} };
995 eval "use SQL::Translator";
996 $self->throw_exception("Can't deploy without SQL::Translator: $@") if $@;
998 my $sqlt = SQL::Translator->new($sqltargs);
999 foreach my $db (@$databases)
1002 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
1003 # $sqlt->parser_args({'DBIx::Class' => $schema);
1004 $sqlt->data($schema);
1005 $sqlt->producer($db);
1008 my $filename = $schema->ddl_filename($db, $dir, $version);
1011 $self->throw_exception("$filename already exists, skipping $db");
1014 open($file, ">$filename")
1015 or $self->throw_exception("Can't open $filename for writing ($!)");
1016 my $output = $sqlt->translate;
1018 # print join(":", keys %{$schema->source_registrations});
1019 # print Dumper($sqlt->schema);
1022 $self->throw_exception("Failed to translate to $db. (" . $sqlt->error . ")");
1025 print $file $output;
1031 =head2 deployment_statements
1035 =item Arguments: $schema, $type, $version, $directory, $sqlt_args
1039 Returns the statements used by L</deploy> and L<DBIx::Class::Schema/deploy>.
1040 The database driver name is given by C<$type>, though the value from
1041 L</sqlt_type> is used if it is not specified.
1043 C<$directory> is used to return statements from files in a previously created
1044 L</create_ddl_dir> directory and is optional. The filenames are constructed
1045 from L<DBIx::Class::Schema/ddl_filename>, the schema name and the C<$version>.
1047 If no C<$directory> is specified then the statements are constructed on the
1048 fly using L<SQL::Translator> and C<$version> is ignored.
1050 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>.
1054 sub deployment_statements {
1055 my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
1056 # Need to be connected to get the correct sqlt_type
1057 $self->ensure_connected() unless $type;
1058 $type ||= $self->sqlt_type;
1059 $version ||= $schema->VERSION || '1.x';
1061 eval "use SQL::Translator";
1064 eval "use SQL::Translator::Parser::DBIx::Class;";
1065 $self->throw_exception($@) if $@;
1066 eval "use SQL::Translator::Producer::${type};";
1067 $self->throw_exception($@) if $@;
1068 my $tr = SQL::Translator->new(%$sqltargs);
1069 SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
1070 return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
1073 my $filename = $schema->ddl_filename($type, $dir, $version);
1076 # $schema->create_ddl_dir([ $type ], $version, $dir, $sqltargs);
1077 $self->throw_exception("No SQL::Translator, and no Schema file found, aborting deploy");
1081 open($file, "<$filename")
1082 or $self->throw_exception("Can't open $filename ($!)");
1086 return join('', @rows);
1092 Sends the appropriate statements to create or modify tables to the
1093 db. This would normally be called through
1094 L<DBIx::Class::Schema/deploy>.
1099 my ($self, $schema, $type, $sqltargs, $dir) = @_;
1100 foreach my $statement ( $self->deployment_statements($schema, $type, undef, $dir, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
1101 for ( split(";\n", $statement)) {
1102 next if($_ =~ /^--/);
1104 # next if($_ =~ /^DROP/m);
1105 next if($_ =~ /^BEGIN TRANSACTION/m);
1106 next if($_ =~ /^COMMIT/m);
1107 next if $_ =~ /^\s+$/; # skip whitespace only
1108 $self->debugobj->query_start($_) if $self->debug;
1109 $self->dbh->do($_) or warn "SQL was:\n $_";
1110 $self->debugobj->query_end($_) if $self->debug;
1115 =head2 datetime_parser
1117 Returns the datetime parser class
1121 sub datetime_parser {
1123 return $self->{datetime_parser} ||= $self->build_datetime_parser(@_);
1126 =head2 datetime_parser_type
1128 Defines (returns) the datetime parser class - currently hardwired to
1129 L<DateTime::Format::MySQL>
1133 sub datetime_parser_type { "DateTime::Format::MySQL"; }
1135 =head2 build_datetime_parser
1137 See L</datetime_parser>
1141 sub build_datetime_parser {
1143 my $type = $self->datetime_parser_type(@_);
1145 $self->throw_exception("Couldn't load ${type}: $@") if $@;
1150 # NOTE: if there's a merge conflict here when -current is pushed
1151 # back to trunk, take -current's version and ignore this trunk one :)
1154 if($self->_dbh && $self->_conn_pid != $$) {
1155 $self->_dbh->{InactiveDestroy} = 1;
1165 The module defines a set of methods within the DBIC::SQL::Abstract
1166 namespace. These build on L<SQL::Abstract::Limit> to provide the
1167 SQL query functions.
1169 The following methods are extended:-
1183 See L</connect_info> for details.
1184 For setting, this method is deprecated in favor of L</connect_info>.
1188 See L</connect_info> for details.
1189 For setting, this method is deprecated in favor of L</connect_info>.
1193 See L</connect_info> for details.
1194 For setting, this method is deprecated in favor of L</connect_info>.
1198 =head1 ENVIRONMENT VARIABLES
1202 If C<DBIC_TRACE> is set then SQL trace information
1203 is produced (as when the L<debug> method is set).
1205 If the value is of the form C<1=/path/name> then the trace output is
1206 written to the file C</path/name>.
1208 This environment variable is checked when the storage object is first
1209 created (when you call connect on your schema). So, run-time changes
1210 to this environment variable will not take effect unless you also
1211 re-connect on your schema.
1213 =head2 DBIX_CLASS_STORAGE_DBI_DEBUG
1215 Old name for DBIC_TRACE
1219 Matt S. Trout <mst@shadowcatsystems.co.uk>
1221 Andy Grundman <andy@hybridized.org>
1225 You may distribute this code under the same terms as Perl itself.