File Coverage

blib/lib/WebDyne/HTML/TreeBuilder.pm
Criterion Covered Total %
statement 197 212 92.9
branch 48 56 85.7
condition 27 38 71.0
subroutine 27 30 90.0
pod 6 15 40.0
total 305 351 86.8


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::HTML::TreeBuilder;
15              
16              
17             # Compiler Pragma
18             #
19 1     1   6 use strict qw(vars);
  1         2  
  1         49  
20 1     1   19 use vars qw($VERSION @ISA %CGI_TAG_WEBDYNE %CGI_TAG_IMPLICIT %CGI_TAG_SPECIAL);
  1         3  
  1         60  
21 1     1   4 use warnings;
  1         2  
  1         24  
22 1     1   7 no warnings qw(uninitialized redefine once);
  1         2  
  1         26  
23              
24              
25             # WebDyne Modules
26             #
27 1     1   5 use WebDyne;
  1         1  
  1         23  
28 1     1   4 use WebDyne::Constant;
  1         2  
  1         442  
29 1     1   6 use WebDyne::Base;
  1         3  
  1         11  
30              
31              
32             # External Modules. Keep HTML::Entities or nullification of encode/decode
33             # subs will not work below
34             #
35 1     1   13 use HTML::TreeBuilder;
  1         5  
  1         24  
36 1     1   36 use HTML::Entities;
  1         2  
  1         58  
37 1     1   10 use HTML::Tagset;
  1         2  
  1         40  
38 1     1   7 use IO::File;
  1         6  
  1         172  
39 1     1   6 use Data::Dumper;
  1         2  
  1         3008  
40              
41              
42             # Inheritance
43             #
44             @ISA=qw(HTML::TreeBuilder);
45              
46              
47             # Version information
48             #
49             $VERSION='1.247';
50              
51              
52             # Debug load
53             #
54             0 && debug("Loading %s version $VERSION", __PACKAGE__);
55              
56              
57             # Make a hash of our implictly closed tags. TODO, expand to full list,
58             # instead of most used.
59             #
60             #%CGI_TAG_IMPLICIT=map { $_=>1 } (
61             #
62             # 'popup_menu',
63             # 'textfield',
64             # 'textarea',
65             # 'radio_group',
66             # 'password_field',
67             # 'filefield',
68             # 'scrolling_list',
69             # 'checkbox_group',
70             # 'checkbox',
71             # 'hidden',
72             # 'submit',
73             # 'reset',
74             # 'dump'
75             #
76             # );
77              
78              
79             # Update - get from CGI module, add special dump tag
80             %CGI_TAG_IMPLICIT=map {$_ => 1} (
81              
82             @{$CGI::EXPORT_TAGS{':form'}},
83             'dump'
84              
85             );
86              
87              
88             # Get WebDyne tags from main module
89             #
90             %CGI_TAG_WEBDYNE=%WebDyne::CGI_TAG_WEBDYNE;
91              
92              
93             # The tags below need to be handled specially at compile time - see the method
94             # associated with each tag below.
95             #
96             map {$CGI_TAG_SPECIAL{$_}++} qw(perl script style start_html end_html include);
97              
98              
99             # Nullify Entities encode & decode
100             #
101       0     *HTML::Entities::encode=sub { };
102       389     *HTML::Entities::decode=sub { };
103              
104              
105             # Add to islist items in TreeBuilder
106             #
107             map {$HTML::TreeBuilder::isList{$_}++} keys %CGI_TAG_WEBDYNE;
108              
109              
110             # Need to tell HTML::TagSet about our special elements so
111             #
112             map {$HTML::Tagset::isTableElement{$_}++} keys %CGI_TAG_WEBDYNE;
113              
114              
115             # And that we also block

tag closures

116             #
117             push @HTML::TreeBuilder::p_closure_barriers, keys %CGI_TAG_WEBDYNE;
118              
119              
120             # Local vars neeeded for cross sub comms
121             #
122             our ($Text_fg, $Line_no, $Line_no_next, $Line_no_start, $HTML_Perl_or, @HTML_Wedge);
123              
124              
125             # All done. Positive return
126             #
127             1;
128              
129              
130             #==================================================================================================
131              
132              
133             sub parse_fh {
134              
135              
136             # Get self ref, file handle
137             #
138 14     14 0 30 my ($self, $html_fh)=@_;
139 14         17 0 && debug("parse $html_fh");
140              
141              
142             # Turn off HTML_Perl object global, in case left over from a __PERL__ segment
143             # at the bottom of the last file parsed. Should never happen, as we check in
144             # delete() also
145             #
146 14 50       29 $HTML_Perl_or && ($HTML_Perl_or=$HTML_Perl_or->delete());
147 14         24 undef $Text_fg;
148 14         22 undef $Line_no;
149 14         15 undef $Line_no_start;
150 14         18 undef $Line_no_next;
151 14         24 undef @HTML_Wedge;
152              
153              
154             # Return closure code ref that understands how to count line
155             # numbers and wedge in extra code
156             #
157             my $parse_cr=sub {
158              
159             #$Line_no++;
160 388     388   566 my $line;
161 388 100       1405 my $html=@HTML_Wedge ? shift @HTML_Wedge : ($line=<$html_fh>);
162 388 100       787 if ($line) {
163 356         415 0 && debug("line $line");
164 356         1012 my @cr=($line=~/\n/g);
165 356   100     664 $Line_no=$Line_no_next || 1;
166 356         524 $Line_no_next=$Line_no+@cr;
167 356         550 0 && debug("Line $Line_no, Line_no_next $Line_no_next, Line_no_start $Line_no_start cr %s", scalar @cr);
168             }
169 388         1663 return $html;
170              
171 14         103 };
172 14         60 return $parse_cr;
173              
174             }
175              
176              
177             sub delete {
178              
179              
180             # Destroy tree, reset any globals
181             #
182 14     14 1 31 my $self=shift();
183 14         17 0 && debug('delete');
184              
185              
186             # Get rid of inline HTML object, if still around
187             #
188 14 100       67 $HTML_Perl_or && ($HTML_Perl_or=$HTML_Perl_or->delete());
189              
190              
191             # Reset script and line number vars
192             #
193 14         298 undef $Text_fg;
194 14         22 undef $Line_no;
195 14         21 undef $Line_no_next;
196 14         17 undef $Line_no_start;
197 14         23 undef @HTML_Wedge;
198              
199              
200             # Run real deal from parent
201             #
202 14         75 $self->SUPER::delete(@_);
203              
204              
205             }
206              
207              
208             sub tag_parse {
209              
210              
211             # Get our self ref
212             #
213 513     513 0 859 my ($self, $method)=(shift, shift);
214              
215              
216             # Get the tag, tag attr
217             #
218 513         807 my ($tag, $attr_hr)=@_;
219              
220              
221             # Debug
222             #
223 513         599 0 && debug("tag_parse $method, $tag, line $Line_no, line_no_start $Line_no_start");
224              
225              
226             # Get the parent tag
227             #
228 513         599 my $pos;
229             my $tag_parent=(
230             $pos=$self->{'_pos'} || $self
231 513   66     1255 )->{'_tag'};
232 513         581 0 && debug("tag $tag, tag_parent $tag_parent");
233              
234              
235             # Var to hold returned html object ref
236             #
237 513         619 my $html_or;
238              
239              
240             # If it is an below an implicit parent tag close that tag now.
241             #
242 513 100 66     4691 if ($CGI_TAG_IMPLICIT{$tag_parent} || $tag_parent=~/^start_/i || $tag_parent=~/^end_/i) {
    100 66        
    100 100        
    100 100        
    100 66        
    100 66        
      100        
243              
244             # End implicit parent if it was an implicit tag
245             #
246 2         8 0 && debug("ending implicit parent tag $tag_parent");
247 2         7 $self->end($tag_parent);
248 2         8 $html_or=$self->$method(@_);
249              
250             }
251              
252              
253             # Special case where wraps or tags. HTML::TreeBuilder assumes
254             # head is always under html - we have to hack.
255             #
256             elsif ($CGI_TAG_WEBDYNE{$tag_parent} && ($tag eq 'head')) {
257              
258             # Debug and modify tree
259             #
260 1         6 0 && debug("found $tag_parent above $tag, modifying tree");
261 1         8 $self->{'_head'}->preinsert($pos);
262 1         58 $self->{'_head'}->detach();
263 1         17 $pos->push_content($self->{'_head'});
264 1         27 $self->$method(@_);
265              
266             }
267              
268              
269             # Same for body tag as above
270             #
271             elsif ($CGI_TAG_WEBDYNE{$tag_parent} && ($tag eq 'body')) {
272              
273 1         7 0 && debug("found $tag_parent above $tag, modifying tree");
274 1         7 $self->{'_body'}->preinsert($pos);
275 1         48 $self->{'_body'}->detach();
276 1         15 $pos->push_content($self->{'_body'});
277 1         17 $self->$method(@_);
278              
279             }
280              
281              
282             # If it is an custom webdyne tag, massage with methods below
283             # before processing
284             #
285             elsif ($CGI_TAG_SPECIAL{$tag} && ($method ne 'SUPER::text')) {
286              
287              
288             # Yes, is WebDyne tag
289             #
290 47         70 0 && debug("webdyne tag ($tag) dispatch");
291 47         171 $html_or=$self->$tag($method, $tag, $attr_hr);
292              
293             }
294              
295              
296             # If it is an custom CGI tag that we need to close implicityly
297             #
298             elsif ($CGI_TAG_IMPLICIT{$tag_parent} || $tag=~/^start_/i || $tag=~/^end_/) {
299              
300              
301             # Yes, is CGI tag
302             #
303 8         17 0 && debug("webdyne tag ($tag) dispatch");
304 8         21 $html_or=$self->$method(@_);
305 8         939 $self->end($tag)
306              
307             }
308              
309              
310             # If its parent was a custom webdyne tag, the turn off implicitness
311             # before processing
312             #
313             elsif ($CGI_TAG_WEBDYNE{$tag_parent}) {
314              
315              
316             # Turn off implicitness here to stop us from being moved
317             # around in the parse tree if we are under a table or some
318             # such
319             #
320 77         114 0 && debug('turning off implicit tags');
321 77         196 $self->implicit_tags(0);
322              
323              
324             # Run the WebDyne tag method.
325             #
326 77         617 0 && debug("webdyne tag_parent ($tag_parent) dispatch");
327 77         150 $html_or=$self->$tag_parent($method, $tag, $attr_hr);
328              
329              
330             # Turn implicitness back on again
331             #
332 77         2071 0 && debug('turning on implicit tags');
333 77         171 $self->implicit_tags(1);
334              
335              
336             }
337             else {
338              
339              
340             # Pass onto our base class for further processing
341             #
342 377         472 0 && debug("base class method $method");
343 377         1029 $html_or=$self->$method(@_);
344              
345              
346             }
347              
348              
349             # Insert line number if possible
350             #
351 513         26304 0 && debug("insert line_no $Line_no, line_no_start $Line_no_start into object ref $html_or");
352 513 100       1055 ref($html_or) && (@{$html_or}{'_line_no', '_line_no_tag_end'}=($Line_no_start, $Line_no));
  201         466  
353              
354              
355             # Returm object ref
356             #
357 513         911 $html_or;
358              
359              
360             }
361              
362              
363             sub block {
364              
365              
366             # No special handling needed, just log for debugging purposes
367             #
368 30     30 0 48 my ($self, $method)=(shift, shift);
369 30         35 0 && debug("block self $self, method $method, @_ text_fg $Text_fg");
370 30         70 $self->$method(@_);
371              
372             }
373              
374              
375             sub script {
376              
377 2     2 0 10 my ($self, $method, $tag, $attr_hr)=@_;
378 2         4 0 && debug('script');
379 2         3 $Text_fg='script';
380 2         10 my $or=$self->$method($tag, $attr_hr, @_);
381 2 100       273 $or->postinsert('') if $attr_hr->{'src'};
382 2         33 $or;
383              
384             }
385              
386              
387             sub style {
388              
389 0     0 0 0 my ($self, $method)=(shift, shift);
390 0         0 0 && debug('style');
391 0         0 $Text_fg='style';
392 0         0 $self->$method(@_);
393              
394             }
395              
396              
397             sub perl {
398              
399              
400             # Special handling of perl tag
401             #
402 71     71 0 189 my ($self, $method, $tag, $attr_hr)=@_;
403 71         80 0 && debug("$tag $method");
404              
405              
406             # Call SUPER method, check if inline
407             #
408 71         158 my $html_perl_or=$self->$method($tag, $attr_hr);
409 71         6861 my $inline;
410 71 100       161 if ($tag eq 'perl') {
411 24 100       41 unless (grep {exists $attr_hr->{$_}} qw(package class method)) {
  72         159  
412 3         14 $html_perl_or->attr(inline => ++$inline);
413             }
414             }
415 71 100       170 if ($inline) {
416              
417             # Inline tag, set global var to this element so any extra text can be
418             # added here
419             #
420 3         8 $HTML_Perl_or=$html_perl_or;
421 3         8 $Text_fg='perl';
422              
423              
424             # And return it
425             #
426 3         9 return $html_perl_or;
427              
428             }
429             else {
430              
431              
432             # Not inline, just return object
433             #
434 68         127 return $html_perl_or;
435              
436             }
437              
438              
439             }
440              
441              
442             sub process {
443              
444             # Rough and ready process handler, try to handle perl code in . Not sure if I really
445             # want to support this yet ...
446             #
447 3     3 1 10 my ($self, $text)=@_;
448 3         6 0 && debug("process $text");
449 3         10 my $or=HTML::Element->new('perl', inline => 1, perl => $text);
450 3         89 0 && debug("insert line_no $Line_no into object ref $or");
451 3         14 @{$or}{'_line_no', '_line_no_tag_end'}=($Line_no_start, $Line_no);
  3         8  
452 3         10 $self->tag_parse('SUPER::text', $or)
453              
454             }
455              
456              
457             sub start {
458              
459              
460             # Ugly, make sure if in perl or script tag, whatever we see counts
461             # as text
462             #
463 203     203 1 502 my ($self, $tag)=(shift, shift);
464 203         325 my $text=$_[2];
465 203 50       467 ref($tag) || ($tag=lc($tag));
466 203         2082 0 && debug("start $tag Line_no $Line_no, @_, %s", Data::Dumper::Dumper(\@_));
467 203         236 my $html_or;
468 203 50       344 if ($Text_fg) {
469 0         0 $html_or=$self->text($text)
470             }
471             else {
472 203         512 my @cr=($text=~/\n/g);
473 203         309 $Line_no_start=$Line_no-@cr;
474 203         250 0 && debug("tag $tag line_no $Line_no, line_no_start $Line_no_start");
475 203         433 $html_or=$self->tag_parse('SUPER::start', $tag, @_);
476              
477             }
478 203         1121 $html_or;
479              
480             }
481              
482              
483             sub end {
484              
485              
486             # Ugly special case conditions, ensure end tag between perl or script
487             # blocks are treated as text
488             #
489 216     216 1 3318 my ($self, $tag)=(shift, shift);
490 216 100       448 ref($tag) || ($tag=lc($tag));
491 216         239 0 && debug("end $tag, text_fg $Text_fg, line $Line_no");
492 216         252 my $html_or;
493 216 100 66     525 if ($Text_fg && ($tag eq $Text_fg)) {
    50          
494 5         14 $Text_fg=undef;
495 5         19 $html_or=$self->SUPER::end($tag, @_)
496             }
497             elsif ($Text_fg) {
498 0         0 $html_or=$self->text($_[0])
499             }
500             else {
501 211         493 $html_or=$self->SUPER::end($tag, @_)
502             }
503 216         11943 $html_or;
504              
505              
506             }
507              
508              
509             # Reminder to self. Keep this in, or implicit CGI tags will not be closed
510             # if text block follows implicit CGI tag immediately
511             #
512             sub text {
513              
514              
515             # get self ref, text we will process
516             #
517 408     408 1 1354 my ($self, $text)=@_;
518 408         486 0 && debug("text *$text*, text_fg $Text_fg, pos %s", $self->{'_pos'});
519              
520              
521             # Are we in an inline perl block ?
522             #
523 408 100 66     1482 if ($Text_fg eq 'perl') {
    100          
    50          
524              
525              
526             # Yes. We have inline perl code, not text. Just add to perl attribute, which
527             # is treated specially when rendering
528             #
529 92         99 0 && debug('in __PERL__ tag, appending text to __PERL__ block');
530              
531             # Strip leading CR from Perl code so line numbers in errors make sense
532             #unless ($HTML_Perl_or->{'perl'}) { $text=~s/^\n// }
533 92         167 $HTML_Perl_or->{'perl'}.=$text;
534 92         117 $HTML_Perl_or->{'_line_no_tag_end'}=$Line_no;
535              
536              
537             }
538              
539             # Used to do this so __PERL__ block would only count if at end of file.
540             #elsif (($text=~/^\W*__CODE__/ || $text=~/^\W*__PERL__/) && !$self->{'_pos'}) {
541              
542             elsif (($text=~/^\W*__CODE__/ || $text=~/^\W*__PERL__/)) {
543              
544              
545             # Close off any HTML
546             #
547 9 50       51 delete $self->{'_pos'} if $self->{'_pos'};
548              
549              
550             # Perl code fragment. Will be last thing we do, as __PERL__ must be at the
551             # bottom of the file.
552             #
553 9         16 0 && debug('found __PERL__ tag');
554 9         16 $Text_fg='perl';
555 9         61 $self->implicit(0);
556 9         181 $self->push_content($HTML_Perl_or=HTML::Element->new('perl', inline => 1));
557 9         384 0 && debug("insert line_no $Line_no into object ref $HTML_Perl_or");
558 9         18 @{$HTML_Perl_or}{'_line_no', '_line_no_tag_end'}=($Line_no, $Line_no);
  9         24  
559 9         29 $HTML_Perl_or->{'_code'}++;
560              
561             }
562             elsif ($text=~/^\W*__END__/) {
563              
564              
565             # End of file
566             #
567 0         0 0 && debug('found __END__ tag, running eof');
568 0         0 $self->eof();
569              
570             }
571             else {
572              
573             # Normal text, process by parent class after handling any subst flags in code
574             #
575             #if ($text=~/([$|!|+|^|*]+)\{([$|!|+]?)(.*?)\2\}/gs) {
576 307 100       589 if ($text=~/([$|!|+|^|*]+)\{([$|!|+]?)(.*?)\2\}/s) {
577              
578             # Meeds subst. Get rid of cr's at start and end of text after a tag, stuffs up formatting in
 sections 
579             #
580 16         28 0 && debug("found subst tag line_no_start $Line_no_start, line_no $Line_no, text '$text'");
581 16         72 my @cr=($text=~/\n/g);
582 16 50       56 if (my $html_or=$self->{'_pos'}) {
583 16         22 0 && debug("parent %s", $html_or->tag());
584 16 100 66     42 if (($html_or->tag() eq 'perl') && !$html_or->attr('inline')) {
585 3         72 0 && debug('hit !');
586              
587             #$text=~s/^\n//;
588             #$text=~s/\n$//;
589             }
590             }
591              
592 16         127 my $or=HTML::Element->new('subst');
593 16         332 my $line_no_start=$Line_no;
594 16         21 0 && debug("insert line_no $Line_no_start, line_no_tag_end $Line_no into object ref $or for text $text, cr %s", scalar @cr);
595 16         30 @{$or}{'_line_no', '_line_no_tag_end'}=($line_no_start, $Line_no);
  16         49  
596 16         46 $or->push_content($text);
597 16         207 $self->tag_parse('SUPER::text', $or)
598             }
599             else {
600              
601             # No subst, process as normal
602             #
603 291         326 0 && debug('processing as normal text');
604 291         506 $self->tag_parse('SUPER::text', $text)
605             }
606              
607             }
608              
609              
610             # Return self ref. Not really sure if this is what we should really return, but
611             # seems to work
612             #
613 408         2078 $self;
614              
615             }
616              
617              
618             sub comment {
619              
620 0     0 1 0 0 && debug('comment');
621 0         0 my $self=shift()->SUPER::comment(@_);
622 0         0 0 && debug("insert line_no $Line_no into object ref $self");
623 0         0 @{$self}{'_line_no', '_line_no_tag_end'}=($Line_no_start, $Line_no);
  0         0  
624 0         0 $self;
625              
626             }
627              
628              
629             sub start_html {
630              
631             # Need to handle this specially ..
632 10     10 0 30 my ($self, $method, $tag, $attr_hr)=@_;
633 10 50       28 if ($WEBDYNE_CONTENT_TYPE_HTML_META) {
634 0   0     0 $attr_hr->{'head'} ||= &CGI::meta({"http-equiv" => "Content-Type", content => $WEBDYNE_CONTENT_TYPE_HTML})
635             }
636 10         74 my $html=&CGI::start_html_cgi($attr_hr);
637 10         6084 0 && debug("html is $html");
638 10         24 push @HTML_Wedge, $html;
639 10         24 $self;
640             }
641              
642              
643             sub end_html {
644              
645             # Need to handle this specially ..
646 8     8 0 33 my ($self, $method, $tag, $attr_hr)=@_;
647 8         42 my $html=&CGI::end_html_cgi($attr_hr);
648 8         42 0 && debug("html is $html");
649 8         22 push @HTML_Wedge, $html;
650 8         18 $self;
651             }
652              
653              
654             sub include {
655              
656              
657             # No special handling needed, just log for debugging purposes
658             #
659 3     3 0 13 my ($self, $method)=(shift, shift);
660 3         6 0 && debug("block self $self, method $method, @_ text_fg $Text_fg");
661 3         13 $self->$method(@_);
662              
663              
664             }
665              
666