use lib qw(t/lib);
use DBICTest::RunMode;
use DBIx::Class;
+use B 'svref_2object';
BEGIN {
plan skip_all => "Your perl version $] appears to leak like a sieve - skipping test"
- if DBIx::Class::_ENV_::PEEPEENESS();
+ if DBIx::Class::_ENV_::PEEPEENESS;
}
use Scalar::Util qw/refaddr reftype weaken/;
%$weak_registry = ();
}
+my @compose_ns_classes;
{
use_ok ('DBICTest');
my $rs = $schema->resultset ('Artist');
my $storage = $schema->storage;
+ @compose_ns_classes = map { "DBICTest::${_}" } keys %{$schema->source_registrations};
+
ok ($storage->connected, 'we are connected');
my $row_obj = $rs->search({}, { rows => 1})->next; # so that commits/rollbacks work
$schema->txn_rollback;
}
+ # prefetching
+ my $cds_rs = $schema->resultset('CD');
+ my $cds_with_artist = $cds_rs->search({}, { prefetch => 'artist' });
+ my $cds_with_tracks = $cds_rs->search({}, { prefetch => 'tracks' });
+ my $cds_with_stuff = $cds_rs->search({}, { prefetch => [ 'genre', { artist => { cds => { tracks => 'cd_single' } } } ] });
+
+ # implicit pref
+ my $cds_with_impl_artist = $cds_rs->search({}, { columns => [qw/me.title artist.name/], join => 'artist' });
+
+ # get_column
+ my $getcol_rs = $cds_rs->get_column('me.cdid');
+ my $pref_getcol_rs = $cds_with_stuff->get_column('me.cdid');
+
+ # fire the column getters
+ my @throwaway = $pref_getcol_rs->all;
+
my $base_collection = {
resultset => $rs,
+ pref_precursor => $cds_rs,
+
+ pref_rs_single => $cds_with_artist,
+ pref_rs_multi => $cds_with_tracks,
+ pref_rs_nested => $cds_with_stuff,
+
+ pref_rs_implicit => $cds_with_impl_artist,
+
+ pref_row_single => $cds_with_artist->next,
+ pref_row_multi => $cds_with_tracks->next,
+ pref_row_nested => $cds_with_stuff->next,
+
+ # even though this does not leak Storable croaks on it :(((
+ #pref_row_implicit => $cds_with_impl_artist->next,
+
+ get_column_rs_plain => $getcol_rs,
+ get_column_rs_pref => $pref_getcol_rs,
+
# twice so that we make sure only one H::M object spawned
chained_resultset => $rs->search_rs ({}, { '+columns' => [ 'foo' ] } ),
chained_resultset2 => $rs->search_rs ({}, { '+columns' => [ 'bar' ] } ),
result_source_handle => $rs->result_source->handle,
- fresh_pager => $rs->page(5)->pager,
- pager => $pager,
pager_explicit_count => $pager_explicit_count,
-
};
require Storable;
%$base_collection,
refrozen => Storable::dclone( $base_collection ),
rerefrozen => Storable::dclone( Storable::dclone( $base_collection ) ),
+ pref_row_implicit => $cds_with_impl_artist->next,
schema => $schema,
storage => $storage,
sql_maker => $storage->sql_maker,
dbh => $storage->_dbh,
+ fresh_pager => $rs->page(5)->pager,
+ pager => $pager,
);
if ($has_dt) {
reftype $phantom,
refaddr $phantom,
);
+
$weak_registry->{$slot} = $phantom;
weaken $weak_registry->{$slot};
}
delete $weak_registry->{$slot}
unless $cleared->{hash_merge_singleton}{$weak_registry->{$slot}{weakref}{behavior}}++;
}
- elsif ($slot =~ /^__TxnScopeGuard__FIXUP__/) {
+ elsif (DBIx::Class::_ENV_::INVISIBLE_DOLLAR_AT and $slot =~ /^__TxnScopeGuard__FIXUP__/) {
delete $weak_registry->{$slot}
- if $] > 5.013001 and $] < 5.013008;
}
elsif ($slot =~ /^DateTime::TimeZone/) {
# DT is going through a refactor it seems - let it leak zones for now
}
}
-
-# FIXME
-# For reasons I can not yet fully understand the table() god-method (located in
-# ::ResultSourceProxy::Table) attaches an actual source instance to each class
-# as virtually *immortal* class-data.
-# For now just ignore these instances manually but there got to be a saner way
-for ( map { $_->result_source_instance } (
+# every result class has a result source instance as classdata
+# make sure these are all present and distinct before ignoring
+# (distinct means only 1 reference)
+for my $rs_class (
'DBICTest::BaseResult',
+ @compose_ns_classes,
map { DBICTest::Schema->class ($_) } DBICTest::Schema->sources
-)) {
- delete $weak_registry->{$_};
+) {
+ # need to store the SVref and examine it separately, to push the rsrc instance off the pad
+ my $SV = svref_2object($rs_class->result_source_instance);
+ is( $SV->REFCNT, 1, "Source instance of $rs_class referenced exactly once" );
+
+ # ignore it
+ delete $weak_registry->{$rs_class->result_source_instance};
}
-# FIXME
-# same problem goes for the schema - its classdata contains live result source
-# objects, which to add insult to the injury are *different* instances from the
-# ones we ignored above
-for ( values %{DBICTest::Schema->source_registrations || {}} ) {
- delete $weak_registry->{$_};
+# Schema classes also hold sources, but these are clones, since
+# each source contains the schema (or schema class name in this case)
+# Hence the clone so that the same source can be registered with
+# multiple schemas
+for my $moniker ( keys %{DBICTest::Schema->source_registrations || {}} ) {
+
+ my $SV = svref_2object(DBICTest::Schema->source($moniker));
+ is( $SV->REFCNT, 1, "Source instance registered under DBICTest::Schema as $moniker referenced exactly once" );
+
+ delete $weak_registry->{DBICTest::Schema->source($moniker)};
}
for my $slot (sort keys %$weak_registry) {
};
}
-
# we got so far without a failure - this is a good thing
# now let's try to rerun this script under a "persistent" environment
# this is ugly and dirty but we do not yet have a Test::Embedded or
projects / dbsrgits/DBIx-Class.git / blobdiff