package ML::Tree;

use strict;

sub new
{
    my ( $class, $tagname, $attrs, $text ) = @_;
    $class = ref( $class ) || $class;

    my $this = { 'tag' => $tagname, 'attr' => $attrs, 
              'content' => defined $text ? $text : [],
              'path' => "$tagname/",
              'parent' => undef,
          };
    for( my $i = 4; $i < $#_; $i += 2 ) { $this->{ $_[$i] } = $_[$i+1]; }
    return bless( $this, $class );
}

sub newTEXT
{
    my ( $class, $text ) = @_;
    $class = ref( $class ) || $class;
    $text = $text || '';
    my $tagname = $text =~ /^\s*$/ ? 'TEXT_S' : 'TEXT';

    my $this = { 'tag' => $tagname, 'attr' => {},
                 'content' => $text, 'path' => "$tagname/", 'parent' => undef,
             };
    
    for( my $i = 2; $i < $#_; $i += 2 ) { $this->{ $_[$i] } = $_[$i+1]; }
    return bless( $this, $class );
}



sub new_fromTree
{
    my ( $class, $this ) = @_;
    $class = ref( $class ) || $class;

    $this->{'path'} = $this->{'path'} || ( $this->{'tag'} . '/' );
    $this->{'parent'} = $this->{'parent'} || undef;
    if( ref( $this->{'content'} ) eq 'ARRAY' )
    {
        foreach my $node (@{$this->{'content'}})
        {
            $node->{ 'parent' } = $this;
            $node->{ 'path' } = $this->{'path'} . $node->{'tag'} . '/';
            $node = new_fromTree ML::Tree( $node );
        }
    }
    return bless( $this, $class );
}

sub new_fromFile
{
    my ( $class, $file ) = @_;
    $class = ref( $class ) || $class;

    my $code = CodeFromFile $class($file);
    return &$code();
}

sub CodeFromFile
{
    my ( $class, $file ) = @_;
    $class = ref( $class ) || $class;

    local *MLPDFH;
    open MLPDFH, "$file " or die $file;
    undef $/;
    my $data = "sub { return new_fromTree $class( " . <MLPDFH> . "); }";
    close MLPDFH;

    return eval( $data );
}


sub ToFile
{
    my ($this, $file) = @_;
    local *MLPDFH;

    open MLPDFH, ">$file " or die "cannot open $file for writing";
    select MLPDFH;
    $this->PerlDump();
    close MLPDFH;
    select STDOUT;
}


sub Add
{
    my ($this, $node, $update) = @_;

    if( ref( $this->{'content'} ) ne 'ARRAY' )
    { die "Text node cannot have content"; }

    if( ref( $node ) ne 'ARRAY' ) { $node = [ $node ]; }
    foreach  my $n (@{$node})
    {
        push( @{$this->{'content'}}, $n );
        $n->{'parent'} = $this;
        $n->{ 'path' } = $this->{'path'} . $n->{'tag'} . '/';
        $n->{ 'root' } = $this->{'root'} || $this;
        $n->UpdateTree if( $update );
    }
    return $this;
}    

sub AddFirst
{
    my ($this, $node, $update) = @_;

    if( ref( $this->{'content'} ) ne 'ARRAY' )
    { die "Text node cannot have content"; }

    if( ref( $node ) ne 'ARRAY' ) { $node = [ $node ]; }
    foreach  my $n (@{$node})
    {
        unshift( @{$this->{'content'}}, $n );
        $n->{'parent'} = $this;
        $n->{ 'path' } = $this->{'path'} . $n->{'tag'} . '/';
        $n->{ 'root' } = $this->{'root'} || $this;
        $n->UpdateTree if( $update );
    }
    return $this;
}

sub IsSEmpty
{
    my $this = $_[0];

    return (ref( $this->{'content'} ) eq 'ARRAY' and 
            $#{$this->{'content'}} < 0 || $#{$this->{'content'}} == 0 &&
            $this->{'content'}[0]{'tag'} eq 'TEXT_S' );
}


sub IsEmpty
{
    my $this = $_[0];

    return (ref( $this->{'content'} ) eq 'ARRAY' and 
            $#{$this->{'content'}} < 0 );
}



sub UpdateTree
{
    my $this = shift;

    return if( ref( $this->{'content'} ) ne 'ARRAY' );

    foreach my $node (@{$this->{'content'}})
    {
        $node->{ 'parent' } = $this;
        $node->{ 'path' } = $this->{'path'} . $node->{'tag'} . '/';
        $node->{ 'root' } = $this->{'root'} || $this;
        $node->UpdateTree;
    }
}

sub DumpPaths
{
    my $this = shift;

    return if( ref( $this->{'content'} ) ne 'ARRAY' );
    foreach my $node (@{$this->{'content'}})
    {
        print $node->{'path'} . "\n";
        $node->DumpPaths;
    }
}

sub DumpTags
{
    my ($this, $indent) = @_;
    $indent = $indent || '';

    return if( ref( $this->{'content'} ) ne 'ARRAY' );
    foreach my $node (@{$this->{'content'}})
    {
        print $indent . $node->{'tag'} . "\n";
        $node->DumpTags( $indent . '  ' );
    }
}

sub Dump
{
    my ($this, $indent, $dtd) = @_;
    my $noend;

    return if( ref( $this->{'content'} ) ne 'ARRAY' );
    foreach my $node (@{$this->{'content'}})
    {
        $noend = $dtd && exists( $dtd->{ $node->{'tag'} } ) &&
            ! defined( $dtd->{ $node->{'tag'} } );
        $noend = $noend || 0;
        if( $noend && ref( $node->{'content'} ) && $#{$node->{'content'}} >=0)
        {
            die "noend tag with content";
        }

        if( defined( $indent ) )
        {
            print "$indent<" . $node->{'tag'};
            foreach my $at (keys %{$node->{'attr'}} )
            {
                print " $at=\"" . $node->{'attr'}{$at} . "\"";
            }
            print ">";

            if( ref( $node->{'content'} ) )
            {
                print "\n";
                $node->Dump( $indent . '  ', $dtd );
                print "$indent";
            }
            else
            {
                my $tx = $node->{'content'};
                print $tx;
            }
            if( !$noend ) { print "</" . $node->{'tag'}  .">\n"; }
        }
        elsif( ref( $node->{'content'} ) )
        {
            print "<" . $node->{'tag'};
            foreach my $at (keys %{$node->{'attr'}} )
            {
                print " $at=\"" . $node->{'attr'}{$at} . "\"";
            }
            print ">";
            $node->Dump( undef, $dtd );
            if( !$noend ) { print "</" . $node->{'tag'}  .">"; }
        }
        else
        {
            print $node->{'content'};
        }
    }
}

sub PerlDump
{
    my $this = $_[0];
    my $indent = $_[1] || '';

    print $indent, "{\n";
    print "$indent  'tag'  => \'$this->{'tag'}\',\n";
    print "$indent  'attr' => {";
    foreach my $at ( keys(%{$this->{'attr'}}) )
    {
        print " \'$at\' => \"", $this->Escape($this->{'attr'}{$at}), "\", ";
    }
    print "},\n";
    
    if( ref( $this->{'content'} ) eq 'ARRAY' )
    {
        print "$indent  \'content\' =>\n";
        print "$indent  [\n";
        foreach my $node (@{$this->{'content'}})
        {
            $node->PerlDump( $indent . $indent ? "    " : '' );
            print ",\n";
        }
        print "$indent  ],\n";
    }
    else
    {
        $_ = $this->Escape( $this->{'content'} );
        
        print "$indent  \'content\' => \"$_\",\n";
    }
    print "$indent}";
}

sub Escape
{
    $_ = $_[1];

    s/\\/\\\\/g;
    s/\n/\\n/g;
    s/\t/\\t/g;
    s/\'/\\\'/g;
    s/\"/\\\"/g;
    s/\$/\\\$/g;
    s/\@/\\\@/g;
    s/\%/\\\%/g;
    return $_;
}

sub Proc
{
    my ($this, $dtd) = @_;
    my (@out, $out, $node);

    for( my $i = 2; $i < $#_; $i += 2 ) { $this->{ $_[$i] } = $_[$i+1]; }
    if( ref( $this->{'content'} ) eq 'ARRAY' )
    {
        $this->{ 'precontent' } = $this->{ 'content' };
        $this->{ 'content' } = [];

      NODE:
        while( $node = shift @{$this->{'precontent'}} )
        {
            $node->{ 'parent' } = $this;
            $node->{ 'path' } = $this->{'path'} . $node->{'tag'} . '/';
            $node->{ 'root' } = $this->{'root'} || $this;

            @out = &$dtd( $node, $dtd );
            die $this->Tx( "%f unhandled tag %p" ) if( ! @out );
            my @stack = ();
          OUT:
            while( $out = shift @out )
            {
                if( ref( $out ) )
                { push @stack, (ref($out) eq 'ARRAY' ? @{$out} : $out); }
                elsif( !$out ) {}
                elsif( $out eq 'redo' ) { #redo
                    print STDERR "warning: nonempty stack\n " if( @stack );
                    redo NODE;
                }    
                elsif( $out eq 'add' ) 
                {
                    push @{$this->{'content'}}, @stack;
                    @stack = ();
                }
                elsif( $out eq 'skip' ) { $this->{'precontent'} = [] ;}
                elsif( $out eq 'skipto' || $out eq 'skipto0' ) {
                    my $o = $stack[-1] || die "empty stack\n ";
                    $o->Add( $node ) if( $out eq 'skipto' );
                    $o->Add( $this->{'precontent'} );
                    $this->{'precontent'} = [];
                }
                elsif( $out eq 'proc' ) 
                {
                    my $o = $stack[-1] || die "empty stack\n ";
                    $o->{ 'parent' } = $this;
                    $o->{ 'path' } = $this->{'path'} . $o->{'tag'} . '/';
                    $o->{ 'root' } = $this->{'root'} || $this;
                    $o->Proc( $dtd );
                }
                elsif( $out eq 'toup' ) 
                {
                    die "not parent" if( not defined( $this->{'parent'} ) );
                    my $o = pop @stack || die "empty stack\n ";
                    unshift @{$this->{'parent'}{'precontent'}}, $o
                }

                elsif( $out eq 'flat' || $out eq 'flat0' ) {   #pre_flatten
                    die "not parent" if( not defined( $this->{'parent'} ) );
                    unshift @{$this->{'parent'}{'precontent'}},
                    @{$this->{'precontent'}};
                    if( $out eq 'flat' )
                    {
                        unshift @{$this->{'parent'}{'precontent'}}, $node;
                    }
                    $this->{'precontent'} = [];
                }
                else { die "wrong result to Proc :\"$out\""; }
            }
            push @{$this->{'content'}}, @stack;
        }
    }
    return $this;
}

sub Tx
{
    my ($this, $tx) = @_;

    $tx =~ s/\%p/$this->{'path'}/g;
    $tx =~ s/\%t/$this->{'tag'}/g;
    if( $this->{'fl'} )
    {
        $tx =~ s/\%f/$this->{'fl'}/g;
    }
    else
    {
        $tx =~ s/\%f/\?\?\?/g;
    }

    return $tx;
}

1;
