File Coverage

blib/lib/CatalystX/ASP/Parser.pm
Criterion Covered Total %
statement 131 135 97.0
branch 40 54 74.0
condition 4 6 66.6
subroutine 13 13 100.0
pod 2 2 100.0
total 190 210 90.4


line stmt bran cond sub pod time code
1             package CatalystX::ASP::Parser;
2              
3 9     9   4187 use Moose::Role;
  9         18  
  9         54  
4              
5 9     9   40115 use File::Slurp qw(read_file);
  9         18  
  9         424  
6 9     9   2717 use HTML::Entities;
  9         35140  
  9         12752  
7              
8             with 'CatalystX::ASP::Compiler';
9              
10             requires 'compile_include';
11              
12             =head1 NAME
13              
14             CatalystX::ASP::Parser - Role for CatalystX::ASP providing code parsing
15              
16             =head1 SYNOPSIS
17              
18             use CatalystX::ASP;
19             with 'CatalystX::ASP::Compiler', 'CatalystX::ASP::Parser';
20              
21             sub execute {
22             my ($self, $c, $scriptref) = @_;
23             my $parsed = $self->parse($c, $scriptref);
24             my $subid = $self->compile($c, $parsed->{data});
25             eval { &$subid };
26             }
27              
28             =head1 DESCRIPTION
29              
30             This class implements the ability to parse ASP code into readable format for
31             C<CatalystX::ASP::Compiler>
32              
33             =cut
34              
35             sub _build_parsed_object {
36 25     25   92 my ( $self, $scriptref, %opts ) = @_;
37              
38             $$scriptref = join( ';;',
39             'no strict;',
40 115         358 'use vars qw(' . join( ' ', map {"\$$_"} @CatalystX::ASP::Objects ) . ');',
41             $opts{file} ? "\n#line 1 $opts{file}\n" : '',
42             $$scriptref,
43 25 50       119 ) unless $opts{is_raw};
    100          
44              
45 25         146 return { %opts, data => $scriptref };
46             }
47              
48             =head1 METHODS
49              
50             =over
51              
52             =item $self->parse($c, $scriptref)
53              
54             Take a C<$scriptref> and returns a hash including parsed data
55              
56             =cut
57              
58             sub parse {
59 25     25 1 8369 my ( $self, $c, $scriptref ) = @_;
60              
61 25         56 my $parsed_object = eval {
62 25         474 $self->GlobalASA->Script_OnParse;
63 25         3272 $scriptref = $self->_parse_ssi( $c, $scriptref );
64 25         105 my $parsed_scriptref = $self->_parse_asp( $c, $scriptref );
65 25 100       65 if ( $parsed_scriptref ) {
66 23         86 return $self->_build_parsed_object( $parsed_scriptref, is_perl => 1 );
67             } else {
68 2         11 return $self->_build_parsed_object( $scriptref, is_raw => 1 );
69             }
70             };
71 25 50       71 if ( $@ ) {
72 0         0 $c->error( "Error in parsing: $@" );
73             }
74 25         64 return $parsed_object;
75             }
76              
77             =item $self->parse_file($c, $file)
78              
79             Take a C<$file> and returns a hash including parsed data
80              
81             =cut
82              
83             sub parse_file {
84 15     15 1 3266 my ( $self, $c, $file ) = @_;
85              
86 15         38 my $scriptref = eval { read_file( $file, scalar_ref => 1 ); };
  15         118  
87              
88             # Asssume $@ =~ /sysopen: No such file or directory/
89             # Don't want to parse error because of possibly different locale than en_US.UTF-8
90 15 100       3999 if ( $@ ) {
91              
92             # To get to this point would mean that some call to $Response->Include()
93             # is for a non-existent file
94 1         6 $c->error( "Could not read_file: $file in parse_file: $@" );
95 1         42 $c->detach;
96             }
97              
98 14         118 my $parsed_object = $self->parse( $c, $scriptref );
99              
100 14         46 $parsed_object->{file} = $file;
101              
102 14         51 return $parsed_object;
103             }
104              
105             # This parser processes and converts are SSI to call $Response->Include()
106             sub _parse_ssi {
107 25     25   77 my ( $self, $c, $scriptref ) = @_;
108              
109 25         57 my $data = '';
110 25         51 my $file_line_number;
111             my $is_code_block;
112              
113 25 50       84 return \$data unless $$scriptref;
114              
115 25         171 while ( $$scriptref =~ s/^(.*?)\<!--\#include\s+file\s*=\s*\"?([^\s\"]*?)\"?(\s+args\s*=\s*\"?.*?)?\"?\s*--\>//so ) {
116 2         13 $data .= $1; # append the head
117 2         7 my $include = $2;
118 2         6 my $args;
119 2 100       9 if ( $3 ) {
120 1         4 $args = $3;
121 1         9 $args =~ s/^\s+args\s*\=\s*\"?//sgo;
122             }
123              
124 2         7 my $head_data = $1;
125 2 50       6 if ( $head_data =~ s/.*\n\#line (\d+) [^\n]+\n(\%\>)?//s ) {
126 0         0 $file_line_number = $1;
127 0 0       0 $is_code_block = $2 ? 0 : 1;
128             }
129 2         7 $file_line_number += $head_data =~ s/\n//sg;
130 2         5 $head_data =~ s/\<\%.*?\%\>//sg;
131 2         4 $is_code_block += $head_data =~ s/\<\%//sg;
132 2         6 $is_code_block -= $head_data =~ s/\%\>//sg;
133 2         5 $is_code_block = $is_code_block > 0; # stray percents like height=100%> kinds of tags
134              
135             # global directory, as well as includes dirs
136 2 50       8 $c->error( "Could not find $include in IncludesDir" )
137             unless $self->search_includes_dir( $include );
138              
139             # because the script is literally different whether there
140             # are includes or not, whether we are compiling includes
141             # need to be part of the script identifier, so the global
142             # caching does not return a script with different preferences.
143 2   100     529 $args ||= '';
144 2         6 $data .= "<% \$Response->Include('$include', '$args'); %>";
145              
146             # compile include now, so Loading() works for dynamic includes too
147 2 50       8 $c->error( "Failed to compile $include" )
148             unless $self->compile_include( $c, $include );
149             }
150 25         78 $data .= $$scriptref; # append what's left
151              
152 25         69 return \$data;
153             }
154              
155             # Where the real ASP parsing happens. It's actually decently simple, just don't
156             # look at the Parse() from the original author.
157             sub _parse_asp {
158 27     27   73 my ( $self, $c, $scriptref ) = @_;
159              
160 27 100       377 $$scriptref = $self->_parse_xml_subs( $c, $$scriptref ) if $self->XMLSubsMatch;
161              
162             # This is where we start to throw data back that lets the system render a
163             # static file as is instead of executing it as a per subroutine.
164 27 100       143 return unless $$scriptref =~ /\<\%.*?\%\>/s;
165              
166 25         93 $scriptref = \join( '', $$scriptref, '<%;;;%>' ); # always end with some perl code for parsing.
167              
168 25         58 my ( $script, @out, $perl_block, $last_perl_block );
169 25         158 while ( $$scriptref =~ s/^(.*?)\<\%(.*?)\%\>//so ) {
170 63         199 my ( $text, $perl ) = ( $1, $2 );
171 63         157 my $is_perl_block = $perl !~ /^\s*\=(.*)$/so;
172              
173             # with some extra text parsing, we remove asp formatting from
174             # influencing the generated html formatting, in particular
175             # dealing with perl blocks and new lines
176 63 100       131 if ( $text ) {
177              
178             # don't touch the white space, to preserve line numbers
179 27         43 $text =~ s/\\/\\\\/gso;
180 27         45 $text =~ s/\'/\\\'/gso;
181              
182 27 100       62 $last_perl_block = 0 if $last_perl_block;
183              
184 27         63 push @out, "\'$text\'";
185             }
186              
187 63 50       114 if ( $perl ) {
188 63 100       113 unless ( $is_perl_block ) {
189              
190             # we have a scalar assignment here
191 14         79 push( @out, "($1)" );
192             } else {
193 49         79 $last_perl_block = 1;
194 49 100       105 if ( @out ) {
195              
196             # we pass by reference here with the idea that we are not
197             # copying the HTML twice this way. This might be large
198             # saving on a typical site with rich HTML headers & footers
199 19         67 $script .= '$Response->WriteRef( \(' . join( '.', @out ) . ') );';
200 19         44 @out = ();
201             }
202              
203             # allow old <% #comment %> style to still work, but we
204             # need to insert a newline at the end of the comment for
205             # it to still exist, with the lines now being sync'd up
206             # if these old comments still exist, the perl script
207             # will be off by one line from the asp script
208 49 100       138 if ( $perl !~ /\n\s*$/so ) {
209 43 50       93 if ( $perl =~ /\#[^\n]*$/so ) {
210 0         0 $perl .= "\n";
211             }
212             }
213              
214             # skip if the perl code is just a placeholder
215 49 100       130 unless ( $perl eq ';;;' ) {
216 24         138 $script .= $perl . '; ';
217             }
218             }
219             }
220             }
221              
222 25         66 \$script;
223             }
224              
225             # Helper method to process all the XML substitions in the script. Essentially
226             # translates xmlsubs to perl method calls, passing in arguments and html within
227             # each xmlsub tag
228             sub _parse_xml_subs {
229 23     23   160 my ( $self, $c, $script ) = @_;
230              
231 23         74 $script = $self->_code_tag_encode( $script );
232              
233 23         249 my $xml_subs_match = $self->XMLSubsMatch;
234              
235             # Does a first pass to process xmlsubs with no content block within.
236             # Eg. <xmlsub:method />
237             # Why need to do first pass? I have no clue, need to ask JCHAMAS.
238 23         355 $script =~ s@\<\s*($xml_subs_match)(\s+[^\>]*)?/\>
239             @ {
240 3         9 my ( $func, $args ) = ( $1, $2 );
  3         13  
241 3         13 $args = $self->_code_tag_decode( $args );
242 3         16 $func =~ s/\:+/\:\:/g;
243 3         7 $func =~ s/\-/\_/g;
244 3 50       11 if ( $args ) {
245 3         31 $args =~ s/(\s*)([^\s]+?)(\s*)\=(\s*[^\s]+)/,$1'$2'$3\=\>$4/sg;
246 3         15 $args =~ s/^(\s*),/$1/s;
247             }
248 3   50     9 $args ||= '';
249 3         21 "<% $func({ $args }, ''); %>"
250             } @sgex;
251              
252 23         42 while ( 1 ) {
253 27 100       266 last unless $script =~ s@
254             \<\s*($xml_subs_match)(\s+[^\>]*)?\>(?!.*?\<\s*\1[^\>]*\>)(.*?)\<\/\1\s*>
255             @ {
256 4         7 my( $func, $args, $text ) = ( $1, $2, $3 );
  4         15  
257 4         10 $args = $self->_code_tag_decode( $args );
258 4         17 $func =~ s/\:+/\:\:/g;
259             # Parse and process args to convert into perl hash
260 4 50       13 if ( $args ) {
261 4         45 $args =~ s/(\s*)([^\s]+?)(\s*)\=(\s*[^\s]+)/,$1'$2'$3\=\>$4/sg;
262 4         17 $args =~ s/^(\s*),/$1/s;
263             }
264 4   50     13 $args ||= '';
265 4         11 $text = $self->_code_tag_decode( $text );
266              
267 4 100       137 if ( $text =~ m/\<\%|\<($xml_subs_match)/) {
268             # parse again, and control output buffer for this level
269 2         8 my $sub_scriptref = $self->_parse_asp( $c, \$text );
270             # Place the script inside a sub for compilation later
271 2         9 $text = join( ' ',
272             '&{sub {',
273             'my $saved = $Response->Body;',
274             '$Response->Clear;',
275             'local $Response->{out} = local $Response->{BinaryRef} = \( $Response->{Body} );',
276             'local *CatalystX::ASP::Response::Flush = sub {};',
277             $$sub_scriptref,
278             ';',
279             'my $trapped = $Response->Body;',
280             '$Response->Body( $saved );',
281             '$trapped;',
282             '} }'
283             );
284             } else {
285             # raw text
286 2         7 $text =~ s/\\/\\\\/gso;
287 2         6 $text =~ s/\'/\\\'/gso;
288 2         6 $text = "'$text'";
289             }
290              
291 4         24 "<% $func({ $args }, $text); %>"
292             } @sgex;
293             }
294              
295 23         78 return $self->_code_tag_decode( $script );
296             }
297              
298             # This simply encodes any ASP tags into something that won't be processed anywhere
299             sub _code_tag_encode {
300 23     23   56 my ( $self, $data ) = @_;
301              
302 23 50       70 if ( defined $data ) {
303 23         155 $data =~ s@\<\%(.*?)\%\>
304 30         385 @ { '[-AsP-[' . encode_entities( $1 ) . ']-AsP-]'; } @esgx;
  30         111  
305             }
306 23         616 return $data;
307             }
308              
309             # This simply decodes what's been encoded above
310             sub _code_tag_decode {
311 34     34   68 my ( $self, $data ) = @_;
312              
313 34 50       77 if ( defined $data ) {
314 34         119 $data =~ s@\[\-AsP\-\[(.*?)\]\-AsP\-\]
315 30         52 @ { '<%' . decode_entities( $1 ) . '%>'; } @esgx;
  30         249  
316             }
317 34         102 return $data;
318             }
319              
320             # Searches the script for and subroutines, returns 1 or 0
321             sub _parse_for_subs {
322 13     13   36 my ( $self, $scriptref ) = @_;
323              
324 13         573 return $$scriptref =~ /(^|\n)\s*sub\s+([^\s\{]+)\s*\{/;
325             }
326              
327 9     9   88 no Moose::Role;
  9         24  
  9         81  
328              
329             1;
330              
331             =back
332              
333             =head1 SEE ALSO
334              
335             =over
336              
337             =item * L<CatalystX::ASP>
338              
339             =item * L<CatalystX::ASP::Compiler>
340              
341             =back