view release on metacpan or  search on metacpan

lib/XML/Parser/Lite/Tree.pm  view on Meta::CPAN

package XML::Parser::Lite::Tree;

use 5.006;
use strict;
use warnings;
use XML::Parser::LiteCopy;

our $VERSION = '0.14';

use vars qw( $parser );

sub instance {
	return $parser if $parser;
	$parser = __PACKAGE__->new;
}

sub new {
	my $class = shift;
	my $self = bless {}, $class;

	my %opts = (ref $_[0]) ? ((ref $_[0] eq 'HASH') ? %{$_[0]} : () ) : @_;
	$self->{opts} = \%opts;

	$self->{__parser} = new XML::Parser::LiteCopy
		Handlers => {
			Start	=> sub { $self->_start_tag(@_); },
			Char	=> sub { $self->_do_char(@_); },
			CData	=> sub { $self->_do_cdata(@_); },
			End	=> sub { $self->_end_tag(@_); },
			Comment	=> sub { $self->_do_comment(@_); },
			PI	=> sub { $self->_do_pi(@_); },
			Doctype	=> sub { $self->_do_doctype(@_); },
		};
	$self->{process_ns} = $self->{opts}->{process_ns} || 0;
	$self->{skip_white} = $self->{opts}->{skip_white} || 0;

	return $self;
}

sub parse {
	my ($self, $content) = @_;

	my $root = {
		'type' => 'root',
		'children' => [],
	};

	$self->{tag_stack} = [$root];

	$self->{__parser}->parse($content);

	$self->cleanup($root);

	if ($self->{skip_white}){
		$self->strip_white($root);
	}

	if ($self->{process_ns}){
		$self->{ns_stack} = {};
		$self->mark_namespaces($root);
	}

	return $root;
}

sub _start_tag {
	my $self = shift;
	shift;

	my $new_tag = {
		'type' => 'element',
		'name' => shift,
		'attributes' => {},
		'children' => [],
	};

	while (my $a_name = shift @_){
		my $a_value = shift @_;
		$new_tag->{attributes}->{$a_name} = $a_value;
	}

	push @{$self->{tag_stack}->[-1]->{children}}, $new_tag;
	push @{$self->{tag_stack}}, $new_tag;
	1;
}

sub _do_char {
	my $self = shift;
	shift;

	for my $content(@_){

		my $new_tag = {
			'type' => 'text',
			'content' => $content,
		};

		push @{$self->{tag_stack}->[-1]->{children}}, $new_tag;
	}
	1;
}

sub _do_cdata {
	my $self = shift;
	shift;

	for my $content(@_){

		my $new_tag = {
			'type' => 'cdata',
			'content' => $content,
		};

		push @{$self->{tag_stack}->[-1]->{children}}, $new_tag;
	}
	1;
}

sub _end_tag {
	my $self = shift;

	pop @{$self->{tag_stack}};
	1;
}

sub _do_comment {
	my $self = shift;
	shift;

	for my $content(@_){

		my $new_tag = {
			'type' => 'comment',
			'content' => $content,
		};

		push @{$self->{tag_stack}->[-1]->{children}}, $new_tag;
	}
	1;
}

sub _do_pi {
	my $self = shift;
	shift;

	push @{$self->{tag_stack}->[-1]->{children}}, {
		'type' => 'pi',
		'content' => shift,
	};
	1;
}

sub _do_doctype {
	my $self = shift;
	shift;

	push @{$self->{tag_stack}->[-1]->{children}}, {
		'type' => 'dtd',
		'content' => shift,
	};
	1;
}

sub mark_namespaces {
	my ($self, $obj) = @_;

	my @ns_keys;

	#
	# mark