File Coverage

lib/MKDoc/XML/TreeBuilder.pm

Criterion	Covered	Total	%
statement	58	63	92.0
branch	13	16	81.2
condition			n/a
subroutine	7	7	100.0
pod	1	2	50.0
total	79	88	89.7

# -------------------------------------------------------------------------------------
# MKDoc::XML::TreeBuilder
# -------------------------------------------------------------------------------------
# Author : Jean-Michel Hiver.
# Copyright : (c) MKDoc Holdings Ltd, 2003
#
# This module turns an XML string into a tree of elements and returns the top elements.
# This assumes that the XML string is well-formed. Well. More or less :)
#
# This module is distributed under the same license as Perl itself.
# -------------------------------------------------------------------------------------
package MKDoc::XML::TreeBuilder;
use MKDoc::XML::Tokenizer;
use strict;
use warnings;


##
# $class->process_data ($xml);
# ----------------------------
# Parses $xml and turns it into a tree structure very similar
# to HTML::Element objects.
##
sub process_data
{
    my $class  = shift;
    my $tokens = MKDoc::XML::Tokenizer->process_data (@_);
    return _process_recurse ($tokens);
}


##
# $class->process_file ($filename);
# ---------------------------------
# Parses $xml and turns it into a tree structure very similar
# to HTML::Element objects.
##
sub process_file
{
    my $class  = shift;
    my $tokens = MKDoc::XML::Tokenizer->process_file (@_);
    return _process_recurse ($tokens);
}


##
# _process_recurse ($token_list);
# -------------------------------
# Turns $token_list array ref into a tree structure.
##
sub _process_recurse
{
    my $tokens = shift;
    my @result = ();

    while (@{$tokens})
    {
	# takes the first available token from the $tokens array reference
        my $token = shift @{$tokens};
	my $node  = undef;

	$node = $token->leaf();
	defined $node and do {
	    push @result, $node;
	    next;
	};

	$node = $token->tag_open();
	defined $node and do {
	    my $descendants   = _descendant_tokens ($token, $tokens);
	    $node->{_content} = _process_recurse ($descendants);
	    push @result, $node;
	    next;
	};

        my $token_as_string = $token->as_string();
	die qq |parse_error: Is this XML well-formed? (unexpected closing tag "$token_as_string")|;
    }

    return wantarray ? @result : \@result;
}


##
# $class->descendant_tokens ($token, $tokens);
# --------------------------------------------
# Removes all tokens from $tokens which are descendants
# of $token - assuming that $token is an opening tag token.
#
# Returns all the tokens removed except for $token matching
# closing tag. So the closing tag is removed from $tokens
# but not returned.
##
sub _descendant_tokens
{
    my $token   = shift;
    my $tokens  = shift;
    my @res     = ();
    my $balance = 1;
    while (@{$tokens})
    {
	my $next_token = shift (@{$tokens});
	my $node       = undef;

	$node = $next_token->leaf();
	defined $node and do {
	    push @res, $next_token;
	    next;
	};

	$node = $next_token->tag_open();
	defined $node and do {
	    $balance++;
	    push @res, $next_token;
	    next;
	};

	$node = $next_token->tag_close();
	defined $node and do {
	    $balance--;
	    last if ($balance == 0);
	    push @res, $next_token;
	    next;
	};

	die "BUG: The program should never reach this statement.";
    }

    return \@res if ($balance == 0);
    my $token_as_string = $token->as_string();
    die qq |parse_error: Is this XML well-formed? (could not find closing tag for "$token_as_string")|;
}


1;


__END__