Skip to content

Commit

Permalink
Cleanup compose_namespace(), clarify leaktests wrt classdata
Browse files Browse the repository at this point in the history
  • Loading branch information
@ribasushi
ribasushi committed Oct 25, 2011
1 parent 8a6f415 commit dee99c2
Show file tree
Hide file tree
Showing 4 changed files with 95 additions and 81 deletions.
1 change: 0 additions & 1 deletion lib/DBIx/Class/Carp.pm
View file
Expand Up @@ -31,7 +31,6 @@ sub __find_caller {
while (@f = caller($fr_num++)) {
last unless $f[0] =~ $skip_pattern;

#
if (
$f[0]->can('_skip_namespace_frames')
and
Expand Down
128 changes: 66 additions & 62 deletions lib/DBIx/Class/Schema.pm
View file
Expand Up @@ -196,17 +196,16 @@ sub _map_namespaces {
# returns the result_source_instance for the passed class/object,
# or dies with an informative message (used by load_namespaces)
sub _ns_get_rsrc_instance {
my $class = shift;
my $rs = ref ($_[0]) || $_[0];

if ($rs->can ('result_source_instance') ) {
return $rs->result_source_instance;
}
else {
$class->throw_exception (
"Attempt to load_namespaces() class $rs failed - are you sure this is a real Result Class?"
my $me = shift;
my $rs_class = ref ($_[0]) || $_[0];

return try {
$rs_class->result_source_instance
} catch {
$me->throw_exception (
"Attempt to load_namespaces() class $rs_class failed - are you sure this is a real Result Class?: $_"
);
}
};
}

sub load_namespaces {
Expand Down Expand Up @@ -400,7 +399,6 @@ sub load_classes {

foreach my $to (@to_register) {
$class->register_class(@$to);
# if $class->can('result_source_instance');
}
}

Expand Down Expand Up @@ -831,7 +829,7 @@ sub connection {
}
catch {
$self->throw_exception(
"No arguments to load_classes and couldn't load ${storage_class} ($_)"
"Unable to load storage class ${storage_class}: $_"
);
};
my $storage = $storage_class->new($self=>$args);
Expand Down Expand Up @@ -905,40 +903,51 @@ will produce the output

sub compose_namespace {
my ($self, $target, $base) = @_;

my $schema = $self->clone;

$schema->source_registrations({});

# the original class-mappings must remain - otherwise
# reverse_relationship_info will not work
#$schema->class_mappings({});

{
no warnings qw/redefine/;
local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO;
use warnings qw/redefine/;

no strict qw/refs/;
foreach my $moniker ($schema->sources) {
my $source = $schema->source($moniker);
foreach my $moniker ($self->sources) {
my $orig_source = $self->source($moniker);

my $target_class = "${target}::${moniker}";
$self->inject_base(
$target_class => $source->result_class, ($base ? $base : ())
$self->inject_base($target_class, $orig_source->result_class, ($base || ()) );

# register_source examines result_class, and then returns us a clone
my $new_source = $schema->register_source($moniker, bless
{ %$orig_source, result_class => $target_class },
ref $orig_source,
);
$source->result_class($target_class);
if ($target_class->can('result_source_instance')) {

# since the newly created classes are registered only with
# the instance of $schema, it should be safe to weaken
# the ref (it will GC when $schema is destroyed)
$target_class->result_source_instance($source);
weaken ${"${target_class}::__cag_result_source_instance"};
if ($target_class->can('result_source_instance')) {
# give the class a schema-less source copy
$target_class->result_source_instance( bless
{ %$new_source, schema => ref $new_source->{schema} || $new_source->{schema} },
ref $new_source,
);
}
$schema->register_source($moniker, $source);
}
}
Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
{
no strict 'refs';
no warnings 'redefine';

foreach my $meth (qw/class source resultset/) {
no warnings 'redefine';
*{"${target}::${meth}"} = subname "${target}::${meth}" =>
sub { shift->schema->$meth(@_) };
}
}

Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;

return $schema;
}

Expand Down Expand Up @@ -1035,6 +1044,7 @@ sub clone {
$clone->register_extra_source($moniker => $new);
}
$clone->storage->set_schema($clone) if $clone->storage;

return $clone;
}

Expand Down Expand Up @@ -1319,11 +1329,7 @@ moniker.
=cut

sub register_source {
my $self = shift;

$self->_register_source(@_);
}
sub register_source { shift->_register_source(@_) }

=head2 unregister_source
Expand All @@ -1337,11 +1343,7 @@ Removes the L<DBIx::Class::ResultSource> from the schema for the given moniker.
=cut

sub unregister_source {
my $self = shift;

$self->_unregister_source(@_);
}
sub unregister_source { shift->_unregister_source(@_) }

=head2 register_extra_source
Expand All @@ -1356,42 +1358,44 @@ has a source and you want to register an extra one.
=cut

sub register_extra_source {
my $self = shift;

$self->_register_source(@_, { extra => 1 });
}
sub register_extra_source { shift->_register_source(@_, { extra => 1 }) }

sub _register_source {
my ($self, $moniker, $source, $params) = @_;

my $orig_source = $source;

$source = $source->new({ %$source, source_name => $moniker });

$source->schema($self);
weaken $source->{schema} if ref($self);

my $rs_class = $source->result_class;

my %reg = %{$self->source_registrations};
$reg{$moniker} = $source;
$self->source_registrations(\%reg);

return if ($params->{extra});
return unless defined($rs_class) && $rs_class->can('result_source_instance');

my %map = %{$self->class_mappings};
if (
exists $map{$rs_class}
and
$map{$rs_class} ne $moniker
and
$rs_class->result_source_instance ne $orig_source
) {
carp "$rs_class already has a source, use register_extra_source for additional sources";
return $source if $params->{extra};

my $rs_class = $source->result_class;
if ($rs_class and my $rsrc = try { $rs_class->result_source_instance } ) {
my %map = %{$self->class_mappings};
if (
exists $map{$rs_class}
and
$map{$rs_class} ne $moniker
and
$rsrc ne $_[2] # orig_source
) {
carp
"$rs_class already had a registered source which was replaced by this call. "
. 'Perhaps you wanted register_extra_source(), though it is more likely you did '
. 'something wrong.'
;
}

$map{$rs_class} = $moniker;
$self->class_mappings(\%map);
}
$map{$rs_class} = $moniker;
$self->class_mappings(\%map);

return $source;
}

{
Expand Down
2 changes: 1 addition & 1 deletion t/100extra_source.t
View file
Expand Up @@ -55,7 +55,7 @@ warnings_like (
isa_ok ($schema->resultset('Artist'), 'DBIx::Class::ResultSet');
},
[
qr/DBICTest::Artist already has a source, use register_extra_source for additional sources/
qr/DBICTest::Artist already had a registered source which was replaced by this call/
],
'registering source to an existing result warns'
);
Expand Down
45 changes: 28 additions & 17 deletions t/52leaks.t
View file
Expand Up @@ -36,9 +36,10 @@ if ($ENV{DBICTEST_IN_PERSISTENT_ENV}) {
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/;
Expand Down Expand Up @@ -121,13 +122,16 @@ unless (DBICTest::RunMode->is_plain) {
%$weak_registry = ();
}

my @compose_ns_classes;
{
use_ok ('DBICTest');

my $schema = DBICTest->init_schema;
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
Expand Down Expand Up @@ -267,6 +271,7 @@ unless (DBICTest::RunMode->is_plain) {
reftype $phantom,
refaddr $phantom,
);

$weak_registry->{$slot} = $phantom;
weaken $weak_registry->{$slot};
}
Expand Down Expand Up @@ -300,25 +305,32 @@ for my $slot (keys %$weak_registry) {
}
}


# 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) {
Expand All @@ -337,7 +349,6 @@ 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
Expand Down

0 comments on commit dee99c2

Please sign in to comment.