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