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; |
12 | my %args = @_; |
13 | my $instance = bless {}, $class; |
14 | |
f89acace |
15 | for my $attribute (values %{ $class->meta->get_attribute_map }) { |
384072a3 |
16 | my $from = $attribute->init_arg; |
17 | my $key = $attribute->name; |
c3398f5b |
18 | my $default; |
19 | |
384072a3 |
20 | if (!exists($args{$from})) { |
de9a434a |
21 | if ($attribute->has_default || $attribute->has_builder) { |
2434d21b |
22 | unless ($attribute->is_lazy) { |
fb706f5c |
23 | my $default = $attribute->default; |
de9a434a |
24 | my $builder = $attribute->builder; |
25 | my $value = $attribute->has_builder |
26 | ? $instance->$builder |
27 | : ref($default) eq 'CODE' |
28 | ? $default->() |
29 | : $default; |
30 | |
31 | $attribute->verify_type_constraint($value) |
5aa30ced |
32 | if $attribute->has_type_constraint; |
33 | |
de9a434a |
34 | $instance->{$key} = $value; |
5aa30ced |
35 | |
b17094ce |
36 | weaken($instance->{$key}) |
3645b316 |
37 | if ref($instance->{$key}) && $attribute->is_weak_ref; |
c3398f5b |
38 | } |
39 | } |
40 | else { |
2434d21b |
41 | if ($attribute->is_required) { |
398327c3 |
42 | confess "Attribute (".$attribute->name.") is required"; |
c3398f5b |
43 | } |
44 | } |
45 | } |
46 | |
384072a3 |
47 | if (exists($args{$from})) { |
48 | $attribute->verify_type_constraint($args{$from}) |
5aa30ced |
49 | if $attribute->has_type_constraint; |
50 | |
384072a3 |
51 | $instance->{$key} = $args{$from}; |
5aa30ced |
52 | |
b17094ce |
53 | weaken($instance->{$key}) |
3645b316 |
54 | if ref($instance->{$key}) && $attribute->is_weak_ref; |
c3398f5b |
55 | |
de9a434a |
56 | if ($attribute->has_trigger) { |
384072a3 |
57 | $attribute->trigger->($instance, $args{$from}, $attribute); |
c3398f5b |
58 | } |
59 | } |
60 | } |
61 | |
62 | $instance->BUILDALL(\%args); |
63 | |
64 | return $instance; |
65 | } |
66 | |
67 | sub DESTROY { shift->DEMOLISHALL } |
68 | |
69 | sub BUILDALL { |
70 | my $self = shift; |
71 | |
72 | # short circuit |
73 | return unless $self->can('BUILD'); |
74 | |
75 | no strict 'refs'; |
76 | |
77 | for my $class ($self->meta->linearized_isa) { |
78 | my $code = *{ $class . '::BUILD' }{CODE} |
79 | or next; |
80 | $code->($self, @_); |
81 | } |
82 | } |
83 | |
84 | sub DEMOLISHALL { |
85 | my $self = shift; |
86 | |
87 | # short circuit |
88 | return unless $self->can('DEMOLISH'); |
89 | |
90 | no strict 'refs'; |
91 | |
92 | for my $class ($self->meta->linearized_isa) { |
93 | my $code = *{ $class . '::DEMOLISH' }{CODE} |
94 | or next; |
95 | $code->($self, @_); |
96 | } |
97 | } |
98 | |
99 | 1; |
100 | |
101 | __END__ |
102 | |
103 | =head1 NAME |
104 | |
105 | Mouse::Object - we don't need to steenkin' constructor |
106 | |
107 | =head1 METHODS |
108 | |
109 | =head2 new arguments -> object |
110 | |
111 | Instantiates a new Mouse::Object. This is obviously intended for subclasses. |
112 | |
113 | =head2 BUILDALL \%args |
114 | |
115 | Calls L</BUILD> on each class in the class hierarchy. This is called at the |
116 | end of L</new>. |
117 | |
118 | =head2 BUILD \%args |
119 | |
120 | You may put any business logic initialization in BUILD methods. You don't |
121 | need to redispatch or return any specific value. |
122 | |
123 | =head2 DEMOLISHALL |
124 | |
125 | Calls L</DEMOLISH> on each class in the class hierarchy. This is called at |
126 | L</DESTROY> time. |
127 | |
128 | =head2 DEMOLISH |
129 | |
130 | You may put any business logic deinitialization in DEMOLISH methods. You don't |
131 | need to redispatch or return any specific value. |
132 | |
133 | =cut |
134 | |