X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBI.pm;h=14cc4abb9622803617a0a915503ca673e5c07c56;hb=9d678dc6f3e5153bf999ff6befdcafa144345e43;hp=c533fec642e96be949dadb5663535ba8a5fc4e2e;hpb=d79f59b9f1008f4b8e9d34666cbb27d32c425824;p=dbsrgits%2FDBIx-Class-Historic.git diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index c533fec..14cc4ab 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,22 +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 on_connect_do transaction_depth/); + 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; } @@ -166,14 +201,62 @@ This class represents the connection to the database 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 dbh { +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; } @@ -189,7 +272,11 @@ sub _populate_dbh { my ($self) = @_; my @info = @{$self->connect_info || []}; $self->_dbh($self->_connect(@info)); - + my $driver = $self->_dbh->{Driver}->{Name}; + eval "require DBIx::Class::Storage::DBI::${driver}"; + unless ($@) { + bless $self, "DBIx::Class::Storage::DBI::${driver}"; + } # if on-connect sql statements are given execute them foreach my $sql_statement (@{$self->on_connect_do || []}) { $self->_dbh->do($sql_statement); @@ -248,16 +335,24 @@ 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); @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; } @@ -296,10 +391,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 { @@ -338,8 +437,29 @@ sub columns_info_for { return \%result; } +sub last_insert_id { + my ($self, $row) = @_; + + return $self->dbh->func('last_insert_rowid'); + +} + + + +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