#
#
#  Copyright (C) 2006-2010 Andrew Speer <andrew@webdyne.org>.
#  All rights reserved.
#
#  This file is part of WebDyne.
#
#  WebDyne is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
#
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;


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


#  Version information
#
$VERSION='1.015';


#  Debug load
#
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 <p> 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)=@_;
    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) {
            debug("line $line");
            my @cr=($line=~/\n/g);
            $Line_no=$Line_no_next || 1;
            $Line_no_next=$Line_no+@cr;
            debug("Line $Line_no, Line_no_next $Line_no_next, Line_no_start $Line_no_start cr %s", scalar @cr);
        }
        return $html;

    }

}


sub delete {


    #  Destroy tree, reset any globals
    #
    my $self=shift();
    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
    #
    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'};
    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
	#
	debug("ending implicit parent tag $tag_parent");
	$self->end($tag_parent);

    }


    #  Special case where <perl/block/etc> wraps <head> or <body> 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
	#
	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')) {

    	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
	#
	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
	#
	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
	#
	debug('turning off implicit tags');
	$self->implicit_tags(0);


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


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



    }
    else {


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


    }


    #  Insert line number if possible
    #
    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);
    debug("block self $self, method $method, @_ text_fg $Text_fg");
    $self->$method(@_);

}


sub script {

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

}


sub style {

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

}


sub perl {


    #  Special handling of perl tag
    #
    my ($self, $method, $tag, $attr_hr)=@_;
    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)=@_;
    debug("process $text");
    my $or=HTML::Element->new('perl', inline=>1, perl=>$text);
    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));
    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;
        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));
    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)=@_;
    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
	#
        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;


    }
    
    #  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.
	#
	debug('found __PERL__ tag');
	$Text_fg='perl';
	$self->implicit(0);
	$self->push_content($HTML_Perl_or=HTML::Element->new('perl', inline=>1));
        debug("insert line_no $Line_no into object ref $HTML_Perl_or");
	@{$HTML_Perl_or}{'_line_no', '_line_no_tag_end'}=($Line_no_start, $Line_no);
	$HTML_Perl_or->{'_code'}++;

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


        #  End of file
        #
        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 <perl> tag, stuffs up formatting in <pre> sections
	    #
	    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'}) {
		debug("parent %s", $html_or->tag());
		if (($html_or->tag() eq 'perl') && !$html_or->attr('inline')) {
		    debug('hit !');
		    #$text=~s/^\n//;
		    #$text=~s/\n$//;
		}
	    }

	    my $or=HTML::Element->new('subst');
	    #$or->{'_line_no'}=$Line_no_start;
	    $Line_no_start=$Line_no - scalar @cr;
            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
	    #
	    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 {

    debug('comment');
    my $self=shift()->SUPER::comment(@_);
    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);
    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);
    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);
    debug("block self $self, method $method, @_ text_fg $Text_fg");
    $self->$method(@_);


}


