bump version for imminent release
[p5sagit/Devel-Declare.git] / lib / Devel / Declare / Context / Simple.pm
1 package Devel::Declare::Context::Simple;
2
3 use strict;
4 use warnings;
5 use Devel::Declare ();
6 use B::Hooks::EndOfScope;
7 use Carp qw/confess/;
8
9 our $VERSION = '0.006012';
10
11 sub new {
12   my $class = shift;
13   bless {@_}, $class;
14 }
15
16 sub init {
17   my $self = shift;
18   @{$self}{ qw(Declarator Offset WarningOnRedefined) } = @_;
19   return $self;
20 }
21
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 }
36
37 sub warning_on_redefine {
38   my $self = shift;
39   return $self->{WarningOnRedefined}
40 }
41
42 sub skip_declarator {
43   my $self = shift;
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);
55 }
56
57 sub skipspace {
58   my $self = shift;
59   $self->inc_offset(Devel::Declare::toke_skipspace($self->offset));
60 }
61
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
74 sub strip_name {
75   my $self = shift;
76   $self->skipspace;
77   if (my $len = Devel::Declare::toke_scan_word( $self->offset, 1 )) {
78     my $linestr = $self->get_linestr();
79     my $name = substr( $linestr, $self->offset, $len );
80     substr( $linestr, $self->offset, $len ) = '';
81     $self->set_linestr($linestr);
82     return $name;
83   }
84
85   $self->skipspace;
86   return;
87 }
88
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
104 sub strip_proto {
105   my $self = shift;
106   $self->skipspace;
107
108   my $linestr = $self->get_linestr();
109   if (substr($linestr, $self->offset, 1) eq '(') {
110     my $length = Devel::Declare::toke_scan_str($self->offset);
111     my $proto = Devel::Declare::get_lex_stuff();
112     Devel::Declare::clear_lex_stuff();
113     $linestr = $self->get_linestr();
114
115     substr($linestr, $self->offset,
116       defined($length) ? $length : length($linestr)) = '';
117     $self->set_linestr($linestr);
118
119     return $proto;
120   }
121   return;
122 }
123
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;
144       # If there's no bareword here, bail
145       confess "failed to parse bareword. found ${linestr}"
146         unless defined $thing;
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
179       confess "couldn't find closing paren for argument. found ${linestr}"
180     }
181   } else {
182     # No parens, so expect a single arg
183     my $thing = $self->strip_name;
184     # If there's no bareword here, bail
185     confess "failed to parse bareword. found ${linestr}"
186       unless defined $thing;
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
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
246 sub get_curstash_name {
247   return Devel::Declare::get_curstash_name;
248 }
249
250 sub shadow {
251   my $self = shift;
252   my $pack = $self->get_curstash_name;
253   Devel::Declare::shadow_sub( $pack . '::' . $self->declarator, $_[0] );
254 }
255
256 sub inject_if_block {
257   my $self   = shift;
258   my $inject = shift;
259   my $before = shift || '';
260
261   $self->skipspace;
262
263   my $linestr = $self->get_linestr;
264   if (substr($linestr, $self->offset, 1) eq '{') {
265     substr($linestr, $self->offset + 1, 0) = $inject;
266     substr($linestr, $self->offset, 0) = $before;
267     $self->set_linestr($linestr);
268     return 1;
269   }
270   return 0;
271 }
272
273 sub scope_injector_call {
274   my $self = shift;
275   my $inject = shift || '';
276   return ' BEGIN { ' . ref($self) . "->inject_scope('${inject}') }; ";
277 }
278
279 sub inject_scope {
280   my $class = shift;
281   my $inject = shift;
282   on_scope_end {
283       my $linestr = Devel::Declare::get_linestr;
284       return unless defined $linestr;
285       my $offset  = Devel::Declare::get_linestr_offset;
286       substr( $linestr, $offset, 0 ) = ';' . $inject;
287       Devel::Declare::set_linestr($linestr);
288   };
289 }
290
291 1;
292 # vi:sw=2 ts=2