no strict 'refs';
# create exactly one instance
- if (defined ${"$pkg\::singleton"}) {
+ if ( defined ${"$pkg\::singleton"} ) {
return ${"$pkg\::singleton"};
}
use Scalar::Util 'weaken';
sub get_singleton_instance {
- my ($self, $instance) = @_;
+ my ( $self, $instance ) = @_;
return $instance if blessed $instance;
return $instance->meta->name->new;
}
-override clone_instance => sub {
- my ($self, $instance) = @_;
+override clone_instance => sub {
+ my ( $self, $instance ) = @_;
$self->get_singleton_instance($instance);
};
-override get_slot_value => sub {
- my ($self, $instance, $slot_name) = @_;
- $self->is_slot_initialized($instance, $slot_name) ? $self->get_singleton_instance($instance)->{$slot_name} : undef;
+override get_slot_value => sub {
+ my ( $self, $instance, $slot_name ) = @_;
+ $self->is_slot_initialized( $instance, $slot_name )
+ ? $self->get_singleton_instance($instance)->{$slot_name}
+ : undef;
};
-override set_slot_value => sub {
- my ($self, $instance, $slot_name, $value) = @_;
+override set_slot_value => sub {
+ my ( $self, $instance, $slot_name, $value ) = @_;
$self->get_singleton_instance($instance)->{$slot_name} = $value;
};
-override deinitialize_slot => sub {
+override deinitialize_slot => sub {
my ( $self, $instance, $slot_name ) = @_;
delete $self->get_singleton_instance($instance)->{$slot_name};
};
-override is_slot_initialized => sub {
- my ($self, $instance, $slot_name, $value) = @_;
+override is_slot_initialized => sub {
+ my ( $self, $instance, $slot_name, $value ) = @_;
exists $self->get_singleton_instance($instance)->{$slot_name} ? 1 : 0;
};
-override weaken_slot_value => sub {
- my ($self, $instance, $slot_name) = @_;
+override weaken_slot_value => sub {
+ my ( $self, $instance, $slot_name ) = @_;
weaken $self->get_singleton_instance($instance)->{$slot_name};
};
-override inline_slot_access => sub {
- my ($self, $instance, $slot_name) = @_;
- sprintf "%s->meta->instance_metaclass->get_singleton_instance(%s)->{%s}", $instance, $instance, $slot_name;
+override inline_slot_access => sub {
+ my ( $self, $instance, $slot_name ) = @_;
+ sprintf "%s->meta->instance_metaclass->get_singleton_instance(%s)->{%s}",
+ $instance, $instance, $slot_name;
};
no Moose::Role;
override _initialize_body => sub {
my $self = shift;
+
# TODO:
# the %options should also include a both
# a call 'initializer' and call 'SUPER::'
my $source = 'sub {';
$source .= "\n" . 'my $class = shift;';
- $source .= "\n" . 'my $existing = do { no strict "refs"; no warnings "once"; \${"$class\::singleton"}; };';
+ $source .= "\n"
+ . 'my $existing = do { no strict "refs"; no warnings "once"; \${"$class\::singleton"}; };';
$source .= "\n" . 'return ${$existing} if ${$existing};';
$source .= "\n" . 'return $class->Moose::Object::new(@_)';
- $source .= "\n" . ' if $class ne \'' . $self->associated_metaclass->name . '\';';
+ $source
+ .= "\n"
+ . ' if $class ne \''
+ . $self->associated_metaclass->name . '\';';
- $source .= $self->_generate_params('$params', '$class');
- $source .= $self->_generate_instance('$instance', '$class');
+ $source .= $self->_generate_params( '$params', '$class' );
+ $source .= $self->_generate_instance( '$instance', '$class' );
$source .= $self->_generate_slot_initializers;
$source .= ";\n" . $self->_generate_triggers();
my $attrs = $self->_attributes;
- my @type_constraints = map {
- $_->can('type_constraint') ? $_->type_constraint : undef
- } @$attrs;
+ my @type_constraints
+ = map { $_->can('type_constraint') ? $_->type_constraint : undef }
+ @$attrs;
- my @type_constraint_bodies = map {
- defined $_ ? $_->_compiled_type_constraint : undef;
- } @type_constraints;
+ my @type_constraint_bodies
+ = map { defined $_ ? $_->_compiled_type_constraint : undef; }
+ @type_constraints;
my ( $code, $e ) = $self->_compile_code(
- code => $source,
+ code => $source,
environment => {
- '$meta' => \$self,
- '$attrs' => \$attrs,
- '@type_constraints' => \@type_constraints,
+ '$meta' => \$self,
+ '$attrs' => \$attrs,
+ '@type_constraints' => \@type_constraints,
'@type_constraint_bodies' => \@type_constraint_bodies,
},
);
- $self->throw_error("Could not eval the constructor :\n\n$source\n\nbecause :\n\n$e", error => $e, data => $source )
+ $self->throw_error(
+ "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$e",
+ error => $e, data => $source )
if $e;
$self->{'body'} = $code;
sub instance { shift->new }
sub initialize {
- my ($class, @args) = @_;
+ my ( $class, @args ) = @_;
- my $existing = $class->meta->existing_singleton;
- confess "Singleton is already initialized" if $existing;
+ my $existing = $class->meta->existing_singleton;
+ confess "Singleton is already initialized" if $existing;
- return $class->new(@args);
+ return $class->new(@args);
}
override new => sub {
- my ($class, @args) = @_;
+ my ( $class, @args ) = @_;
- my $existing = $class->meta->existing_singleton;
- confess "Singleton is already initialized" if $existing and @args;
+ my $existing = $class->meta->existing_singleton;
+ confess "Singleton is already initialized" if $existing and @args;
- # Otherwise BUILD will be called repeatedly on the existing instance.
- # -- rjbs, 2008-02-03
- return $existing if $existing and ! @args;
+ # Otherwise BUILD will be called repeatedly on the existing instance.
+ # -- rjbs, 2008-02-03
+ return $existing if $existing and !@args;
- return super();
+ return super();
};
sub _clear_instance {
- my ($class) = @_;
- $class->meta->clear_singleton;
+ my ($class) = @_;
+ $class->meta->clear_singleton;
}
no Moose::Role;
sub clear {
my $self = shift;
- $self->bag({});
+ $self->bag( {} );
}
sub add {
- my $self = shift;
- my $key = shift;
+ my $self = shift;
+ my $key = shift;
my $value = @_ ? shift : 1;
$self->bag->{$key} += $value;
}
my $mst = MooseX::Singleton::Test->instance;
-isa_ok($mst, 'MooseX::Singleton::Test', 'Singleton->instance returns a real instance');
+isa_ok( $mst, 'MooseX::Singleton::Test',
+ 'Singleton->instance returns a real instance' );
-is($mst->distinct_keys, 1, "default keys");
+is( $mst->distinct_keys, 1, "default keys" );
-$mst->add(foo => 10);
-is($mst->distinct_keys, 2, "added key");
+$mst->add( foo => 10 );
+is( $mst->distinct_keys, 2, "added key" );
-$mst->add(bar => 5);
-is($mst->distinct_keys, 3, "added another key");
+$mst->add( bar => 5 );
+is( $mst->distinct_keys, 3, "added another key" );
my $mst2 = MooseX::Singleton::Test->instance;
-is($mst, $mst2, 'instances are the same object');
-isa_ok($mst2, 'MooseX::Singleton::Test', 'Singleton->instance returns a real instance');
+is( $mst, $mst2, 'instances are the same object' );
+isa_ok( $mst2, 'MooseX::Singleton::Test',
+ 'Singleton->instance returns a real instance' );
-is($mst2->distinct_keys, 3, "keys from before");
+is( $mst2->distinct_keys, 3, "keys from before" );
-$mst->add(baz => 2);
+$mst->add( baz => 2 );
-is($mst->distinct_keys, 4, "attributes are shared even after ->instance");
-is($mst2->distinct_keys, 4, "attributes are shared even after ->instance");
+is( $mst->distinct_keys, 4, "attributes are shared even after ->instance" );
+is( $mst2->distinct_keys, 4, "attributes are shared even after ->instance" );
-is(MooseX::Singleton::Test->distinct_keys, 4, "Package->reader works");
+is( MooseX::Singleton::Test->distinct_keys, 4, "Package->reader works" );
-MooseX::Singleton::Test->add(quux => 9000);
+MooseX::Singleton::Test->add( quux => 9000 );
-is($mst->distinct_keys, 5, "Package->add works");
-is($mst2->distinct_keys, 5, "Package->add works");
-is(MooseX::Singleton::Test->distinct_keys, 5, "Package->add works");
+is( $mst->distinct_keys, 5, "Package->add works" );
+is( $mst2->distinct_keys, 5, "Package->add works" );
+is( MooseX::Singleton::Test->distinct_keys, 5, "Package->add works" );
MooseX::Singleton::Test->clear;
-is($mst->distinct_keys, 0, "Package->clear works");
-is($mst2->distinct_keys, 0, "Package->clear works");
-is(MooseX::Singleton::Test->distinct_keys, 0, "Package->clear works");
+is( $mst->distinct_keys, 0, "Package->clear works" );
+is( $mst2->distinct_keys, 0, "Package->clear works" );
+is( MooseX::Singleton::Test->distinct_keys, 0, "Package->clear works" );
MooseX::Singleton::Test->_clear_instance;
$mst = $mst2 = undef;
-is(MooseX::Singleton::Test->new->distinct_keys, 1, "back to the default");
+is( MooseX::Singleton::Test->new->distinct_keys, 1, "back to the default" );
use Test::More;
BEGIN {
- unless ( eval 'use Test::Warn; 1' ) {
+ unless ( eval 'use Test::Warn; 1' ) {
plan skip_all => 'These tests require Test::Warn';
}
else {
sub clear {
my $self = shift;
- $self->bag({});
+ $self->bag( {} );
}
sub add {
- my $self = shift;
- my $key = shift;
+ my $self = shift;
+ my $key = shift;
my $value = @_ ? shift : 1;
$self->bag->{$key} += $value;
}
my $mst = MooseX::Singleton::Test->instance;
-isa_ok($mst, 'MooseX::Singleton::Test', 'Singleton->instance returns a real instance');
+isa_ok( $mst, 'MooseX::Singleton::Test',
+ 'Singleton->instance returns a real instance' );
-is($mst->distinct_keys, 1, "default keys");
+is( $mst->distinct_keys, 1, "default keys" );
-$mst->add(foo => 10);
-is($mst->distinct_keys, 2, "added key");
+$mst->add( foo => 10 );
+is( $mst->distinct_keys, 2, "added key" );
-$mst->add(bar => 5);
-is($mst->distinct_keys, 3, "added another key");
+$mst->add( bar => 5 );
+is( $mst->distinct_keys, 3, "added another key" );
my $mst2 = MooseX::Singleton::Test->instance;
-is($mst, $mst2, 'instances are the same object');
-isa_ok($mst2, 'MooseX::Singleton::Test', 'Singleton->instance returns a real instance');
+is( $mst, $mst2, 'instances are the same object' );
+isa_ok( $mst2, 'MooseX::Singleton::Test',
+ 'Singleton->instance returns a real instance' );
-is($mst2->distinct_keys, 3, "keys from before");
+is( $mst2->distinct_keys, 3, "keys from before" );
-$mst->add(baz => 2);
+$mst->add( baz => 2 );
-is($mst->distinct_keys, 4, "attributes are shared even after ->instance");
-is($mst2->distinct_keys, 4, "attributes are shared even after ->instance");
+is( $mst->distinct_keys, 4, "attributes are shared even after ->instance" );
+is( $mst2->distinct_keys, 4, "attributes are shared even after ->instance" );
-is(MooseX::Singleton::Test->distinct_keys, 4, "Package->reader works");
+is( MooseX::Singleton::Test->distinct_keys, 4, "Package->reader works" );
-MooseX::Singleton::Test->add(quux => 9000);
+MooseX::Singleton::Test->add( quux => 9000 );
-is($mst->distinct_keys, 5, "Package->add works");
-is($mst2->distinct_keys, 5, "Package->add works");
-is(MooseX::Singleton::Test->distinct_keys, 5, "Package->add works");
+is( $mst->distinct_keys, 5, "Package->add works" );
+is( $mst2->distinct_keys, 5, "Package->add works" );
+is( MooseX::Singleton::Test->distinct_keys, 5, "Package->add works" );
MooseX::Singleton::Test->clear;
-is($mst->distinct_keys, 0, "Package->clear works");
-is($mst2->distinct_keys, 0, "Package->clear works");
-is(MooseX::Singleton::Test->distinct_keys, 0, "Package->clear works");
+is( $mst->distinct_keys, 0, "Package->clear works" );
+is( $mst2->distinct_keys, 0, "Package->clear works" );
+is( MooseX::Singleton::Test->distinct_keys, 0, "Package->clear works" );
{
my $addr;
$addr = refaddr( MooseX::Singleton::Test->instance );
}
- is( $addr, refaddr( MooseX::Singleton::Test->instance ),
- 'singleton is not randomly destroyed' );
+ is(
+ $addr, refaddr( MooseX::Singleton::Test->instance ),
+ 'singleton is not randomly destroyed'
+ );
}
-
BEGIN {
eval "require MooseX::StrictConstructor; use Test::Exception; 1;";
- plan skip_all => 'This test requires MooseX::StrictConstructor and Test::Exception'
+ plan skip_all =>
+ 'This test requires MooseX::StrictConstructor and Test::Exception'
if $@;
}
use MooseX::Singleton;
use MooseX::StrictConstructor;
- has 'attrib' =>
- is => 'rw';
+ has 'attrib' => is => 'rw';
}
throws_ok {
- MySingleton->new( bad_name => 42 )
+ MySingleton->new( bad_name => 42 );
}
-qr/Found unknown attribute/,
-'singleton class also has a strict constructor';
+qr/Found unknown attribute/, 'singleton class also has a strict constructor';