use DBIx::Class::ResultSetColumn;
use DBIx::Class::ResultSourceHandle;
use List::Util ();
-use Scalar::Util 'blessed';
+use Scalar::Util qw/blessed weaken/;
+use Try::Tiny;
use namespace::clean;
use overload
my $self = shift;
my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {});
- # Default to the primary key, but allow a specific key
- my @cols = exists $attrs->{key}
- ? $self->result_source->unique_constraint_columns($attrs->{key})
- : $self->result_source->primary_columns;
- $self->throw_exception(
- "Can't find unless a primary key is defined or unique constraint is specified"
- ) unless @cols;
-
- # Parse out a hashref from input
+ # Parse out a query from input
my $input_query;
if (ref $_[0] eq 'HASH') {
$input_query = { %{$_[0]} };
}
- elsif (@_ == @cols) {
- $input_query = {};
- @{$input_query}{@cols} = @_;
- }
else {
- # Compatibility: Allow e.g. find(id => $value)
- carp "Find by key => value deprecated; please use a hashref instead";
- $input_query = {@_};
- }
+ my $constraint = exists $attrs->{key} ? $attrs->{key} : 'primary';
+ my @c_cols = $self->result_source->unique_constraint_columns($constraint);
- my (%related, $info);
+ $self->throw_exception(
+ "No constraint columns, maybe a malformed '$constraint' constraint?"
+ ) unless @c_cols;
+
+ $self->throw_exception (
+ 'find() expects either a column/value hashref, or a list of values '
+ . "corresponding to the columns of the specified unique constraint '$constraint'"
+ ) unless @c_cols == @_;
+
+ $input_query = {};
+ @{$input_query}{@c_cols} = @_;
+ }
- KEY: foreach my $key (keys %$input_query) {
- if (ref($input_query->{$key})
- && ($info = $self->result_source->relationship_info($key))) {
+ my %related;
+ for my $key (keys %$input_query) {
+ if (
+ my $keyref = ref($input_query->{$key})
+ and
+ my $relinfo = $self->result_source->relationship_info($key)
+ ) {
my $val = delete $input_query->{$key};
- next KEY if (ref($val) eq 'ARRAY'); # has_many for multi_create
+
+ next if $keyref eq 'ARRAY'; # has_many for multi_create
+
my $rel_q = $self->result_source->_resolve_condition(
- $info->{cond}, $val, $key
- );
- die "Can't handle OR join condition in find" if ref($rel_q) eq 'ARRAY';
+ $relinfo->{cond}, $val, $key
+ );
+ die "Can't handle complex relationship conditions in find" if ref($rel_q) ne 'HASH';
@related{keys %$rel_q} = values %$rel_q;
}
}
- if (my @keys = keys %related) {
- @{$input_query}{@keys} = values %related;
- }
+ # relationship conditions take precedence (?)
+ @{$input_query}{keys %related} = values %related;
# Build the final query: Default to the disjunction of the unique queries,
# but allow the input query in case the ResultSet defines the query or the
=item Arguments: $cond?
-=item Return Value: $row_object?
+=item Return Value: $row_object | undef
=back
my $cd = $schema->resultset('CD')->single({ year => 2001 });
Inflates the first result without creating a cursor if the resultset has
-any records in it; if not returns nothing. Used by L</find> as a lean version of
-L</search>.
+any records in it; if not returns C<undef>. Used by L</find> as a lean version
+of L</search>.
While this method can take an optional search condition (just like L</search>)
being a fast-code-path it does not recognize search attributes. If you need to
}
}
-# XXX: Disabled since it doesn't infer uniqueness in all cases
-# unless ($self->_is_unique_query($attrs->{where})) {
-# carp "Query not guaranteed to return a single row"
-# . "; please declare your unique constraints or use search instead";
-# }
-
my @data = $self->result_source->storage->select_single(
$attrs->{from}, $attrs->{select},
$attrs->{where}, $attrs
}
-# _is_unique_query
-#
-# Try to determine if the specified query is guaranteed to be unique, based on
-# the declared unique constraints.
-
-sub _is_unique_query {
- my ($self, $query) = @_;
-
- my $collapsed = $self->_collapse_query($query);
- my $alias = $self->{attrs}{alias};
-
- foreach my $name ($self->result_source->unique_constraint_names) {
- my @unique_cols = map {
- "$alias.$_"
- } $self->result_source->unique_constraint_columns($name);
-
- # Count the values for each unique column
- my %seen = map { $_ => 0 } @unique_cols;
-
- foreach my $key (keys %$collapsed) {
- my $aliased = $key =~ /\./ ? $key : "$alias.$key";
- next unless exists $seen{$aliased}; # Additional constraints are okay
- $seen{$aliased} = scalar keys %{ $collapsed->{$key} };
- }
-
- # If we get 0 or more than 1 value for a column, it's not necessarily unique
- return 1 unless grep { $_ != 1 } values %seen;
- }
-
- return 0;
-}
-
# _collapse_query
#
# Recursively collapse the query, accumulating values for each column.
$attrs->{offset} = $self->{attrs}{offset} || 0;
$attrs->{offset} += $min;
$attrs->{rows} = ($max ? ($max - $min + 1) : 1);
- return $self->search(undef(), $attrs);
+ return $self->search(undef, $attrs);
#my $slice = (ref $self)->new($self->result_source, $attrs);
#return (wantarray ? $slice->all : $slice);
}
=item Arguments: none
-=item Return Value: $result?
+=item Return Value: $result | undef
=back
return $cache->[$self->{all_cache_position}++];
}
if ($self->{attrs}{cache}) {
+ delete $self->{pager};
$self->{all_cache_position} = 1;
return ($self->all)[0];
}
=item Arguments: none
-=item Return Value: $object?
+=item Return Value: $object | undef
=back
-Resets the resultset and returns an object for the first result (if the
-resultset returns anything).
+Resets the resultset and returns an object for the first result (or C<undef>
+if the resultset is empty).
=cut
=back
Sets the specified columns in the resultset to the supplied values in a
-single query. Return value will be true if the update succeeded or false
-if no records were updated; exact type of success value is storage-dependent.
+single query. Note that this will not run any accessor/set_column/update
+triggers, nor will it update any row object instances derived from this
+resultset (this includes the contents of the L<resultset cache|/set_cache>
+if any). See L</update_all> if you need to execute any on-update
+triggers or cascades defined either by you or a
+L<result component|DBIx::Class::Manual::Component/WHAT_IS_A_COMPONENT>.
+
+The return value is a pass through of what the underlying
+storage backend returned, and may vary. See L<DBI/execute> for the most
+common case.
=cut
=back
-Fetches all objects and updates them one at a time. Note that C<update_all>
-will run DBIC cascade triggers, while L</update> will not.
+Fetches all objects and updates them one at a time via
+L<DBIx::Class::Row/update>. Note that C<update_all> will run DBIC defined
+triggers, while L</update> will not.
=cut
=back
-Deletes the contents of the resultset from its result source. Note that this
-will not run DBIC cascade triggers. See L</delete_all> if you need triggers
-to run. See also L<DBIx::Class::Row/delete>.
+Deletes the rows matching this resultset in a single query. Note that this
+will not run any delete triggers, nor will it alter the
+L<in_storage|DBIx::Class::Row/in_storage> status of any row object instances
+derived from this resultset (this includes the contents of the
+L<resultset cache|/set_cache> if any). See L</delete_all> if you need to
+execute any on-delete triggers or cascades defined either by you or a
+L<result component|DBIx::Class::Manual::Component/WHAT_IS_A_COMPONENT>.
-Return value will be the number of rows deleted; exact type of return value
-is storage-dependent.
+The return value is a pass through of what the underlying storage backend
+returned, and may vary. See L<DBI/execute> for the most common case.
=cut
=back
-Fetches all objects and deletes them one at a time. Note that C<delete_all>
-will run DBIC cascade triggers, while L</delete> will not.
+Fetches all objects and deletes them one at a time via
+L<DBIx::Class::Row/delete>. Note that C<delete_all> will run DBIC defined
+triggers, while L</delete> will not.
=cut
=cut
+# make a wizard good for both a scalar and a hashref
+my $mk_lazy_count_wizard = sub {
+ require Variable::Magic;
+
+ my $stash = { total_rs => shift };
+ my $slot = shift; # only used by the hashref magic
+
+ my $magic = Variable::Magic::wizard (
+ data => sub { $stash },
+
+ (!$slot)
+ ? (
+ # the scalar magic
+ get => sub {
+ # set value lazily, and dispell for good
+ ${$_[0]} = $_[1]{total_rs}->count;
+ Variable::Magic::dispell (${$_[0]}, $_[1]{magic_selfref});
+ return 1;
+ },
+ set => sub {
+ # an explicit set implies dispell as well
+ # the unless() is to work around "fun and giggles" below
+ Variable::Magic::dispell (${$_[0]}, $_[1]{magic_selfref})
+ unless (caller(2))[3] eq 'DBIx::Class::ResultSet::pager';
+ return 1;
+ },
+ )
+ : (
+ # the uvar magic
+ fetch => sub {
+ if ($_[2] eq $slot and !$_[1]{inactive}) {
+ my $cnt = $_[1]{total_rs}->count;
+ $_[0]->{$slot} = $cnt;
+
+ # attempting to dispell in a fetch handle (works in store), seems
+ # to invariable segfault on 5.10, 5.12, 5.13 :(
+ # so use an inactivator instead
+ #Variable::Magic::dispell (%{$_[0]}, $_[1]{magic_selfref});
+ $_[1]{inactive}++;
+ }
+ return 1;
+ },
+ store => sub {
+ if (! $_[1]{inactive} and $_[2] eq $slot) {
+ #Variable::Magic::dispell (%{$_[0]}, $_[1]{magic_selfref});
+ $_[1]{inactive}++
+ unless (caller(2))[3] eq 'DBIx::Class::ResultSet::pager';
+ }
+ return 1;
+ },
+ ),
+ );
+
+ $stash->{magic_selfref} = $magic;
+ weaken ($stash->{magic_selfref}); # this fails on 5.8.1
+
+ return $magic;
+};
+
+# the tie class for 5.8.1
+{
+ package DBIx::Class::__DBIC_LAZY_RS_COUNT__;
+ use base qw/Tie::Hash/;
+
+ sub FIRSTKEY { my $dummy = scalar keys %{$_[0]{data}}; each %{$_[0]{data}} }
+ sub NEXTKEY { each %{$_[0]{data}} }
+ sub EXISTS { exists $_[0]{data}{$_[1]} }
+ sub DELETE { delete $_[0]{data}{$_[1]} }
+ sub CLEAR { %{$_[0]{data}} = () }
+ sub SCALAR { scalar %{$_[0]{data}} }
+
+ sub TIEHASH {
+ $_[1]{data} = {%{$_[1]{selfref}}};
+ %{$_[1]{selfref}} = ();
+ Scalar::Util::weaken ($_[1]{selfref});
+ return bless ($_[1], $_[0]);
+ };
+
+ sub FETCH {
+ if ($_[1] eq $_[0]{slot}) {
+ my $cnt = $_[0]{data}{$_[1]} = $_[0]{total_rs}->count;
+ untie %{$_[0]{selfref}};
+ %{$_[0]{selfref}} = %{$_[0]{data}};
+ return $cnt;
+ }
+ else {
+ $_[0]{data}{$_[1]};
+ }
+ }
+
+ sub STORE {
+ $_[0]{data}{$_[1]} = $_[2];
+ if ($_[1] eq $_[0]{slot}) {
+ untie %{$_[0]{selfref}};
+ %{$_[0]{selfref}} = %{$_[0]{data}};
+ }
+ $_[2];
+ }
+}
+
sub pager {
my ($self) = @_;
return $self->{pager} if $self->{pager};
+ if ($self->get_cache) {
+ $self->throw_exception ('Pagers on cached resultsets are not supported');
+ }
+
my $attrs = $self->{attrs};
$self->throw_exception("Can't create pager for non-paged rs")
unless $self->{attrs}{page};
# with a subselect) to get the real total count
my $count_attrs = { %$attrs };
delete $count_attrs->{$_} for qw/rows offset page pager/;
- my $total_count = (ref $self)->new($self->result_source, $count_attrs)->count;
+ my $total_rs = (ref $self)->new($self->result_source, $count_attrs);
+
- return $self->{pager} = Data::Page->new(
- $total_count,
+### the following may seem awkward and dirty, but it's a thought-experiment
+### necessary for future development of DBIx::DS. Do *NOT* change this code
+### before talking to ribasushi/mst
+
+ my $pager = Data::Page->new(
+ 0, #start with an empty set
$attrs->{rows},
- $self->{attrs}{page}
+ $self->{attrs}{page},
);
+
+ my $data_slot = 'total_entries';
+
+ # Since we are interested in a cached value (once it's set - it's set), every
+ # technique will detach from the magic-host once the time comes to fire the
+ # ->count (or in the segfaulting case of >= 5.10 it will deactivate itself)
+
+ if ($] < 5.008003) {
+ # 5.8.1 throws 'Modification of a read-only value attempted' when one tries
+ # to weakref the magic container :(
+ # tested on 5.8.1
+ tie (%$pager, 'DBIx::Class::__DBIC_LAZY_RS_COUNT__',
+ { slot => $data_slot, total_rs => $total_rs, selfref => $pager }
+ );
+ }
+ elsif ($] < 5.010) {
+ # We can use magic on the hash value slot. It's interesting that the magic is
+ # attached to the hash-slot, and does *not* stop working once I do the dummy
+ # assignments after the cast()
+ # tested on 5.8.3 and 5.8.9
+ my $magic = $mk_lazy_count_wizard->($total_rs);
+ Variable::Magic::cast ( $pager->{$data_slot}, $magic );
+
+ # this is for fun and giggles
+ $pager->{$data_slot} = -1;
+ $pager->{$data_slot} = 0;
+
+ # this does not work for scalars, but works with
+ # uvar magic below
+ #my %vals = %$pager;
+ #%$pager = ();
+ #%{$pager} = %vals;
+ }
+ else {
+ # And the uvar magic
+ # works on 5.10.1, 5.12.1 and 5.13.4 in its current form,
+ # however see the wizard maker for more notes
+ my $magic = $mk_lazy_count_wizard->($total_rs, $data_slot);
+ Variable::Magic::cast ( %$pager, $magic );
+
+ # still works
+ $pager->{$data_slot} = -1;
+ $pager->{$data_slot} = 0;
+
+ # this now works
+ my %vals = %$pager;
+ %$pager = ();
+ %{$pager} = %vals;
+ }
+
+ return $self->{pager} = $pager;
}
=head2 page
=item Arguments: none
-=item Return Value: \@cache_objects?
+=item Return Value: \@cache_objects | undef
=back
=item Arguments: none
-=item Return Value: []
+=item Return Value: undef
=back
sub is_ordered {
my ($self) = @_;
- return scalar $self->result_source->storage->_parse_order_by($self->{attrs}{order_by});
+ return scalar $self->result_source->storage->_extract_order_columns($self->{attrs}{order_by});
}
=head2 related_resultset
# add any order_by parts that are not already present in the group_by
# we need to be careful not to add any named functions/aggregates
# i.e. select => [ ... { count => 'foo', -as 'foocount' } ... ]
- for my $chunk ($storage->_parse_order_by($attrs->{order_by})) {
+ for my $chunk ($storage->_extract_order_columns($attrs->{order_by})) {
# only consider real columns (for functions the user got to do an explicit group_by)
my $colinfo = $rs_column_list->{$chunk}