File Coverage

blib/lib/WebDyne/Compile.pm
Criterion Covered Total %
statement 272 318 85.5
branch 82 130 63.0
condition 72 131 54.9
subroutine 26 28 92.8
pod 0 6 0.0
total 452 613 73.7


line stmt bran cond sub pod time code
1             #
2             # This file is part of WebDyne.
3             #
4             # This software is Copyright (c) 2017 by Andrew Speer .
5             #
6             # This is free software, licensed under:
7             #
8             # The GNU General Public License, Version 2, June 1991
9             #
10             # Full license text is available at:
11             #
12             #
13             #
14             package WebDyne::Compile;
15              
16              
17             # Packace init, attempt to load optional Time::HiRes module
18             #
19             sub BEGIN {
20 1     1   8 local $SIG{__DIE__};
21 1         4 $^W=0;
22 1 50   1   67 eval("use Time::HiRes qw(time)") || eval {undef};
  1         185  
  1         6  
  1         1  
  1         12  
23             }
24              
25              
26             # Pragma
27             #
28 1     1   10 use strict qw(vars);
  1         4  
  1         55  
29 1     1   6 use vars qw($VERSION %CGI_TAG_WEBDYNE %CGI_TAG_IMPLICIT);
  1         2  
  1         70  
30 1     1   13 use warnings;
  1         2  
  1         38  
31 1     1   4 no warnings qw(uninitialized redefine once);
  1         2  
  1         49  
32              
33              
34             # External Modules
35             #
36 1     1   4 use WebDyne;
  1         2  
  1         24  
37 1     1   367 use WebDyne::HTML::TreeBuilder;
  1         2  
  1         8  
38 1     1   35 use Storable;
  1         2  
  1         54  
39 1     1   6 use IO::File;
  1         1  
  1         133  
40 1     1   7 use CGI qw(-no_xhtml);
  1         1  
  1         11  
41 1     1   96 use CGI::Util;
  1         2  
  1         77  
42 1     1   25 use Data::Dumper;
  1         2  
  1         36  
43              
44              
45             # WebDyne Modules
46             #
47 1     1   5 use WebDyne::Constant;
  1         1  
  1         283  
48 1     1   5 use WebDyne::Base;
  1         2  
  1         4  
49              
50              
51             # Version information
52             #
53             $VERSION='1.250';
54              
55              
56             # Debug load
57             #
58             0 && debug("Loading %s version $VERSION", __PACKAGE__);
59              
60              
61             # Tags that are case sensitive
62             #
63             our %CGI_Tag_Ucase=map {$_ => ucfirst($_)} (
64              
65             qw(select tr link delete accept sub header button)
66              
67             );
68              
69              
70             # Get WebDyne and CGI tags from TreeBuilder module
71             #
72             *CGI_TAG_WEBDYNE=\%WebDyne::CGI_TAG_WEBDYNE;
73             *CGI_TAG_IMPLICIT=\%WebDyne::HTML::TreeBuilder::CGI_TAG_IMPLICIT;
74              
75              
76             # Need the start/end_html code ref for later on
77             #
78             my $CGI_start_html_cr=UNIVERSAL::can(CGI, 'start_html');
79             my $CGI_end_html_cr=UNIVERSAL::can(CGI, 'end_html');
80              
81              
82             # Var to hold package wide hash, for data shared across package
83             #
84             my %Package;
85              
86              
87             # All done. Positive return
88             #
89             1;
90              
91              
92             #==================================================================================================
93              
94              
95             sub new {
96              
97              
98             # Only used when debugging from outside apache, eg test script. If so, user
99             # must create new object ref, then run the compile. See wdcompile script for
100             # example. wdcompile is only used for debugging - we do some q&d stuff here
101             # to make it work
102             #
103 0     0 0 0 my $class=shift();
104              
105              
106             # Init WebDyne module
107             #
108 0         0 WebDyne->init_class();
109 0         0 require WebDyne::Request::Fake;
110 0         0 my $r=WebDyne::Request::Fake->new();
111              
112              
113             # New self ref
114             #
115 0         0 my %self=(
116              
117             _r => $r,
118             _CGI => CGI->new(),
119             _time => time()
120              
121             );
122              
123              
124             # And return blessed ref
125             #
126 0         0 return bless \%self, 'WebDyne';
127              
128              
129             }
130              
131              
132             sub compile {
133              
134              
135             # Compile HTML file into Storable structure
136             #
137 14     14 0 50 my ($self, $param_hr)=@_;
138              
139              
140             # Start timer so we can log how long it takes us to compile a file
141             #
142 14         69 my $time=time();
143              
144              
145             # Init class if not yet done
146             #
147 14   66     145 (ref($self))->{_compile_init} ||= do {
148 1 50       5 $self->compile_init() || return err ()
149             };
150              
151              
152             # Debug
153             #
154 14         58 0 && debug('compile %s', Dumper($param_hr));
155              
156              
157             # Get srce and dest
158             #
159 14         62 my ($html_cn, $dest_cn)=@{$param_hr}{qw(srce dest)};
  14         61  
160              
161              
162             # Need request object ref
163             #
164 14   50     88 my $r=$self->{'_r'} || $self->r() || return err ();
165              
166              
167             # Get CGI ref
168             #
169 14   50     161 my $cgi_or=$self->{'_CGI'} || $self->CGI() || return err ();
170              
171              
172             # Turn off xhtml in CGI - should work in pragma, seems dodgy - seems like
173             # we must do every time we compile a page
174             #
175 14         38 $CGI::XHTML=0;
176              
177              
178             # Nostick
179             #
180 14         29 $CGI::NOSTICKY=1;
181              
182              
183             # Open the file
184             #
185 14   50     220 my $html_fh=IO::File->new($html_cn, O_RDONLY) ||
186             return err ("unable to open file $html_cn, $!");
187              
188              
189             # Get new TreeBuilder object
190             #
191 14   50     2024 my $html_ox=WebDyne::HTML::TreeBuilder->new(
192              
193             api_version => 3,
194              
195             ) || return err ('unable to create HTML::TreeBuilder object');
196              
197              
198             # Tell HTML::TreeBuilder we do *not* want to ignore tags it
199             # considers "unknown". Since we use and tags,
200             # amongst other things, we need these to be in the tree
201             #
202 14         5790 $html_ox->ignore_unknown(0);
203              
204              
205             # Tell it if we also want to see comments, use XML mode
206             #
207 14         307 $html_ox->store_comments($WEBDYNE_STORE_COMMENTS);
208 14         174 $html_ox->xml_mode(1);
209              
210              
211             # No space compacting ?
212             #
213 14         57 $html_ox->ignore_ignorable_whitespace($WEBDYNE_COMPILE_IGNORE_WHITESPACE);
214 14         166 $html_ox->no_space_compacting($WEBDYNE_COMPILE_NO_SPACE_COMPACTING);
215              
216              
217             # Get code ref closure of file to be parsed
218             #
219 14   50     188 my $parse_cr=$html_ox->parse_fh($html_fh) ||
220             return err ();
221              
222              
223             # Muck around with strictness of P tags
224             #
225             #$html_ox->implicit_tags(0);
226 14         72 $html_ox->p_strict(1);
227              
228              
229             # Now parse through the file, running eof at end as per HTML::TreeBuilder
230             # man page.
231             #
232 14         211 $html_ox->parse($parse_cr);
233 14         130 $html_ox->eof();
234              
235              
236             # And close the file handle
237             #
238 14         3972 $html_fh->close();
239              
240              
241             # Now start iterating through the treebuilder object, creating
242             # our own array tree structure. Do this in a separate method that
243             # is rentrant as the tree is descended
244             #
245 14         301 my %meta=(
246              
247             manifest => [\$html_cn]
248              
249             );
250 14   33     104 my $data_ar=$self->parse($html_ox, \%meta) || do {
251             $html_ox->delete;
252             undef $html_ox;
253             return err ();
254             };
255 14         40 0 && debug("meta after parse %s", Dumper(\%meta));
256              
257              
258             # Now destroy the HTML::Treebuilder object, or else mem leak occurs
259             #
260 14         61 $html_ox=$html_ox->delete;
261 14         2996 undef $html_ox;
262              
263              
264             # Meta block
265             #
266 14   50     173 my $head_ar=$self->find_node(
267             {
268              
269             data_ar => $data_ar,
270             tag => 'head',
271              
272             }) || return err ();
273 14   50     136 my $meta_ar=$self->find_node(
274             {
275              
276             data_ar => $head_ar->[0],
277             tag => 'meta',
278             all_fg => 1,
279              
280             }) || return err ();
281 14         44 foreach my $tag_ar (@{$meta_ar}) {
  14         53  
282 2   50     12 my $attr_hr=$tag_ar->[$WEBDYNE_NODE_ATTR_IX] || next;
283 2 50       10 if ($attr_hr->{'name'} eq 'WebDyne') {
284 0         0 my @meta=split(/;/, $attr_hr->{'content'});
285 0         0 0 && debug('meta %s', Dumper(\@meta));
286 0         0 foreach my $meta (@meta) {
287 0         0 my ($name, $value)=split(/[=:]/, $meta, 2);
288 0 0       0 defined($value) || ($value=1);
289              
290             # Eval any meta attrs like @{}, %{}..
291 0   0     0 my $hr=$self->subst_attr(undef, {$name => $value}) ||
292             return err ();
293 0         0 $meta{$name}=$hr->{$name};
294             }
295              
296             # Do not want anymore
297             $self->delete_node(
298             {
299              
300 0 0       0 data_ar => $data_ar,
301             node_ar => $tag_ar
302              
303             }) || return err ();
304             }
305             }
306              
307             # Construct final webdyne container
308             #
309 14 50       90 my @container=(keys %meta ? \%meta : undef, $data_ar);
310              
311              
312             # Quit if user wants to see tree at this stage
313             #
314 14 100       81 $param_hr->{'stage0'} && (return \@container);
315              
316              
317             # Store meta information for this instance so that when perl_init (or code running under perl_init)
318             # runs it can access meta data via $self->meta();
319             #
320 12 50       53 $self->{'_meta_hr'}=\%meta if keys %meta;
321 12 100 66     84 if ((my $perl_ar=$meta{'perl'}) && !$param_hr->{'noperl'}) {
322              
323             # This is inline __PERL__ perl. Must be executed before filter so any filters added by the __PERL__
324             # block are seen
325             #
326 9         16 my $perl_debug_ar=$meta{'perl_debug'};
327 9 50       75 $self->perl_init($perl_ar, $perl_debug_ar) || return err ();
328              
329              
330             }
331              
332              
333             # Quit if user wants to see tree at this stage
334             #
335 12 100       172 $param_hr->{'stage1'} && (return \@container);
336              
337              
338             # Filter ?
339             #
340 10         25 my @filter=@{$meta{'webdynefilter'}};
  10         33  
341 10 50       27 unless (@filter) {
342 10   33     129 my $filter=$self->{'_filter'} || $r->dir_config('WebDyneFilter');
343 10 50       34 @filter=split(/\s+/, $filter) if $filter;
344             }
345 10         19 0 && debug('filter %s', Dumper(\@filter));
346 10 50 33     39 if ((@filter) && !$param_hr->{'nofilter'}) {
347 0         0 local $SIG{'__DIE__'};
348 0         0 foreach my $filter (@filter) {
349 0         0 $filter=~s/::filter$//;
350 0 0       0 eval("require $filter") ||
351             return err ("unable to load filter $filter, " . lcfirst($@));
352 0 0       0 UNIVERSAL::can($filter, 'filter') ||
353             return err ("custom filter '$filter' does not seem to have a 'filter' method to call");
354 0         0 $filter.='::filter';
355 0   0     0 $data_ar=$self->$filter($data_ar, \%meta) || return err ();
356             }
357             }
358              
359              
360             # Optimise tree, first step
361             #
362 10   50     88 $data_ar=$self->optimise_one($data_ar) || return err ();
363              
364              
365             # Quit if user wants to see tree at this stage
366             #
367 10 50       39 $param_hr->{'stage2'} && (return \@container);
368              
369              
370             # Optimise tree, second step
371             #
372 10   50     64 $data_ar=$self->optimise_two($data_ar) ||
373             return err ();
374              
375              
376             # Quit if user wants to see tree at this stage
377             #
378 10 50       35 $param_hr->{'stage3'} && (return \@container);
379              
380              
381             # Is there any dynamic data ? If not, set meta html flag to indicate
382             # document is complete HTML
383             #
384 10 100       16 unless (grep {ref($_)} @{$data_ar}) {
  99         155  
  10         21  
385 1         4 $meta{'html'}=1;
386             }
387              
388              
389             # Construct final webdyne container
390             #
391 10 50       51 @container=(keys %meta ? \%meta : undef, $data_ar);
392              
393              
394             # Quit if user wants to final container
395             #
396 10 50       34 $param_hr->{'stage4'} && (return \@container);
397              
398              
399             # Save compiled object. Can't store code based cache refs, will be
400             # recreated anyway (when reloaded), so delete, save, then restore
401             #
402 10         14 my $cache_cr;
403 10 50       34 if (ref($meta{'cache'}) eq 'CODE') {$cache_cr=delete $meta{'cache'}}
  0         0  
404              
405              
406             # Store to cache file if dest filename given
407             #
408 10 50       25 if ($dest_cn) {
409 0         0 0 && debug("attempting to cache to dest $dest_cn");
410 0         0 local $SIG{'__DIE__'};
411 0 0       0 eval {Storable::lock_store(\@container, $dest_cn)} || do {
  0         0  
412              
413             # This used to be fatal
414             #
415             #return err("error storing compiled $html_cn to dest $dest_cn, $@");
416              
417              
418             # No more, just log warning and continue - no point crashing an otherwise
419             # perfectly good app because we can't write to a directory
420             #
421             $r->log_error(
422             "error storing compiled $html_cn to dest $dest_cn, $@ - " .
423             'please ensure destination directory is writeable.'
424             )
425 0 0       0 unless $Package{'warn_write'}++;
426 0         0 0 && debug("caching FAILED to $dest_cn");
427              
428             };
429             }
430             else {
431 10         18 0 && debug('no destination file for compile - not caching');
432             }
433              
434              
435             # Put the cache code ref back again now we have finished storing.
436             #
437 10 50       23 $cache_cr && ($meta{'cache'}=$cache_cr);
438              
439              
440             # Work out the page compile time, log
441             #
442 10         176 my $time_render=sprintf('%0.4f', time()-$time);
443 10         15 0 && debug("form $html_cn compile time $time_render");
444              
445              
446             # Destroy self
447             #
448 10         18 undef $self;
449              
450              
451             # Done
452             #
453 10         234 return \@container;
454              
455             }
456              
457              
458             sub compile_init {
459              
460              
461             # Used to init package, move ugliness out of handler
462             #
463 1     1 0 1 my $class=shift();
464 1         2 0 && debug("in compile_init class $class");
465              
466              
467             # Init some CGI custom routines we need for correct compilation etc.
468             #
469 1     0   4 *{'CGI::~comment'}=sub {sprintf('', $_[1]->{'text'})};
  1         11  
  0         0  
470 1         2 $CGI::XHTML=0;
471 1         2 $CGI::NOSTICKY=1;
472 1         16 *CGI::start_html_cgi=$CGI_start_html_cr;
473 1         3 *CGI::end_html_cgi=$CGI_end_html_cr;
474             *CGI::start_html=sub {
475 10     10   39 my ($self, $attr_hr)=@_;
476              
477             #CORE::print Data::Dumper::Dumper($attr_hr);
478 10 50       20 keys %{$attr_hr} || ($attr_hr=$WEBDYNE_HTML_PARAM);
  10         36  
479 10         22 my $html_attr=join(' ', map {qq($_="$attr_hr->{$_}")} keys %{$attr_hr});
  10         62  
  10         27  
480 10 50       91 return $WEBDYNE_DTD . ($html_attr ? "" : '');
481 1         10 };
482             *CGI::end_html=sub {
483 10     10   40 ''
484 1         7 };
485             *CGI::html=sub {
486 1     1   6 my ($self, $attr_hr, @html)=@_;
487 1         7 return join(undef, CGI->start_html($attr_hr), @html, $self->end_html);
488 1         17 };
489              
490              
491             # Get rid of the simple escape routine, which mangles attribute characters we
492             # want to keep
493             #
494 1     4   24 *CGI::Util::simple_escape=sub {shift()};
  4         130  
495              
496              
497             # Get rid of compiler warnings on start and end routines
498             #
499             #0 && *CGI::start_html;
500             #0 && *CGI::end_html;
501              
502              
503             # All done
504             #
505 1         7 return \undef;
506              
507              
508             }
509              
510              
511             sub optimise_one {
512              
513              
514             # Optimise a data tree
515             #
516 12     12 0 57 my ($self, $data_ar)=@_;
517              
518              
519             # Debug
520             #
521 12         25 0 && debug('optimise stage one');
522              
523              
524             # Get CGI object
525             #
526 12   50     46 my $cgi_or=$self->{'_CGI'} ||
527             return err ("unable to get CGI object from self ref");
528              
529              
530             # Recursive anon sub to do the render
531             #
532             my $compile_cr=sub {
533              
534              
535             # Get self ref, node array
536             #
537 176     176   261 my ($compile_cr, $data_ar)=@_;
538              
539              
540             # Only do if we have children, if we do a foreach over nonexistent child node
541             # it will spring into existance as empty array ref, which we then have to
542             # wastefully store
543             #
544 176 100       302 if ($data_ar->[$WEBDYNE_NODE_CHLD_IX]) {
545              
546              
547             # Process sub nodes to get child html data
548             #
549 132         152 foreach my $data_chld_ix (0..$#{$data_ar->[$WEBDYNE_NODE_CHLD_IX]}) {
  132         277  
550              
551              
552             # Get data child
553             #
554 219         297 my $data_chld_ar=$data_ar->[$WEBDYNE_NODE_CHLD_IX][$data_chld_ix];
555 219         233 0 && debug("data_chld_ar $data_chld_ar");
556              
557              
558             # If ref, recursivly run through compile process
559             #
560 219 100       414 ref($data_chld_ar) && do {
561              
562              
563             # Run through compile sub-process
564             #
565 164   50     360 my $data_chld_xv=$compile_cr->($compile_cr, $data_chld_ar) ||
566             return err ();
567 164 100       333 if (ref($data_chld_xv) eq 'SCALAR') {
568 42         60 $data_chld_xv=${$data_chld_xv}
  42         79  
569             }
570              
571              
572             # Replace in tree
573             #
574 164         327 $data_ar->[$WEBDYNE_NODE_CHLD_IX][$data_chld_ix]=$data_chld_xv;
575              
576             }
577              
578             }
579              
580             }
581              
582              
583             # Get this node tag and attrs
584             #
585             my ($html_tag, $attr_hr)=
586 176         251 @{$data_ar}[$WEBDYNE_NODE_NAME_IX, $WEBDYNE_NODE_ATTR_IX];
  176         339  
587 176         219 0 && debug("tag $html_tag, attr %s", Dumper($attr_hr));
588              
589             # Store data block as hint to error handler should something go wrong
590             #
591 176         281 $self->{'_data_ar'}=$data_ar;
592              
593              
594             # Check to see if any of the attributes will require a subst to be carried out
595             #
596 176         225 my @subst_oper;
597              
598             #my $subst_fg=grep { $_=~/([$|@|%|!|+|^|*]{1})\{([$|@|%|!|+|^|*]?)(.*?)\2\}/s && push (@subst_oper, $1) } values %{$attr_hr};
599             #my $subst_fg=grep { $_=~/([\$@%!+*^]){1}{(\1?)(.*?)\2}/ && push (@subst_oper, $1) } values %{$attr_hr};
600             my $subst_fg=$data_ar->[$WEBDYNE_NODE_SBST_IX] || delete $attr_hr->{'subst'} ||
601 176   66     556 grep {$_=~/([\$@%!+*^]){1}{(\1?)(.*?)\2}/ && push(@subst_oper, $1)} values %{$attr_hr};
602              
603              
604             # Do not subst comments
605             #
606 176 50       325 ($html_tag=~/~comment$/) && ($subst_fg=undef);
607              
608              
609             # If subst_fg present, means we must do a subst on attr vars. Flag
610             #
611 176 100       270 $subst_fg && ($data_ar->[$WEBDYNE_NODE_SBST_IX]=1);
612              
613              
614             # A CGI tag can be marked static, means that we can pre-render it for efficieny
615             #
616 176         272 my $static_fg=$attr_hr->{'static'};
617 176         187 0 && debug("tag $html_tag, static_fg $static_fg, subst_fg $subst_fg, subst_oper %s", Dumper(\@subst_oper));
618              
619              
620             # If static, but subst requires an eval, we can do now *only* if @ or % tags though,
621             # and some !'s that do not need request object etc. Cannot do on $
622             #
623 176 50 33     276 if ($static_fg && $subst_fg) {
624              
625              
626             # Cannot optimes subst values with ${value}, must do later
627             #
628 0 0       0 (grep {$_ eq '$'} @subst_oper) && return $data_ar;
  0         0  
629              
630              
631             # Do it
632             #
633 0   0     0 $attr_hr=$self->WebDyne::subst_attr(undef, $attr_hr) ||
634             return err ();
635              
636             }
637              
638              
639             # If not special WebDyne tag, see if we can render node
640             #
641             #if ((!$CGI_TAG_WEBDYNE{$html_tag} && !$CGI_TAG_IMPLICIT{$html_tag} && !$subst_fg) || $static_fg) {
642 176 100 100     625 if ((!$CGI_TAG_WEBDYNE{$html_tag} && !$subst_fg) || $static_fg) {
      66        
643              
644              
645             # Check all child nodes to see if ref or scalar
646             #
647             my $ref_fv=$data_ar->[$WEBDYNE_NODE_CHLD_IX] &&
648 105   100     199 grep {ref($_)} @{$data_ar->[$WEBDYNE_NODE_CHLD_IX]};
649              
650              
651             # If all scalars (ie no refs found)t, we can simply pre render all child nodes
652             #
653 105 100       177 unless ($ref_fv) {
654              
655              
656             # Done with static tag, delete so not rendered
657             #
658 45         69 delete $attr_hr->{'static'};
659              
660              
661             # Special case. If WebDyne tag and static, render now via WebDyne. Experimental
662             #
663 45 50       87 if ($CGI_TAG_WEBDYNE{$html_tag}) {
664              
665              
666             # Render via WebDyne
667             #
668 0         0 0 && debug("about to render tag $html_tag, attr %s", Dumper($attr_hr));
669 0   0     0 my $html_sr=$self->$html_tag($data_ar, $attr_hr) ||
670             return err ();
671 0         0 0 && debug("html *$html_sr*, *${$html_sr}*");
672 0         0 return $html_sr;
673              
674              
675             }
676              
677              
678             # Wrap up in our HTML tag. Do in eval so we can catch errors from invalid tags etc
679             #
680 45 100       96 my @data_child_ar=$data_ar->[$WEBDYNE_NODE_CHLD_IX] ? @{$data_ar->[$WEBDYNE_NODE_CHLD_IX]} : undef;
  29         66  
681 45   50     69 my $html=eval {
682             $cgi_or->$html_tag(grep {$_} $attr_hr, join(undef, @data_child_ar))
683             } ||
684              
685             # Use errsubst as CGI may have DIEd during eval and be caught by WebDyne SIG handler
686             return errsubst(
687             "CGI tag '<$html_tag>': %s",
688             $@ || "undefined error rendering tag '$html_tag'"
689             );
690              
691              
692             # Debug
693             #
694             #0 && debug("html *$html*");
695              
696              
697             # Done
698             #
699 45         3180 return \$html;
700              
701             }
702              
703             }
704              
705              
706             # Return current node, perhaps now somewhat optimised
707             #
708             $data_ar
709              
710 12         165 };
  131         315  
711              
712              
713             # Run it
714             #
715 12   50     53 $data_ar=$compile_cr->($compile_cr, $data_ar) || return err ();
716              
717              
718             # If scalar ref returned it is all HTML - return as plain scalar
719             #
720 12 100       45 if (ref($data_ar) eq 'SCALAR') {
721 3         10 $data_ar=${$data_ar}
  3         8  
722             }
723              
724              
725             # Done
726             #
727 12         226 $data_ar;
728              
729             }
730              
731              
732             sub optimise_two {
733              
734              
735             # Optimise a data tree
736             #
737 12     12 0 36 my ($self, $data_ar)=@_;
738              
739              
740             # Debug
741             #
742 12         19 0 && debug('optimise stage two');
743              
744              
745             # Get CGI object
746             #
747 12   50     43 my $cgi_or=$self->{'_CGI'} ||
748             return err ("unable to get CGI object from self ref");
749              
750              
751             # Recursive anon sub to do the render
752             #
753             my $compile_cr=sub {
754              
755              
756             # Get self ref, node array
757             #
758 133     133   242 my ($compile_cr, $data_ar, $data_uppr_ar)=@_;
759              
760              
761             # Only do if we have children, if do a foreach over nonexistent child node
762             # it will spring into existance as empty array ref, which we then have to
763             # wastefully store
764             #
765 133 100       283 if ($data_ar->[$WEBDYNE_NODE_CHLD_IX]) {
766              
767              
768             # Process sub nodes to get child html data
769             #
770             my @data_child_ar=$data_ar->[$WEBDYNE_NODE_CHLD_IX]
771             ?
772 105 50       182 @{$data_ar->[$WEBDYNE_NODE_CHLD_IX]}
  105         191  
773             : undef;
774 105         165 foreach my $data_chld_ar (@data_child_ar) {
775              
776              
777             # Debug
778             #
779             #0 && debug("found child node $data_chld_ar");
780              
781              
782             # If ref, run through compile process recursively
783             #
784 188 100       320 ref($data_chld_ar) && do {
785              
786              
787             # Run through compile sub-process
788             #
789 122   50     414 $data_ar=$compile_cr->($compile_cr, $data_chld_ar, $data_ar) ||
790             return err ();
791              
792             }
793              
794              
795             }
796              
797             }
798              
799              
800             # Get this tag and attrs
801             #
802             my ($html_tag, $attr_hr)=
803 133         182 @{$data_ar}[$WEBDYNE_NODE_NAME_IX, $WEBDYNE_NODE_ATTR_IX];
  133         251  
804 133         164 0 && debug("tag $html_tag");
805              
806              
807             # Store data block as hint to error handler should something go wrong
808             #
809 133         194 $self->{'_data_ar'}=$data_ar;
810              
811              
812             # Check if this tag attributes will need substitution (eg ${foo});
813             #
814             #my $subst_fg=grep { $_=~/([$|@|%|!|+|^|*]{1})\{([$|@|%|!|+|^|*]?)(.*?)\2\}/s } values %{$attr_hr};
815             my $subst_fg=$data_ar->[$WEBDYNE_NODE_SBST_IX] || delete $attr_hr->{'subst'} ||
816 133   33     419 grep {$_=~/([\$@%!+*^]){1}{(\1?)(.*?)\2}/so} values %{$attr_hr};
817              
818              
819             # If subst_fg present, means we must do a subst on attr vars. Flag, also get static flag
820             #
821 133 100       224 $subst_fg && ($data_ar->[$WEBDYNE_NODE_SBST_IX]=1);
822 133         179 my $static_fg=delete $attr_hr->{'static'};
823              
824              
825             # If not special WebDyne tag, and no dynamic params we can render this node into
826             # its final HTML format
827             #
828 133 100 100     851 if (!$CGI_TAG_WEBDYNE{$html_tag} && !$CGI_TAG_IMPLICIT{$html_tag} && $data_uppr_ar && !$subst_fg) {
    50 100        
    100 100        
      66        
      66        
829              
830              
831             # Get nodes into array now, removes risk of iterating over shifting ground
832             #
833             my @data_child_ar=$data_uppr_ar->[$WEBDYNE_NODE_CHLD_IX]
834             ?
835 51 50       101 @{$data_uppr_ar->[$WEBDYNE_NODE_CHLD_IX]}
  51         131  
836             : undef;
837              
838              
839             # Get uppr node
840             #
841 51         124 foreach my $data_chld_ix (0..$#data_child_ar) {
842              
843              
844             # Get node, skip unless ref
845             #
846 297         373 my $data_chld_ar=$data_child_ar[$data_chld_ix];
847 297 100       489 ref($data_chld_ar) || next;
848              
849              
850             # Debug
851             #
852             #0 && debug("looking at node $data_chld_ix, $data_chld_ar vs $data_ar");
853              
854              
855             # Skip unless eq us
856             #
857 159 100       325 next unless ($data_chld_ar eq $data_ar);
858              
859              
860             # Get start and end tag methods
861             #
862 51         133 my ($html_tag_start, $html_tag_end)=
863             ("start_${html_tag}", "end_${html_tag}");
864              
865              
866             # Translate tags into HTML
867             #
868             my ($html_start, $html_end)=map {
869 51 50 0     95 eval {
  102         2026  
870 102         145 $cgi_or->$_(grep {$_} $attr_hr)
  102         435  
871             } ||
872              
873             # Use errsubst as CGI may have DIEd during eval and be caught by WebDyne SIG handler
874             return errsubst(
875             "CGI tag '<$_>' error- %s",
876             $@ || "undefined error rendering tag '$_'"
877             );
878             } ($html_tag_start, $html_tag_end);
879              
880              
881             # Splice start and end tags for this HTML into appropriate place
882             #
883 51         97 splice @{$data_uppr_ar->[$WEBDYNE_NODE_CHLD_IX]}, $data_chld_ix, 1,
884             $html_start,
885 51         1593 @{$data_ar->[$WEBDYNE_NODE_CHLD_IX]},
  51         177  
886             $html_end;
887              
888             # Done, no need to iterate any more
889             #
890 51         103 last;
891              
892              
893             }
894              
895              
896             # Concatenate all non ref values in the parent. Var to hold results
897             #
898 51         65 my @data_uppr;
899              
900              
901             # Repopulate data child array, as probably changed in above foreach
902             # block.
903             #
904             @data_child_ar=$data_uppr_ar->[$WEBDYNE_NODE_CHLD_IX]
905             ?
906 51 50       90 @{$data_uppr_ar->[$WEBDYNE_NODE_CHLD_IX]}
  51         188  
907             : undef;
908              
909             #@data_child_ar=@{$data_uppr_ar->[$WEBDYNE_NODE_CHLD_IX]};
910              
911              
912             # Begin concatenation
913             #
914 51         110 foreach my $data_chld_ix (0..$#data_child_ar) {
915              
916              
917             # Get child
918             #
919 627         801 my $data_chld_ar=$data_child_ar[$data_chld_ix];
920              
921              
922             # Can we concatenate with above node
923             #
924 627 100 100     1832 if (@data_uppr && !ref($data_chld_ar) && !ref($data_uppr[$#data_uppr])) {
      100        
925              
926              
927             # Yes, concatentate
928             #
929 79         166 $data_uppr[$#data_uppr].=$data_chld_ar;
930              
931             }
932             else {
933              
934             # No, push onto new data_uppr array
935             #
936 548         939 push @data_uppr, $data_chld_ar;
937              
938             }
939             }
940              
941              
942             # Replace with new optimised array
943             #
944 51         149 $data_uppr_ar->[$WEBDYNE_NODE_CHLD_IX]=\@data_uppr;
945              
946              
947             }
948             elsif ($CGI_TAG_WEBDYNE{$html_tag} && $data_uppr_ar && $static_fg) {
949              
950              
951             # Now render to make HTML and modify the data arrat above us with the rendered code
952             #
953 0   0     0 my $html_sr=$self->render(
954             {
955             data => [$data_ar],
956             }) || return err ();
957             my @data_child_ar=$data_uppr_ar->[$WEBDYNE_NODE_CHLD_IX]
958             ?
959 0 0       0 @{$data_uppr_ar->[$WEBDYNE_NODE_CHLD_IX]}
  0         0  
960             : undef;
961 0         0 foreach my $ix (0..$#data_child_ar) {
962 0 0       0 if ($data_uppr_ar->[$WEBDYNE_NODE_CHLD_IX][$ix] eq $data_ar) {
963 0         0 $data_uppr_ar->[$WEBDYNE_NODE_CHLD_IX][$ix]=${$html_sr};
  0         0  
964 0         0 last;
965             }
966             }
967              
968              
969             }
970             elsif (!$data_uppr_ar) {
971              
972              
973             # Must be at top node, as nothing above us,
974             # get start and end tag methods
975             #
976 11         45 my ($html_tag_start, $html_tag_end)=
977             ("start_${html_tag}", "end_${html_tag}");
978              
979              
980             # Get resulting start and ending HTML
981             #
982             my ($html_start, $html_end)=map {
983 11 50 0     46 eval {
  22         150  
984 22         48 $cgi_or->$_(grep {$_} $attr_hr)
  22         145  
985             } ||
986             return errsubst(
987             "CGI tag '<$_>': %s",
988             $@ || "undefined error rendering tag '$_'"
989             );
990              
991             #return err("$@" || "no html returned from tag $_")
992             } ($html_tag_start, $html_tag_end);
993             my @data_child_ar=$data_ar->[$WEBDYNE_NODE_CHLD_IX]
994             ?
995 11 50       129 @{$data_ar->[$WEBDYNE_NODE_CHLD_IX]}
  11         59  
996             : undef;
997              
998             # Place start and end tags for this HTML into appropriate place
999             #
1000 11         36 my @data=(
1001             $html_start,
1002             @data_child_ar,
1003             $html_end
1004             );
1005              
1006              
1007             # Concatenate all non ref vals
1008             #
1009 11         27 my @data_new;
1010 11         39 foreach my $data_chld_ix (0..$#data) {
1011              
1012 121 100 100     434 if ($data_chld_ix && !ref($data[$data_chld_ix]) && !(ref($data[$data_chld_ix-1]))) {
      100        
1013 21         79 $data_new[$#data_new].=$data[$data_chld_ix];
1014             }
1015             else {
1016 100         170 push @data_new, $data[$data_chld_ix]
1017             }
1018              
1019             }
1020              
1021              
1022             # Return completed array
1023             #
1024 11         38 $data_uppr_ar=\@data_new;
1025              
1026              
1027             }
1028              
1029              
1030             # Return current node
1031             #
1032 133         763 return $data_uppr_ar;
1033              
1034              
1035 12         138 };
1036              
1037              
1038             # Run it, return whatever it does, allowing for the special case that first stage
1039             # optimisation found no special tags, and precompiled the whole array into a
1040             # single HTML string. In which case return as array ref to allow for correct storage
1041             # and rendering.
1042             #
1043 12 100 33     89 return ref($data_ar)
1044             ?
1045             $compile_cr->($compile_cr, $data_ar, undef) || err ()
1046             :
1047             [$data_ar];
1048              
1049              
1050             }
1051              
1052              
1053             sub parse {
1054              
1055              
1056             # A recusively called method to parse a HTML::Treebuilder tree. content is an
1057             # array ref of the HTML entity contents, return custom array tree from that
1058             # structure
1059             #
1060 213     213 0 358 my ($self, $html_or, $meta_hr)=@_;
1061 213         289 my ($line_no, $line_no_tag_end)=@{$html_or}{'_line_no', '_line_no_tag_end'};
  213         412  
1062 213         354 my $html_fn_sr=$meta_hr->{'manifest'}[0];
1063 213         242 0 && debug("parse $self, $html_or line_no $line_no line_no_tag_end $line_no_tag_end");
1064              
1065             #0 && debug("parse $html_or, %s", Dumper($html_or));
1066              
1067              
1068             # Create array to hold this data node
1069             #
1070 213         568 my @data;
1071 213         657 @data[
1072             $WEBDYNE_NODE_NAME_IX,
1073             $WEBDYNE_NODE_ATTR_IX,
1074             $WEBDYNE_NODE_CHLD_IX,
1075             $WEBDYNE_NODE_SBST_IX,
1076             $WEBDYNE_NODE_LINE_IX,
1077             $WEBDYNE_NODE_LINE_TAG_END_IX,
1078             $WEBDYNE_NODE_SRCE_IX
1079             ]=(
1080             #undef, undef, undef, undef, $line_no, $line_no_tag_end, $meta_hr->{'manifest'}[0]
1081             undef, undef, undef, undef, $line_no, $line_no_tag_end, $html_fn_sr
1082             );
1083              
1084              
1085             # Get tag
1086             #
1087 213         470 my $html_tag=$html_or->tag();
1088              
1089              
1090             # Check special cases like tr that need to be uppercased (Tr) to work correctly
1091             # in CGI
1092             #
1093 213   33     1629 $html_tag=$CGI_Tag_Ucase{$html_tag} || $html_tag;
1094              
1095              
1096             # Check valid
1097             #
1098 213 50 66     1222 unless (UNIVERSAL::can('CGI', $html_tag) || $CGI_TAG_WEBDYNE{$html_tag}) {
1099 0         0 return err ("unknown CGI/WebDyne tag: <$html_tag>, line $line_no in source file ${$html_fn_sr}")
  0         0  
1100             }
1101              
1102              
1103             # Get tag attr
1104             #
1105 213 100       339 if (my %attr=map {$_ => $html_or->{$_}} (grep {!/^_/} keys %{$html_or})) {
  120         419  
  1406         3298  
  213         612  
1106              
1107              
1108             # Save tagm attr into node
1109             #
1110             #@data[$WEBDYNE_NODE_NAME_IX, $WEBDYNE_NODE_ATTR_IX]=($html_tag, \%attr);
1111              
1112              
1113             # Is this the inline perl __PERL__ block ?
1114             #
1115 91 100 66     254 if ($html_or->{'_code'} && $attr{'perl'}) {
1116 9         19 push @{$meta_hr->{'perl'}}, \$attr{'perl'};
  9         39  
1117 9         16 push @{$meta_hr->{'perl_debug'}}, [$line_no, $html_fn_sr];
  9         37  
1118             }
1119             else {
1120 82         203 @data[$WEBDYNE_NODE_NAME_IX, $WEBDYNE_NODE_ATTR_IX]=($html_tag, \%attr);
1121             }
1122              
1123             }
1124             else {
1125              
1126              
1127             # No attr, just save tag
1128             #
1129 122         230 $data[$WEBDYNE_NODE_NAME_IX]=$html_tag;
1130              
1131             }
1132              
1133              
1134             # Child nodes
1135             #
1136 213         337 my @html_child=@{$html_or->content()};
  213         454  
1137              
1138              
1139             # Get child, parse down the tree
1140             #
1141 213         964 foreach my $html_child_or (@html_child) {
1142              
1143 303         361 0 && debug("html_child_or $html_child_or");
1144              
1145              
1146             # Ref is a sub-tag, non ref is plain text
1147             #
1148 303 100       500 if (ref($html_child_or)) {
1149              
1150              
1151             # Sub tag. Recurse down tree, updating to nearest line number
1152             #
1153 199         312 $line_no=$html_child_or->{'_line_no'};
1154 199   50     434 my $data_ar=$self->parse($html_child_or, $meta_hr) ||
1155             return err ();
1156              
1157              
1158             # If no node name returned is not an error, just a no-op
1159             #
1160 199 100       385 if ($data_ar->[$WEBDYNE_NODE_NAME_IX]) {
1161 190         255 push @{$data[$WEBDYNE_NODE_CHLD_IX]}, $data_ar;
  190         401  
1162             }
1163              
1164             }
1165             else {
1166              
1167             # Node is just plain text. Used to not insert empty children, but this
1168             # stuffed up
 sections that use \n for spacing/formatting. Now we 
1169             # are more careful
1170             #
1171 104 50 66     518 push(@{$data[$WEBDYNE_NODE_CHLD_IX]}, $html_child_or)
  65   66     185  
      33        
1172             unless (
1173             $html_child_or=~/^\s*$/
1174             &&
1175             ($html_tag ne 'pre') && ($html_tag ne 'textarea') && !$WEBDYNE_COMPILE_NO_SPACE_COMPACTING
1176             );
1177              
1178             }
1179              
1180             }
1181              
1182              
1183             # All done, return data node
1184             #
1185 213         571 return \@data;
1186              
1187             }
1188