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