X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBI.pm;h=f643441b8da83c4acf0753c1fd7124b0ef2ba57a;hb=dec2517f954b8c6053570a6b5ecf08fbaf1a2bc2;hp=c9db1080beab442c9ffbd0d3a2792f627b527d11;hpb=cb5f2eeaf536e93839c858bc02da9573e926e4f2;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index c9db108..f643441 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -5,6 +5,8 @@ use warnings; use DBI; use SQL::Abstract::Limit; use DBIx::Class::Storage::DBI::Cursor; +use IO::File; +use Carp::Clan qw/DBIx::Class/; BEGIN { @@ -128,23 +130,55 @@ sub _join_condition { sub _quote { my ($self, $label) = @_; return '' unless defined $label; + return $label unless $self->{quote_char}; return $self->SUPER::_quote($label); } +sub _RowNum { + my $self = shift; + my $c; + $_[0] =~ s/SELECT (.*?) FROM/ + 'SELECT '.join(', ', map { $_.' AS col'.++$c } split(', ', $1)).' FROM'/e; + $self->SUPER::_RowNum(@_); +} + +# Accessor for setting limit dialect. This is useful +# for JDBC-bridge among others where the remote SQL-dialect cannot +# be determined by the name of the driver alone. +# +sub limit_dialect { + my $self = shift; + $self->{limit_dialect} = shift if @_; + return $self->{limit_dialect}; +} + +package DBIx::Class::Storage::DBI::DebugCallback; + +sub print { + my ($self, $string) = @_; + $string =~ m/^(\w+)/; + ${$self}->($1, $string); +} + } # End of BEGIN block use base qw/DBIx::Class/; -__PACKAGE__->load_components(qw/Exception AccessorGroup/); +__PACKAGE__->load_components(qw/AccessorGroup/); __PACKAGE__->mk_group_accessors('simple' => - qw/connect_info _dbh _sql_maker debug cursor/); - -our $TRANSACTION = 0; + qw/connect_info _dbh _sql_maker debug debugfh cursor on_connect_do transaction_depth/); sub new { my $new = bless({}, ref $_[0] || $_[0]); $new->cursor("DBIx::Class::Storage::DBI::Cursor"); + $new->transaction_depth(0); + if (defined($ENV{DBIX_CLASS_STORAGE_DBI_DEBUG}) && + ($ENV{DBIX_CLASS_STORAGE_DBI_DEBUG} =~ /=(.+)$/)) { + $new->debugfh(IO::File->new($1, 'w')||croak "Cannot open trace file $1"); + } else { + $new->debugfh(IO::File->new('>&STDERR')); + } $new->debug(1) if $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG}; return $new; } @@ -163,12 +197,66 @@ This class represents the connection to the database =cut -sub dbh { +=head2 on_connect_do + +Executes the sql statements given as a listref on every db connect. + +=head2 debug + +Causes SQL trace information to be emitted on C filehandle +(or C if C has not specifically been set). + +=head2 debugfh + +Sets or retrieves the filehandle used for trace/debug output. This +should be an IO::Handle compatible object (only the C method is +used). Initially set to be STDERR - although see information on the +L environment variable. + +=head2 debugcb + +Sets a callback to be executed each time a statement is run; takes a sub +reference. Overrides debugfh. Callback is executed as $sub->($op, $info) +where $op is SELECT/INSERT/UPDATE/DELETE and $info is what would normally +be printed. + +=cut + +sub debugcb { + my ($self, $cb) = @_; + my $cb_obj = bless(\$cb, 'DBIx::Class::Storage::DBI::DebugCallback'); + $self->debugfh($cb_obj); +} + +sub disconnect { my ($self) = @_; + + if( $self->connected ) { + $self->_dbh->rollback unless $self->_dbh->{AutoCommit}; + $self->_dbh->disconnect; + $self->_dbh(undef); + } +} + +sub connected { + my ($self) = @_; + my $dbh; - unless (($dbh = $self->_dbh) && $dbh->FETCH('Active') && $dbh->ping) { + (($dbh = $self->_dbh) && $dbh->FETCH('Active') && $dbh->ping) +} + +sub ensure_connected { + my ($self) = @_; + + unless ($self->connected) { $self->_populate_dbh; } +} + +sub dbh { + my ($self) = @_; + + $self->ensure_connected; return $self->_dbh; } @@ -184,6 +272,11 @@ sub _populate_dbh { my ($self) = @_; my @info = @{$self->connect_info || []}; $self->_dbh($self->_connect(@info)); + + # if on-connect sql statements are given execute them + foreach my $sql_statement (@{$self->on_connect_do || []}) { + $self->_dbh->do($sql_statement); + } } sub _connect { @@ -198,7 +291,8 @@ Calls begin_work on the current dbh. =cut sub txn_begin { - $_[0]->dbh->begin_work if $TRANSACTION++ == 0 and $_[0]->dbh->{AutoCommit}; + my $self = shift; + $self->dbh->begin_work if $self->{transaction_depth}++ == 0 and $self->dbh->{AutoCommit}; } =head2 txn_commit @@ -208,11 +302,12 @@ Issues a commit against the current dbh. =cut sub txn_commit { - if ($TRANSACTION == 0) { - $_[0]->dbh->commit; + my $self = shift; + if ($self->{transaction_depth} == 0) { + $self->dbh->commit unless $self->dbh->{AutoCommit}; } else { - $_[0]->dbh->commit if --$TRANSACTION == 0; + $self->dbh->commit if --$self->{transaction_depth} == 0; } } @@ -223,11 +318,12 @@ Issues a rollback against the current dbh. =cut sub txn_rollback { - if ($TRANSACTION == 0) { - $_[0]->dbh->rollback; + my $self = shift; + if ($self->{transaction_depth} == 0) { + $self->dbh->rollback unless $self->dbh->{AutoCommit}; } else { - --$TRANSACTION == 0 ? $_[0]->dbh->rollback : die $@; + --$self->{transaction_depth} == 0 ? $self->dbh->rollback : die $@; } } @@ -235,16 +331,25 @@ sub _execute { my ($self, $op, $extra_bind, $ident, @args) = @_; my ($sql, @bind) = $self->sql_maker->$op($ident, @args); unshift(@bind, @$extra_bind) if $extra_bind; - warn "$sql: @bind" if $self->debug; + if ($self->debug) { + my @debug_bind = map { defined $_ ? $_ : 'NULL' } @bind; + $self->debugfh->print("$sql: @debug_bind\n"); + } my $sth = $self->sth($sql,$op); + croak "no sth generated via sql: $sql" unless $sth; @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args - my $rv = $sth->execute(@bind); + my $rv; + if ($sth) { + $rv = $sth->execute(@bind); + } else { + croak "'$sql' did not generate a statement."; + } return (wantarray ? ($rv, $sth, @bind) : $rv); } sub insert { my ($self, $ident, $to_insert) = @_; - $self->throw( "Couldn't insert ".join(', ', map "$_ => $to_insert->{$_}", keys %$to_insert)." into ${ident}" ) + croak( "Couldn't insert ".join(', ', map "$_ => $to_insert->{$_}", keys %$to_insert)." into ${ident}" ) unless ($self->_execute('insert' => [], $ident, $to_insert)); return $to_insert; } @@ -283,10 +388,14 @@ sub select { return $self->cursor->new($self, \@_, $attrs); } +# Need to call finish() to work round broken DBDs + sub select_single { my $self = shift; my ($rv, $sth, @bind) = $self->_select(@_); - return $sth->fetchrow_array; + my @row = $sth->fetchrow_array; + $sth->finish(); + return @row; } sub sth { @@ -295,8 +404,50 @@ sub sth { return $self->dbh->prepare_cached($sql, {}, 3); } +=head2 columns_info_for + +Returns database type info for a given table columns. + +=cut + +sub columns_info_for { + my ($self, $table) = @_; + my %result; + if ( $self->dbh->can( 'column_info' ) ){ + my $sth = $self->dbh->column_info( undef, undef, $table, '%' ); + $sth->execute(); + while ( my $info = $sth->fetchrow_hashref() ){ + my %column_info; + $column_info{data_type} = $info->{TYPE_NAME}; + $column_info{size} = $info->{COLUMN_SIZE}; + $column_info{is_nullable} = $info->{NULLABLE}; + $result{$info->{COLUMN_NAME}} = \%column_info; + } + }else{ + my $sth = $self->dbh->prepare("SELECT * FROM $table WHERE 1=0"); + $sth->execute; + my @columns = @{$sth->{NAME}}; + for my $i ( 0 .. $#columns ){ + $result{$columns[$i]}{data_type} = $sth->{TYPE}->[$i]; + } + } + return \%result; +} + +sub DESTROY { shift->disconnect } + 1; +=head1 ENVIRONMENT VARIABLES + +=head2 DBIX_CLASS_STORAGE_DBI_DEBUG + +If C is set then SQL trace information +is produced (as when the L method is set). + +If the value is of the form C<1=/path/name> then the trace output is +written to the file C. + =head1 AUTHORS Matt S. Trout