This is a bit gross, but it works, and it cooperates with MX::StrictConstructor, at least.
package MooseX::Singleton;
-use Moose 0.82 ();
+use Moose 0.89_02 ();
use Moose::Exporter;
use MooseX::Singleton::Object;
use MooseX::Singleton::Meta::Class;
sub init_meta {
shift;
- Moose->init_meta(
- @_,
- base_class => 'MooseX::Singleton::Object',
- metaclass => 'MooseX::Singleton::Meta::Class',
+ my %p = @_;
+
+ Moose->init_meta(%p);
+
+ my $caller = $p{for_class};
+
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => $caller,
+ metaclass_roles => ['MooseX::Singleton::Role::Meta::Class'],
+ instance_metaclass_roles =>
+ ['MooseX::Singleton::Role::Meta::Instance'],
+ constructor_class_roles =>
+ ['MooseX::Singleton::Role::Meta::Method::Constructor'],
);
+
+ Moose::Util::MetaRole::apply_base_class_roles(
+ for_class => $caller,
+ roles =>
+ ['MooseX::Singleton::Role::Object'],
+ );
+
+ return $caller->meta();
}
+
1;
__END__
#!/usr/bin/env perl
-package MooseX::Singleton::Meta::Class;
-use Moose;
+package MooseX::Singleton::Role::Meta::Class;
+use Moose::Role;
use MooseX::Singleton::Meta::Instance;
use MooseX::Singleton::Meta::Method::Constructor;
-extends 'Moose::Meta::Class';
-
-sub initialize {
- my $class = shift;
- my $pkg = shift;
-
- my $self = $class->SUPER::initialize(
- $pkg,
- instance_metaclass => 'MooseX::Singleton::Meta::Instance',
- constructor_class => 'MooseX::Singleton::Meta::Method::Constructor',
- @_,
- );
-
- return $self;
-}
-
sub existing_singleton {
my ($class) = @_;
my $pkg = $class->name;
=head1 NAME
-MooseX::Singleton::Meta::Class
+MooseX::Singleton::Role::Meta::Class - Metaclass role for MooseX::Singleton
=head1 DESCRIPTION
-This metaclass is where the forcing of one instance occurs. The first call to
-C<construct_instance> is run normally (and then cached). Subsequent calls will
-return the cached version.
+This metaclass role makes sure that there is only ever one instance of an
+object for a singleton class. The first call to C<construct_instance> is run
+normally (and then cached). Subsequent calls will return the cached version.
=cut
#!/usr/bin/env perl
-package MooseX::Singleton::Meta::Instance;
-use Moose;
+package MooseX::Singleton::Role::Meta::Instance;
+use Moose::Role;
use Scalar::Util 'weaken';
-extends 'Moose::Meta::Instance';
-
sub get_singleton_instance {
my ($self, $instance) = @_;
return $instance->meta->name->new;
}
-sub clone_instance {
+override clone_instance => sub {
my ($self, $instance) = @_;
$self->get_singleton_instance($instance);
-}
+};
-sub get_slot_value {
+override get_slot_value => sub {
my ($self, $instance, $slot_name) = @_;
$self->is_slot_initialized($instance, $slot_name) ? $self->get_singleton_instance($instance)->{$slot_name} : undef;
-}
+};
-sub set_slot_value {
+override set_slot_value => sub {
my ($self, $instance, $slot_name, $value) = @_;
$self->get_singleton_instance($instance)->{$slot_name} = $value;
-}
+};
-sub deinitialize_slot {
+override deinitialize_slot => sub {
my ( $self, $instance, $slot_name ) = @_;
delete $self->get_singleton_instance($instance)->{$slot_name};
-}
+};
-sub is_slot_initialized {
+override is_slot_initialized => sub {
my ($self, $instance, $slot_name, $value) = @_;
exists $self->get_singleton_instance($instance)->{$slot_name} ? 1 : 0;
-}
+};
-sub weaken_slot_value {
+override weaken_slot_value => sub {
my ($self, $instance, $slot_name) = @_;
weaken $self->get_singleton_instance($instance)->{$slot_name};
-}
+};
-sub inline_slot_access {
+override inline_slot_access => sub {
my ($self, $instance, $slot_name) = @_;
sprintf "%s->meta->instance_metaclass->get_singleton_instance(%s)->{%s}", $instance, $instance, $slot_name;
-}
+};
no Moose;
=head1 NAME
-MooseX::Singleton::Meta::Instance
+MooseX::Singleton::Role::Meta::Instance - Instance metaclass role for MooseX::Singleton
=head1 DESCRIPTION
-This instance metaclass manages attribute access and storage. When accessing an
-attribute, it will convert a bare package to its cached singleton instance
-(creating it if necessary).
+This role overrides all object access so that it gets the appropriate
+singleton instance for the class.
=cut
#!/usr/bin/env perl
-package MooseX::Singleton::Meta::Method::Constructor;
-use Moose;
+package MooseX::Singleton::Role::Meta::Method::Constructor;
+use Moose::Role;
-extends 'Moose::Meta::Method::Constructor';
-
-sub _initialize_body {
+override _initialize_body => sub {
my $self = shift;
# TODO:
# the %options should also include a both
# the author, after all, nothing is free)
my $source = 'sub {';
$source .= "\n" . 'my $class = shift;';
-
+
$source .= "\n" . 'my $existing = do { no strict "refs"; no warnings "once"; \${"$class\::singleton"}; };';
$source .= "\n" . 'return ${$existing} if ${$existing};';
if $e;
$self->{'body'} = $code;
-}
-
-# For CMOP 0.82_01+
-sub _expected_method_class {
- return 'MooseX::Singleton::Object';
-}
+};
+
+# Ideally we'd be setting this in the constructor, but the new() methods in
+# what the parent classes are not well-factored.
+#
+# This is all a nasty hack, though. We need to fix Class::MOP::Inlined to
+# allow constructor class roles to say "if the parent class has role X,
+# inline".
+override _expected_method_class => sub {
+ my $self = shift;
-# For older versions of Moose/CMOP
-sub _expected_constructor_class {
- return 'MooseX::Singleton::Object';
-}
+ my $super_value = super();
+ if ( $super_value eq 'Moose::Object' ) {
+ for my $parent ( map { Class::MOP::class_of($_) }
+ $self->associated_metaclass->superclasses ) {
+ return $parent->name
+ if $parent->is_anon_class
+ && grep { $_->name eq 'Moose::Object' }
+ map { Class::MOP::class_of($_) } $parent->superclasses;
+ }
+ }
+
+ return $super_value;
+};
no Moose;
#!/usr/bin/env perl
-package MooseX::Singleton::Object;
-use Moose;
-
-extends 'Moose::Object';
+package MooseX::Singleton::Role::Object;
+use Moose::Role;
sub instance { shift->new }
return $class->SUPER::new(@args);
}
-sub new {
+override new => sub {
my ($class, @args) = @_;
my $existing = $class->meta->existing_singleton;
# -- rjbs, 2008-02-03
return $existing if $existing and ! @args;
- return $class->SUPER::new(@args);
-}
+ return super();
+};
sub _clear_instance {
my ($class) = @_;
=head1 NAME
-MooseX::Singleton::Object - base class for MooseX::Singleton
+MooseX::Singleton::Object - Object class role for MooseX::Singleton
=head1 DESCRIPTION
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+BEGIN {
+ eval "require MooseX::StrictConstructor; use Test::Exception; 1;";
+ plan skip_all => 'This test requires MooseX::StrictConstructor and Test::Exception'
+ if $@;
+}
+
+plan 'no_plan';
+
+{
+ package MySingleton;
+ use Moose;
+ use MooseX::Singleton;
+ use MooseX::StrictConstructor;
+
+ has 'attrib' =>
+ is => 'rw';
+}
+
+throws_ok {
+ MySingleton->new( bad_name => 42 )
+}
+qr/Found unknown attribute/,
+'singleton class also has a strict constructor';
projects / gitmo/MooseX-Singleton.git / commitdiff