File Coverage

blib/lib/HTML/DOM/_TreeBuilder.pm

Criterion	Covered	Total	%
statement	284	466	60.9
branch	163	298	54.7
condition	96	243	39.5
subroutine	23	44	52.2
pod	8	33	24.2
total	574	1084	52.9

# This is a fork of HTML::Element.  Eventually the code may be merged.

package HTML::DOM::_TreeBuilder;

use warnings;
use strict;
use integer;    # vroom vroom!
use Carp ();
use vars qw(@ISA $VERSION $DEBUG);

#---------------------------------------------------------------------------
# Make a 'DEBUG' constant...

BEGIN {

    # We used to have things like
    #  print $indent, "lalala" if $Debug;
    # But there were an awful lot of having to evaluate $Debug's value.
    # If we make that depend on a constant, like so:
    #   sub DEBUG () { 1 } # or whatever value.
    #   ...
    #   print $indent, "lalala" if DEBUG;
    # Which at compile-time (thru the miracle of constant folding) turns into:
    #   print $indent, "lalala";
    # or, if DEBUG is a constant with a true value, then that print statement
    # is simply optimized away, and doesn't appear in the target code at all.
    # If you don't believe me, run:
    #    perl -MO=Deparse,-uHTML::DOM::_TreeBuilder -e 'BEGIN { \
    #      $HTML::DOM::_TreeBuilder::DEBUG = 4}  use HTML::DOM::_TreeBuilder'
    # and see for yourself (substituting whatever value you want for $DEBUG
    # there).
## no critic
    if ( defined &DEBUG ) {

        # Already been defined!  Do nothing.
    }
    elsif ( $] < 5.00404 ) {

        # Grudgingly accomodate ancient (pre-constant) versions.
        eval 'sub DEBUG { $Debug } ';
    }
    elsif ( !$DEBUG ) {
        eval 'sub DEBUG () {0}';    # Make it a constant.
    }
    elsif ( $DEBUG =~ m<^\d+$>s ) {
        eval 'sub DEBUG () { ' . $DEBUG . ' }';    # Make THAT a constant.
    }
    else {                                         # WTF?
        warn "Non-numeric value \"$DEBUG\" in \$HTML::DOM::_Element::DEBUG";
        eval 'sub DEBUG () { $DEBUG }';            # I guess.
    }
## use critic
}

#---------------------------------------------------------------------------

use HTML::Entities ();
use HTML::Tagset 3.02 ();

use HTML::DOM::_Element ();
use HTML::Parser  ();
@ISA = qw(HTML::DOM::_Element HTML::Parser);
$VERSION = 4.2001;

# This looks schizoid, I know.
# It's not that we ARE an element AND a parser.
# We ARE an element, but one that knows how to handle signals
#  (method calls) from Parser in order to elaborate its subtree.

# Legacy aliases:
*HTML::DOM::_TreeBuilder::isKnown             = \%HTML::Tagset::isKnown;
*HTML::DOM::_TreeBuilder::canTighten          = \%HTML::Tagset::canTighten;
*HTML::DOM::_TreeBuilder::isHeadElement       = \%HTML::Tagset::isHeadElement;
*HTML::DOM::_TreeBuilder::isBodyElement       = \%HTML::Tagset::isBodyElement;
*HTML::DOM::_TreeBuilder::isPhraseMarkup      = \%HTML::Tagset::isPhraseMarkup;
*HTML::DOM::_TreeBuilder::isHeadOrBodyElement = \%HTML::Tagset::isHeadOrBodyElement;
*HTML::DOM::_TreeBuilder::isList              = \%HTML::Tagset::isList;
*HTML::DOM::_TreeBuilder::isTableElement      = \%HTML::Tagset::isTableElement;
*HTML::DOM::_TreeBuilder::isFormElement       = \%HTML::Tagset::isFormElement;
*HTML::DOM::_TreeBuilder::p_closure_barriers  = \@HTML::Tagset::p_closure_barriers;

#==========================================================================
# Two little shortcut constructors:

sub new_from_file {    # or from a FH
    my $class = shift;
    Carp::croak("new_from_file takes only one argument")
        unless @_ == 1;
    Carp::croak("new_from_file is a class method only")
        if ref $class;
    my $new = $class->new();
    $new->parse_file( $_[0] );
    return $new;
}

sub new_from_content {    # from any number of scalars
    my $class = shift;
    Carp::croak("new_from_content is a class method only")
        if ref $class;
    my $new = $class->new();
    foreach my $whunk (@_) {
        if ( ref($whunk) eq 'SCALAR' ) {
            $new->parse($$whunk);
        }
        else {
            $new->parse($whunk);
        }
        last if $new->{'_stunted'};    # might as well check that.
    }
    $new->eof();
    return $new;
}

# TODO: document more fully?
sub parse_content {                    # from any number of scalars
    my $tree = shift;
    my $retval;
    foreach my $whunk (@_) {
        if ( ref($whunk) eq 'SCALAR' ) {
            $retval = $tree->parse($$whunk);
        }
        else {
            $retval = $tree->parse($whunk);
        }
        last if $tree->{'_stunted'};    # might as well check that.
    }
    $tree->eof();
    return $retval;
}

#---------------------------------------------------------------------------

sub new {                               # constructor!
    my $class = shift;
    $class = ref($class) || $class;

    # Initialize HTML::DOM::_Element part
    my $self = $class->element_class->new('html');

    {

        # A hack for certain strange versions of Parser:
        my $other_self = HTML::Parser->new();
        %$self = ( %$self, %$other_self );    # copy fields
           # Yes, multiple inheritance is messy.  Kids, don't try this at home.
        bless $other_self, "HTML::DOM::_TreeBuilder::_hideyhole";

        # whack it out of the HTML::Parser class, to avoid the destructor
    }

    # The root of the tree is special, as it has these funny attributes,
    # and gets reblessed into this class.

    # Initialize parser settings
    $self->{'_implicit_tags'}       = 1;
    $self->{'_implicit_body_p_tag'} = 0;

    # If true, trying to insert text, or any of %isPhraseMarkup right
    #  under 'body' will implicate a 'p'.  If false, will just go there.

    $self->{'_tighten'} = 1;

    # whether ignorable WS in this tree should be deleted

    $self->{'_implicit'} = 1; # to delete, once we find a real open-"html" tag

    $self->{'_ignore_unknown'}      = 1;
    $self->{'_ignore_text'}         = 0;
    $self->{'_warn'}                = 0;
    $self->{'_no_space_compacting'} = 0;
    $self->{'_store_comments'}      = 0;
    $self->{'_store_declarations'}  = 1;
    $self->{'_store_pis'}           = 0;
    $self->{'_p_strict'}            = 0;
    $self->{'_no_expand_entities'}  = 0;

    # Parse attributes passed in as arguments
    if (@_) {
        my %attr = @_;
        for ( keys %attr ) {
            $self->{"_$_"} = $attr{$_};
        }
    }

    $HTML::DOM::_Element::encoded_content = $self->{'_no_expand_entities'};

    # rebless to our class
    bless $self, $class;

    $self->{'_element_count'} = 1;

    # undocumented, informal, and maybe not exactly correct

    $self->{'_head'} = $self->insert_element( 'head', 1 );
    $self->{'_pos'}  = undef;                                # pull it back up
    $self->{'_body'} = $self->insert_element( 'body', 1 );
    $self->{'_pos'} = undef;    # pull it back up again

    return $self;
}

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

sub _elem                       # universal accessor...
{
    my ( $self, $elem, $val ) = @_;
    my $old = $self->{$elem};
    $self->{$elem} = $val if defined $val;
    return $old;
}

# accessors....
sub implicit_tags       { shift->_elem( '_implicit_tags',       @_ ); }
sub implicit_body_p_tag { shift->_elem( '_implicit_body_p_tag', @_ ); }
sub p_strict            { shift->_elem( '_p_strict',            @_ ); }
sub no_space_compacting { shift->_elem( '_no_space_compacting', @_ ); }
sub ignore_unknown      { shift->_elem( '_ignore_unknown',      @_ ); }
sub ignore_text         { shift->_elem( '_ignore_text',         @_ ); }
sub ignore_ignorable_whitespace { shift->_elem( '_tighten',            @_ ); }
sub store_comments              { shift->_elem( '_store_comments',     @_ ); }
sub store_declarations          { shift->_elem( '_store_declarations', @_ ); }
sub store_pis                   { shift->_elem( '_store_pis',          @_ ); }
sub warn                        { shift->_elem( '_warn',               @_ ); }

sub no_expand_entities {
    shift->_elem( '_no_expand_entities', @_ );
    $HTML::DOM::_Element::encoded_content = @_;
}

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

sub warning {
    my $self = shift;
    CORE::warn("HTML::Parse: $_[0]\n") if $self->{'_warn'};

    # should maybe say HTML::DOM::_TreeBuilder instead
}

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

{

    # To avoid having to rebuild these lists constantly...
    my $_Closed_by_structurals = [qw(p h1 h2 h3 h4 h5 h6 pre textarea)];
    my $indent;

    sub start {
        return if $_[0]{'_stunted'};

        # Accept a signal from HTML::Parser for start-tags.
        my ( $self, $tag, $attr ) = @_;

        # Parser passes more, actually:
        #   $self->start($tag, $attr, $attrseq, $origtext)
        # But we can merrily ignore $attrseq and $origtext.

        if ( $tag eq 'x-html' ) {
            print "Ignoring open-x-html tag.\n" if DEBUG;

            # inserted by some lame code-generators.
            return;    # bypass tweaking.
        }

        $tag =~ s{/$}{}s;    # So  turns into .  Silently forgive.

        unless ( $tag =~ m/^[-_a-zA-Z0-9:%]+$/s ) {
            DEBUG and print "Start-tag name $tag is no good.  Skipping.\n";
            return;

            # This avoids having Element's new() throw an exception.
        }

        my $ptag = ( my $pos = $self->{'_pos'} || $self )->{'_tag'};
        my $already_inserted;

        #my($indent);
        if (DEBUG) {

       # optimization -- don't figure out indenting unless we're in debug mode
            my @lineage = $pos->lineage;
            $indent = '  ' x ( 1 + @lineage );
            print $indent, "Proposing a new \U$tag\E under ",
                join( '/', map $_->{'_tag'}, reverse( $pos, @lineage ) )
                || 'Root',
                ".\n";

            #} else {
            #  $indent = ' ';
        }

        #print $indent, "POS: $pos ($ptag)\n" if DEBUG > 2;
        # $attr = {%$attr};

        foreach my $k ( keys %$attr ) {

            # Make sure some stooge doesn't have "".
            # That happens every few million Web pages.
            $attr->{ ' ' . $k } = delete $attr->{$k}
                if length $k and substr( $k, 0, 1 ) eq '_';

            # Looks bad, but is fine for round-tripping.
        }

        my $e = $self->element_class->new( $tag, %$attr );

        # Make a new element object.
        # (Only rarely do we end up just throwing it away later in this call.)

      # Some prep -- custom messiness for those damned tables, and strict P's.
        if ( $self->{'_implicit_tags'} ) {    # wallawallawalla!

            unless ( $HTML::DOM::_TreeBuilder::isTableElement{$tag} ) {
                if ( $ptag eq 'table' ) {
                    print $indent,
                        " * Phrasal \U$tag\E right under TABLE makes implicit TR and TD\n"
                        if DEBUG > 1;
                    $self->insert_element( 'tr', 1 );
                    $pos = $self->insert_element( 'td', 1 )
                        ;                     # yes, needs updating
                }
                elsif ( $ptag eq 'tr' ) {
                    print $indent,
                        " * Phrasal \U$tag\E right under TR makes an implicit TD\n"
                        if DEBUG > 1;
                    $pos = $self->insert_element( 'td', 1 )
                        ;                     # yes, needs updating
                }
                $ptag = $pos->{'_tag'};       # yes, needs updating
            }

            # end of table-implication block.

            # Now maybe do a little dance to enforce P-strictness.
            # This seems like it should be integrated with the big
            # "ALL HOPE..." block, further below, but that doesn't
            # seem feasable.
            if (    $self->{'_p_strict'}
                and $HTML::DOM::_TreeBuilder::isKnown{$tag}
                and not $HTML::Tagset::is_Possible_Strict_P_Content{$tag} )
            {
                my $here     = $pos;
                my $here_tag = $ptag;
                while (1) {
                    if ( $here_tag eq 'p' ) {
                        print $indent, " * Inserting $tag closes strict P.\n"
                            if DEBUG > 1;
                        $self->end( \q{p} );

                    # NB: same as \'q', but less confusing to emacs cperl-mode
                        last;
                    }

                    #print("Lasting from $here_tag\n"),
                    last
                        if $HTML::DOM::_TreeBuilder::isKnown{$here_tag}
                            and
                            not $HTML::Tagset::is_Possible_Strict_P_Content{
                                $here_tag};

               # Don't keep looking up the tree if we see something that can't
               #  be strict-P content.

                    $here_tag
                        = ( $here = $here->{'_parent'} || last )->{'_tag'};
                }    # end while
                $ptag = ( $pos = $self->{'_pos'} || $self )
                    ->{'_tag'};    # better update!
            }

            # end of strict-p block.
        }

       # And now, get busy...
       #----------------------------------------------------------------------
        if ( !$self->{'_implicit_tags'} ) {    # bimskalabim
                                               # do nothing
            print $indent, " * _implicit_tags is off.  doing nothing\n"
                if DEBUG > 1;

       #----------------------------------------------------------------------
        }
        elsif ( $HTML::DOM::_TreeBuilder::isHeadOrBodyElement{$tag} ) {
            if ( $pos->is_inside('body') ) {    # all is well
                print $indent,
                    " * ambilocal element \U$tag\E is fine under BODY.\n"
                    if DEBUG > 1;
            }
            elsif ( $pos->is_inside('head') ) {
                print $indent,
                    " * ambilocal element \U$tag\E is fine under HEAD.\n"
                    if DEBUG > 1;
            }
            else {

                # In neither head nor body!  mmmmm... put under head?

                if ( $ptag eq 'html' ) {    # expected case
                     # TODO?? : would there ever be a case where _head would be
                     #  absent from a tree that would ever be accessed at this
                     #  point?
                    die "Where'd my head go?" unless ref $self->{'_head'};
                    if ( $self->{'_head'}{'_implicit'} ) {
                        print $indent,
                            " * ambilocal element \U$tag\E makes an implicit HEAD.\n"
                            if DEBUG > 1;

                        # or rather, points us at it.
                        $self->{'_pos'}
                            = $self->{'_head'};    # to insert under...
                    }
                    else {
                        $self->warning(
                            "Ambilocal element <$tag> not under HEAD or BODY!?"
                        );

                        # Put it under HEAD by default, I guess
                        $self->{'_pos'}
                            = $self->{'_head'};    # to insert under...
                    }

                }
                else {

             # Neither under head nor body, nor right under html... pass thru?
                    $self->warning(
                        "Ambilocal element <$tag> neither under head nor body, nor right under html!?"
                    );
                }
            }

       #----------------------------------------------------------------------
        }
        elsif ( $HTML::DOM::_TreeBuilder::isBodyElement{$tag} ) {

            # Ensure that we are within
            if ( $ptag eq 'body' ) {

                # We're good.
            }
            elsif (
                $HTML::DOM::_TreeBuilder::isBodyElement{$ptag}    # glarg
                and not $HTML::DOM::_TreeBuilder::isHeadOrBodyElement{$ptag}
                )
            {

              # Special case: Save ourselves a call to is_inside further down.
              # If our $ptag is an isBodyElement element (but not an
              # isHeadOrBodyElement element), then we must be under body!
                print $indent, " * Inferring that $ptag is under BODY.\n",
                    if DEBUG > 3;

                # I think this and the test for 'body' trap everything
                # bodyworthy, except the case where the parent element is
                # under an unknown element that's a descendant of body.
            }
            elsif ( $pos->is_inside('head') ) {
                print $indent,
                    " * body-element \U$tag\E minimizes HEAD, makes implicit BODY.\n"
                    if DEBUG > 1;
                $ptag = (
                    $pos = $self->{'_pos'}
                        = $self->{'_body'}    # yes, needs updating
                        || die "Where'd my body go?"
                )->{'_tag'};                  # yes, needs updating
            }
            elsif ( !$pos->is_inside('body') ) {
                print $indent,
                    " * body-element \U$tag\E makes implicit BODY.\n"
                    if DEBUG > 1;
                $ptag = (
                    $pos = $self->{'_pos'}
                        = $self->{'_body'}    # yes, needs updating
                        || die "Where'd my body go?"
                )->{'_tag'};                  # yes, needs updating
            }

            # else we ARE under body, so okay.

            # Handle implicit endings and insert based on  and position
            # ... ALL HOPE ABANDON ALL YE WHO ENTER HERE ...
            if (   $tag eq 'p'
                or $tag eq 'h1'
                or $tag eq 'h2'
                or $tag eq 'h3'
                or $tag eq 'h4'
                or $tag eq 'h5'
                or $tag eq 'h6'
                or $tag eq 'form'

                # Hm, should  really be here?!
                )
            {

                # Can't have ,  or  inside these
                $self->end(
                    $_Closed_by_structurals,
                    @HTML::DOM::_TreeBuilder::p_closure_barriers

                        # used to be just li!
                );

            }
            elsif ( $tag eq 'ol' or $tag eq 'ul' or $tag eq 'dl' ) {

                # Can't have lists inside  -- in the unlikely
                #  event anyone tries to put them there!
                if (   $ptag eq 'h1'
                    or $ptag eq 'h2'
                    or $ptag eq 'h3'
                    or $ptag eq 'h4'
                    or $ptag eq 'h5'
                    or $ptag eq 'h6' )
                {
                    $self->end( \$ptag );
                }

                # TODO: Maybe keep closing up the tree until
                #  the ptag isn't any of the above?
                # But anyone that says ...
                #  deserves what they get anyway.

            }
            elsif ( $tag eq 'li' ) {    # list item
                    # Get under a list tag, one way or another
                unless (
                    exists $HTML::DOM::_TreeBuilder::isList{$ptag}
                    or $self->end( \q{*}, keys %HTML::DOM::_TreeBuilder::isList ) #'
                    )
                {
                    print $indent,
                        " * inserting implicit UL for lack of containing ",
                        join( '|', keys %HTML::DOM::_TreeBuilder::isList ), ".\n"
                        if DEBUG > 1;
                    $self->insert_element( 'ul', 1 );
                }

            }
            elsif ( $tag eq 'dt' or $tag eq 'dd' ) {

                # Get under a DL, one way or another
                unless ( $ptag eq 'dl' or $self->end( \q{*}, 'dl' ) ) {    #'
                    print $indent,
                        " * inserting implicit DL for lack of containing DL.\n"
                        if DEBUG > 1;
                    $self->insert_element( 'dl', 1 );
                }

            }
            elsif ( $HTML::DOM::_TreeBuilder::isFormElement{$tag} ) {
                if ($self->{
                        '_ignore_formies_outside_form'}  # TODO: document this
                    and not $pos->is_inside('form')
                    )
                {
                    print $indent,
                        " * ignoring \U$tag\E because not in a FORM.\n"
                        if DEBUG > 1;
                    return;                              # bypass tweaking.
                }
                if ( $tag eq 'option' ) {

                    # return unless $ptag eq 'select';
                    $self->end( \q{option} );
                    $ptag = ( $self->{'_pos'} || $self )->{'_tag'};
                    unless ( $ptag eq 'select' or $ptag eq 'optgroup' ) {
                        print $indent,
                            " * \U$tag\E makes an implicit SELECT.\n"
                            if DEBUG > 1;
                        $pos = $self->insert_element( 'select', 1 );

                    # but not a very useful select -- has no 'name' attribute!
                    # is $pos's value used after this?
                    }
                }
            }
            elsif ( $HTML::DOM::_TreeBuilder::isTableElement{$tag} ) {
                if ( !$pos->is_inside('table') ) {
                    print $indent, " * \U$tag\E makes an implicit TABLE\n"
                        if DEBUG > 1;
                    $self->insert_element( 'table', 1 );
                }

                if ( $tag eq 'td' or $tag eq 'th' ) {

                    # Get under a tr one way or another
                    unless (
                        $ptag eq 'tr'    # either under a tr
                        or $self->end( \q{*}, 'tr',
                            'table' )    #or we can get under one
                        )
                    {
                        print $indent,
                            " * \U$tag\E under \U$ptag\E makes an implicit TR\n"
                            if DEBUG > 1;
                        $self->insert_element( 'tr', 1 );

                        # presumably pos's value isn't used after this.
                    }
                }
                else {
                    $self->end( \$tag, 'table' );    #'
                }

                # Hmm, I guess this is right.  To work it out:
                #   tr closes any open tr (limited at a table)
                #   thead closes any open thead (limited at a table)
                #   tbody closes any open tbody (limited at a table)
                #   tfoot closes any open tfoot (limited at a table)
                #   colgroup closes any open colgroup (limited at a table)
                #   col can try, but will always fail, at the enclosing table,
                #     as col is empty, and therefore never open!
                # But!
                #   td closes any open td OR th (limited at a table)
                #   th closes any open th OR td (limited at a table)
                #   ...implementable as "close to a tr, or make a tr"

            }
            elsif ( $HTML::DOM::_TreeBuilder::isPhraseMarkup{$tag} ) {
                if ( $ptag eq 'body' and $self->{'_implicit_body_p_tag'} ) {
                    print
                        " * Phrasal \U$tag\E right under BODY makes an implicit P\n"
                        if DEBUG > 1;
                    $pos = $self->insert_element( 'p', 1 );

                    # is $pos's value used after this?
                }
            }

            # End of implicit endings logic

       # End of "elsif ($HTML::DOM::_TreeBuilder::isBodyElement{$tag}"
       #----------------------------------------------------------------------

        }
        elsif ( $HTML::DOM::_TreeBuilder::isHeadElement{$tag} ) {
            if ( $pos->is_inside('body') ) {
                print $indent, " * head element \U$tag\E found inside BODY!\n"
                    if DEBUG;
                $self->warning("Header element <$tag> in body");    # [sic]
            }
            elsif ( !$pos->is_inside('head') ) {
                print $indent,
                    " * head element \U$tag\E makes an implicit HEAD.\n"
                    if DEBUG > 1;
            }
            else {
                print $indent,
                    " * head element \U$tag\E goes inside existing HEAD.\n"
                    if DEBUG > 1;
            }
            $self->{'_pos'} = $self->{'_head'} || die "Where'd my head go?";

       #----------------------------------------------------------------------
        }
        elsif ( $tag eq 'html' ) {
            if ( delete $self->{'_implicit'} ) {    # first time here
                print $indent, " * good! found the real HTML element!\n"
                    if DEBUG > 1;
            }
            else {
                print $indent, " * Found a second HTML element\n"
                    if DEBUG;
                $self->warning("Found a nested  element");
            }

            # in either case, migrate attributes to the real element
            for ( keys %$attr ) {
                $self->attr( $_, $attr->{$_} );
            }
            $self->{'_pos'} = undef;
            return $self;    # bypass tweaking.

       #----------------------------------------------------------------------
        }
        elsif ( $tag eq 'head' ) {
            my $head = $self->{'_head'} || die "Where'd my head go?";
            if ( delete $head->{'_implicit'} ) {    # first time here
                print $indent, " * good! found the real HEAD element!\n"
                    if DEBUG > 1;
            }
            else {                                  # been here before
                print $indent, " * Found a second HEAD element\n"
                    if DEBUG;
                $self->warning("Found a second  element");
            }

            # in either case, migrate attributes to the real element
            for ( keys %$attr ) {
                $head->attr( $_, $attr->{$_} );
            }
            return $self->{'_pos'} = $head;         # bypass tweaking.

       #----------------------------------------------------------------------
        }
        elsif ( $tag eq 'body' ) {
            my $body = $self->{'_body'} || die "Where'd my body go?";
            if ( delete $body->{'_implicit'} ) {    # first time here
                print $indent, " * good! found the real BODY element!\n"
                    if DEBUG > 1;
            }
            else {                                  # been here before
                print $indent, " * Found a second BODY element\n"
                    if DEBUG;
                $self->warning("Found a second  element");
            }

            # in either case, migrate attributes to the real element
            for ( keys %$attr ) {
                $body->attr( $_, $attr->{$_} );
            }
            $self->{'_pos'} = $body unless $pos->is_inside('body');
            return $body;                           # bypass tweaking.

       #----------------------------------------------------------------------
        }
        elsif ( $tag eq 'frameset' ) {
            if (!( $self->{'_frameset_seen'}++ )    # first frameset seen
                and !$self->{'_noframes_seen'}

                # otherwise it'll be under the noframes already
                and !$self->is_inside('body')
                )
            {

           # The following is a bit of a hack.  We don't use the normal
           #  insert_element because 1) we don't want it as _pos, but instead
           #  right under $self, and 2), more importantly, that we don't want
           #  this inserted at the /end/ of $self's content_list, but instead
           #  in the middle of it, specifiaclly right before the body element.
           #
                my $c    = $self->{'_content'} || die "Contentless root?";
                my $body = $self->{'_body'}    || die "Where'd my BODY go?";
                for ( my $i = 0; $i < @$c; ++$i ) {
                    if ( $c->[$i] eq $body ) {
                        splice( @$c, $i, 0, $self->{'_pos'} = $pos = $e );
                        $e->{'_parent'} = $self;
                        $already_inserted = 1;
                        print $indent,
                            " * inserting 'frameset' right before BODY.\n"
                            if DEBUG > 1;
                        last;
                    }
                }
                die "BODY not found in children of root?"
                    unless $already_inserted;
            }

        }
        elsif ( $tag eq 'frame' ) {

            # Okay, fine, pass thru.
            # Should probably enforce that these should be under a frameset.
            # But hey.  Ditto for enforcing that 'noframes' should be under
            # a 'frameset', as the DTDs say.

        }
        elsif ( $tag eq 'noframes' ) {

           # This basically assumes there'll be exactly one 'noframes' element
           #  per document.  At least, only the first one gets to have the
           #  body under it.  And if there are no noframes elements, then
           #  the body pretty much stays where it is.  Is that ever a problem?
            if ( $self->{'_noframes_seen'}++ ) {
                print $indent, " * ANOTHER noframes element?\n" if DEBUG;
            }
            else {
                if ( $pos->is_inside('body') ) {
                    print $indent, " * 'noframes' inside 'body'.  Odd!\n"
                        if DEBUG;

               # In that odd case, we /can't/ make body a child of 'noframes',
               # because it's an ancestor of the 'noframes'!
                }
                else {
                    $e->push_content( $self->{'_body'}
                            || die "Where'd my body go?" );
                    print $indent, " * Moving body to be under noframes.\n"
                        if DEBUG;
                }
            }

       #----------------------------------------------------------------------
        }
        else {

            # unknown tag
            if ( $self->{'_ignore_unknown'} ) {
                print $indent, " * Ignoring unknown tag \U$tag\E\n" if DEBUG;
                $self->warning("Skipping unknown tag $tag");
                return;
            }
            else {
                print $indent, " * Accepting unknown tag \U$tag\E\n"
                    if DEBUG;
            }
        }

       #----------------------------------------------------------------------
       # End of mumbo-jumbo

        print $indent, "(Attaching ", $e->{'_tag'}, " under ",
            ( $self->{'_pos'} || $self )->{'_tag'}, ")\n"

            # because if _pos isn't defined, it goes under self
            if DEBUG;

        # The following if-clause is to delete /some/ ignorable whitespace
        #  nodes, as we're making the tree.
        # This'd be a node we'd catch later anyway, but we might as well
        #  nip it in the bud now.
        # This doesn't catch /all/ deletable WS-nodes, so we do have to call
        #  the tightener later to catch the rest.

        if ( $self->{'_tighten'} and !$self->{'_ignore_text'} )
        {    # if tightenable
            my ( $sibs, $par );
            if (( $sibs = ( $par = $self->{'_pos'} || $self )->{'_content'} )
                and @$sibs            # parent already has content
                and !
                ref( $sibs->[-1] )    # and the last one there is a text node
                and $sibs->[-1] !~ m<[^\n\r\f\t ]>s  # and it's all whitespace

                and (    # one of these has to be eligible...
                    $HTML::DOM::_TreeBuilder::canTighten{$tag}
                    or (( @$sibs == 1 )
                        ?    # WS is leftmost -- so parent matters
                        $HTML::DOM::_TreeBuilder::canTighten{ $par->{'_tag'} }
                        :    # WS is after another node -- it matters
                        (   ref $sibs->[-2]
                                and
                                $HTML::DOM::_TreeBuilder::canTighten{ $sibs->[-2]
                                    {'_tag'} }
                        )
                    )
                )

                and !$par->is_inside( 'pre', 'xmp', 'textarea', 'plaintext' )

                # we're clear
                )
            {
                pop @$sibs;
                print $indent, "Popping a preceding all-WS node\n" if DEBUG;
            }
        }

        $self->insert_element($e) unless $already_inserted;

        if (DEBUG) {
            if ( $self->{'_pos'} ) {
                print $indent, "(Current lineage of pos:  \U$tag\E under ",
                    join(
                    '/',
                    reverse(

                        # $self->{'_pos'}{'_tag'},  # don't list myself!
                        $self->{'_pos'}->lineage_tag_names
                    )
                    ),
                    ".)\n";
            }
            else {
                print $indent, "(Pos points nowhere!?)\n";
            }
        }

        unless ( ( $self->{'_pos'} || '' ) eq $e ) {

            # if it's an empty element -- i.e., if it didn't change the _pos
            &{         $self->{"_tweak_$tag"}
                    || $self->{'_tweak_*'}
                    || return $e }( map $_, $e, $tag, $self )
                ;    # make a list so the user can't clobber
        }

        return $e;
    }
}

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

{
    my $indent;

    sub end {
        return if $_[0]{'_stunted'};

       # Either: Acccept an end-tag signal from HTML::Parser
       # Or: Method for closing currently open elements in some fairly complex
       #  way, as used by other methods in this class.
        my ( $self, $tag, @stop ) = @_;
        if ( $tag eq 'x-html' ) {
            print "Ignoring close-x-html tag.\n" if DEBUG;

            # inserted by some lame code-generators.
            return;
        }

        unless ( ref($tag) or $tag =~ m/^[-_a-zA-Z0-9:%]+$/s ) {
            DEBUG and print "End-tag name $tag is no good.  Skipping.\n";
            return;

            # This avoids having Element's new() throw an exception.
        }

       # This method accepts two calling formats:
       #  1) from Parser:  $self->end('tag_name', 'origtext')
       #        in which case we shouldn't mistake origtext as a blocker tag
       #  2) from myself:  $self->end(\q{tagname1}, 'blk1', ... )
       #     from myself:  $self->end(['tagname1', 'tagname2'], 'blk1',  ... )

        # End the specified tag, but don't move above any of the blocker tags.
        # The tag can also be a reference to an array.  Terminate the first
        # tag found.

        my $ptag = ( my $p = $self->{'_pos'} || $self )->{'_tag'};

        # $p and $ptag are sort-of stratch

        if ( ref($tag) ) {

            # First param is a ref of one sort or another --
            #  THE CALL IS COMING FROM INSIDE THE HOUSE!
            $tag = $$tag if ref($tag) eq 'SCALAR';

            # otherwise it's an arrayref.
        }
        else {

            # the call came from Parser -- just ignore origtext
            # except in a table ignore unmatched table tags RT #59980
            @stop = $tag =~ /^t[hdr]\z/ ? 'table' : ();
        }

        #my($indent);
        if (DEBUG) {

           # optimization -- don't figure out depth unless we're in debug mode
            my @lineage_tags = $p->lineage_tag_names;
            $indent = '  ' x ( 1 + @lineage_tags );

            # now announce ourselves
            print $indent, "Ending ",
                ref($tag) ? ( '[', join( ' ', @$tag ), ']' ) : "\U$tag\E",
                scalar(@stop)
                ? ( " no higher than [", join( ' ', @stop ), "]" )
                : (), ".\n";

            print $indent, " (Current lineage: ", join( '/', @lineage_tags ),
                ".)\n"
                if DEBUG > 1;

            if ( DEBUG > 3 ) {

                #my(
                # $package, $filename, $line, $subroutine,
                # $hasargs, $wantarray, $evaltext, $is_require) = caller;
                print $indent,
                    " (Called from ", ( caller(1) )[3], ' line ',
                    ( caller(1) )[2],
                    ")\n";
            }

            #} else {
            #  $indent = ' ';
        }

        # End of if DEBUG

        # Now actually do it
        my @to_close;
        if ( $tag eq '*' ) {

        # Special -- close everything up to (but not including) the first
        #  limiting tag, or return if none found.  Somewhat of a special case.
        PARENT:
            while ( defined $p ) {
                $ptag = $p->{'_tag'};
                print $indent, " (Looking at $ptag.)\n" if DEBUG > 2;
                for (@stop) {
                    if ( $ptag eq $_ ) {
                        print $indent,
                            " (Hit a $_; closing everything up to here.)\n"
                            if DEBUG > 2;
                        last PARENT;
                    }
                }
                push @to_close, $p;
                $p = $p->{'_parent'};    # no match so far? keep moving up
                print $indent,
                    " (Moving on up to ", $p ? $p->{'_tag'} : 'nil', ")\n"
                    if DEBUG > 1;
            }
            unless ( defined $p ) { # We never found what we were looking for.
                print $indent, " (We never found a limit.)\n" if DEBUG > 1;
                return;
            }

            #print
            #   $indent,
            #   " (To close: ", join('/', map $_->tag, @to_close), ".)\n"
            #  if DEBUG > 4;

            # Otherwise update pos and fall thru.
            $self->{'_pos'} = $p;
        }
        elsif ( ref $tag ) {

           # Close the first of any of the matching tags, giving up if you hit
           #  any of the stop-tags.
        PARENT:
            while ( defined $p ) {
                $ptag = $p->{'_tag'};
                print $indent, " (Looking at $ptag.)\n" if DEBUG > 2;
                for (@$tag) {
                    if ( $ptag eq $_ ) {
                        print $indent, " (Closing $_.)\n" if DEBUG > 2;
                        last PARENT;
                    }
                }
                for (@stop) {
                    if ( $ptag eq $_ ) {
                        print $indent,
                            " (Hit a limiting $_ -- bailing out.)\n"
                            if DEBUG > 1;
                        return;    # so it was all for naught
                    }
                }
                push @to_close, $p;
                $p = $p->{'_parent'};
            }
            return unless defined $p;    # We went off the top of the tree.
               # Otherwise specified element was found; set pos to its parent.
            push @to_close, $p;
            $self->{'_pos'} = $p->{'_parent'};
        }
        else {

            # Close the first of the specified tag, giving up if you hit
            #  any of the stop-tags.
            while ( defined $p ) {
                $ptag = $p->{'_tag'};
                print $indent, " (Looking at $ptag.)\n" if DEBUG > 2;
                if ( $ptag eq $tag ) {
                    print $indent, " (Closing $tag.)\n" if DEBUG > 2;
                    last;
                }
                for (@stop) {
                    if ( $ptag eq $_ ) {
                        print $indent,
                            " (Hit a limiting $_ -- bailing out.)\n"
                            if DEBUG > 1;
                        return;    # so it was all for naught
                    }
                }
                push @to_close, $p;
                $p = $p->{'_parent'};
            }
            return unless defined $p;    # We went off the top of the tree.
               # Otherwise specified element was found; set pos to its parent.
            push @to_close, $p;
            $self->{'_pos'} = $p->{'_parent'};
        }

        $self->{'_pos'} = undef if $self eq ( $self->{'_pos'} || '' );
        print $indent, "(Pos now points to ",
            $self->{'_pos'} ? $self->{'_pos'}{'_tag'} : '???', ".)\n"
            if DEBUG > 1;

        ### EXPENSIVE, because has to check that it's not under a pre
        ### or a CDATA-parent.  That's one more method call per end()!
        ### Might as well just do this at the end of the tree-parse, I guess,
        ### at which point we'd be parsing top-down, and just not traversing
        ### under pre's or CDATA-parents.
        ##
        ## Take this opportunity to nix any terminal whitespace nodes.
        ## TODO: consider whether this (plus the logic in start(), above)
        ## would ever leave any WS nodes in the tree.
        ## If not, then there's no reason to have eof() call
        ## delete_ignorable_whitespace on the tree, is there?
        ##
    #if(@to_close and $self->{'_tighten'} and !$self->{'_ignore_text'} and
    #  ! $to_close[-1]->is_inside('pre', keys %HTML::Tagset::isCDATA_Parent)
    #) {  # if tightenable
    #  my($children, $e_tag);
    #  foreach my $e (reverse @to_close) { # going top-down
    #    last if 'pre' eq ($e_tag = $e->{'_tag'}) or
    #     $HTML::Tagset::isCDATA_Parent{$e_tag};
    #
    #    if(
    #      $children = $e->{'_content'}
    #      and @$children      # has children
    #      and !ref($children->[-1])
    #      and $children->[-1] =~ m<^\s+$>s # last node is all-WS
    #      and
    #        (
    #         # has a tightable parent:
    #         $HTML::DOM::_TreeBuilder::canTighten{ $e_tag }
    #         or
    #          ( # has a tightenable left sibling:
    #            @$children > 1 and
    #            ref($children->[-2])
    #            and $HTML::DOM::_TreeBuilder::canTighten{ $children->[-2]{'_tag'} }
    #          )
    #        )
    #    ) {
    #      pop @$children;
    #      #print $indent, "Popping a terminal WS node from ", $e->{'_tag'},
    #      #  " (", $e->address, ") while exiting.\n" if DEBUG;
    #    }
    #  }
    #}

        foreach my $e (@to_close) {

            # Call the applicable callback, if any
            $ptag = $e->{'_tag'};
            &{         $self->{"_tweak_$ptag"}
                    || $self->{'_tweak_*'}
                    || next }( map $_, $e, $ptag, $self );
            print $indent, "Back from tweaking.\n" if DEBUG;
            last
                if $self->{ '_stunted'
                    };    # in case one of the handlers called stunt
        }
        return @to_close;
    }
}

#==========================================================================
{
    my ( $indent, $nugget );

    sub text {
        return if $_[0]{'_stunted'};

        # Accept a "here's a text token" signal from HTML::Parser.
        my ( $self, $text, $is_cdata ) = @_;

        # the >3.0 versions of Parser may pass a cdata node.
        # Thanks to Gisle Aas for pointing this out.

        return unless length $text;    # I guess that's always right

        my $ignore_text         = $self->{'_ignore_text'};
        my $no_space_compacting = $self->{'_no_space_compacting'};
        my $no_expand_entities  = $self->{'_no_expand_entities'};
        my $pos                 = $self->{'_pos'} || $self;

        HTML::Entities::decode($text)
            unless $ignore_text
                || $is_cdata
                || $HTML::Tagset::isCDATA_Parent{ $pos->{'_tag'} }
                || $no_expand_entities;

        #my($indent, $nugget);
        if (DEBUG) {

           # optimization -- don't figure out depth unless we're in debug mode
            my @lineage_tags = $pos->lineage_tag_names;
            $indent = '  ' x ( 1 + @lineage_tags );

            $nugget
                = ( length($text) <= 25 )
                ? $text
                : ( substr( $text, 0, 25 ) . '...' );
            $nugget =~ s<([\x00-\x1F])>
                 <'\\x'.(unpack("H2",$1))>eg;
            print $indent, "Proposing a new text node ($nugget) under ",
                join( '/', reverse( $pos->{'_tag'}, @lineage_tags ) )
                || 'Root',
                ".\n";

            #} else {
            #  $indent = ' ';
        }

        my $ptag;
        if ($HTML::Tagset::isCDATA_Parent{ $ptag = $pos->{'_tag'} }

            #or $pos->is_inside('pre')
            or $pos->is_inside( 'pre', 'textarea' )
            )
        {
            return if $ignore_text;
            $pos->push_content($text);
        }
        else {

            # return unless $text =~ /\S/;  # This is sometimes wrong

            if ( !$self->{'_implicit_tags'} || $text !~ /[^\n\r\f\t ]/ ) {

                # don't change anything
            }
            elsif ( $ptag eq 'head' or $ptag eq 'noframes' ) {
                if ( $self->{'_implicit_body_p_tag'} ) {
                    print $indent,
                        " * Text node under \U$ptag\E closes \U$ptag\E, implicates BODY and P.\n"
                        if DEBUG > 1;
                    $self->end( \$ptag );
                    $pos = $self->{'_body'}
                        ? ( $self->{'_pos'}
                            = $self->{'_body'} )    # expected case
                        : $self->insert_element( 'body', 1 );
                    $pos = $self->insert_element( 'p', 1 );
                }
                else {
                    print $indent,
                        " * Text node under \U$ptag\E closes, implicates BODY.\n"
                        if DEBUG > 1;
                    $self->end( \$ptag );
                    $pos = $self->{'_body'}
                        ? ( $self->{'_pos'}
                            = $self->{'_body'} )    # expected case
                        : $self->insert_element( 'body', 1 );
                }
            }
            elsif ( $ptag eq 'html' ) {
                if ( $self->{'_implicit_body_p_tag'} ) {
                    print $indent,
                        " * Text node under HTML implicates BODY and P.\n"
                        if DEBUG > 1;
                    $pos = $self->{'_body'}
                        ? ( $self->{'_pos'}
                            = $self->{'_body'} )    # expected case
                        : $self->insert_element( 'body', 1 );
                    $pos = $self->insert_element( 'p', 1 );
                }
                else {
                    print $indent,
                        " * Text node under HTML implicates BODY.\n"
                        if DEBUG > 1;
                    $pos = $self->{'_body'}
                        ? ( $self->{'_pos'}
                            = $self->{'_body'} )    # expected case
                        : $self->insert_element( 'body', 1 );

                    #print "POS is $pos, ", $pos->{'_tag'}, "\n";
                }
            }
            elsif ( $ptag eq 'body' ) {
                if ( $self->{'_implicit_body_p_tag'} ) {
                    print $indent, " * Text node under BODY implicates P.\n"
                        if DEBUG > 1;
                    $pos = $self->insert_element( 'p', 1 );
                }
            }
            elsif ( $ptag eq 'table' ) {
                print $indent,
                    " * Text node under TABLE implicates TR and TD.\n"
                    if DEBUG > 1;
                $self->insert_element( 'tr', 1 );
                $pos = $self->insert_element( 'td', 1 );

                # double whammy!
            }
            elsif ( $ptag eq 'tr' ) {
                print $indent, " * Text node under TR implicates TD.\n"
                    if DEBUG > 1;
                $pos = $self->insert_element( 'td', 1 );
            }

            # elsif (
            #       # $ptag eq 'li'   ||
            #       # $ptag eq 'dd'   ||
            #         $ptag eq 'form') {
            #    $pos = $self->insert_element('p', 1);
            #}

            # Whatever we've done above should have had the side
            # effect of updating $self->{'_pos'}

            #print "POS is now $pos, ", $pos->{'_tag'}, "\n";

            return if $ignore_text;
            $text =~ s/[\n\r\f\t ]+/ /g    # canonical space
                unless $no_space_compacting;

            print $indent, " (Attaching text node ($nugget) under ",

           # was: $self->{'_pos'} ? $self->{'_pos'}{'_tag'} : $self->{'_tag'},
                $pos->{'_tag'}, ").\n"
                if DEBUG > 1;

            $pos->push_content($text);
        }

        &{ $self->{'_tweak_~text'} || return }( $text, $pos,
            $pos->{'_tag'} . '' );

        # Note that this is very exceptional -- it doesn't fall back to
        #  _tweak_*, and it gives its tweak different arguments.
        return;
    }
}

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

# TODO: test whether comment(), declaration(), and process(), do the right
#  thing as far as tightening and whatnot.
# Also, currently, doctypes and comments that appear before head or body
#  show up in the tree in the wrong place.  Something should be done about
#  this.  Tricky.  Maybe this whole business of pre-making the body and
#  whatnot is wrong.

sub comment {
    return if $_[0]{'_stunted'};

    # Accept a "here's a comment" signal from HTML::Parser.

    my ( $self, $text ) = @_;
    my $pos = $self->{'_pos'} || $self;
    return
        unless $self->{'_store_comments'}
            || $HTML::Tagset::isCDATA_Parent{ $pos->{'_tag'} };

    if (DEBUG) {
        my @lineage_tags = $pos->lineage_tag_names;
        my $indent = '  ' x ( 1 + @lineage_tags );

        my $nugget
            = ( length($text) <= 25 )
            ? $text
            : ( substr( $text, 0, 25 ) . '...' );
        $nugget =~ s<([\x00-\x1F])>
                 <'\\x'.(unpack("H2",$1))>eg;
        print $indent, "Proposing a Comment ($nugget) under ",
            join( '/', reverse( $pos->{'_tag'}, @lineage_tags ) ) || 'Root',
            ".\n";
    }

    ( my $e = $self->element_class->new('~comment') )->{'text'} = $text;
    $pos->push_content($e);
    ++( $self->{'_element_count'} );

    &{         $self->{'_tweak_~comment'}
            || $self->{'_tweak_*'}
            || return $e }( map $_, $e, '~comment', $self );

    return $e;
}

sub declaration {
    return if $_[0]{'_stunted'};

    # Accept a "here's a markup declaration" signal from HTML::Parser.

    my ( $self, $text ) = @_;
    my $pos = $self->{'_pos'} || $self;

    if (DEBUG) {
        my @lineage_tags = $pos->lineage_tag_names;
        my $indent = '  ' x ( 1 + @lineage_tags );

        my $nugget
            = ( length($text) <= 25 )
            ? $text
            : ( substr( $text, 0, 25 ) . '...' );
        $nugget =~ s<([\x00-\x1F])>
                 <'\\x'.(unpack("H2",$1))>eg;
        print $indent, "Proposing a Declaration ($nugget) under ",
            join( '/', reverse( $pos->{'_tag'}, @lineage_tags ) ) || 'Root',
            ".\n";
    }
    ( my $e = $self->element_class->new('~declaration') )->{'text'} = $text;

    $self->{_decl} = $e;
    return $e;
}

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

sub process {
    return if $_[0]{'_stunted'};

    # Accept a "here's a PI" signal from HTML::Parser.

    return unless $_[0]->{'_store_pis'};
    my ( $self, $text ) = @_;
    my $pos = $self->{'_pos'} || $self;

    if (DEBUG) {
        my @lineage_tags = $pos->lineage_tag_names;
        my $indent = '  ' x ( 1 + @lineage_tags );

        my $nugget
            = ( length($text) <= 25 )
            ? $text
            : ( substr( $text, 0, 25 ) . '...' );
        $nugget =~ s<([\x00-\x1F])>
                 <'\\x'.(unpack("H2",$1))>eg;
        print $indent, "Proposing a PI ($nugget) under ",
            join( '/', reverse( $pos->{'_tag'}, @lineage_tags ) ) || 'Root',
            ".\n";
    }
    ( my $e = $self->element_class->new('~pi') )->{'text'} = $text;
    $pos->push_content($e);
    ++( $self->{'_element_count'} );

    &{ $self->{'_tweak_~pi'} || $self->{'_tweak_*'} || return $e }( map $_,
        $e, '~pi', $self );

    return $e;
}

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

#When you call $tree->parse_file($filename), and the
#tree's ignore_ignorable_whitespace attribute is on (as it is
#by default), HTML::DOM::_TreeBuilder's logic will manage to avoid
#creating some, but not all, nodes that represent ignorable
#whitespace.  However, at the end of its parse, it traverses the
#tree and deletes any that it missed.  (It does this with an
#around-method around HTML::Parser's eof method.)
#
#However, with $tree->parse($content), the cleanup-traversal step
#doesn't happen automatically -- so when you're done parsing all
#content for a document (regardless of whether $content is the only
#bit, or whether it's just another chunk of content you're parsing into
#the tree), call $tree->eof() to signal that you're at the end of the
#text you're inputting to the tree.  Besides properly cleaning any bits
#of ignorable whitespace from the tree, this will also ensure that
#HTML::Parser's internal buffer is flushed.

sub eof {

    # Accept an "end-of-file" signal from HTML::Parser, or thrown by the user.

    return if $_[0]->{'_done'};    # we've already been here

    return $_[0]->SUPER::eof() if $_[0]->{'_stunted'};

    my $x = $_[0];
    print "EOF received.\n" if DEBUG;
    my (@rv);
    if (wantarray) {

        # I don't think this makes any difference for this particular
        #  method, but let's be scrupulous, for once.
        @rv = $x->SUPER::eof();
    }
    else {
        $rv[0] = $x->SUPER::eof();
    }

    $x->end('html') unless $x eq ( $x->{'_pos'} || $x );

    # That SHOULD close everything, and will run the appropriate tweaks.
    # We /could/ be running under some insane mode such that there's more
    #  than one HTML element, but really, that's just insane to do anyhow.

    unless ( $x->{'_implicit_tags'} ) {

        # delete those silly implicit head and body in case we put
        # them there in implicit tags mode
        foreach my $node ( $x->{'_head'}, $x->{'_body'} ) {
            $node->replace_with_content
                if defined $node
                    and ref $node
                    and $node->{'_implicit'}
                    and $node->{'_parent'};

            # I think they should be empty anyhow, since the only
            # logic that'd insert under them can apply only, I think,
            # in the case where _implicit_tags is on
        }

        # this may still leave an implicit 'html' at the top, but there's
        # nothing we can do about that, is there?
    }

    $x->delete_ignorable_whitespace()

        # this's why we trap this -- an after-method
        if $x->{'_tighten'} and !$x->{'_ignore_text'};
    $x->{'_done'} = 1;

    return @rv if wantarray;
    return $rv[0];
}

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

# TODO: document

sub stunt {
    my $self = $_[0];
    print "Stunting the tree.\n" if DEBUG;
    $self->{'_done'} = 1;

    if ( $HTML::Parser::VERSION < 3 ) {

        #This is a MEAN MEAN HACK.  And it works most of the time!
        $self->{'_buf'} = '';
        my $fh = *HTML::Parser::F{IO};

        # the local'd FH used by parse_file loop
        if ( defined $fh ) {
            print "Closing Parser's filehandle $fh\n" if DEBUG;
            close($fh);
        }

      # But if they called $tree->parse_file($filehandle)
      #  or $tree->parse_file(*IO), then there will be no *HTML::Parser::F{IO}
      #  to close.  Ahwell.  Not a problem for most users these days.

    }
    else {
        $self->SUPER::eof();

        # Under 3+ versions, calling eof from inside a parse will abort the
        #  parse / parse_file
    }

    # In the off chance that the above didn't work, we'll throw
    #  this flag to make any future events be no-ops.
    $self->stunted(1);
    return;
}

# TODO: document
sub stunted { shift->_elem( '_stunted', @_ ); }
sub done    { shift->_elem( '_done',    @_ ); }

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

sub delete {

    # Override Element's delete method.
    # This does most, if not all, of what Element's delete does anyway.
    # Deletes content, including content in some special attributes.
    # But doesn't empty out the hash.

    $_[0]->{'_element_count'} = 1;    # never hurts to be scrupulously correct

    delete @{ $_[0] }{ '_body', '_head', '_pos' };
    for (
        @{ delete( $_[0]->{'_content'} ) || [] },    # all/any content

     #       delete @{$_[0]}{'_body', '_head', '_pos'}
     # ...and these, in case these elements don't appear in the
     #   content, which is possible.  If they did appear (as they
     #   usually do), then calling $_->delete on them again is harmless.
     #  I don't think that's such a hot idea now.  Thru creative reattachment,
     #  those could actually now point to elements in OTHER trees (which we do
     #  NOT want to delete!).
## Reasoned out:
  #  If these point to elements not in the content list of any element in this
  #   tree, but not in the content list of any element in any OTHER tree, then
  #   just deleting these will make their refcounts hit zero.
  #  If these point to elements in the content lists of elements in THIS tree,
  #   then we'll get to deleting them when we delete from the top.
  #  If these point to elements in the content lists of elements in SOME OTHER
  #   tree, then they're not to be deleted.
        )
    {
        $_->delete
            if defined $_ and ref $_    #  Make sure it's an object.
                and $_ ne $_[0];    #  And avoid hitting myself, just in case!
    }

    $_[0]->detach if $_[0]->{'_parent'} and $_[0]->{'_parent'}{'_content'};

    # An 'html' element having a parent is quite unlikely.

    return;
}

sub tighten_up {                    # legacy
    shift->delete_ignorable_whitespace(@_);
}

sub elementify {

    # Rebless this object down into the normal element class.
    my $self     = $_[0];
    my $to_class = $self->element_class;
    delete @{$self}{
        grep {
            ;
            length $_ and substr( $_, 0, 1 ) eq '_'

                # The private attributes that we'll retain:
                and $_ ne '_tag'
                and $_ ne '_parent'
                and $_ ne '_content'
                and $_ ne '_implicit'
                and $_ ne '_pos'
                and $_ ne '_element_class'
            } keys %$self
        };
    bless $self, $to_class;    # Returns the same object we were fed
}

sub element_class {
    return 'HTML::DOM::_Element' if not ref $_[0];
    return $_[0]->{_element_class} || 'HTML::DOM::_Element';
}

#--------------------------------------------------------------------------

sub guts {
    my @out;
    my @stack       = ( $_[0] );
    my $destructive = $_[1];
    my $this;
    while (@stack) {
        $this = shift @stack;
        if ( !ref $this ) {
            push @out, $this;    # yes, it can include text nodes
        }
        elsif ( !$this->{'_implicit'} ) {
            push @out, $this;
            delete $this->{'_parent'} if $destructive;
        }
        else {

            # it's an implicit node.  Delete it and recurse
            delete $this->{'_parent'} if $destructive;
            unshift @stack,
                @{
                (   $destructive
                    ? delete( $this->{'_content'} )
                    : $this->{'_content'}
                    )
                    || []
                };
        }
    }

    # Doesn't call a real $root->delete on the (when implicit) root,
    #  but I don't think it needs to.

    return @out if wantarray;    # one simple normal case.
    return unless @out;
    return $out[0] if @out == 1 and ref( $out[0] );
    my $x = HTML::DOM::_Element->new( 'div', '_implicit' => 1 );
    $x->push_content(@out);
    return $x;
}

sub disembowel { $_[0]->guts(1) }

#--------------------------------------------------------------------------
1;

__END__