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 sub clear_singleton {
  38     my ($class) = @_;
  39     my $pkg = $class->name;
  40     no strict 'refs';
  41     undef ${"$pkg\::singleton"};
  42 }
  43
  44 override _construct_instance => sub {
  45     my ($class) = @_;
  46
  47     # create exactly one instance
  48     my $existing = $class->existing_singleton;
  49     return $existing if $existing;
  50
  51     my $pkg = $class->name;
  52     no strict 'refs';
  53     return ${"$pkg\::singleton"} = super;
  54 };
  55
  56 no Moose;
  57
  58 1;
  59
  60 __END__
  61
  62 =pod
  63
  64 =head1 NAME
  65
  66 MooseX::Singleton::Meta::Class
  67
  68 =head1 DESCRIPTION
  69
  70 This metaclass is where the forcing of one instance occurs. The first call to
  71 C<construct_instance> is run normally (and then cached). Subsequent calls will
  72 return the cached version.
  73
  74 =cut
  75