use strict;
use warnings;
-use Carp qw/croak/;
use overload
- '0+' => 'count',
+ '0+' => \&count,
'bool' => sub { 1; },
fallback => 1;
use Data::Page;
use Storable;
+use Scalar::Util qw/weaken/;
+
+use base qw/DBIx::Class/;
+__PACKAGE__->load_components(qw/AccessorGroup/);
+__PACKAGE__->mk_group_accessors('simple' => qw/result_source result_class/);
=head1 NAME
package MyApp::Schema::Artist;
use base qw/DBIx::Class/;
+ __PACKAGE__->load_components(qw/Core/);
__PACKAGE__->table('artist');
__PACKAGE__->add_columns(qw/artistid name/);
__PACKAGE__->set_primary_key('artistid');
package MyApp::Schema::CD;
use base qw/DBIx::Class/;
- __PACKAGE__->table('artist');
+ __PACKAGE__->load_components(qw/Core/);
+ __PACKAGE__->table('cd');
__PACKAGE__->add_columns(qw/cdid artist title year/);
__PACKAGE__->set_primary_key('cdid');
__PACKAGE__->belongs_to(artist => 'MyApp::Schema::Artist');
=head1 METHODS
-=head2 new($source, \%$attrs)
+=head2 new
+
+=head3 Arguments: ($source, \%$attrs)
The resultset constructor. Takes a source object (usually a
-L<DBIx::Class::TableInstance>) and an attribute hash (see L</ATRRIBUTES>
+L<DBIx::Class::ResultSourceProxy::Table>) and an attribute hash (see L</ATTRIBUTES>
below). Does not perform any queries -- these are executed as needed by the
other methods.
sub new {
my $class = shift;
return $class->new_result(@_) if ref $class;
+
my ($source, $attrs) = @_;
- #use Data::Dumper; warn Dumper($attrs);
+ weaken $source;
$attrs = Storable::dclone($attrs || {}); # { %{ $attrs || {} } };
- my %seen;
+ #use Data::Dumper; warn Dumper($attrs);
my $alias = ($attrs->{alias} ||= 'me');
- if ($attrs->{cols} || !$attrs->{select}) {
- delete $attrs->{as} if $attrs->{cols};
- my @cols = ($attrs->{cols}
- ? @{delete $attrs->{cols}}
- : $source->columns);
- $attrs->{select} = [ map { m/\./ ? $_ : "${alias}.$_" } @cols ];
+
+ $attrs->{columns} ||= delete $attrs->{cols} if $attrs->{cols};
+ delete $attrs->{as} if $attrs->{columns};
+ $attrs->{columns} ||= [ $source->columns ] unless $attrs->{select};
+ $attrs->{select} = [ map { m/\./ ? $_ : "${alias}.$_" } @{delete $attrs->{columns}} ]
+ if $attrs->{columns};
+ $attrs->{as} ||= [ map { m/^\Q$alias.\E(.+)$/ ? $1 : $_ } @{$attrs->{select}} ];
+ if (my $include = delete $attrs->{include_columns}) {
+ push(@{$attrs->{select}}, @$include);
+ push(@{$attrs->{as}}, map { m/([^.]+)$/; $1; } @$include);
}
- $attrs->{as} ||= [ map { m/^$alias\.(.*)$/ ? $1 : $_ } @{$attrs->{select}} ];
#use Data::Dumper; warn Dumper(@{$attrs}{qw/select as/});
+
$attrs->{from} ||= [ { $alias => $source->from } ];
+ $attrs->{seen_join} ||= {};
+ my %seen;
if (my $join = delete $attrs->{join}) {
- foreach my $j (ref $join eq 'ARRAY'
- ? (@{$join}) : ($join)) {
+ foreach my $j (ref $join eq 'ARRAY' ? @$join : ($join)) {
if (ref $j eq 'HASH') {
$seen{$_} = 1 foreach keys %$j;
} else {
$seen{$j} = 1;
}
}
- push(@{$attrs->{from}}, $source->resolve_join($join, $attrs->{alias}));
+ push(@{$attrs->{from}}, $source->resolve_join($join, $attrs->{alias}, $attrs->{seen_join}));
}
+
$attrs->{group_by} ||= $attrs->{select} if delete $attrs->{distinct};
- foreach my $pre (@{delete $attrs->{prefetch} || []}) {
- push(@{$attrs->{from}}, $source->resolve_join($pre, $attrs->{alias}))
- unless $seen{$pre};
- my @pre =
- map { "$pre.$_" }
- $source->related_source($pre)->columns;
- push(@{$attrs->{select}}, @pre);
- push(@{$attrs->{as}}, @pre);
+ $attrs->{order_by} = [ $attrs->{order_by} ] if $attrs->{order_by} and !ref($attrs->{order_by});
+ $attrs->{order_by} ||= [];
+
+ my $collapse = $attrs->{collapse} || {};
+ if (my $prefetch = delete $attrs->{prefetch}) {
+ my @pre_order;
+ foreach my $p (ref $prefetch eq 'ARRAY' ? @$prefetch : ($prefetch)) {
+ if ( ref $p eq 'HASH' ) {
+ foreach my $key (keys %$p) {
+ push(@{$attrs->{from}}, $source->resolve_join($p, $attrs->{alias}))
+ unless $seen{$key};
+ }
+ } else {
+ push(@{$attrs->{from}}, $source->resolve_join($p, $attrs->{alias}))
+ unless $seen{$p};
+ }
+ my @prefetch = $source->resolve_prefetch(
+ $p, $attrs->{alias}, {}, \@pre_order, $collapse);
+ push(@{$attrs->{select}}, map { $_->[0] } @prefetch);
+ push(@{$attrs->{as}}, map { $_->[1] } @prefetch);
+ }
+ push(@{$attrs->{order_by}}, @pre_order);
}
+ $attrs->{collapse} = $collapse;
+# use Data::Dumper; warn Dumper($collapse) if keys %{$collapse};
+
if ($attrs->{page}) {
$attrs->{rows} ||= 10;
$attrs->{offset} ||= 0;
$attrs->{offset} += ($attrs->{rows} * ($attrs->{page} - 1));
}
- my $new = {
- source => $source,
+
+ bless {
+ result_source => $source,
+ result_class => $attrs->{result_class} || $source->result_class,
cond => $attrs->{where},
from => $attrs->{from},
+ collapse => $collapse,
count => undef,
page => delete $attrs->{page},
pager => undef,
- attrs => $attrs };
- bless ($new, $class);
- return $new;
+ attrs => $attrs
+ }, $class;
}
=head2 search
my $new_rs = $rs->search({ foo => 3 });
If you need to pass in additional attributes but no additional condition,
-call it as C<search({}, \%attrs);>.
+call it as C<search(undef, \%attrs);>.
# "SELECT foo, bar FROM $class_table"
- my @all = $class->search({}, { cols => [qw/foo bar/] });
+ my @all = $class->search(undef, { columns => [qw/foo bar/] });
=cut
sub search {
my $self = shift;
- #use Data::Dumper;warn Dumper(@_);
-
- my $attrs = { %{$self->{attrs}} };
- if (@_ > 1 && ref $_[$#_] eq 'HASH') {
- $attrs = { %$attrs, %{ pop(@_) } };
- }
-
- my $where = (@_ ? ((@_ == 1 || ref $_[0] eq "HASH") ? shift : {@_}) : undef());
- if (defined $where) {
- $where = (defined $attrs->{where}
+ my $rs;
+ if( @_ ) {
+
+ my $attrs = { %{$self->{attrs}} };
+ my $having = delete $attrs->{having};
+ $attrs = { %$attrs, %{ pop(@_) } } if @_ > 1 and ref $_[$#_] eq 'HASH';
+
+ my $where = (@_
+ ? ((@_ == 1 || ref $_[0] eq "HASH")
+ ? shift
+ : ((@_ % 2)
+ ? $self->throw_exception(
+ "Odd number of arguments to search")
+ : {@_}))
+ : undef());
+ if (defined $where) {
+ $attrs->{where} = (defined $attrs->{where}
? { '-and' =>
[ map { ref $_ eq 'ARRAY' ? [ -or => $_ ] : $_ }
$where, $attrs->{where} ] }
: $where);
- $attrs->{where} = $where;
- }
+ }
- my $rs = (ref $self)->new($self->{source}, $attrs);
+ if (defined $having) {
+ $attrs->{having} = (defined $attrs->{having}
+ ? { '-and' =>
+ [ map { ref $_ eq 'ARRAY' ? [ -or => $_ ] : $_ }
+ $having, $attrs->{having} ] }
+ : $having);
+ }
+ $rs = (ref $self)->new($self->result_source, $attrs);
+ }
+ else {
+ $rs = $self;
+ $rs->reset;
+ }
return (wantarray ? $rs->all : $rs);
}
resultset.
=cut
-
+
sub search_literal {
my ($self, $cond, @vals) = @_;
my $attrs = (ref $vals[$#vals] eq 'HASH' ? { %{ pop(@vals) } } : {});
return $self->search(\$cond, $attrs);
}
-=head2 find(@colvalues), find(\%cols, \%attrs?)
+=head2 find
+
+=head3 Arguments: (@colvalues) | (\%cols, \%attrs?)
Finds a row based on its primary key or unique constraint. For example:
Also takes an optional C<key> attribute, to search by a specific key or unique
constraint. For example:
- my $cd = $schema->resultset('CD')->find_or_create(
+ my $cd = $schema->resultset('CD')->find(
{
artist => 'Massive Attack',
title => 'Mezzanine',
my ($self, @vals) = @_;
my $attrs = (@vals > 1 && ref $vals[$#vals] eq 'HASH' ? pop(@vals) : {});
- my @cols = $self->{source}->primary_columns;
+ my @cols = $self->result_source->primary_columns;
if (exists $attrs->{key}) {
- my %uniq = $self->{source}->unique_constraints;
- $self->( "Unknown key " . $attrs->{key} . " on " . $self->name )
+ my %uniq = $self->result_source->unique_constraints;
+ $self->throw_exception( "Unknown key $attrs->{key} on $self->name" )
unless exists $uniq{$attrs->{key}};
@cols = @{ $uniq{$attrs->{key}} };
}
#use Data::Dumper; warn Dumper($attrs, @vals, @cols);
- $self->{source}->result_class->throw( "Can't find unless a primary key or unique constraint is defined" )
+ $self->throw_exception( "Can't find unless a primary key or unique constraint is defined" )
unless @cols;
my $query;
if (ref $vals[0] eq 'HASH') {
- $query = $vals[0];
+ $query = { %{$vals[0]} };
} elsif (@cols == @vals) {
$query = {};
@{$query}{@cols} = @vals;
} else {
$query = {@vals};
}
+ foreach my $key (grep { ! m/\./ } keys %$query) {
+ $query->{"$self->{attrs}{alias}.$key"} = delete $query->{$key};
+ }
#warn Dumper($query);
- # Useless -> disabled
- #$self->{source}->result_class->throw( "Can't find unless all primary keys are specified" )
- # unless (keys %$query >= @pk); # If we check 'em we run afoul of uc/lc
- # column names etc. Not sure what to do yet
- return $self->search($query)->next;
+
+ if (keys %$attrs) {
+ my $rs = $self->search($query,$attrs);
+ return keys %{$rs->{collapse}} ? $rs->next : $rs->single;
+ } else {
+ return keys %{$self->{collapse}} ? $self->search($query)->next : $self->single($query);
+ }
}
=head2 search_related
=cut
sub search_related {
- my ($self, $rel, @rest) = @_;
- my $rel_obj = $self->{source}->relationship_info($rel);
- $self->{source}->result_class->throw(
- "No such relationship ${rel} in search_related")
- unless $rel_obj;
- my $rs = $self->search(undef, { join => $rel });
- return $self->{source}->schema->resultset($rel_obj->{class}
- )->search( undef,
- { %{$rs->{attrs}},
- alias => $rel,
- select => undef(),
- as => undef() }
- )->search(@rest);
+ return shift->related_resultset(shift)->search(@_);
}
=head2 cursor
sub cursor {
my ($self) = @_;
- my ($source, $attrs) = @{$self}{qw/source attrs/};
- $attrs = { %$attrs };
+ my $attrs = { %{$self->{attrs}} };
return $self->{cursor}
- ||= $source->storage->select($self->{from}, $attrs->{select},
+ ||= $self->result_source->storage->select($self->{from}, $attrs->{select},
+ $attrs->{where},$attrs);
+}
+
+=head2 single
+
+Inflates the first result without creating a cursor
+
+=cut
+
+sub single {
+ my ($self, $where) = @_;
+ my $attrs = { %{$self->{attrs}} };
+ if ($where) {
+ if (defined $attrs->{where}) {
+ $attrs->{where} = {
+ '-and' =>
+ [ map { ref $_ eq 'ARRAY' ? [ -or => $_ ] : $_ }
+ $where, delete $attrs->{where} ]
+ };
+ } else {
+ $attrs->{where} = $where;
+ }
+ }
+ my @data = $self->result_source->storage->select_single(
+ $self->{from}, $attrs->{select},
$attrs->{where},$attrs);
+ return (@data ? $self->_construct_object(@data) : ());
}
+
=head2 search_like
Perform a search, but use C<LIKE> instead of equality as the condition. Note
=cut
sub search_like {
- my $class = shift;
- my $attrs = { };
- if (@_ > 1 && ref $_[$#_] eq 'HASH') {
- $attrs = pop(@_);
- }
- my $query = ref $_[0] eq "HASH" ? { %{shift()} }: {@_};
+ my $class = shift;
+ my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {});
+ my $query = ref $_[0] eq 'HASH' ? { %{shift()} }: {@_};
$query->{$_} = { 'like' => $query->{$_} } for keys %$query;
return $class->search($query, { %$attrs });
}
-=head2 slice($first, $last)
+=head2 slice
+
+=head3 Arguments: ($first, $last)
Returns a subset of elements from the resultset.
$attrs->{offset} ||= 0;
$attrs->{offset} += $min;
$attrs->{rows} = ($max ? ($max - $min + 1) : 1);
- my $slice = (ref $self)->new($self->{source}, $attrs);
+ my $slice = (ref $self)->new($self->result_source, $attrs);
return (wantarray ? $slice->all : $slice);
}
Can be used to efficiently iterate over records in the resultset:
- my $rs = $schema->resultset('CD')->search({});
+ my $rs = $schema->resultset('CD')->search;
while (my $cd = $rs->next) {
print $cd->title;
}
sub next {
my ($self) = @_;
- my @row = $self->cursor->next;
+ if (@{$self->{all_cache} || []}) {
+ $self->{all_cache_position} ||= 0;
+ return $self->{all_cache}->[$self->{all_cache_position}++];
+ }
+ if ($self->{attrs}{cache}) {
+ $self->{all_cache_position} = 1;
+ return ($self->all)[0];
+ }
+ my @row = (exists $self->{stashed_row}
+ ? @{delete $self->{stashed_row}}
+ : $self->cursor->next);
# warn Dumper(\@row); use Data::Dumper;
return unless (@row);
return $self->_construct_object(@row);
sub _construct_object {
my ($self, @row) = @_;
- my @cols = @{ $self->{attrs}{as} };
- #warn "@cols -> @row";
- my (%me, %pre);
- foreach my $col (@cols) {
- if ($col =~ /([^\.]+)\.([^\.]+)/) {
- $pre{$1}[0]{$2} = shift @row;
- } else {
- $me{$col} = shift @row;
- }
- }
- my $new = $self->{source}->result_class->inflate_result(
- $self->{source}, \%me, \%pre);
+ my @as = @{ $self->{attrs}{as} };
+
+ my $info = $self->_collapse_result(\@as, \@row);
+
+ my $new = $self->result_class->inflate_result($self->result_source, @$info);
+
$new = $self->{attrs}{record_filter}->($new)
if exists $self->{attrs}{record_filter};
return $new;
}
+sub _collapse_result {
+ my ($self, $as, $row, $prefix) = @_;
+
+ my %const;
+
+ my @copy = @$row;
+ foreach my $this_as (@$as) {
+ my $val = shift @copy;
+ if (defined $prefix) {
+ if ($this_as =~ m/^\Q${prefix}.\E(.+)$/) {
+ my $remain = $1;
+ $remain =~ /^(?:(.*)\.)?([^.]+)$/;
+ $const{$1||''}{$2} = $val;
+ }
+ } else {
+ $this_as =~ /^(?:(.*)\.)?([^.]+)$/;
+ $const{$1||''}{$2} = $val;
+ }
+ }
+
+ my $info = [ {}, {} ];
+ foreach my $key (keys %const) {
+ if (length $key) {
+ my $target = $info;
+ my @parts = split(/\./, $key);
+ foreach my $p (@parts) {
+ $target = $target->[1]->{$p} ||= [];
+ }
+ $target->[0] = $const{$key};
+ } else {
+ $info->[0] = $const{$key};
+ }
+ }
+
+ my @collapse = (defined($prefix)
+ ? (map { (m/^\Q${prefix}.\E(.+)$/ ? ($1) : ()); }
+ keys %{$self->{collapse}})
+ : keys %{$self->{collapse}});
+ if (@collapse) {
+ my ($c) = sort { length $a <=> length $b } @collapse;
+ my $target = $info;
+ foreach my $p (split(/\./, $c)) {
+ $target = $target->[1]->{$p} ||= [];
+ }
+ my $c_prefix = (defined($prefix) ? "${prefix}.${c}" : $c);
+ my @co_key = @{$self->{collapse}{$c_prefix}};
+ my %co_check = map { ($_, $target->[0]->{$_}); } @co_key;
+ my $tree = $self->_collapse_result($as, $row, $c_prefix);
+ my (@final, @raw);
+ while ( !(grep {
+ !defined($tree->[0]->{$_})
+ || $co_check{$_} ne $tree->[0]->{$_}
+ } @co_key) ) {
+ push(@final, $tree);
+ last unless (@raw = $self->cursor->next);
+ $row = $self->{stashed_row} = \@raw;
+ $tree = $self->_collapse_result($as, $row, $c_prefix);
+ #warn Data::Dumper::Dumper($tree, $row);
+ }
+ @$target = @final;
+ }
+
+ return $info;
+}
+
+=head2 result_source
+
+Returns a reference to the result source for this recordset.
+
+=cut
+
+
=head2 count
Performs an SQL C<COUNT> with the same query as the resultset was built
with to find the number of elements. If passed arguments, does a search
on the resultset and counts the results of that.
+Note: When using C<count> with C<group_by>, L<DBIX::Class> emulates C<GROUP BY>
+using C<COUNT( DISTINCT( columns ) )>. Some databases (notably SQLite) do
+not support C<DISTINCT> with multiple columns. If you are using such a
+database, you should only use columns from the main table in your C<group_by>
+clause.
+
=cut
sub count {
my $self = shift;
- return $self->search(@_)->count if @_ && defined $_[0];
- croak "Unable to ->count with a GROUP BY" if defined $self->{attrs}{group_by};
- unless (defined $self->{count}) {
- my $attrs = { %{ $self->{attrs} },
- select => { 'count' => '*' },
- as => [ 'count' ] };
- # offset, order by and page are not needed to count. record_filter is cdbi
- delete $attrs->{$_} for qw/rows offset order_by page pager record_filter/;
-
- ($self->{count}) = (ref $self)->new($self->{source}, $attrs)->cursor->next;
- }
- return 0 unless $self->{count};
- my $count = $self->{count};
+ return $self->search(@_)->count if @_ and defined $_[0];
+ return scalar @{ $self->get_cache } if @{ $self->get_cache };
+
+ my $count = $self->_count;
+ return 0 unless $count;
+
$count -= $self->{attrs}{offset} if $self->{attrs}{offset};
$count = $self->{attrs}{rows} if
- ($self->{attrs}{rows} && $self->{attrs}{rows} < $count);
+ $self->{attrs}{rows} and $self->{attrs}{rows} < $count;
+ return $count;
+}
+
+sub _count { # Separated out so pager can get the full count
+ my $self = shift;
+ my $select = { count => '*' };
+ my $attrs = { %{ $self->{attrs} } };
+ if (my $group_by = delete $attrs->{group_by}) {
+ delete $attrs->{having};
+ my @distinct = (ref $group_by ? @$group_by : ($group_by));
+ # todo: try CONCAT for multi-column pk
+ my @pk = $self->result_source->primary_columns;
+ if (@pk == 1) {
+ foreach my $column (@distinct) {
+ if ($column =~ qr/^(?:\Q$attrs->{alias}.\E)?$pk[0]$/) {
+ @distinct = ($column);
+ last;
+ }
+ }
+ }
+
+ $select = { count => { distinct => \@distinct } };
+ #use Data::Dumper; die Dumper $select;
+ }
+
+ $attrs->{select} = $select;
+ $attrs->{as} = [qw/count/];
+
+ # offset, order by and page are not needed to count. record_filter is cdbi
+ delete $attrs->{$_} for qw/rows offset order_by page pager record_filter/;
+
+ my ($count) = (ref $self)->new($self->result_source, $attrs)->cursor->next;
return $count;
}
sub all {
my ($self) = @_;
- return map { $self->_construct_object(@$_); }
- $self->cursor->all;
+ return @{ $self->get_cache } if @{ $self->get_cache };
+
+ my @obj;
+
+ if (keys %{$self->{collapse}}) {
+ # Using $self->cursor->all is really just an optimisation.
+ # If we're collapsing has_many prefetches it probably makes
+ # very little difference, and this is cleaner than hacking
+ # _construct_object to survive the approach
+ $self->cursor->reset;
+ my @row = $self->cursor->next;
+ while (@row) {
+ push(@obj, $self->_construct_object(@row));
+ @row = (exists $self->{stashed_row}
+ ? @{delete $self->{stashed_row}}
+ : $self->cursor->next);
+ }
+ } else {
+ @obj = map { $self->_construct_object(@$_) } $self->cursor->all;
+ }
+
+ $self->set_cache(\@obj) if $self->{attrs}{cache};
+ return @obj;
}
=head2 reset
sub reset {
my ($self) = @_;
+ $self->{all_cache_position} = 0;
$self->cursor->reset;
return $self;
}
return $_[0]->reset->next;
}
-=head2 update(\%values)
+=head2 update
+
+=head3 Arguments: (\%values)
Sets the specified columns in the resultset to the supplied values.
sub update {
my ($self, $values) = @_;
- croak "Values for update must be a hash" unless ref $values eq 'HASH';
- return $self->{source}->storage->update(
- $self->{source}->from, $values, $self->{cond});
+ $self->throw_exception("Values for update must be a hash") unless ref $values eq 'HASH';
+ return $self->result_source->storage->update(
+ $self->result_source->from, $values, $self->{cond});
}
-=head2 update_all(\%values)
+=head2 update_all
+
+=head3 Arguments: (\%values)
Fetches all objects and updates them one at a time. Note that C<update_all>
will run cascade triggers while L</update> will not.
sub update_all {
my ($self, $values) = @_;
- croak "Values for update must be a hash" unless ref $values eq 'HASH';
+ $self->throw_exception("Values for update must be a hash") unless ref $values eq 'HASH';
foreach my $obj ($self->all) {
$obj->set_columns($values)->update;
}
sub delete {
my ($self) = @_;
- $self->{source}->storage->delete($self->{source}->from, $self->{cond});
+ my $del = {};
+
+ if (!ref($self->{cond})) {
+
+ # No-op. No condition, we're deleting everything
+
+ } elsif (ref $self->{cond} eq 'ARRAY') {
+
+ $del = [ map { my %hash;
+ foreach my $key (keys %{$_}) {
+ $key =~ /([^.]+)$/;
+ $hash{$1} = $_->{$key};
+ }; \%hash; } @{$self->{cond}} ];
+
+ } elsif (ref $self->{cond} eq 'HASH') {
+
+ if ((keys %{$self->{cond}})[0] eq '-and') {
+
+ $del->{-and} = [ map { my %hash;
+ foreach my $key (keys %{$_}) {
+ $key =~ /([^.]+)$/;
+ $hash{$1} = $_->{$key};
+ }; \%hash; } @{$self->{cond}{-and}} ];
+
+ } else {
+
+ foreach my $key (keys %{$self->{cond}}) {
+ $key =~ /([^.]+)$/;
+ $del->{$1} = $self->{cond}{$key};
+ }
+ }
+ } else {
+ $self->throw_exception(
+ "Can't delete on resultset with condition unless hash or array");
+ }
+
+ $self->result_source->storage->delete($self->result_source->from, $del);
return 1;
}
sub pager {
my ($self) = @_;
my $attrs = $self->{attrs};
- croak "Can't create pager for non-paged rs" unless $self->{page};
+ $self->throw_exception("Can't create pager for non-paged rs") unless $self->{page};
$attrs->{rows} ||= 10;
- $self->count;
return $self->{pager} ||= Data::Page->new(
- $self->{count}, $attrs->{rows}, $self->{page});
+ $self->_count, $attrs->{rows}, $self->{page});
}
-=head2 page($page_num)
+=head2 page
+
+=head3 Arguments: ($page_num)
Returns a new resultset for the specified page.
my ($self, $page) = @_;
my $attrs = { %{$self->{attrs}} };
$attrs->{page} = $page;
- return (ref $self)->new($self->{source}, $attrs);
+ return (ref $self)->new($self->result_source, $attrs);
}
-=head2 new_result(\%vals)
+=head2 new_result
+
+=head3 Arguments: (\%vals)
Creates a result in the resultset's result class.
sub new_result {
my ($self, $values) = @_;
- $self->{source}->result_class->throw( "new_result needs a hash" )
+ $self->throw_exception( "new_result needs a hash" )
unless (ref $values eq 'HASH');
- $self->{source}->result_class->throw( "Can't abstract implicit construct, condition not a hash" )
+ $self->throw_exception( "Can't abstract implicit construct, condition not a hash" )
if ($self->{cond} && !(ref $self->{cond} eq 'HASH'));
my %new = %$values;
my $alias = $self->{attrs}{alias};
foreach my $key (keys %{$self->{cond}||{}}) {
- $new{$1} = $self->{cond}{$key} if ($key =~ m/^(?:$alias\.)?([^\.]+)$/);
+ $new{$1} = $self->{cond}{$key} if ($key =~ m/^(?:\Q${alias}.\E)?([^.]+)$/);
}
- my $obj = $self->{source}->result_class->new(\%new);
- $obj->result_source($self->{source}) if $obj->can('result_source');
- $obj;
+ my $obj = $self->result_class->new(\%new);
+ $obj->result_source($self->result_source) if $obj->can('result_source');
+ return $obj;
}
-=head2 create(\%vals)
+=head2 create
+
+=head3 Arguments: (\%vals)
Inserts a record into the resultset and returns the object.
sub create {
my ($self, $attrs) = @_;
- $self->{source}->result_class->throw( "create needs a hashref" ) unless ref $attrs eq 'HASH';
+ $self->throw_exception( "create needs a hashref" ) unless ref $attrs eq 'HASH';
return $self->new_result($attrs)->insert;
}
-=head2 find_or_create(\%vals, \%attrs?)
+=head2 find_or_create
+
+=head3 Arguments: (\%vals, \%attrs?)
$class->find_or_create({ key => $val, ... });
-Searches for a record matching the search condition; if it doesn't find one,
-creates one and returns that instead.
+Searches for a record matching the search condition; if it doesn't find one,
+creates one and returns that instead.
my $cd = $schema->resultset('CD')->find_or_create({
cdid => 5,
sub find_or_create {
my $self = shift;
my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {});
- my $hash = ref $_[0] eq "HASH" ? shift : {@_};
+ my $hash = ref $_[0] eq 'HASH' ? shift : {@_};
my $exists = $self->find($hash, $attrs);
- return defined($exists) ? $exists : $self->create($hash);
+ return defined $exists ? $exists : $self->create($hash);
}
=head2 update_or_create
sub update_or_create {
my $self = shift;
-
my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {});
- my $hash = ref $_[0] eq "HASH" ? shift : {@_};
+ my $hash = ref $_[0] eq 'HASH' ? shift : {@_};
- my %unique_constraints = $self->{source}->unique_constraints;
+ my %unique_constraints = $self->result_source->unique_constraints;
my @constraint_names = (exists $attrs->{key}
? ($attrs->{key})
: keys %unique_constraints);
if (scalar keys %unique_hash == scalar @unique_cols);
}
- my $row;
if (@unique_hashes) {
- $row = $self->search(\@unique_hashes, { rows => 1 })->first;
- if ($row) {
+ my $row = $self->single(\@unique_hashes);
+ if (defined $row) {
$row->set_columns($hash);
$row->update;
+ return $row;
}
}
- unless ($row) {
- $row = $self->create($hash);
+ return $self->create($hash);
+}
+
+=head2 get_cache
+
+Gets the contents of the cache for the resultset.
+
+=cut
+
+sub get_cache {
+ shift->{all_cache} || [];
+}
+
+=head2 set_cache
+
+Sets the contents of the cache for the resultset. Expects an arrayref of objects of the same class as those produced by the resultset.
+
+=cut
+
+sub set_cache {
+ my ( $self, $data ) = @_;
+ $self->throw_exception("set_cache requires an arrayref")
+ if ref $data ne 'ARRAY';
+ my $result_class = $self->result_class;
+ foreach( @$data ) {
+ $self->throw_exception("cannot cache object of type '$_', expected '$result_class'")
+ if ref $_ ne $result_class;
}
+ $self->{all_cache} = $data;
+}
+
+=head2 clear_cache
+
+Clears the cache for the resultset.
- return $row;
+=cut
+
+sub clear_cache {
+ shift->set_cache([]);
+}
+
+=head2 related_resultset
+
+Returns a related resultset for the supplied relationship name.
+
+ $rs = $rs->related_resultset('foo');
+
+=cut
+
+sub related_resultset {
+ my ( $self, $rel, @rest ) = @_;
+ $self->{related_resultsets} ||= {};
+ return $self->{related_resultsets}{$rel} ||= do {
+ #warn "fetching related resultset for rel '$rel'";
+ my $rel_obj = $self->result_source->relationship_info($rel);
+ $self->throw_exception(
+ "search_related: result source '" . $self->result_source->name .
+ "' has no such relationship ${rel}")
+ unless $rel_obj; #die Dumper $self->{attrs};
+
+ my $rs = $self->search(undef, { join => $rel });
+ my $alias = defined $rs->{attrs}{seen_join}{$rel}
+ && $rs->{attrs}{seen_join}{$rel} > 1
+ ? join('_', $rel, $rs->{attrs}{seen_join}{$rel})
+ : $rel;
+
+ $self->result_source->schema->resultset($rel_obj->{class}
+ )->search( undef,
+ { %{$rs->{attrs}},
+ alias => $alias,
+ select => undef,
+ as => undef }
+ )->search(@rest);
+ };
+}
+
+=head2 throw_exception
+
+See Schema's throw_exception
+
+=cut
+
+sub throw_exception {
+ my $self=shift;
+ $self->result_source->schema->throw_exception(@_);
}
=head1 ATTRIBUTES
Which column(s) to order the results by. This is currently passed through
directly to SQL, so you can give e.g. C<foo DESC> for a descending order.
-=head2 cols (arrayref)
+=head2 columns
+
+=head3 Arguments: (arrayref)
Shortcut to request a particular set of columns to be retrieved. 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.
+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.)
+
+=head2 include_columns
+
+=head3 Arguments: (arrayref)
+
+Shortcut to include additional columns in the returned results - for example
+
+ { include_columns => ['foo.name'], join => ['foo'] }
-=head2 select (arrayref)
+would add a 'name' column to the information passed to object inflation
+
+=head2 select
+
+=head3 Arguments: (arrayref)
Indicates which columns should be selected from the storage. You can use
column names, or in the case of RDBMS back ends, function or stored procedure
names:
$rs = $schema->resultset('Foo')->search(
- {},
+ undef,
{
- select => {
+ select => [
'column_name',
{ count => 'column_to_count' },
{ sum => 'column_to_sum' }
- }
+ ]
}
);
attribute, the column names returned are storage-dependent. E.g. MySQL would
return a column named C<count(column_to_count)> in the above example.
-=head2 as (arrayref)
+=head2 as
+
+=head3 Arguments: (arrayref)
Indicates column names for object inflation. This is used in conjunction with
C<select>, usually when C<select> contains one or more function or stored
procedure names:
$rs = $schema->resultset('Foo')->search(
- {},
+ undef,
{
- select => {
+ select => [
'column1',
{ count => 'column2' }
- },
+ ],
as => [qw/ column1 column2_count /]
}
);
}
);
-If you want to fetch the columns from the related table as well, see
-C<prefetch> below.
+If the same join is supplied twice, it will be aliased to <rel>_2 (and
+similarly for a third time). For e.g.
+
+ my $rs = $schema->resultset('Artist')->search(
+ { 'cds.title' => 'Foo',
+ 'cds_2.title' => 'Bar' },
+ { join => [ qw/cds cds/ ] });
+
+will return a set of all artists that have both a cd with title Foo and a cd
+with title Bar.
+
+If you want to fetch related objects from other tables as well, see C<prefetch>
+below.
=head2 prefetch
-Contains a list of relationships that should be fetched along with the main
+=head3 Arguments: arrayref/hashref
+
+Contains one or more relationships that should be fetched along with the main
query (when they are accessed afterwards they will have already been
"prefetched"). This is useful for when you know you will need the related
-objects, because it saves a query. Currently limited to prefetching
-one relationship deep, so unlike C<join>, prefetch must be an arrayref.
+objects, because it saves at least one query:
+
+ my $rs = $schema->resultset('Tag')->search(
+ undef,
+ {
+ prefetch => {
+ cd => 'artist'
+ }
+ }
+ );
+
+The initial search results in SQL like the following:
+
+ SELECT tag.*, cd.*, artist.* FROM tag
+ JOIN cd ON tag.cd = cd.cdid
+ JOIN artist ON cd.artist = artist.artistid
-=head2 from (arrayref)
+L<DBIx::Class> has no need to go back to the database when we access the
+C<cd> or C<artist> relationships, which saves us two SQL statements in this
+case.
+
+Simple prefetches will be joined automatically, so there is no need
+for a C<join> attribute in the above search. If you're prefetching to
+depth (e.g. { cd => { artist => 'label' } or similar), you'll need to
+specify the join as well.
+
+C<prefetch> can be used with the following relationship types: C<belongs_to>,
+C<has_one> (or if you're using C<add_relationship>, any relationship declared
+with an accessor type of 'single' or 'filter').
+
+=head2 from
+
+=head3 Arguments: (arrayref)
The C<from> attribute gives you manual control over the C<FROM> clause of SQL
statements generated by L<DBIx::Class>, allowing you to express custom C<JOIN>
then search against all mothers of those children:
$rs = $schema->resultset('Person')->search(
- {},
+ undef,
{
alias => 'mother', # alias columns in accordance with "from"
from => [
]
],
{ 'mother.person_id' => 'child.mother_id' }
- ],
+ ],
]
},
);
with a father in the person table, we could explicitly use C<INNER JOIN>:
$rs = $schema->resultset('Person')->search(
- {},
+ undef,
{
alias => 'child', # alias columns in accordance with "from"
from => [
Can also be used to simulate an SQL C<LIMIT>.
-=head2 group_by (arrayref)
+=head2 group_by
+
+=head3 Arguments: (arrayref)
-A arrayref of columns to group by. Can include columns of joined tables. Note
-note that L</count> doesn't work on grouped resultsets.
+A arrayref of columns to group by. Can include columns of joined tables.
group_by => [qw/ column1 column2 ... /]