Revision history for DBIx::Class
+ - select et al weren't properly detecing when the server connection
+ had timed out when not in a transaction
+ - The SQL::T parser class now respects a relationship attribute of
+ is_foreign_key_constrain to allow explicit control over wether or not
+ a foreign constraint is needed
+
0.07999_02 2007-01-25 20:11:00
- add support for binding BYTEA and similar parameters (w/Pg impl)
- add support to Ordered for multiple ordering columns
You can make it work like before via
__PACKAGE__->column_info_from_storage(1) for now
- Replaced DBIx::Class::AccessorGroup and Class::Data::Accessor with
- Class::Accessor::Grouped. Only user noticible change is to
- table_class on ResultSourceProxy::Table (i.e. table objects in
- schemas) and, resultset_class and result_class in ResultSource.
+ Class::Accessor::Grouped. Only user noticible change is to
+ table_class on ResultSourceProxy::Table (i.e. table objects in
+ schemas) and, resultset_class and result_class in ResultSource.
These accessors no longer automatically require the classes when
set.
- fixes to pass test suite on Windows
- rewrote and cleaned up SQL::Translator tests
- changed relationship helpers to only call ensure_class_loaded when the
- join condition is inferred
+ join condition is inferred
- rewrote many_to_many implementation, now provides helpers for adding
and deleting objects without dealing with the link table
- reworked InflateColumn implementation to lazily deflate where
- changed join merging to not create a rel_2 alias when adding a join
that already exists in a parent resultset
- Storage::DBI::deployment_statements now calls ensure_connected
- if it isn't passed a type
+ if it isn't passed a type
- fixed Componentized::ensure_class_loaded
- InflateColumn::DateTime supports date as well as datetime
- split Storage::DBI::MSSQL into MSSQL and Sybase::MSSQL
- - fixed wrong debugging hook call in Storage::DBI
- - set connect_info properly before setting any ->sql_maker things
+ - fixed wrong debugging hook call in Storage::DBI
+ - set connect_info properly before setting any ->sql_maker things
0.06999_02 2006-06-09 23:58:33
- Fixed up POD::Coverage tests, filled in some POD holes
dkubb: Dan Kubb <dan.kubb-cpan@onautopilot.com>
+dnm: Justin Wheeler <jwheeler@datademons.com>
+
draven: Marcus Ramberg <mramberg@cpan.org>
dwc: Daniel Westermann-Clark <danieltwc@cpan.org>
a column accessor). For C<multi> accessors, an add_to_* method is also
created, which calls C<create_related> for the relationship.
+=item is_foreign_key_constraint
+
+If you are using L<SQL::Translator> to create SQL for you and you find that it
+is creating constraints where it shouldn't, or not creating them where it
+should, set this attribute to a true or false value to override the detection
+of when to create constraints.
+
=back
=head2 register_relationship
$self->debugobj->query_end($sql_statement) if $self->debug();
}
- # Rebless after we connect to the database, so we can take advantage of
- # values in get_info
- if(ref $self eq 'DBIx::Class::Storage::DBI') {
- my $driver = $self->_dbh->{Driver}->{Name};
- if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
- bless $self, "DBIx::Class::Storage::DBI::${driver}";
- $self->_rebless() if $self->can('_rebless');
- }
- }
-
$self->_conn_pid($$);
$self->_conn_tid(threads->tid) if $INC{'threads.pm'};
}
map { defined ($_ && $_->[1]) ? qq{'$_->[1]'} : q{'NULL'} } @bind;
$self->debugobj->query_start($sql, @debug_bind);
}
- my $sth = eval { $self->sth($sql,$op) };
- if (!$sth || $@) {
- $self->throw_exception(
- 'no sth generated via sql (' . ($@ || $self->_dbh->errstr) . "): $sql"
- );
- }
+ my ($rv, $sth);
+ RETRY: while (1) {
+ $sth = eval { $self->sth($sql,$op) };
- my $rv;
- if ($sth) {
- my $time = time();
- $rv = eval {
- my $placeholder_index = 1;
+ if (!$sth || $@) {
+ $self->throw_exception(
+ 'no sth generated via sql (' . ($@ || $self->_dbh->errstr) . "): $sql"
+ );
+ }
- foreach my $bound (@bind) {
+ if ($sth) {
+ my $time = time();
+ $rv = eval {
+ my $placeholder_index = 1;
- my $attributes = {};
- my($column_name, @data) = @$bound;
+ foreach my $bound (@bind) {
- if( $bind_attributes ) {
- $attributes = $bind_attributes->{$column_name}
- if defined $bind_attributes->{$column_name};
- }
+ my $attributes = {};
+ my($column_name, @data) = @$bound;
- foreach my $data (@data)
- {
- $data = ref $data ? ''.$data : $data; # stringify args
+ if( $bind_attributes ) {
+ $attributes = $bind_attributes->{$column_name}
+ if defined $bind_attributes->{$column_name};
+ }
- $sth->bind_param($placeholder_index, $data, $attributes);
- $placeholder_index++;
+ foreach my $data (@data)
+ {
+ $data = ref $data ? ''.$data : $data; # stringify args
+
+ $sth->bind_param($placeholder_index, $data, $attributes);
+ $placeholder_index++;
+ }
}
+ $sth->execute();
+ };
+
+ if ($@ || !$rv) {
+ $self->throw_exception("Error executing '$sql': ".($@ || $sth->errstr))
+ if $self->connected;
+ $self->_populate_dbh;
+ } else {
+ last RETRY;
}
- $sth->execute();
- };
-
- if ($@ || !$rv) {
- $self->throw_exception("Error executing '$sql': ".($@ || $sth->errstr));
+ } else {
+ $self->throw_exception("'$sql' did not generate a statement.");
}
- } else {
- $self->throw_exception("'$sql' did not generate a statement.");
- }
+ } # While(1) to retry if disconencted
+
if ($self->debug) {
my @debug_bind =
map { defined ($_ && $_->[1]) ? qq{'$_->[1]'} : q{'NULL'} } @bind;
package DBIx::Class::Storage::DBI::Oracle;
-# -*- mode: cperl; cperl-indent-level: 2 -*-
use strict;
use warnings;
use base qw/DBIx::Class::Storage::DBI/;
+print STDERR "Oracle.pm got called.\n";
+
sub _rebless {
- my ($self) = @_;
+ my ($self) = @_;
+
+ print STDERR "Rebless got called.\n";
+
+ my $version = eval { $self->_dbh->get_info(18); };
+
+ if ( !$@ ) {
+ my ($major, $minor, $patchlevel) = split(/\./, $version);
- my $version = eval { $self->_dbh->get_info(18); };
- unless ( $@ ) {
- my ($major,$minor,$patchlevel) = split(/\./,$version);
+ # Default driver
+ my $class = $major >= 8
+ ? 'DBIx::Class::Storage::DBI::Oracle::WhereJoins'
+ : 'DBIx::Class::Storage::DBI::Oracle::Generic';
- # Default driver
- my $class = "DBIx::Class::Storage::DBI::Oracle::Generic";
+ print STDERR "Class: $class\n";
- # Version specific drivers
- $class = "DBIx::Class::Storage::DBI::Oracle::8"
- if $major == 8;
+ # Load and rebless
+ eval "require $class";
- # Load and rebless
- eval "require $class";
- bless $self, $class unless $@;
- }
+ print STDERR "\$@: $@\n";
+ bless $self, $class unless $@;
+ }
}
--- /dev/null
+package DBIx::Class::Storage::DBI::Oracle::WhereJoins;
+
+use base qw( DBIx::Class::Storage::DBI::Oracle::Generic );
+
+use strict;
+use warnings;
+
+BEGIN {
+ package DBIC::SQL::Abstract::Oracle;
+
+ use base qw( DBIC::SQL::Abstract );
+
+ sub select {
+ my ($self, $table, $fields, $where, $order, @rest) = @_;
+
+ $self->_oracle_joins($where, @{ $table });
+
+ return $self->SUPER::select($table, $fields, $where, $order, @rest);
+ }
+
+ sub _recurse_from {
+ my ($self, $from, @join) = @_;
+
+ my @sqlf = $self->_make_as($from);
+
+ foreach my $j (@join) {
+ my ($to, $on) = @{ $j };
+
+ if (ref $to eq 'ARRAY') {
+ push (@sqlf, $self->_recurse_from(@{ $to }));
+ }
+ else {
+ push (@sqlf, $self->_make_as($to));
+ }
+ }
+
+ return join q{, }, @sqlf;
+ }
+
+ sub _oracle_joins {
+ my ($self, $where, $from, @join) = @_;
+
+ foreach my $j (@join) {
+ my ($to, $on) = @{ $j };
+
+ if (ref $to eq 'ARRAY') {
+ $self->_oracle_joins($where, @{ $to });
+ }
+
+ my $to_jt = ref $to eq 'ARRAY' ? $to->[0] : $to;
+ my $left_join = q{};
+ my $right_join = q{};
+
+ if (ref $to_jt eq 'HASH' and exists $to_jt->{-join_type}) {
+ #TODO: Support full outer joins -- this would happen much earlier in
+ #the sequence since oracle 8's full outer join syntax is best
+ #described as INSANE.
+ die "Can't handle full outer joins in Oracle 8 yet!\n"
+ if $to_jt->{-join_type} =~ /full/i;
+
+ $left_join = q{(+)} if $to_jt->{-join_type} =~ /right/i
+ && $to_jt->{-join_type} !~ /inner/i;
+
+ $right_join = q{(+)} if $to_jt->{-join_type} =~ /left/i
+ && $to_jt->{-join_type} !~ /inner/i;
+ }
+
+ foreach my $lhs (keys %{ $on }) {
+ $where->{$lhs . $left_join} = \" = $on->{ $lhs }$right_join";
+ }
+ }
+ }
+}
+
+sub sql_maker {
+ my ($self) = @_;
+
+ unless ($self->_sql_maker) {
+ $self->_sql_maker(
+ new DBIC::SQL::Abstract::Oracle( $self->_sql_maker_args )
+ );
+ }
+
+ return $self->_sql_maker;
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::Oracle::WhereJoins - Oracle joins in WHERE syntax
+support (instead of ANSI).
+
+=head1 PURPOSE
+
+This module was originally written to support Oracle < 9i where ANSI joins
+weren't supported at all, but became the module for Oracle >= 8 because
+Oracle's optimising of ANSI joins is horrible. (See:
+http://scsys.co.uk:8001/7495)
+
+=head1 SYNOPSIS
+
+DBIx::Class should automagically detect Oracle and use this module with no
+work from you.
+
+=head1 DESCRIPTION
+
+This class implements Oracle's WhereJoin support. Instead of:
+
+ SELECT x FROM y JOIN z ON y.id = z.id
+
+It will write:
+
+ SELECT x FROM y, z WHERE y.id = z.id
+
+It should properly support left joins, and right joins. Full outer joins are
+not possible due to the fact that Oracle requires the entire query be written
+to union the results of a left and right join, and by the time this module is
+called to create the where query and table definition part of the sql query,
+it's already too late.
+
+=head1 METHODS
+
+This module replaces a subroutine contained in DBIC::SQL::Abstract:
+
+=over
+
+=item sql_maker
+
+=back
+
+It also creates a new module in its BEGIN { } block called
+DBIC::SQL::Abstract::Oracle which has the following methods:
+
+=over
+
+=item select ($\@$;$$@)
+
+Replaces DBIC::SQL::Abstract's select() method, which calls _oracle_joins()
+to modify the column and table list before calling SUPER::select().
+
+=item _recurse_from ($$\@)
+
+Recursive subroutine that builds the table list.
+
+=item _oracle_joins ($$$@)
+
+Creates the left/right relationship in the where query.
+
+=back
+
+=head1 BUGS
+
+Does not support full outer joins.
+Probably lots more.
+
+=head1 SEE ALSO
+
+=over
+
+=item L<DBIC::SQL::Abstract>
+
+=item L<DBIx::Class::Storage::DBI::Oracle::Generic>
+
+=item L<DBIx::Class>
+
+=back
+
+=head1 AUTHOR
+
+Justin Wheeler C<< <jwheeler@datademons.com> >>
+
+=head1 CONTRIBUTORS
+
+David Jack Olrik C<< <djo@cpan.org> >>
+
+=head1 LICENSE
+
+This module is licensed under the same terms as Perl itself.
+
+=cut
#Decide if this is a foreign key based on whether the self
#items are our primary columns.
+ $DB::single = 1 if $moniker eq 'Tests::MBTI::Result';
# If the sets are different, then we assume it's a foreign key from
# us to another table.
- # OR: If is_foreign_key attr is explicity set on one the local columns
- if ( ! exists $created_FK_rels{$rel_table}->{$key_test}
- &&
- ( !$source->compare_relationship_keys(\@keys, \@primary) ||
- grep { $source->column_info($_)->{is_foreign_key} } @keys
- )
- ) {
+ # OR: If is_foreign_key_constraint attr is explicity set (or set to false) on the relation
+ if ( ! exists $created_FK_rels{$rel_table}->{$key_test} &&
+ ( exists $rel_info->{attrs}{is_foreign_key_constraint} &&
+ $rel_info->{attrs}{is_foreign_key_constraint} ||
+ !$source->compare_relationship_keys(\@keys, \@primary)
+ )
+ )
+ {
$created_FK_rels{$rel_table}->{$key_test} = 1;
$table->add_constraint(
type => 'foreign_key',
use Test::More;
use lib qw(t/lib);
use DBICTest;
+use DBICTest::ExplodingStorage;
-plan tests => 1;
+plan tests => 3;
my $schema = DBICTest->init_schema();
is( ref($schema->storage), 'DBIx::Class::Storage::DBI::SQLite',
'Storage reblessed correctly into DBIx::Class::Storage::DBI::SQLite' );
+
+my $storage = $schema->storage;
+$storage->ensure_connected;
+
+bless $storage, "DBICTest::ExplodingStorage";
+$schema->storage($storage);
+
+eval {
+ $schema->resultset('Artist')->create({ name => "Exploding Sheep" })
+};
+
+is($@, "", "Exploding \$sth->execute was caught");
+
+is(1, $schema->resultset('Artist')->search({name => "Exploding Sheep" })->count,
+ "And the STH was retired");
+
+
1;
--- /dev/null
+package DBICTest::ExplodingStorage::Sth;
+
+sub execute {
+ die "Kablammo!";
+}
+
+sub bind_param {}
+
+package DBICTest::ExplodingStorage;
+
+use strict;
+use warnings;
+
+use base 'DBIx::Class::Storage::DBI::SQLite';
+
+my $count = 0;
+sub sth {
+ my ($self, $sql) = @_;
+ return bless {}, "DBICTest::ExplodingStorage::Sth" unless $count++;
+ return $self->next::method($sql);
+}
+
+sub connected {
+ return 0 if $count == 1;
+ return shift->next::method(@_);
+}
+
+1;
projects / dbsrgits/DBIx-Class.git / commitdiff