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>.
370 Important note: DBIC expects the returned database handle provided by
371 a subref argument to have RaiseError set on it. If it doesn't, things
372 might not work very well, YMMV. If you don't use a subref, DBIC will
373 force this setting for you anyways. Setting HandleError to anything
374 other than simple exception object wrapper might cause problems too.
378 # Simple SQLite connection
379 ->connect_info([ 'dbi:SQLite:./foo.db' ]);
382 ->connect_info([ sub { DBI->connect(...) } ]);
384 # A bit more complicated
391 { quote_char => q{"}, name_sep => q{.} },
395 # Equivalent to the previous example
401 { AutoCommit => 0, quote_char => q{"}, name_sep => q{.} },
405 # Subref + DBIC-specific connection options
408 sub { DBI->connect(...) },
412 on_connect_do => ['SET search_path TO myschema,otherschema,public'],
419 This method is deprecated in favor of setting via L</connect_info>.
423 Causes SQL trace information to be emitted on the C<debugobj> object.
424 (or C<STDERR> if C<debugobj> has not specifically been set).
426 This is the equivalent to setting L</DBIC_TRACE> in your
431 Set or retrieve the filehandle used for trace/debug output. This should be
432 an IO::Handle compatible ojbect (only the C<print> method is used. Initially
433 set to be STDERR - although see information on the
434 L<DBIC_TRACE> environment variable.
441 if ($self->debugobj->can('debugfh')) {
442 return $self->debugobj->debugfh(@_);
448 Sets or retrieves the object used for metric collection. Defaults to an instance
449 of L<DBIx::Class::Storage::Statistics> that is campatible with the original
450 method of using a coderef as a callback. See the aforementioned Statistics
451 class for more information.
455 Sets a callback to be executed each time a statement is run; takes a sub
456 reference. Callback is executed as $sub->($op, $info) where $op is
457 SELECT/INSERT/UPDATE/DELETE and $info is what would normally be printed.
459 See L<debugobj> for a better way.
466 if ($self->debugobj->can('callback')) {
467 return $self->debugobj->callback(@_);
473 Execute the given subref with the underlying database handle as its
474 first argument, using the new exception-based connection management.
477 my @stuff = $schema->storage->dbh_do(
479 shift->selectrow_array("SELECT * FROM foo")
486 my ($self, $todo) = @_;
489 my $want_array = wantarray;
492 $self->_verify_pid if $self->_dbh;
493 $self->_populate_dbh if !$self->_dbh;
494 my $dbh = $self->_dbh;
496 @result = $todo->($dbh);
498 elsif(defined $want_array) {
499 $result[0] = $todo->($dbh);
509 ? $self->throw_exception($exception)
510 : $self->_populate_dbh;
512 my $dbh = $self->_dbh;
513 return $todo->($dbh);
516 return $want_array ? @result : $result[0];
521 Disconnect the L<DBI> handle, performing a rollback first if the
522 database is not in C<AutoCommit> mode.
529 if( $self->connected ) {
530 $self->_dbh->rollback unless $self->_dbh->{AutoCommit};
531 $self->_dbh->disconnect;
538 Check if the L<DBI> handle is connected. Returns true if the handle
546 if(my $dbh = $self->_dbh) {
547 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
548 return $self->_dbh(undef);
553 return ($dbh->FETCH('Active') && $dbh->ping);
559 # handle pid changes correctly
560 # NOTE: assumes $self->_dbh is a valid $dbh
564 return if $self->_conn_pid == $$;
566 $self->_dbh->{InactiveDestroy} = 1;
572 =head2 ensure_connected
574 Check whether the database handle is connected - if not then make a
579 sub ensure_connected {
582 unless ($self->connected) {
583 $self->_populate_dbh;
589 Returns the dbh - a data base handle of class L<DBI>.
596 $self->ensure_connected;
600 sub _sql_maker_args {
603 return ( limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
608 Returns a C<sql_maker> object - normally an object of class
609 C<DBIC::SQL::Abstract>.
615 unless ($self->_sql_maker) {
616 $self->_sql_maker(new DBIC::SQL::Abstract( $self->_sql_maker_args ));
618 return $self->_sql_maker;
622 my ($self, $info_arg) = @_;
624 return $self->_connect_info if !$info_arg;
626 # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
627 # the new set of options
628 $self->_sql_maker(undef);
629 $self->_sql_maker_opts({});
631 my $info = [ @$info_arg ]; # copy because we can alter it
632 my $last_info = $info->[-1];
633 if(ref $last_info eq 'HASH') {
634 if(my $on_connect_do = delete $last_info->{on_connect_do}) {
635 $self->on_connect_do($on_connect_do);
637 for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
638 if(my $opt_val = delete $last_info->{$sql_maker_opt}) {
639 $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
643 # Get rid of any trailing empty hashref
644 pop(@$info) if !keys %$last_info;
647 $self->_connect_info($info);
652 my @info = @{$self->_connect_info || []};
653 $self->_dbh($self->_connect(@info));
655 if(ref $self eq 'DBIx::Class::Storage::DBI') {
656 my $driver = $self->_dbh->{Driver}->{Name};
657 if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
658 bless $self, "DBIx::Class::Storage::DBI::${driver}";
659 $self->_rebless() if $self->can('_rebless');
663 # if on-connect sql statements are given execute them
664 foreach my $sql_statement (@{$self->on_connect_do || []}) {
665 $self->debugobj->query_start($sql_statement) if $self->debug();
666 $self->_dbh->do($sql_statement);
667 $self->debugobj->query_end($sql_statement) if $self->debug();
670 $self->_conn_pid($$);
671 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
675 my ($self, @info) = @_;
677 $self->throw_exception("You failed to provide any connection info")
680 my ($old_connect_via, $dbh);
682 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
683 $old_connect_via = $DBI::connect_via;
684 $DBI::connect_via = 'connect';
688 if(ref $info[0] eq 'CODE') {
692 $dbh = DBI->connect(@info);
693 $dbh->{RaiseError} = 1;
694 $dbh->{PrintError} = 0;
698 $DBI::connect_via = $old_connect_via if $old_connect_via;
701 $self->throw_exception("DBI Connection failed: " . ($@ || $DBI::errstr));
709 Calls begin_work on the current dbh.
711 See L<DBIx::Class::Schema> for the txn_do() method, which allows for
712 an entire code block to be executed transactionally.
718 if ($self->{transaction_depth}++ == 0) {
721 if ($dbh->{AutoCommit}) {
722 $self->debugobj->txn_begin()
732 Issues a commit against the current dbh.
740 if ($self->{transaction_depth} == 0) {
741 unless ($dbh->{AutoCommit}) {
742 $self->debugobj->txn_commit()
748 if (--$self->{transaction_depth} == 0) {
749 $self->debugobj->txn_commit()
759 Issues a rollback against the current dbh. A nested rollback will
760 throw a L<DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION> exception,
761 which allows the rollback to propagate to the outermost transaction.
771 if ($self->{transaction_depth} == 0) {
772 unless ($dbh->{AutoCommit}) {
773 $self->debugobj->txn_rollback()
779 if (--$self->{transaction_depth} == 0) {
780 $self->debugobj->txn_rollback()
785 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
793 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
794 $error =~ /$exception_class/ and $self->throw_exception($error);
795 $self->{transaction_depth} = 0; # ensure that a failed rollback
796 $self->throw_exception($error); # resets the transaction depth
801 my ($self, $op, $extra_bind, $ident, @args) = @_;
802 my ($sql, @bind) = $self->sql_maker->$op($ident, @args);
803 unshift(@bind, @$extra_bind) if $extra_bind;
805 my @debug_bind = map { defined $_ ? qq{'$_'} : q{'NULL'} } @bind;
806 $self->debugobj->query_start($sql, @debug_bind);
808 my $sth = eval { $self->sth($sql,$op) };
811 $self->throw_exception(
812 'no sth generated via sql (' . ($@ || $self->_dbh->errstr) . "): $sql"
815 @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
819 $rv = eval { $sth->execute(@bind) };
822 $self->throw_exception("Error executing '$sql': ".($@ || $sth->errstr));
825 $self->throw_exception("'$sql' did not generate a statement.");
828 my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind;
829 $self->debugobj->query_end($sql, @debug_bind);
831 return (wantarray ? ($rv, $sth, @bind) : $rv);
835 my ($self, $ident, $to_insert) = @_;
836 $self->throw_exception(
837 "Couldn't insert ".join(', ',
838 map "$_ => $to_insert->{$_}", keys %$to_insert
840 ) unless ($self->_execute('insert' => [], $ident, $to_insert));
845 return shift->_execute('update' => [], @_);
849 return shift->_execute('delete' => [], @_);
853 my ($self, $ident, $select, $condition, $attrs) = @_;
854 my $order = $attrs->{order_by};
855 if (ref $condition eq 'SCALAR') {
856 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
858 if (exists $attrs->{group_by} || $attrs->{having}) {
860 group_by => $attrs->{group_by},
861 having => $attrs->{having},
862 ($order ? (order_by => $order) : ())
865 my @args = ('select', $attrs->{bind}, $ident, $select, $condition, $order);
866 if ($attrs->{software_limit} ||
867 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
868 $attrs->{software_limit} = 1;
870 $self->throw_exception("rows attribute must be positive if present")
871 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
872 push @args, $attrs->{rows}, $attrs->{offset};
874 return $self->_execute(@args);
879 Handle a SQL select statement.
885 my ($ident, $select, $condition, $attrs) = @_;
886 return $self->cursor->new($self, \@_, $attrs);
891 Performs a select, fetch and return of data - handles a single row
896 # Need to call finish() to work round broken DBDs
900 my ($rv, $sth, @bind) = $self->_select(@_);
901 my @row = $sth->fetchrow_array;
908 Returns a L<DBI> sth (statement handle) for the supplied SQL.
913 my ($self, $sql) = @_;
914 # 3 is the if_active parameter which avoids active sth re-use
915 return $self->dbh_do(sub { shift->prepare_cached($sql, {}, 3) });
918 =head2 columns_info_for
920 Returns database type info for a given table columns.
924 sub columns_info_for {
925 my ($self, $table) = @_;
930 if ($dbh->can('column_info')) {
933 my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
934 my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
936 while ( my $info = $sth->fetchrow_hashref() ){
938 $column_info{data_type} = $info->{TYPE_NAME};
939 $column_info{size} = $info->{COLUMN_SIZE};
940 $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0;
941 $column_info{default_value} = $info->{COLUMN_DEF};
942 my $col_name = $info->{COLUMN_NAME};
943 $col_name =~ s/^\"(.*)\"$/$1/;
945 $result{$col_name} = \%column_info;
948 return \%result if !$@;
952 my $sth = $dbh->prepare("SELECT * FROM $table WHERE 1=0");
954 my @columns = @{$sth->{NAME_lc}};
955 for my $i ( 0 .. $#columns ){
957 my $type_num = $sth->{TYPE}->[$i];
959 if(defined $type_num && $dbh->can('type_info')) {
960 my $type_info = $dbh->type_info($type_num);
961 $type_name = $type_info->{TYPE_NAME} if $type_info;
963 $column_info{data_type} = $type_name ? $type_name : $type_num;
964 $column_info{size} = $sth->{PRECISION}->[$i];
965 $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
967 if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
968 $column_info{data_type} = $1;
969 $column_info{size} = $2;
972 $result{$columns[$i]} = \%column_info;
979 =head2 last_insert_id
981 Return the row id of the last insert.
986 my ($self, $row) = @_;
988 $self->dbh_do(sub { shift->func('last_insert_rowid') });
993 Returns the database driver name.
997 sub sqlt_type { shift->dbh_do(sub { shift->{Driver}->{Name} }) }
999 =head2 create_ddl_dir (EXPERIMENTAL)
1003 =item Arguments: $schema \@databases, $version, $directory, $sqlt_args
1007 Creates an SQL file based on the Schema, for each of the specified
1008 database types, in the given directory.
1010 Note that this feature is currently EXPERIMENTAL and may not work correctly
1011 across all databases, or fully handle complex relationships.
1017 my ($self, $schema, $databases, $version, $dir, $sqltargs) = @_;
1019 if(!$dir || !-d $dir)
1021 warn "No directory given, using ./\n";
1024 $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
1025 $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
1026 $version ||= $schema->VERSION || '1.x';
1027 $sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} };
1029 eval "use SQL::Translator";
1030 $self->throw_exception("Can't deploy without SQL::Translator: $@") if $@;
1032 my $sqlt = SQL::Translator->new($sqltargs);
1033 foreach my $db (@$databases)
1036 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
1037 # $sqlt->parser_args({'DBIx::Class' => $schema);
1038 $sqlt->data($schema);
1039 $sqlt->producer($db);
1042 my $filename = $schema->ddl_filename($db, $dir, $version);
1045 $self->throw_exception("$filename already exists, skipping $db");
1048 open($file, ">$filename")
1049 or $self->throw_exception("Can't open $filename for writing ($!)");
1050 my $output = $sqlt->translate;
1052 # print join(":", keys %{$schema->source_registrations});
1053 # print Dumper($sqlt->schema);
1056 $self->throw_exception("Failed to translate to $db. (" . $sqlt->error . ")");
1059 print $file $output;
1065 =head2 deployment_statements
1067 Create the statements for L</deploy> and
1068 L<DBIx::Class::Schema/deploy>.
1072 sub deployment_statements {
1073 my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
1074 # Need to be connected to get the correct sqlt_type
1075 $self->ensure_connected() unless $type;
1076 $type ||= $self->sqlt_type;
1077 $version ||= $schema->VERSION || '1.x';
1079 eval "use SQL::Translator";
1082 eval "use SQL::Translator::Parser::DBIx::Class;";
1083 $self->throw_exception($@) if $@;
1084 eval "use SQL::Translator::Producer::${type};";
1085 $self->throw_exception($@) if $@;
1086 my $tr = SQL::Translator->new(%$sqltargs);
1087 SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
1088 return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
1091 my $filename = $schema->ddl_filename($type, $dir, $version);
1094 # $schema->create_ddl_dir([ $type ], $version, $dir, $sqltargs);
1095 $self->throw_exception("No SQL::Translator, and no Schema file found, aborting deploy");
1099 open($file, "<$filename")
1100 or $self->throw_exception("Can't open $filename ($!)");
1104 return join('', @rows);
1110 Sends the appropriate statements to create or modify tables to the
1111 db. This would normally be called through
1112 L<DBIx::Class::Schema/deploy>.
1117 my ($self, $schema, $type, $sqltargs) = @_;
1118 foreach my $statement ( $self->deployment_statements($schema, $type, undef, undef, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
1119 for ( split(";\n", $statement)) {
1120 next if($_ =~ /^--/);
1122 # next if($_ =~ /^DROP/m);
1123 next if($_ =~ /^BEGIN TRANSACTION/m);
1124 next if($_ =~ /^COMMIT/m);
1125 next if $_ =~ /^\s+$/; # skip whitespace only
1126 $self->debugobj->query_start($_) if $self->debug;
1127 $self->dbh->do($_) or warn "SQL was:\n $_"; # XXX exceptions?
1128 $self->debugobj->query_end($_) if $self->debug;
1133 =head2 datetime_parser
1135 Returns the datetime parser class
1139 sub datetime_parser {
1141 return $self->{datetime_parser} ||= $self->build_datetime_parser(@_);
1144 =head2 datetime_parser_type
1146 Defines (returns) the datetime parser class - currently hardwired to
1147 L<DateTime::Format::MySQL>
1151 sub datetime_parser_type { "DateTime::Format::MySQL"; }
1153 =head2 build_datetime_parser
1155 See L</datetime_parser>
1159 sub build_datetime_parser {
1161 my $type = $self->datetime_parser_type(@_);
1163 $self->throw_exception("Couldn't load ${type}: $@") if $@;
1169 return if !$self->_dbh;
1179 The module defines a set of methods within the DBIC::SQL::Abstract
1180 namespace. These build on L<SQL::Abstract::Limit> to provide the
1181 SQL query functions.
1183 The following methods are extended:-
1197 See L</connect_info> for details.
1198 For setting, this method is deprecated in favor of L</connect_info>.
1202 See L</connect_info> for details.
1203 For setting, this method is deprecated in favor of L</connect_info>.
1207 See L</connect_info> for details.
1208 For setting, this method is deprecated in favor of L</connect_info>.
1212 =head1 ENVIRONMENT VARIABLES
1216 If C<DBIC_TRACE> is set then SQL trace information
1217 is produced (as when the L<debug> method is set).
1219 If the value is of the form C<1=/path/name> then the trace output is
1220 written to the file C</path/name>.
1222 This environment variable is checked when the storage object is first
1223 created (when you call connect on your schema). So, run-time changes
1224 to this environment variable will not take effect unless you also
1225 re-connect on your schema.
1227 =head2 DBIX_CLASS_STORAGE_DBI_DEBUG
1229 Old name for DBIC_TRACE
1233 Matt S. Trout <mst@shadowcatsystems.co.uk>
1235 Andy Grundman <andy@hybridized.org>
1239 You may distribute this code under the same terms as Perl itself.