do not allow double initialization

[gitmo/MooseX-Singleton.git] / lib / MooseX / Singleton / Meta / Class.pm

diff --git a/lib/MooseX/Singleton/Meta/Class.pm b/lib/MooseX/Singleton/Meta/Class.pm
index 447859d..bc929c0 100644 (file)
--- a/lib/MooseX/Singleton/Meta/Class.pm
+++ b/lib/MooseX/Singleton/Meta/Class.pm
@@ -16,5 +16,47 @@ sub initialize {
     );
 };
 
+sub existing_singleton {
+    my ($class) = @_;
+    my $pkg = $class->name;
+
+    no strict 'refs';
+
+    # create exactly one instance
+    if (defined ${"$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;
 
+__END__
+
+=pod
+
+=head1 NAME
+
+MooseX::Singleton::Meta::Class
+
+=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.
+
+=cut
+