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 | |
8449c31f |
113 | substr($linestr, $self->offset, |
114 | defined($length) ? $length : length($linestr)) = ''; |
7a3f5539 |
115 | $self->set_linestr($linestr); |
116 | |
5b27c9b2 |
117 | return $proto; |
118 | } |
119 | return; |
e7be1784 |
120 | } |
121 | |
01fadf71 |
122 | sub strip_names_and_args { |
123 | my $self = shift; |
124 | $self->skipspace; |
125 | |
126 | my @args; |
127 | |
128 | my $linestr = $self->get_linestr; |
129 | if (substr($linestr, $self->offset, 1) eq '(') { |
130 | # We had a leading paren, so we will now expect comma separated |
131 | # arguments |
132 | substr($linestr, $self->offset, 1) = ''; |
133 | $self->set_linestr($linestr); |
134 | $self->skipspace; |
135 | |
136 | # At this point we expect to have a comma-separated list of |
137 | # barewords with optional protos afterward, so loop until we |
138 | # run out of comma-separated values |
139 | while (1) { |
140 | # Get the bareword |
141 | my $thing = $self->strip_name; |
79f9fba8 |
142 | # If there's no bareword here, bail |
143 | confess "failed to parse bareword. found ${linestr}" |
144 | unless defined $thing; |
01fadf71 |
145 | |
146 | $linestr = $self->get_linestr; |
147 | if (substr($linestr, $self->offset, 1) eq '(') { |
148 | # This one had a proto, pull it out |
149 | push(@args, [ $thing, $self->strip_proto ]); |
150 | } else { |
151 | # This had no proto, so store it with an undef |
152 | push(@args, [ $thing, undef ]); |
153 | } |
154 | $self->skipspace; |
155 | $linestr = $self->get_linestr; |
156 | |
157 | if (substr($linestr, $self->offset, 1) eq ',') { |
158 | # We found a comma, strip it out and set things up for |
159 | # another iteration |
160 | substr($linestr, $self->offset, 1) = ''; |
161 | $self->set_linestr($linestr); |
162 | $self->skipspace; |
163 | } else { |
164 | # No comma, get outta here |
165 | last; |
166 | } |
167 | } |
168 | |
169 | # look for the final closing paren of the list |
170 | if (substr($linestr, $self->offset, 1) eq ')') { |
171 | substr($linestr, $self->offset, 1) = ''; |
172 | $self->set_linestr($linestr); |
173 | $self->skipspace; |
174 | } |
175 | else { |
176 | # fail if it isn't there |
79f9fba8 |
177 | confess "couldn't find closing paren for argument. found ${linestr}" |
01fadf71 |
178 | } |
179 | } else { |
180 | # No parens, so expect a single arg |
181 | my $thing = $self->strip_name; |
79f9fba8 |
182 | # If there's no bareword here, bail |
183 | confess "failed to parse bareword. found ${linestr}" |
184 | unless defined $thing; |
01fadf71 |
185 | $linestr = $self->get_linestr; |
186 | if (substr($linestr, $self->offset, 1) eq '(') { |
187 | # This one had a proto, pull it out |
188 | push(@args, [ $thing, $self->strip_proto ]); |
189 | } else { |
190 | # This had no proto, so store it with an undef |
191 | push(@args, [ $thing, undef ]); |
192 | } |
193 | } |
194 | |
195 | return \@args; |
196 | } |
197 | |
9de3c057 |
198 | sub strip_attrs { |
199 | my $self = shift; |
200 | $self->skipspace; |
201 | |
202 | my $linestr = Devel::Declare::get_linestr; |
203 | my $attrs = ''; |
204 | |
205 | if (substr($linestr, $self->offset, 1) eq ':') { |
206 | while (substr($linestr, $self->offset, 1) ne '{') { |
207 | if (substr($linestr, $self->offset, 1) eq ':') { |
208 | substr($linestr, $self->offset, 1) = ''; |
209 | Devel::Declare::set_linestr($linestr); |
210 | |
211 | $attrs .= ':'; |
212 | } |
213 | |
214 | $self->skipspace; |
215 | $linestr = Devel::Declare::get_linestr(); |
216 | |
217 | if (my $len = Devel::Declare::toke_scan_word($self->offset, 0)) { |
218 | my $name = substr($linestr, $self->offset, $len); |
219 | substr($linestr, $self->offset, $len) = ''; |
220 | Devel::Declare::set_linestr($linestr); |
221 | |
222 | $attrs .= " ${name}"; |
223 | |
224 | if (substr($linestr, $self->offset, 1) eq '(') { |
225 | my $length = Devel::Declare::toke_scan_str($self->offset); |
226 | my $arg = Devel::Declare::get_lex_stuff(); |
227 | Devel::Declare::clear_lex_stuff(); |
228 | $linestr = Devel::Declare::get_linestr(); |
229 | substr($linestr, $self->offset, $length) = ''; |
230 | Devel::Declare::set_linestr($linestr); |
231 | |
232 | $attrs .= "(${arg})"; |
233 | } |
234 | } |
235 | } |
236 | |
237 | $linestr = Devel::Declare::get_linestr(); |
238 | } |
239 | |
240 | return $attrs; |
241 | } |
242 | |
243 | |
e7be1784 |
244 | sub get_curstash_name { |
5b27c9b2 |
245 | return Devel::Declare::get_curstash_name; |
e7be1784 |
246 | } |
247 | |
248 | sub shadow { |
ab449c2e |
249 | my $self = shift; |
5b27c9b2 |
250 | my $pack = $self->get_curstash_name; |
251 | Devel::Declare::shadow_sub( $pack . '::' . $self->declarator, $_[0] ); |
e7be1784 |
252 | } |
253 | |
254 | sub inject_if_block { |
b0a89632 |
255 | my $self = shift; |
5b27c9b2 |
256 | my $inject = shift; |
b0a89632 |
257 | my $before = shift || ''; |
258 | |
5b27c9b2 |
259 | $self->skipspace; |
b0a89632 |
260 | |
7a3f5539 |
261 | my $linestr = $self->get_linestr; |
b0a89632 |
262 | if (substr($linestr, $self->offset, 1) eq '{') { |
263 | substr($linestr, $self->offset + 1, 0) = $inject; |
264 | substr($linestr, $self->offset, 0) = $before; |
7a3f5539 |
265 | $self->set_linestr($linestr); |
712c5dd1 |
266 | return 1; |
5b27c9b2 |
267 | } |
712c5dd1 |
268 | return 0; |
e7be1784 |
269 | } |
270 | |
271 | sub scope_injector_call { |
b0a89632 |
272 | my $self = shift; |
273 | my $inject = shift || ''; |
274 | return ' BEGIN { ' . ref($self) . "->inject_scope('${inject}') }; "; |
e7be1784 |
275 | } |
276 | |
277 | sub inject_scope { |
b0a89632 |
278 | my $class = shift; |
279 | my $inject = shift; |
280 | on_scope_end { |
5b27c9b2 |
281 | my $linestr = Devel::Declare::get_linestr; |
b0a89632 |
282 | return unless defined $linestr; |
5b27c9b2 |
283 | my $offset = Devel::Declare::get_linestr_offset; |
b0a89632 |
284 | substr( $linestr, $offset, 0 ) = ';' . $inject; |
5b27c9b2 |
285 | Devel::Declare::set_linestr($linestr); |
b0a89632 |
286 | }; |
e7be1784 |
287 | } |
288 | |
289 | 1; |
b0a89632 |
290 | # vi:sw=2 ts=2 |