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