File Coverage

blib/lib/Catalyst/View/ByCode/Declare.pm
Criterion Covered Total %
statement 103 132 78.0
branch 17 34 50.0
condition 4 4 100.0
subroutine 25 28 89.2
pod 0 19 0.0
total 149 217 68.6


line stmt bran cond sub pod time code
1             package Catalyst::View::ByCode::Declare;
2             $Catalyst::View::ByCode::Declare::VERSION = '0.26';
3 3     3   12 use strict;
  3         3  
  3         98  
4 3     3   12 use warnings;
  3         3  
  3         86  
5              
6 3     3   12 use Devel::Declare();
  3         4  
  3         44  
7 3     3   1517 use B::Hooks::EndOfScope;
  3         30383  
  3         16  
8              
9             ###### Thanks #####################################################
10             # #
11             # Thanks to Kang-min Liu for doing 'Markapl.pm' #
12             # most of the concepts here are 'borrowed' from this great module #
13             # sorry for copying instead of thinking. #
14             # #
15             #################################################### /Thanks ######
16              
17             # these variables will get local()'ized during a parser run
18             our ($Declarator, $Offset);
19              
20             ####################################### SCANNERs
21             #
22             # skip space symbols (if any)
23             #
24             sub skip_space {
25 71     71 0 96 $Offset += Devel::Declare::toke_skipspace($Offset);
26             }
27              
28             #
29             # skip the sub_name just parsed (is still in $Declarator)
30             #
31             sub skip_declarator {
32 19     19 0 43 $Offset += Devel::Declare::toke_move_past_token($Offset);
33             }
34              
35             #
36             # skip a word and return it -- or undef if no word found
37             #
38             sub skip_word {
39 1     1 0 2 skip_space;
40            
41 1 50       4 if (my $length = Devel::Declare::toke_scan_word($Offset, 1)) {
42 1         3 my $linestr = Devel::Declare::get_linestr;
43 1         1 $Offset += $length;
44 1         4 return substr($linestr,$Offset-$length, $length);
45             }
46 0         0 return;
47             }
48              
49             #
50             # non-destructively read next character
51             #
52             sub next_char {
53 69     69 0 76 skip_space;
54 69         87 my $linestr = Devel::Declare::get_linestr;
55 69         193 return substr($linestr, $Offset, 1);
56             }
57              
58             #
59             # non-destructively read next word (=token)
60             #
61             sub next_word {
62 1     1 0 3 skip_space;
63            
64 1 50       4 if (my $length = Devel::Declare::toke_scan_word($Offset, 1)) {
65 1         3 my $linestr = Devel::Declare::get_linestr;
66 1         9 return substr($linestr, $Offset, $length);
67             }
68 0         0 return '';
69             }
70              
71             #
72             # destructively read a valid name if possible
73             #
74             sub strip_name {
75 0     0 0 0 skip_space;
76            
77 0 0       0 if (my $length = Devel::Declare::toke_scan_word($Offset, 1)) {
78 0         0 return inject('', $length);
79             }
80 0         0 return;
81             }
82              
83             #
84             # destructively read a possibly dash-separated name
85             #
86             sub strip_css_name {
87 0     0 0 0 my $name = strip_name;
88 0         0 while (next_char eq '-') {
89 0         0 inject('', 1);
90 0         0 $name .= '-';
91 0 0       0 if (next_char =~ m{\A[a-zA-Z0-9_]}xms) {
92 0         0 $name .= strip_name;
93             }
94             }
95            
96 0         0 return $name;
97             }
98              
99             #
100             # read a prototype-like definition (looks like '(...)')
101             #
102             sub strip_proto {
103 18 100   18 0 20 if (next_char eq '(') {
104 7         73 my $length = Devel::Declare::toke_scan_str($Offset);
105 7         20 my $proto = Devel::Declare::get_lex_stuff();
106 7         10 Devel::Declare::clear_lex_stuff();
107 7         12 inject('', $length);
108 7         14 return $proto;
109             }
110 11         13 return;
111             }
112              
113             #
114             # helper: check if a declarator is in a hash key
115             #
116             sub declarator_is_hash_key {
117 19     19 0 21 my $offset_before = $Offset;
118 19         27 skip_declarator;
119            
120             # This means that current declarator is in a hash key.
121             # Don't shadow sub in this case
122 19         45 return ($Offset == $offset_before);
123             }
124              
125             #
126             # parse: id? ('.' class)* ( '(' .* ')' )?
127             #
128             sub parse_tag_declaration {
129             # collect ID, class and (...) staff here...
130             # for later injection into top of block
131 18     18 0 16 my $extras = '';
132            
133             # check for an indentifier (ID)
134 18 50       30 if (next_char =~ m{\A[a-zA-Z0-9_]}xms) {
135             # looks like an ID
136 0         0 my $name = strip_css_name;
137 0         0 $extras .= " id => '$name',";
138             }
139            
140             # check for '.class' as often as possible
141 18         18 my @class;
142 18         21 while (next_char eq '.') {
143             # found '.' -- eliminate it and read name
144 0         0 inject('',1);
145 0         0 push @class, strip_css_name;
146             }
147 18 50       30 if (scalar(@class)) {
148 0         0 $extras .= " class => '" . join(' ', @class) . "',";
149             }
150            
151             #
152             # see if we have (...) stuff
153             #
154 18         31 my $proto = strip_proto;
155 18 100       27 if ($proto) {
156             ###
157             ### BAD HACK: multiline (...) things will otherwise fail
158             ### must be very tolerant!
159             ###
160 7         42 $proto =~ s{\s*[\r\n]\s*}{}xmsg;
161            
162 7         16 $extras .= " $proto,";
163             }
164            
165 18 100       64 if ($extras) {
166 7 50       10 if (next_char eq '{') {
167             # block present -- add after block
168 7         13 inject_after_block($extras);
169             } else {
170             # no block present -- fake a block and add after it
171 0         0 inject(" {} $extras");
172             }
173             }
174             }
175              
176             ####################################### INJECTORs
177             #
178             # inject something at current position
179             # - with optional length
180             # - at optional offset
181             # returns thing at inserted position before
182             #
183             sub inject {
184 15     15 0 11 my $inject = shift;
185 15   100     38 my $length = shift || 0;
186 15   100     40 my $offset = shift || 0;
187              
188 15         64 my $linestr = Devel::Declare::get_linestr;
189 15         20 my $previous = substr($linestr, $Offset+$offset, $length);
190 15         18 substr($linestr, $Offset+$offset, $length) = $inject;
191 15         19 Devel::Declare::set_linestr($linestr);
192            
193 15         19 return $previous;
194             }
195              
196             #
197             # inject something at top of a '{ ...}' block
198             # returns: boolean depending on success
199             #
200             sub inject_into_block {
201 7     7 0 7 my $inject = shift;
202            
203 7 50       9 if (next_char eq '{') {
204 7         11 inject($inject,0,1);
205 7         38 return 1;
206             }
207 0         0 return 0;
208             }
209              
210             #
211             # inject something before a '{ ...}' block
212             # returns: boolean depending on success
213             #
214             sub inject_before_block {
215 0     0 0 0 my $inject = shift;
216            
217 0 0       0 if (next_char eq '{') {
218 0         0 inject($inject);
219 0         0 return 1;
220             }
221            
222 0         0 return 0;
223             }
224              
225             #
226             # inject something after scope as soon as '}' is reached
227             #
228             our @thing_to_inject;
229              
230             sub inject_after_block { # called from a parser
231 7     7 0 6 my $inject = shift;
232 7         10 push @thing_to_inject, $inject;
233            
234             # force calling the sub below as soon as block's scope is done.
235 7         11 inject_into_block(qq{ BEGIN { Catalyst::View::ByCode::Declare::post_block_inject }; });
236             }
237              
238             sub post_block_inject { # called from a BEGIN {} block at scope start
239 7     7 0 237 my $inject = pop @thing_to_inject;
240              
241             on_scope_end {
242 7     7   173 my $linestr = Devel::Declare::get_linestr;
243 7         14 my $offset = Devel::Declare::get_linestr_offset;
244            
245 7         12 substr($linestr, $offset, 0) = $inject;
246 7         18 Devel::Declare::set_linestr($linestr);
247 7         42 };
248             }
249              
250             ####################################### ADD SUBs
251             #
252             # put modified sub into requested package
253             #
254             sub install_sub {
255 1     1 0 2 my $sub_name = shift;
256 1         1 my $code = shift;
257 1         2 my $add_to_array = shift;
258              
259 1         2 my $package = Devel::Declare::get_curstash_name;
260              
261 3     3   3131 no strict 'refs';
  3         6  
  3         138  
262 3     3   15 no warnings 'redefine';
  3         5  
  3         1292  
263             ### deleting does not warn, but aliassing is still in action
264             # http://www252.pair.com/comdog/mastering_perl/Chapters/08.symbol_tables.html
265             # delete ${"$package\::"}{$sub_name};
266 1         1 *{"$package\::$sub_name"} = $code;
  1         4  
267             # cannot modify: *{"$package\::$sub_name"}{CODE} = $code;
268 1         1 push @{"$package\::EXPORT"}, $sub_name;
  1         4  
269 1 50       3 push @{"$package\::$add_to_array"}, $sub_name if ($add_to_array);
  1         5  
270             ### right?? push @{"$package\::$EXPORT_TAGS\{default\}"}, $sub_name;
271             }
272              
273             ####################################### PARSERs
274             #
275             # generate a tag-parser
276             # initiated after compiling a tag subroutine
277             # parses: tag id? ('.' class)* ( '(' .* ')' )?
278             # injects some magic after the block following the declaration
279             #
280             sub tag_parser {
281             return sub {
282 18     18   7860 local ($Declarator, $Offset) = @_;
283 18 50       31 return if (declarator_is_hash_key);
284            
285             # parse the id.class() {} declaration
286 18         32 parse_tag_declaration;
287 277     277 0 1143 };
288             }
289              
290             #
291             # add a tag parser
292             #
293             sub add_tag_parser {
294 1     1 0 2 my $sub_name = shift;
295            
296 1         3 my $package = Devel::Declare::get_curstash_name;
297            
298 1         4 Devel::Declare->setup_for($package,
299             {
300             $sub_name => {
301             const => tag_parser
302             }
303             });
304             }
305              
306             #
307             # generate a block-parser
308             # initiated after compiling 'block'
309             # parses: 'block' name '{'
310             # injects ' => sub' after name
311             # always installs a parser for block() calls.
312             #
313             sub block_parser {
314             return sub {
315 1     1   103 local ($Declarator, $Offset) = @_;
316 1 50       5 return if (declarator_is_hash_key);
317              
318 1         2 my $sub_name;
319 1 50       3 if (next_word =~ m{\A [a-zA-Z_]\w* \z}xms) {
320             # skip the block_name to append a '=> sub' afterwards
321 1         8 $sub_name = skip_word;
322 1 50       3 if (next_char eq '{') {
323 1         4 inject(' => sub ');
324 1         3 $Offset += 8;
325             }
326             } else {
327             # take the next string we find as sub_name
328             # silently assume correct perl-syntax
329 0         0 Devel::Declare::toke_scan_str($Offset);
330 0         0 $sub_name = Devel::Declare::get_lex_stuff();
331 0         0 Devel::Declare::clear_lex_stuff();
332             }
333            
334             # insert a preliminary sub named $sub_name
335             # into the caller's namespace to make compiler happy
336             # and to allow calling the sub without ()'s
337 1         8 install_sub($sub_name => sub(;&@) {}, 'EXPORT_BLOCK');
  0         0  
338 1         3 add_tag_parser($sub_name);
339 2     2 0 10 };
340             }
341              
342             1;