lib/MooseX/Singleton/Meta/Class.pm

   1 #!/usr/bin/env perl
   2 package MooseX::Singleton::Meta::Class;
   3 use Moose;
   4 use MooseX::Singleton::Meta::Instance;
   5
   6 extends 'Moose::Meta::Class';
   7
   8 sub initialize {
   9     my $class = shift;
  10     my $pkg   = shift;
  11
  12     $class->SUPER::initialize(
  13         $pkg,
  14         instance_metaclass => 'MooseX::Singleton::Meta::Instance',
  15         @_,
  16     );
  17 };
  18
  19 sub existing_singleton {
  20     my ($class) = @_;
  21     my $pkg = $class->name;
  22
  23     no strict 'refs';
  24
  25     # create exactly one instance
  26     if (defined ${"$pkg\::singleton"}) {
  27         return ${"$pkg\::singleton"};
  28     }
  29
  30     return;
  31 }
  32
  33 override construct_instance => sub {
  34     my ($class) = @_;
  35
  36     # create exactly one instance
  37     my $existing = $class->existing_singleton;
  38     return $existing if $existing;
  39
  40     my $pkg = $class->name;
  41     no strict 'refs';
  42     return ${"$pkg\::singleton"} = super;
  43 };
  44
  45 # Need to remove make_immutable before we define it below
  46 no Moose;
  47
  48 use MooseX::Singleton::Meta::Method::Constructor;
  49
  50 sub make_immutable {
  51     my $self = shift;
  52     $self->SUPER::make_immutable
  53       (
  54        constructor_class => 'MooseX::Singleton::Meta::Method::Constructor',
  55        @_,
  56       );
  57 }
  58
  59 1;
  60
  61 __END__
  62
  63 =pod
  64
  65 =head1 NAME
  66
  67 MooseX::Singleton::Meta::Class
  68
  69 =head1 DESCRIPTION
  70
  71 This metaclass is where the forcing of one instance occurs. The first call to
  72 C<construct_instance> is run normally (and then cached). Subsequent calls will
  73 return the cached version.
  74
  75 =cut
  76