Commit | Line | Data |
a41c0667 |
1 | package Mouse::Meta::Method::Accessor; |
bc69ee88 |
2 | use Mouse::Util; # enables strict and warnings |
7b133c92 |
3 | use Scalar::Util qw(blessed); |
a41c0667 |
4 | |
f8cbb121 |
5 | sub _inline_slot{ |
6 | my(undef, $self_var, $attr_name) = @_; |
7 | return sprintf '%s->{q{%s}}', $self_var, $attr_name; |
8 | } |
9 | |
2a464664 |
10 | sub _generate_accessor{ |
f8cbb121 |
11 | my ($method_class, $attribute, $class, $type) = @_; |
a41c0667 |
12 | |
13 | my $name = $attribute->name; |
14 | my $default = $attribute->default; |
15 | my $constraint = $attribute->type_constraint; |
16 | my $builder = $attribute->builder; |
17 | my $trigger = $attribute->trigger; |
18 | my $is_weak = $attribute->is_weak_ref; |
19 | my $should_deref = $attribute->should_auto_deref; |
cd00d876 |
20 | my $should_coerce = (defined($constraint) && $constraint->has_coercion && $attribute->should_coerce); |
a41c0667 |
21 | |
cd00d876 |
22 | my $compiled_type_constraint = defined($constraint) ? $constraint->_compiled_type_constraint : undef; |
a41c0667 |
23 | |
24 | my $self = '$_[0]'; |
f8cbb121 |
25 | my $slot = $method_class->_inline_slot($self, $name);; |
a41c0667 |
26 | |
27 | $type ||= 'accessor'; |
28 | |
cd00d876 |
29 | my $accessor = sprintf(qq{#line 1 "%s for %s (%s)"\n}, $type, $name, __FILE__) |
30 | . "sub {\n"; |
2a464664 |
31 | |
a41c0667 |
32 | if ($type eq 'accessor' || $type eq 'writer') { |
33 | if($type eq 'accessor'){ |
34 | $accessor .= |
a41c0667 |
35 | 'if (scalar(@_) >= 2) {' . "\n"; |
36 | } |
37 | else{ # writer |
38 | $accessor .= |
2a464664 |
39 | 'if(@_ < 2){ Carp::confess("Not enough arguments for the writer of '.$name.'") }'. |
a41c0667 |
40 | '{' . "\n"; |
41 | } |
42 | |
43 | my $value = '$_[1]'; |
44 | |
14d7595a |
45 | if (defined $constraint) { |
a41c0667 |
46 | if ($should_coerce) { |
47 | $accessor .= |
48 | "\n". |
ffbbf459 |
49 | 'my $val = $constraint->coerce('.$value.');'; |
a41c0667 |
50 | $value = '$val'; |
51 | } |
14d7595a |
52 | $accessor .= |
53 | "\n". |
cd00d876 |
54 | '$compiled_type_constraint->('.$value.') or |
55 | $attribute->verify_type_constraint_error($name, '.$value.', $constraint);' . "\n"; |
a41c0667 |
56 | } |
57 | |
58 | # if there's nothing left to do for the attribute we can return during |
59 | # this setter |
60 | $accessor .= 'return ' if !$is_weak && !$trigger && !$should_deref; |
61 | |
cd00d876 |
62 | $accessor .= "$slot = $value;\n"; |
a41c0667 |
63 | |
64 | if ($is_weak) { |
cd00d876 |
65 | $accessor .= "Scalar::Util::weaken($slot) if ref $slot;\n"; |
a41c0667 |
66 | } |
67 | |
68 | if ($trigger) { |
69 | $accessor .= '$trigger->('.$self.', '.$value.');' . "\n"; |
70 | } |
71 | |
72 | $accessor .= "}\n"; |
73 | } |
74 | elsif($type eq 'reader') { |
75 | $accessor .= 'Carp::confess("Cannot assign a value to a read-only accessor") if scalar(@_) >= 2;' . "\n"; |
76 | } |
77 | else{ |
78 | $class->throw_error("Unknown accessor type '$type'"); |
79 | } |
80 | |
f774b7de |
81 | if ($attribute->is_lazy) { |
cd00d876 |
82 | my $value; |
a41c0667 |
83 | |
cd00d876 |
84 | if (defined $builder){ |
85 | $value = "$self->\$builder()"; |
86 | } |
87 | elsif (ref($default) eq 'CODE'){ |
88 | $value = "$self->\$default()"; |
89 | } |
90 | else{ |
91 | $value = '$default'; |
14d7595a |
92 | } |
14d7595a |
93 | |
95ecd6f1 |
94 | $accessor .= "if(!exists $slot){\n"; |
cd00d876 |
95 | if($should_coerce){ |
95ecd6f1 |
96 | $accessor .= "$slot = \$constraint->coerce($value)"; |
14d7595a |
97 | } |
95ecd6f1 |
98 | elsif(defined $constraint){ |
99 | $accessor .= "my \$tmp = $value;\n"; |
b6331c0c |
100 | |
95ecd6f1 |
101 | $accessor .= "\$compiled_type_constraint->(\$tmp)"; |
b6331c0c |
102 | $accessor .= " || \$attribute->verify_type_constraint_error(\$name, \$tmp, \$constraint);\n"; |
95ecd6f1 |
103 | $accessor .= "$slot = \$tmp;\n"; |
104 | } |
105 | else{ |
106 | $accessor .= "$slot = $value;\n"; |
107 | } |
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 | |
c3797828 |
125 | #print "# class ", $class->name, "\n", $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 | |
2a464664 |
137 | sub _generate_reader{ |
a41c0667 |
138 | my $class = shift; |
2a464664 |
139 | return $class->_generate_accessor(@_, 'reader'); |
a41c0667 |
140 | } |
141 | |
2a464664 |
142 | sub _generate_writer{ |
a41c0667 |
143 | my $class = shift; |
2a464664 |
144 | return $class->_generate_accessor(@_, 'writer'); |
a41c0667 |
145 | } |
146 | |
147 | |
2a464664 |
148 | sub _generate_predicate { |
4ab51fb0 |
149 | my (undef, $attribute, $class) = @_; |
a41c0667 |
150 | |
7b133c92 |
151 | my $slot = $attribute->name; |
4ab51fb0 |
152 | return sub{ |
7b133c92 |
153 | return exists $_[0]->{$slot}; |
4ab51fb0 |
154 | }; |
a41c0667 |
155 | } |
156 | |
2a464664 |
157 | sub _generate_clearer { |
4ab51fb0 |
158 | my (undef, $attribute, $class) = @_; |
a41c0667 |
159 | |
7b133c92 |
160 | my $slot = $attribute->name; |
a41c0667 |
161 | |
4ab51fb0 |
162 | return sub{ |
7b133c92 |
163 | delete $_[0]->{$slot}; |
4ab51fb0 |
164 | }; |
a41c0667 |
165 | } |
166 | |
a41c0667 |
167 | 1; |
0126c27c |
168 | __END__ |
a25ca8d6 |
169 | |
170 | =head1 NAME |
171 | |
172 | Mouse::Meta::Method::Accessor - A Mouse method generator for accessors |
173 | |
174 | =head1 VERSION |
175 | |
6e168432 |
176 | This document describes Mouse version 0.40_05 |
a25ca8d6 |
177 | |
178 | =head1 SEE ALSO |
179 | |
180 | L<Moose::Meta::Method::Accessor> |
181 | |
182 | =cut |