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
279 bless $new, (ref $_[0] || $_[0]);
281 $new->cursor("DBIx::Class::Storage::DBI::Cursor");
282 $new->transaction_depth(0);
284 $new->debugobj(new DBIx::Class::Storage::Statistics());
288 my $debug_env = $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG}
291 if (defined($debug_env) && ($debug_env =~ /=(.+)$/)) {
292 $fh = IO::File->new($1, 'w')
293 or $new->throw_exception("Cannot open trace file $1");
295 $fh = IO::File->new('>&STDERR');
298 $new->debug(1) if $debug_env;
299 $new->_sql_maker_opts({});
303 =head2 throw_exception
305 Throws an exception - croaks.
309 sub throw_exception {
310 my ($self, $msg) = @_;
316 The arguments of C<connect_info> are always a single array reference.
318 This is normally accessed via L<DBIx::Class::Schema/connection>, which
319 encapsulates its argument list in an arrayref before calling
320 C<connect_info> here.
322 The arrayref can either contain the same set of arguments one would
323 normally pass to L<DBI/connect>, or a lone code reference which returns
324 a connected database handle.
326 In either case, if the final argument in your connect_info happens
327 to be a hashref, C<connect_info> will look there for several
328 connection-specific options:
334 This can be set to an arrayref of literal sql statements, which will
335 be executed immediately after making the connection to the database
336 every time we [re-]connect.
340 Sets the limit dialect. This is useful for JDBC-bridge among others
341 where the remote SQL-dialect cannot be determined by the name of the
346 Specifies what characters to use to quote table and column names. If
347 you use this you will want to specify L<name_sep> as well.
349 quote_char expects either a single character, in which case is it is placed
350 on either side of the table/column, or an arrayref of length 2 in which case the
351 table/column name is placed between the elements.
353 For example under MySQL you'd use C<quote_char =E<gt> '`'>, and user SQL Server you'd
354 use C<quote_char =E<gt> [qw/[ ]/]>.
358 This only needs to be used in conjunction with L<quote_char>, and is used to
359 specify the charecter that seperates elements (schemas, tables, columns) from
360 each other. In most cases this is simply a C<.>.
364 These options can be mixed in with your other L<DBI> connection attributes,
365 or placed in a seperate hashref after all other normal L<DBI> connection
368 Every time C<connect_info> is invoked, any previous settings for
369 these options will be cleared before setting the new ones, regardless of
370 whether any options are specified in the new C<connect_info>.
374 # Simple SQLite connection
375 ->connect_info([ 'dbi:SQLite:./foo.db' ]);
378 ->connect_info([ sub { DBI->connect(...) } ]);
380 # A bit more complicated
387 { quote_char => q{"}, name_sep => q{.} },
391 # Equivalent to the previous example
397 { AutoCommit => 0, quote_char => q{"}, name_sep => q{.} },
401 # Subref + DBIC-specific connection options
404 sub { DBI->connect(...) },
408 on_connect_do => ['SET search_path TO myschema,otherschema,public'],
415 This method is deprecated in favor of setting via L</connect_info>.
419 Causes SQL trace information to be emitted on the C<debugobj> object.
420 (or C<STDERR> if C<debugobj> has not specifically been set).
422 This is the equivalent to setting L</DBIC_TRACE> in your
427 Set or retrieve the filehandle used for trace/debug output. This should be
428 an IO::Handle compatible ojbect (only the C<print> method is used. Initially
429 set to be STDERR - although see information on the
430 L<DBIC_TRACE> environment variable.
437 if ($self->debugobj->can('debugfh')) {
438 return $self->debugobj->debugfh(@_);
444 Sets or retrieves the object used for metric collection. Defaults to an instance
445 of L<DBIx::Class::Storage::Statistics> that is campatible with the original
446 method of using a coderef as a callback. See the aforementioned Statistics
447 class for more information.
451 Sets a callback to be executed each time a statement is run; takes a sub
452 reference. Callback is executed as $sub->($op, $info) where $op is
453 SELECT/INSERT/UPDATE/DELETE and $info is what would normally be printed.
455 See L<debugobj> for a better way.
462 if ($self->debugobj->can('callback')) {
463 return $self->debugobj->callback(@_);
469 Disconnect the L<DBI> handle, performing a rollback first if the
470 database is not in C<AutoCommit> mode.
477 if( $self->connected ) {
478 $self->_dbh->rollback unless $self->_dbh->{AutoCommit};
479 $self->_dbh->disconnect;
486 Check if the L<DBI> handle is connected. Returns true if the handle
491 sub connected { my ($self) = @_;
493 if(my $dbh = $self->_dbh) {
494 if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
495 return $self->_dbh(undef);
497 elsif($self->_conn_pid != $$) {
498 $self->_dbh->{InactiveDestroy} = 1;
499 return $self->_dbh(undef);
501 return ($dbh->FETCH('Active') && $dbh->ping);
507 =head2 ensure_connected
509 Check whether the database handle is connected - if not then make a
514 sub ensure_connected {
517 unless ($self->connected) {
518 $self->_populate_dbh;
524 Returns the dbh - a data base handle of class L<DBI>.
531 $self->ensure_connected;
535 sub _sql_maker_args {
538 return ( limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
543 Returns a C<sql_maker> object - normally an object of class
544 C<DBIC::SQL::Abstract>.
550 unless ($self->_sql_maker) {
551 $self->_sql_maker(new DBIC::SQL::Abstract( $self->_sql_maker_args ));
553 return $self->_sql_maker;
557 my ($self, $info_arg) = @_;
560 # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
561 # the new set of options
562 $self->_sql_maker(undef);
563 $self->_sql_maker_opts({});
565 my $info = [ @$info_arg ]; # copy because we can alter it
566 my $last_info = $info->[-1];
567 if(ref $last_info eq 'HASH') {
568 if(my $on_connect_do = delete $last_info->{on_connect_do}) {
569 $self->on_connect_do($on_connect_do);
571 for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
572 if(my $opt_val = delete $last_info->{$sql_maker_opt}) {
573 $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
577 # Get rid of any trailing empty hashref
578 pop(@$info) if !keys %$last_info;
581 $self->_connect_info($info);
584 $self->_connect_info;
589 my @info = @{$self->_connect_info || []};
590 $self->_dbh($self->_connect(@info));
592 if(ref $self eq 'DBIx::Class::Storage::DBI') {
593 my $driver = $self->_dbh->{Driver}->{Name};
594 if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
595 bless $self, "DBIx::Class::Storage::DBI::${driver}";
596 $self->_rebless() if $self->can('_rebless');
600 # if on-connect sql statements are given execute them
601 foreach my $sql_statement (@{$self->on_connect_do || []}) {
602 $self->debugobj->query_start($sql_statement) if $self->debug();
603 $self->_dbh->do($sql_statement);
604 $self->debugobj->query_end($sql_statement) if $self->debug();
607 $self->_conn_pid($$);
608 $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
612 my ($self, @info) = @_;
614 $self->throw_exception("You failed to provide any connection info")
617 my ($old_connect_via, $dbh);
619 if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
620 $old_connect_via = $DBI::connect_via;
621 $DBI::connect_via = 'connect';
625 $dbh = ref $info[0] eq 'CODE'
627 : DBI->connect(@info);
630 $DBI::connect_via = $old_connect_via if $old_connect_via;
633 $self->throw_exception("DBI Connection failed: " . ($@ || $DBI::errstr));
641 Calls begin_work on the current dbh.
643 See L<DBIx::Class::Schema> for the txn_do() method, which allows for
644 an entire code block to be executed transactionally.
650 if ($self->{transaction_depth}++ == 0) {
651 my $dbh = $self->dbh;
652 if ($dbh->{AutoCommit}) {
653 $self->debugobj->txn_begin()
662 Issues a commit against the current dbh.
668 my $dbh = $self->dbh;
669 if ($self->{transaction_depth} == 0) {
670 unless ($dbh->{AutoCommit}) {
671 $self->debugobj->txn_commit()
677 if (--$self->{transaction_depth} == 0) {
678 $self->debugobj->txn_commit()
687 Issues a rollback against the current dbh. A nested rollback will
688 throw a L<DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION> exception,
689 which allows the rollback to propagate to the outermost transaction.
697 my $dbh = $self->dbh;
698 if ($self->{transaction_depth} == 0) {
699 unless ($dbh->{AutoCommit}) {
700 $self->debugobj->txn_rollback()
706 if (--$self->{transaction_depth} == 0) {
707 $self->debugobj->txn_rollback()
712 die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
719 my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
720 $error =~ /$exception_class/ and $self->throw_exception($error);
721 $self->{transaction_depth} = 0; # ensure that a failed rollback
722 $self->throw_exception($error); # resets the transaction depth
727 my ($self, $op, $extra_bind, $ident, @args) = @_;
728 my ($sql, @bind) = $self->sql_maker->$op($ident, @args);
729 unshift(@bind, @$extra_bind) if $extra_bind;
731 my @debug_bind = map { defined $_ ? qq{'$_'} : q{'NULL'} } @bind;
732 $self->debugobj->query_start($sql, @debug_bind);
734 my $sth = eval { $self->sth($sql,$op) };
737 $self->throw_exception(
738 'no sth generated via sql (' . ($@ || $self->_dbh->errstr) . "): $sql"
741 @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
745 $rv = eval { $sth->execute(@bind) };
748 $self->throw_exception("Error executing '$sql': ".($@ || $sth->errstr));
751 $self->throw_exception("'$sql' did not generate a statement.");
754 my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind;
755 $self->debugobj->query_end($sql, @debug_bind);
757 return (wantarray ? ($rv, $sth, @bind) : $rv);
761 my ($self, $ident, $to_insert) = @_;
762 $self->throw_exception(
763 "Couldn't insert ".join(', ',
764 map "$_ => $to_insert->{$_}", keys %$to_insert
766 ) unless ($self->_execute('insert' => [], $ident, $to_insert));
771 return shift->_execute('update' => [], @_);
775 return shift->_execute('delete' => [], @_);
779 my ($self, $ident, $select, $condition, $attrs) = @_;
780 my $order = $attrs->{order_by};
781 if (ref $condition eq 'SCALAR') {
782 $order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
784 if (exists $attrs->{group_by} || $attrs->{having}) {
786 group_by => $attrs->{group_by},
787 having => $attrs->{having},
788 ($order ? (order_by => $order) : ())
791 my @args = ('select', $attrs->{bind}, $ident, $select, $condition, $order);
792 if ($attrs->{software_limit} ||
793 $self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
794 $attrs->{software_limit} = 1;
796 $self->throw_exception("rows attribute must be positive if present")
797 if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
798 push @args, $attrs->{rows}, $attrs->{offset};
800 return $self->_execute(@args);
805 Handle a SQL select statement.
811 my ($ident, $select, $condition, $attrs) = @_;
812 return $self->cursor->new($self, \@_, $attrs);
817 Performs a select, fetch and return of data - handles a single row
822 # Need to call finish() to work round broken DBDs
826 my ($rv, $sth, @bind) = $self->_select(@_);
827 my @row = $sth->fetchrow_array;
834 Returns a L<DBI> sth (statement handle) for the supplied SQL.
839 my ($self, $sql) = @_;
840 # 3 is the if_active parameter which avoids active sth re-use
841 return $self->dbh->prepare_cached($sql, {}, 3);
844 =head2 columns_info_for
846 Returns database type info for a given table columns.
850 sub columns_info_for {
851 my ($self, $table) = @_;
853 my $dbh = $self->dbh;
855 if ($dbh->can('column_info')) {
857 local $dbh->{RaiseError} = 1;
858 local $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 return \%result if !$@;
885 my $sth = $dbh->prepare("SELECT * FROM $table WHERE 1=0");
887 my @columns = @{$sth->{NAME_lc}};
888 for my $i ( 0 .. $#columns ){
890 my $type_num = $sth->{TYPE}->[$i];
892 if(defined $type_num && $dbh->can('type_info')) {
893 my $type_info = $dbh->type_info($type_num);
894 $type_name = $type_info->{TYPE_NAME} if $type_info;
896 $column_info{data_type} = $type_name ? $type_name : $type_num;
897 $column_info{size} = $sth->{PRECISION}->[$i];
898 $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
900 if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
901 $column_info{data_type} = $1;
902 $column_info{size} = $2;
905 $result{$columns[$i]} = \%column_info;
911 =head2 last_insert_id
913 Return the row id of the last insert.
918 my ($self, $row) = @_;
920 return $self->dbh->func('last_insert_rowid');
926 Returns the database driver name.
930 sub sqlt_type { shift->dbh->{Driver}->{Name} }
932 =head2 create_ddl_dir (EXPERIMENTAL)
936 =item Arguments: $schema \@databases, $version, $directory, $sqlt_args
940 Creates an SQL file based on the Schema, for each of the specified
941 database types, in the given directory.
943 Note that this feature is currently EXPERIMENTAL and may not work correctly
944 across all databases, or fully handle complex relationships.
950 my ($self, $schema, $databases, $version, $dir, $sqltargs) = @_;
952 if(!$dir || !-d $dir)
954 warn "No directory given, using ./\n";
957 $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
958 $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
959 $version ||= $schema->VERSION || '1.x';
960 $sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} };
962 eval "use SQL::Translator";
963 $self->throw_exception("Can't deploy without SQL::Translator: $@") if $@;
965 my $sqlt = SQL::Translator->new($sqltargs);
966 foreach my $db (@$databases)
969 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
970 # $sqlt->parser_args({'DBIx::Class' => $schema);
971 $sqlt->data($schema);
972 $sqlt->producer($db);
975 my $filename = $schema->ddl_filename($db, $dir, $version);
978 $self->throw_exception("$filename already exists, skipping $db");
981 open($file, ">$filename")
982 or $self->throw_exception("Can't open $filename for writing ($!)");
983 my $output = $sqlt->translate;
985 # print join(":", keys %{$schema->source_registrations});
986 # print Dumper($sqlt->schema);
989 $self->throw_exception("Failed to translate to $db. (" . $sqlt->error . ")");
998 =head2 deployment_statements
1000 Create the statements for L</deploy> and
1001 L<DBIx::Class::Schema/deploy>.
1005 sub deployment_statements {
1006 my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
1007 # Need to be connected to get the correct sqlt_type
1008 $self->ensure_connected() unless $type;
1009 $type ||= $self->sqlt_type;
1010 $version ||= $schema->VERSION || '1.x';
1012 eval "use SQL::Translator";
1015 eval "use SQL::Translator::Parser::DBIx::Class;";
1016 $self->throw_exception($@) if $@;
1017 eval "use SQL::Translator::Producer::${type};";
1018 $self->throw_exception($@) if $@;
1019 my $tr = SQL::Translator->new(%$sqltargs);
1020 SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
1021 return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
1024 my $filename = $schema->ddl_filename($type, $dir, $version);
1027 # $schema->create_ddl_dir([ $type ], $version, $dir, $sqltargs);
1028 $self->throw_exception("No SQL::Translator, and no Schema file found, aborting deploy");
1032 open($file, "<$filename")
1033 or $self->throw_exception("Can't open $filename ($!)");
1037 return join('', @rows);
1043 Sends the appropriate statements to create or modify tables to the
1044 db. This would normally be called through
1045 L<DBIx::Class::Schema/deploy>.
1050 my ($self, $schema, $type, $sqltargs) = @_;
1051 foreach my $statement ( $self->deployment_statements($schema, $type, undef, undef, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
1052 for ( split(";\n", $statement)) {
1053 next if($_ =~ /^--/);
1055 # next if($_ =~ /^DROP/m);
1056 next if($_ =~ /^BEGIN TRANSACTION/m);
1057 next if($_ =~ /^COMMIT/m);
1058 next if $_ =~ /^\s+$/; # skip whitespace only
1059 $self->debugobj->query_start($_) if $self->debug;
1060 $self->dbh->do($_) or warn "SQL was:\n $_";
1061 $self->debugobj->query_end($_) if $self->debug;
1066 =head2 datetime_parser
1068 Returns the datetime parser class
1072 sub datetime_parser {
1074 return $self->{datetime_parser} ||= $self->build_datetime_parser(@_);
1077 =head2 datetime_parser_type
1079 Defines (returns) the datetime parser class - currently hardwired to
1080 L<DateTime::Format::MySQL>
1084 sub datetime_parser_type { "DateTime::Format::MySQL"; }
1086 =head2 build_datetime_parser
1088 See L</datetime_parser>
1092 sub build_datetime_parser {
1094 my $type = $self->datetime_parser_type(@_);
1096 $self->throw_exception("Couldn't load ${type}: $@") if $@;
1100 sub DESTROY { shift->disconnect }
1106 The module defines a set of methods within the DBIC::SQL::Abstract
1107 namespace. These build on L<SQL::Abstract::Limit> to provide the
1108 SQL query functions.
1110 The following methods are extended:-
1124 See L</connect_info> for details.
1125 For setting, this method is deprecated in favor of L</connect_info>.
1129 See L</connect_info> for details.
1130 For setting, this method is deprecated in favor of L</connect_info>.
1134 See L</connect_info> for details.
1135 For setting, this method is deprecated in favor of L</connect_info>.
1139 =head1 ENVIRONMENT VARIABLES
1143 If C<DBIC_TRACE> is set then SQL trace information
1144 is produced (as when the L<debug> method is set).
1146 If the value is of the form C<1=/path/name> then the trace output is
1147 written to the file C</path/name>.
1149 This environment variable is checked when the storage object is first
1150 created (when you call connect on your schema). So, run-time changes
1151 to this environment variable will not take effect unless you also
1152 re-connect on your schema.
1154 =head2 DBIX_CLASS_STORAGE_DBI_DEBUG
1156 Old name for DBIC_TRACE
1160 Matt S. Trout <mst@shadowcatsystems.co.uk>
1162 Andy Grundman <andy@hybridized.org>
1166 You may distribute this code under the same terms as Perl itself.