- Storage::DBI::connected() improvements for Oracle and Sybase
- Fixed prefetch+incomplete select regression introduced in
0.08100
+ - MSSQL limit (TOP emulation) fixes and improvements
0.08107 2009-06-14 08:21:00 (UTC)
- Fix serialization regression introduced in 0.08103 (affects
$ENV{DBICTEST_PG_DSN}
? (
'Sys::SigAction' => 0,
+ 'DBD::Pg' => 2.009002,
'DateTime::Format::Pg' => 0,
) : ()
,
use strict;
use warnings;
+use MRO::Compat;
+
use vars qw($VERSION);
use base qw/DBIx::Class::Componentised Class::Accessor::Grouped/;
use DBIx::Class::StartupCheck;
-
sub mk_classdata {
shift->mk_classaccessor(@_);
}
$sub_attrs->{from}, $sub_attrs->{alias}
);
+ # this is so that ordering can be thrown away in things like Top limit
+ $sub_attrs->{-for_count_only} = 1;
+
+ my $sub_rs = $rsrc->resultset_class->new ($rsrc, $sub_attrs);
+
$attrs->{from} = [{
- count_subq => $rsrc->resultset_class->new ($rsrc, $sub_attrs )->as_query
+ -alias => 'count_subq',
+ -source_handle => $rsrc->handle,
+ count_subq => $sub_rs->as_query,
}];
# the subquery replaces this
];
}
- if ( $attrs->{order_by} ) {
+ if ( defined $attrs->{order_by} ) {
$attrs->{order_by} = (
ref( $attrs->{order_by} ) eq 'ARRAY'
? [ @{ $attrs->{order_by} } ]
- : [ $attrs->{order_by} ]
+ : [ $attrs->{order_by} || () ]
);
}
$attrs->{group_by} = [ $attrs->{group_by} ];
}
- # If the order_by is otherwise empty - we will use this for TOP limit
- # emulation and the like.
- # 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 ];
-
-
$attrs->{collapse} ||= {};
if ( my $prefetch = delete $attrs->{prefetch} ) {
$prefetch = $self->_merge_attr( {}, $prefetch );
push @{ $attrs->{select} }, @{$attrs->{prefetch_select}};
push @{ $attrs->{as} }, (map { $_->[1] } @prefetch);
- push( @{ $attrs->{order_by} }, @$prefetch_ordering );
+ push( @{$attrs->{order_by}}, @$prefetch_ordering );
$attrs->{_collapse_order_by} = \@$prefetch_ordering;
}
if ($attrs) {
$new->throw_exception("attrs must be a hashref")
unless ref($attrs) eq 'HASH';
-
+
my ($related,$inflated);
## Pretend all the rels are actual objects, unset below if not, for insert() to fix
$new->{_rel_in_storage} = 1;
}
$new->throw_exception("No such column $key on $class")
unless $class->has_column($key);
- $new->store_column($key => $attrs->{$key});
+ $new->store_column($key => $attrs->{$key});
}
$new->{_relationship_data} = $related if $related;
my $rollback_guard;
# Check if we stored uninserted relobjs here in new()
- my %related_stuff = (%{$self->{_relationship_data} || {}},
+ my %related_stuff = (%{$self->{_relationship_data} || {}},
%{$self->{_inflated_column} || {}});
if(!$self->{_rel_in_storage}) {
## PK::Auto
my @auto_pri = grep {
- !defined $self->get_column($_) ||
+ !defined $self->get_column($_) ||
ref($self->get_column($_)) eq 'SCALAR'
} $self->primary_columns;
Indicates whether the object exists as a row in the database or
not. This is set to true when L<DBIx::Class::ResultSet/find>,
L<DBIx::Class::ResultSet/create> or L<DBIx::Class::ResultSet/insert>
-are used.
+are used.
Creating a row object using L<DBIx::Class::ResultSet/new>, or calling
L</delete> on one, sets it to false.
The object is still perfectly usable, but L</in_storage> will
now return 0 and the object must be reinserted using L</insert>
-before it can be used to L</update> the row again.
+before it can be used to L</update> the row again.
If you delete an object in a class with a C<has_many> relationship, an
attempt is made to delete all the related objects as well. To turn
this behaviour off, pass C<< cascade_delete => 0 >> in the C<$attr>
hashref of the relationship, see L<DBIx::Class::Relationship>. Any
database-level cascade or restrict will take precedence over a
-DBIx-Class-based cascading delete.
+DBIx-Class-based cascading delete.
If you delete an object within a txn_do() (see L<DBIx::Class::Storage/txn_do>)
and the transaction subsequently fails, the row object will remain marked as
return $self->{_column_data}{$column} if exists $self->{_column_data}{$column};
if (exists $self->{_inflated_column}{$column}) {
return $self->store_column($column,
- $self->_deflated_column($column, $self->{_inflated_column}{$column}));
+ $self->_deflated_column($column, $self->{_inflated_column}{$column}));
}
$self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
return undef;
Throws an exception if the column does not exist.
Marks a column as having been changed regardless of whether it has
-really changed.
+really changed.
=cut
sub make_column_dirty {
$self->throw_exception( "No such column '${column}'" )
unless exists $self->{_column_data}{$column} || $self->has_column($column);
- # the entire clean/dirty code relieas on exists, not on true/false
+ # the entire clean/dirty code relies on exists, not on true/false
return 1 if exists $self->{_dirty_columns}{$column};
$self->{_dirty_columns}{$column} = 1;
$row->set_columns({ $col => $val, ... });
-=over
+=over
=item Arguments: \%columndata
=back
Sets more than one column value at once. Any inflated values are
-deflated and the raw values stored.
+deflated and the raw values stored.
Any related values passed as Row objects, using the relation name as a
key, are reduced to the appropriate foreign key values and stored. If
}
}
}
- $self->set_columns($upd);
+ $self->set_columns($upd);
}
=head2 copy
$new->set_inflated_columns($changes);
$new->insert;
- # Its possible we'll have 2 relations to the same Source. We need to make
+ # Its possible we'll have 2 relations to the same Source. We need to make
# sure we don't try to insert the same row twice esle we'll violate unique
# constraints
my $rels_copied = {};
my $rel_info = $self->result_source->relationship_info($rel);
next unless $rel_info->{attrs}{cascade_copy};
-
+
my $resolved = $self->result_source->_resolve_condition(
$rel_info->{cond}, $rel, $new
);
$copied->{$id_str} = 1;
my $rel_copy = $related->copy($resolved);
}
-
+
}
return $new;
}
my $self = shift @_;
my $attrs = shift @_;
my $resultset = $self->result_source->resultset;
-
+
if(defined $attrs) {
$resultset = $resultset->search(undef, $attrs);
}
-
+
return $resultset->find($self->{_orig_ident} || $self->ident_condition);
}
no warnings qw/redefine/;
no strict qw/refs/;
for my $f (qw/carp croak/) {
+
my $orig = \&{"SQL::Abstract::$f"};
*{"SQL::Abstract::$f"} = sub {
local $Carp::CarpLevel = 1; # even though Carp::Clan ignores this, $orig will not
- if (Carp::longmess() =~ /DBIx::Class::SQLAHacks::[\w]+\(\) called/) {
+ if (Carp::longmess() =~ /DBIx::Class::SQLAHacks::[\w]+ .+? called \s at/x) {
__PACKAGE__->can($f)->(@_);
}
else {
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 || '.';
+ my $esc_name_sep = "\Q$name_sep\E";
+ my $col_re = qr/ ^ (?: (.+) $esc_name_sep )? ([^$esc_name_sep]+) $ /x;
+
+ my $rs_alias = $self->{_dbic_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 (@{$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 = $order->{order_by};
- my $req_order = $self->_order_by ($order->{order_by});
+ # examine normalized version, collapses nesting
+ my $limit_order;
+ if (scalar $self->_order_by_chunks ($req_order)) {
+ $limit_order = $req_order;
+ }
+ else {
+ $limit_order = [ map
+ { join ('', $rs_alias, $name_sep, $_ ) }
+ ( $self->{_dbic_rs_attrs}{_source_handle}->resolve->primary_columns )
+ ];
+ }
- 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);
- delete $order->{$_} for qw/order_by _virtual_order_by/;
+ # generate the rest
+ delete $order->{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
+ ) $quoted_rs_alias
$order_by_outer
- ) AS bar
- $req_order
+SQL
+
+ }
+ if ($order_by_requested) {
+ $sql = <<"SQL";
+
+ SELECT $outer_select FROM
+ ( $sql ) $quoted_rs_alias
+ $order_by_requested
SQL
- return $sql;
+
+ }
+
+ $sql =~ s/\s*\n\s*/ /g; # parsing out multiline statements is harder than a single line
+ 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 unqualified 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};
}
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) = @_;
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;
}
--- /dev/null
+package # Hide from PAUSE
+ DBIx::Class::SQLAHacks::MSSQL;
+
+use base qw( DBIx::Class::SQLAHacks );
+use Carp::Clan qw/^DBIx::Class|^SQL::Abstract/;
+
+#
+# MSSQL is retarded wrt TOP (crappy limit) and ordering.
+# One needs to add a TOP to *all* ordered subqueries, if
+# TOP has been used in the statement at least once.
+# Do it here.
+#
+sub select {
+ my $self = shift;
+
+ my ($sql, @bind) = $self->SUPER::select (@_);
+
+ # ordering was requested and there are at least 2 SELECT/FROM pairs
+ # (thus subquery), and there is no TOP specified
+ if (
+ $sql =~ /\bSELECT\b .+? \bFROM\b .+? \bSELECT\b .+? \bFROM\b/isx
+ &&
+ $sql !~ /^ \s* SELECT \s+ TOP \s+ \d+ /xi
+ &&
+ scalar $self->_order_by_chunks ($_[3]->{order_by})
+ ) {
+ $sql =~ s/^ \s* SELECT \s/SELECT TOP 100 PERCENT /xi;
+ }
+
+ return wantarray ? ($sql, @bind) : $sql;
+}
+
+1;
use Carp::Clan qw/^DBIx::Class/;
use Scalar::Util qw/weaken/;
use File::Spec;
-use MRO::Compat;
use Sub::Name ();
-require Module::Find;
+use Module::Find();
use base qw/DBIx::Class/;
use warnings;
use base qw/DBIx::Class/;
+use mro 'c3';
use Scalar::Util qw/weaken/;
use Carp::Clan qw/^DBIx::Class/;
package DBIx::Class::Storage::DBI;
# -*- mode: cperl; cperl-indent-level: 2 -*-
+use strict;
+use warnings;
+
use base 'DBIx::Class::Storage';
+use mro 'c3';
-use strict;
-use warnings;
use Carp::Clan qw/^DBIx::Class/;
use DBI;
use DBIx::Class::Storage::DBI::Cursor;
=item *
-A single code reference which returns a connected
-L<DBI database handle|DBI/connect> optionally followed by
+A single code reference which returns a connected
+L<DBI database handle|DBI/connect> optionally followed by
L<extra attributes|/DBIx::Class specific connection attributes> recognized
by DBIx::Class:
%extra_attributes,
}];
-This is particularly useful for L<Catalyst> based applications, allowing the
+This is particularly useful for L<Catalyst> based applications, allowing the
following config (L<Config::General> style):
<Model::DB>
set C<AutoCommit> to either I<0> or I<1>. L<DBIx::Class> further
recommends that it be set to I<1>, and that you perform transactions
via our L<DBIx::Class::Schema/txn_do> method. L<DBIx::Class> 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</DBIx::Class and AutoCommit> for details.
=head3 DBIx::Class specific connection attributes
If set to a true value, this option will disable the caching of
statement handles via L<DBI/prepare_cached>.
-=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
=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</name_sep> as well.
C<quote_char> expects either a single character, in which case is it
=item name_sep
-This only needs to be used in conjunction with C<quote_char>, and is used to
-specify the charecter that seperates elements (schemas, tables, columns) from
+This only needs to be used in conjunction with C<quote_char>, 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<SQL::Abstract>
($driver) = $self->_dbi_connect_info->[0] =~ /dbi:([^:]+):/i;
}
- if ($self->load_optional_class("DBIx::Class::Storage::DBI::${driver}")) {
- bless $self, "DBIx::Class::Storage::DBI::${driver}";
+ my $storage_class = "DBIx::Class::Storage::DBI::${driver}";
+ if ($self->load_optional_class($storage_class)) {
+ mro::set_mro($storage_class, 'c3');
+ bless $self, $storage_class;
$self->_rebless();
}
}
$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);
}
}
$self->debugobj->svp_rollback($name) if $self->debug;
-
+
return $self->_svp_rollback($name);
}
my $sth = $self->sth($sql,$op);
- my $placeholder_index = 1;
+ my $placeholder_index = 1;
foreach my $bound (@$bind) {
my $attributes = {};
}
## 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 {
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);
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) {
my $self = shift @_;
my $source = shift @_;
my $bind_attributes = $self->source_bind_attributes($source);
-
+
return $self->_execute('update' => [], $source, $bind_attributes, @_);
}
sub delete {
my $self = shift @_;
my $source = shift @_;
-
+
my $bind_attrs = $self->source_bind_attributes($source);
-
+
return $self->_execute('delete' => [], $source, $bind_attrs, @_);
}
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(@_));
}
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);
sub _select_args {
my ($self, $ident, $select, $where, $attrs) = @_;
+ my ($alias2source, $rs_alias) = $self->_resolve_ident_sources ($ident);
+
my $sql_maker = $self->sql_maker;
- my $alias2source = $self->_resolve_ident_sources ($ident);
+ $sql_maker->{_dbic_rs_attrs} = {
+ %$attrs,
+ select => $select,
+ from => $ident,
+ where => $where,
+ $rs_alias
+ ? ( _source_handle => $alias2source->{$rs_alias}->handle )
+ : ()
+ ,
+ };
# calculate bind_attrs before possible $ident mangling
my $bind_attrs = {};
$bind_attrs->{$fqcn} = $bindtypes->{$col} if $bindtypes->{$col};
# so that unqualified searches can be bound too
- $bind_attrs->{$col} = $bind_attrs->{$fqcn} if $alias eq 'me';
+ $bind_attrs->{$col} = $bind_attrs->{$fqcn} if $alias eq $rs_alias;
}
}
my $order = { map
{ $attrs->{$_} ? ( $_ => $attrs->{$_} ) : () }
- (qw/order_by group_by having _virtual_order_by/ )
+ (qw/order_by group_by having/ )
};
- $sql_maker->{for} = delete $attrs->{for};
-
return ('select', $attrs->{bind}, $ident, $bind_attrs, $select, $where, $order, @limit);
}
+#
+# This is the code producing joined subqueries like:
+# SELECT me.*, other.* FROM ( SELECT me.* FROM ... ) JOIN other ON ...
+#
sub _adjust_select_args_for_complex_prefetch {
my ($self, $from, $select, $where, $attrs) = @_;
+ $self->throw_exception ('Complex prefetches are not supported on resultsets with a custom from attribute')
+ if (ref $from ne 'ARRAY');
+
# copies for mangling
$from = [ @$from ];
$select = [ @$select ];
$attrs = { %$attrs };
- $self->throw_exception ('Complex prefetches are 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 group_by having/;
delete $sub_attrs->{$_} for qw/for collapse prefetch_select _collapse_order_by select as/;
my $alias = $attrs->{alias};
+ my $sql_maker = $self->sql_maker;
# create subquery select list - loop only over primary columns
my $sub_select = [];
}
# mangle {from}
- my $select_root = shift @$from;
+ my $join_root = shift @$from;
my @outer_from = @$from;
my %inner_joins;
# so always include it in the inner join, and also shift away
# from the outer stack, so that the two datasets actually do
# meet
- if ($select_root->{-alias} ne $alias) {
+ if ($join_root->{-alias} ne $alias) {
$inner_joins{$alias} = 1;
while (@outer_from && $outer_from[0][0]{-alias} ne $alias) {
# It may not be very efficient, but it's a reasonable stop-gap
{
# produce stuff unquoted, so it can be scanned
- my $sql_maker = $self->sql_maker;
local $sql_maker->{quote_char};
my @order_by = (map
}
# construct the inner $from for the subquery
- my $inner_from = [ $select_root ];
+ my $inner_from = [ $join_root ];
for my $j (@$from) {
push @$inner_from, $j if $inner_joins{$j->[0]{-alias}};
}
# if a multi-type join was needed in the subquery ("multi" is indicated by
# presence in {collapse}) - add a group_by to simulate the collapse in the subq
-
for my $alias (keys %inner_joins) {
# the dot comes from some weirdness in collapse
);
# put it in the new {from}
- unshift @outer_from, { $alias => $subq };
+ unshift @outer_from, {
+ -alias => $alias,
+ -source_handle => $join_root->{-source_handle},
+ $alias => $subq,
+ };
# This is totally horrific - the $where ends up in both the inner and outer query
- # Unfortunately not much can be done until SQLA2 introspection arrives
+ # Unfortunately not much can be done until SQLA2 introspection arrives, and even
+ # then if where conditions apply to the *right* side of the prefetch, you may have
+ # to both filter the inner select (e.g. to apply a limit) and then have to re-filter
+ # the outer select to exclude joins you didin't want in the first place
#
# OTOH it can be seen as a plus: <ash> (notes that this query would make a DBA cry ;)
return (\@outer_from, $select, $where, $attrs);
my ($self, $ident) = @_;
my $alias2source = {};
+ my $rs_alias;
# the reason this is so contrived is that $ident may be a {from}
# structure, specifying multiple tables to join
if ( Scalar::Util::blessed($ident) && $ident->isa("DBIx::Class::ResultSource") ) {
# this is compat mode for insert/update/delete which do not deal with aliases
$alias2source->{me} = $ident;
+ $rs_alias = 'me';
}
elsif (ref $ident eq 'ARRAY') {
my $tabinfo;
if (ref $_ eq 'HASH') {
$tabinfo = $_;
+ $rs_alias = $tabinfo->{-alias};
}
if (ref $_ eq 'ARRAY' and ref $_->[0] eq 'HASH') {
$tabinfo = $_->[0];
}
}
- return $alias2source;
+ return ($alias2source, $rs_alias);
+}
+
+# Takes $ident, \@column_names
+#
+# returns { $column_name => \%column_info, ... }
+# also note: this adds -result_source => $rsrc to the column info
+#
+# usage:
+# my $col_sources = $self->_resolve_column_info($ident, [map $_->[0], @{$bind}]);
+sub _resolve_column_info {
+ my ($self, $ident, $colnames) = @_;
+ my ($alias2src, $root_alias) = $self->_resolve_ident_sources($ident);
+
+ my $sep = $self->_sql_maker_opts->{name_sep} || '.';
+ $sep = "\Q$sep\E";
+
+ my (%return, %converted);
+ foreach my $col (@$colnames) {
+ my ($alias, $colname) = $col =~ m/^ (?: ([^$sep]+) $sep)? (.+) $/x;
+
+ # deal with unqualified cols - we assume the main alias for all
+ # unqualified ones, ugly but can't think of anything better right now
+ $alias ||= $root_alias;
+
+ my $rsrc = $alias2src->{$alias};
+ $return{$col} = $rsrc && { %{$rsrc->column_info($colname)}, -result_source => $rsrc };
+ }
+ return \%return;
}
# Returns a counting SELECT for a simple count
{ 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.
$version ||= $schema_version;
$sqltargs = {
- add_drop_table => 1,
+ add_drop_table => 1,
ignore_constraint_names => 1,
ignore_index_names => 1,
%{$sqltargs || {}}
}
print $file $output;
close($file);
-
+
next unless ($preversion);
require SQL::Translator::Diff;
carp("Overwriting existing diff file - $difffile");
unlink($difffile);
}
-
+
my $source_schema;
{
my $t = SQL::Translator->new($sqltargs);
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;
$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;
}
if(-f $filename)
{
my $file;
- open($file, "<$filename")
+ open($file, "<$filename")
or $self->throw_exception("Can't open $filename ($!)");
my @rows = <$file>;
close($file);
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};
sub is_replicating {
return;
-
+
}
=head2 lag_behind_master
--- /dev/null
+package DBIx::Class::Storage::DBI::AmbiguousGlob;
+
+use strict;
+use warnings;
+
+use base 'DBIx::Class::Storage::DBI';
+use mro 'c3';
+
+=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<DBIx::Class/CONTRIBUTORS>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+1;
package DBIx::Class::Storage::DBI::Cursor;
-use base qw/DBIx::Class::Cursor/;
-
use strict;
use warnings;
+use base qw/DBIx::Class::Cursor/;
+
=head1 NAME
DBIx::Class::Storage::DBI::Cursor - Object representing a query cursor on a
use warnings;
use base qw/DBIx::Class::Storage::DBI/;
-
-# __PACKAGE__->load_components(qw/PK::Auto/);
+use mro 'c3';
sub _dbh_last_insert_id {
my ($self, $dbh, $source, $col) = @_;
use strict;
use warnings;
-use base qw/DBIx::Class::Storage::DBI/;
+use base qw/DBIx::Class::Storage::DBI::AmbiguousGlob DBIx::Class::Storage::DBI/;
+use mro 'c3';
+
+__PACKAGE__->sql_maker_class('DBIx::Class::SQLAHacks::MSSQL');
sub _dbh_last_insert_id {
my ($self, $dbh, $source, $col) = @_;
use warnings;
use base 'DBIx::Class::Storage::DBI';
+use mro 'c3';
=head1 NAME
use warnings;
use base 'DBIx::Class::Storage::DBI';
+use mro 'c3';
=head1 NAME
use warnings;
use base qw/DBIx::Class::Storage::DBI/;
+use mro 'c3';
sub _rebless {
my ($self) = @_;
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;
+ }
}
}
use strict;
use warnings;
-use DBI;
use base qw/DBIx::Class::Storage::DBI/;
+use mro 'c3';
+
+use DBI;
my $ERR_MSG_START = __PACKAGE__ . ' failed: ';
use warnings;
use base qw/DBIx::Class::Storage::DBI::ODBC/;
+use mro 'c3';
sub _dbh_last_insert_id {
my ($self, $dbh, $source, $col) = @_;
use warnings;
use base qw/DBIx::Class::Storage::DBI::MSSQL/;
+use mro 'c3';
+
+use List::Util();
+
+sub insert_bulk {
+ my $self = shift;
+ my ($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;
+ }
+ }
+
+ if ($identity_insert) {
+ my $table = $source->from;
+ $self->dbh->do("SET IDENTITY_INSERT $table ON");
+ }
+
+ $self->next::method(@_);
+
+ if ($identity_insert) {
+ my $table = $source->from;
+ $self->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 (@_);
- my ($sql, $bind) = $self->next::method (@_);
- $sql .= ';SELECT SCOPE_IDENTITY()' if $op eq 'insert';
+ if ($op eq 'insert') {
+ $sql .= ';SELECT SCOPE_IDENTITY()';
+
+ my $col_info = $self->_resolve_column_info($ident, [map $_->[0], @{$bind}]);
+ if (List::Util::first { $_->{is_auto_increment} } (values %$col_info) ) {
+
+ my $table = $ident->from;
+ my $identity_insert_on = "SET IDENTITY_INSERT $table ON";
+ my $identity_insert_off = "SET IDENTITY_INSERT $table OFF";
+ $sql = "$identity_insert_on; $sql; $identity_insert_off";
+ }
+ }
- return ($sql, $bind);
+ return ($sql, $bind);
}
sub _execute {
You may distribute this code under the same terms as Perl itself.
=cut
+# vim: sw=2 sts=2
use warnings;
use base qw/DBIx::Class::Storage::DBI/;
+use mro 'c3';
sub _rebless {
my ($self) = @_;
=cut
use base qw/DBIx::Class::Storage::DBI/;
-use Carp::Clan qw/^DBIx::Class/;
+use mro 'c3';
# For ORA_BLOB => 113, ORA_CLOB => 112
use DBD::Oracle qw( :ora_types );
package DBIx::Class::Storage::DBI::Oracle::WhereJoins;
-use base qw( DBIx::Class::Storage::DBI::Oracle::Generic );
-
use strict;
use warnings;
+use base qw( DBIx::Class::Storage::DBI::Oracle::Generic );
+use mro 'c3';
+
__PACKAGE__->sql_maker_class('DBIx::Class::SQLAHacks::OracleJoins');
1;
use strict;
use warnings;
-use DBD::Pg qw(:pg_types);
-
use base qw/DBIx::Class::Storage::DBI::MultiColumnIn/;
+use mro 'c3';
-# __PACKAGE__->load_components(qw/PK::Auto/);
+use DBD::Pg qw(:pg_types);
-# Warn about problematic versions of DBD::Pg
-warn "DBD::Pg 1.49 is strongly recommended"
- if ($DBD::Pg::VERSION < 1.49);
+# Ask for a DBD::Pg with array support
+warn "DBD::Pg 2.9.2 or greater is strongly recommended"
+ if ($DBD::Pg::VERSION < 2.009002); # pg uses (used?) version::qv()
sub with_deferred_fk_checks {
my ($self, $sub) = @_;
use strict;
use warnings;
+
+use base qw/DBIx::Class::Storage::DBI/;
+use mro 'c3';
+
use POSIX 'strftime';
use File::Copy;
use File::Spec;
-use base qw/DBIx::Class::Storage::DBI/;
-
sub _dbh_last_insert_id {
my ($self, $dbh, $source, $col) = @_;
$dbh->func('last_insert_rowid');
use strict;
use warnings;
-use mro 'c3';
+
use base qw/
DBIx::Class::Storage::DBI::Sybase::Base
DBIx::Class::Storage::DBI::NoBindVars
/;
+use mro 'c3';
sub _rebless {
my $self = shift;
use strict;
use warnings;
+use base qw/DBIx::Class::Storage::DBI/;
+use mro 'c3';
+
=head1 NAME
DBIx::Class::Storage::DBI::Sybase::Base - Common functionality for drivers using
use base qw/DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server/;
+use mro 'c3';
1;
use strict;
use warnings;
-use mro 'c3';
+
use base qw/
DBIx::Class::Storage::DBI::Sybase::Base
DBIx::Class::Storage::DBI::ODBC::Microsoft_SQL_Server
/;
+use mro 'c3';
1;
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
+/;
+use mro 'c3';
__PACKAGE__->sql_maker_class('DBIx::Class::SQLAHacks::MySQL');
$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');
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
'DBIx::Class::Storage::DBI::SQLite' => { skip => 1 },
'DBIx::Class::Storage::DBI::mysql' => { skip => 1 },
'DBIx::Class::SQLAHacks::MySQL' => { skip => 1 },
+ 'DBIx::Class::SQLAHacks::MSSQL' => { skip => 1 },
'SQL::Translator::Parser::DBIx::Class' => { skip => 1 },
'SQL::Translator::Producer::DBIx::Class::File' => { skip => 1 },
# Trick the sqlite DB to use Top limit emulation
# We could test all of this via $sq->$op directly,
-# but some conditions needs a $rsrc
+# but some conditions need a $rsrc
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 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;
is_same_sql_bind(
$rs->search ({}, {order_by => $args->{order_by}})->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 ORDER BY $args->{order_inner}
- ) foo ORDER BY $args->{order_outer}
- ) bar
- $req_order
+ "(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
)",
- [],
+ [ [ source => 'Library' ] ],
);
}
my @tests = (
{
- order_by => \ 'foo DESC',
+ order_by => \'foo DESC',
order_req => 'foo DESC',
order_inner => 'foo DESC',
- order_outer => 'foo ASC'
+ order_outer => 'foo ASC'
},
{
order_by => { -asc => 'foo' },
order_inner => 'foo ASC, bar DESC, hello ASC, sensors ASC',
order_outer => 'foo DESC, bar ASC, hello DESC, sensors DESC',
},
- {
- order_by => undef,
- order_req => undef,
- order_inner => 'foo ASC, bar ASC, hello ASC, goodbye ASC',
- order_outer => 'foo DESC, bar DESC, hello DESC, goodbye DESC',
- },
- {
- order_by => '',
- order_req => undef,
- order_inner => 'foo ASC, bar ASC, hello ASC, goodbye ASC',
- order_outer => 'foo DESC, bar DESC, hello DESC, goodbye DESC',
- },
- {
- order_by => {},
- order_req => undef,
- order_inner => 'foo ASC, bar ASC, hello ASC, goodbye ASC',
- order_outer => 'foo DESC, bar DESC, hello DESC, goodbye DESC',
- },
- {
- order_by => [],
- order_req => undef,
- order_inner => 'foo ASC, bar ASC, hello ASC, goodbye ASC',
- order_outer => 'foo DESC, bar DESC, hello DESC, goodbye DESC',
- },
);
-plan (tests => scalar @tests + 1);
+my @default_tests = ( undef, '', {}, [] );
+
+plan (tests => scalar @tests + scalar @default_tests + 1);
test_order ($_) for @tests;
+default_test_order ($_) for @default_tests;
+
is_same_sql_bind (
- $rs->search ({}, { group_by => 'bar', order_by => 'bar' })->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
- )',
- [],
+ $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
+ ) me
+ ORDER BY title
+ ) me JOIN
+ owners owner ON owner.id = me.owner WHERE
+ ( source = ? )
+ ORDER BY title)' ,
+ [ [ source => 'Library' ], [ source => 'Library' ] ],
);
is_deeply($type_info, $test_type_info,
'columns_info_for - column data types');
-{
+SKIP: {
+ skip "Need DBD::Pg 2.9.2 or newer for array tests", 4 if $DBD::Pg::VERSION < 2.009002;
+
lives_ok {
$schema->resultset('ArrayTest')->create({
arrayfield => [1, 2],
use strict;
-use warnings;
+use warnings;
use Test::More;
+use Test::Exception;
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 => 27;
-my $schema = DBICTest::Schema->connect($dsn, $user, $pass, {AutoCommit => 1});
+my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
{
no warnings 'redefine';
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' });
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
+
+});
+
+lives_ok ( sub {
+ $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/],
+ ]);
+}, 'populate with PKs supplied ok' );
+
+lives_ok ( sub {
+ $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' );
+
+#
+# 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
+ 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',
+ rows => 2, # 3 results total
+ order_by => { -desc => 'owner' },
+ # there is no sane way to order by the right side of a grouped prefetch currently :(
+ #order_by => { -desc => 'owner.name' },
+ });
+
+
+ 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
use Test::More;
-BEGIN {
- eval "use SQL::Abstract 1.49";
- plan $@
- ? ( skip_all => "Needs SQLA 1.49+" )
- : ( tests => 8 );
-}
-
use lib qw(t/lib);
use DBICTest;
use DBIC::SqlMakerTest;
+plan tests => 8;
+
my $schema = DBICTest->init_schema();
my $art_rs = $schema->resultset('Artist');
my $cdrs = $schema->resultset('CD');