Commit | Line | Data |
---|---|---|
c3398f5b | 1 | package Mouse::Object; |
2 | use strict; | |
3 | use warnings; | |
c3398f5b | 4 | |
f6715552 | 5 | use Scalar::Util 'weaken'; |
c3398f5b | 6 | use Carp 'confess'; |
7 | ||
8 | sub new { | |
9 | my $class = shift; | |
d574882a | 10 | |
11 | my $args = $class->BUILDARGS(@_); | |
da4cb913 | 12 | |
c3398f5b | 13 | my $instance = bless {}, $class; |
14 | ||
0eaf53c2 | 15 | for my $attribute ($class->meta->get_all_attributes) { |
384072a3 | 16 | my $from = $attribute->init_arg; |
17 | my $key = $attribute->name; | |
c3398f5b | 18 | |
d574882a | 19 | if (defined($from) && exists($args->{$from})) { |
4188b837 | 20 | $args->{$from} = $attribute->coerce_constraint($args->{$from}) |
32af3489 | 21 | if $attribute->should_coerce; |
20e25eb9 | 22 | $attribute->verify_against_type_constraint($args->{$from}); |
491e5923 | 23 | |
a08e715f | 24 | $instance->{$key} = $args->{$from}; |
fe5fe061 | 25 | |
a08e715f | 26 | weaken($instance->{$key}) |
27 | if ref($instance->{$key}) && $attribute->is_weak_ref; | |
491e5923 | 28 | |
a08e715f | 29 | if ($attribute->has_trigger) { |
88b6c018 | 30 | $attribute->trigger->($instance, $args->{$from}); |
491e5923 | 31 | } |
32 | } | |
33 | else { | |
de9a434a | 34 | if ($attribute->has_default || $attribute->has_builder) { |
2434d21b | 35 | unless ($attribute->is_lazy) { |
fb706f5c | 36 | my $default = $attribute->default; |
de9a434a | 37 | my $builder = $attribute->builder; |
38 | my $value = $attribute->has_builder | |
39 | ? $instance->$builder | |
40 | : ref($default) eq 'CODE' | |
0e503bd9 | 41 | ? $default->($instance) |
de9a434a | 42 | : $default; |
43 | ||
4188b837 | 44 | $value = $attribute->coerce_constraint($value) |
32af3489 | 45 | if $attribute->should_coerce; |
20e25eb9 | 46 | $attribute->verify_against_type_constraint($value); |
5aa30ced | 47 | |
de9a434a | 48 | $instance->{$key} = $value; |
5aa30ced | 49 | |
b17094ce | 50 | weaken($instance->{$key}) |
3645b316 | 51 | if ref($instance->{$key}) && $attribute->is_weak_ref; |
c3398f5b | 52 | } |
53 | } | |
54 | else { | |
2434d21b | 55 | if ($attribute->is_required) { |
398327c3 | 56 | confess "Attribute (".$attribute->name.") is required"; |
c3398f5b | 57 | } |
58 | } | |
59 | } | |
c3398f5b | 60 | } |
61 | ||
d574882a | 62 | $instance->BUILDALL($args); |
c3398f5b | 63 | |
64 | return $instance; | |
65 | } | |
66 | ||
d574882a | 67 | sub BUILDARGS { |
68 | my $class = shift; | |
69 | ||
70 | if (scalar @_ == 1) { | |
c9aefe26 | 71 | (ref($_[0]) eq 'HASH') |
72 | || confess "Single parameters to new() must be a HASH ref"; | |
73 | return {%{$_[0]}}; | |
d574882a | 74 | } |
75 | else { | |
76 | return {@_}; | |
77 | } | |
78 | } | |
79 | ||
c3398f5b | 80 | sub DESTROY { shift->DEMOLISHALL } |
81 | ||
82 | sub BUILDALL { | |
83 | my $self = shift; | |
84 | ||
85 | # short circuit | |
86 | return unless $self->can('BUILD'); | |
87 | ||
2230a6a3 | 88 | for my $class (reverse $self->meta->linearized_isa) { |
cbe29bd9 | 89 | no strict 'refs'; |
90 | no warnings 'once'; | |
c3398f5b | 91 | my $code = *{ $class . '::BUILD' }{CODE} |
92 | or next; | |
93 | $code->($self, @_); | |
94 | } | |
3a63a2e7 | 95 | return; |
c3398f5b | 96 | } |
97 | ||
98 | sub DEMOLISHALL { | |
99 | my $self = shift; | |
100 | ||
101 | # short circuit | |
102 | return unless $self->can('DEMOLISH'); | |
103 | ||
104 | no strict 'refs'; | |
105 | ||
c26e296a | 106 | my @isa; |
3a63a2e7 | 107 | if ( my $meta = Mouse::Meta::Class::class_of($self) ) { |
c26e296a | 108 | @isa = $meta->linearized_isa; |
109 | } else { | |
110 | # We cannot count on being able to retrieve a previously made | |
111 | # metaclass, _or_ being able to make a new one during global | |
112 | # destruction. However, we should still be able to use mro at | |
113 | # that time (at least tests suggest so ;) | |
114 | my $class_name = ref $self; | |
6ebf64d5 | 115 | @isa = @{ Mouse::Util::get_linear_isa($class_name) } |
c26e296a | 116 | } |
117 | ||
118 | foreach my $class (@isa) { | |
119 | no strict 'refs'; | |
120 | my $demolish = *{"${class}::DEMOLISH"}{CODE}; | |
121 | $self->$demolish | |
122 | if defined $demolish; | |
c3398f5b | 123 | } |
3a63a2e7 | 124 | return; |
c3398f5b | 125 | } |
126 | ||
df963a63 | 127 | sub dump { |
128 | my $self = shift; | |
129 | require Data::Dumper; | |
130 | local $Data::Dumper::Maxdepth = shift if @_; | |
3a63a2e7 | 131 | Data::Dumper::Dumper($self); |
df963a63 | 132 | } |
133 | ||
56a558f9 | 134 | |
135 | sub does { | |
136 | my ($self, $role_name) = @_; | |
137 | (defined $role_name) | |
138 | || confess "You must supply a role name to does()"; | |
3a63a2e7 | 139 | |
3370794f | 140 | return $self->meta->does_role($role_name); |
56a558f9 | 141 | }; |
142 | ||
c3398f5b | 143 | 1; |
144 | ||
145 | __END__ | |
146 | ||
147 | =head1 NAME | |
148 | ||
149 | Mouse::Object - we don't need to steenkin' constructor | |
150 | ||
151 | =head1 METHODS | |
152 | ||
153 | =head2 new arguments -> object | |
154 | ||
155 | Instantiates a new Mouse::Object. This is obviously intended for subclasses. | |
156 | ||
157 | =head2 BUILDALL \%args | |
158 | ||
159 | Calls L</BUILD> on each class in the class hierarchy. This is called at the | |
160 | end of L</new>. | |
161 | ||
162 | =head2 BUILD \%args | |
163 | ||
164 | You may put any business logic initialization in BUILD methods. You don't | |
165 | need to redispatch or return any specific value. | |
166 | ||
442125dc | 167 | =head2 BUILDARGS |
168 | ||
169 | Lets you override the arguments that C<new> takes. Return a hashref of | |
170 | parameters. | |
171 | ||
c3398f5b | 172 | =head2 DEMOLISHALL |
173 | ||
174 | Calls L</DEMOLISH> on each class in the class hierarchy. This is called at | |
175 | L</DESTROY> time. | |
176 | ||
177 | =head2 DEMOLISH | |
178 | ||
179 | You may put any business logic deinitialization in DEMOLISH methods. You don't | |
180 | need to redispatch or return any specific value. | |
181 | ||
df963a63 | 182 | |
56a558f9 | 183 | =head2 does $role_name |
184 | ||
185 | This will check if the invocant's class "does" a given C<$role_name>. | |
186 | This is similar to "isa" for object, but it checks the roles instead. | |
187 | ||
188 | ||
df963a63 | 189 | =head2 B<dump ($maxdepth)> |
190 | ||
191 | From the Moose POD: | |
192 | ||
193 | C'mon, how many times have you written the following code while debugging: | |
194 | ||
195 | use Data::Dumper; | |
196 | warn Dumper $obj; | |
197 | ||
198 | It can get seriously annoying, so why not just use this. | |
199 | ||
200 | The implementation was lifted directly from Moose::Object. | |
201 | ||
c3398f5b | 202 | =cut |
203 | ||
df963a63 | 204 |