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 | |
28d26949 |
15 | for my $attribute ($class->meta->compute_all_applicable_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) { |
30 | $attribute->trigger->($instance, $args->{$from}, $attribute); |
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) { |
71 | if (defined $_[0]) { |
72 | (ref($_[0]) eq 'HASH') |
73 | || confess "Single parameters to new() must be a HASH ref"; |
74 | return {%{$_[0]}}; |
75 | } else { |
76 | return {}; |
77 | } |
78 | } |
79 | else { |
80 | return {@_}; |
81 | } |
82 | } |
83 | |
c3398f5b |
84 | sub DESTROY { shift->DEMOLISHALL } |
85 | |
86 | sub BUILDALL { |
87 | my $self = shift; |
88 | |
89 | # short circuit |
90 | return unless $self->can('BUILD'); |
91 | |
2230a6a3 |
92 | for my $class (reverse $self->meta->linearized_isa) { |
cbe29bd9 |
93 | no strict 'refs'; |
94 | no warnings 'once'; |
c3398f5b |
95 | my $code = *{ $class . '::BUILD' }{CODE} |
96 | or next; |
97 | $code->($self, @_); |
98 | } |
99 | } |
100 | |
101 | sub DEMOLISHALL { |
102 | my $self = shift; |
103 | |
104 | # short circuit |
105 | return unless $self->can('DEMOLISH'); |
106 | |
107 | no strict 'refs'; |
108 | |
109 | for my $class ($self->meta->linearized_isa) { |
110 | my $code = *{ $class . '::DEMOLISH' }{CODE} |
111 | or next; |
112 | $code->($self, @_); |
113 | } |
114 | } |
115 | |
df963a63 |
116 | sub dump { |
117 | my $self = shift; |
118 | require Data::Dumper; |
119 | local $Data::Dumper::Maxdepth = shift if @_; |
120 | Data::Dumper::Dumper $self; |
121 | } |
122 | |
56a558f9 |
123 | |
124 | sub does { |
125 | my ($self, $role_name) = @_; |
126 | (defined $role_name) |
127 | || confess "You must supply a role name to does()"; |
128 | my $meta = $self->meta; |
129 | foreach my $class ($meta->linearized_isa) { |
130 | my $m = $meta->initialize($class); |
131 | return 1 |
132 | if $m->can('does_role') && $m->does_role($role_name); |
133 | } |
134 | return 0; |
135 | }; |
136 | |
c3398f5b |
137 | 1; |
138 | |
139 | __END__ |
140 | |
141 | =head1 NAME |
142 | |
143 | Mouse::Object - we don't need to steenkin' constructor |
144 | |
145 | =head1 METHODS |
146 | |
147 | =head2 new arguments -> object |
148 | |
149 | Instantiates a new Mouse::Object. This is obviously intended for subclasses. |
150 | |
151 | =head2 BUILDALL \%args |
152 | |
153 | Calls L</BUILD> on each class in the class hierarchy. This is called at the |
154 | end of L</new>. |
155 | |
156 | =head2 BUILD \%args |
157 | |
158 | You may put any business logic initialization in BUILD methods. You don't |
159 | need to redispatch or return any specific value. |
160 | |
442125dc |
161 | =head2 BUILDARGS |
162 | |
163 | Lets you override the arguments that C<new> takes. Return a hashref of |
164 | parameters. |
165 | |
c3398f5b |
166 | =head2 DEMOLISHALL |
167 | |
168 | Calls L</DEMOLISH> on each class in the class hierarchy. This is called at |
169 | L</DESTROY> time. |
170 | |
171 | =head2 DEMOLISH |
172 | |
173 | You may put any business logic deinitialization in DEMOLISH methods. You don't |
174 | need to redispatch or return any specific value. |
175 | |
df963a63 |
176 | |
56a558f9 |
177 | =head2 does $role_name |
178 | |
179 | This will check if the invocant's class "does" a given C<$role_name>. |
180 | This is similar to "isa" for object, but it checks the roles instead. |
181 | |
182 | |
df963a63 |
183 | =head2 B<dump ($maxdepth)> |
184 | |
185 | From the Moose POD: |
186 | |
187 | C'mon, how many times have you written the following code while debugging: |
188 | |
189 | use Data::Dumper; |
190 | warn Dumper $obj; |
191 | |
192 | It can get seriously annoying, so why not just use this. |
193 | |
194 | The implementation was lifted directly from Moose::Object. |
195 | |
c3398f5b |
196 | =cut |
197 | |
df963a63 |
198 | |