From: Peter Rabbitson Date: Sun, 15 Nov 2009 12:13:42 +0000 (+0000) Subject: Merge 'trunk' into 'prefetch-group_by' X-Git-Tag: v0.08116~138^2~2 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c42eb796da02b36daa77e5722934853e94690afc;hp=d59eba65fea17274d25f2676d96bb116795f07c9;p=dbsrgits%2FDBIx-Class.git Merge 'trunk' into 'prefetch-group_by' r7858@Thesaurus (orig r7846): caelum | 2009-11-06 16:01:30 +0100 transactions for MSSQL over DBD::Sybase r7861@Thesaurus (orig r7849): caelum | 2009-11-10 13:16:18 +0100 made commit/rollback when disconnected an exception r7862@Thesaurus (orig r7850): robkinyon | 2009-11-10 17:19:57 +0100 Added a note about select r7863@Thesaurus (orig r7851): ribasushi | 2009-11-10 18:23:10 +0100 Changes r7867@Thesaurus (orig r7855): frew | 2009-11-11 21:56:37 +0100 RT50874 r7868@Thesaurus (orig r7856): frew | 2009-11-11 23:50:43 +0100 RT50828 r7869@Thesaurus (orig r7857): frew | 2009-11-11 23:54:15 +0100 clearer test message r7870@Thesaurus (orig r7858): frew | 2009-11-12 00:37:27 +0100 some cleanup for $rs->populate r7872@Thesaurus (orig r7860): ribasushi | 2009-11-12 01:35:36 +0100 Fix find on resultset with custom result_class r7873@Thesaurus (orig r7861): ribasushi | 2009-11-12 01:40:14 +0100 Fix return value of in_storage r7874@Thesaurus (orig r7862): ribasushi | 2009-11-12 01:43:48 +0100 Extra FAQ entry r7875@Thesaurus (orig r7863): ribasushi | 2009-11-12 02:11:25 +0100 Sanify _determine_driver handling in ::Storage::DBI r7876@Thesaurus (orig r7864): ribasushi | 2009-11-12 02:14:37 +0100 Add mysql determine_driver test by Pedro Melo r7881@Thesaurus (orig r7869): ribasushi | 2009-11-12 11:10:04 +0100 _cond_for_update_delete is hopelessly broken attempting to introspect SQLA1. Replace with a horrific but effective hack r7882@Thesaurus (orig r7870): ribasushi | 2009-11-12 11:15:12 +0100 Clarifying comment r7884@Thesaurus (orig r7872): ribasushi | 2009-11-13 00:13:40 +0100 The real fix for the non-introspectable condition bug, mst++ r7885@Thesaurus (orig r7873): ribasushi | 2009-11-13 00:24:56 +0100 Some cleanup r7887@Thesaurus (orig r7875): frew | 2009-11-13 10:01:37 +0100 fix subtle bug with Sybase database type determination r7892@Thesaurus (orig r7880): frew | 2009-11-14 00:53:29 +0100 release woo! r7894@Thesaurus (orig r7882): caelum | 2009-11-14 03:57:52 +0100 fix oracle dep in Makefile.PL r7895@Thesaurus (orig r7883): caelum | 2009-11-14 04:20:53 +0100 skip Oracle BLOB tests on DBD::Oracle == 1.23 r7897@Thesaurus (orig r7885): caelum | 2009-11-14 09:40:01 +0100 r7357@pentium (orig r7355): caelum | 2009-08-20 17:58:23 -0400 branch to support MSSQL over ADO r7358@pentium (orig r7356): caelum | 2009-08-21 00:32:14 -0400 something apparently working r7359@pentium (orig r7357): caelum | 2009-08-21 00:53:53 -0400 slightly better mars test, still passes r7899@Thesaurus (orig r7887): caelum | 2009-11-14 09:41:54 +0100 r7888@pentium (orig r7886): caelum | 2009-11-14 03:41:25 -0500 add TODO test for large column list in select r7901@Thesaurus (orig r7889): caelum | 2009-11-14 09:47:16 +0100 add ADO/MSSQL to Changes r7902@Thesaurus (orig r7890): caelum | 2009-11-14 10:27:29 +0100 fix the large column list test for ADO/MSSQL, now passes r7904@Thesaurus (orig r7892): caelum | 2009-11-14 12:20:58 +0100 fix Changes (ADO change in wrong release) r7905@Thesaurus (orig r7893): ribasushi | 2009-11-14 19:23:23 +0100 Release 0.08114 r7907@Thesaurus (orig r7895): ribasushi | 2009-11-15 12:09:17 +0100 Failing test to highlight mssql autoconnect regression r7908@Thesaurus (orig r7896): ribasushi | 2009-11-15 12:20:25 +0100 Fix plan r7913@Thesaurus (orig r7901): ribasushi | 2009-11-15 13:11:38 +0100 r7773@Thesaurus (orig r7761): norbi | 2009-10-05 14:49:06 +0200 Created branch 'prefetch_bug-unqualified_column_in_search_related_cond': A bug that manifests when a prefetched table's column is referenced without the table name in the condition of a search_related() on an M:N relationship. r7878@Thesaurus (orig r7866): ribasushi | 2009-11-12 02:36:08 +0100 Factor some code out r7879@Thesaurus (orig r7867): ribasushi | 2009-11-12 09:11:03 +0100 Factor out more stuff r7880@Thesaurus (orig r7868): ribasushi | 2009-11-12 09:21:04 +0100 Saner naming/comments r7910@Thesaurus (orig r7898): ribasushi | 2009-11-15 12:39:29 +0100 Move more code to DBIHacks, put back the update/delete rs check, just in case r7911@Thesaurus (orig r7899): ribasushi | 2009-11-15 13:01:34 +0100 TODOify test until we get an AST r7912@Thesaurus (orig r7900): ribasushi | 2009-11-15 13:10:15 +0100 Hide from pause --- diff --git a/Changes b/Changes index f76cc0a..0f2dead 100644 --- a/Changes +++ b/Changes @@ -1,6 +1,14 @@ Revision history for DBIx::Class - +0.08114 2009-11-14 17:45:00 (UTC) + - Preliminary support for MSSQL via DBD::ADO + - Fix botched 0.08113 release (invalid tarball) + +0.08113 2009-11-13 23:13:00 (UTC) + - Fix populate with has_many bug + (RT #50828) + - Fix Oracle autoincrement broken for Resultsets with scalar refs + (RT #50874) - Complete Sybase RDBMS support including: - Support for TEXT/IMAGE columns - Support for the 'money' datatype @@ -13,6 +21,7 @@ Revision history for DBIx::Class - Support for interpolated variables with proper quoting when connecting to an older Sybase and/or via FreeTDS - bulk API support for populate() + - Transaction support for MSSQL via DBD::Sybase - Add is_paged method to DBIx::Class::ResultSet so that we can check that if we want a pager - Skip versioning test on really old perls lacking Time::HiRes @@ -23,6 +32,16 @@ Revision history for DBIx::Class - Fixed another lingering problem with PostgreSQL auto-increment support and its interaction with multiple schemas + - Remove some IN workarounds, and require a recent version of + SQLA instead + - Improvements to populate's handling of mixed scalarref values + - Fixed regression losing result_class after $rs->find (introduced + in 0.08108) + - Fix in_storage() to return 1|0 as per existing documentation + - Centralize handling of _determine_driver calls prior to certain + ::Storage::DBI methods + - Fix update/delete arbitrary condition handling (RT#51409) + - POD improvements 0.08112 2009-09-21 10:57:00 (UTC) - Remove the recommends from Makefile.PL, DBIx::Class is not diff --git a/Makefile.PL b/Makefile.PL index 51e0f2a..2332153 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -110,7 +110,7 @@ my %force_requires_if_author = ( ) : () , - $ENV{DBICTEST_ORACLE_DSN} + $ENV{DBICTEST_ORA_DSN} ? ( 'DateTime::Format::Oracle' => '0', ) : () @@ -148,6 +148,7 @@ no_index 'DBIx::Class::SQLAHacks::MSSQL'; no_index 'DBIx::Class::Storage::DBI::AmbiguousGlob'; no_index 'DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server'; no_index 'DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server::NoBindVars'; +no_index 'DBIx::Class::Storage::DBIHacks'; # re-build README and require extra modules for testing if we're in a checkout diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm index 5f9c4c3..07b678c 100644 --- a/lib/DBIx/Class.pm +++ b/lib/DBIx/Class.pm @@ -24,7 +24,7 @@ sub component_base_class { 'DBIx::Class' } # Always remember to do all digits for the version even if they're 0 # i.e. first release of 0.XX *must* be 0.XX000. This avoids fBSD ports # brain damage and presumably various other packaging systems too -$VERSION = '0.08112'; +$VERSION = '0.08114'; $VERSION = eval $VERSION; # numify for warning-free dev releases @@ -115,7 +115,7 @@ Then you can use these classes in your application's code: my $all_artists_rs = $schema->resultset('Artist'); # Output all artists names - # $artist here is a DBIx::Class::Row, which has accessors + # $artist here is a DBIx::Class::Row, which has accessors # for all its columns. Rows are also subclasses of your Result class. foreach $artist (@artists) { print $artist->name, "\n"; diff --git a/lib/DBIx/Class/Manual/FAQ.pod b/lib/DBIx/Class/Manual/FAQ.pod index 4a5d7ba..6d35ae6 100644 --- a/lib/DBIx/Class/Manual/FAQ.pod +++ b/lib/DBIx/Class/Manual/FAQ.pod @@ -371,6 +371,9 @@ C supplied with C. =item .. insert many rows of data efficiently? +The C method in L provides +efficient bulk inserts. + =item .. update a collection of rows at the same time? Create a resultset using a search, to filter the rows of data you diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index fbd676f..61b2a16 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -357,9 +357,9 @@ sub search_rs { } my $rs = (ref $self)->new($self->result_source, $new_attrs); - if ($rows) { - $rs->set_cache($rows); - } + + $rs->set_cache($rows) if ($rows); + return $rs; } @@ -530,7 +530,7 @@ sub find { } # Run the query - my $rs = $self->search ($query, $attrs); + my $rs = $self->search ($query, {result_class => $self->result_class, %$attrs}); if (keys %{$rs->_resolved_attrs->{collapse}}) { my $row = $rs->next; carp "Query returned more than one row" if $rs->next; @@ -1248,7 +1248,7 @@ sub _count_rs { $tmp_attrs->{as} = 'count'; # read the comment on top of the actual function to see what this does - $tmp_attrs->{from} = $self->_switch_to_inner_join_if_needed ( + $tmp_attrs->{from} = $self->result_source->schema->storage->_straight_join_to_node ( $tmp_attrs->{from}, $tmp_attrs->{alias} ); @@ -1280,11 +1280,13 @@ sub _count_subq_rs { $sub_attrs->{select} = $rsrc->storage->_subq_count_select ($rsrc, $sub_attrs); # read the comment on top of the actual function to see what this does - $sub_attrs->{from} = $self->_switch_to_inner_join_if_needed ( + $sub_attrs->{from} = $self->result_source->schema->storage->_straight_join_to_node ( $sub_attrs->{from}, $sub_attrs->{alias} ); - # this is so that ordering can be thrown away in things like Top limit + # this is so that the query can be simplified e.g. + # * non-limiting joins can be pruned + # * ordering can be thrown away in things like Top limit $sub_attrs->{-for_count_only} = 1; my $sub_rs = $rsrc->resultset_class->new ($rsrc, $sub_attrs); @@ -1301,77 +1303,6 @@ sub _count_subq_rs { return $self->_count_rs ($attrs); } - -# The DBIC relationship chaining implementation is pretty simple - every -# new related_relationship is pushed onto the {from} stack, and the {select} -# window simply slides further in. This means that when we count somewhere -# in the middle, we got to make sure that everything in the join chain is an -# actual inner join, otherwise the count will come back with unpredictable -# results (a resultset may be generated with _some_ rows regardless of if -# the relation which the $rs currently selects has rows or not). E.g. -# $artist_rs->cds->count - normally generates: -# SELECT COUNT( * ) FROM artist me LEFT JOIN cd cds ON cds.artist = me.artistid -# which actually returns the number of artists * (number of cds || 1) -# -# So what we do here is crawl {from}, determine if the current alias is at -# the top of the stack, and if not - make sure the chain is inner-joined down -# to the root. -# -sub _switch_to_inner_join_if_needed { - my ($self, $from, $alias) = @_; - - # subqueries and other oddness is naturally not supported - return $from if ( - ref $from ne 'ARRAY' - || - @$from <= 1 - || - ref $from->[0] ne 'HASH' - || - ! $from->[0]{-alias} - || - $from->[0]{-alias} eq $alias - ); - - my $switch_branch; - JOINSCAN: - for my $j (@{$from}[1 .. $#$from]) { - if ($j->[0]{-alias} eq $alias) { - $switch_branch = $j->[0]{-join_path}; - last JOINSCAN; - } - } - - # something else went wrong - return $from unless $switch_branch; - - # So it looks like we will have to switch some stuff around. - # local() is useless here as we will be leaving the scope - # anyway, and deep cloning is just too fucking expensive - # So replace the inner hashref manually - my @new_from = ($from->[0]); - my $sw_idx = { map { $_ => 1 } @$switch_branch }; - - for my $j (@{$from}[1 .. $#$from]) { - my $jalias = $j->[0]{-alias}; - - if ($sw_idx->{$jalias}) { - my %attrs = %{$j->[0]}; - delete $attrs{-join_type}; - push @new_from, [ - \%attrs, - @{$j}[ 1 .. $#$j ], - ]; - } - else { - push @new_from, $j; - } - } - - return \@new_from; -} - - sub _bool { return 1; } @@ -1495,8 +1426,12 @@ sub _rs_update_delete { my $rsrc = $self->result_source; + # if a condition exists we need to strip all table qualifiers + # if this is not possible we'll force a subquery below + my $cond = $rsrc->schema->storage->_strip_cond_qualifiers ($self->{cond}); + my $needs_group_by_subq = $self->_has_resolved_attr (qw/collapse group_by -join/); - my $needs_subq = $self->_has_resolved_attr (qw/row offset/); + my $needs_subq = (not defined $cond) || $self->_has_resolved_attr(qw/row offset/); if ($needs_group_by_subq or $needs_subq) { @@ -1544,70 +1479,11 @@ sub _rs_update_delete { return $rsrc->storage->$op( $rsrc, $op eq 'update' ? $values : (), - $self->_cond_for_update_delete, + $cond, ); } } - -# _cond_for_update_delete -# -# update/delete require the condition to be modified to handle -# the differing SQL syntax available. This transforms the $self->{cond} -# appropriately, returning the new condition. - -sub _cond_for_update_delete { - my ($self, $full_cond) = @_; - my $cond = {}; - - $full_cond ||= $self->{cond}; - # No-op. No condition, we're updating/deleting everything - return $cond unless ref $full_cond; - - if (ref $full_cond eq 'ARRAY') { - $cond = [ - map { - my %hash; - foreach my $key (keys %{$_}) { - $key =~ /([^.]+)$/; - $hash{$1} = $_->{$key}; - } - \%hash; - } @{$full_cond} - ]; - } - elsif (ref $full_cond eq 'HASH') { - if ((keys %{$full_cond})[0] eq '-and') { - $cond->{-and} = []; - my @cond = @{$full_cond->{-and}}; - for (my $i = 0; $i < @cond; $i++) { - my $entry = $cond[$i]; - my $hash; - if (ref $entry eq 'HASH') { - $hash = $self->_cond_for_update_delete($entry); - } - else { - $entry =~ /([^.]+)$/; - $hash->{$1} = $cond[++$i]; - } - push @{$cond->{-and}}, $hash; - } - } - else { - foreach my $key (keys %{$full_cond}) { - $key =~ /([^.]+)$/; - $cond->{$1} = $full_cond->{$key}; - } - } - } - else { - $self->throw_exception("Can't update/delete on resultset with condition unless hash or array"); - } - - return $cond; -} - - =head2 update =over 4 @@ -1794,15 +1670,19 @@ sub populate { } return wantarray ? @created : \@created; } else { - my ($first, @rest) = @$data; - - require overload; - my @names = grep { - (not ref $first->{$_}) || (ref $first->{$_} eq 'SCALAR') || - (overload::Method($first->{$_}, '""')) - } keys %$first; + my $first = $data->[0]; + + # if a column is a registered relationship, and is a non-blessed hash/array, consider + # it relationship data + my (@rels, @columns); + for (keys %$first) { + my $ref = ref $first->{$_}; + $self->result_source->has_relationship($_) && ($ref eq 'ARRAY' or $ref eq 'HASH') + ? push @rels, $_ + : push @columns, $_ + ; + } - my @rels = grep { $self->result_source->has_relationship($_) } keys %$first; my @pks = $self->result_source->primary_columns; ## do the belongs_to relationships @@ -1831,17 +1711,15 @@ sub populate { delete $data->[$index]->{$rel}; $data->[$index] = {%{$data->[$index]}, %$related}; - push @names, keys %$related if $index == 0; + push @columns, keys %$related if $index == 0; } } ## do bulk insert on current row - my @values = map { [ @$_{@names} ] } @$data; - $self->result_source->storage->insert_bulk( $self->result_source, - \@names, - \@values, + \@columns, + [ map { [ @$_{@columns} ] } @$data ], ); ## do the has_many relationships @@ -1850,7 +1728,7 @@ sub populate { foreach my $rel (@rels) { next unless $item->{$rel} && ref $item->{$rel} eq "ARRAY"; - my $parent = $self->find(map {{$_=>$item->{$_}} } @pks) + my $parent = $self->find({map { $_ => $item->{$_} } @pks}) || $self->throw_exception('Cannot find the relating object.'); my $child = $parent->$rel; @@ -3260,6 +3138,9 @@ When you use function/stored procedure names and do not supply an C attribute, the column names returned are storage-dependent. E.g. MySQL would return a column named C in the above example. +B You will almost always need a corresponding 'as' entry when you use +'select'. + =head2 +select =over 4 diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm index f708d21..75b64db 100644 --- a/lib/DBIx/Class/Row.pm +++ b/lib/DBIx/Class/Row.pm @@ -424,7 +424,7 @@ L on one, sets it to false. sub in_storage { my ($self, $val) = @_; $self->{_in_storage} = $val if @_ > 1; - return $self->{_in_storage}; + return $self->{_in_storage} ? 1 : 0; } =head2 update diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 1e558e8..60c6277 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -4,7 +4,7 @@ package DBIx::Class::Storage::DBI; use strict; use warnings; -use base 'DBIx::Class::Storage'; +use base qw/DBIx::Class::Storage::DBIHacks DBIx::Class::Storage/; use mro 'c3'; use Carp::Clan qw/^DBIx::Class/; @@ -41,6 +41,38 @@ __PACKAGE__->mk_group_accessors('inherited' => qw/sql_maker_class/); __PACKAGE__->sql_maker_class('DBIx::Class::SQLAHacks'); +# Each of these methods need _determine_driver called before itself +# in order to function reliably. This is a purely DRY optimization +my @rdbms_specific_methods = qw/ + sqlt_type + build_datetime_parser + datetime_parser_type + + insert + insert_bulk + update + delete + select + select_single +/; + +for my $meth (@rdbms_specific_methods) { + + my $orig = __PACKAGE__->can ($meth) + or next; + + no strict qw/refs/; + no warnings qw/redefine/; + *{__PACKAGE__ ."::$meth"} = sub { + if (not $_[0]->_driver_determined) { + $_[0]->_determine_driver; + goto $_[0]->can($meth); + } + $orig->(@_); + }; +} + + =head1 NAME DBIx::Class::Storage::DBI - DBI storage handler @@ -713,7 +745,6 @@ in MySQL's case disabled entirely. # Storage subclasses should override this sub with_deferred_fk_checks { my ($self, $sub) = @_; - $sub->(); } @@ -1145,7 +1176,6 @@ sub _dbh_begin_work { sub txn_commit { my $self = shift; if ($self->{transaction_depth} == 1) { - my $dbh = $self->_dbh; $self->debugobj->txn_commit() if ($self->debug); $self->_dbh_commit; @@ -1161,7 +1191,9 @@ sub txn_commit { sub _dbh_commit { my $self = shift; - $self->_dbh->commit; + my $dbh = $self->_dbh + or $self->throw_exception('cannot COMMIT on a disconnected handle'); + $dbh->commit; } sub txn_rollback { @@ -1198,7 +1230,9 @@ sub txn_rollback { sub _dbh_rollback { my $self = shift; - $self->_dbh->rollback; + my $dbh = $self->_dbh + or $self->throw_exception('cannot ROLLBACK on a disconnected handle'); + $dbh->rollback; } # This used to be the top-half of _execute. It was split out to make it @@ -1301,12 +1335,6 @@ sub _execute { sub insert { my ($self, $source, $to_insert) = @_; -# redispatch to insert method of storage we reblessed into, if necessary - if (not $self->_driver_determined) { - $self->_determine_driver; - goto $self->can('insert'); - } - my $ident = $source->from; my $bind_attributes = $self->source_bind_attributes($source); @@ -1338,12 +1366,6 @@ sub insert { sub insert_bulk { my ($self, $source, $cols, $data) = @_; -# redispatch to insert_bulk method of storage we reblessed into, if necessary - if (not $self->_driver_determined) { - $self->_determine_driver; - goto $self->can('insert_bulk'); - } - my %colvalues; @colvalues{@$cols} = (0..$#$cols); @@ -1529,32 +1551,25 @@ sub _dbh_execute_inserts_with_no_binds { sub update { my ($self, $source, @args) = @_; -# redispatch to update method of storage we reblessed into, if necessary - if (not $self->_driver_determined) { - $self->_determine_driver; - goto $self->can('update'); - } - - my $bind_attributes = $self->source_bind_attributes($source); + my $bind_attrs = $self->source_bind_attributes($source); - return $self->_execute('update' => [], $source, $bind_attributes, @args); + return $self->_execute('update' => [], $source, $bind_attrs, @args); } sub delete { - my $self = shift @_; - my $source = shift @_; - $self->_determine_driver; + my ($self, $source, @args) = @_; + my $bind_attrs = $self->source_bind_attributes($source); - return $self->_execute('delete' => [], $source, $bind_attrs, @_); + return $self->_execute('delete' => [], $source, $bind_attrs, @args); } # We were sent here because the $rs contains a complex search # which will require a subquery to select the correct rows -# (i.e. joined or limited resultsets) +# (i.e. joined or limited resultsets, or non-introspectable conditions) # -# Genarating a single PK column subquery is trivial and supported +# Generating a single PK column subquery is trivial and supported # by all RDBMS. However if we have a multicolumn PK, things get ugly. # Look at _multipk_update_delete() sub _subq_update_delete { @@ -1563,14 +1578,19 @@ sub _subq_update_delete { my $rsrc = $rs->result_source; - # we already check this, but double check naively just in case. Should be removed soon + # quick check if we got a sane rs on our hands + my @pcols = $rsrc->primary_columns; + my $sel = $rs->_resolved_attrs->{select}; $sel = [ $sel ] unless ref $sel eq 'ARRAY'; - my @pcols = $rsrc->primary_columns; - if (@$sel != @pcols) { + + if ( + join ("\x00", map { join '.', $rs->{attrs}{alias}, $_ } sort @pcols) + ne + join ("\x00", sort @$sel ) + ) { $self->throw_exception ( - 'Subquery update/delete can not be called on resultsets selecting a' - .' number of columns different than the number of primary keys' + '_subq_update_delete can not be called on resultsets selecting columns other than the primary keys' ); } @@ -1772,324 +1792,6 @@ sub _select_args { return ('select', $attrs->{bind}, $ident, $bind_attrs, $select, $where, $order, @limit); } -# -# This is the code producing joined subqueries like: -# SELECT me.*, other.* FROM ( SELECT me.* FROM ... ) JOIN other ON ... -# -sub _adjust_select_args_for_complex_prefetch { - my ($self, $from, $select, $where, $attrs) = @_; - - $self->throw_exception ('Nothing to prefetch... how did we get here?!') - if not @{$attrs->{_prefetch_select}}; - - $self->throw_exception ('Complex prefetches are not supported on resultsets with a custom from attribute') - if (ref $from ne 'ARRAY' || ref $from->[0] ne 'HASH' || ref $from->[1] ne 'ARRAY'); - - - # generate inner/outer attribute lists, remove stuff that doesn't apply - my $outer_attrs = { %$attrs }; - delete $outer_attrs->{$_} for qw/where bind rows offset group_by having/; - - my $inner_attrs = { %$attrs }; - delete $inner_attrs->{$_} for qw/for collapse _prefetch_select _collapse_order_by select as/; - - - # bring over all non-collapse-induced order_by into the inner query (if any) - # the outer one will have to keep them all - delete $inner_attrs->{order_by}; - if (my $ord_cnt = @{$outer_attrs->{order_by}} - @{$outer_attrs->{_collapse_order_by}} ) { - $inner_attrs->{order_by} = [ - @{$outer_attrs->{order_by}}[ 0 .. $ord_cnt - 1] - ]; - } - - - # generate the inner/outer select lists - # for inside we consider only stuff *not* brought in by the prefetch - # on the outside we substitute any function for its alias - my $outer_select = [ @$select ]; - my $inner_select = []; - for my $i (0 .. ( @$outer_select - @{$outer_attrs->{_prefetch_select}} - 1) ) { - my $sel = $outer_select->[$i]; - - if (ref $sel eq 'HASH' ) { - $sel->{-as} ||= $attrs->{as}[$i]; - $outer_select->[$i] = join ('.', $attrs->{alias}, ($sel->{-as} || "inner_column_$i") ); - } - - push @$inner_select, $sel; - } - - # normalize a copy of $from, so it will be easier to work with further - # down (i.e. promote the initial hashref to an AoH) - $from = [ @$from ]; - $from->[0] = [ $from->[0] ]; - my %original_join_info = map { $_->[0]{-alias} => $_->[0] } (@$from); - - - # decide which parts of the join will remain in either part of - # the outer/inner query - - # First we compose a list of which aliases are used in restrictions - # (i.e. conditions/order/grouping/etc). Since we do not have - # introspectable SQLA, we fall back to ugly scanning of raw SQL for - # WHERE, and for pieces of ORDER BY in order to determine which aliases - # need to appear in the resulting sql. - # It may not be very efficient, but it's a reasonable stop-gap - # Also unqualified column names will not be considered, but more often - # than not this is actually ok - # - # In the same loop we enumerate part of the selection aliases, as - # it requires the same sqla hack for the time being - my ($restrict_aliases, $select_aliases, $prefetch_aliases); - { - # produce stuff unquoted, so it can be scanned - my $sql_maker = $self->sql_maker; - local $sql_maker->{quote_char}; - my $sep = $self->_sql_maker_opts->{name_sep} || '.'; - $sep = "\Q$sep\E"; - - my $non_prefetch_select_sql = $sql_maker->_recurse_fields ($inner_select); - my $prefetch_select_sql = $sql_maker->_recurse_fields ($outer_attrs->{_prefetch_select}); - my $where_sql = $sql_maker->where ($where); - my $group_by_sql = $sql_maker->_order_by({ - map { $_ => $inner_attrs->{$_} } qw/group_by having/ - }); - my @non_prefetch_order_by_chunks = (map - { ref $_ ? $_->[0] : $_ } - $sql_maker->_order_by_chunks ($inner_attrs->{order_by}) - ); - - - for my $alias (keys %original_join_info) { - my $seen_re = qr/\b $alias $sep/x; - - for my $piece ($where_sql, $group_by_sql, @non_prefetch_order_by_chunks ) { - if ($piece =~ $seen_re) { - $restrict_aliases->{$alias} = 1; - } - } - - if ($non_prefetch_select_sql =~ $seen_re) { - $select_aliases->{$alias} = 1; - } - - if ($prefetch_select_sql =~ $seen_re) { - $prefetch_aliases->{$alias} = 1; - } - - } - } - - # Add any non-left joins to the restriction list (such joins are indeed restrictions) - for my $j (values %original_join_info) { - my $alias = $j->{-alias} or next; - $restrict_aliases->{$alias} = 1 if ( - (not $j->{-join_type}) - or - ($j->{-join_type} !~ /^left (?: \s+ outer)? $/xi) - ); - } - - # mark all join parents as mentioned - # (e.g. join => { cds => 'tracks' } - tracks will need to bring cds too ) - for my $collection ($restrict_aliases, $select_aliases) { - for my $alias (keys %$collection) { - $collection->{$_} = 1 - for (@{ $original_join_info{$alias}{-join_path} || [] }); - } - } - - # construct the inner $from for the subquery - my %inner_joins = (map { %{$_ || {}} } ($restrict_aliases, $select_aliases) ); - my @inner_from; - for my $j (@$from) { - push @inner_from, $j if $inner_joins{$j->[0]{-alias}}; - } - - # if a multi-type join was needed in the subquery ("multi" is indicated by - # presence in {collapse}) - add a group_by to simulate the collapse in the subq - unless ($inner_attrs->{group_by}) { - for my $alias (keys %inner_joins) { - - # the dot comes from some weirdness in collapse - # remove after the rewrite - if ($attrs->{collapse}{".$alias"}) { - $inner_attrs->{group_by} ||= $inner_select; - last; - } - } - } - - # demote the inner_from head - $inner_from[0] = $inner_from[0][0]; - - # generate the subquery - my $subq = $self->_select_args_to_query ( - \@inner_from, - $inner_select, - $where, - $inner_attrs, - ); - - my $subq_joinspec = { - -alias => $attrs->{alias}, - -source_handle => $inner_from[0]{-source_handle}, - $attrs->{alias} => $subq, - }; - - # Generate the outer from - this is relatively easy (really just replace - # the join slot with the subquery), with a major caveat - we can not - # join anything that is non-selecting (not part of the prefetch), but at - # the same time is a multi-type relationship, as it will explode the result. - # - # There are two possibilities here - # - either the join is non-restricting, in which case we simply throw it away - # - it is part of the restrictions, in which case we need to collapse the outer - # result by tackling yet another group_by to the outside of the query - - # so first generate the outer_from, up to the substitution point - my @outer_from; - while (my $j = shift @$from) { - if ($j->[0]{-alias} eq $attrs->{alias}) { # time to swap - push @outer_from, [ - $subq_joinspec, - @{$j}[1 .. $#$j], - ]; - last; # we'll take care of what's left in $from below - } - else { - push @outer_from, $j; - } - } - - # see what's left - throw away if not selecting/restricting - # also throw in a group_by if restricting to guard against - # cross-join explosions - # - while (my $j = shift @$from) { - my $alias = $j->[0]{-alias}; - - if ($select_aliases->{$alias} || $prefetch_aliases->{$alias}) { - push @outer_from, $j; - } - elsif ($restrict_aliases->{$alias}) { - push @outer_from, $j; - - # FIXME - this should be obviated by SQLA2, as I'll be able to - # have restrict_inner and restrict_outer... or something to that - # effect... I think... - - # FIXME2 - I can't find a clean way to determine if a particular join - # is a multi - instead I am just treating everything as a potential - # explosive join (ribasushi) - # - # if (my $handle = $j->[0]{-source_handle}) { - # my $rsrc = $handle->resolve; - # ... need to bail out of the following if this is not a multi, - # as it will be much easier on the db ... - - $outer_attrs->{group_by} ||= $outer_select; - # } - } - } - - # demote the outer_from head - $outer_from[0] = $outer_from[0][0]; - - # This is totally horrific - the $where ends up in both the inner and outer query - # Unfortunately not much can be done until SQLA2 introspection arrives, and even - # then if where conditions apply to the *right* side of the prefetch, you may have - # to both filter the inner select (e.g. to apply a limit) and then have to re-filter - # the outer select to exclude joins you didin't want in the first place - # - # OTOH it can be seen as a plus: (notes that this query would make a DBA cry ;) - return (\@outer_from, $outer_select, $where, $outer_attrs); -} - -sub _resolve_ident_sources { - my ($self, $ident) = @_; - - my $alias2source = {}; - my $rs_alias; - - # the reason this is so contrived is that $ident may be a {from} - # structure, specifying multiple tables to join - if ( Scalar::Util::blessed($ident) && $ident->isa("DBIx::Class::ResultSource") ) { - # this is compat mode for insert/update/delete which do not deal with aliases - $alias2source->{me} = $ident; - $rs_alias = 'me'; - } - elsif (ref $ident eq 'ARRAY') { - - for (@$ident) { - my $tabinfo; - if (ref $_ eq 'HASH') { - $tabinfo = $_; - $rs_alias = $tabinfo->{-alias}; - } - if (ref $_ eq 'ARRAY' and ref $_->[0] eq 'HASH') { - $tabinfo = $_->[0]; - } - - $alias2source->{$tabinfo->{-alias}} = $tabinfo->{-source_handle}->resolve - if ($tabinfo->{-source_handle}); - } - } - - return ($alias2source, $rs_alias); -} - -# Takes $ident, \@column_names -# -# returns { $column_name => \%column_info, ... } -# also note: this adds -result_source => $rsrc to the column info -# -# usage: -# my $col_sources = $self->_resolve_column_info($ident, @column_names); -sub _resolve_column_info { - my ($self, $ident, $colnames) = @_; - my ($alias2src, $root_alias) = $self->_resolve_ident_sources($ident); - - my $sep = $self->_sql_maker_opts->{name_sep} || '.'; - $sep = "\Q$sep\E"; - - my (%return, %seen_cols); - - # compile a global list of column names, to be able to properly - # disambiguate unqualified column names (if at all possible) - for my $alias (keys %$alias2src) { - my $rsrc = $alias2src->{$alias}; - for my $colname ($rsrc->columns) { - push @{$seen_cols{$colname}}, $alias; - } - } - - COLUMN: - foreach my $col (@$colnames) { - my ($alias, $colname) = $col =~ m/^ (?: ([^$sep]+) $sep)? (.+) $/x; - - unless ($alias) { - # see if the column was seen exactly once (so we know which rsrc it came from) - if ($seen_cols{$colname} and @{$seen_cols{$colname}} == 1) { - $alias = $seen_cols{$colname}[0]; - } - else { - next COLUMN; - } - } - - my $rsrc = $alias2src->{$alias}; - $return{$col} = $rsrc && { - %{$rsrc->column_info($colname)}, - -result_source => $rsrc, - -source_alias => $alias, - }; - } - - return \%return; -} - # Returns a counting SELECT for a simple count # query. Abstracted so that a storage could override # this to { count => 'firstcol' } or whatever makes @@ -2347,14 +2049,7 @@ Returns the database driver name. =cut sub sqlt_type { - my ($self) = @_; - - if (not $self->_driver_determined) { - $self->_determine_driver; - goto $self->can ('sqlt_type'); - } - - $self->_get_dbh->{Driver}->{Name}; + shift->_get_dbh->{Driver}->{Name}; } =head2 bind_attribute_by_data_type @@ -2698,11 +2393,6 @@ See L =cut sub build_datetime_parser { - if (not $_[0]->_driver_determined) { - $_[0]->_determine_driver; - goto $_[0]->can('build_datetime_parser'); - } - my $self = shift; my $type = $self->datetime_parser_type(@_); $self->ensure_class_loaded ($type); diff --git a/lib/DBIx/Class/Storage/DBI/ADO.pm b/lib/DBIx/Class/Storage/DBI/ADO.pm new file mode 100644 index 0000000..8a0fa68 --- /dev/null +++ b/lib/DBIx/Class/Storage/DBI/ADO.pm @@ -0,0 +1,42 @@ +package # hide from PAUSE + DBIx::Class::Storage::DBI::ADO; + +use base 'DBIx::Class::Storage::DBI'; + +sub _rebless { + my $self = shift; + +# check for MSSQL +# XXX This should be using an OpenSchema method of some sort, but I don't know +# how. +# Current version is stolen from Sybase.pm + my $dbtype = eval { + @{$self->_get_dbh + ->selectrow_arrayref(qq{sp_server_info \@attribute_id=1}) + }[2] + }; + + unless ($@) { + $dbtype =~ s/\W/_/gi; + my $subclass = "DBIx::Class::Storage::DBI::ADO::${dbtype}"; + if ($self->load_optional_class($subclass) && !$self->isa($subclass)) { + bless $self, $subclass; + $self->_rebless; + } + } +} + +# set cursor type here, if necessary +#sub _dbh_sth { +# my ($self, $dbh, $sql) = @_; +# +# my $sth = $self->disable_sth_caching +# ? $dbh->prepare($sql, { CursorType => 'adOpenStatic' }) +# : $dbh->prepare_cached($sql, { CursorType => 'adOpenStatic' }, 3); +# +# $self->throw_exception($dbh->errstr) if !$sth; +# +# $sth; +#} + +1; diff --git a/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server.pm b/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server.pm new file mode 100644 index 0000000..4082a93 --- /dev/null +++ b/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server.pm @@ -0,0 +1,45 @@ +package DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server; + +use strict; +use warnings; + +use base qw/ + DBIx::Class::Storage::DBI::ADO + DBIx::Class::Storage::DBI::MSSQL +/; +use mro 'c3'; + +sub _rebless { + my $self = shift; + $self->_identity_method('@@identity'); +} + +1; + +=head1 NAME + +DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server - Support for Microsoft +SQL Server via DBD::ADO + +=head1 SYNOPSIS + +This subclass supports MSSQL server connections via L. + +=head1 DESCRIPTION + +The MSSQL specific functionality is provided by +L. + +C<_identity_method> is set to C<@@identity>, as C doesn't work +with L. See L +for caveats regarding this. + +=head1 AUTHOR + +See L. + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut diff --git a/lib/DBIx/Class/Storage/DBI/MSSQL.pm b/lib/DBIx/Class/Storage/DBI/MSSQL.pm index 3189a3c..2db2af7 100644 --- a/lib/DBIx/Class/Storage/DBI/MSSQL.pm +++ b/lib/DBIx/Class/Storage/DBI/MSSQL.pm @@ -160,7 +160,7 @@ sub _execute { # this should bring back the result of SELECT SCOPE_IDENTITY() we tacked # on in _prep_for_execute above - my ($identity) = $sth->fetchrow_array; + my ($identity) = eval { $sth->fetchrow_array }; # SCOPE_IDENTITY failed, but we can do something else if ( (! $identity) && $self->_identity_method) { diff --git a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm index 88cf72d..b1f3ddf 100644 --- a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm +++ b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm @@ -53,8 +53,16 @@ sub _dbh_get_autoinc_seq { my $sth; + my $source_name; + if ( ref $source->name ne 'SCALAR' ) { + $source_name = $source->name; + } + else { + $source_name = ${$source->name}; + } + # check for fully-qualified name (eg. SCHEMA.TABLENAME) - if ( my ( $schema, $table ) = $source->name =~ /(\w+)\.(\w+)/ ) { + if ( my ( $schema, $table ) = $source_name =~ /(\w+)\.(\w+)/ ) { $sql = q{ SELECT trigger_body FROM ALL_TRIGGERS t WHERE t.owner = ? AND t.table_name = ? @@ -66,7 +74,7 @@ sub _dbh_get_autoinc_seq { } else { $sth = $dbh->prepare($sql); - $sth->execute( uc( $source->name ) ); + $sth->execute( uc( $source_name ) ); } while (my ($insert_trigger) = $sth->fetchrow_array) { return uc($1) if $insert_trigger =~ m!(\w+)\.nextval!i; # col name goes here??? @@ -223,7 +231,7 @@ table with more than one LOB column. =cut -sub source_bind_attributes +sub source_bind_attributes { require DBD::Oracle; my $self = shift; diff --git a/lib/DBIx/Class/Storage/DBI/Sybase.pm b/lib/DBIx/Class/Storage/DBI/Sybase.pm index eeb4f01..8cb5f5f 100644 --- a/lib/DBIx/Class/Storage/DBI/Sybase.pm +++ b/lib/DBIx/Class/Storage/DBI/Sybase.pm @@ -63,12 +63,13 @@ sub _rebless { my $dbtype = eval { @{$self->_get_dbh->selectrow_arrayref(qq{sp_server_info \@attribute_id=1})}[2] } || ''; + $self->throw_exception("Unable to estable connection to determine database type: $@") + if $@; - my $exception = $@; $dbtype =~ s/\W/_/gi; my $subclass = "DBIx::Class::Storage::DBI::Sybase::${dbtype}"; - if (!$exception && $dbtype && $self->load_optional_class($subclass)) { + if ($dbtype && $self->load_optional_class($subclass)) { bless $self, $subclass; $self->_rebless; } else { # real Sybase @@ -189,7 +190,7 @@ sub _populate_dbh { my $self = shift; $self->next::method(@_); - + if ($self->_is_bulk_storage) { # this should be cleared on every reconnect $self->_began_bulk_work(0); @@ -381,7 +382,7 @@ sub insert { # we are already in a transaction, or there are no blobs # and we don't need the PK - just (try to) do it if ($self->{transaction_depth} - || (!$blob_cols && !$dumb_last_insert_id) + || (!$blob_cols && !$dumb_last_insert_id) ) { return $self->_insert ( $next, $source, $to_insert, $blob_cols, $identity_col @@ -511,7 +512,7 @@ EOF # _execute_array uses a txn anyway, but it ends too early in case we need to # select max(col) to get the identity for inserting blobs. - ($self, my $guard) = $self->{transaction_depth} == 0 ? + ($self, my $guard) = $self->{transaction_depth} == 0 ? ($self->_writer_storage, $self->_writer_storage->txn_scope_guard) : ($self, undef); diff --git a/lib/DBIx/Class/Storage/DBI/Sybase/Microsoft_SQL_Server.pm b/lib/DBIx/Class/Storage/DBI/Sybase/Microsoft_SQL_Server.pm index 3d83020..5cd5aa1 100644 --- a/lib/DBIx/Class/Storage/DBI/Sybase/Microsoft_SQL_Server.pm +++ b/lib/DBIx/Class/Storage/DBI/Sybase/Microsoft_SQL_Server.pm @@ -29,6 +29,26 @@ sub _init { $self->set_textsize; } +sub _dbh_begin_work { + my $self = shift; + + $self->_get_dbh->do('BEGIN TRAN'); +} + +sub _dbh_commit { + my $self = shift; + my $dbh = $self->_dbh + or $self->throw_exception('cannot COMMIT on a disconnected handle'); + $dbh->do('COMMIT'); +} + +sub _dbh_rollback { + my $self = shift; + my $dbh = $self->_dbh + or $self->throw_exception('cannot ROLLBACK on a disconnected handle'); + $dbh->do('ROLLBACK'); +} + 1; =head1 NAME diff --git a/lib/DBIx/Class/Storage/DBIHacks.pm b/lib/DBIx/Class/Storage/DBIHacks.pm new file mode 100644 index 0000000..61331fe --- /dev/null +++ b/lib/DBIx/Class/Storage/DBIHacks.pm @@ -0,0 +1,463 @@ +package #hide from PAUSE + DBIx::Class::Storage::DBIHacks; + +# +# This module contains code that should never have seen the light of day, +# does not belong in the Storage, or is otherwise unfit for public +# display. The arrival of SQLA2 should immediately oboslete 90% of this +# + +use strict; +use warnings; + +use base 'DBIx::Class::Storage'; +use mro 'c3'; + +use Carp::Clan qw/^DBIx::Class/; + +# +# This is the code producing joined subqueries like: +# SELECT me.*, other.* FROM ( SELECT me.* FROM ... ) JOIN other ON ... +# +sub _adjust_select_args_for_complex_prefetch { + my ($self, $from, $select, $where, $attrs) = @_; + + $self->throw_exception ('Nothing to prefetch... how did we get here?!') + if not @{$attrs->{_prefetch_select}}; + + $self->throw_exception ('Complex prefetches are not supported on resultsets with a custom from attribute') + if (ref $from ne 'ARRAY' || ref $from->[0] ne 'HASH' || ref $from->[1] ne 'ARRAY'); + + + # generate inner/outer attribute lists, remove stuff that doesn't apply + my $outer_attrs = { %$attrs }; + delete $outer_attrs->{$_} for qw/where bind rows offset group_by having/; + + my $inner_attrs = { %$attrs }; + delete $inner_attrs->{$_} for qw/for collapse _prefetch_select _collapse_order_by select as/; + + + # bring over all non-collapse-induced order_by into the inner query (if any) + # the outer one will have to keep them all + delete $inner_attrs->{order_by}; + if (my $ord_cnt = @{$outer_attrs->{order_by}} - @{$outer_attrs->{_collapse_order_by}} ) { + $inner_attrs->{order_by} = [ + @{$outer_attrs->{order_by}}[ 0 .. $ord_cnt - 1] + ]; + } + + + # generate the inner/outer select lists + # for inside we consider only stuff *not* brought in by the prefetch + # on the outside we substitute any function for its alias + my $outer_select = [ @$select ]; + my $inner_select = []; + for my $i (0 .. ( @$outer_select - @{$outer_attrs->{_prefetch_select}} - 1) ) { + my $sel = $outer_select->[$i]; + + if (ref $sel eq 'HASH' ) { + $sel->{-as} ||= $attrs->{as}[$i]; + $outer_select->[$i] = join ('.', $attrs->{alias}, ($sel->{-as} || "inner_column_$i") ); + } + + push @$inner_select, $sel; + } + + # normalize a copy of $from, so it will be easier to work with further + # down (i.e. promote the initial hashref to an AoH) + $from = [ @$from ]; + $from->[0] = [ $from->[0] ]; + my %original_join_info = map { $_->[0]{-alias} => $_->[0] } (@$from); + + + # decide which parts of the join will remain in either part of + # the outer/inner query + + # First we compose a list of which aliases are used in restrictions + # (i.e. conditions/order/grouping/etc). Since we do not have + # introspectable SQLA, we fall back to ugly scanning of raw SQL for + # WHERE, and for pieces of ORDER BY in order to determine which aliases + # need to appear in the resulting sql. + # It may not be very efficient, but it's a reasonable stop-gap + # Also unqualified column names will not be considered, but more often + # than not this is actually ok + # + # In the same loop we enumerate part of the selection aliases, as + # it requires the same sqla hack for the time being + my ($restrict_aliases, $select_aliases, $prefetch_aliases); + { + # produce stuff unquoted, so it can be scanned + my $sql_maker = $self->sql_maker; + local $sql_maker->{quote_char}; + my $sep = $self->_sql_maker_opts->{name_sep} || '.'; + $sep = "\Q$sep\E"; + + my $non_prefetch_select_sql = $sql_maker->_recurse_fields ($inner_select); + my $prefetch_select_sql = $sql_maker->_recurse_fields ($outer_attrs->{_prefetch_select}); + my $where_sql = $sql_maker->where ($where); + my $group_by_sql = $sql_maker->_order_by({ + map { $_ => $inner_attrs->{$_} } qw/group_by having/ + }); + my @non_prefetch_order_by_chunks = (map + { ref $_ ? $_->[0] : $_ } + $sql_maker->_order_by_chunks ($inner_attrs->{order_by}) + ); + + + for my $alias (keys %original_join_info) { + my $seen_re = qr/\b $alias $sep/x; + + for my $piece ($where_sql, $group_by_sql, @non_prefetch_order_by_chunks ) { + if ($piece =~ $seen_re) { + $restrict_aliases->{$alias} = 1; + } + } + + if ($non_prefetch_select_sql =~ $seen_re) { + $select_aliases->{$alias} = 1; + } + + if ($prefetch_select_sql =~ $seen_re) { + $prefetch_aliases->{$alias} = 1; + } + + } + } + + # Add any non-left joins to the restriction list (such joins are indeed restrictions) + for my $j (values %original_join_info) { + my $alias = $j->{-alias} or next; + $restrict_aliases->{$alias} = 1 if ( + (not $j->{-join_type}) + or + ($j->{-join_type} !~ /^left (?: \s+ outer)? $/xi) + ); + } + + # mark all join parents as mentioned + # (e.g. join => { cds => 'tracks' } - tracks will need to bring cds too ) + for my $collection ($restrict_aliases, $select_aliases) { + for my $alias (keys %$collection) { + $collection->{$_} = 1 + for (@{ $original_join_info{$alias}{-join_path} || [] }); + } + } + + # construct the inner $from for the subquery + my %inner_joins = (map { %{$_ || {}} } ($restrict_aliases, $select_aliases) ); + my @inner_from; + for my $j (@$from) { + push @inner_from, $j if $inner_joins{$j->[0]{-alias}}; + } + + # if a multi-type join was needed in the subquery ("multi" is indicated by + # presence in {collapse}) - add a group_by to simulate the collapse in the subq + unless ($inner_attrs->{group_by}) { + for my $alias (keys %inner_joins) { + + # the dot comes from some weirdness in collapse + # remove after the rewrite + if ($attrs->{collapse}{".$alias"}) { + $inner_attrs->{group_by} ||= $inner_select; + last; + } + } + } + + # demote the inner_from head + $inner_from[0] = $inner_from[0][0]; + + # generate the subquery + my $subq = $self->_select_args_to_query ( + \@inner_from, + $inner_select, + $where, + $inner_attrs, + ); + + my $subq_joinspec = { + -alias => $attrs->{alias}, + -source_handle => $inner_from[0]{-source_handle}, + $attrs->{alias} => $subq, + }; + + # Generate the outer from - this is relatively easy (really just replace + # the join slot with the subquery), with a major caveat - we can not + # join anything that is non-selecting (not part of the prefetch), but at + # the same time is a multi-type relationship, as it will explode the result. + # + # There are two possibilities here + # - either the join is non-restricting, in which case we simply throw it away + # - it is part of the restrictions, in which case we need to collapse the outer + # result by tackling yet another group_by to the outside of the query + + # so first generate the outer_from, up to the substitution point + my @outer_from; + while (my $j = shift @$from) { + if ($j->[0]{-alias} eq $attrs->{alias}) { # time to swap + push @outer_from, [ + $subq_joinspec, + @{$j}[1 .. $#$j], + ]; + last; # we'll take care of what's left in $from below + } + else { + push @outer_from, $j; + } + } + + # see what's left - throw away if not selecting/restricting + # also throw in a group_by if restricting to guard against + # cross-join explosions + # + while (my $j = shift @$from) { + my $alias = $j->[0]{-alias}; + + if ($select_aliases->{$alias} || $prefetch_aliases->{$alias}) { + push @outer_from, $j; + } + elsif ($restrict_aliases->{$alias}) { + push @outer_from, $j; + + # FIXME - this should be obviated by SQLA2, as I'll be able to + # have restrict_inner and restrict_outer... or something to that + # effect... I think... + + # FIXME2 - I can't find a clean way to determine if a particular join + # is a multi - instead I am just treating everything as a potential + # explosive join (ribasushi) + # + # if (my $handle = $j->[0]{-source_handle}) { + # my $rsrc = $handle->resolve; + # ... need to bail out of the following if this is not a multi, + # as it will be much easier on the db ... + + $outer_attrs->{group_by} ||= $outer_select; + # } + } + } + + # demote the outer_from head + $outer_from[0] = $outer_from[0][0]; + + # This is totally horrific - the $where ends up in both the inner and outer query + # Unfortunately not much can be done until SQLA2 introspection arrives, and even + # then if where conditions apply to the *right* side of the prefetch, you may have + # to both filter the inner select (e.g. to apply a limit) and then have to re-filter + # the outer select to exclude joins you didin't want in the first place + # + # OTOH it can be seen as a plus: (notes that this query would make a DBA cry ;) + return (\@outer_from, $outer_select, $where, $outer_attrs); +} + +sub _resolve_ident_sources { + my ($self, $ident) = @_; + + my $alias2source = {}; + my $rs_alias; + + # the reason this is so contrived is that $ident may be a {from} + # structure, specifying multiple tables to join + if ( Scalar::Util::blessed($ident) && $ident->isa("DBIx::Class::ResultSource") ) { + # this is compat mode for insert/update/delete which do not deal with aliases + $alias2source->{me} = $ident; + $rs_alias = 'me'; + } + elsif (ref $ident eq 'ARRAY') { + + for (@$ident) { + my $tabinfo; + if (ref $_ eq 'HASH') { + $tabinfo = $_; + $rs_alias = $tabinfo->{-alias}; + } + if (ref $_ eq 'ARRAY' and ref $_->[0] eq 'HASH') { + $tabinfo = $_->[0]; + } + + $alias2source->{$tabinfo->{-alias}} = $tabinfo->{-source_handle}->resolve + if ($tabinfo->{-source_handle}); + } + } + + return ($alias2source, $rs_alias); +} + +# Takes $ident, \@column_names +# +# returns { $column_name => \%column_info, ... } +# also note: this adds -result_source => $rsrc to the column info +# +# usage: +# my $col_sources = $self->_resolve_column_info($ident, @column_names); +sub _resolve_column_info { + my ($self, $ident, $colnames) = @_; + my ($alias2src, $root_alias) = $self->_resolve_ident_sources($ident); + + my $sep = $self->_sql_maker_opts->{name_sep} || '.'; + $sep = "\Q$sep\E"; + + my (%return, %seen_cols); + + # compile a global list of column names, to be able to properly + # disambiguate unqualified column names (if at all possible) + for my $alias (keys %$alias2src) { + my $rsrc = $alias2src->{$alias}; + for my $colname ($rsrc->columns) { + push @{$seen_cols{$colname}}, $alias; + } + } + + COLUMN: + foreach my $col (@$colnames) { + my ($alias, $colname) = $col =~ m/^ (?: ([^$sep]+) $sep)? (.+) $/x; + + unless ($alias) { + # see if the column was seen exactly once (so we know which rsrc it came from) + if ($seen_cols{$colname} and @{$seen_cols{$colname}} == 1) { + $alias = $seen_cols{$colname}[0]; + } + else { + next COLUMN; + } + } + + my $rsrc = $alias2src->{$alias}; + $return{$col} = $rsrc && { + %{$rsrc->column_info($colname)}, + -result_source => $rsrc, + -source_alias => $alias, + }; + } + + return \%return; +} + +# The DBIC relationship chaining implementation is pretty simple - every +# new related_relationship is pushed onto the {from} stack, and the {select} +# window simply slides further in. This means that when we count somewhere +# in the middle, we got to make sure that everything in the join chain is an +# actual inner join, otherwise the count will come back with unpredictable +# results (a resultset may be generated with _some_ rows regardless of if +# the relation which the $rs currently selects has rows or not). E.g. +# $artist_rs->cds->count - normally generates: +# SELECT COUNT( * ) FROM artist me LEFT JOIN cd cds ON cds.artist = me.artistid +# which actually returns the number of artists * (number of cds || 1) +# +# So what we do here is crawl {from}, determine if the current alias is at +# the top of the stack, and if not - make sure the chain is inner-joined down +# to the root. +# +sub _straight_join_to_node { + my ($self, $from, $alias) = @_; + + # subqueries and other oddness are naturally not supported + return $from if ( + ref $from ne 'ARRAY' + || + @$from <= 1 + || + ref $from->[0] ne 'HASH' + || + ! $from->[0]{-alias} + || + $from->[0]{-alias} eq $alias # this last bit means $alias is the head of $from - nothing to do + ); + + # find the current $alias in the $from structure + my $switch_branch; + JOINSCAN: + for my $j (@{$from}[1 .. $#$from]) { + if ($j->[0]{-alias} eq $alias) { + $switch_branch = $j->[0]{-join_path}; + last JOINSCAN; + } + } + + # something else went quite wrong + return $from unless $switch_branch; + + # So it looks like we will have to switch some stuff around. + # local() is useless here as we will be leaving the scope + # anyway, and deep cloning is just too fucking expensive + # So replace the first hashref in the node arrayref manually + my @new_from = ($from->[0]); + my $sw_idx = { map { $_ => 1 } @$switch_branch }; + + for my $j (@{$from}[1 .. $#$from]) { + my $jalias = $j->[0]{-alias}; + + if ($sw_idx->{$jalias}) { + my %attrs = %{$j->[0]}; + delete $attrs{-join_type}; + push @new_from, [ + \%attrs, + @{$j}[ 1 .. $#$j ], + ]; + } + else { + push @new_from, $j; + } + } + + return \@new_from; +} + +# Most databases do not allow aliasing of tables in UPDATE/DELETE. Thus +# a condition containing 'me' or other table prefixes will not work +# at all. What this code tries to do (badly) is introspect the condition +# and remove all column qualifiers. If it bails out early (returns undef) +# the calling code should try another approach (e.g. a subquery) +sub _strip_cond_qualifiers { + my ($self, $where) = @_; + + my $cond = {}; + + # No-op. No condition, we're updating/deleting everything + return $cond unless $where; + + if (ref $where eq 'ARRAY') { + $cond = [ + map { + my %hash; + foreach my $key (keys %{$_}) { + $key =~ /([^.]+)$/; + $hash{$1} = $_->{$key}; + } + \%hash; + } @$where + ]; + } + elsif (ref $where eq 'HASH') { + if ( (keys %$where) == 1 && ( (keys %{$where})[0] eq '-and' )) { + $cond->{-and} = []; + my @cond = @{$where->{-and}}; + for (my $i = 0; $i < @cond; $i++) { + my $entry = $cond[$i]; + my $hash; + if (ref $entry eq 'HASH') { + $hash = $self->_strip_cond_qualifiers($entry); + } + else { + $entry =~ /([^.]+)$/; + $hash->{$1} = $cond[++$i]; + } + push @{$cond->{-and}}, $hash; + } + } + else { + foreach my $key (keys %$where) { + $key =~ /([^.]+)$/; + $cond->{$1} = $where->{$key}; + } + } + } + else { + return undef; + } + + return $cond; +} + + +1; diff --git a/t/100populate.t b/t/100populate.t index 2e30a17..e179931 100644 --- a/t/100populate.t +++ b/t/100populate.t @@ -296,4 +296,24 @@ for ( ok ($row, "Stringification test row '$_' properly inserted"); } +lives_ok { + $schema->resultset('TwoKeys')->populate([{ + artist => 1, + cd => 5, + fourkeys_to_twokeys => [{ + f_foo => 1, + f_bar => 1, + f_hello => 1, + f_goodbye => 1, + autopilot => 'a', + },{ + f_foo => 2, + f_bar => 2, + f_hello => 2, + f_goodbye => 2, + autopilot => 'b', + }] + }]) +} 'multicol-PK has_many populate works'; + done_testing; diff --git a/t/60core.t b/t/60core.t index b62b82d..8ab6129 100644 --- a/t/60core.t +++ b/t/60core.t @@ -65,7 +65,7 @@ lives_ok (sub { $art->delete }, 'Cascading delete on Ordered has_many works' ); is(@art, 2, 'And then there were two'); -ok(!$art->in_storage, "It knows it's dead"); +is($art->in_storage, 0, "It knows it's dead"); dies_ok ( sub { $art->delete }, "Can't delete twice"); @@ -144,7 +144,7 @@ is($schema->resultset("Artist")->count, 4, 'count ok'); }); is($new_obj->name, 'find_or_new', 'find_or_new: instantiated a new artist'); - ok(! $new_obj->in_storage, 'new artist is not in storage'); + is($new_obj->in_storage, 0, 'new artist is not in storage'); } my $cd = $schema->resultset("CD")->find(1); diff --git a/t/71mysql.t b/t/71mysql.t index 0c099f8..0d49a0e 100644 --- a/t/71mysql.t +++ b/t/71mysql.t @@ -227,4 +227,14 @@ NULLINSEARCH: { => 'Nothing Found!'; } + +## If find() is the first query after connect() +## DBI::Storage::sql_maker() will be called before +## _determine_driver() and so the ::SQLHacks class for MySQL +## will not be used + +my $schema2 = DBICTest::Schema->connect($dsn, $user, $pass); +$schema2->resultset("Artist")->find(4); +isa_ok($schema2->storage->sql_maker, 'DBIx::Class::SQLAHacks::MySQL'); + done_testing; diff --git a/t/73oracle.t b/t/73oracle.t index f565de9..bb5a86e 100644 --- a/t/73oracle.t +++ b/t/73oracle.t @@ -26,7 +26,7 @@ } use strict; -use warnings; +use warnings; use Test::Exception; use Test::More; @@ -40,7 +40,7 @@ plan skip_all => 'Set $ENV{DBICTEST_ORA_DSN}, _USER and _PASS to run this test. ' as well as following sequences: \'pkid1_seq\', \'pkid2_seq\' and \'nonpkid_seq\'' unless ($dsn && $user && $pass); -plan tests => 35; +plan tests => 36; DBICTest::Schema->load_classes('ArtistFQN'); my $schema = DBICTest::Schema->connect($dsn, $user, $pass); @@ -49,6 +49,7 @@ my $dbh = $schema->storage->dbh; eval { $dbh->do("DROP SEQUENCE artist_seq"); + $dbh->do("DROP SEQUENCE cd_seq"); $dbh->do("DROP SEQUENCE pkid1_seq"); $dbh->do("DROP SEQUENCE pkid2_seq"); $dbh->do("DROP SEQUENCE nonpkid_seq"); @@ -58,6 +59,7 @@ eval { $dbh->do("DROP TABLE track"); }; $dbh->do("CREATE SEQUENCE artist_seq START WITH 1 MAXVALUE 999999 MINVALUE 0"); +$dbh->do("CREATE SEQUENCE cd_seq START WITH 1 MAXVALUE 999999 MINVALUE 0"); $dbh->do("CREATE SEQUENCE pkid1_seq START WITH 1 MAXVALUE 999999 MINVALUE 0"); $dbh->do("CREATE SEQUENCE pkid2_seq START WITH 10 MAXVALUE 999999 MINVALUE 0"); $dbh->do("CREATE SEQUENCE nonpkid_seq START WITH 20 MAXVALUE 999999 MINVALUE 0"); @@ -67,6 +69,7 @@ $dbh->do("CREATE TABLE cd (cdid NUMBER(12), artist NUMBER(12), title VARCHAR(255 $dbh->do("CREATE TABLE track (trackid NUMBER(12), cd NUMBER(12), position NUMBER(12), title VARCHAR(255), last_updated_on DATE, last_updated_at DATE, small_dt DATE)"); $dbh->do("ALTER TABLE artist ADD (CONSTRAINT artist_pk PRIMARY KEY (artistid))"); +$dbh->do("ALTER TABLE cd ADD (CONSTRAINT cd_pk PRIMARY KEY (cdid))"); $dbh->do("ALTER TABLE sequence_test ADD (CONSTRAINT sequence_test_constraint PRIMARY KEY (pkid1, pkid2))"); $dbh->do(qq{ CREATE OR REPLACE TRIGGER artist_insert_trg @@ -80,6 +83,18 @@ $dbh->do(qq{ END IF; END; }); +$dbh->do(qq{ + CREATE OR REPLACE TRIGGER cd_insert_trg + BEFORE INSERT ON cd + FOR EACH ROW + BEGIN + IF :new.cdid IS NULL THEN + SELECT cd_seq.nextval + INTO :new.cdid + FROM DUAL; + END IF; + END; +}); { # Swiped from t/bindtype_columns.t to avoid creating my own Resultset. @@ -88,7 +103,7 @@ $dbh->do(qq{ eval { $dbh->do('DROP TABLE bindtype_test') }; $dbh->do(qq[ - CREATE TABLE bindtype_test + CREATE TABLE bindtype_test ( id integer NOT NULL PRIMARY KEY, bytea integer NULL, @@ -108,13 +123,15 @@ $schema->class('Track')->load_components('PK::Auto::Oracle'); my $new = $schema->resultset('Artist')->create({ name => 'foo' }); is($new->artistid, 1, "Oracle Auto-PK worked"); +my $cd = $schema->resultset('CD')->create({ artist => 1, title => 'EP C', year => '2003' }); +is($new->artistid, 1, "Oracle Auto-PK worked - using scalar ref as table name"); + # test again with fully-qualified table name $new = $schema->resultset('ArtistFQN')->create( { name => 'bar' } ); is( $new->artistid, 2, "Oracle Auto-PK worked with fully-qualified tablename" ); # test join with row count ambiguity -my $cd = $schema->resultset('CD')->create({ cdid => 1, artist => 1, title => 'EP C', year => '2003' }); my $track = $schema->resultset('Track')->create({ trackid => 1, cd => 1, position => 1, title => 'Track1' }); my $tjoin = $schema->resultset('Track')->search({ 'me.title' => 'Track1'}, @@ -149,7 +166,7 @@ is($tcount->count, 2, 'multiple column COUNT DISTINCT ok'); $tcount = $schema->resultset('Track')->search( {}, - { + { group_by => [ qw/position title/ ] } ); @@ -186,7 +203,10 @@ for (1..5) { my $st = $schema->resultset('SequenceTest')->create({ name => 'foo', pkid1 => 55 }); is($st->pkid1, 55, "Oracle Auto-PK without trigger: First primary key set manually"); -{ +SKIP: { + skip 'buggy BLOB support in DBD::Oracle 1.23', 8 + if $DBD::Oracle::VERSION == 1.23; + my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) ); $binstr{'large'} = $binstr{'small'} x 1024; @@ -212,6 +232,7 @@ is($st->pkid1, 55, "Oracle Auto-PK without trigger: First primary key set manual END { if($schema && ($dbh = $schema->storage->dbh)) { $dbh->do("DROP SEQUENCE artist_seq"); + $dbh->do("DROP SEQUENCE cd_seq"); $dbh->do("DROP SEQUENCE pkid1_seq"); $dbh->do("DROP SEQUENCE pkid2_seq"); $dbh->do("DROP SEQUENCE nonpkid_seq"); diff --git a/t/747mssql_ado.t b/t/747mssql_ado.t new file mode 100644 index 0000000..7981c78 --- /dev/null +++ b/t/747mssql_ado.t @@ -0,0 +1,70 @@ +use strict; +use warnings; + +use Test::More; +use Test::Exception; +use lib qw(t/lib); +use DBICTest; + +my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSSQL_ADO_${_}" } qw/DSN USER PASS/}; + +plan skip_all => 'Set $ENV{DBICTEST_MSSQL_ADO_DSN}, _USER and _PASS to run this test' + unless ($dsn && $user); + +plan tests => 12; + +my $schema = DBICTest::Schema->connect($dsn, $user, $pass); +$schema->storage->ensure_connected; + +isa_ok( $schema->storage, 'DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server' ); + +$schema->storage->dbh_do (sub { + my ($storage, $dbh) = @_; + eval { $dbh->do("DROP TABLE artist") }; + $dbh->do(<<'SQL'); +CREATE TABLE artist ( + artistid INT IDENTITY NOT NULL, + name VARCHAR(100), + rank INT NOT NULL DEFAULT '13', + charfield CHAR(10) NULL, + primary key(artistid) +) +SQL +}); + +my $new = $schema->resultset('Artist')->create({ name => 'foo' }); +ok($new->artistid > 0, 'Auto-PK worked'); + +# make sure select works +my $found = $schema->resultset('Artist')->search({ name => 'foo' })->first; +is $found->artistid, $new->artistid, 'search works'; + +# test large column list in select +$found = $schema->resultset('Artist')->search({ name => 'foo' }, { + select => ['artistid', 'name', map "'foo' foo_$_", 0..50], + as => ['artistid', 'name', map "foo_$_", 0..50], +})->first; +is $found->artistid, $new->artistid, 'select with big column list'; +is $found->get_column('foo_50'), 'foo', 'last item in big column list'; + +# create a few more rows +for (1..6) { + $schema->resultset('Artist')->create({ name => 'Artist ' . $_ }); +} + +# test multiple active cursors +my $rs1 = $schema->resultset('Artist')->search({}, { order_by => 'artistid' }); +my $rs2 = $schema->resultset('Artist')->search({}, { order_by => 'name' }); + +while ($rs1->next) { + ok eval { $rs2->next }, 'multiple active cursors'; +} + +# clean up our mess +END { + if (my $dbh = eval { $schema->storage->_dbh }) { + eval { $dbh->do("DROP TABLE $_") } + for qw/artist/; + } +} +# vim:sw=2 sts=2 diff --git a/t/74mssql.t b/t/74mssql.t index 172c78d..02e1950 100644 --- a/t/74mssql.t +++ b/t/74mssql.t @@ -18,10 +18,6 @@ my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSSQL_${_}" } qw/DSN USER PASS/}; plan skip_all => 'Set $ENV{DBICTEST_MSSQL_DSN}, _USER and _PASS to run this test' unless ($dsn); -my $TESTS = 15; - -plan tests => $TESTS * 2; - my @storage_types = ( 'DBI::Sybase::Microsoft_SQL_Server', 'DBI::Sybase::Microsoft_SQL_Server::NoBindVars', @@ -29,6 +25,7 @@ my @storage_types = ( my $storage_idx = -1; my $schema; +my $NUMBER_OF_TESTS_IN_BLOCK = 18; for my $storage_type (@storage_types) { $storage_idx++; @@ -44,7 +41,7 @@ for my $storage_type (@storage_types) { if ($storage_idx == 0 && ref($schema->storage) =~ /NoBindVars\z/) { my $tb = Test::More->builder; - $tb->skip('no placeholders') for 1..$TESTS; + $tb->skip('no placeholders') for 1..$NUMBER_OF_TESTS_IN_BLOCK; next; } @@ -145,17 +142,44 @@ SQL $rs->reset; } 'multiple active statements'; - # test multiple active statements in a transaction - TODO: { - local $TODO = 'needs similar FreeTDS fixes to the ones in Sybase.pm'; - lives_ok { - $schema->txn_do(sub { - $rs->create({ amount => 400 }); - }); - } 'simple transaction'; - } + $rs->delete; + + # test simple transaction with commit + lives_ok { + $schema->txn_do(sub { + $rs->create({ amount => 400 }); + }); + } 'simple transaction'; + + cmp_ok $rs->first->amount, '==', 400, 'committed'; + $rs->reset; + + $rs->delete; + + # test rollback + throws_ok { + $schema->txn_do(sub { + $rs->create({ amount => 400 }); + die 'mtfnpy'; + }); + } qr/mtfnpy/, 'simple failed txn'; + + is $rs->first, undef, 'rolled back'; + $rs->reset; } +# test op-induced autoconnect +lives_ok (sub { + + my $schema = DBICTest::Schema->clone; + $schema->connection($dsn, $user, $pass); + + my $artist = $schema->resultset ('Artist')->search ({}, { order_by => 'artistid' })->next; + is ($artist->id, 1, 'Artist retrieved successfully'); +}, 'Query-induced autoconnect works'); + +done_testing; + # clean up our mess END { if (my $dbh = eval { $schema->storage->dbh }) { diff --git a/t/79aliasing.t b/t/79aliasing.t index 94ae02b..4f9b3a3 100644 --- a/t/79aliasing.t +++ b/t/79aliasing.t @@ -52,7 +52,7 @@ plan tests => 11; my $cd_rs = $schema->resultset('CD')->search({ 'artist.name' => 'Caterwauler McCrae' }, { join => 'artist' }); my $cd = $cd_rs->find_or_new({ title => 'Huh?', year => 2006 }); - ok(! $cd->in_storage, 'new CD not in storage yet'); + is($cd->in_storage, 0, 'new CD not in storage yet'); is($cd->title, 'Huh?', 'new CD title is correct'); is($cd->year, 2006, 'new CD year is correct'); } diff --git a/t/80unique.t b/t/80unique.t index 2245511..0e4108b 100644 --- a/t/80unique.t +++ b/t/80unique.t @@ -195,7 +195,7 @@ is($row->baz, 3, 'baz is correct'); { key => 'cd_artist_title' } ); - ok(!$cd1->in_storage, 'CD is not in storage yet after update_or_new'); + is($cd1->in_storage, 0, 'CD is not in storage yet after update_or_new'); $cd1->insert; ok($cd1->in_storage, 'CD got added to strage after update_or_new && insert'); diff --git a/t/inflate/hri.t b/t/inflate/hri.t index 1d32dd6..292c943 100644 --- a/t/inflate/hri.t +++ b/t/inflate/hri.t @@ -1,7 +1,7 @@ use strict; -use warnings; +use warnings; -use Test::More qw(no_plan); +use Test::More; use lib qw(t/lib); use DBICTest; my $schema = DBICTest->init_schema(); @@ -9,7 +9,7 @@ my $schema = DBICTest->init_schema(); # Under some versions of SQLite if the $rs is left hanging around it will lock # So we create a scope here cos I'm lazy { - my $rs = $schema->resultset('CD'); + my $rs = $schema->resultset('CD')->search ({}, { order_by => 'cdid' }); # get the defined columns my @dbic_cols = sort $rs->result_source->columns; @@ -23,8 +23,10 @@ my $schema = DBICTest->init_schema(); my @hashref_cols = sort keys %$datahashref1; is_deeply( \@dbic_cols, \@hashref_cols, 'returned columns' ); -} + my $cd1 = $rs->find ({cdid => 1}); + is_deeply ( $cd1, $datahashref1, 'first/find return the same thing'); +} sub check_cols_of { my ($dbic_obj, $datahashref) = @_; @@ -135,3 +137,5 @@ is_deeply( [{ $artist->get_columns, cds => [] }], 'nested has_many prefetch without entries' ); + +done_testing; diff --git a/t/prefetch/via_search_related.t b/t/prefetch/via_search_related.t index 7725c6e..f686e15 100644 --- a/t/prefetch/via_search_related.t +++ b/t/prefetch/via_search_related.t @@ -37,6 +37,36 @@ lives_ok ( sub { }, 'search_related prefetch with order_by works'); +TODO: { local $TODO = 'Unqualified columns in where clauses can not be fixed without an SQLA rewrite' if SQL::Abstract->VERSION < 2; +lives_ok ( sub { + my $no_prefetch = $schema->resultset('Track')->search_related(cd => + { + 'cd.year' => "2000", + 'tagid' => 1, + }, + { + join => 'tags', + rows => 1, + } + ); + + my $use_prefetch = $no_prefetch->search( + undef, + { + prefetch => 'tags', + } + ); + + is($use_prefetch->count, $no_prefetch->count, 'counts with and without prefetch match'); + is( + scalar ($use_prefetch->all), + scalar ($no_prefetch->all), + "Amount of returned rows is right" + ); + +}, 'search_related prefetch with condition referencing unqualified column of a joined table works'); +} + lives_ok (sub { my $rs = $schema->resultset("Artwork")->search(undef, {distinct => 1}) diff --git a/t/relationship/core.t b/t/relationship/core.t index 6a09c57..90e49a3 100644 --- a/t/relationship/core.t +++ b/t/relationship/core.t @@ -133,7 +133,7 @@ $cd = $artist->find_or_new_related( 'cds', { year => 2007, } ); is( $cd->title, 'Greatest Hits 2: Louder Than Ever', 'find_or_new_related new record ok' ); -ok( ! $cd->in_storage, 'find_or_new_related on a new record: not in_storage' ); +is( $cd->in_storage, 0, 'find_or_new_related on a new record: not in_storage' ); $cd->artist(undef); my $newartist = $cd->find_or_new_related( 'artist', { diff --git a/t/resultset/update_delete.t b/t/resultset/update_delete.t index fc535e6..05d245b 100644 --- a/t/resultset/update_delete.t +++ b/t/resultset/update_delete.t @@ -79,8 +79,12 @@ throws_ok ( ); # grouping on PKs only should pass -$sub_rs->search ({}, { group_by => [ reverse $sub_rs->result_source->primary_columns ] }) # reverse to make sure the comaprison works - ->update ({ pilot_sequence => \ 'pilot_sequence + 1' }); +$sub_rs->search ( + {}, + { + group_by => [ reverse $sub_rs->result_source->primary_columns ], # reverse to make sure the PK-list comaprison works + }, +)->update ({ pilot_sequence => \ 'pilot_sequence + 1' }); is_deeply ( [ $tkfks->search ({ autopilot => [qw/a b x y/]}, { order_by => 'autopilot' }) @@ -90,6 +94,19 @@ is_deeply ( 'Only two rows incremented', ); +# also make sure weird scalarref usage works (RT#51409) +$tkfks->search ( + \ 'pilot_sequence BETWEEN 11 AND 21', +)->update ({ pilot_sequence => \ 'pilot_sequence + 1' }); + +is_deeply ( + [ $tkfks->search ({ autopilot => [qw/a b x y/]}, { order_by => 'autopilot' }) + ->get_column ('pilot_sequence')->all + ], + [qw/12 22 30 40/], + 'Only two rows incremented (where => scalarref works)', +); + $sub_rs->delete; is ($tkfks->count, $tkfk_cnt -= 2, 'Only two rows deleted');