From: Dave Rolsky <autarch@urth.org>
Date: Fri, 11 Sep 2009 14:20:32 +0000 (-0500)
Subject: Converted this extension to use MetaRole
X-Git-Tag: 0.20~3
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8eec3c69ee4aa161601b0255c3b32cd6d9cc6998;p=gitmo%2FMooseX-Singleton.git

Converted this extension to use MetaRole

This is a bit gross, but it works, and it cooperates with MX::StrictConstructor, at least.
---

diff --git a/lib/MooseX/Singleton.pm b/lib/MooseX/Singleton.pm
index bde5065..3401c7e 100644
--- a/lib/MooseX/Singleton.pm
+++ b/lib/MooseX/Singleton.pm
@@ -1,6 +1,6 @@
 package MooseX::Singleton;
 
-use Moose 0.82 ();
+use Moose 0.89_02 ();
 use Moose::Exporter;
 use MooseX::Singleton::Object;
 use MooseX::Singleton::Meta::Class;
@@ -12,13 +12,31 @@ Moose::Exporter->setup_import_methods( also => 'Moose' );
 
 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__
diff --git a/lib/MooseX/Singleton/Meta/Class.pm b/lib/MooseX/Singleton/Role/Meta/Class.pm
similarity index 57%
rename from lib/MooseX/Singleton/Meta/Class.pm
rename to lib/MooseX/Singleton/Role/Meta/Class.pm
index 609c250..a8a43ee 100644
--- a/lib/MooseX/Singleton/Meta/Class.pm
+++ b/lib/MooseX/Singleton/Role/Meta/Class.pm
@@ -1,25 +1,9 @@
 #!/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;
@@ -63,13 +47,13 @@ __END__
 
 =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
 
diff --git a/lib/MooseX/Singleton/Meta/Instance.pm b/lib/MooseX/Singleton/Role/Meta/Instance.pm
similarity index 74%
rename from lib/MooseX/Singleton/Meta/Instance.pm
rename to lib/MooseX/Singleton/Role/Meta/Instance.pm
index a56db58..b13b0ca 100644
--- a/lib/MooseX/Singleton/Meta/Instance.pm
+++ b/lib/MooseX/Singleton/Role/Meta/Instance.pm
@@ -1,10 +1,8 @@
 #!/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) = @_;
 
@@ -21,40 +19,40 @@ sub get_singleton_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;
 
@@ -66,13 +64,12 @@ __END__
 
 =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
 
diff --git a/lib/MooseX/Singleton/Meta/Method/Constructor.pm b/lib/MooseX/Singleton/Role/Meta/Method/Constructor.pm
similarity index 67%
rename from lib/MooseX/Singleton/Meta/Method/Constructor.pm
rename to lib/MooseX/Singleton/Role/Meta/Method/Constructor.pm
index 01ea6f4..d45c91b 100644
--- a/lib/MooseX/Singleton/Meta/Method/Constructor.pm
+++ b/lib/MooseX/Singleton/Role/Meta/Method/Constructor.pm
@@ -1,10 +1,8 @@
 #!/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
@@ -15,7 +13,7 @@ sub _initialize_body {
     # 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};';
 
@@ -57,17 +55,30 @@ sub _initialize_body {
         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;
 
diff --git a/lib/MooseX/Singleton/Object.pm b/lib/MooseX/Singleton/Role/Object.pm
similarity index 80%
rename from lib/MooseX/Singleton/Object.pm
rename to lib/MooseX/Singleton/Role/Object.pm
index 312e472..b09613f 100644
--- a/lib/MooseX/Singleton/Object.pm
+++ b/lib/MooseX/Singleton/Role/Object.pm
@@ -1,8 +1,6 @@
 #!/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 }
 
@@ -15,7 +13,7 @@ sub initialize {
   return $class->SUPER::new(@args);
 }
 
-sub new {
+override new => sub {
   my ($class, @args) = @_;
 
   my $existing = $class->meta->existing_singleton;
@@ -25,8 +23,8 @@ sub new {
   # -- rjbs, 2008-02-03
   return $existing if $existing and ! @args;
 
-  return $class->SUPER::new(@args);
-}
+  return super();
+};
 
 sub _clear_instance {
   my ($class) = @_;
@@ -43,7 +41,7 @@ __END__
 
 =head1 NAME
 
-MooseX::Singleton::Object - base class for MooseX::Singleton
+MooseX::Singleton::Object - Object class role for MooseX::Singleton
 
 =head1 DESCRIPTION
 
diff --git a/t/006-cooperative.t b/t/006-cooperative.t
new file mode 100644
index 0000000..7924cc3
--- /dev/null
+++ b/t/006-cooperative.t
@@ -0,0 +1,28 @@
+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';