Use the correct hash keys with init_arg in the constructor
[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 qw/blessed weaken/;
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 (values %{ $class->meta->get_attribute_map }) {
16         my $from = $attribute->init_arg;
17         my $key  = $attribute->name;
18         my $default;
19
20         if (!exists($args{$from})) {
21             if ($attribute->has_default || $attribute->has_builder) {
22                 unless ($attribute->is_lazy) {
23                     my $default = $attribute->default;
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)
32                         if $attribute->has_type_constraint;
33
34                     $instance->{$key} = $value;
35
36                     weaken($instance->{$key})
37                         if ref($instance->{$key}) && $attribute->is_weak_ref;
38                 }
39             }
40             else {
41                 if ($attribute->is_required) {
42                     confess "Attribute (".$attribute->name.") is required";
43                 }
44             }
45         }
46
47         if (exists($args{$from})) {
48             $attribute->verify_type_constraint($args{$from})
49                 if $attribute->has_type_constraint;
50
51             $instance->{$key} = $args{$from};
52
53             weaken($instance->{$key})
54                 if ref($instance->{$key}) && $attribute->is_weak_ref;
55
56             if ($attribute->has_trigger) {
57                 $attribute->trigger->($instance, $args{$from}, $attribute);
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