# 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 {
foreach my $to (@to_register) {
$class->register_class(@$to);
- # if $class->can('result_source_instance');
}
}
}
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);
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;
}
$clone->register_extra_source($moniker => $new);
}
$clone->storage->set_schema($clone) if $clone->storage;
+
return $clone;
}
=cut
-sub register_source {
- my $self = shift;
-
- $self->_register_source(@_);
-}
+sub register_source { shift->_register_source(@_) }
=head2 unregister_source
=cut
-sub unregister_source {
- my $self = shift;
-
- $self->_unregister_source(@_);
-}
+sub unregister_source { shift->_unregister_source(@_) }
=head2 register_extra_source
=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;
}
{
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
reftype $phantom,
refaddr $phantom,
);
+
$weak_registry->{$slot} = $phantom;
weaken $weak_registry->{$slot};
}
}
}
-
-# 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 / commitdiff