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