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 | |
2a464664 |
6 | sub _generate_accessor{ |
4ab51fb0 |
7 | my (undef, $attribute, $class, $type) = @_; |
a41c0667 |
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 | |
ffbbf459 |
18 | my $compiled_type_constraint = $constraint ? $constraint->_compiled_type_constraint : undef; |
a41c0667 |
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" . |
ad087d11 |
27 | "sub {\n"; |
2a464664 |
28 | |
a41c0667 |
29 | if ($type eq 'accessor' || $type eq 'writer') { |
30 | if($type eq 'accessor'){ |
31 | $accessor .= |
32 | '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" . |
33 | 'if (scalar(@_) >= 2) {' . "\n"; |
34 | } |
35 | else{ # writer |
36 | $accessor .= |
37 | '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" . |
2a464664 |
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) { |
ffbbf459 |
45 | if(!$compiled_type_constraint){ |
14d7595a |
46 | Carp::confess("[BUG] Missing compiled type constraint for $constraint"); |
ffbbf459 |
47 | } |
a41c0667 |
48 | if ($should_coerce) { |
49 | $accessor .= |
50 | "\n". |
51 | '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" . |
ffbbf459 |
52 | 'my $val = $constraint->coerce('.$value.');'; |
a41c0667 |
53 | $value = '$val'; |
54 | } |
14d7595a |
55 | $accessor .= |
56 | "\n". |
57 | '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" . |
58 | 'unless ($compiled_type_constraint->('.$value.')) { |
59 | $attribute->verify_type_constraint_error($name, '.$value.', $attribute->{type_constraint}); |
60 | }' . "\n"; |
a41c0667 |
61 | } |
62 | |
63 | # if there's nothing left to do for the attribute we can return during |
64 | # this setter |
65 | $accessor .= 'return ' if !$is_weak && !$trigger && !$should_deref; |
66 | |
67 | $accessor .= $self.'->{'.$key.'} = '.$value.';' . "\n"; |
68 | |
69 | if ($is_weak) { |
70 | $accessor .= 'Scalar::Util::weaken('.$self.'->{'.$key.'}) if ref('.$self.'->{'.$key.'});' . "\n"; |
71 | } |
72 | |
73 | if ($trigger) { |
74 | $accessor .= '$trigger->('.$self.', '.$value.');' . "\n"; |
75 | } |
76 | |
77 | $accessor .= "}\n"; |
78 | } |
79 | elsif($type eq 'reader') { |
80 | $accessor .= 'Carp::confess("Cannot assign a value to a read-only accessor") if scalar(@_) >= 2;' . "\n"; |
81 | } |
82 | else{ |
83 | $class->throw_error("Unknown accessor type '$type'"); |
84 | } |
85 | |
86 | if ($attribute->is_lazy) { |
87 | $accessor .= $self.'->{'.$key.'} = '; |
88 | |
14d7595a |
89 | if($should_coerce && defined($constraint)){ |
90 | $accessor .= '$attribute->_coerce_and_verify('; |
91 | } |
92 | $accessor .= $attribute->has_builder ? $self.'->$builder' |
93 | : ref($default) eq 'CODE' ? '$default->('.$self.')' |
94 | : '$default'; |
95 | |
96 | if($should_coerce && defined $constraint){ |
97 | $accessor .= ')'; |
98 | } |
a41c0667 |
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"; |
2a464664 |
121 | my $code; |
122 | my $e = do{ |
123 | local $@; |
124 | $code = eval $accessor; |
125 | $@; |
126 | }; |
127 | die $e if $e; |
128 | |
ad087d11 |
129 | return $code; |
a41c0667 |
130 | } |
131 | |
2a464664 |
132 | sub _generate_reader{ |
a41c0667 |
133 | my $class = shift; |
2a464664 |
134 | return $class->_generate_accessor(@_, 'reader'); |
a41c0667 |
135 | } |
136 | |
2a464664 |
137 | sub _generate_writer{ |
a41c0667 |
138 | my $class = shift; |
2a464664 |
139 | return $class->_generate_accessor(@_, 'writer'); |
a41c0667 |
140 | } |
141 | |
142 | |
2a464664 |
143 | sub _generate_predicate { |
4ab51fb0 |
144 | my (undef, $attribute, $class) = @_; |
a41c0667 |
145 | |
7b133c92 |
146 | my $slot = $attribute->name; |
4ab51fb0 |
147 | return sub{ |
7b133c92 |
148 | return exists $_[0]->{$slot}; |
4ab51fb0 |
149 | }; |
a41c0667 |
150 | } |
151 | |
2a464664 |
152 | sub _generate_clearer { |
4ab51fb0 |
153 | my (undef, $attribute, $class) = @_; |
a41c0667 |
154 | |
7b133c92 |
155 | my $slot = $attribute->name; |
a41c0667 |
156 | |
4ab51fb0 |
157 | return sub{ |
7b133c92 |
158 | delete $_[0]->{$slot}; |
4ab51fb0 |
159 | }; |
a41c0667 |
160 | } |
161 | |
4ab51fb0 |
162 | sub _generate_delegation{ |
163 | my (undef, $attribute, $class, $reader, $handle_name, $method_to_call) = @_; |
164 | |
165 | return sub { |
166 | my $instance = shift; |
167 | my $proxy = $instance->$reader(); |
168 | |
169 | my $error = !defined($proxy) ? ' is not defined' |
170 | : ref($proxy) && !blessed($proxy) ? qq{ is not an object (got '$proxy')} |
171 | : undef; |
172 | if ($error) { |
173 | $instance->meta->throw_error( |
174 | "Cannot delegate $handle_name to $method_to_call because " |
175 | . "the value of " |
176 | . $attribute->name |
177 | . $error |
178 | ); |
179 | } |
180 | $proxy->$method_to_call(@_); |
181 | }; |
a41c0667 |
182 | } |
183 | |
184 | |
185 | 1; |