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 1;
  46
  47 __END__
  48
  49 =pod
  50
  51 =head1 NAME
  52
  53 MooseX::Singleton::Meta::Class
  54
  55 =head1 DESCRIPTION
  56
  57 This metaclass is where the forcing of one instance occurs. The first call to
  58 C<construct_instance> is run normally (and then cached). Subsequent calls will
  59 return the cached version.
  60
  61 =cut
  62