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