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