Commit | Line | Data |
e7be1784 |
1 | package Devel::Declare::Context::Simple; |
2 | |
e7be1784 |
3 | use strict; |
4 | use warnings; |
616311ae |
5 | use Devel::Declare (); |
6 | use B::Hooks::EndOfScope; |
7 | use Carp qw/confess/; |
e7be1784 |
8 | |
9 | sub new { |
5b27c9b2 |
10 | my $class = shift; |
11 | bless {@_}, $class; |
e7be1784 |
12 | } |
13 | |
14 | sub init { |
5b27c9b2 |
15 | my $self = shift; |
f1b89adc |
16 | @{$self}{ qw(Declarator Offset WarningOnRedefined) } = @_; |
ab449c2e |
17 | return $self; |
e7be1784 |
18 | } |
19 | |
ab449c2e |
20 | sub offset { |
21 | my $self = shift; |
22 | return $self->{Offset} |
23 | } |
24 | |
25 | sub inc_offset { |
26 | my $self = shift; |
27 | $self->{Offset} += shift; |
28 | } |
29 | |
30 | sub declarator { |
31 | my $self = shift; |
32 | return $self->{Declarator} |
33 | } |
e7be1784 |
34 | |
f1b89adc |
35 | sub warning_on_redefine { |
36 | my $self = shift; |
37 | return $self->{WarningOnRedefined} |
38 | } |
39 | |
e7be1784 |
40 | sub skip_declarator { |
5b27c9b2 |
41 | my $self = shift; |
616311ae |
42 | my $decl = $self->declarator; |
43 | my $len = Devel::Declare::toke_scan_word($self->offset, 0); |
44 | confess "Couldn't find declarator '$decl'" |
45 | unless $len; |
46 | |
47 | my $linestr = $self->get_linestr; |
48 | my $name = substr($linestr, $self->offset, $len); |
49 | confess "Expected declarator '$decl', got '${name}'" |
50 | unless $name eq $decl; |
51 | |
52 | $self->inc_offset($len); |
e7be1784 |
53 | } |
54 | |
55 | sub skipspace { |
5b27c9b2 |
56 | my $self = shift; |
ab449c2e |
57 | $self->inc_offset(Devel::Declare::toke_skipspace($self->offset)); |
e7be1784 |
58 | } |
59 | |
7a3f5539 |
60 | sub get_linestr { |
61 | my $self = shift; |
62 | my $line = Devel::Declare::get_linestr(); |
63 | return $line; |
64 | } |
65 | |
66 | sub set_linestr { |
67 | my $self = shift; |
68 | my ($line) = @_; |
69 | Devel::Declare::set_linestr($line); |
70 | } |
71 | |
e7be1784 |
72 | sub strip_name { |
5b27c9b2 |
73 | my $self = shift; |
74 | $self->skipspace; |
75 | if (my $len = Devel::Declare::toke_scan_word( $self->offset, 1 )) { |
7a3f5539 |
76 | my $linestr = $self->get_linestr(); |
5b27c9b2 |
77 | my $name = substr( $linestr, $self->offset, $len ); |
78 | substr( $linestr, $self->offset, $len ) = ''; |
7a3f5539 |
79 | $self->set_linestr($linestr); |
5b27c9b2 |
80 | return $name; |
81 | } |
b0a89632 |
82 | |
83 | $self->skipspace; |
5b27c9b2 |
84 | return; |
e7be1784 |
85 | } |
86 | |
c0f4fa58 |
87 | sub strip_ident { |
88 | my $self = shift; |
89 | $self->skipspace; |
90 | if (my $len = Devel::Declare::toke_scan_ident( $self->offset )) { |
91 | my $linestr = $self->get_linestr(); |
92 | my $ident = substr( $linestr, $self->offset, $len ); |
93 | substr( $linestr, $self->offset, $len ) = ''; |
94 | $self->set_linestr($linestr); |
95 | return $ident; |
96 | } |
97 | |
98 | $self->skipspace; |
99 | return; |
100 | } |
101 | |
e7be1784 |
102 | sub strip_proto { |
5b27c9b2 |
103 | my $self = shift; |
104 | $self->skipspace; |
105 | |
7a3f5539 |
106 | my $linestr = $self->get_linestr(); |
b0a89632 |
107 | if (substr($linestr, $self->offset, 1) eq '(') { |
108 | my $length = Devel::Declare::toke_scan_str($self->offset); |
7a3f5539 |
109 | my $proto = Devel::Declare::get_lex_stuff(); |
5b27c9b2 |
110 | Devel::Declare::clear_lex_stuff(); |
86964fb3 |
111 | $linestr = $self->get_linestr(); |
7a3f5539 |
112 | |
b0a89632 |
113 | substr($linestr, $self->offset, $length) = ''; |
7a3f5539 |
114 | $self->set_linestr($linestr); |
115 | |
5b27c9b2 |
116 | return $proto; |
117 | } |
118 | return; |
e7be1784 |
119 | } |
120 | |
01fadf71 |
121 | sub strip_names_and_args { |
122 | my $self = shift; |
123 | $self->skipspace; |
124 | |
125 | my @args; |
126 | |
127 | my $linestr = $self->get_linestr; |
128 | if (substr($linestr, $self->offset, 1) eq '(') { |
129 | # We had a leading paren, so we will now expect comma separated |
130 | # arguments |
131 | substr($linestr, $self->offset, 1) = ''; |
132 | $self->set_linestr($linestr); |
133 | $self->skipspace; |
134 | |
135 | # At this point we expect to have a comma-separated list of |
136 | # barewords with optional protos afterward, so loop until we |
137 | # run out of comma-separated values |
138 | while (1) { |
139 | # Get the bareword |
140 | my $thing = $self->strip_name; |
79f9fba8 |
141 | # If there's no bareword here, bail |
142 | confess "failed to parse bareword. found ${linestr}" |
143 | unless defined $thing; |
01fadf71 |
144 | |
145 | $linestr = $self->get_linestr; |
146 | if (substr($linestr, $self->offset, 1) eq '(') { |
147 | # This one had a proto, pull it out |
148 | push(@args, [ $thing, $self->strip_proto ]); |
149 | } else { |
150 | # This had no proto, so store it with an undef |
151 | push(@args, [ $thing, undef ]); |
152 | } |
153 | $self->skipspace; |
154 | $linestr = $self->get_linestr; |
155 | |
156 | if (substr($linestr, $self->offset, 1) eq ',') { |
157 | # We found a comma, strip it out and set things up for |
158 | # another iteration |
159 | substr($linestr, $self->offset, 1) = ''; |
160 | $self->set_linestr($linestr); |
161 | $self->skipspace; |
162 | } else { |
163 | # No comma, get outta here |
164 | last; |
165 | } |
166 | } |
167 | |
168 | # look for the final closing paren of the list |
169 | if (substr($linestr, $self->offset, 1) eq ')') { |
170 | substr($linestr, $self->offset, 1) = ''; |
171 | $self->set_linestr($linestr); |
172 | $self->skipspace; |
173 | } |
174 | else { |
175 | # fail if it isn't there |
79f9fba8 |
176 | confess "couldn't find closing paren for argument. found ${linestr}" |
01fadf71 |
177 | } |
178 | } else { |
179 | # No parens, so expect a single arg |
180 | my $thing = $self->strip_name; |
79f9fba8 |
181 | # If there's no bareword here, bail |
182 | confess "failed to parse bareword. found ${linestr}" |
183 | unless defined $thing; |
01fadf71 |
184 | $linestr = $self->get_linestr; |
185 | if (substr($linestr, $self->offset, 1) eq '(') { |
186 | # This one had a proto, pull it out |
187 | push(@args, [ $thing, $self->strip_proto ]); |
188 | } else { |
189 | # This had no proto, so store it with an undef |
190 | push(@args, [ $thing, undef ]); |
191 | } |
192 | } |
193 | |
194 | return \@args; |
195 | } |
196 | |
9de3c057 |
197 | sub strip_attrs { |
198 | my $self = shift; |
199 | $self->skipspace; |
200 | |
201 | my $linestr = Devel::Declare::get_linestr; |
202 | my $attrs = ''; |
203 | |
204 | if (substr($linestr, $self->offset, 1) eq ':') { |
205 | while (substr($linestr, $self->offset, 1) ne '{') { |
206 | if (substr($linestr, $self->offset, 1) eq ':') { |
207 | substr($linestr, $self->offset, 1) = ''; |
208 | Devel::Declare::set_linestr($linestr); |
209 | |
210 | $attrs .= ':'; |
211 | } |
212 | |
213 | $self->skipspace; |
214 | $linestr = Devel::Declare::get_linestr(); |
215 | |
216 | if (my $len = Devel::Declare::toke_scan_word($self->offset, 0)) { |
217 | my $name = substr($linestr, $self->offset, $len); |
218 | substr($linestr, $self->offset, $len) = ''; |
219 | Devel::Declare::set_linestr($linestr); |
220 | |
221 | $attrs .= " ${name}"; |
222 | |
223 | if (substr($linestr, $self->offset, 1) eq '(') { |
224 | my $length = Devel::Declare::toke_scan_str($self->offset); |
225 | my $arg = Devel::Declare::get_lex_stuff(); |
226 | Devel::Declare::clear_lex_stuff(); |
227 | $linestr = Devel::Declare::get_linestr(); |
228 | substr($linestr, $self->offset, $length) = ''; |
229 | Devel::Declare::set_linestr($linestr); |
230 | |
231 | $attrs .= "(${arg})"; |
232 | } |
233 | } |
234 | } |
235 | |
236 | $linestr = Devel::Declare::get_linestr(); |
237 | } |
238 | |
239 | return $attrs; |
240 | } |
241 | |
242 | |
e7be1784 |
243 | sub get_curstash_name { |
5b27c9b2 |
244 | return Devel::Declare::get_curstash_name; |
e7be1784 |
245 | } |
246 | |
247 | sub shadow { |
ab449c2e |
248 | my $self = shift; |
5b27c9b2 |
249 | my $pack = $self->get_curstash_name; |
250 | Devel::Declare::shadow_sub( $pack . '::' . $self->declarator, $_[0] ); |
e7be1784 |
251 | } |
252 | |
253 | sub inject_if_block { |
b0a89632 |
254 | my $self = shift; |
5b27c9b2 |
255 | my $inject = shift; |
b0a89632 |
256 | my $before = shift || ''; |
257 | |
5b27c9b2 |
258 | $self->skipspace; |
b0a89632 |
259 | |
7a3f5539 |
260 | my $linestr = $self->get_linestr; |
b0a89632 |
261 | if (substr($linestr, $self->offset, 1) eq '{') { |
262 | substr($linestr, $self->offset + 1, 0) = $inject; |
263 | substr($linestr, $self->offset, 0) = $before; |
7a3f5539 |
264 | $self->set_linestr($linestr); |
712c5dd1 |
265 | return 1; |
5b27c9b2 |
266 | } |
712c5dd1 |
267 | return 0; |
e7be1784 |
268 | } |
269 | |
270 | sub scope_injector_call { |
b0a89632 |
271 | my $self = shift; |
272 | my $inject = shift || ''; |
273 | return ' BEGIN { ' . ref($self) . "->inject_scope('${inject}') }; "; |
e7be1784 |
274 | } |
275 | |
276 | sub inject_scope { |
b0a89632 |
277 | my $class = shift; |
278 | my $inject = shift; |
279 | on_scope_end { |
5b27c9b2 |
280 | my $linestr = Devel::Declare::get_linestr; |
b0a89632 |
281 | return unless defined $linestr; |
5b27c9b2 |
282 | my $offset = Devel::Declare::get_linestr_offset; |
b0a89632 |
283 | substr( $linestr, $offset, 0 ) = ';' . $inject; |
5b27c9b2 |
284 | Devel::Declare::set_linestr($linestr); |
b0a89632 |
285 | }; |
e7be1784 |
286 | } |
287 | |
288 | 1; |
b0a89632 |
289 | # vi:sw=2 ts=2 |