Re-implementation. This uses a bit of Moose meta magic to get real singletons.

The basic idea is you can now do:

package Moofty;
use MooseX::Singleton;
has 'config' => (is => 'rw', isa => 'HashRef');

package main;
my $moofty = Moofty->instance;
Moofty->config->{min_frob} = 10; # !!
print $moofty->config->{min_frob}; # 10

diff --git a/lib/MooseX/Singleton.pm b/lib/MooseX/Singleton.pm
index c0bb14d..c8c4123 100644 (file)
--- a/lib/MooseX/Singleton.pm
+++ b/lib/MooseX/Singleton.pm
@@ -1,24 +1,19 @@
 package MooseX::Singleton;
-use Moose::Role;
+use Moose;
+use MooseX::Singleton::Object;
+use MooseX::Singleton::Meta::Class;
 
 our $VERSION = 0.02;
 
-override new => sub {
-    my ($class) = @_;
+sub import {
+    my $caller = caller;
 
-    no strict 'refs';
+    Moose::init_meta($caller, 'MooseX::Singleton::Object', 'MooseX::Singleton::Meta::Class');
 
-    # create our instance if we don't already have one
-    if (!defined ${"$class\::singleton"}) {
-        ${"$class\::singleton"} = super;
-    }
+    Moose->import({into => $caller});
+    strict->import;
+    warnings->import;
 
-    return ${"$class\::singleton"};
-};
-
-# instance really is the same as new. any ideas for a better implementation?
-sub instance {
-    shift->new(@_);
 }
 
 1;

diff --git a/lib/MooseX/Singleton/Meta/Class.pm b/lib/MooseX/Singleton/Meta/Class.pm
new file mode 100644 (file)
index 0000000..447859d
--- /dev/null
+++ b/lib/MooseX/Singleton/Meta/Class.pm
@@ -0,0 +1,20 @@
+#!/usr/bin/env perl
+package MooseX::Singleton::Meta::Class;
+use Moose;
+use MooseX::Singleton::Meta::Instance;
+
+extends 'Moose::Meta::Class';
+
+sub initialize {
+    my $class = shift;
+    my $pkg   = shift;
+
+    $class->SUPER::initialize(
+        $pkg,
+        instance_metaclass => 'MooseX::Singleton::Meta::Instance',
+        @_,
+    );
+};
+
+1;
+

diff --git a/lib/MooseX/Singleton/Meta/Instance.pm b/lib/MooseX/Singleton/Meta/Instance.pm
new file mode 100644 (file)
index 0000000..d308120
--- /dev/null
+++ b/lib/MooseX/Singleton/Meta/Instance.pm
@@ -0,0 +1,46 @@
+#!/usr/bin/env perl
+package MooseX::Singleton::Meta::Instance;
+use Moose;
+use Scalar::Util 'weaken';
+
+extends 'Moose::Meta::Instance';
+
+sub instantiate {
+    my ($self, $instance) = @_;
+
+    return $instance if blessed $instance;
+    return $instance->instance;
+}
+
+sub get_slot_value {
+    my ($self, $instance, $slot_name) = @_;
+    $self->is_slot_initialized($instance, $slot_name) ? $self->instantiate($instance)->{$slot_name} : undef;
+}
+
+sub set_slot_value {
+    my ($self, $instance, $slot_name, $value) = @_;
+    $self->instantiate($instance)->{$slot_name} = $value;
+}
+
+sub deinitialize_slot {
+    my ( $self, $instance, $slot_name ) = @_;
+    delete $self->instantiate($instance)->{$slot_name};
+}
+
+sub is_slot_initialized {
+    my ($self, $instance, $slot_name, $value) = @_;
+    exists $self->instantiate($instance)->{$slot_name} ? 1 : 0;
+}
+
+sub weaken_slot_value {
+    my ($self, $instance, $slot_name) = @_;
+    weaken $self->instantiate($instance)->{$slot_name};
+}
+
+sub inline_slot_access {
+    my ($self, $instance, $slot_name) = @_;
+    sprintf "%s->meta->instance_metaclass->instantiate(%s)->{%s}", $instance, $instance, $slot_name;
+}
+
+1;
+

diff --git a/lib/MooseX/Singleton/Object.pm b/lib/MooseX/Singleton/Object.pm
new file mode 100644 (file)
index 0000000..dc04e2f
--- /dev/null
+++ b/lib/MooseX/Singleton/Object.pm
@@ -0,0 +1,24 @@
+#!/usr/bin/env perl
+package MooseX::Singleton::Object;
+use Moose;
+use metaclass 'MooseX::Singleton::Meta::Class';
+
+extends 'Moose::Object';
+
+no strict 'refs';
+
+override new => sub {
+    my $class = shift;
+
+    # create exactly one instance
+    if (!defined ${"$class\::singleton"}) {
+        ${"$class\::singleton"} = super;
+    }
+
+    return ${"$class\::singleton"};
+};
+
+sub instance { shift->new }
+
+1;
+

diff --git a/t/001-basic.t b/t/001-basic.t
new file mode 100644 (file)
index 0000000..99ed3de
--- /dev/null
+++ b/t/001-basic.t
@@ -0,0 +1,68 @@
+use strict;
+use warnings;
+use Test::More tests => 15;
+
+BEGIN {
+    package MooseX::Singleton::Test;
+    use MooseX::Singleton;
+
+    has bag => (
+        is      => 'rw',
+        isa     => 'HashRef[Int]',
+        default => sub { {} },
+    );
+
+    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;
+    }
+}
+
+my $mst = MooseX::Singleton::Test->instance;
+isa_ok($mst, 'MooseX::Singleton::Test', 'Singleton->instance returns a real instance');
+
+is($mst->distinct_keys, 0, "no keys yet");
+
+$mst->add(foo => 10);
+is($mst->distinct_keys, 1, "one key");
+
+$mst->add(bar => 5);
+is($mst->distinct_keys, 2, "two keys");
+
+my $mst2 = MooseX::Singleton::Test->instance;
+isa_ok($mst2, 'MooseX::Singleton::Test', 'Singleton->instance returns a real instance');
+
+is($mst2->distinct_keys, 2, "two keys, from before");
+
+$mst->add(baz => 2);
+
+is($mst->distinct_keys, 3, "three keys");
+is($mst2->distinct_keys, 3, "attributes are shared even after ->instance");
+
+is(MooseX::Singleton::Test->distinct_keys, 3, "three keys even when Package->distinct_keys");
+
+MooseX::Singleton::Test->add(quux => 9000);
+
+is($mst->distinct_keys, 4, "Package->add works fine");
+is($mst2->distinct_keys, 4, "Package->add works fine");
+is(MooseX::Singleton::Test->distinct_keys, 4, "Package->add works fine");
+
+MooseX::Singleton::Test->clear;
+
+is($mst->distinct_keys, 0, "Package->clear works fine");
+is($mst2->distinct_keys, 0, "Package->clear works fine");
+is(MooseX::Singleton::Test->distinct_keys, 0, "Package->clear works fine");
+

diff --git a/t/singleton.t b/t/singleton.t
deleted file mode 100644 (file)
index 8f4ca17..0000000
--- a/t/singleton.t
+++ /dev/null
@@ -1,28 +0,0 @@
-use Test::More tests => 4;
-
-use strict;
-use warnings;
-
-{
-    package Foo::Singleton;
-    use Moose;
-
-    with qw/MooseX::Singleton/;
-
-    has gravy => (is => 'rw');
-}
-
-my $ante = Foo::Singleton->instance;
-
-ok(Foo::Singleton->new,'new');
-
-my $foo = Foo::Singleton->instance;
-my $bar = Foo::Singleton->instance;
-my $baz = Foo::Singleton->new;
-
-$foo->gravy('sauce');
-
-is($bar->gravy,'sauce','singleton');
-is($baz->gravy,'sauce','singleton');
-is($ante->gravy,'sauce','singleton');
-