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