Commit | Line | Data |
a41c0667 |
1 | package Mouse::Meta::Method::Accessor; |
3821b191 |
2 | use Mouse::Util qw(:meta); # enables strict and warnings |
a41c0667 |
3 | |
f8cbb121 |
4 | sub _inline_slot{ |
5 | my(undef, $self_var, $attr_name) = @_; |
6 | return sprintf '%s->{q{%s}}', $self_var, $attr_name; |
7 | } |
8 | |
bb4204b1 |
9 | sub _generate_accessor_any{ |
10 | my($method_class, $type, $attribute, $class) = @_; |
a41c0667 |
11 | |
12 | my $name = $attribute->name; |
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 | |
23 | my $self = '$_[0]'; |
f8cbb121 |
24 | my $slot = $method_class->_inline_slot($self, $name);; |
a41c0667 |
25 | |
f35b50f2 |
26 | my $accessor = sprintf(qq{package %s;\n#line 1 "%s-accessor for %s (%s)"\n}, $class->name, $type, $name, __FILE__) |
cd00d876 |
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 .= |
2a464664 |
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 |
52 | $attribute->verify_type_constraint_error($name, '.$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 | |
cd00d876 |
59 | $accessor .= "$slot = $value;\n"; |
a41c0667 |
60 | |
61 | if ($is_weak) { |
cd00d876 |
62 | $accessor .= "Scalar::Util::weaken($slot) if ref $slot;\n"; |
a41c0667 |
63 | } |
64 | |
65 | if ($trigger) { |
66 | $accessor .= '$trigger->('.$self.', '.$value.');' . "\n"; |
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){ |
82 | $value = "$self->\$builder()"; |
83 | } |
84 | elsif (ref($default) eq 'CODE'){ |
85 | $value = "$self->\$default()"; |
86 | } |
87 | else{ |
88 | $value = '$default'; |
14d7595a |
89 | } |
14d7595a |
90 | |
95ecd6f1 |
91 | $accessor .= "if(!exists $slot){\n"; |
cd00d876 |
92 | if($should_coerce){ |
95ecd6f1 |
93 | $accessor .= "$slot = \$constraint->coerce($value)"; |
14d7595a |
94 | } |
95ecd6f1 |
95 | elsif(defined $constraint){ |
96 | $accessor .= "my \$tmp = $value;\n"; |
b6331c0c |
97 | |
95ecd6f1 |
98 | $accessor .= "\$compiled_type_constraint->(\$tmp)"; |
b6331c0c |
99 | $accessor .= " || \$attribute->verify_type_constraint_error(\$name, \$tmp, \$constraint);\n"; |
95ecd6f1 |
100 | $accessor .= "$slot = \$tmp;\n"; |
101 | } |
102 | else{ |
103 | $accessor .= "$slot = $value;\n"; |
104 | } |
3f2c3dc7 |
105 | if ($is_weak) { |
106 | $accessor .= "Scalar::Util::weaken($slot) if ref $slot;\n"; |
107 | } |
95ecd6f1 |
108 | $accessor .= "}\n"; |
a41c0667 |
109 | } |
110 | |
111 | if ($should_deref) { |
112 | if ($constraint->is_a_type_of('ArrayRef')) { |
cd00d876 |
113 | $accessor .= "return \@{ $slot || [] } if wantarray;\n"; |
a41c0667 |
114 | } |
115 | elsif($constraint->is_a_type_of('HashRef')){ |
cd00d876 |
116 | $accessor .= "return \%{ $slot || {} } if wantarray;\n"; |
a41c0667 |
117 | } |
118 | else{ |
119 | $class->throw_error("Can not auto de-reference the type constraint " . $constraint->name); |
120 | } |
121 | } |
122 | |
cd00d876 |
123 | $accessor .= "return $slot;\n}\n"; |
a41c0667 |
124 | |
8aba926d |
125 | #print $accessor, "\n"; |
2a464664 |
126 | my $code; |
127 | my $e = do{ |
128 | local $@; |
129 | $code = eval $accessor; |
130 | $@; |
131 | }; |
132 | die $e if $e; |
133 | |
ad087d11 |
134 | return $code; |
a41c0667 |
135 | } |
136 | |
bb4204b1 |
137 | sub _generate_accessor{ |
a41c0667 |
138 | my $class = shift; |
bb4204b1 |
139 | return $class->_generate_accessor_any(rw => @_); |
a41c0667 |
140 | } |
141 | |
bb4204b1 |
142 | sub _generate_reader { |
a41c0667 |
143 | my $class = shift; |
bb4204b1 |
144 | return $class->_generate_accessor_any(ro => @_); |
a41c0667 |
145 | } |
146 | |
bb4204b1 |
147 | sub _generate_writer { |
148 | my $class = shift; |
149 | return $class->_generate_accessor_any(wo => @_); |
150 | } |
a41c0667 |
151 | |
2a464664 |
152 | sub _generate_predicate { |
4ab51fb0 |
153 | my (undef, $attribute, $class) = @_; |
a41c0667 |
154 | |
7b133c92 |
155 | my $slot = $attribute->name; |
4ab51fb0 |
156 | return sub{ |
7b133c92 |
157 | return exists $_[0]->{$slot}; |
4ab51fb0 |
158 | }; |
a41c0667 |
159 | } |
160 | |
2a464664 |
161 | sub _generate_clearer { |
4ab51fb0 |
162 | my (undef, $attribute, $class) = @_; |
a41c0667 |
163 | |
7b133c92 |
164 | my $slot = $attribute->name; |
bb4204b1 |
165 | return sub{ |
7b133c92 |
166 | delete $_[0]->{$slot}; |
4ab51fb0 |
167 | }; |
a41c0667 |
168 | } |
169 | |
a41c0667 |
170 | 1; |
0126c27c |
171 | __END__ |
a25ca8d6 |
172 | |
173 | =head1 NAME |
174 | |
175 | Mouse::Meta::Method::Accessor - A Mouse method generator for accessors |
176 | |
177 | =head1 VERSION |
178 | |
a4cbb3cb |
179 | This document describes Mouse version 0.44 |
a25ca8d6 |
180 | |
181 | =head1 SEE ALSO |
182 | |
183 | L<Moose::Meta::Method::Accessor> |
184 | |
185 | =cut |