package ML::Parser;

use base HTML::Parser;
use ML::Tree;
use strict;

sub new
{
    my $class = shift;
    $class = ref( $class ) || $class;
    my $this = HTML::Parser->new();
    $this->{ 'node' } = undef;
    $this->{ 'fl' } =  "";
    $this->{ 'usefl' } =  0;
    $this->{ 'debug' } =  0;
    $this->{ 'warn' } =  0;
    $this->{ 'dtd' } =  {};
    $this->{ 'textacc' } =  '';

    for( my $i = 0; $i < $#_; $i += 2 ) { $this->{ $_[$i] } = $_[$i+1]; }
    return bless( $this, $class );
}

sub ParseFile
{
    my ($this, $file) = @_;
    my ($row, $line, $node);
    local *FH;
    open FH, $file or die "Cannot open $file";

    if( defined( $this->{'node'} ) ) { die "internal error - node defined"; }

    $this->{ 'node' } = new ML::Tree( 'FILE', { 'file' => $file } );
    $this->{ 'level' } = 0;
    if( defined( $this->{ 'dtd' }{ 'FILE' } ) )
    {
        $this->{'node'}{'dtd'} = $this->{ 'dtd' }{ 'FILE' };
    }


    $this->DPrint( "Parsing file \"$file\"" );
    $line = 0;
    while( $row = <FH> )
    {
        $line ++;
        $this->{ 'fl' } = "$file:$line";
        $this->parse($row);
    }
    close FH;
    $this->eof;
    $this->flushtext;

    $this->DPrint( "File end" );

    if( defined( $this->{'node'}{'parent'} ) || $this->{'level'} != 0 )
    { die "internal error - document without end tag"; }

    $node = $this->{'node'};
    $this->{'node'} = undef;
    return $node;
}       

sub ApplyDTD
{
    my( $this, $node ) = @_;
    my $tagname = $node->{'tag'};
    my $dtd;

    DTD: while( $dtd = $this->{'node'}{ 'dtd' } )
    {
        if( InArray( $dtd->[1], $tagname ) )     # ok, process
        { last; }
        else
        { 
            for( my $i = 2; $i <= $#{$dtd}; ++ $i ) # run dispatches
            {

                my $retval = &{$dtd->[$i]}( $this, $tagname, $node );
                if( defined( $retval ) && $retval == 1 )  # proceed next
                { next DTD; }
                elsif( defined( $retval ) && $retval == 0 ) # ignore tag
                { 
                    $this->WPrint( "warn:$this->{'fl'} " .
                                   "<$tagname> ignored by DTD " .
                                   "in $this->{'node'}->{'path'}" );
                    return 0; 
                }
                # else try next dispatch
            }
        }

        # lets make implicit end
        if( ! $dtd->[0] ) # end is optional
        {
            $this->IPrint( "$node->{'fl'} implicit end of " .
                           "$this->{'node'}{'tag'} because of $tagname" );
        }
        else  # end is mandatory - warning
        {
            $this->WPrint( "$node->{'fl'} implicit MANDATORY end of " .
                           "$this->{'node'}{'tag'} because of $tagname" );
        }
        $this->end( $this->{'node'}{'tag'} );
    }
    
    $this->{'node'}->Add( $node );
    
    if( ref( $node->{'content'} ) )
    {
        if( exists( $this->{ 'dtd' }{ $tagname } ) and 
            !defined( $this->{ 'dtd' }{ $tagname } ) )     # empty tag - no end
        {
            $this->DPrint( "TAG $tagname" );
        }
        else
        {
            $this->DPrint( "START $tagname" );
            $this->{'level'} ++;
            $this->{'node'} = $node;
            if( defined( $this->{ 'dtd' }{ $tagname } ) )
            {
                $node->{'dtd'} = $this->{ 'dtd' }{ $tagname };
            }
        }
    }
    else # text element
    {
        $this->DPrint( "$tagname" . $node->{'content'} );
    }
}

sub start
{
    my( $this, $tagname, $attr ) = @_;
    $tagname = lc( $tagname );
    $this->flushtext;

    my $attrs = {};
    foreach my $at (keys %{$attr} ) { $attrs->{ lc($at) } = $$attr{$at}; }
    $attrs->{'fl'} = $this->{ 'fl' } if( $this->{'usefl' } );
    my $node = new ML::Tree( $tagname, $attrs, [], 'fl' => $this->{ 'fl' } );


    $this->ApplyDTD( $node );
}

sub end
{
    my($this, $tagname) = @_;
    $this->flushtext;

    $tagname = lc( $tagname );
    my $node = $this->{'node'};
    my $dtd = $this->{'node'}{ 'dtd' };

    if( not defined( $node->{'parent'} ) )
    {
        die "$this->{'fl'} FATAL: cannot end root $node->{'path'}" .
            " by $tagname\n ";
    }

    if( $node->{'tag'} ne $tagname )           #ommited tag end
    {
        if( $node->{'path'} !~ m</$tagname/> )
        {
            $this->WPrint( "$this->{'fl'} FATAL extra end <\/$tagname> " .
                           "of $node->{'path'} ignored" );
            return;
        }

        if( !$dtd || $dtd->[0] )  # end tag is mandatory, ignore end
        {
            $this->WPrint( "$this->{'fl'} FATAL <\/$tagname> ending " .
                           "$node->{'path'} ignored" );
            return;
        }

        $this->{'level'} --;
        $this->{'node'} = $this->{'node'}{'parent'};

        $this->IPrint( "$this->{'fl'} implicit end of $node->{'tag'}" );
        $this->DPrint("iEND $node->{'tag'}\n" );
        $this->end( $tagname );
    }
    else
    { 
        $this->{'level'} --;
        $this->{'node'} = $this->{'node'}{'parent'};
        $this->DPrint("END $$node{'tag'}\n" );
    }
}

sub text
{ 
    my ($this, $text, $is_cdata) = @_;
    $this->{'textacc'} .= $text;
}

sub flushtext
{
    my $this = shift;
    
    if( $this->{ 'textacc' } ne '' )
    {
        my $node = ML::Tree->newTEXT( $this->{ 'textacc' },
                                      'fl' => $this->{ 'fl' } );
        $this->{ 'textacc' } = '';
        $this->ApplyDTD( $node );
    }
}

sub Warn
{
    my ($this, $tx) = @_;
    if( $this->{ 'warn' } and $tx ne '')
    { print STDERR "$this->{'fl'} warning:$tx \n"; }
}

sub DPrint
{
    my ($this, $tx) = @_;
    if( $this->{ 'debug' } and $tx ne '')
    {
#        print STDERR "$this->{'fl'} warning\n";
        my $next = 1;
        if( $this->{'debug'} < 0 )
        {
            $next = 0;
            $this->{'debug'} = -$this->{'debug'};
        }

        my $left = ( $this->{ 'level' } + 1 ) * 2; 
        my $len = $this->{'debug'} - 1 - $left;

        $tx =~ s/\\/\\\\/g;
        $tx =~ s/\n/\\n/g;
        $tx =~ s/\t/\\t/g;
        $tx =~ s/\r/\\r/g;
        $tx =~ s/([\001-\037])/sprintf( "\\x%.2lx", ord($1) )/ge;
        $tx =~ s/\240/\&nbsp;/g;

        $tx =~ /^.{1,$len}/;
        $tx = $';

        if( $this->{'usefl'} ){ print STDERR $this->{'fl'}; }
        print STDERR  ( ' ' x $left ) . $& . ( $tx eq '' ? "\n" : "|\n" );
        $left += 2;
        $len -= 3;
        
        while( $next and $tx ne '' )
        {
            $tx =~ /^.{1,$len}/;
            $tx = $';
            print STDERR ( ' ' x $left ) . "|$&|\n";
        }
    }
}

sub IPrint
{
    my ($this, $tx) = @_;
    if( $this->{ 'warn' } > 1 || $this->{ 'debug' })
    {
        print STDERR  $tx, "\n";
    }
}

sub WPrint
{
    my ($this, $tx) = @_;
    if( $this->{ 'warn' } || $this->{ 'debug' } )
    { print STDERR $tx, "\n"; }
}


sub InArray
{
    my ( $array, $tx ) = @_;

    foreach my $arr ( @{$array} )
    {
        return 1 if( $arr eq $tx );
    }
    return 0;
}

1;
