From: Peter Rabbitson Date: Mon, 29 Jun 2009 20:21:24 +0000 (+0000) Subject: Merge 'trunk' into 'mssql_top_fixes' X-Git-Tag: v0.08108~12^2~15 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=56a6908124b046dfbf5baa4b0a6238a0a2be26e9;hp=d7c0e3201adf2d1aec502181ad95927786bc7f8d;p=dbsrgits%2FDBIx-Class.git Merge 'trunk' into 'mssql_top_fixes' r6753@Thesaurus (orig r6752): ribasushi | 2009-06-21 09:00:21 +0200 Clenaup text r6754@Thesaurus (orig r6753): ribasushi | 2009-06-21 14:37:56 +0200 make_column_dirty fix r6756@Thesaurus (orig r6755): ribasushi | 2009-06-21 23:12:40 +0200 Fix borked test r6764@Thesaurus (orig r6763): ribasushi | 2009-06-23 10:33:59 +0200 Real inheritance ordering for load_namespaces r6772@Thesaurus (orig r6771): ribasushi | 2009-06-23 16:46:18 +0200 Move tests around, add extra has_one relationship r6773@Thesaurus (orig r6772): caelum | 2009-06-23 18:36:22 +0200 add missing ' to doc r6781@Thesaurus (orig r6780): ribasushi | 2009-06-24 11:08:02 +0200 Properly name the relinfo variable r6782@Thesaurus (orig r6781): ribasushi | 2009-06-24 12:12:49 +0200 find_related fix for single-type relationships r6783@Thesaurus (orig r6782): nigel | 2009-06-24 17:28:33 +0200 r11786@hex: nigel | 2009-06-24 16:27:58 +0100 Fixed set_$rel with where restriction deleting rows outside the restriction r6784@Thesaurus (orig r6783): nigel | 2009-06-24 17:47:31 +0200 r11788@hex: nigel | 2009-06-24 16:47:04 +0100 Rework of set_$rel patch with less obfuscation r6789@Thesaurus (orig r6788): ribasushi | 2009-06-25 09:19:10 +0200 Commit test inspired by joel - it seemingly fails on Mac? r6790@Thesaurus (orig r6789): ribasushi | 2009-06-25 11:04:26 +0200 Minor cleanups r6793@Thesaurus (orig r6792): teejay | 2009-06-26 14:43:05 +0200 normalised artist_id, and plural relationships to plural names making use of alias/relname less ambiguous than relname/tablename being the same, also added a little more info on joining/relationships r6794@Thesaurus (orig r6793): tomboh | 2009-06-26 15:25:19 +0200 Documentation fix: - timezone is no longer an extra setting - fix a typo of 'subsequently' r6795@Thesaurus (orig r6794): gphat | 2009-06-26 16:33:35 +0200 Fix typo in ResultSet docs r6803@Thesaurus (orig r6802): ribasushi | 2009-06-27 12:39:03 +0200 Todoified (unsolvable) test from RT#42466 r6804@Thesaurus (orig r6803): ribasushi | 2009-06-27 12:52:26 +0200 POD patch from RT#46808 r6805@Thesaurus (orig r6804): ribasushi | 2009-06-27 13:59:03 +0200 Adjust sqlt schema parser to add tables in FK dependency order r6806@Thesaurus (orig r6805): ribasushi | 2009-06-27 14:08:35 +0200 Bump author SQLT dependency for early developer testing Regenerate SQLite schema with new parser/sqlt Use throw_exception in lieu of plain die when possible r6813@Thesaurus (orig r6812): castaway | 2009-06-28 06:11:08 +0200 Tests for grouping with prefetch r6820@Thesaurus (orig r6819): ribasushi | 2009-06-28 13:00:03 +0200 The prefetch+group_by is a complex problem - branch r6844@Thesaurus (orig r6843): abraxxa | 2009-06-29 11:02:17 +0200 fixed typo in test r6848@Thesaurus (orig r6847): ribasushi | 2009-06-29 19:09:00 +0200 Minor Ordered optimization (don't use count) --- diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index b012e03..d708d39 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -1254,6 +1254,9 @@ sub _count_subq_rs { $sub_attrs->{select} = $rsrc->storage->_subq_count_select ($rsrc, $sub_attrs); + # this is so that ordering can be thrown away in things like Top limit + $sub_attrs->{-for_count_only} = 1; + $attrs->{from} = [{ count_subq => $rsrc->resultset_class->new ($rsrc, $sub_attrs )->as_query }]; @@ -2708,8 +2711,10 @@ sub _resolved_attrs { # Although this is needed only if the order_by is not defined, it is # actually cheaper to just populate this rather than properly examining # order_by (stuf like [ {} ] and the like) - $attrs->{_virtual_order_by} = [ $self->result_source->primary_columns ]; - + my $prefix = $alias . ($source->schema->storage->sql_maker->{name_sep} || '.'); + $attrs->{_virtual_order_by} = [ + map { $prefix . $_ } ($source->primary_columns) + ]; $attrs->{collapse} ||= {}; if ( my $prefetch = delete $attrs->{prefetch} ) { diff --git a/lib/DBIx/Class/SQLAHacks.pm b/lib/DBIx/Class/SQLAHacks.pm index a454cd5..7ff05d6 100644 --- a/lib/DBIx/Class/SQLAHacks.pm +++ b/lib/DBIx/Class/SQLAHacks.pm @@ -116,37 +116,179 @@ SQL sub _Top { my ( $self, $sql, $order, $rows, $offset ) = @_; + # mangle the input sql so it can be properly aliased in the outer queries + $sql =~ s/^ \s* SELECT \s+ (.+?) \s+ (?=FROM)//ix + or croak "Unrecognizable SELECT: $sql"; + my $sql_select = $1; + my @sql_select = split (/\s*,\s*/, $sql_select); + + # we can't support subqueries (in fact MSSQL can't) - croak + if (@sql_select != @{$self->{_dbic_rs_attrs}{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 @{$self->{_dbic_rs_attrs}{select}}, + $sql_select, + )); + } + + my $name_sep = $self->name_sep || '.'; + $name_sep = "\Q$name_sep\E"; + my $col_re = qr/ ^ (?: (.+) $name_sep )? ([^$name_sep]+) $ /x; + + # construct the new select lists, rename(alias) some columns if necessary + my (@outer_select, @inner_select, %seen_names, %col_aliases, %outer_col_aliases); + + for (@{$self->{_dbic_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 $colsel_arg = $self->{_dbic_rs_attrs}{select}[$i]; + my $colsel_sql = $sql_select[$i]; + + # this may or may not work (in case of a scalarref or something) + my ($table, $orig_colname) = ( $colsel_arg =~ $col_re ); + + my $quoted_alias; + # do not attempt to understand non-scalar selects - alias numerically + if (ref $colsel_arg) { + $quoted_alias = $self->_quote ('column_' . (@inner_select + 1) ); + } + # column name seen more than once - alias it + elsif ($orig_colname && ($seen_names{$orig_colname} > 1) ) { + $quoted_alias = $self->_quote ("${table}__${orig_colname}"); + } + + # 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, + ); + } + + # 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, + ); + } + } + + my $outer_select = join (', ', @outer_select ); + my $inner_select = join (', ', @inner_select ); + + %outer_col_aliases = (%outer_col_aliases, %col_aliases); + + # deal with order croak '$order supplied to SQLAHacks limit emulators must be a hash' if (ref $order ne 'HASH'); $order = { %$order }; #copy - my $last = $rows + $offset; - - my $req_order = $self->_order_by ($order->{order_by}); + my $req_order = $order->{order_by}; + my $limit_order = + scalar $self->_order_by_chunks ($req_order) # exaime normalized version, collapses nesting + ? $req_order + : $order->{_virtual_order_by} + ; - my $limit_order = $req_order ? $order->{order_by} : $order->{_virtual_order_by}; + 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 $order->{$_} for qw/order_by _virtual_order_by/; my $grpby_having = $self->_order_by ($order); - my ( $order_by_inner, $order_by_outer ) = $self->_order_directions($limit_order); + # short circuit for counts - the ordering complexity is needless + if ($self->{_dbic_rs_attrs}{-for_count_only}) { + return "SELECT TOP $rows $inner_select $sql $grpby_having $order_by_outer"; + } - $sql =~ s/^\s*(SELECT|select)//; + # 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; + } - $sql = <<"SQL"; - SELECT * FROM - ( - SELECT TOP $rows * FROM + + my $inner_lim = $rows + $offset; + + $sql = "SELECT TOP $inner_lim $inner_select $sql $grpby_having $order_by_inner"; + + if ($offset) { + $sql = <<"SQL"; + + SELECT TOP $rows $outer_select FROM ( - SELECT TOP $last $sql $grpby_having $order_by_inner - ) AS foo + $sql + ) AS me $order_by_outer - ) AS bar - $req_order +SQL + + } + + if ($order_by_requested) { + $sql = <<"SQL"; + SELECT $outer_select FROM + ( $sql ) AS me + $order_by_requested; SQL - return $sql; + + } + + return $sql; +} + +# action at a distance to shorten Top code above +sub __record_alias { + my ($self, $register, $alias, $fqcol, $col) = @_; + + # record qualified name + $register->{$fqcol} = $alias; + $register->{$self->_quote($fqcol)} = $alias; + + return unless $col; + + # record unqialified name, undef (no adjustment) if a duplicate is found + if (exists $register->{$col}) { + $register->{$col} = undef; + } + else { + $register->{$col} = $alias; + } + + $register->{$self->_quote($col)} = $register->{$col}; } @@ -158,6 +300,10 @@ sub _find_syntax { return $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax); } +my $for_syntax = { + update => 'FOR UPDATE', + shared => 'FOR SHARE', +}; sub select { my ($self, $table, $fields, $where, $order, @rest) = @_; @@ -177,15 +323,10 @@ sub select { my ($sql, @where_bind) = $self->SUPER::select( $table, $self->_recurse_fields($fields), $where, $order, @rest ); - $sql .= - $self->{for} ? - ( - $self->{for} eq 'update' ? ' FOR UPDATE' : - $self->{for} eq 'shared' ? ' FOR SHARE' : - '' - ) : - '' - ; + if (my $for = delete $self->{_dbic_rs_attrs}{for}) { + $sql .= " $for_syntax->{$for}" if $for_syntax->{$for}; + } + return wantarray ? ($sql, @{$self->{from_bind}}, @where_bind, @{$self->{having_bind}}, @{$self->{order_bind}} ) : $sql; } diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 7998423..56dd7e2 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -3,7 +3,7 @@ package DBIx::Class::Storage::DBI; use base 'DBIx::Class::Storage'; -use strict; +use strict; use warnings; use Carp::Clan qw/^DBIx::Class/; use DBI; @@ -89,8 +89,8 @@ recognized by DBIx::Class: =item * -A single code reference which returns a connected -L optionally followed by +A single code reference which returns a connected +L optionally followed by L recognized by DBIx::Class: @@ -109,7 +109,7 @@ mixed together: %extra_attributes, }]; -This is particularly useful for L based applications, allowing the +This is particularly useful for L based applications, allowing the following config (L style): @@ -128,7 +128,7 @@ Please note that the L docs recommend that you always explicitly set C to either I<0> or I<1>. L further recommends that it be set to I<1>, and that you perform transactions via our L method. L will set it -to I<1> if you do not do explicitly set it to zero. This is the default +to I<1> if you do not do explicitly set it to zero. This is the default for most DBDs. See L for details. =head3 DBIx::Class specific connection attributes @@ -182,7 +182,7 @@ storage object. If set to a true value, this option will disable the caching of statement handles via L. -=item limit_dialect +=item limit_dialect Sets the limit dialect. This is useful for JDBC-bridge among others where the remote SQL-dialect cannot be determined by the name of the @@ -190,7 +190,7 @@ driver alone. See also L. =item quote_char -Specifies what characters to use to quote table and column names. If +Specifies what characters to use to quote table and column names. If you use this you will want to specify L as well. C expects either a single character, in which case is it @@ -202,8 +202,8 @@ SQL Server you should use C<< quote_char => [qw/[ ]/] >>. =item name_sep -This only needs to be used in conjunction with C, and is used to -specify the charecter that seperates elements (schemas, tables, columns) from +This only needs to be used in conjunction with C, and is used to +specify the charecter that seperates elements (schemas, tables, columns) from each other. In most cases this is simply a C<.>. The consequences of not supplying this value is that L @@ -594,7 +594,7 @@ sub dbh { sub _sql_maker_args { my ($self) = @_; - + return ( bindtype=>'columns', array_datatypes => 1, limit_dialect => $self->dbh, %{$self->_sql_maker_opts} ); } @@ -753,11 +753,11 @@ sub svp_begin { $self->throw_exception ("Your Storage implementation doesn't support savepoints") unless $self->can('_svp_begin'); - + push @{ $self->{savepoints} }, $name; $self->debugobj->svp_begin($name) if $self->debug; - + return $self->_svp_begin($name); } @@ -817,7 +817,7 @@ sub svp_rollback { } $self->debugobj->svp_rollback($name) if $self->debug; - + return $self->_svp_rollback($name); } @@ -955,7 +955,7 @@ sub _dbh_execute { my $sth = $self->sth($sql,$op); - my $placeholder_index = 1; + my $placeholder_index = 1; foreach my $bound (@$bind) { my $attributes = {}; @@ -1014,7 +1014,7 @@ sub insert { } ## Still not quite perfect, and EXPERIMENTAL -## Currently it is assumed that all values passed will be "normal", i.e. not +## Currently it is assumed that all values passed will be "normal", i.e. not ## scalar refs, or at least, all the same type as the first set, the statement is ## only prepped once. sub insert_bulk { @@ -1023,7 +1023,7 @@ sub insert_bulk { my $table = $source->from; @colvalues{@$cols} = (0..$#$cols); my ($sql, @bind) = $self->sql_maker->insert($table, \%colvalues); - + $self->_query_start( $sql, @bind ); my $sth = $self->sth($sql); @@ -1036,7 +1036,7 @@ sub insert_bulk { my $bind_attributes = $self->source_bind_attributes($source); ## Bind the values and execute - my $placeholder_index = 1; + my $placeholder_index = 1; foreach my $bound (@bind) { @@ -1084,7 +1084,7 @@ sub update { my $self = shift @_; my $source = shift @_; my $bind_attributes = $self->source_bind_attributes($source); - + return $self->_execute('update' => [], $source, $bind_attributes, @_); } @@ -1092,9 +1092,9 @@ sub update { sub delete { my $self = shift @_; my $source = shift @_; - + my $bind_attrs = $self->source_bind_attributes($source); - + return $self->_execute('delete' => [], $source, $bind_attrs, @_); } @@ -1193,10 +1193,10 @@ sub _select { my $self = shift; # localization is neccessary as - # 1) there is no infrastructure to pass this around (easy to do, but will wait) + # 1) there is no infrastructure to pass this around before SQLA2 # 2) _select_args sets it and _prep_for_execute consumes it my $sql_maker = $self->sql_maker; - local $sql_maker->{for}; + local $sql_maker->{_dbic_rs_attrs}; return $self->_execute($self->_select_args(@_)); } @@ -1205,10 +1205,10 @@ sub _select_args_to_query { my $self = shift; # localization is neccessary as - # 1) there is no infrastructure to pass this around (easy to do, but will wait) + # 1) there is no infrastructure to pass this around before SQLA2 # 2) _select_args sets it and _prep_for_execute consumes it my $sql_maker = $self->sql_maker; - local $sql_maker->{for}; + local $sql_maker->{_dbic_rs_attrs}; # my ($op, $bind, $ident, $bind_attrs, $select, $cond, $order, $rows, $offset) # = $self->_select_args($ident, $select, $cond, $attrs); @@ -1229,6 +1229,13 @@ sub _select_args { my ($self, $ident, $select, $where, $attrs) = @_; my $sql_maker = $self->sql_maker; + $sql_maker->{_dbic_rs_attrs} = { + %$attrs, + select => $select, + from => $ident, + where => $where, + }; + my $alias2source = $self->_resolve_ident_sources ($ident); # calculate bind_attrs before possible $ident mangling @@ -1281,26 +1288,24 @@ sub _select_args { }; - $sql_maker->{for} = delete $attrs->{for}; - return ('select', $attrs->{bind}, $ident, $bind_attrs, $select, $where, $order, @limit); } sub _adjust_select_args_for_limited_prefetch { my ($self, $from, $select, $where, $attrs) = @_; - if ($attrs->{group_by} and @{$attrs->{group_by}}) { - $self->throw_exception ('Prefetch with limit (rows/offset) is not supported on resultsets with a group_by attribute'); + if ($attrs->{group_by} && @{$attrs->{group_by}}) { + $self->throw_exception ('has_many prefetch with limit (rows/offset) is not supported on grouped resultsets'); } - $self->throw_exception ('Prefetch with limit (rows/offset) is not supported on resultsets with a custom from attribute') + $self->throw_exception ('has_many prefetch with limit (rows/offset) is not supported on resultsets with a custom from attribute') if (ref $from ne 'ARRAY'); # separate attributes my $sub_attrs = { %$attrs }; delete $attrs->{$_} for qw/where bind rows offset/; - delete $sub_attrs->{$_} for qw/for collapse select order_by/; + delete $sub_attrs->{$_} for qw/for collapse select as order_by/; my $alias = $attrs->{alias}; @@ -1464,6 +1469,33 @@ sub _resolve_ident_sources { return $alias2source; } +# 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, [map $_->[0], @{$bind}]); +sub _resolve_column_info { + my ($self, $ident, $colnames) = @_; + my $alias2src = $self->_resolve_ident_sources($ident); + + my $sep = $self->_sql_maker_opts->{name_sep} || '.'; + $sep = "\Q$sep\E"; + + my %return; + foreach my $col (@{$colnames}) { + $col =~ m/^ (?: ([^$sep]+) $sep)? (.+) $/x; + + my $alias = $1 || 'me'; + my $colname = $2; + + my $rsrc = $alias2src->{$alias}; + $return{$col} = $rsrc && { %{$rsrc->column_info($colname)}, -result_source => $rsrc }; + } + 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 @@ -1743,13 +1775,13 @@ By default, C<\%sqlt_args> will have { add_drop_table => 1, ignore_constraint_names => 1, ignore_index_names => 1 } -merged with the hash passed in. To disable any of those features, pass in a +merged with the hash passed in. To disable any of those features, pass in a hashref like the following { ignore_constraint_names => 0, # ... other options } -Note that this feature is currently EXPERIMENTAL and may not work correctly +Note that this feature is currently EXPERIMENTAL and may not work correctly across all databases, or fully handle complex relationships. WARNING: Please check all SQL files created, before applying them. @@ -1770,7 +1802,7 @@ sub create_ddl_dir { $version ||= $schema_version; $sqltargs = { - add_drop_table => 1, + add_drop_table => 1, ignore_constraint_names => 1, ignore_index_names => 1, %{$sqltargs || {}} @@ -1810,7 +1842,7 @@ sub create_ddl_dir { } print $file $output; close($file); - + next unless ($preversion); require SQL::Translator::Diff; @@ -1826,7 +1858,7 @@ sub create_ddl_dir { carp("Overwriting existing diff file - $difffile"); unlink($difffile); } - + my $source_schema; { my $t = SQL::Translator->new($sqltargs); @@ -1845,7 +1877,7 @@ sub create_ddl_dir { unless ( $source_schema->name ); } - # The "new" style of producers have sane normalization and can support + # The "new" style of producers have sane normalization and can support # diffing a SQL file against a DBIC->SQLT schema. Old style ones don't # And we have to diff parsed SQL against parsed SQL. my $dest_schema = $sqlt_schema; @@ -1866,12 +1898,12 @@ sub create_ddl_dir { $dest_schema->name( $filename ) unless $dest_schema->name; } - + my $diff = SQL::Translator::Diff::schema_diff($source_schema, $db, $dest_schema, $db, $sqltargs ); - if(!open $file, ">$difffile") { + if(!open $file, ">$difffile") { $self->throw_exception("Can't write to $difffile ($!)"); next; } @@ -1915,7 +1947,7 @@ sub deployment_statements { if(-f $filename) { my $file; - open($file, "<$filename") + open($file, "<$filename") or $self->throw_exception("Can't open $filename ($!)"); my @rows = <$file>; close($file); @@ -1930,7 +1962,7 @@ sub deployment_statements { eval qq{use SQL::Translator::Producer::${type}}; $self->throw_exception($@) if $@; - # sources needs to be a parser arg, but for simplicty allow at top level + # sources needs to be a parser arg, but for simplicty allow at top level # coming in $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources} if exists $sqltargs->{sources}; @@ -2035,7 +2067,7 @@ returned by databases that don't support replication. sub is_replicating { return; - + } =head2 lag_behind_master diff --git a/lib/DBIx/Class/Storage/DBI/AmbiguousGlob.pm b/lib/DBIx/Class/Storage/DBI/AmbiguousGlob.pm new file mode 100644 index 0000000..a7ed94b --- /dev/null +++ b/lib/DBIx/Class/Storage/DBI/AmbiguousGlob.pm @@ -0,0 +1,43 @@ +package DBIx::Class::Storage::DBI::AmbiguousGlob; + +use strict; +use warnings; + +use base 'DBIx::Class::Storage::DBI'; + +=head1 NAME + +DBIx::Class::Storage::DBI::AmbiguousGlob - Storage component for RDBMS supporting multicolumn in clauses + +=head1 DESCRIPTION + +Some servers choke on things like: + + COUNT(*) FROM (SELECT tab1.col, tab2.col FROM tab1 JOIN tab2 ... ) + +claiming that col is a duplicate column (it loses the table specifiers by +the time it gets to the *). Thus for any subquery count we select only the +primary keys of the main table in the inner query. This hopefully still +hits the indexes and keeps the server happy. + +At this point the only overriden method is C<_subq_count_select()> + +=cut + +sub _subq_count_select { + my ($self, $source, $rs_attrs) = @_; + my @pcols = map { join '.', $rs_attrs->{alias}, $_ } ($source->primary_columns); + return @pcols ? \@pcols : [ 1 ]; +} + +=head1 AUTHORS + +See L + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut + +1; diff --git a/lib/DBIx/Class/Storage/DBI/MSSQL.pm b/lib/DBIx/Class/Storage/DBI/MSSQL.pm index 40afe76..c6b9360 100644 --- a/lib/DBIx/Class/Storage/DBI/MSSQL.pm +++ b/lib/DBIx/Class/Storage/DBI/MSSQL.pm @@ -3,7 +3,7 @@ package DBIx::Class::Storage::DBI::MSSQL; use strict; use warnings; -use base qw/DBIx::Class::Storage::DBI/; +use base qw/DBIx::Class::Storage::DBI::AmbiguousGlob DBIx::Class::Storage::DBI/; sub _dbh_last_insert_id { my ($self, $dbh, $source, $col) = @_; diff --git a/lib/DBIx/Class/Storage/DBI/ODBC.pm b/lib/DBIx/Class/Storage/DBI/ODBC.pm index 09a7c6b..40d12aa 100644 --- a/lib/DBIx/Class/Storage/DBI/ODBC.pm +++ b/lib/DBIx/Class/Storage/DBI/ODBC.pm @@ -11,9 +11,11 @@ sub _rebless { unless ( $@ ) { # Translate the backend name into a perl identifier $dbtype =~ s/\W/_/gi; - my $class = "DBIx::Class::Storage::DBI::ODBC::${dbtype}"; - eval "require $class"; - bless $self, $class unless $@; + my $subclass = "DBIx::Class::Storage::DBI::ODBC::${dbtype}"; + if ($self->load_optional_class($subclass) && !$self->isa($subclass)) { + bless $self, $subclass; + $self->_rebless; + } } } diff --git a/lib/DBIx/Class/Storage/DBI/ODBC/Microsoft_SQL_Server.pm b/lib/DBIx/Class/Storage/DBI/ODBC/Microsoft_SQL_Server.pm index 3a464fd..544e68c 100644 --- a/lib/DBIx/Class/Storage/DBI/ODBC/Microsoft_SQL_Server.pm +++ b/lib/DBIx/Class/Storage/DBI/ODBC/Microsoft_SQL_Server.pm @@ -4,14 +4,61 @@ use warnings; use base qw/DBIx::Class::Storage::DBI::MSSQL/; +sub insert_bulk { + my ($self, $source, $cols, $data) = @_; + + my $identity_insert = 0; + + COLUMNS: + foreach my $col (@{$cols}) { + if ($source->column_info($col)->{is_auto_increment}) { + $identity_insert = 1; + last COLUMNS; + } + } + + my $table = $source->from; + if ($identity_insert) { + $source->storage->dbh_do(sub { + my ($storage, $dbh, @cols) = @_; + $dbh->do("SET IDENTITY_INSERT $table ON;"); + }); + } + + next::method(@_); + + if ($identity_insert) { + $source->storage->dbh_do(sub { + my ($storage, $dbh, @cols) = @_; + $dbh->do("SET IDENTITY_INSERT $table OFF;"); + }); + } + +} + sub _prep_for_execute { - my $self = shift; - my ($op, $extra_bind, $ident, $args) = @_; + my $self = shift; + my ($op, $extra_bind, $ident, $args) = @_; + + my ($sql, $bind) = $self->next::method (@_); + $sql .= ';SELECT SCOPE_IDENTITY()' if $op eq 'insert'; + + my %identity_insert_tables; + my $col_info = $self->_resolve_column_info($ident, [map $_->[0], @{$bind}]); + + foreach my $bound (@{$bind}) { + my $col = $bound->[0]; + if ($col_info->{$col}->{is_auto_increment}) { + my $table = $col_info->{$col}->{-result_source}->from; + $identity_insert_tables{$table} = 1; + } + } - my ($sql, $bind) = $self->next::method (@_); - $sql .= ';SELECT SCOPE_IDENTITY()' if $op eq 'insert'; + my $identity_insert_on = join '', map { "SET IDENTITY_INSERT $_ ON; " } keys %identity_insert_tables; + my $identity_insert_off = join '', map { "SET IDENTITY_INSERT $_ OFF; " } keys %identity_insert_tables; + $sql = "$identity_insert_on $sql $identity_insert_off"; - return ($sql, $bind); + return ($sql, $bind); } sub _execute { @@ -64,3 +111,4 @@ Marc Mims C<< >> You may distribute this code under the same terms as Perl itself. =cut +# vim: sw=2 sts=2 diff --git a/lib/DBIx/Class/Storage/DBI/mysql.pm b/lib/DBIx/Class/Storage/DBI/mysql.pm index 53b8e16..9432d0c 100644 --- a/lib/DBIx/Class/Storage/DBI/mysql.pm +++ b/lib/DBIx/Class/Storage/DBI/mysql.pm @@ -3,7 +3,11 @@ package DBIx::Class::Storage::DBI::mysql; use strict; use warnings; -use base qw/DBIx::Class::Storage::DBI::MultiColumnIn/; +use base qw/ + DBIx::Class::Storage::DBI::MultiColumnIn + DBIx::Class::Storage::DBI::AmbiguousGlob + DBIx::Class::Storage::DBI +/; __PACKAGE__->sql_maker_class('DBIx::Class::SQLAHacks::MySQL'); @@ -41,7 +45,7 @@ sub _svp_rollback { $self->dbh->do("ROLLBACK TO SAVEPOINT $name") } - + sub is_replicating { my $status = shift->dbh->selectrow_hashref('show slave status'); return ($status->{Slave_IO_Running} eq 'Yes') && ($status->{Slave_SQL_Running} eq 'Yes'); @@ -57,19 +61,6 @@ sub _subq_update_delete { return shift->_per_row_update_delete (@_); } -# MySql chokes on things like: -# COUNT(*) FROM (SELECT tab1.col, tab2.col FROM tab1 JOIN tab2 ... ) -# claiming that col is a duplicate column (it loses the table specifiers by -# the time it gets to the *). Thus for any subquery count we select only the -# primary keys of the main table in the inner query. This hopefully still -# hits the indexes and keeps mysql happy. -# (mysql does not care if the SELECT and the GROUP BY match) -sub _subq_count_select { - my ($self, $source, $rs_attrs) = @_; - my @pcols = map { join '.', $rs_attrs->{alias}, $_ } ($source->primary_columns); - return @pcols ? \@pcols : [ 1 ]; -} - 1; =head1 NAME diff --git a/t/42toplimit.t b/t/42toplimit.t index f63b74c..96c4fa8 100644 --- a/t/42toplimit.t +++ b/t/42toplimit.t @@ -14,7 +14,7 @@ my $schema = DBICTest->init_schema; delete $schema->storage->_sql_maker->{_cached_syntax}; $schema->storage->_sql_maker->limit_dialect ('Top'); -my $rs = $schema->resultset ('FourKeys')->search ({}, { rows => 1, offset => 3 }); +my $rs = $schema->resultset ('BooksInLibrary')->search ({}, { prefetch => 'owner', rows => 1, offset => 3 }); sub test_order { my $args = shift; @@ -34,7 +34,7 @@ sub test_order { ) bar $req_order )", - [], + [ [ source => 'Library' ] ], ); } @@ -122,17 +122,22 @@ plan (tests => scalar @tests + 1); test_order ($_) for @tests; is_same_sql_bind ( - $rs->search ({}, { group_by => 'bar', order_by => 'bar' })->as_query, + $rs->search ({}, { group_by => 'title', order_by => 'title' })->as_query, '( - SELECT * FROM - ( - SELECT TOP 1 * FROM - ( - SELECT TOP 4 me.foo, me.bar, me.hello, me.goodbye, me.sensors, me.read_count FROM fourkeys me GROUP BY bar ORDER BY bar ASC - ) AS foo - ORDER BY bar DESC - ) AS bar - ORDER BY bar + 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 = ? ) + GROUP BY title + ORDER BY title ASC + ) AS me + ORDER BY title DESC + ) AS me + ORDER BY title; )', - [], + [ [ source => 'Library' ] ], ); diff --git a/t/746mssql.t b/t/746mssql.t index f53d49f..bae2e7c 100644 --- a/t/746mssql.t +++ b/t/746mssql.t @@ -1,18 +1,19 @@ use strict; -use warnings; +use warnings; use Test::More; use lib qw(t/lib); use DBICTest; +use DBIC::SqlMakerTest; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSSQL_ODBC_${_}" } qw/DSN USER PASS/}; plan skip_all => 'Set $ENV{DBICTEST_MSSQL_ODBC_DSN}, _USER and _PASS to run this test' unless ($dsn && $user); -plan tests => 13; +plan tests => 25; -my $schema = DBICTest::Schema->connect($dsn, $user, $pass, {AutoCommit => 1}); +my $schema = DBICTest::Schema->connect($dsn, $user, $pass); { no warnings 'redefine'; @@ -47,7 +48,7 @@ SQL my %seen_id; # fresh $schema so we start unconnected -$schema = DBICTest::Schema->connect($dsn, $user, $pass, {AutoCommit => 1}); +$schema = DBICTest::Schema->connect($dsn, $user, $pass); # test primary key handling my $new = $schema->resultset('Artist')->create({ name => 'foo' }); @@ -73,10 +74,157 @@ $it->next; is( $it->next->name, "Artist 2", "iterator->next ok" ); is( $it->next, undef, "next past end of resultset ok" ); +$schema->storage->dbh_do (sub { + my ($storage, $dbh) = @_; + eval { $dbh->do("DROP TABLE Owners") }; + eval { $dbh->do("DROP TABLE Books") }; + $dbh->do(<<'SQL'); + + +CREATE TABLE Books ( + id INT IDENTITY (1, 1) NOT NULL, + source VARCHAR(100), + owner INT, + title VARCHAR(10), + price INT NULL +) + +CREATE TABLE Owners ( + id INT IDENTITY (1, 1) NOT NULL, + name VARCHAR(100), +) + +SQL + +}); +$schema->populate ('Owners', [ + [qw/id name /], + [qw/1 wiggle/], + [qw/2 woggle/], + [qw/3 boggle/], + [qw/4 fREW/], + [qw/5 fRIOUX/], + [qw/6 fROOH/], + [qw/7 fRUE/], + [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/], +]); + +$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/], +]); + +# +# try a prefetch on tables with identically named columns +# + +# set quote char - make sure things work while quoted +$schema->storage->_sql_maker->{quote_char} = [qw/[ ]/]; +$schema->storage->_sql_maker->{name_sep} = '.'; + +{ + # try a ->has_many direction (group_by is not possible on has_many with limit) + my $owners = $schema->resultset ('Owners')->search ({ + 'books.id' => { '!=', undef } + }, { + prefetch => 'books', + order_by => 'name', + rows => 3, # 8 results total + }); + + 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'); + + TODO: { + local $TODO = 'limit past end of resultset problem'; + 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'); + + # make sure count does not become overly complex FIXME + is_same_sql_bind ( + $owners->page(3)->count_rs->as_query, + '( + SELECT COUNT( * ) + FROM ( + SELECT TOP 3 [me].[id] + FROM [owners] [me] + LEFT JOIN [books] [books] ON [books].[owner] = [me].[id] + WHERE ( [books].[id] IS NOT NULL ) + GROUP BY [me].[id] + ORDER BY [me].[id] DESC + ) [count_subq] + )', + [], + ); + } + + # 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, + prefetch => 'owner', + order_by => 'name', + rows => 2, # 3 results total + }); + + + 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'); + + TODO: { + local $TODO = 'limit past end of resultset problem'; + 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'); + + # make sure count does not become overly complex FIXME + is_same_sql_bind ( + $books->page(2)->count_rs->as_query, + '( + SELECT COUNT( * ) + FROM ( + SELECT TOP 2 [me].[id] + FROM [books] [me] + JOIN [owners] [owner] ON [owner].[id] = [me].[owner] + WHERE ( ( ( [owner].[name] = ? OR [owner].[name] = ? ) AND [source] = ? ) ) + GROUP BY [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price], [owner].[id], [owner].[name] + ORDER BY [me].[id] DESC + ) [count_subq] + )', + [ + [ 'owner.name' => 'wiggle' ], + [ 'owner.name' => 'woggle' ], + [ 'source' => 'Library' ], + ], + ); + } + +} # clean up our mess END { my $dbh = eval { $schema->storage->_dbh }; $dbh->do('DROP TABLE artist') if $dbh; } - +# vim:sw=2 sts=2