Singleton objects were not singletons when made immutable. We need to

provide a custom Meta::Method::Constructor so the generated immtable
new() method respects singleton-ness.

This test implements this, along with tests.

Finally, it adds no Moose at the end of all the classes to prevent any
conflicts between Moose's exports and the class's methods. This was a
problem in Meta::Class, where the exported make_immutable was
overriding the one provided by Moose::Meta::Class.

diff --git a/ChangeLog b/ChangeLog
index 4a4efdd..46f07f2 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,9 @@
 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
 

diff --git a/lib/MooseX/Singleton.pm b/lib/MooseX/Singleton.pm
index 5b65d5d..34291a8 100644 (file)
--- a/lib/MooseX/Singleton.pm
+++ b/lib/MooseX/Singleton.pm
@@ -15,6 +15,8 @@ sub import {
     warnings->import;
 }
 
+no Moose;
+
 1;
 
 __END__

diff --git a/lib/MooseX/Singleton/Meta/Class.pm b/lib/MooseX/Singleton/Meta/Class.pm
index bc929c0..3a0d5d6 100644 (file)
--- a/lib/MooseX/Singleton/Meta/Class.pm
+++ b/lib/MooseX/Singleton/Meta/Class.pm
@@ -42,6 +42,20 @@ override construct_instance => sub {
     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__

diff --git a/lib/MooseX/Singleton/Meta/Instance.pm b/lib/MooseX/Singleton/Meta/Instance.pm
index ad01ccc..c6a0a3c 100644 (file)
--- a/lib/MooseX/Singleton/Meta/Instance.pm
+++ b/lib/MooseX/Singleton/Meta/Instance.pm
@@ -54,6 +54,8 @@ sub inline_slot_access {
     sprintf "%s->meta->instance_metaclass->get_singleton_instance(%s)->{%s}", $instance, $instance, $slot_name;
 }
 
+no Moose;
+
 1;
 
 __END__

diff --git a/lib/MooseX/Singleton/Meta/Method/Constructor.pm b/lib/MooseX/Singleton/Meta/Method/Constructor.pm
new file mode 100644 (file)
index 0000000..4c866e9
--- /dev/null
+++ b/lib/MooseX/Singleton/Meta/Method/Constructor.pm
@@ -0,0 +1,71 @@
+#!/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;

diff --git a/lib/MooseX/Singleton/Object.pm b/lib/MooseX/Singleton/Object.pm
index e13457b..8e38472 100644 (file)
--- a/lib/MooseX/Singleton/Object.pm
+++ b/lib/MooseX/Singleton/Object.pm
@@ -29,6 +29,8 @@ sub new {
   return $class->SUPER::new(@args);
 }
 
+no Moose;
+
 1;
 
 __END__

diff --git a/t/001-basic.t b/t/001-basic.t
index 78caa63..9cd90b0 100644 (file)
--- a/t/001-basic.t
+++ b/t/001-basic.t
@@ -1,6 +1,6 @@
 use strict;
 use warnings;
-use Test::More tests => 15;
+use Test::More tests => 16;
 
 BEGIN {
     package MooseX::Singleton::Test;
@@ -43,6 +43,7 @@ $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");

diff --git a/t/003-immutable.t b/t/003-immutable.t
new file mode 100644 (file)
index 0000000..9cc74ec
--- /dev/null
+++ b/t/003-immutable.t
@@ -0,0 +1,82 @@
+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");
+