Commit | Line | Data |
a41c0667 |
1 | package Mouse::Meta::Method::Accessor; |
2 | use strict; |
3 | use warnings; |
7b133c92 |
4 | use Scalar::Util qw(blessed); |
a41c0667 |
5 | |
6 | sub _install_accessor{ |
7 | my (undef, $attribute, $method_name, $class, $type) = @_; |
8 | |
9 | my $name = $attribute->name; |
10 | my $default = $attribute->default; |
11 | my $constraint = $attribute->type_constraint; |
12 | my $builder = $attribute->builder; |
13 | my $trigger = $attribute->trigger; |
14 | my $is_weak = $attribute->is_weak_ref; |
15 | my $should_deref = $attribute->should_auto_deref; |
16 | my $should_coerce = $attribute->should_coerce; |
17 | |
18 | my $compiled_type_constraint = $constraint ? $constraint->{_compiled_type_constraint} : undef; |
19 | |
20 | my $self = '$_[0]'; |
7b133c92 |
21 | my $key = sprintf q{"%s"}, quotemeta $name; |
a41c0667 |
22 | |
23 | $type ||= 'accessor'; |
24 | |
25 | my $accessor = |
26 | '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" . |
27 | "sub {\n"; |
28 | if ($type eq 'accessor' || $type eq 'writer') { |
29 | if($type eq 'accessor'){ |
30 | $accessor .= |
31 | '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" . |
32 | 'if (scalar(@_) >= 2) {' . "\n"; |
33 | } |
34 | else{ # writer |
35 | $accessor .= |
36 | '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" . |
37 | 'if(@_ < 2){ Carp::confess("Not enough arguments for writer '.$method_name.'") }'. |
38 | '{' . "\n"; |
39 | } |
40 | |
41 | my $value = '$_[1]'; |
42 | |
43 | if ($constraint) { |
44 | if ($should_coerce) { |
45 | $accessor .= |
46 | "\n". |
47 | '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" . |
48 | 'my $val = Mouse::Util::TypeConstraints->typecast_constraints("'.$attribute->associated_class->name.'", $attribute->{type_constraint}, '.$value.');'; |
49 | $value = '$val'; |
50 | } |
51 | if ($compiled_type_constraint) { |
52 | $accessor .= |
53 | "\n". |
54 | '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" . |
55 | 'unless ($compiled_type_constraint->('.$value.')) { |
56 | $attribute->verify_type_constraint_error($name, '.$value.', $attribute->{type_constraint}); |
57 | }' . "\n"; |
58 | } else { |
59 | $accessor .= |
60 | "\n". |
61 | '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" . |
62 | 'unless ($constraint->check('.$value.')) { |
63 | $attribute->verify_type_constraint_error($name, '.$value.', $attribute->{type_constraint}); |
64 | }' . "\n"; |
65 | } |
66 | } |
67 | |
68 | # if there's nothing left to do for the attribute we can return during |
69 | # this setter |
70 | $accessor .= 'return ' if !$is_weak && !$trigger && !$should_deref; |
71 | |
72 | $accessor .= $self.'->{'.$key.'} = '.$value.';' . "\n"; |
73 | |
74 | if ($is_weak) { |
75 | $accessor .= 'Scalar::Util::weaken('.$self.'->{'.$key.'}) if ref('.$self.'->{'.$key.'});' . "\n"; |
76 | } |
77 | |
78 | if ($trigger) { |
79 | $accessor .= '$trigger->('.$self.', '.$value.');' . "\n"; |
80 | } |
81 | |
82 | $accessor .= "}\n"; |
83 | } |
84 | elsif($type eq 'reader') { |
85 | $accessor .= 'Carp::confess("Cannot assign a value to a read-only accessor") if scalar(@_) >= 2;' . "\n"; |
86 | } |
87 | else{ |
88 | $class->throw_error("Unknown accessor type '$type'"); |
89 | } |
90 | |
91 | if ($attribute->is_lazy) { |
92 | $accessor .= $self.'->{'.$key.'} = '; |
93 | |
94 | $accessor .= $attribute->has_builder |
95 | ? $self.'->$builder' |
96 | : ref($default) eq 'CODE' |
97 | ? '$default->('.$self.')' |
98 | : '$default'; |
99 | $accessor .= ' if !exists '.$self.'->{'.$key.'};' . "\n"; |
100 | } |
101 | |
102 | if ($should_deref) { |
103 | if ($constraint->is_a_type_of('ArrayRef')) { |
104 | $accessor .= 'if (wantarray) { |
105 | return @{ '.$self.'->{'.$key.'} || [] }; |
106 | }'; |
107 | } |
108 | elsif($constraint->is_a_type_of('HashRef')){ |
109 | $accessor .= 'if (wantarray) { |
110 | return %{ '.$self.'->{'.$key.'} || {} }; |
111 | }'; |
112 | } |
113 | else{ |
114 | $class->throw_error("Can not auto de-reference the type constraint " . $constraint->name); |
115 | } |
116 | } |
117 | |
118 | $accessor .= 'return '.$self.'->{'.$key."};\n}"; |
119 | |
120 | #print $accessor, "\n"; |
121 | my $code = eval $accessor; |
122 | $attribute->throw_error($@) if $@; |
123 | |
124 | $class->add_method($method_name => $code); |
125 | return; |
126 | } |
127 | |
128 | sub _install_reader{ |
129 | my $class = shift; |
130 | $class->_install_accessor(@_, 'reader'); |
131 | return; |
132 | } |
133 | |
134 | sub _install_writer{ |
135 | my $class = shift; |
136 | $class->_install_accessor(@_, 'writer'); |
137 | return; |
138 | } |
139 | |
140 | |
141 | sub _install_predicate { |
142 | my (undef, $attribute, $method_name, $class) = @_; |
143 | |
7b133c92 |
144 | my $slot = $attribute->name; |
a41c0667 |
145 | |
7b133c92 |
146 | $class->add_method($method_name => sub{ |
147 | return exists $_[0]->{$slot}; |
148 | }); |
a41c0667 |
149 | return; |
150 | } |
151 | |
152 | sub _install_clearer { |
153 | my (undef, $attribute, $method_name, $class) = @_; |
154 | |
7b133c92 |
155 | my $slot = $attribute->name; |
a41c0667 |
156 | |
7b133c92 |
157 | $class->add_method($method_name => sub{ |
158 | delete $_[0]->{$slot}; |
159 | }); |
a41c0667 |
160 | return; |
161 | } |
162 | |
163 | sub _install_handles { |
164 | my (undef, $attribute, $handles, $class) = @_; |
165 | |
7b133c92 |
166 | my $reader = $attribute->reader || $attribute->accessor |
167 | or $class->throw_error("You must pass a reader method for '".$attribute->name."'"); |
a41c0667 |
168 | |
7b133c92 |
169 | my %handles = $attribute->_canonicalize_handles($handles); |
a41c0667 |
170 | |
7b133c92 |
171 | foreach my $handle_name (keys %handles) { |
172 | my $method_to_call = $handles{$handle_name}; |
173 | |
bc71de54 |
174 | my $code = sub { |
175 | my $instance = shift; |
176 | my $proxy = $instance->$reader(); |
177 | |
178 | my $error = !defined($proxy) ? ' is not defined' |
179 | : ref($proxy) && !blessed($proxy) ? qq{ is not an object (got '$proxy')} |
180 | : undef; |
912fa381 |
181 | if ($error) { |
bc71de54 |
182 | $instance->meta->throw_error( |
183 | "Cannot delegate $handle_name to $method_to_call because " |
184 | . "the value of " |
185 | . $attribute->name |
912fa381 |
186 | . $error |
bc71de54 |
187 | ); |
188 | } |
189 | $proxy->$method_to_call(@_); |
7b133c92 |
190 | }; |
191 | $class->add_method($handle_name => $code); |
a41c0667 |
192 | } |
193 | return; |
194 | } |
195 | |
196 | |
197 | 1; |