do not allow double initialization

diff --git a/lib/MooseX/Singleton/Meta/Class.pm b/lib/MooseX/Singleton/Meta/Class.pm
index 28b1437..bc929c0 100644 (file)
--- a/lib/MooseX/Singleton/Meta/Class.pm
+++ b/lib/MooseX/Singleton/Meta/Class.pm
@@ -16,18 +16,30 @@ sub initialize {
     );
 };
 
-override construct_instance => sub {
+sub existing_singleton {
     my ($class) = @_;
     my $pkg = $class->name;
 
     no strict 'refs';
 
     # create exactly one instance
-    if (!defined ${"$pkg\::singleton"}) {
-        ${"$pkg\::singleton"} = super;
+    if (defined ${"$pkg\::singleton"}) {
+        return ${"$pkg\::singleton"};
     }
 
-    return ${"$pkg\::singleton"};
+    return;
+}
+
+override construct_instance => sub {
+    my ($class) = @_;
+
+    # create exactly one instance
+    my $existing = $class->existing_singleton;
+    return $existing if $existing;
+
+    my $pkg = $class->name;
+    no strict 'refs';
+    return ${"$pkg\::singleton"} = super;
 };
 
 1;

diff --git a/lib/MooseX/Singleton/Object.pm b/lib/MooseX/Singleton/Object.pm
index c35c1e8..942e149 100644 (file)
--- a/lib/MooseX/Singleton/Object.pm
+++ b/lib/MooseX/Singleton/Object.pm
@@ -7,6 +7,15 @@ extends 'Moose::Object';
 
 sub instance { shift->new }
 
+sub new {
+  my ($class, @args) = @_;
+
+  my $existing = $class->meta->existing_singleton;
+  confess "Singleton is already initialized" if $existing and @args;
+
+  return $class->SUPER::new(@args);
+}
+
 1;
 
 __END__

diff --git a/t/002-init.t b/t/002-init.t
new file mode 100644 (file)
index 0000000..2c25897
--- /dev/null
+++ b/t/002-init.t
@@ -0,0 +1,52 @@
+use strict;
+use warnings;
+use Test::More tests => 8;
+
+my $i = 0;
+sub new_singleton_pkg {
+  my $pkg_name = sprintf 'MooseX::Singleton::Test%s', $i++;
+  eval qq{
+    package $pkg_name;
+    use MooseX::Singleton;
+    has number => (is => 'rw', isa => 'Num', required => 1);
+    has string => (is => 'rw', isa => 'Str', default  => 'Hello!');
+  };
+
+  return $pkg_name;
+}
+
+eval { new_singleton_pkg()->instance; };
+like(
+  $@,
+  qr/\QAttribute (number) is required/,
+  q{can't get the Singleton if requires attrs and we don't provide them},
+);
+
+eval { new_singleton_pkg()->string; };
+like(
+  $@,
+  qr/\QAttribute (number) is required/,
+  q{can't call any Singleton attr reader if Singleton can't be inited},
+);
+
+for my $pkg (new_singleton_pkg) {
+  my $mst = $pkg->new(number => 5);
+  isa_ok($mst, $pkg);
+
+  is($mst->number, 5, "the instance has the given attribute value");
+
+  is(
+    $pkg->number,
+    5,
+    "the class method, called directly, returns the given attribute value"
+  );
+
+  eval { $pkg->new(number => 3) };
+  ok($@, "can't make new singleton with conflicting attributes");
+
+  my $second = eval { $pkg->new };
+  ok(!$@, "...but a second ->new without args is okay");
+
+  is($second->number, 5, "...we get the originally inited number from it");
+}
+