Commit | Line | Data |
c3398f5b |
1 | #!/usr/bin/env perl |
2 | package Mouse::Object; |
3 | use strict; |
4 | use warnings; |
5 | use MRO::Compat; |
6 | |
b17094ce |
7 | use Scalar::Util qw/blessed weaken/; |
c3398f5b |
8 | use Carp 'confess'; |
9 | |
10 | sub new { |
11 | my $class = shift; |
d574882a |
12 | |
13 | my $args = $class->BUILDARGS(@_); |
da4cb913 |
14 | |
c3398f5b |
15 | my $instance = bless {}, $class; |
16 | |
28d26949 |
17 | for my $attribute ($class->meta->compute_all_applicable_attributes) { |
384072a3 |
18 | my $from = $attribute->init_arg; |
19 | my $key = $attribute->name; |
c3398f5b |
20 | my $default; |
21 | |
d574882a |
22 | if (defined($from) && exists($args->{$from})) { |
d0721247 |
23 | if ($attribute->has_trigger && $attribute->trigger->{before}) { |
24 | $attribute->trigger->{before}->($instance, $args->{$from}, $attribute); |
25 | } |
26 | |
fe5fe061 |
27 | if ($attribute->has_trigger && $attribute->trigger->{around}) { |
28 | $attribute->trigger->{around}->(sub { |
29 | $args->{$from} = $_[1]; |
491e5923 |
30 | |
fe5fe061 |
31 | $attribute->verify_type_constraint($args->{$from}) |
32 | if $attribute->has_type_constraint; |
491e5923 |
33 | |
fe5fe061 |
34 | $instance->{$key} = $args->{$from}; |
35 | |
36 | weaken($instance->{$key}) |
37 | if ref($instance->{$key}) && $attribute->is_weak_ref; |
38 | }, $instance, $args->{$from}, $attribute); |
39 | } |
40 | else { |
41 | $attribute->verify_type_constraint($args->{$from}) |
42 | if $attribute->has_type_constraint; |
43 | |
44 | $instance->{$key} = $args->{$from}; |
45 | |
46 | weaken($instance->{$key}) |
47 | if ref($instance->{$key}) && $attribute->is_weak_ref; |
48 | } |
491e5923 |
49 | |
d0721247 |
50 | if ($attribute->has_trigger && $attribute->trigger->{after}) { |
51 | $attribute->trigger->{after}->($instance, $args->{$from}, $attribute); |
491e5923 |
52 | } |
53 | } |
54 | else { |
de9a434a |
55 | if ($attribute->has_default || $attribute->has_builder) { |
2434d21b |
56 | unless ($attribute->is_lazy) { |
fb706f5c |
57 | my $default = $attribute->default; |
de9a434a |
58 | my $builder = $attribute->builder; |
59 | my $value = $attribute->has_builder |
60 | ? $instance->$builder |
61 | : ref($default) eq 'CODE' |
62 | ? $default->() |
63 | : $default; |
64 | |
65 | $attribute->verify_type_constraint($value) |
5aa30ced |
66 | if $attribute->has_type_constraint; |
67 | |
de9a434a |
68 | $instance->{$key} = $value; |
5aa30ced |
69 | |
b17094ce |
70 | weaken($instance->{$key}) |
3645b316 |
71 | if ref($instance->{$key}) && $attribute->is_weak_ref; |
c3398f5b |
72 | } |
73 | } |
74 | else { |
2434d21b |
75 | if ($attribute->is_required) { |
398327c3 |
76 | confess "Attribute (".$attribute->name.") is required"; |
c3398f5b |
77 | } |
78 | } |
79 | } |
c3398f5b |
80 | } |
81 | |
d574882a |
82 | $instance->BUILDALL($args); |
c3398f5b |
83 | |
84 | return $instance; |
85 | } |
86 | |
d574882a |
87 | sub BUILDARGS { |
88 | my $class = shift; |
89 | |
90 | if (scalar @_ == 1) { |
91 | if (defined $_[0]) { |
92 | (ref($_[0]) eq 'HASH') |
93 | || confess "Single parameters to new() must be a HASH ref"; |
94 | return {%{$_[0]}}; |
95 | } else { |
96 | return {}; |
97 | } |
98 | } |
99 | else { |
100 | return {@_}; |
101 | } |
102 | } |
103 | |
c3398f5b |
104 | sub DESTROY { shift->DEMOLISHALL } |
105 | |
106 | sub BUILDALL { |
107 | my $self = shift; |
108 | |
109 | # short circuit |
110 | return unless $self->can('BUILD'); |
111 | |
2230a6a3 |
112 | for my $class (reverse $self->meta->linearized_isa) { |
cbe29bd9 |
113 | no strict 'refs'; |
114 | no warnings 'once'; |
c3398f5b |
115 | my $code = *{ $class . '::BUILD' }{CODE} |
116 | or next; |
117 | $code->($self, @_); |
118 | } |
119 | } |
120 | |
121 | sub DEMOLISHALL { |
122 | my $self = shift; |
123 | |
124 | # short circuit |
125 | return unless $self->can('DEMOLISH'); |
126 | |
127 | no strict 'refs'; |
128 | |
129 | for my $class ($self->meta->linearized_isa) { |
130 | my $code = *{ $class . '::DEMOLISH' }{CODE} |
131 | or next; |
132 | $code->($self, @_); |
133 | } |
134 | } |
135 | |
136 | 1; |
137 | |
138 | __END__ |
139 | |
140 | =head1 NAME |
141 | |
142 | Mouse::Object - we don't need to steenkin' constructor |
143 | |
144 | =head1 METHODS |
145 | |
146 | =head2 new arguments -> object |
147 | |
148 | Instantiates a new Mouse::Object. This is obviously intended for subclasses. |
149 | |
150 | =head2 BUILDALL \%args |
151 | |
152 | Calls L</BUILD> on each class in the class hierarchy. This is called at the |
153 | end of L</new>. |
154 | |
155 | =head2 BUILD \%args |
156 | |
157 | You may put any business logic initialization in BUILD methods. You don't |
158 | need to redispatch or return any specific value. |
159 | |
442125dc |
160 | =head2 BUILDARGS |
161 | |
162 | Lets you override the arguments that C<new> takes. Return a hashref of |
163 | parameters. |
164 | |
c3398f5b |
165 | =head2 DEMOLISHALL |
166 | |
167 | Calls L</DEMOLISH> on each class in the class hierarchy. This is called at |
168 | L</DESTROY> time. |
169 | |
170 | =head2 DEMOLISH |
171 | |
172 | You may put any business logic deinitialization in DEMOLISH methods. You don't |
173 | need to redispatch or return any specific value. |
174 | |
175 | =cut |
176 | |