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
return $cache->[$self->{all_cache_position}++];
}
if ($self->{attrs}{cache}) {
+ delete $self->{pager};
$self->{all_cache_position} = 1;
return ($self->all)[0];
}
=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);
+
+
+### 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
- return $self->{pager} = Data::Page->new(
- $total_count,
+ 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
use warnings;
use Test::More;
+use Test::Exception;
use lib qw(t/lib);
use DBICTest;
my $schema = DBICTest->init_schema();
+is ($schema->resultset("CD")->count, 5, 'Initial count sanity check');
+
+my $qcnt;
+$schema->storage->debugcb(sub { $qcnt++ });
+$schema->storage->debug (1);
+
+my $rs = $schema->resultset("CD");
+
# first page
-my $it = $schema->resultset("CD")->search(
+$qcnt = 0;
+my $it = $rs->search(
{},
{ order_by => 'title',
rows => 3,
page => 1 }
);
+my $pager = $it->pager;
+is ($qcnt, 0, 'No queries on rs/pager creation');
-is( $it->pager->entries_on_this_page, 3, "entries_on_this_page ok" );
+is ($pager->entries_per_page, 3, 'Pager created with correct entries_per_page');
+ok ($pager->current_page(-1), 'Set nonexistent page');
+is ($pager->current_page, 1, 'Page set behaves correctly');
+ok ($pager->current_page(2), 'Set 2nd page');
-is( $it->pager->next_page, 2, "next_page ok" );
+is ($qcnt, 0, 'No queries on total_count-independent methods');
-is( $it->count, 3, "count on paged rs ok" );
+is( $it->pager->entries_on_this_page, 2, "entries_on_this_page ok for page 2" );
+
+is ($qcnt, 1, 'Count fired to get pager page entries');
-is( $it->pager->total_entries, 5, "total_entries ok" );
+$qcnt = 0;
+is ($pager->previous_page, 1, 'Correct previous_page');
+is ($pager->next_page, undef, 'No more pages');
+is ($qcnt, 0, 'No more counts - amount of entries cached in pager');
+
+is( $it->count, 3, "count on paged rs ok" );
+is ($qcnt, 1, 'An $rs->count still fires properly');
is( $it->next->title, "Caterwaulin' Blues", "iterator->next ok" );
is( $it->next, undef, "next past end of page ok" );
+
# second page, testing with array
-my @page2 = $schema->resultset("CD")->search(
+my @page2 = $rs->search(
{},
{ order_by => 'title',
rows => 3,
is( $page2[0]->title, "Generic Manufactured Singles", "second page first title ok" );
# page a standard resultset
-$it = $schema->resultset("CD")->search(
+$it = $rs->search(
{},
{ order_by => 'title',
rows => 3 }
is( $page->next->title, "Generic Manufactured Singles", "second page of standard resultset ok" );
+
# test software-based limit paging
-$it = $schema->resultset("CD")->search(
+$it = $rs->search(
{},
{ order_by => 'title',
rows => 3,
is( $it->next->title, "Generic Manufactured Singles", "software iterator->next ok" );
# test paging with chained searches
-$it = $schema->resultset("CD")->search(
+$it = $rs->search(
{},
{ rows => 2,
page => 2 }
is( $it->count, 2, "chained searches paging ok" );
-my $p = sub { $schema->resultset("CD")->page(1)->pager->entries_per_page; };
-
-is($p->(), 10, 'default rows is 10');
-
-$schema->default_resultset_attributes({ rows => 5 });
-
-is($p->(), 5, 'default rows is 5');
-
# test page with offset
-$it = $schema->resultset('CD')->search({}, {
+$it = $rs->search({}, {
rows => 2,
page => 2,
offset => 1,
order_by => 'cdid'
});
-my $row = $schema->resultset('CD')->search({}, {
+my $row = $rs->search({}, {
order_by => 'cdid',
offset => 3,
rows => 1
is($row->cdid, $it->first->cdid, 'page with offset');
+
+# test pager on non-title page behavior
+$qcnt = 0;
+$it = $rs->search({}, { rows => 3 })->page (2);
+ok ($it->pager);
+is ($qcnt, 0, 'No count on past-first-page pager instantiation');
+
+is ($it->pager->current_page, 2, 'Page set properby by $rs');
+is( $it->pager->total_entries, 5, 'total_entries correct' );
+
+$rs->create ({ artist => 1, title => 'MOAR!', year => 2010 });
+is( $it->count, 3, 'Dynamic count on filling up page' );
+$rs->create ({ artist => 1, title => 'MOAR!!!', year => 2011 });
+is( $it->count, 3, 'Count still correct (does not overflow' );
+
+$qcnt = 0;
+is( $it->pager->total_entries, 5, 'total_entries properly cached at old value' );
+is ($qcnt, 0, 'No queries');
+
+# test fresh pager with explicit total count assignment
+$qcnt = 0;
+$pager = $rs->search({}, { rows => 4 })->page (2)->pager;
+$pager->total_entries (13);
+
+is ($pager->current_page, 2, 'Correct start page');
+is ($pager->next_page, 3, 'One more page');
+is ($pager->last_page, 4, 'And one more page');
+is ($pager->previous_page, 1, 'One page in front');
+
+is ($qcnt, 0, 'No queries with explicitly sey total count');
+
+# test cached resultsets
+my $init_cnt = $rs->count;
+
+$it = $rs->search({}, { rows => 3, cache => 1 })->page(3);
+is ($it->count, 1, 'One row');
+is (scalar $it->all, 1, 'One object');
+
+$it->delete;
+is ($rs->count, $init_cnt - 1, 'One row deleted as expected');
+
+is ($it->count, 1, 'One row (cached)');
+is (scalar $it->all, 1, 'One object (cached)');
+
+throws_ok { $it->pager }
+ qr/Pagers on cached resultsets are not supported/, 'No pagers on cached resultsets';
+
+# test fresh rs creation with modified defaults
+my $p = sub { $schema->resultset('CD')->page(1)->pager->entries_per_page; };
+
+is($p->(), 10, 'default rows is 10');
+
+$schema->default_resultset_attributes({ rows => 5 });
+
+is($p->(), 5, 'default rows is 5');
+
+
done_testing;
projects / dbsrgits/DBIx-Class.git / commitdiff