Commit | Line | Data |
a41c0667 |
1 | package Mouse::Meta::Method::Accessor; |
3821b191 |
2 | use Mouse::Util qw(:meta); # enables strict and warnings |
f031f4d5 |
3 | |
401ad01d |
4 | use constant _MOUSE_DEBUG => $ENV{MOUSE_DEBUG} ? 1 : 0; |
68ad9d66 |
5 | |
f031f4d5 |
6 | sub _inline_slot{ |
7 | my(undef, $self_var, $attr_name) = @_; |
8 | return sprintf '%s->{q{%s}}', $self_var, $attr_name; |
9 | } |
f8cbb121 |
10 | |
bb4204b1 |
11 | sub _generate_accessor_any{ |
12 | my($method_class, $type, $attribute, $class) = @_; |
a41c0667 |
13 | |
f031f4d5 |
14 | my $name = $attribute->name; |
a41c0667 |
15 | my $default = $attribute->default; |
16 | my $constraint = $attribute->type_constraint; |
17 | my $builder = $attribute->builder; |
18 | my $trigger = $attribute->trigger; |
19 | my $is_weak = $attribute->is_weak_ref; |
20 | my $should_deref = $attribute->should_auto_deref; |
401ad01d |
21 | my $should_coerce = (defined($constraint) |
22 | && $constraint->has_coercion |
23 | && $attribute->should_coerce); |
a41c0667 |
24 | |
401ad01d |
25 | my $compiled_type_constraint = defined($constraint) |
26 | ? $constraint->_compiled_type_constraint |
27 | : undef; |
a41c0667 |
28 | |
f031f4d5 |
29 | my $self = '$_[0]'; |
30 | my $slot = $method_class->_inline_slot($self, $name);; |
a41c0667 |
31 | |
f031f4d5 |
32 | my $accessor = sprintf(qq{package %s;\n#line 1 "%s-accessor for %s (%s)"\n}, $class->name, $type, $name, __FILE__) |
33 | . "sub {\n"; |
2a464664 |
34 | |
bb4204b1 |
35 | if ($type eq 'rw' || $type eq 'wo') { |
36 | if($type eq 'rw'){ |
401ad01d |
37 | $accessor .= |
a41c0667 |
38 | 'if (scalar(@_) >= 2) {' . "\n"; |
39 | } |
40 | else{ # writer |
401ad01d |
41 | $accessor .= |
f4118476 |
42 | 'if(@_ < 2){ Carp::confess("Not enough arguments for the writer of $name") }'. |
a41c0667 |
43 | '{' . "\n"; |
44 | } |
401ad01d |
45 | |
a41c0667 |
46 | my $value = '$_[1]'; |
47 | |
14d7595a |
48 | if (defined $constraint) { |
a41c0667 |
49 | if ($should_coerce) { |
50 | $accessor .= |
51 | "\n". |
ffbbf459 |
52 | 'my $val = $constraint->coerce('.$value.');'; |
a41c0667 |
53 | $value = '$val'; |
54 | } |
401ad01d |
55 | $accessor .= |
14d7595a |
56 | "\n". |
cd00d876 |
57 | '$compiled_type_constraint->('.$value.') or |
da23cd4a |
58 | $attribute->_throw_type_constraint_error('.$value.', $constraint);' . "\n"; |
a41c0667 |
59 | } |
60 | |
61 | # if there's nothing left to do for the attribute we can return during |
62 | # this setter |
63 | $accessor .= 'return ' if !$is_weak && !$trigger && !$should_deref; |
64 | |
f031f4d5 |
65 | $accessor .= "$slot = $value;\n"; |
a41c0667 |
66 | |
67 | if ($is_weak) { |
f031f4d5 |
68 | $accessor .= "Scalar::Util::weaken($slot) if ref $slot;\n"; |
a41c0667 |
69 | } |
70 | |
71 | if ($trigger) { |
f031f4d5 |
72 | $accessor .= '$trigger->('.$self.', '.$value.');' . "\n"; |
a41c0667 |
73 | } |
74 | |
75 | $accessor .= "}\n"; |
76 | } |
bb4204b1 |
77 | elsif($type eq 'ro') { |
f4118476 |
78 | $accessor .= 'Carp::confess("Cannot assign a value to a read-only accessor of $name") if scalar(@_) >= 2;' . "\n"; |
a41c0667 |
79 | } |
80 | else{ |
81 | $class->throw_error("Unknown accessor type '$type'"); |
82 | } |
83 | |
52b9f5fa |
84 | if ($attribute->is_lazy and $type ne 'wo') { |
cd00d876 |
85 | my $value; |
a41c0667 |
86 | |
cd00d876 |
87 | if (defined $builder){ |
f031f4d5 |
88 | $value = "$self->\$builder()"; |
cd00d876 |
89 | } |
90 | elsif (ref($default) eq 'CODE'){ |
f031f4d5 |
91 | $value = "$self->\$default()"; |
cd00d876 |
92 | } |
93 | else{ |
94 | $value = '$default'; |
14d7595a |
95 | } |
14d7595a |
96 | |
52b9f5fa |
97 | $accessor .= "els" if $type eq 'rw'; |
f031f4d5 |
98 | $accessor .= "if(!exists $slot){\n"; |
cd00d876 |
99 | if($should_coerce){ |
f031f4d5 |
100 | $accessor .= "$slot = \$constraint->coerce($value)"; |
14d7595a |
101 | } |
95ecd6f1 |
102 | elsif(defined $constraint){ |
103 | $accessor .= "my \$tmp = $value;\n"; |
104 | $accessor .= "\$compiled_type_constraint->(\$tmp)"; |
da23cd4a |
105 | $accessor .= " || \$attribute->_throw_type_constraint_error(\$tmp, \$constraint);\n"; |
f031f4d5 |
106 | $accessor .= "$slot = \$tmp;\n"; |
107 | } |
108 | else{ |
109 | $accessor .= "$slot = $value;\n"; |
95ecd6f1 |
110 | } |
3f2c3dc7 |
111 | if ($is_weak) { |
f031f4d5 |
112 | $accessor .= "Scalar::Util::weaken($slot) if ref $slot;\n"; |
3f2c3dc7 |
113 | } |
95ecd6f1 |
114 | $accessor .= "}\n"; |
a41c0667 |
115 | } |
116 | |
117 | if ($should_deref) { |
118 | if ($constraint->is_a_type_of('ArrayRef')) { |
cd00d876 |
119 | $accessor .= "return \@{ $slot || [] } if wantarray;\n"; |
a41c0667 |
120 | } |
121 | elsif($constraint->is_a_type_of('HashRef')){ |
cd00d876 |
122 | $accessor .= "return \%{ $slot || {} } if wantarray;\n"; |
a41c0667 |
123 | } |
124 | else{ |
125 | $class->throw_error("Can not auto de-reference the type constraint " . $constraint->name); |
126 | } |
127 | } |
128 | |
cd00d876 |
129 | $accessor .= "return $slot;\n}\n"; |
a41c0667 |
130 | |
68ad9d66 |
131 | warn $accessor if _MOUSE_DEBUG; |
2a464664 |
132 | my $code; |
133 | my $e = do{ |
134 | local $@; |
135 | $code = eval $accessor; |
136 | $@; |
137 | }; |
138 | die $e if $e; |
139 | |
ad087d11 |
140 | return $code; |
a41c0667 |
141 | } |
142 | |
bb4204b1 |
143 | sub _generate_accessor{ |
230dd14a |
144 | #my($self, $attribute, $metaclass) = @_; |
145 | my $self = shift; |
146 | return $self->_generate_accessor_any(rw => @_); |
a41c0667 |
147 | } |
148 | |
bb4204b1 |
149 | sub _generate_reader { |
230dd14a |
150 | #my($self, $attribute, $metaclass) = @_; |
151 | my $self = shift; |
152 | return $self->_generate_accessor_any(ro => @_); |
a41c0667 |
153 | } |
154 | |
bb4204b1 |
155 | sub _generate_writer { |
230dd14a |
156 | #my($self, $attribute, $metaclass) = @_; |
157 | my $self = shift; |
158 | return $self->_generate_accessor_any(wo => @_); |
bb4204b1 |
159 | } |
a41c0667 |
160 | |
2a464664 |
161 | sub _generate_predicate { |
230dd14a |
162 | #my($self, $attribute, $metaclass) = @_; |
163 | my(undef, $attribute) = @_; |
a41c0667 |
164 | |
7b133c92 |
165 | my $slot = $attribute->name; |
4ab51fb0 |
166 | return sub{ |
7b133c92 |
167 | return exists $_[0]->{$slot}; |
4ab51fb0 |
168 | }; |
a41c0667 |
169 | } |
170 | |
2a464664 |
171 | sub _generate_clearer { |
230dd14a |
172 | #my($self, $attribute, $metaclass) = @_; |
173 | my(undef, $attribute) = @_; |
a41c0667 |
174 | |
7b133c92 |
175 | my $slot = $attribute->name; |
bb4204b1 |
176 | return sub{ |
7b133c92 |
177 | delete $_[0]->{$slot}; |
4ab51fb0 |
178 | }; |
a41c0667 |
179 | } |
180 | |
a41c0667 |
181 | 1; |
0126c27c |
182 | __END__ |
a25ca8d6 |
183 | |
184 | =head1 NAME |
185 | |
186 | Mouse::Meta::Method::Accessor - A Mouse method generator for accessors |
187 | |
188 | =head1 VERSION |
189 | |
5b3e7678 |
190 | This document describes Mouse version 0.89 |
a25ca8d6 |
191 | |
192 | =head1 SEE ALSO |
193 | |
194 | L<Moose::Meta::Method::Accessor> |
195 | |
196 | =cut |