From: Peter Rabbitson Date: Fri, 7 May 2010 21:35:07 +0000 (+0000) Subject: Merge 'trunk' into 'oracle_hierarchical_queries_rt39121' X-Git-Tag: v0.08122~34^2~14 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=de7f4263dd25784787ebd28a4fbd0dfee53b6959;hp=2e4dd2413cf6add731083c60f493cc7374b3fcf8;p=dbsrgits%2FDBIx-Class.git Merge 'trunk' into 'oracle_hierarchical_queries_rt39121' r9318@Thesaurus (orig r9305): rabbit | 2010-05-05 11:49:51 +0200 r9296@Thesaurus (orig r9283): ribasushi | 2010-05-01 11:51:15 +0200 Branch to clean up various limit dialects r9297@Thesaurus (orig r9284): rabbit | 2010-05-01 11:55:04 +0200 Preliminary version r9301@Thesaurus (orig r9288): rabbit | 2010-05-03 18:31:24 +0200 Fix incorrect comparison r9302@Thesaurus (orig r9289): rabbit | 2010-05-03 18:32:36 +0200 Do not add TOP prefixes to queries already containing it r9303@Thesaurus (orig r9290): rabbit | 2010-05-03 18:33:15 +0200 Add an as selector to a prefetch subquery to aid the subselecting-limit analyzer r9304@Thesaurus (orig r9291): rabbit | 2010-05-03 18:34:49 +0200 Rewrite mssql test to verify both types of limit dialects with and without quoting, rewrite the RNO, Top and RowNum dialects to rely on a factored out column re-aliaser r9305@Thesaurus (orig r9292): rabbit | 2010-05-03 21:06:01 +0200 Fix Top tests, make extra col selector order consistent r9307@Thesaurus (orig r9294): ribasushi | 2010-05-04 00:50:35 +0200 Fix test warning r9308@Thesaurus (orig r9295): ribasushi | 2010-05-04 01:04:32 +0200 Some databases (db2) do not like leading __s - use a different weird identifier for extra selector names r9313@Thesaurus (orig r9300): rabbit | 2010-05-05 11:08:33 +0200 Rename test r9314@Thesaurus (orig r9301): rabbit | 2010-05-05 11:11:32 +0200 If there was no offset, there is no sense in reordering r9315@Thesaurus (orig r9302): rabbit | 2010-05-05 11:12:19 +0200 Split and fix oracle tests r9317@Thesaurus (orig r9304): rabbit | 2010-05-05 11:49:33 +0200 Changes r9321@Thesaurus (orig r9308): rabbit | 2010-05-05 13:01:35 +0200 Changes r9322@Thesaurus (orig r9309): rabbit | 2010-05-05 13:02:39 +0200 Fix obsucre bug with as_subselect_rs (gah wrong commit msg) r9323@Thesaurus (orig r9310): rabbit | 2010-05-05 14:56:38 +0200 Forgotten pieces r9329@Thesaurus (orig r9316): rabbit | 2010-05-07 10:15:52 +0200 Failure to determine dbms version is *not* a fatal error - trap exceptions r9330@Thesaurus (orig r9317): caelum | 2010-05-07 11:57:24 +0200 detect row_number() over support in MSSQL if version detection fails r9331@Thesaurus (orig r9318): caelum | 2010-05-07 14:56:57 +0200 minor change r9332@Thesaurus (orig r9319): nigel | 2010-05-07 15:03:00 +0200 empty update OK even if row is not in database r9333@Thesaurus (orig r9320): nigel | 2010-05-07 15:28:06 +0200 Added reference to cascade_* in relationship attributes r9334@Thesaurus (orig r9321): nigel | 2010-05-07 15:39:37 +0200 empty update OK even if row is not in database (fixed) r9335@Thesaurus (orig r9322): nigel | 2010-05-07 15:48:19 +0200 empty update OK even if row is not in database (fixed2) r9336@Thesaurus (orig r9323): nigel | 2010-05-07 15:54:36 +0200 Clarification to cascade_update attribute documentation r9337@Thesaurus (orig r9324): nigel | 2010-05-07 16:08:17 +0200 Clarification cascade_* attribute defaults documentation --- diff --git a/Changes b/Changes index 5a6f7ce..f1e998a 100644 --- a/Changes +++ b/Changes @@ -3,7 +3,7 @@ Revision history for DBIx::Class - Add a warning to load_namespaces if a class in ResultSet/ is not a subclass of DBIx::Class::ResultSet - ::Storage::DBI now correctly preserves a parent $dbh from - terminating children, even during interpreter global + terminating children, even during interpreter-global out-of-order destruction - InflateColumn::DateTime support for MSSQL via DBD::Sybase - Millisecond precision support for MSSQL datetimes for @@ -12,7 +12,17 @@ Revision history for DBIx::Class - current_source_alias method on ResultSet objects to determine the alias to use in programatically assembled search()es (originally added in 0.08100 but unmentioned) + - Rewrite/unification of all subselecting limit emulations + (RNO, Top, RowNum) to be much more robust wrt complex joined + resultsets + - MSSQL limits now don't require nearly as many applications of + the unsafe_subselect_ok attribute, due to optimized queries + - Fix as_subselect_rs to not inject resultset class-wide where + conditions outside of the resulting subquery - Depend on optimized SQL::Abstract (faster SQL generation) + - update on row not in database now OK if no changes - + fixes problems with cascaded unnecessary updates + 0.08121 2010-04-11 18:43:00 (UTC) - Support for Firebird RDBMS with DBD::InterBase and ODBC diff --git a/lib/DBIx/Class/Relationship/Base.pm b/lib/DBIx/Class/Relationship/Base.pm index 62133a8..35ae568 100644 --- a/lib/DBIx/Class/Relationship/Base.pm +++ b/lib/DBIx/Class/Relationship/Base.pm @@ -122,6 +122,40 @@ 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. +=item cascade_copy + +If C is true on a C relationship for an +object, then when you copy the object all the related objects will +be copied too. To turn this behaviour off, pass C<< cascade_copy => 0 >> +in the C<$attr> hashref. + +The behaviour defaults to C<< cascade_copy => 1 >> for C +relationships. + +=item cascade_delete + +By default, DBIx::Class cascades deletes across C, +C and C relationships. You can disable this +behaviour on a per-relationship basis by supplying +C<< cascade_delete => 0 >> in the relationship attributes. + +The cascaded operations are performed after the requested delete, +so if your database has a constraint on the relationship, it will +have deleted/updated the related records or raised an exception +before DBIx::Class gets to perform the cascaded operation. + +=item cascade_update + +By default, DBIx::Class cascades updates across C and +C relationships. You can disable this behaviour on a +per-relationship basis by supplying C<< cascade_update => 0 >> in +the relationship attributes. + +This is not a RDMS style cascade update - it purely means that when +an object has update called on it, all the related objects also +have update called. It will not change foreign keys automatically - +you must arrange to do this yourself. + =item on_delete / on_update If you are using L to create SQL for you, you can use these diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 3805812..7ac07ca 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -1289,11 +1289,6 @@ sub _count_subq_rs { $sub_attrs->{select} = @pcols ? \@pcols : [ 1 ]; } - - # this is so that the query can be simplified e.g. - # * ordering can be thrown away in things like Top limit - $sub_attrs->{-for_count_only} = 1; - return $rsrc->resultset_class ->new ($rsrc, $sub_attrs) ->as_subselect_rs @@ -2684,15 +2679,22 @@ sub as_subselect_rs { my $attrs = $self->_resolved_attrs; - return $self->result_source->resultset->search( undef, { + my $fresh_rs = (ref $self)->new ( + $self->result_source + ); + + # these pieces will be locked in the subquery + delete $fresh_rs->{cond}; + delete @{$fresh_rs->{attrs}}{qw/where bind/}; + + return $fresh_rs->search( {}, { from => [{ $attrs->{alias} => $self->as_query, -alias => $attrs->{alias}, -source_handle => $self->result_source->handle, }], - map { $_ => $attrs->{$_} } qw/select as alias/ - - }); + alias => $attrs->{alias}, + }); } # This code is called by search_related, and makes sure there diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm index 06f850b..31c7028 100644 --- a/lib/DBIx/Class/Row.pm +++ b/lib/DBIx/Class/Row.pm @@ -518,16 +518,18 @@ this method. sub update { my ($self, $upd) = @_; - $self->throw_exception( "Not in database" ) unless $self->in_storage; my $ident_cond = $self->{_orig_ident} || $self->ident_condition; - $self->throw_exception('Unable to update a row with incomplete or no identity') - if ! keys %$ident_cond; - $self->set_inflated_columns($upd) if $upd; my %to_update = $self->get_dirty_columns; return $self unless keys %to_update; + + $self->throw_exception( "Not in database" ) unless $self->in_storage; + + $self->throw_exception('Unable to update a row with incomplete or no identity') + if ! keys %$ident_cond; + my $rows = $self->result_source->storage->update( $self->result_source, \%to_update, $ident_cond ); diff --git a/lib/DBIx/Class/SQLAHacks.pm b/lib/DBIx/Class/SQLAHacks.pm index 0669e36..40bc7a3 100644 --- a/lib/DBIx/Class/SQLAHacks.pm +++ b/lib/DBIx/Class/SQLAHacks.pm @@ -46,32 +46,168 @@ sub new { $self; } +# !!! THIS IS ALSO HORRIFIC !!! /me ashamed +# +# generate inner/outer select lists for various limit dialects +# which result in one or more subqueries (e.g. RNO, Top, RowNum) +# Any non-root-table columns need to have their table qualifier +# turned into a column alias (otherwise names in subqueries clash +# and/or lose their source table) +# +# returns inner/outer strings of SQL QUOTED selectors with aliases +# (to be used in whatever select statement), and an alias index hashref +# of QUOTED SEL => QUOTED ALIAS pairs (to maybe be used for string-subst +# higher up) +# +# If the $scan_order option is supplied, it signals that the limit dialect +# needs to order the outer side of the query, which in turn means that the +# inner select needs to bring out columns used in implicit (non-selected) +# orders, and the order condition itself needs to be realiased to the proper +# names in the outer query. +# +# In this case ($scan_order os true) we also return a hashref (order doesn't +# matter) of QUOTED EXTRA-SEL => QUOTED ALIAS pairs, which is a list of extra +# selectors that do *not* exist in the original select list + +sub _subqueried_limit_attrs { + my ($self, $rs_attrs, $scan_order) = @_; + + croak 'Limit dialect implementation usable only in the context of DBIC (missing $rs_attrs)' + unless ref ($rs_attrs) eq 'HASH'; + + my ($re_sep, $re_alias) = map { quotemeta $_ } ( + $self->name_sep || '.', + $rs_attrs->{alias}, + ); + + # correlate select and as, build selection index + my (@sel, $in_sel_index); + for my $i (0 .. $#{$rs_attrs->{select}}) { + + my $s = $rs_attrs->{select}[$i]; + my $sql_sel = $self->_recurse_fields ($s); + my $sql_alias = (ref $s) eq 'HASH' ? $s->{-as} : undef; + + + push @sel, { + sql => $sql_sel, + unquoted_sql => do { local $self->{quote_char}; $self->_recurse_fields ($s) }, + as => + $sql_alias + || + $rs_attrs->{as}[$i] + || + croak "Select argument $i ($s) without corresponding 'as'" + , + }; + + $in_sel_index->{$sql_sel}++; + $in_sel_index->{$self->_quote ($sql_alias)}++ if $sql_alias; + +# this *may* turn out to be necessary, not sure yet +# my ($sql_unqualified_sel) = $sql_sel =~ / $re_sep (.+) $/x +# if ! ref $s; +# $in_sel_index->{$sql_unqualified_sel}++; + } + + + # re-alias and remove any name separators from aliases, + # unless we are dealing with the current source alias + # (which will transcend the subqueries as it is necessary + # for possible further chaining) + my (@in_sel, @out_sel, %renamed); + for my $node (@sel) { + if (List::Util::first { $_ =~ / (?{as}, $node->{unquoted_sql}) ) { + $node->{as} =~ s/ $re_sep /__/xg; + my $quoted_as = $self->_quote($node->{as}); + push @in_sel, sprintf '%s AS %s', $node->{sql}, $quoted_as; + push @out_sel, $quoted_as; + $renamed{$node->{sql}} = $quoted_as; + } + else { + push @in_sel, $node->{sql}; + push @out_sel, $self->_quote ($node->{as}); + } + } + + my %extra_order_sel; + if ($scan_order) { + for my $chunk ($self->_order_by_chunks ($rs_attrs->{order_by})) { + # order with bind + $chunk = $chunk->[0] if (ref $chunk) eq 'ARRAY'; + $chunk =~ s/\s+ (?: ASC|DESC ) \s* $//ix; + + next if $in_sel_index->{$chunk}; -# ANSI standard Limit/Offset implementation. DB2 and MSSQL use this + $extra_order_sel{$chunk} ||= $self->_quote ( + 'ORDER__BY__' . scalar keys %extra_order_sel + ); + } + } + return ( + (map { join (', ', @$_ ) } ( + \@in_sel, + \@out_sel) + ), + \%renamed, + keys %extra_order_sel ? \%extra_order_sel : (), + ); +} + +# ANSI standard Limit/Offset implementation. DB2 and MSSQL >= 2005 use this sub _RowNumberOver { my ($self, $sql, $rs_attrs, $rows, $offset ) = @_; - # get the select to make the final amount of columns equal the original one - my ($select) = $sql =~ /^ \s* SELECT \s+ (.+?) \s+ FROM/ix + # mangle the input sql as we will be replacing the selector + $sql =~ s/^ \s* SELECT \s+ .+? \s+ (?= \b FROM \b )//ix or croak "Unrecognizable SELECT: $sql"; - # make up an order if none exists - my $order_by = $self->_order_by( - (delete $rs_attrs->{order_by}) || $self->_rno_default_order + # get selectors, and scan the order_by (if any) + my ($in_sel, $out_sel, $alias_map, $extra_order_sel) = $self->_subqueried_limit_attrs ( + $rs_attrs, 'scan_order_by', ); - # whatever is left of the order_by + # make up an order if none exists + my $requested_order = (delete $rs_attrs->{order_by}) || $self->_rno_default_order; + my $rno_ord = $self->_order_by ($requested_order); + + # this is the order supplement magic + my $mid_sel = $out_sel; + if ($extra_order_sel) { + for my $extra_col (sort + { $extra_order_sel->{$a} cmp $extra_order_sel->{$b} } + keys %$extra_order_sel + ) { + $in_sel .= sprintf (', %s AS %s', + $extra_col, + $extra_order_sel->{$extra_col}, + ); + + $mid_sel .= ', ' . $extra_order_sel->{$extra_col}; + } + } + + # and this is order re-alias magic + for ($extra_order_sel, $alias_map) { + for my $col (keys %$_) { + my $re_col = quotemeta ($col); + $rno_ord =~ s/$re_col/$_->{$col}/; + } + } + + # whatever is left of the order_by (only where is processed at this point) my $group_having = $self->_parse_rs_attrs($rs_attrs); my $qalias = $self->_quote ($rs_attrs->{alias}); + my $idx_name = $self->_quote ('rno__row__index'); $sql = sprintf (<{select}}) { - croak (sprintf ( - 'SQL SELECT did not parse cleanly - retrieved %d comma separated elements, while ' - . 'the resultset select attribure contains %d elements: %s', - scalar @sql_select, - scalar @{$rs_attrs->{select}}, - $sql_select, - )); - } - my $name_sep = $self->name_sep || '.'; - my $esc_name_sep = "\Q$name_sep\E"; - my $col_re = qr/ ^ (?: (.+) $esc_name_sep )? ([^$esc_name_sep]+) $ /x; + my ($insel, $outsel) = $self->_subqueried_limit_attrs ($rs_attrs); - my $rs_alias = $rs_attrs->{alias}; - my $quoted_rs_alias = $self->_quote ($rs_alias); - - # construct the new select lists, rename(alias) some columns if necessary - my (@outer_select, @inner_select, %seen_names, %col_aliases, %outer_col_aliases); - - for (@{$rs_attrs->{select}}) { - next if ref $_; - my ($table, $orig_colname) = ( $_ =~ $col_re ); - next unless $table; - $seen_names{$orig_colname}++; - } - - for my $i (0 .. $#sql_select) { + my $qalias = $self->_quote ($rs_attrs->{alias}); + my $idx_name = $self->_quote ('rownum__index'); + my $order_group_having = $self->_parse_rs_attrs($rs_attrs); - my $colsel_arg = $rs_attrs->{select}[$i]; - my $colsel_sql = $sql_select[$i]; + $sql = sprintf (<_quote ('column_' . (@inner_select + 1) ); - } - # column name seen more than once - alias it - elsif ($orig_colname && - ($seen_names{$orig_colname} && $seen_names{$orig_colname} > 1) ) { - $quoted_alias = $self->_quote ("${table}__${orig_colname}"); - } +EOS - # we did rename - make a record and adjust - if ($quoted_alias) { - # alias inner - push @inner_select, "$colsel_sql AS $quoted_alias"; - - # push alias to outer - push @outer_select, $quoted_alias; - - # Any aliasing accumulated here will be considered - # both for inner and outer adjustments of ORDER BY - $self->__record_alias ( - \%col_aliases, - $quoted_alias, - $colsel_arg, - $table ? $orig_colname : undef, - ); - } + $sql =~ s/\s*\n\s*/ /g; # easier to read in the debugger + return $sql; +} - # otherwise just leave things intact inside, and use the abbreviated one outside - # (as we do not have table names anymore) - else { - push @inner_select, $colsel_sql; - - my $outer_quoted = $self->_quote ($orig_colname); # it was not a duplicate so should just work - push @outer_select, $outer_quoted; - $self->__record_alias ( - \%outer_col_aliases, - $outer_quoted, - $colsel_arg, - $table ? $orig_colname : undef, - ); - } - } +# Crappy Top based Limit/Offset support. Legacy for MSSQL < 2005 +sub _Top { + my ( $self, $sql, $rs_attrs, $rows, $offset ) = @_; - my $outer_select = join (', ', @outer_select ); - my $inner_select = join (', ', @inner_select ); + # mangle the input sql as we will be replacing the selector + $sql =~ s/^ \s* SELECT \s+ .+? \s+ (?= \b FROM \b )//ix + or croak "Unrecognizable SELECT: $sql"; - %outer_col_aliases = (%outer_col_aliases, %col_aliases); + # get selectors + my ($in_sel, $out_sel, $alias_map, $extra_order_sel) + = $self->_subqueried_limit_attrs ($rs_attrs, 'outer_order_by'); - # deal with order - croak '$order/attr container supplied to SQLAHacks limit emulators must be a hash' - if (ref $rs_attrs ne 'HASH'); + my $requested_order = delete $rs_attrs->{order_by}; - my $req_order = $rs_attrs->{order_by}; + my $order_by_requested = $self->_order_by ($requested_order); - # examine normalized version, collapses nesting - my $limit_order = scalar $self->_order_by_chunks ($req_order) - ? $req_order + # make up an order unless supplied + my $inner_order = ($order_by_requested + ? $requested_order : [ map - { join ('', $rs_alias, $name_sep, $_ ) } - ( $rs_attrs->{_rsroot_source_handle}->resolve->primary_columns ) + { join ('', $rs_attrs->{alias}, $self->{name_sep}||'.', $_ ) } + ( $rs_attrs->{_rsroot_source_handle}->resolve->_pri_cols ) ] - ; - - my ( $order_by_inner, $order_by_outer ) = $self->_order_directions($limit_order); - my $order_by_requested = $self->_order_by ($req_order); - - # generate the rest - delete $rs_attrs->{order_by}; - my $grpby_having = $self->_parse_rs_attrs ($rs_attrs); - - # short circuit for counts - the ordering complexity is needless - if ($rs_attrs->{-for_count_only}) { - return "SELECT TOP $rows $inner_select $sql $grpby_having $order_by_outer"; - } - - # we can't really adjust the order_by columns, as introspection is lacking - # resort to simple substitution - for my $col (keys %outer_col_aliases) { - for ($order_by_requested, $order_by_outer) { - $_ =~ s/\s+$col\s+/ $outer_col_aliases{$col} /g; - } - } - for my $col (keys %col_aliases) { - $order_by_inner =~ s/\s+$col\s+/ $col_aliases{$col} /g; - } + ); + my ($order_by_inner, $order_by_reversed); - my $inner_lim = $rows + $offset; + # localise as we already have all the bind values we need + { + local $self->{order_bind}; + $order_by_inner = $self->_order_by ($inner_order); - $sql = "SELECT TOP $inner_lim $inner_select $sql $grpby_having $order_by_inner"; + my @out_chunks; + for my $ch ($self->_order_by_chunks ($inner_order)) { + $ch = $ch->[0] if ref $ch eq 'ARRAY'; - if ($offset) { - $sql = <<"SQL"; + $ch =~ s/\s+ ( ASC|DESC ) \s* $//ix; + my $dir = uc ($1||'ASC'); - SELECT TOP $rows $outer_select FROM - ( - $sql - ) $quoted_rs_alias - $order_by_outer -SQL + push @out_chunks, \join (' ', $ch, $dir eq 'ASC' ? 'DESC' : 'ASC' ); + } + $order_by_reversed = $self->_order_by (\@out_chunks); } - if ($order_by_requested) { - $sql = <<"SQL"; + # this is the order supplement magic + my $mid_sel = $out_sel; + if ($extra_order_sel) { + for my $extra_col (sort + { $extra_order_sel->{$a} cmp $extra_order_sel->{$b} } + keys %$extra_order_sel + ) { + $in_sel .= sprintf (', %s AS %s', + $extra_col, + $extra_order_sel->{$extra_col}, + ); - SELECT $outer_select FROM - ( $sql ) $quoted_rs_alias - $order_by_requested -SQL + $mid_sel .= ', ' . $extra_order_sel->{$extra_col}; + } + } + # and this is order re-alias magic + for my $map ($extra_order_sel, $alias_map) { + for my $col (keys %$map) { + my $re_col = quotemeta ($col); + $_ =~ s/$re_col/$map->{$col}/ + for ($order_by_reversed, $order_by_requested); + } } - $sql =~ s/\s*\n\s*/ /g; # parsing out multiline statements is harder than a single line - return $sql; -} + # generate the rest of the sql + my $grpby_having = $self->_parse_rs_attrs ($rs_attrs); -# action at a distance to shorten Top code above -sub __record_alias { - my ($self, $register, $alias, $fqcol, $col) = @_; + my $quoted_rs_alias = $self->_quote ($rs_attrs->{alias}); - # record qualified name - $register->{$fqcol} = $alias; - $register->{$self->_quote($fqcol)} = $alias; + $sql = sprintf ('SELECT TOP %d %s %s %s %s', + $rows + ($offset||0), + $in_sel, + $sql, + $grpby_having, + $order_by_inner, + ); - return unless $col; + $sql = sprintf ('SELECT TOP %d %s FROM ( %s ) %s %s', + $rows, + $mid_sel, + $sql, + $quoted_rs_alias, + $order_by_reversed, + ) if $offset; - # record unqualified name, undef (no adjustment) if a duplicate is found - if (exists $register->{$col}) { - $register->{$col} = undef; - } - else { - $register->{$col} = $alias; - } + $sql = sprintf ('SELECT TOP %d %s FROM ( %s ) %s %s', + $rows, + $out_sel, + $sql, + $quoted_rs_alias, + $order_by_requested, + ) if ( ($offset && $order_by_requested) || ($mid_sel ne $out_sel) ); - $register->{$self->_quote($col)} = $register->{$col}; + return $sql; } - # While we're at it, this should make LIMIT queries more efficient, # without digging into things too deeply sub _find_syntax { @@ -326,8 +405,6 @@ sub select { $table = $self->_quote($table); } - local $self->{rownum_hack_count} = 1 - if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum'); @rest = (-1) unless defined $rest[0]; croak "LIMIT 0 Does Not Compute" if $rest[0] == 0; # and anyway, SQL::Abstract::Limit will cause a barf if we don't first @@ -388,26 +465,25 @@ sub _emulate_limit { } sub _recurse_fields { - my ($self, $fields, $params) = @_; + my ($self, $fields) = @_; my $ref = ref $fields; return $self->_quote($fields) unless $ref; return $$fields if $ref eq 'SCALAR'; if ($ref eq 'ARRAY') { - return join(', ', map { - $self->_recurse_fields($_) - .(exists $self->{rownum_hack_count} && !($params && $params->{no_rownum_hack}) - ? ' AS col'.$self->{rownum_hack_count}++ - : '') - } @$fields); + return join(', ', map { $self->_recurse_fields($_) } @$fields); } elsif ($ref eq 'HASH') { - my %hash = %$fields; + my %hash = %$fields; # shallow copy my $as = delete $hash{-as}; # if supplied - my ($func, $args) = each %hash; - delete $hash{$func}; + my ($func, $args, @toomany) = %hash; + + # there should be only one pair + if (@toomany) { + croak "Malformed select argument - too many keys in hash: " . join (',', keys %$fields ); + } if (lc ($func) eq 'distinct' && ref $args eq 'ARRAY' && @$args > 1) { croak ( @@ -425,11 +501,6 @@ sub _recurse_fields { : '' ); - # there should be nothing left - if (keys %hash) { - croak "Malformed select argument - too many keys in hash: " . join (',', keys %$fields ); - } - return $select; } # Is the second check absolutely necessary? @@ -459,7 +530,7 @@ sub _parse_rs_attrs { my $sql = ''; - if (my $g = $self->_recurse_fields($arg->{group_by}, { no_rownum_hack => 1 }) ) { + if (my $g = $self->_recurse_fields($arg->{group_by}) ) { $sql .= $self->_sqlcase(' group by ') . $g; } diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 4616b7b..4214463 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -1012,7 +1012,10 @@ sub _server_info { my %info; - my $server_version = $self->_get_server_version; + my $server_version = do { + local $@; # might be happenin in some sort of destructor + eval { $self->_get_server_version }; + }; if (defined $server_version) { $info{dbms_version} = $server_version; @@ -1044,7 +1047,7 @@ sub _server_info { } sub _get_server_version { - eval { shift->_get_dbh->get_info(18) }; + shift->_get_dbh->get_info(18); } sub _determine_driver { @@ -1931,17 +1934,6 @@ sub _select_args { #limited has_many ( $attrs->{rows} && keys %{$attrs->{collapse}} ) || - # limited prefetch with RNO subqueries (otherwise a risk of column name clashes) - ( - $attrs->{rows} - && - $sql_maker->limit_dialect eq 'RowNumberOver' - && - $attrs->{_prefetch_select} - && - @{$attrs->{_prefetch_select}} - ) - || # grouped prefetch (to satisfy group_by == select) ( $attrs->{group_by} && @@ -1955,39 +1947,6 @@ sub _select_args { ($ident, $select, $where, $attrs) = $self->_adjust_select_args_for_complex_prefetch ($ident, $select, $where, $attrs); } - - elsif ( - # the RNO limit dialect mangles the SQL such that the join gets lost - # wrap a subquery here - ($attrs->{rows} || $attrs->{offset}) - && - $sql_maker->limit_dialect eq 'RowNumberOver' - && - (ref $ident eq 'ARRAY' && @$ident > 1) # indicates a join - && - scalar $self->_parse_order_by ($attrs->{order_by}) - ) { - - push @limit, delete @{$attrs}{qw/rows offset/}; - - my $subq = $self->_select_args_to_query ( - $ident, - $select, - $where, - $attrs, - ); - - $ident = { - -alias => $attrs->{alias}, - -source_handle => $ident->[0]{-source_handle}, - $attrs->{alias} => $subq, - }; - - # all part of the subquery now - delete @{$attrs}{qw/order_by group_by having/}; - $where = undef; - } - elsif (! $attrs->{software_limit} ) { push @limit, $attrs->{rows}, $attrs->{offset}; } diff --git a/lib/DBIx/Class/Storage/DBI/MSSQL.pm b/lib/DBIx/Class/Storage/DBI/MSSQL.pm index ef09d49..515ff9b 100644 --- a/lib/DBIx/Class/Storage/DBI/MSSQL.pm +++ b/lib/DBIx/Class/Storage/DBI/MSSQL.pm @@ -158,7 +158,11 @@ sub _select_args_to_query { # see if this is an ordered subquery my $attrs = $_[3]; - if ( scalar $self->_parse_order_by ($attrs->{order_by}) ) { + if ( + $sql !~ /^ \s* SELECT \s+ TOP \s+ \d+ \s+ /xi + && + scalar $self->_parse_order_by ($attrs->{order_by}) + ) { $self->throw_exception( 'An ordered subselect encountered - this is not safe! Please see "Ordered Subselects" in DBIx::Class::Storage::DBI::MSSQL ') unless $attrs->{unsafe_subselect_ok}; @@ -201,11 +205,23 @@ sub sql_maker { unless ($self->_sql_maker) { unless ($self->{_sql_maker_opts}{limit_dialect}) { + my $have_rno = 0; - my $version = $self->_server_info->{normalized_dbms_version} || 0; + if (exists $self->_server_info->{normalized_dbms_version}) { + $have_rno = 1 if $self->_server_info->{normalized_dbms_version} >= 9; + } + else { + # User is connecting via DBD::Sybase and has no permission to run + # stored procedures like xp_msver, or version detection failed for some + # other reason. + # So, we use a query to check if RNO is implemented. + $have_rno = 1 if (eval { local $@; ($self->_get_dbh + ->selectrow_array('SELECT row_number() OVER (ORDER BY rand())') + )[0] }); + } $self->{_sql_maker_opts} = { - limit_dialect => ($version >= 9 ? 'RowNumberOver' : 'Top'), + limit_dialect => ($have_rno ? 'RowNumberOver' : 'Top'), %{$self->{_sql_maker_opts}||{}} }; } diff --git a/lib/DBIx/Class/Storage/DBIHacks.pm b/lib/DBIx/Class/Storage/DBIHacks.pm index 32e0ea3..f16c935 100644 --- a/lib/DBIx/Class/Storage/DBIHacks.pm +++ b/lib/DBIx/Class/Storage/DBIHacks.pm @@ -94,6 +94,8 @@ sub _adjust_select_args_for_complex_prefetch { } push @$inner_select, $sel; + + push @{$inner_attrs->{as}}, $attrs->{as}[$i]; } # construct the inner $from for the subquery diff --git a/t/60core.t b/t/60core.t index 69d99ed..41adcb2 100644 --- a/t/60core.t +++ b/t/60core.t @@ -45,6 +45,8 @@ my %fake_dirty = $art->get_dirty_columns(); is(scalar(keys(%fake_dirty)), 1, '1 fake dirty column'); ok(grep($_ eq 'name', keys(%fake_dirty)), 'name is fake dirty'); +ok($art->update, 'Update run'); + my $record_jp = $schema->resultset("Artist")->search(undef, { join => 'cds' })->search(undef, { prefetch => 'cds' })->next; ok($record_jp, "prefetch on same rel okay"); @@ -67,6 +69,8 @@ is(@art, 2, 'And then there were two'); is($art->in_storage, 0, "It knows it's dead"); +lives_ok { $art->update } 'No changes so update should be OK'; + dies_ok ( sub { $art->delete }, "Can't delete twice"); is($art->name, 'We Are In Rehab', 'But the object is still live'); diff --git a/t/746mssql.t b/t/746mssql.t index ca92a41..1438cee 100644 --- a/t/746mssql.t +++ b/t/746mssql.t @@ -59,8 +59,6 @@ my @opts = ( { on_connect_call => 'use_dynamic_cursors' }, {}, ); -my $new; - # test Auto-PK with different options for my $opts (@opts) { SKIP: { @@ -77,112 +75,18 @@ for my $opts (@opts) { $schema->resultset('Artist')->search({ name => 'foo' })->delete; - $new = $schema->resultset('Artist')->create({ name => 'foo' }); + my $new = $schema->resultset('Artist')->create({ name => 'foo' }); ok($new->artistid > 0, "Auto-PK worked"); } } -$seen_id{$new->artistid}++; - -# test LIMIT support -for (1..6) { - $new = $schema->resultset('Artist')->create({ name => 'Artist ' . $_ }); - is ( $seen_id{$new->artistid}, undef, "id for Artist $_ is unique" ); - $seen_id{$new->artistid}++; -} - -my $it = $schema->resultset('Artist')->search( {}, { - rows => 3, - order_by => 'artistid', -}); - -is( $it->count, 3, "LIMIT count ok" ); -is( $it->next->name, "foo", "iterator->next ok" ); -$it->next; -is( $it->next->name, "Artist 2", "iterator->next ok" ); -is( $it->next, undef, "next past end of resultset ok" ); - -# test GUID columns - -$schema->storage->dbh_do (sub { - my ($storage, $dbh) = @_; - eval { $dbh->do("DROP TABLE artist") }; - $dbh->do(<<'SQL'); -CREATE TABLE artist ( - artistid UNIQUEIDENTIFIER NOT NULL, - name VARCHAR(100), - rank INT NOT NULL DEFAULT '13', - charfield CHAR(10) NULL, - a_guid UNIQUEIDENTIFIER, - primary key(artistid) -) -SQL -}); - -# start disconnected to make sure insert works on an un-reblessed storage -$schema = DBICTest::Schema->connect($dsn, $user, $pass); - -my $row; -lives_ok { - $row = $schema->resultset('ArtistGUID')->create({ name => 'mtfnpy' }) -} 'created a row with a GUID'; - -ok( - eval { $row->artistid }, - 'row has GUID PK col populated', -); -diag $@ if $@; - -ok( - eval { $row->a_guid }, - 'row has a GUID col with auto_nextval populated', -); -diag $@ if $@; - -my $row_from_db = $schema->resultset('ArtistGUID') - ->search({ name => 'mtfnpy' })->first; - -is $row_from_db->artistid, $row->artistid, - 'PK GUID round trip'; -is $row_from_db->a_guid, $row->a_guid, - 'NON-PK GUID round trip'; -# test MONEY type -$schema->storage->dbh_do (sub { - my ($storage, $dbh) = @_; - eval { $dbh->do("DROP TABLE money_test") }; - $dbh->do(<<'SQL'); -CREATE TABLE money_test ( - id INT IDENTITY PRIMARY KEY, - amount MONEY NULL -) -SQL -}); - -my $rs = $schema->resultset('Money'); - -lives_ok { - $row = $rs->create({ amount => 100 }); -} 'inserted a money value'; - -cmp_ok $rs->find($row->id)->amount, '==', 100, 'money value round-trip'; - -lives_ok { - $row->update({ amount => 200 }); -} 'updated a money value'; - -cmp_ok $rs->find($row->id)->amount, '==', 200, - 'updated money value round-trip'; - -lives_ok { - $row->update({ amount => undef }); -} 'updated a money value to NULL'; +# Test populate -is $rs->find($row->id)->amount, undef,'updated money value to NULL round-trip'; - -$schema->storage->dbh_do (sub { +{ + $schema->storage->dbh_do (sub { my ($storage, $dbh) = @_; eval { $dbh->do("DROP TABLE owners") }; eval { $dbh->do("DROP TABLE books") }; @@ -201,260 +105,378 @@ CREATE TABLE owners ( ) SQL -}); - -lives_ok ( sub { - # start a new connection, make sure rebless works - my $schema = DBICTest::Schema->connect($dsn, $user, $pass); - $schema->populate ('Owners', [ - [qw/id name /], - [qw/1 wiggle/], - [qw/2 woggle/], - [qw/3 boggle/], - [qw/4 fRIOUX/], - [qw/5 fRUE/], - [qw/6 fREW/], - [qw/7 fROOH/], - [qw/8 fISMBoC/], - [qw/9 station/], - [qw/10 mirror/], - [qw/11 dimly/], - [qw/12 face_to_face/], - [qw/13 icarus/], - [qw/14 dream/], - [qw/15 dyrstyggyr/], - ]); -}, 'populate with PKs supplied ok' ); - - -lives_ok (sub { - # start a new connection, make sure rebless works - # test an insert with a supplied identity, followed by one without - my $schema = DBICTest::Schema->connect($dsn, $user, $pass); - for (2, 1) { - my $id = $_ * 20 ; - $schema->resultset ('Owners')->create ({ id => $id, name => "troglodoogle $id" }); - $schema->resultset ('Owners')->create ({ name => "troglodoogle " . ($id + 1) }); - } -}, 'create with/without PKs ok' ); - -is ($schema->resultset ('Owners')->count, 19, 'owner rows really in db' ); - -lives_ok ( sub { - # start a new connection, make sure rebless works - my $schema = DBICTest::Schema->connect($dsn, $user, $pass); - $schema->populate ('BooksInLibrary', [ - [qw/source owner title /], - [qw/Library 1 secrets0/], - [qw/Library 1 secrets1/], - [qw/Eatery 1 secrets2/], - [qw/Library 2 secrets3/], - [qw/Library 3 secrets4/], - [qw/Eatery 3 secrets5/], - [qw/Library 4 secrets6/], - [qw/Library 5 secrets7/], - [qw/Eatery 5 secrets8/], - [qw/Library 6 secrets9/], - [qw/Library 7 secrets10/], - [qw/Eatery 7 secrets11/], - [qw/Library 8 secrets12/], - ]); -}, 'populate without PKs supplied ok' ); - -# plain ordered subqueries throw -throws_ok (sub { - $schema->resultset('Owners')->search ({}, { order_by => 'name' })->as_query -}, qr/ordered subselect encountered/, 'Ordered Subselect detection throws ok'); - -# make sure ordered subselects *somewhat* work -{ - my $owners = $schema->resultset ('Owners')->search ({}, { order_by => 'name', offset => 2, rows => 3, unsafe_subselect_ok => 1 }); - - my $al = $owners->current_source_alias; - my $sealed_owners = $owners->result_source->resultset->search ( - {}, - { - alias => $al, - from => [{ - -alias => $al, - -source_handle => $owners->result_source->handle, - $al => $owners->as_query, - }], - }, - ); + }); - is_deeply ( - [ map { $_->name } ($sealed_owners->all) ], - [ map { $_->name } ($owners->all) ], - 'Sort preserved from within a subquery', - ); + lives_ok ( sub { + # start a new connection, make sure rebless works + my $schema = DBICTest::Schema->connect($dsn, $user, $pass); + $schema->populate ('Owners', [ + [qw/id name /], + [qw/1 wiggle/], + [qw/2 woggle/], + [qw/3 boggle/], + [qw/4 fRIOUX/], + [qw/5 fRUE/], + [qw/6 fREW/], + [qw/7 fROOH/], + [qw/8 fISMBoC/], + [qw/9 station/], + [qw/10 mirror/], + [qw/11 dimly/], + [qw/12 face_to_face/], + [qw/13 icarus/], + [qw/14 dream/], + [qw/15 dyrstyggyr/], + ]); + }, 'populate with PKs supplied ok' ); + + + lives_ok (sub { + # start a new connection, make sure rebless works + # test an insert with a supplied identity, followed by one without + my $schema = DBICTest::Schema->connect($dsn, $user, $pass); + for (2, 1) { + my $id = $_ * 20 ; + $schema->resultset ('Owners')->create ({ id => $id, name => "troglodoogle $id" }); + $schema->resultset ('Owners')->create ({ name => "troglodoogle " . ($id + 1) }); + } + }, 'create with/without PKs ok' ); + + is ($schema->resultset ('Owners')->count, 19, 'owner rows really in db' ); + + lives_ok ( sub { + # start a new connection, make sure rebless works + my $schema = DBICTest::Schema->connect($dsn, $user, $pass); + $schema->populate ('BooksInLibrary', [ + [qw/source owner title /], + [qw/Library 1 secrets0/], + [qw/Library 1 secrets1/], + [qw/Eatery 1 secrets2/], + [qw/Library 2 secrets3/], + [qw/Library 3 secrets4/], + [qw/Eatery 3 secrets5/], + [qw/Library 4 secrets6/], + [qw/Library 5 secrets7/], + [qw/Eatery 5 secrets8/], + [qw/Library 6 secrets9/], + [qw/Library 7 secrets10/], + [qw/Eatery 7 secrets11/], + [qw/Library 8 secrets12/], + ]); + }, 'populate without PKs supplied ok' ); } -TODO: { - local $TODO = "This porbably will never work, but it isn't critical either afaik"; +# test simple, complex LIMIT and limited prefetch support, with both dialects and quote combinations (if possible) +for my $dialect ( + 'Top', + ($schema->storage->_server_info->{normalized_dbms_version} || 0 ) >= 9 + ? ('RowNumberOver') + : () + , +) { + for my $quoted (0, 1) { + + $schema = DBICTest::Schema->connect($dsn, $user, $pass, { + limit_dialect => $dialect, + $quoted + ? ( quote_char => [ qw/ [ ] / ], name_sep => '.' ) + : () + , + }); + + my $test_type = "Dialect:$dialect Quoted:$quoted"; + + # basic limit support + TODO: { + my $art_rs = $schema->resultset ('Artist'); + $art_rs->delete; + $art_rs->create({ name => 'Artist ' . $_ }) for (1..6); + + my $it = $schema->resultset('Artist')->search( {}, { + rows => 4, + offset => 3, + order_by => 'artistid', + }); + + is( $it->count, 3, "$test_type: LIMIT count ok" ); + + local $TODO = "Top-limit does not work when your limit ends up past the resultset" + if $dialect eq 'Top'; + + is( $it->next->name, 'Artist 4', "$test_type: iterator->next ok" ); + $it->next; + is( $it->next->name, 'Artist 6', "$test_type: iterator->next ok" ); + is( $it->next, undef, "$test_type: next past end of resultset ok" ); + } - my $book_owner_ids = $schema->resultset ('BooksInLibrary') - ->search ({}, { join => 'owner', distinct => 1, order_by => 'owner.name', unsafe_subselect_ok => 1 }) - ->get_column ('owner'); + # plain ordered subqueries throw + throws_ok (sub { + $schema->resultset('Owners')->search ({}, { order_by => 'name' })->as_query + }, qr/ordered subselect encountered/, "$test_type: Ordered Subselect detection throws ok"); - my $book_owners = $schema->resultset ('Owners')->search ({ - id => { -in => $book_owner_ids->as_query } - }); + # make sure ordered subselects *somewhat* work + { + my $owners = $schema->resultset ('Owners')->search ({}, { order_by => 'name', offset => 2, rows => 3, unsafe_subselect_ok => 1 }); + my $sealed_owners = $owners->as_subselect_rs; + + is_deeply ( + [ map { $_->name } ($sealed_owners->all) ], + [ map { $_->name } ($owners->all) ], + "$test_type: Sort preserved from within a subquery", + ); + } - is_deeply ( - [ map { $_->id } ($book_owners->all) ], - [ $book_owner_ids->all ], - 'Sort is preserved across IN subqueries', - ); -} + { + my $book_owner_ids = $schema->resultset ('BooksInLibrary')->search ({}, { + rows => 6, + offset => 2, + join => 'owner', + distinct => 1, + order_by => 'owner.name', + unsafe_subselect_ok => 1 + })->get_column ('owner'); + + my @ids = $book_owner_ids->all; + + is (@ids, 6, 'Limit works'); + + my $book_owners = $schema->resultset ('Owners')->search ({ + id => { -in => $book_owner_ids->as_query } + }); + + TODO: { + local $TODO = "Correlated limited IN subqueries will probably never preserve order"; + + is_deeply ( + [ map { $_->id } ($book_owners->all) ], + [ $book_owner_ids->all ], + "$test_type: Sort is preserved across IN subqueries", + ); + } + } -# This is known not to work - thus the negative test -{ - my $owners = $schema->resultset ('Owners')->search ({}, { order_by => 'name', offset => 2, rows => 3, unsafe_subselect_ok => 1 }); - my $corelated_owners = $owners->result_source->resultset->search ( + # still even with lost order of IN, we should be getting correct + # sets { - id => { -in => $owners->get_column('id')->as_query }, - }, + my $owners = $schema->resultset ('Owners')->search ({}, { order_by => 'name', offset => 2, rows => 3, unsafe_subselect_ok => 1 }); + my $corelated_owners = $owners->result_source->resultset->search ( + { + id => { -in => $owners->get_column('id')->as_query }, + }, + { + order_by => 'name' #reorder because of what is shown above + }, + ); + + is ( + join ("\x00", map { $_->name } ($corelated_owners->all) ), + join ("\x00", map { $_->name } ($owners->all) ), + "$test_type: With an outer order_by, everything still matches", + ); + } + + # make sure right-join-side single-prefetch ordering limit works { - order_by => 'name' #reorder because of what is shown above - }, - ); + my $rs = $schema->resultset ('BooksInLibrary')->search ( + { + 'owner.name' => { '!=', 'woggle' }, + }, + { + prefetch => 'owner', + order_by => 'owner.name', + } + ); + # this is the order in which they should come from the above query + my @owner_names = qw/boggle fISMBoC fREW fRIOUX fROOH fRUE wiggle wiggle/; + + is ($rs->all, 8, "$test_type: Correct amount of objects from right-sorted joined resultset"); + is_deeply ( + [map { $_->owner->name } ($rs->all) ], + \@owner_names, + "$test_type: Prefetched rows were properly ordered" + ); + + my $limited_rs = $rs->search ({}, {rows => 6, offset => 2, unsafe_subselect_ok => 1}); + is ($limited_rs->count, 6, "$test_type: Correct count of limited right-sorted joined resultset"); + is ($limited_rs->count_rs->next, 6, "$test_type: Correct count_rs of limited right-sorted joined resultset"); + + my $queries; + $schema->storage->debugcb(sub { $queries++; }); + $schema->storage->debug(1); + + is_deeply ( + [map { $_->owner->name } ($limited_rs->all) ], + [@owner_names[2 .. 7]], + "$test_type: Prefetch-limited rows were properly ordered" + ); + is ($queries, 1, "$test_type: Only one query with prefetch"); + + $schema->storage->debugcb(undef); + $schema->storage->debug(0); + + is_deeply ( + [map { $_->name } ($limited_rs->search_related ('owner')->all) ], + [@owner_names[2 .. 7]], + "$test_type: Rows are still properly ordered after search_related", + ); + } - cmp_ok ( - join ("\x00", map { $_->name } ($corelated_owners->all) ), - 'ne', - join ("\x00", map { $_->name } ($owners->all) ), - 'Sadly sort not preserved from within a corelated subquery', - ); + # try a ->has_many direction with duplicates + my $owners = $schema->resultset ('Owners')->search ( + { + 'books.id' => { '!=', undef }, + 'me.name' => { '!=', 'somebogusstring' }, + }, + { + prefetch => 'books', + order_by => { -asc => \['name + ?', [ test => 'xxx' ]] }, # test bindvar propagation + rows => 3, # 8 results total + unsafe_subselect_ok => 1, + }, + ); + + my ($sql, @bind) = @${$owners->page(3)->as_query}; + is_deeply ( + \@bind, + [ ([ 'me.name' => 'somebogusstring' ], [ test => 'xxx' ]) x 2 ], # double because of the prefetch subq + ); + + is ($owners->page(1)->all, 3, "$test_type: has_many prefetch returns correct number of rows"); + is ($owners->page(1)->count, 3, "$test_type: has-many prefetch returns correct count"); + + is ($owners->page(3)->count, 2, "$test_type: has-many prefetch returns correct count"); + TODO: { + local $TODO = "Top-limit does not work when your limit ends up past the resultset" + if $dialect eq 'Top'; + is ($owners->page(3)->all, 2, "$test_type: has_many prefetch returns correct number of rows"); + is ($owners->page(3)->count_rs->next, 2, "$test_type: has-many prefetch returns correct count_rs"); + } - cmp_ok ( - join ("\x00", sort map { $_->name } ($corelated_owners->all) ), - 'ne', - join ("\x00", sort map { $_->name } ($owners->all) ), - 'Which in fact gives a completely wrong dataset', - ); + + # try a ->belongs_to direction (no select collapse, group_by should work) + my $books = $schema->resultset ('BooksInLibrary')->search ( + { + 'owner.name' => [qw/wiggle woggle/], + }, + { + distinct => 1, + having => \['1 = ?', [ test => 1 ] ], #test having propagation + prefetch => 'owner', + rows => 2, # 3 results total + order_by => { -desc => 'me.owner' }, + unsafe_subselect_ok => 1, + }, + ); + + ($sql, @bind) = @${$books->page(3)->as_query}; + is_deeply ( + \@bind, + [ + # inner + [ 'owner.name' => 'wiggle' ], [ 'owner.name' => 'woggle' ], [ source => 'Library' ], [ test => '1' ], + # outer + [ 'owner.name' => 'wiggle' ], [ 'owner.name' => 'woggle' ], [ source => 'Library' ], + ], + ); + + is ($books->page(1)->all, 2, "$test_type: Prefetched grouped search returns correct number of rows"); + is ($books->page(1)->count, 2, "$test_type: Prefetched grouped search returns correct count"); + + is ($books->page(2)->count, 1, "$test_type: Prefetched grouped search returns correct count"); + TODO: { + local $TODO = "Top-limit does not work when your limit ends up past the resultset" + if $dialect eq 'Top'; + is ($books->page(2)->all, 1, "$test_type: Prefetched grouped search returns correct number of rows"); + is ($books->page(2)->count_rs->next, 1, "$test_type: Prefetched grouped search returns correct count_rs"); + } + } } -# make sure right-join-side single-prefetch ordering limit works +# test GUID columns { - my $rs = $schema->resultset ('BooksInLibrary')->search ( - { - 'owner.name' => { '!=', 'woggle' }, - }, - { - prefetch => 'owner', - order_by => 'owner.name', - } - ); - # this is the order in which they should come from the above query - my @owner_names = qw/boggle fISMBoC fREW fRIOUX fROOH fRUE wiggle wiggle/; - - is ($rs->all, 8, 'Correct amount of objects from right-sorted joined resultset'); - is_deeply ( - [map { $_->owner->name } ($rs->all) ], - \@owner_names, - 'Rows were properly ordered' - ); + $schema->storage->dbh_do (sub { + my ($storage, $dbh) = @_; + eval { $dbh->do("DROP TABLE artist") }; + $dbh->do(<<'SQL'); +CREATE TABLE artist ( + artistid UNIQUEIDENTIFIER NOT NULL, + name VARCHAR(100), + rank INT NOT NULL DEFAULT '13', + charfield CHAR(10) NULL, + a_guid UNIQUEIDENTIFIER, + primary key(artistid) +) +SQL + }); - my $limited_rs = $rs->search ({}, {rows => 7, offset => 2, unsafe_subselect_ok => 1}); - is ($limited_rs->count, 6, 'Correct count of limited right-sorted joined resultset'); - is ($limited_rs->count_rs->next, 6, 'Correct count_rs of limited right-sorted joined resultset'); + # start disconnected to make sure insert works on an un-reblessed storage + $schema = DBICTest::Schema->connect($dsn, $user, $pass); - my $queries; - $schema->storage->debugcb(sub { $queries++; }); - $schema->storage->debug(1); + my $row; + lives_ok { + $row = $schema->resultset('ArtistGUID')->create({ name => 'mtfnpy' }) + } 'created a row with a GUID'; - is_deeply ( - [map { $_->owner->name } ($limited_rs->all) ], - [@owner_names[2 .. 7]], - 'Limited rows were properly ordered' + ok( + eval { $row->artistid }, + 'row has GUID PK col populated', ); - is ($queries, 1, 'Only one query with prefetch'); - - $schema->storage->debugcb(undef); - $schema->storage->debug(0); + diag $@ if $@; - - is_deeply ( - [map { $_->name } ($limited_rs->search_related ('owner')->all) ], - [@owner_names[2 .. 7]], - 'Rows are still properly ordered after search_related' + ok( + eval { $row->a_guid }, + 'row has a GUID col with auto_nextval populated', ); -} + diag $@ if $@; + my $row_from_db = $schema->resultset('ArtistGUID') + ->search({ name => 'mtfnpy' })->first; -# -# try a prefetch on tables with identically named columns -# + is $row_from_db->artistid, $row->artistid, + 'PK GUID round trip'; -# set quote char - make sure things work while quoted -$schema->storage->_sql_maker->{quote_char} = [qw/[ ]/]; -$schema->storage->_sql_maker->{name_sep} = '.'; + is $row_from_db->a_guid, $row->a_guid, + 'NON-PK GUID round trip'; +} +# test MONEY type { - # try a ->has_many direction - my $owners = $schema->resultset ('Owners')->search ( - { - 'books.id' => { '!=', undef }, - 'me.name' => { '!=', 'somebogusstring' }, - }, - { - prefetch => 'books', - order_by => { -asc => \['name + ?', [ test => 'xxx' ]] }, # test bindvar propagation - rows => 3, # 8 results total - unsafe_subselect_ok => 1, - }, - ); - - my ($sql, @bind) = @${$owners->page(3)->as_query}; - is_deeply ( - \@bind, - [ ([ 'me.name' => 'somebogusstring' ], [ test => 'xxx' ]) x 2 ], # double because of the prefetch subq - ); + $schema->storage->dbh_do (sub { + my ($storage, $dbh) = @_; + eval { $dbh->do("DROP TABLE money_test") }; + $dbh->do(<<'SQL'); +CREATE TABLE money_test ( + id INT IDENTITY PRIMARY KEY, + amount MONEY NULL +) +SQL + }); - is ($owners->page(1)->all, 3, 'has_many prefetch returns correct number of rows'); - is ($owners->page(1)->count, 3, 'has-many prefetch returns correct count'); + my $rs = $schema->resultset('Money'); + my $row; - is ($owners->page(3)->all, 2, 'has_many prefetch returns correct number of rows'); - is ($owners->page(3)->count, 2, 'has-many prefetch returns correct count'); - is ($owners->page(3)->count_rs->next, 2, 'has-many prefetch returns correct count_rs'); + lives_ok { + $row = $rs->create({ amount => 100 }); + } 'inserted a money value'; + cmp_ok $rs->find($row->id)->amount, '==', 100, 'money value round-trip'; - # try a ->belongs_to direction (no select collapse, group_by should work) - my $books = $schema->resultset ('BooksInLibrary')->search ( - { - 'owner.name' => [qw/wiggle woggle/], - }, - { - distinct => 1, - having => \['1 = ?', [ test => 1 ] ], #test having propagation - prefetch => 'owner', - rows => 2, # 3 results total - order_by => { -desc => 'me.owner' }, - unsafe_subselect_ok => 1, - }, - ); + lives_ok { + $row->update({ amount => 200 }); + } 'updated a money value'; - ($sql, @bind) = @${$books->page(3)->as_query}; - is_deeply ( - \@bind, - [ - # inner - [ 'owner.name' => 'wiggle' ], [ 'owner.name' => 'woggle' ], [ source => 'Library' ], [ test => '1' ], - # outer - [ 'owner.name' => 'wiggle' ], [ 'owner.name' => 'woggle' ], [ source => 'Library' ], - ], - ); + cmp_ok $rs->find($row->id)->amount, '==', 200, + 'updated money value round-trip'; - is ($books->page(1)->all, 2, 'Prefetched grouped search returns correct number of rows'); - is ($books->page(1)->count, 2, 'Prefetched grouped search returns correct count'); + lives_ok { + $row->update({ amount => undef }); + } 'updated a money value to NULL'; - is ($books->page(2)->all, 1, 'Prefetched grouped search returns correct number of rows'); - is ($books->page(2)->count, 1, 'Prefetched grouped search returns correct count'); - is ($books->page(2)->count_rs->next, 1, 'Prefetched grouped search returns correct count_rs'); + is $rs->find($row->id)->amount, undef,'updated money value to NULL round-trip'; } + done_testing; # clean up our mess diff --git a/t/74mssql.t b/t/74mssql.t index a882e99..78e4691 100644 --- a/t/74mssql.t +++ b/t/74mssql.t @@ -172,6 +172,38 @@ SQL is $rs->first, undef, 'rolled back'; $rs->reset; + + # test RNO detection when version detection fails + SKIP: { + my $storage = $schema->storage; + my $version = $storage->_server_info->{normalized_dbms_version}; + + skip 1, 'could not detect SQL Server version' if not defined $version; + + my $have_rno = $version >= 9 ? 1 : 0; + + # Delete version information to force RNO check when rebuilding SQLA + # instance. + no strict 'refs'; + no warnings 'redefine'; + local *{(ref $storage).'::_get_server_version'} = sub { undef }; + + my $server_info = { %{ $storage->_server_info_hash } }; # clone + + delete @$server_info{qw/dbms_version normalized_dbms_version/}; + + local $storage->{_server_info_hash} = $server_info; + local $storage->{_sql_maker} = undef; + local $storage->{_sql_maker_opts} = undef; + + $storage->sql_maker; + + my $rno_detected = + ($storage->{_sql_maker_opts}{limit_dialect} eq 'RowNumberOver'); + + ok ((not ($have_rno xor $rno_detected)), + 'row_number() over support detected correctly'); + } } # test op-induced autoconnect diff --git a/t/inflate/datetime_mssql.t b/t/inflate/datetime_mssql.t index c1ce5dd..25524de 100644 --- a/t/inflate/datetime_mssql.t +++ b/t/inflate/datetime_mssql.t @@ -95,8 +95,8 @@ SQL ->first ); is( $row->$col, $dt, "$type roundtrip" ); - - is( $row->$col->nanosecond, $sample_dt->{nanosecond}, + + cmp_ok( $row->$col->nanosecond, '==', $sample_dt->{nanosecond}, 'DateTime fractional portion roundtrip' ) if exists $sample_dt->{nanosecond}; } diff --git a/t/resultset/as_subselect_rs.t b/t/resultset/as_subselect_rs.t index c143d11..1453f63 100644 --- a/t/resultset/as_subselect_rs.t +++ b/t/resultset/as_subselect_rs.t @@ -22,4 +22,21 @@ lives_ok { $new_rs->search({ 'artwork_to_artist.artwork_cd_id' => 1})->as_subsel '... and chaining off the virtual view works'; dies_ok { $new_rs->as_subselect_rs->search({'artwork_to_artist.artwork_cd_id'=> 1})->count } q{... but chaining off of a virtual view using join doesn't work}; + +my $book_rs = $schema->resultset ('BooksInLibrary')->search ({}, { join => 'owner' }); + +is_same_sql_bind ( + $book_rs->as_subselect_rs->as_query, + '(SELECT me.id, me.source, me.owner, me.title, me.price + FROM ( + SELECT me.id, me.source, me.owner, me.title, me.price + FROM books me + JOIN owners owner ON owner.id = me.owner + WHERE ( source = ? ) + ) me + )', + [ [ source => 'Library' ] ], + 'Resultset-class attributes do not seep outside of the subselect', +); + done_testing; diff --git a/t/sqlahacks/limit_dialects/rownumberover.t b/t/sqlahacks/limit_dialects/rno.t similarity index 100% rename from t/sqlahacks/limit_dialects/rownumberover.t rename to t/sqlahacks/limit_dialects/rno.t diff --git a/t/sqlahacks/limit_dialects/rownum.t b/t/sqlahacks/limit_dialects/rownum.t new file mode 100644 index 0000000..85ca3e8 --- /dev/null +++ b/t/sqlahacks/limit_dialects/rownum.t @@ -0,0 +1,35 @@ +use strict; +use warnings; + +use Test::More; + +use lib qw(t/lib); +use DBICTest; +use DBIC::SqlMakerTest; + +my $s = DBICTest->init_schema (no_deploy => 1, ); +$s->storage->sql_maker->limit_dialect ('RowNum'); + +my $rs = $s->resultset ('CD'); + +is_same_sql_bind ( + $rs->search ({}, { rows => 1, offset => 3,columns => [ + { id => 'foo.id' }, + { 'bar.id' => 'bar.id' }, + { bleh => \ 'TO_CHAR (foo.womble, "blah")' }, + ]})->as_query, + '(SELECT id, bar__id, bleh + FROM ( + SELECT id, bar__id, bleh, ROWNUM rownum__index + FROM ( + SELECT foo.id AS id, bar.id AS bar__id, TO_CHAR(foo.womble, "blah") AS bleh + FROM cd me + ) me + ) me + WHERE rownum__index BETWEEN 4 AND 4 + )', + [], + 'Rownum subsel aliasing works correctly' +); + +done_testing; diff --git a/t/sqlahacks/limit_dialects/toplimit.t b/t/sqlahacks/limit_dialects/toplimit.t index 1ad1cda..b2840c2 100644 --- a/t/sqlahacks/limit_dialects/toplimit.t +++ b/t/sqlahacks/limit_dialects/toplimit.t @@ -11,143 +11,170 @@ my $schema = DBICTest->init_schema; # Trick the sqlite DB to use Top limit emulation # We could test all of this via $sq->$op directly, # but some conditions need a $rsrc +delete $schema->storage->_sql_maker->{_cached_syntax}; $schema->storage->_sql_maker->limit_dialect ('Top'); -my $rs = $schema->resultset ('BooksInLibrary')->search ({}, { prefetch => 'owner', rows => 1, offset => 3 }); - -sub default_test_order { - my $order_by = shift; - is_same_sql_bind( - $rs->search ({}, {order_by => $order_by})->as_query, - "(SELECT - TOP 1 me__id, source, owner, title, price, owner__id, name FROM - (SELECT - TOP 4 me.id AS me__id, me.source, me.owner, me.title, me.price, owner.id AS owner__id, owner.name - FROM books me - JOIN owners owner ON - owner.id = me.owner - WHERE ( source = ? ) - ORDER BY me__id ASC - ) me ORDER BY me__id DESC - )", - [ [ source => 'Library' ] ], - ); -} - -sub test_order { - my $args = shift; - - my $req_order = $args->{order_req} - ? "ORDER BY $args->{order_req}" - : '' - ; +my $books_45_and_owners = $schema->resultset ('BooksInLibrary')->search ({}, { prefetch => 'owner', rows => 2, offset => 3 }); +for my $null_order ( + undef, + '', + {}, + [], + [{}], +) { + my $rs = $books_45_and_owners->search ({}, {order_by => $null_order }); is_same_sql_bind( - $rs->search ({}, {order_by => $args->{order_by}})->as_query, - "(SELECT - me__id, source, owner, title, price, owner__id, name FROM - (SELECT - TOP 1 me__id, source, owner, title, price, owner__id, name FROM - (SELECT - TOP 4 me.id AS me__id, me.source, me.owner, me.title, me.price, owner.id AS owner__id, owner.name FROM - books me - JOIN owners owner ON owner.id = me.owner - WHERE ( source = ? ) - ORDER BY $args->{order_inner} - ) me ORDER BY $args->{order_outer} - ) me $req_order - )", + $rs->as_query, + '(SELECT TOP 2 + id, source, owner, title, price, owner__id, owner__name + FROM ( + SELECT TOP 5 + me.id, me.source, me.owner, me.title, me.price, owner.id AS owner__id, owner.name AS owner__name + FROM books me + JOIN owners owner ON owner.id = me.owner + WHERE ( source = ? ) + ORDER BY me.id + ) me + ORDER BY me.id DESC + )', [ [ source => 'Library' ] ], ); } -my @tests = ( + +for my $ord_set ( { order_by => \'foo DESC', - order_req => 'foo DESC', order_inner => 'foo DESC', - order_outer => 'foo ASC' + order_outer => 'ORDER__BY__1 ASC', + order_req => 'ORDER__BY__1 DESC', + exselect_outer => 'ORDER__BY__1', + exselect_inner => 'foo AS ORDER__BY__1', }, { order_by => { -asc => 'foo' }, - order_req => 'foo ASC', order_inner => 'foo ASC', - order_outer => 'foo DESC', + order_outer => 'ORDER__BY__1 DESC', + order_req => 'ORDER__BY__1 ASC', + exselect_outer => 'ORDER__BY__1', + exselect_inner => 'foo AS ORDER__BY__1', }, { - order_by => 'foo', - order_req => 'foo', - order_inner => 'foo ASC', - order_outer => 'foo DESC', + order_by => { -desc => 'foo' }, + order_inner => 'foo DESC', + order_outer => 'ORDER__BY__1 ASC', + order_req => 'ORDER__BY__1 DESC', + exselect_outer => 'ORDER__BY__1', + exselect_inner => 'foo AS ORDER__BY__1', }, { - order_by => [ qw{ foo bar} ], - order_req => 'foo, bar', - order_inner => 'foo ASC, bar ASC', - order_outer => 'foo DESC, bar DESC', + order_by => 'foo', + order_inner => 'foo', + order_outer => 'ORDER__BY__1 DESC', + order_req => 'ORDER__BY__1', + exselect_outer => 'ORDER__BY__1', + exselect_inner => 'foo AS ORDER__BY__1', }, { - order_by => { -desc => 'foo' }, - order_req => 'foo DESC', - order_inner => 'foo DESC', - order_outer => 'foo ASC', + order_by => [ qw{ foo me.owner} ], + order_inner => 'foo, me.owner', + order_outer => 'ORDER__BY__1 DESC, me.owner DESC', + order_req => 'ORDER__BY__1, me.owner', + exselect_outer => 'ORDER__BY__1', + exselect_inner => 'foo AS ORDER__BY__1', }, { order_by => ['foo', { -desc => 'bar' } ], - order_req => 'foo, bar DESC', - order_inner => 'foo ASC, bar DESC', - order_outer => 'foo DESC, bar ASC', + order_inner => 'foo, bar DESC', + order_outer => 'ORDER__BY__1 DESC, ORDER__BY__2 ASC', + order_req => 'ORDER__BY__1, ORDER__BY__2 DESC', + exselect_outer => 'ORDER__BY__1, ORDER__BY__2', + exselect_inner => 'foo AS ORDER__BY__1, bar AS ORDER__BY__2', }, { order_by => { -asc => [qw{ foo bar }] }, - order_req => 'foo ASC, bar ASC', order_inner => 'foo ASC, bar ASC', - order_outer => 'foo DESC, bar DESC', + order_outer => 'ORDER__BY__1 DESC, ORDER__BY__2 DESC', + order_req => 'ORDER__BY__1 ASC, ORDER__BY__2 ASC', + exselect_outer => 'ORDER__BY__1, ORDER__BY__2', + exselect_inner => 'foo AS ORDER__BY__1, bar AS ORDER__BY__2', }, { order_by => [ - { -asc => 'foo' }, + 'foo', { -desc => [qw{bar}] }, - { -asc => [qw{hello sensors}]}, + { -asc => [qw{me.owner sensors}]}, ], - order_req => 'foo ASC, bar DESC, hello ASC, sensors ASC', - order_inner => 'foo ASC, bar DESC, hello ASC, sensors ASC', - order_outer => 'foo DESC, bar ASC, hello DESC, sensors DESC', + order_inner => 'foo, bar DESC, me.owner ASC, sensors ASC', + order_outer => 'ORDER__BY__1 DESC, ORDER__BY__2 ASC, me.owner DESC, ORDER__BY__3 DESC', + order_req => 'ORDER__BY__1, ORDER__BY__2 DESC, me.owner ASC, ORDER__BY__3 ASC', + exselect_outer => 'ORDER__BY__1, ORDER__BY__2, ORDER__BY__3', + exselect_inner => 'foo AS ORDER__BY__1, bar AS ORDER__BY__2, sensors AS ORDER__BY__3', }, -); - -my @default_tests = ( undef, '', {}, [] ); - -test_order ($_) for @tests; -default_test_order ($_) for @default_tests; +) { + my $o_sel = $ord_set->{exselect_outer} + ? ', ' . $ord_set->{exselect_outer} + : '' + ; + my $i_sel = $ord_set->{exselect_inner} + ? ', ' . $ord_set->{exselect_inner} + : '' + ; + is_same_sql_bind( + $books_45_and_owners->search ({}, {order_by => $ord_set->{order_by}})->as_query, + "(SELECT TOP 2 + id, source, owner, title, price, owner__id, owner__name + FROM ( + SELECT TOP 2 + id, source, owner, title, price, owner__id, owner__name$o_sel + FROM ( + SELECT TOP 5 + me.id, me.source, me.owner, me.title, me.price, owner.id AS owner__id, owner.name AS owner__name$i_sel + FROM books me + JOIN owners owner ON owner.id = me.owner + WHERE ( source = ? ) + ORDER BY $ord_set->{order_inner} + ) me + ORDER BY $ord_set->{order_outer} + ) me + ORDER BY $ord_set->{order_req} + )", + [ [ source => 'Library' ] ], + ); +} +# with groupby is_same_sql_bind ( - $rs->search ({}, { group_by => 'title', order_by => 'title' })->as_query, -'(SELECT -me.id, me.source, me.owner, me.title, me.price, owner.id, owner.name FROM - ( SELECT - id, source, owner, title, price FROM - ( SELECT - TOP 1 id, source, owner, title, price FROM - ( SELECT - TOP 4 me.id, me.source, me.owner, me.title, me.price FROM - books me JOIN - owners owner ON owner.id = me.owner - WHERE ( source = ? ) - GROUP BY title - ORDER BY title ASC - ) me - ORDER BY title DESC + $books_45_and_owners->search ({}, { group_by => 'title', order_by => 'title' })->as_query, + '(SELECT me.id, me.source, me.owner, me.title, me.price, owner.id, owner.name + FROM ( + SELECT TOP 2 id, source, owner, title, price + FROM ( + SELECT TOP 2 + id, source, owner, title, price, ORDER__BY__1 + FROM ( + SELECT TOP 5 + me.id, me.source, me.owner, me.title, me.price, title AS ORDER__BY__1 + FROM books me + JOIN owners owner ON owner.id = me.owner + WHERE ( source = ? ) + GROUP BY title + ORDER BY title + ) me + ORDER BY ORDER__BY__1 DESC + ) me + ORDER BY ORDER__BY__1 ) me - ORDER BY title - ) me JOIN - owners owner ON owner.id = me.owner WHERE - ( source = ? ) - ORDER BY title)' , + JOIN owners owner ON owner.id = me.owner + WHERE ( source = ? ) + ORDER BY title + )', [ [ source => 'Library' ], [ source => 'Library' ] ], ); +# test deprecated column mixing over join boundaries my $rs_selectas_top = $schema->resultset ('BooksInLibrary')->search ({}, { '+select' => ['owner.name'], '+as' => ['owner_name'], @@ -158,11 +185,11 @@ my $rs_selectas_top = $schema->resultset ('BooksInLibrary')->search ({}, { is_same_sql_bind( $rs_selectas_top->search({})->as_query, '(SELECT TOP 1 me.id, me.source, me.owner, me.title, me.price, - owner.name + owner.name AS owner_name FROM books me JOIN owners owner ON owner.id = me.owner WHERE ( source = ? ) - ORDER BY me.id ASC + ORDER BY me.id )', [ [ 'source', 'Library' ] ], ); diff --git a/t/41orrible.t b/t/sqlahacks/oraclejoin.t similarity index 80% rename from t/41orrible.t rename to t/sqlahacks/oraclejoin.t index b0117a7..83c8332 100644 --- a/t/41orrible.t +++ b/t/sqlahacks/oraclejoin.t @@ -2,33 +2,14 @@ use strict; use warnings; use Test::More; -use DBIx::Class::SQLAHacks::OracleJoins; use lib qw(t/lib); -use DBICTest; # do not remove even though it is not used +use DBIx::Class::SQLAHacks::OracleJoins; +use DBICTest; use DBIC::SqlMakerTest; -plan tests => 4; - my $sa = new DBIx::Class::SQLAHacks::OracleJoins; -$sa->limit_dialect('RowNum'); - -is($sa->select('rubbish', - [ 'foo.id', 'bar.id', \'TO_CHAR(foo.womble, "blah")' ], - undef, undef, 1, 3), - 'SELECT * FROM -( - SELECT A.*, ROWNUM r FROM - ( - SELECT foo.id AS col1, bar.id AS col2, TO_CHAR(foo.womble, "blah") AS col3 FROM rubbish - ) A - WHERE ROWNUM < 5 -) B -WHERE r >= 4 -', 'Munged stuff to make Oracle not explode'); - -# test WhereJoins # search with undefined or empty $cond # my ($self, $table, $fields, $where, $order, @rest) = @_; @@ -86,4 +67,5 @@ is_same_sql_bind( 'WhereJoins search with or in where clause' ); +done_testing; diff --git a/t/storage/dbi_env.t b/t/storage/dbi_env.t index f5275c3..5ef4274 100644 --- a/t/storage/dbi_env.t +++ b/t/storage/dbi_env.t @@ -70,7 +70,7 @@ $schema = DBICTest::Schema->connect("dbi::$dbname"); lives_ok { count_sheep($schema) } 'SQLite in DBI_DRIVER'; isa_ok $schema->storage, 'DBIx::Class::Storage::DBI::SQLite'; -undef $ENV{DBI_DRIVER}; +delete $ENV{DBI_DRIVER}; $ENV{DBI_DSN} = "dbi:SQLite:$dbname"; $schema = DBICTest::Schema->connect; lives_ok { count_sheep($schema) } 'SQLite in DBI_DSN';