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

#
#  This file is part of WebDyne.
#
#  This software is Copyright (c) 2017 by Andrew Speer .
#
#  This is free software, licensed under:
#
#    The GNU General Public License, Version 2, June 1991
#
#  Full license text is available at:
#
#
#
package WebDyne::HTML::TreeBuilder;


#  Compiler Pragma
#
use strict qw(vars);
use vars qw($VERSION @ISA %CGI_TAG_WEBDYNE %CGI_TAG_IMPLICIT %CGI_TAG_SPECIAL);
use warnings;
no warnings qw(uninitialized redefine once);


#  WebDyne Modules
#
use WebDyne;
use WebDyne::Constant;
use WebDyne::Base;


#  External Modules. Keep HTML::Entities or nullification of encode/decode
#  subs will not work below
#
use HTML::TreeBuilder;
use HTML::Entities;
use HTML::Tagset;
use IO::File;
use Data::Dumper;


#  Inheritance
#
@ISA=qw(HTML::TreeBuilder);


#  Version information
#
$VERSION='1.247';


#  Debug load
#
0 && debug("Loading %s version $VERSION", __PACKAGE__);


#  Make a hash of our implictly closed tags. TODO, expand to full list,
#  instead of most used.
#
#%CGI_TAG_IMPLICIT=map { $_=>1 } (
#
#    'popup_menu',
#    'textfield',
#    'textarea',
#    'radio_group',
#    'password_field',
#    'filefield',
#    'scrolling_list',
#    'checkbox_group',
#    'checkbox',
#    'hidden',
#    'submit',
#    'reset',
#    'dump'
#
#   );


#  Update - get from CGI module, add special dump tag
%CGI_TAG_IMPLICIT=map {$_ => 1} (

    @{$CGI::EXPORT_TAGS{':form'}},
    'dump'

);


#  Get WebDyne tags from main module
#
%CGI_TAG_WEBDYNE=%WebDyne::CGI_TAG_WEBDYNE;


#  The tags below need to be handled specially at compile time - see the method
#  associated with each tag below.
#
map {$CGI_TAG_SPECIAL{$_}++} qw(perl script style start_html end_html include);


#  Nullify Entities encode & decode
#
*HTML::Entities::encode=sub { };
*HTML::Entities::decode=sub { };


#  Add to islist items in TreeBuilder
#
map {$HTML::TreeBuilder::isList{$_}++} keys %CGI_TAG_WEBDYNE;


#  Need to tell HTML::TagSet about our special elements so
#
map {$HTML::Tagset::isTableElement{$_}++} keys %CGI_TAG_WEBDYNE;


#  And that we also block  tag closures
#
push @HTML::TreeBuilder::p_closure_barriers, keys %CGI_TAG_WEBDYNE;


#  Local vars neeeded for cross sub comms
#
our ($Text_fg, $Line_no, $Line_no_next, $Line_no_start, $HTML_Perl_or, @HTML_Wedge);


#  All done. Positive return
#
1;


#==================================================================================================


sub parse_fh {


    #  Get self ref, file handle
    #
    my ($self, $html_fh)=@_;
    0 && debug("parse $html_fh");


    #  Turn off HTML_Perl object global, in case left over from a __PERL__ segment
    #  at the bottom of the last file parsed. Should never happen, as we check in
    #  delete() also
    #
    $HTML_Perl_or && ($HTML_Perl_or=$HTML_Perl_or->delete());
    undef $Text_fg;
    undef $Line_no;
    undef $Line_no_start;
    undef $Line_no_next;
    undef @HTML_Wedge;


    #  Return closure code ref that understands how to count line
    #  numbers and wedge in extra code
    #
    my $parse_cr=sub {

        #$Line_no++;
        my $line;
        my $html=@HTML_Wedge ? shift @HTML_Wedge : ($line=<$html_fh>);
        if ($line) {
            0 && debug("line $line");
            my @cr=($line=~/\n/g);
            $Line_no=$Line_no_next || 1;
            $Line_no_next=$Line_no+@cr;
            0 && debug("Line $Line_no, Line_no_next $Line_no_next, Line_no_start $Line_no_start cr %s", scalar @cr);
        }
        return $html;

    };
    return $parse_cr;

}


sub delete {


    #  Destroy tree, reset any globals
    #
    my $self=shift();
    0 && debug('delete');


    #  Get rid of inline HTML object, if still around
    #
    $HTML_Perl_or && ($HTML_Perl_or=$HTML_Perl_or->delete());


    #  Reset script and line number vars
    #
    undef $Text_fg;
    undef $Line_no;
    undef $Line_no_next;
    undef $Line_no_start;
    undef @HTML_Wedge;


    #  Run real deal from parent
    #
    $self->SUPER::delete(@_);


}


sub tag_parse {


    #  Get our self ref
    #
    my ($self, $method)=(shift, shift);


    #  Get the tag, tag attr
    #
    my ($tag, $attr_hr)=@_;


    #  Debug
    #
    0 && debug("tag_parse $method, $tag, line $Line_no, line_no_start $Line_no_start");


    #  Get the parent tag
    #
    my $pos;
    my $tag_parent=(
        $pos=$self->{'_pos'} || $self
    )->{'_tag'};
    0 && debug("tag $tag, tag_parent $tag_parent");


    #  Var to hold returned html object ref
    #
    my $html_or;


    #  If it is an below an implicit parent tag close that tag now.
    #
    if ($CGI_TAG_IMPLICIT{$tag_parent} || $tag_parent=~/^start_/i || $tag_parent=~/^end_/i) {

        #  End implicit parent if it was an implicit tag
        #
        0 && debug("ending implicit parent tag $tag_parent");
        $self->end($tag_parent);
        $html_or=$self->$method(@_);

    }


    #  Special case where  wraps  or  tags. HTML::TreeBuilder assumes
    #  head is always under html - we have to hack.
    #
    elsif ($CGI_TAG_WEBDYNE{$tag_parent} && ($tag eq 'head')) {

        #  Debug and modify tree
        #
        0 && debug("found $tag_parent above $tag, modifying tree");
        $self->{'_head'}->preinsert($pos);
        $self->{'_head'}->detach();
        $pos->push_content($self->{'_head'});
        $self->$method(@_);

    }


    #  Same for body tag as above
    #
    elsif ($CGI_TAG_WEBDYNE{$tag_parent} && ($tag eq 'body')) {

        0 && debug("found $tag_parent above $tag, modifying tree");
        $self->{'_body'}->preinsert($pos);
        $self->{'_body'}->detach();
        $pos->push_content($self->{'_body'});
        $self->$method(@_);

    }


    #  If it is an custom webdyne tag, massage with methods below
    #  before processing
    #
    elsif ($CGI_TAG_SPECIAL{$tag} && ($method ne 'SUPER::text')) {


        #  Yes, is WebDyne tag
        #
        0 && debug("webdyne tag ($tag) dispatch");
        $html_or=$self->$tag($method, $tag, $attr_hr);

    }


    #  If it is an custom CGI tag that we need to close implicityly
    #
    elsif ($CGI_TAG_IMPLICIT{$tag_parent} || $tag=~/^start_/i || $tag=~/^end_/) {


        #  Yes, is CGI tag
        #
        0 && debug("webdyne tag ($tag) dispatch");
        $html_or=$self->$method(@_);
        $self->end($tag)

    }


    #  If its parent was a custom webdyne tag, the turn off implicitness
    #  before processing
    #
    elsif ($CGI_TAG_WEBDYNE{$tag_parent}) {


        #  Turn off implicitness here to stop us from being moved
        #  around in the parse tree if we are under a table or some
        #  such
        #
        0 && debug('turning off implicit tags');
        $self->implicit_tags(0);


        #  Run the WebDyne tag method.
        #
        0 && debug("webdyne tag_parent ($tag_parent) dispatch");
        $html_or=$self->$tag_parent($method, $tag, $attr_hr);


        #  Turn implicitness back on again
        #
        0 && debug('turning on implicit tags');
        $self->implicit_tags(1);


    }
    else {


        #  Pass onto our base class for further processing
        #
        0 && debug("base class method $method");
        $html_or=$self->$method(@_);


    }


    #  Insert line number if possible
    #
    0 && debug("insert line_no $Line_no, line_no_start $Line_no_start into object ref $html_or");
    ref($html_or) && (@{$html_or}{'_line_no', '_line_no_tag_end'}=($Line_no_start, $Line_no));


    #  Returm object ref
    #
    $html_or;


}


sub block {


    #  No special handling needed, just log for debugging purposes
    #
    my ($self, $method)=(shift, shift);
    0 && debug("block self $self, method $method, @_ text_fg $Text_fg");
    $self->$method(@_);

}


sub script {

    my ($self, $method, $tag, $attr_hr)=@_;
    0 && debug('script');
    $Text_fg='script';
    my $or=$self->$method($tag, $attr_hr, @_);
    $or->postinsert('') if $attr_hr->{'src'};
    $or;

}


sub style {

    my ($self, $method)=(shift, shift);
    0 && debug('style');
    $Text_fg='style';
    $self->$method(@_);

}


sub perl {


    #  Special handling of perl tag
    #
    my ($self, $method, $tag, $attr_hr)=@_;
    0 && debug("$tag $method");


    #  Call SUPER method, check if inline
    #
    my $html_perl_or=$self->$method($tag, $attr_hr);
    my $inline;
    if ($tag eq 'perl') {
        unless (grep {exists $attr_hr->{$_}} qw(package class method)) {
            $html_perl_or->attr(inline => ++$inline);
        }
    }
    if ($inline) {

        #  Inline tag, set global var to this element so any extra text can be
        #  added here
        #
        $HTML_Perl_or=$html_perl_or;
        $Text_fg='perl';


        #  And return it
        #
        return $html_perl_or;

    }
    else {


        #  Not inline, just return object
        #
        return $html_perl_or;

    }


}


sub process {

    #  Rough and ready process handler, try to handle perl code in . Not sure if I really
    #  want to support this yet ...
    #
    my ($self, $text)=@_;
    0 && debug("process $text");
    my $or=HTML::Element->new('perl', inline => 1, perl => $text);
    0 && debug("insert line_no $Line_no into object ref $or");
    @{$or}{'_line_no', '_line_no_tag_end'}=($Line_no_start, $Line_no);
    $self->tag_parse('SUPER::text', $or)

}


sub start {


    #  Ugly, make sure if in perl or script tag, whatever we see counts
    #  as text
    #
    my ($self, $tag)=(shift, shift);
    my $text=$_[2];
    ref($tag) || ($tag=lc($tag));
    0 && debug("start $tag Line_no $Line_no, @_, %s", Data::Dumper::Dumper(\@_));
    my $html_or;
    if ($Text_fg) {
        $html_or=$self->text($text)
    }
    else {
        my @cr=($text=~/\n/g);
        $Line_no_start=$Line_no-@cr;
        0 && debug("tag $tag line_no $Line_no, line_no_start $Line_no_start");
        $html_or=$self->tag_parse('SUPER::start', $tag, @_);

    }
    $html_or;

}


sub end {


    #  Ugly special case conditions, ensure end tag between perl or script
    #  blocks are treated as text
    #
    my ($self, $tag)=(shift, shift);
    ref($tag) || ($tag=lc($tag));
    0 && debug("end $tag, text_fg $Text_fg, line $Line_no");
    my $html_or;
    if ($Text_fg && ($tag eq $Text_fg)) {
        $Text_fg=undef;
        $html_or=$self->SUPER::end($tag, @_)
    }
    elsif ($Text_fg) {
        $html_or=$self->text($_[0])
    }
    else {
        $html_or=$self->SUPER::end($tag, @_)
    }
    $html_or;


}


#  Reminder to self. Keep this in, or implicit CGI tags will not be closed
#  if text block follows implicit CGI tag immediately
#
sub text {


    #  get self ref, text we will process
    #
    my ($self, $text)=@_;
    0 && debug("text *$text*, text_fg $Text_fg, pos %s", $self->{'_pos'});


    #  Are we in an inline perl block ?
    #
    if ($Text_fg eq 'perl') {


        #  Yes. We have inline perl code, not text. Just add to perl attribute, which
        #  is treated specially when rendering
        #
        0 && debug('in __PERL__ tag, appending text to __PERL__ block');

        #  Strip leading CR from Perl code so line numbers in errors make sense
        #unless ($HTML_Perl_or->{'perl'}) { $text=~s/^\n// }
        $HTML_Perl_or->{'perl'}.=$text;
        $HTML_Perl_or->{'_line_no_tag_end'}=$Line_no;


    }

    #  Used to do this so __PERL__ block would only count if at end of file.
    #elsif (($text=~/^\W*__CODE__/ || $text=~/^\W*__PERL__/) && !$self->{'_pos'}) {

    elsif (($text=~/^\W*__CODE__/ || $text=~/^\W*__PERL__/)) {


        #  Close off any HTML
        #
        delete $self->{'_pos'} if $self->{'_pos'};


        #  Perl code fragment. Will be last thing we do, as __PERL__ must be at the
        #  bottom of the file.
        #
        0 && debug('found __PERL__ tag');
        $Text_fg='perl';
        $self->implicit(0);
        $self->push_content($HTML_Perl_or=HTML::Element->new('perl', inline => 1));
        0 && debug("insert line_no $Line_no into object ref $HTML_Perl_or");
        @{$HTML_Perl_or}{'_line_no', '_line_no_tag_end'}=($Line_no, $Line_no);
        $HTML_Perl_or->{'_code'}++;

    }
    elsif ($text=~/^\W*__END__/) {


        #  End of file
        #
        0 && debug('found __END__ tag, running eof');
        $self->eof();

    }
    else {

        #  Normal text, process by parent class after handling any subst flags in code
        #
        #if ($text=~/([$|!|+|^|*]+)\{([$|!|+]?)(.*?)\2\}/gs) {
        if ($text=~/([$|!|+|^|*]+)\{([$|!|+]?)(.*?)\2\}/s) {

            #  Meeds subst. Get rid of cr's at start and end of text after a  tag, stuffs up formatting in  sections
            #
            0 && debug("found subst tag line_no_start $Line_no_start, line_no $Line_no, text '$text'");
            my @cr=($text=~/\n/g);
            if (my $html_or=$self->{'_pos'}) {
                0 && debug("parent %s", $html_or->tag());
                if (($html_or->tag() eq 'perl') && !$html_or->attr('inline')) {
                    0 && debug('hit !');

                    #$text=~s/^\n//;
                    #$text=~s/\n$//;
                }
            }

            my $or=HTML::Element->new('subst');
            my $line_no_start=$Line_no;
            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);
            @{$or}{'_line_no', '_line_no_tag_end'}=($line_no_start, $Line_no);
            $or->push_content($text);
            $self->tag_parse('SUPER::text', $or)
        }
        else {

            # No subst, process as normal
            #
            0 && debug('processing as normal text');
            $self->tag_parse('SUPER::text', $text)
        }

    }


    #  Return self ref. Not really sure if this is what we should really return, but
    #  seems to work
    #
    $self;

}


sub comment {

    0 && debug('comment');
    my $self=shift()->SUPER::comment(@_);
    0 && debug("insert line_no $Line_no into object ref $self");
    @{$self}{'_line_no', '_line_no_tag_end'}=($Line_no_start, $Line_no);
    $self;

}


sub start_html {

    #  Need to handle this specially ..
    my ($self, $method, $tag, $attr_hr)=@_;
    if ($WEBDYNE_CONTENT_TYPE_HTML_META) {
        $attr_hr->{'head'} ||= &CGI::meta({"http-equiv" => "Content-Type", content => $WEBDYNE_CONTENT_TYPE_HTML})
    }
    my $html=&CGI::start_html_cgi($attr_hr);
    0 && debug("html is $html");
    push @HTML_Wedge, $html;
    $self;
}


sub end_html {

    #  Need to handle this specially ..
    my ($self, $method, $tag, $attr_hr)=@_;
    my $html=&CGI::end_html_cgi($attr_hr);
    0 && debug("html is $html");
    push @HTML_Wedge, $html;
    $self;
}


sub include {


    #  No special handling needed, just log for debugging purposes
    #
    my ($self, $method)=(shift, shift);
    0 && debug("block self $self, method $method, @_ text_fg $Text_fg");
    $self->$method(@_);


}