Revision history for Perl extension MooseX-Singleton
+0.06
+
+ - singleton objects were broken when made_immutable (Dave Rolsky)
+
0.05 2008-02-03
- avoid re-BUILD-ing existing singleton objects
warnings->import;
}
+no Moose;
+
1;
__END__
return ${"$pkg\::singleton"} = super;
};
+# Need to remove make_immutable before we define it below
+no Moose;
+
+use MooseX::Singleton::Meta::Method::Constructor;
+
+sub make_immutable {
+ my $self = shift;
+ $self->SUPER::make_immutable
+ (
+ constructor_class => 'MooseX::Singleton::Meta::Method::Constructor',
+ @_,
+ );
+}
+
1;
__END__
sprintf "%s->meta->instance_metaclass->get_singleton_instance(%s)->{%s}", $instance, $instance, $slot_name;
}
+no Moose;
+
1;
__END__
--- /dev/null
+#!/usr/bin/env perl
+package MooseX::Singleton::Meta::Method::Constructor;
+use Moose;
+
+extends 'Moose::Meta::Method::Constructor';
+
+sub intialize_body {
+ my $self = shift;
+ # TODO:
+ # the %options should also include a both
+ # a call 'initializer' and call 'SUPER::'
+ # options, which should cover approx 90%
+ # of the possible use cases (even if it
+ # requires some adaption on the part of
+ # the author, after all, nothing is free)
+ my $source = 'sub {';
+ $source .= "\n" . 'my $class = shift;';
+
+ $source .= "\n" . 'my $existing = do { no strict "refs"; \${"$class\::singleton"}; };';
+ $source .= "\n" . 'return ${$existing} if ${$existing};';
+
+ $source .= "\n" . 'return $class->Moose::Object::new(@_)';
+ $source .= "\n" . ' if $class ne \'' . $self->associated_metaclass->name . '\';';
+
+ $source .= "\n" . 'my %params = (scalar @_ == 1) ? %{$_[0]} : @_;';
+
+ $source .= "\n" . 'my $instance = ' . $self->meta_instance->inline_create_instance('$class');
+
+ $source .= ";\n" . (join ";\n" => map {
+ $self->_generate_slot_initializer($_)
+ } 0 .. (@{$self->attributes} - 1));
+
+ $source .= ";\n" . $self->_generate_BUILDALL();
+
+ $source .= ";\n" . 'return ${$existing} = $instance';
+ $source .= ";\n" . '}';
+ warn $source if $self->options->{debug};
+
+ my $code;
+ {
+ # NOTE:
+ # create the nessecary lexicals
+ # to be picked up in the eval
+ my $attrs = $self->attributes;
+
+ # We need to check if the attribute ->can('type_constraint')
+ # since we may be trying to immutabilize a Moose meta class,
+ # which in turn has attributes which are Class::MOP::Attribute
+ # objects, rather than Moose::Meta::Attribute. And
+ # Class::MOP::Attribute attributes have no type constraints.
+ # However we need to make sure we leave an undef value there
+ # because the inlined code is using the index of the attributes
+ # to determine where to find the type constraint
+
+ my @type_constraints = map {
+ $_->can('type_constraint') ? $_->type_constraint : undef
+ } @$attrs;
+
+ my @type_constraint_bodies = map {
+ defined $_ ? $_->_compiled_type_constraint : undef;
+ } @type_constraints;
+
+ $code = eval $source;
+ confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@;
+ }
+ $self->{'&!body'} = $code;
+}
+
+no Moose;
+
+1;
return $class->SUPER::new(@args);
}
+no Moose;
+
1;
__END__
use strict;
use warnings;
-use Test::More tests => 15;
+use Test::More tests => 16;
BEGIN {
package MooseX::Singleton::Test;
is($mst->distinct_keys, 3, "added another key");
my $mst2 = MooseX::Singleton::Test->instance;
+is($mst, $mst2, 'instances are the same object');
isa_ok($mst2, 'MooseX::Singleton::Test', 'Singleton->instance returns a real instance');
is($mst2->distinct_keys, 3, "keys from before");
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+BEGIN {
+ unless ( eval 'use Test::Warn; 1' ) {
+ plan skip_all => 'These tests require Test::Warn';
+ }
+ else {
+ plan tests => 17;
+ }
+}
+
+BEGIN {
+ package MooseX::Singleton::Test;
+ use MooseX::Singleton;
+
+ has bag => (
+ is => 'rw',
+ isa => 'HashRef[Int]',
+ default => sub { { default => 42 } },
+ );
+
+ sub distinct_keys {
+ my $self = shift;
+ scalar keys %{ $self->bag };
+ }
+
+ sub clear {
+ my $self = shift;
+ $self->bag({});
+ }
+
+ sub add {
+ my $self = shift;
+ my $key = shift;
+ my $value = @_ ? shift : 1;
+
+ $self->bag->{$key} += $value;
+ }
+
+ ::warning_is sub { make_immutable }, '',
+ 'no warnings when calling make_immutable';
+}
+
+my $mst = MooseX::Singleton::Test->instance;
+isa_ok($mst, 'MooseX::Singleton::Test', 'Singleton->instance returns a real instance');
+
+is($mst->distinct_keys, 1, "default keys");
+
+$mst->add(foo => 10);
+is($mst->distinct_keys, 2, "added key");
+
+$mst->add(bar => 5);
+is($mst->distinct_keys, 3, "added another key");
+
+my $mst2 = MooseX::Singleton::Test->instance;
+is($mst, $mst2, 'instances are the same object');
+isa_ok($mst2, 'MooseX::Singleton::Test', 'Singleton->instance returns a real instance');
+
+is($mst2->distinct_keys, 3, "keys from before");
+
+$mst->add(baz => 2);
+
+is($mst->distinct_keys, 4, "attributes are shared even after ->instance");
+is($mst2->distinct_keys, 4, "attributes are shared even after ->instance");
+
+is(MooseX::Singleton::Test->distinct_keys, 4, "Package->reader works");
+
+MooseX::Singleton::Test->add(quux => 9000);
+
+is($mst->distinct_keys, 5, "Package->add works");
+is($mst2->distinct_keys, 5, "Package->add works");
+is(MooseX::Singleton::Test->distinct_keys, 5, "Package->add works");
+
+MooseX::Singleton::Test->clear;
+
+is($mst->distinct_keys, 0, "Package->clear works");
+is($mst2->distinct_keys, 0, "Package->clear works");
+is(MooseX::Singleton::Test->distinct_keys, 0, "Package->clear works");
+