use warnings;
use base qw/DBIx::Class/;
use DBIx::Class::Carp;
-use DBIx::Class::Exception;
use DBIx::Class::ResultSetColumn;
-use Scalar::Util qw/blessed weaken/;
+use Scalar::Util qw/blessed weaken reftype/;
use Try::Tiny;
use Data::Compare (); # no imports!!! guard against insane architecture
'bool' => "_bool",
fallback => 1;
+# this is real - CDBICompat overrides it with insanity
+# yes, prototype won't matter, but that's for now ;)
+sub _bool () { 1 }
+
__PACKAGE__->mk_group_accessors('simple' => qw/_result_class result_source/);
=head1 NAME
my $cache;
my %safe = (alias => 1, cache => 1);
if ( ! List::Util::first { !$safe{$_} } keys %$call_attrs and (
- ! defined $_[0]
+ ! defined $call_cond
or
- ref $_[0] eq 'HASH' && ! keys %{$_[0]}
+ ref $call_cond eq 'HASH' && ! keys %$call_cond
or
- ref $_[0] eq 'ARRAY' && ! @{$_[0]}
+ ref $call_cond eq 'ARRAY' && ! @$call_cond
)) {
$cache = $self->get_cache;
}
# older deprecated name, use only if {columns} is not there
if (my $c = delete $new_attrs->{cols}) {
+ carp_unique( "Resultset attribute 'cols' is deprecated, use 'columns' instead" );
if ($new_attrs->{columns}) {
carp "Resultset specifies both the 'columns' and the legacy 'cols' attributes - ignoring 'cols'";
}
my ($self, $attrs) = @_;
# legacy syntax
- $attrs->{'+columns'} = $self->_merge_attr($attrs->{'+columns'}, delete $attrs->{include_columns})
- if exists $attrs->{include_columns};
+ if ( exists $attrs->{include_columns} ) {
+ carp_unique( "Resultset attribute 'include_columns' is deprecated, use '+columns' instead" );
+ $attrs->{'+columns'} = $self->_merge_attr(
+ $attrs->{'+columns'}, delete $attrs->{include_columns}
+ );
+ }
# columns are always placed first, however
my ($lquote, $rquote, $sep) = map { quotemeta $_ } ($sql_maker->_quote_chars, $sql_maker->name_sep);
- my $sql = $sql_maker->_parse_rs_attrs ({ having => $attrs->{having} });
+ my $having_sql = $sql_maker->_parse_rs_attrs ({ having => $attrs->{having} });
+ my %seen_having;
# search for both a proper quoted qualified string, for a naive unquoted scalarref
# and if all fails for an utterly naive quoted scalar-with-function
- while ($sql =~ /
+ while ($having_sql =~ /
$rquote $sep $lquote (.+?) $rquote
|
[\s,] \w+ \. (\w+) [\s,]
|
[\s,] $lquote (.+?) $rquote [\s,]
/gx) {
- push @parts, ($1 || $2 || $3); # one of them matched if we got here
+ my $part = $1 || $2 || $3; # one of them matched if we got here
+ unless ($seen_having{$part}++) {
+ push @parts, $part;
+ }
}
}
->get_column ('count');
}
-sub _bool {
- return 1;
-}
=head2 count_literal
sub _rs_update_delete {
my ($self, $op, $values) = @_;
- my $cond = $self->{cond};
my $rsrc = $self->result_source;
my $storage = $rsrc->schema->storage;
my $attrs = { %{$self->_resolved_attrs} };
+ my $join_classifications;
my $existing_group_by = delete $attrs->{group_by};
- my $needs_subq = defined $existing_group_by;
- # simplify the joinmap and maybe decide if a subquery is necessary
- my $relation_classifications = {};
+ # do we need a subquery for any reason?
+ my $needs_subq = (
+ defined $existing_group_by
+ or
+ # if {from} is unparseable wrap a subq
+ ref($attrs->{from}) ne 'ARRAY'
+ or
+ # limits call for a subq
+ $self->_has_resolved_attr(qw/rows offset/)
+ );
- if (ref($attrs->{from}) eq 'ARRAY') {
- # if we already know we need a subq, no point of classifying relations
- if (!$needs_subq and @{$attrs->{from}} > 1) {
- $attrs->{from} = $storage->_prune_unused_joins ($attrs->{from}, $attrs->{select}, $cond, $attrs);
+ # simplify the joinmap, so we can further decide if a subq is necessary
+ if (!$needs_subq and @{$attrs->{from}} > 1) {
+ $attrs->{from} = $storage->_prune_unused_joins ($attrs->{from}, $attrs->{select}, $self->{cond}, $attrs);
- $relation_classifications = $storage->_resolve_aliastypes_from_select_args (
+ # check if there are any joins left after the prune
+ if ( @{$attrs->{from}} > 1 ) {
+ $join_classifications = $storage->_resolve_aliastypes_from_select_args (
[ @{$attrs->{from}}[1 .. $#{$attrs->{from}}] ],
$attrs->{select},
- $cond,
+ $self->{cond},
$attrs
);
+
+ # any non-pruneable joins imply subq
+ $needs_subq = scalar keys %{ $join_classifications->{restricting} || {} };
}
}
- else {
- $needs_subq ||= 1; # if {from} is unparseable assume the worst
- }
+ # check if the head is composite (by now all joins are thrown out unless $needs_subq)
+ $needs_subq ||= (
+ (ref $attrs->{from}[0]) ne 'HASH'
+ or
+ ref $attrs->{from}[0]{ $attrs->{from}[0]{-alias} }
+ );
+
+ my ($cond, $guard);
# do we need anything like a subquery?
- if (
- ! $needs_subq
- and
- ! keys %{ $relation_classifications->{restricting} || {} }
- and
- ! $self->_has_resolved_attr(qw/rows offset/) # limits call for a subq
- ) {
+ if (! $needs_subq) {
# Most databases do not allow aliasing of tables in UPDATE/DELETE. Thus
# a condition containing 'me' or other table prefixes will not work
# at all. Tell SQLMaker to dequalify idents via a gross hack.
- my $cond = do {
+ $cond = do {
my $sqla = $rsrc->storage->sql_maker;
local $sqla->{_dequalify_idents} = 1;
\[ $sqla->_recurse_where($self->{cond}) ];
};
- return $rsrc->storage->$op(
- $rsrc,
- $op eq 'update' ? $values : (),
- $cond,
- );
- }
-
- # we got this far - means it is time to wrap a subquery
- my $idcols = $rsrc->_identifying_column_set || $self->throw_exception(
- sprintf(
- "Unable to perform complex resultset %s() without an identifying set of columns on source '%s'",
- $op,
- $rsrc->source_name,
- )
- );
-
- # make a new $rs selecting only the PKs (that's all we really need for the subq)
- delete $attrs->{$_} for qw/collapse _collapse_order_by select _prefetch_selector_range as/;
- $attrs->{columns} = [ map { "$attrs->{alias}.$_" } @$idcols ];
- $attrs->{group_by} = \ ''; # FIXME - this is an evil hack, it causes the optimiser to kick in and throw away the LEFT joins
- my $subrs = (ref $self)->new($rsrc, $attrs);
-
- if (@$idcols == 1) {
- return $storage->$op (
- $rsrc,
- $op eq 'update' ? $values : (),
- { $idcols->[0] => { -in => $subrs->as_query } },
- );
}
- elsif ($storage->_use_multicolumn_in) {
- # This is hideously ugly, but SQLA does not understand multicol IN expressions
- my $sql_maker = $storage->sql_maker;
- my ($sql, @bind) = @${$subrs->as_query};
- $sql = sprintf ('(%s) IN %s', # the as_query already comes with a set of parenthesis
- join (', ', map { $sql_maker->_quote ($_) } @$idcols),
- $sql,
+ else {
+ # we got this far - means it is time to wrap a subquery
+ my $idcols = $rsrc->_identifying_column_set || $self->throw_exception(
+ sprintf(
+ "Unable to perform complex resultset %s() without an identifying set of columns on source '%s'",
+ $op,
+ $rsrc->source_name,
+ )
);
- return $storage->$op (
- $rsrc,
- $op eq 'update' ? $values : (),
- \[$sql, @bind],
- );
- }
- else {
+ # make a new $rs selecting only the PKs (that's all we really need for the subq)
+ delete $attrs->{$_} for qw/collapse _collapse_order_by select _prefetch_selector_range as/;
+ $attrs->{columns} = [ map { "$attrs->{alias}.$_" } @$idcols ];
+ $attrs->{group_by} = \ ''; # FIXME - this is an evil hack, it causes the optimiser to kick in and throw away the LEFT joins
+ my $subrs = (ref $self)->new($rsrc, $attrs);
- # if all else fails - get all primary keys and operate over a ORed set
- # wrap in a transaction for consistency
- # this is where the group_by starts to matter
- if (
- $existing_group_by
- or
- keys %{ $relation_classifications->{multiplying} || {} }
- ) {
- # make sure if there is a supplied group_by it matches the columns compiled above
- # perfectly. Anything else can not be sanely executed on most databases so croak
- # right then and there
- if ($existing_group_by) {
- my @current_group_by = map
- { $_ =~ /\./ ? $_ : "$attrs->{alias}.$_" }
- @$existing_group_by
- ;
-
- if (
- join ("\x00", sort @current_group_by)
- ne
- join ("\x00", sort @{$attrs->{columns}} )
- ) {
- $self->throw_exception (
- "You have just attempted a $op operation on a resultset which does group_by"
- . ' on columns other than the primary keys, while DBIC internally needs to retrieve'
- . ' the primary keys in a subselect. All sane RDBMS engines do not support this'
- . ' kind of queries. Please retry the operation with a modified group_by or'
- . ' without using one at all.'
- );
+ if (@$idcols == 1) {
+ $cond = { $idcols->[0] => { -in => $subrs->as_query } };
+ }
+ elsif ($storage->_use_multicolumn_in) {
+ # no syntax for calling this properly yet
+ # !!! EXPERIMENTAL API !!! WILL CHANGE !!!
+ $cond = $storage->sql_maker->_where_op_multicolumn_in (
+ $idcols, # how do I convey a list of idents...? can binds reside on lhs?
+ $subrs->as_query
+ ),
+ }
+ else {
+ # if all else fails - get all primary keys and operate over a ORed set
+ # wrap in a transaction for consistency
+ # this is where the group_by/multiplication starts to matter
+ if (
+ $existing_group_by
+ or
+ keys %{ $join_classifications->{multiplying} || {} }
+ ) {
+ # make sure if there is a supplied group_by it matches the columns compiled above
+ # perfectly. Anything else can not be sanely executed on most databases so croak
+ # right then and there
+ if ($existing_group_by) {
+ my @current_group_by = map
+ { $_ =~ /\./ ? $_ : "$attrs->{alias}.$_" }
+ @$existing_group_by
+ ;
+
+ if (
+ join ("\x00", sort @current_group_by)
+ ne
+ join ("\x00", sort @{$attrs->{columns}} )
+ ) {
+ $self->throw_exception (
+ "You have just attempted a $op operation on a resultset which does group_by"
+ . ' on columns other than the primary keys, while DBIC internally needs to retrieve'
+ . ' the primary keys in a subselect. All sane RDBMS engines do not support this'
+ . ' kind of queries. Please retry the operation with a modified group_by or'
+ . ' without using one at all.'
+ );
+ }
}
- }
- $subrs = $subrs->search({}, { group_by => $attrs->{columns} });
- }
+ $subrs = $subrs->search({}, { group_by => $attrs->{columns} });
+ }
- my $guard = $storage->txn_scope_guard;
+ $guard = $storage->txn_scope_guard;
- my @op_condition;
- for my $row ($subrs->cursor->all) {
- push @op_condition, { map
- { $idcols->[$_] => $row->[$_] }
- (0 .. $#$idcols)
- };
+ $cond = [];
+ for my $row ($subrs->cursor->all) {
+ push @$cond, { map
+ { $idcols->[$_] => $row->[$_] }
+ (0 .. $#$idcols)
+ };
+ }
}
+ }
- my $res = $storage->$op (
- $rsrc,
- $op eq 'update' ? $values : (),
- \@op_condition,
- );
+ my $res = $storage->$op (
+ $rsrc,
+ $op eq 'update' ? $values : (),
+ $cond,
+ );
- $guard->commit;
+ $guard->commit if $guard;
- return $res;
- }
+ return $res;
}
=head2 update
my ($merged_cond, $cols_from_relations) = $self->_merge_with_rscond($values);
- my %new = (
+ my $new = $self->result_class->new({
%$merged_cond,
- @$cols_from_relations
+ ( @$cols_from_relations
? (-cols_from_relations => $cols_from_relations)
- : (),
+ : ()
+ ),
-result_source => $self->result_source, # DO NOT REMOVE THIS, REQUIRED
- );
+ });
+
+ if (
+ reftype($new) eq 'HASH'
+ and
+ ! keys %$new
+ and
+ blessed($new)
+ ) {
+ carp_unique (sprintf (
+ "%s->new returned a blessed empty hashref - a strong indicator something is wrong with its inheritance chain",
+ $self->result_class,
+ ));
+ }
- return $self->result_class->new(\%new);
+ $new;
}
# _merge_with_rscond
expression). Adds C<me.> onto the start of any column without a C<.> in
it and sets C<select> from that, then auto-populates C<as> from
C<select> as normal. (You may also use the C<cols> attribute, as in
-earlier versions of DBIC.)
+earlier versions of DBIC, but this is deprecated.)
Essentially C<columns> does the same as L</select> and L</as>.
=back
-Indicates additional columns to be selected from storage. Works the same
-as L</columns> but adds columns to the selection. (You may also use the
-C<include_columns> attribute, as in earlier versions of DBIC). For
-example:-
+Indicates additional columns to be selected from storage. Works the same as
+L</columns> but adds columns to the selection. (You may also use the
+C<include_columns> attribute, as in earlier versions of DBIC, but this is
+deprecated). For example:-
$schema->resultset('CD')->search(undef, {
'+columns' => ['artist.name'],
projects / dbsrgits/DBIx-Class.git / blobdiff