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