Commit | Line | Data |
109b110b |
1 | #!/usr/bin/env perl |
2 | package MooseX::Singleton::Meta::Instance; |
3 | use Moose; |
4 | use Scalar::Util 'weaken'; |
5 | |
6 | extends 'Moose::Meta::Instance'; |
7 | |
7afceec3 |
8 | sub get_singleton_instance { |
109b110b |
9 | my ($self, $instance) = @_; |
10 | |
11 | return $instance if blessed $instance; |
ef266b1f |
12 | |
13 | # optimization: it's really slow to go through new_object for every access |
14 | # so return the singleton if we see it already exists, which it will every |
15 | # single except the first. |
16 | no strict 'refs'; |
17 | return ${"$instance\::singleton"} if defined ${"$instance\::singleton"}; |
18 | |
e2119ce9 |
19 | # We need to go through ->new in order to make sure BUILD and |
20 | # BUILDARGS get called. |
21 | return $instance->meta->name->new; |
109b110b |
22 | } |
23 | |
7afceec3 |
24 | sub clone_instance { |
25 | my ($self, $instance) = @_; |
26 | $self->get_singleton_instance($instance); |
27 | } |
28 | |
109b110b |
29 | sub get_slot_value { |
30 | my ($self, $instance, $slot_name) = @_; |
7afceec3 |
31 | $self->is_slot_initialized($instance, $slot_name) ? $self->get_singleton_instance($instance)->{$slot_name} : undef; |
109b110b |
32 | } |
33 | |
34 | sub set_slot_value { |
35 | my ($self, $instance, $slot_name, $value) = @_; |
7afceec3 |
36 | $self->get_singleton_instance($instance)->{$slot_name} = $value; |
109b110b |
37 | } |
38 | |
39 | sub deinitialize_slot { |
40 | my ( $self, $instance, $slot_name ) = @_; |
7afceec3 |
41 | delete $self->get_singleton_instance($instance)->{$slot_name}; |
109b110b |
42 | } |
43 | |
44 | sub is_slot_initialized { |
45 | my ($self, $instance, $slot_name, $value) = @_; |
7afceec3 |
46 | exists $self->get_singleton_instance($instance)->{$slot_name} ? 1 : 0; |
109b110b |
47 | } |
48 | |
49 | sub weaken_slot_value { |
50 | my ($self, $instance, $slot_name) = @_; |
7afceec3 |
51 | weaken $self->get_singleton_instance($instance)->{$slot_name}; |
109b110b |
52 | } |
53 | |
54 | sub inline_slot_access { |
55 | my ($self, $instance, $slot_name) = @_; |
7afceec3 |
56 | sprintf "%s->meta->instance_metaclass->get_singleton_instance(%s)->{%s}", $instance, $instance, $slot_name; |
109b110b |
57 | } |
58 | |
2b4ce4bd |
59 | no Moose; |
60 | |
109b110b |
61 | 1; |
62 | |
b375b147 |
63 | __END__ |
64 | |
65 | =pod |
66 | |
67 | =head1 NAME |
68 | |
69 | MooseX::Singleton::Meta::Instance |
70 | |
71 | =head1 DESCRIPTION |
72 | |
73 | This instance metaclass manages attribute access and storage. When accessing an |
74 | attribute, it will convert a bare package to its cached singleton instance |
75 | (creating it if necessary). |
76 | |
77 | =cut |
78 | |