File Coverage

blib/lib/XML/Parser/Nodes.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

package XML::Parser::Nodes ;

use 5.008009 ;
use strict ;
use warnings ;
use Carp ;

use XML::Parser ;
use XML::Dumper ;
use XML::Parser::Style::Tree ;

require Exporter ;

our @ISA = qw( Exporter XML::Parser::Style::Tree ) ;

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use XML::Parser::Nodes ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.

our %EXPORT_TAGS = ( 'all' => [ qw( ) ] ) ;

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ) ;

our @EXPORT = qw( ) ;

our $VERSION = '0.08' ;

$XML::Parser::Built_In_Styles{Nodes} = 1;

sub Init {
	return XML::Parser::Style::Tree::Init( @_ ) ;
	} ;

sub Start {
	return XML::Parser::Style::Tree::Start( @_ ) ;
	} ;

sub End {
	return XML::Parser::Style::Tree::End( @_ ) ;
	} ;

sub Char {
	return XML::Parser::Style::Tree::Char( @_ ) ;
	} ;

sub Final {
	my $tree = XML::Parser::Style::Tree::Final( @_ ) ;
	return XML::Parser::Nodes->conform( $tree ) ;
	} ;

# Preloaded methods go here.

sub new {
	my $self = shift ;
	my $xmlarg = shift ;
	return length $xmlarg < 255 && $xmlarg !~ /^
			$self->parsefile( $xmlarg ):
			$self->parse( $xmlarg ) ;
	}

################################################################################
##
##  In XML::Parser's output, a node is an Array whose first element is a
##  Hash of NVP's that represent that tag's attributes.  Subsequent
##  elements alternate between text and child nodes.
##
##  conform() prepends an empty hash to the output structure to ensure it
##  conforms to this node definition.
##
################################################################################

sub conform {
	my $package = shift ;
	my $parsed = shift ;
	$package = ref $package if ref $package ;
	unshift @$parsed, {} ;
	return bless $parsed, $package ;
	}

sub parse {
	my $self = shift ;
	my $xmlbuff = shift ;

	my $package = ref $self? ref $self: $self ;
	my $parser = ref $self? $self:
			XML::Parser->new( Style => 'Tree' ) ;
	return $package->conform( XML::Parser::parse(
			$parser, $xmlbuff ) ) ;
	}

sub parsefile {
	my $self = shift ;
	my $xmlfn = shift ;

	my $package = ref $self? ref $self: $self ;
	return ref $self? XML::Parser::parsefile( $self, $xmlfn ):
			$package->conform(
			XML::Parser->new( Style => 'Tree' )->parsefile( $xmlfn )
			) ;
	}

sub byfile {
	return parsefile( @_ ) ;
	}

sub readfile {
	return parsefile( @_ ) ;
	}

sub childlist {
	my $self = shift ;
	my $i = 0 ;
	my @a = () ;
	push @a, [ $self->[ $i ], $self->[ ++$i ] ] while $i++ < $#$self ;
	return map { $_->[0] } grep ref $_->[1], @a ;
	}

sub taglist {
	return childlist( @_ ) ;
	}

sub tree {
	my $self = shift ;
	my $tag = '' ;
	my @rv = () ;

	if ( @_ ) {
		push @rv, shift @_ ;
		$tag = $rv[0] .'/' ;
		}

	my $i = 0 ;
	my @a = () ;
	push @a, [ $self->[ $i ], $self->[ ++$i ] ] while $i++ < $#$self ;
	push @rv, map { tree( $_->[1], $tag .$_->[0] ) } grep ref $_->[1], @a ;
	return @rv ;
	}

sub childnodes {
	my $self = shift ;

	my $i = 0 ;
	my @a = () ;
	push @a, [ $self->[ $i ], $self->[ ++$i ] ] while $i++ < $#$self ;
	my @aa = grep ref $_->[1], @a ;
	map { bless $_->[1], ref $self } @aa ;
	return @aa ;
	}

sub getkids {
	return childnodes( @_ ) ;
	}

sub childnode {
	my $self = shift ;
	return $self->childnodes unless @_ ;

	my $key = shift ;

	my $i = 0 ;
	my @a = () ;
	push @a, [ $self->[ $i ], $self->[ ++$i ] ] while $i++ < $#$self ;

	my @aa = map { bless $_->[1], ref $self } grep $_->[0] eq $key, @a ;
	return $aa[0] || bless( [], ref $self ) unless wantarray ;
	return @aa ;
	}

sub getdata {
	return childnode( @_ ) ;
	}

sub nodebykey {
	my $self = shift ;
	my $key = shift ;
	my @key = split( m|/|, $key, 2 ) ;
	my $next = $self->childnode( $key[0] ) ;

	return $next if @key == 1 ;
	return $next->nodebykey( $key[1] ) ;
	}

sub recordbykey {
	return nodebykey( @_ ) ;
	}

sub getattributes {
	my $self = shift ;
	return $self->[0] ;
	}

sub gettext {
	my $self = shift ;

	my $i = 0 ;
	my @a = () ;
	push @a, [ $self->[ $i ], $self->[ ++$i ] ] while $i++ < $#$self ;

	my @results = grep defined $_,
			map { $_->[1] } grep $_->[0] eq '0', @a ;
	return @results if wantarray && @results != 0 ;
	return join '', @results ;
	}

sub cells {
	my $self = shift ;
	my @rv = map { $self->childnode( $_ )->gettext || '' } @_ ;
	return \@rv ;
	}

sub wrapper {
	my $self = shift ;
	my $name = shift ;
	return bless [ {}, $name, $self ], ref $self ;
	}

sub name {
	return wrapper( @_ ) ;
	}

sub dump {
	my $self = shift ;
	return xmlout( @$self[ 1, 2 ] ) ."\n" ;
	}

sub xmlout {
	my $name = shift ;
	my $properties = shift ;
	my $singletag = undef ;		# optionally set true

	return retext( $properties ) if $name eq '0' ;

	my @properties = () ;
	push @properties, @$properties ;
	my $attribs = shift @properties ;
	$attribs ||= {} ;
	my $atstring .= join ' ', '', map { sprintf '%s="%s"',
			$_, charfix( $attribs->{$_} ) } keys %$attribs ;

	return "<$name$atstring />" unless scalar @properties ;

	my $out = "<$name$atstring>" ;
	$out .= xmlout( splice @properties, 0, 2 ) while @properties ;
	return "$out" ;
	}

sub retext {
	my $s = shift ;
	return '' unless defined $s ;
	$s =~ s/&/&/g ;
	$s =~ s/>/>/g ;
	$s =~ s/
	return $s ;
	}

sub charfix {
	my $value = shift ;
	return '' unless defined $value ;
	$value =~ s/&/&/g ;
	$value =~ s/"/"/g ;
	$value =~ s/'/'/g ;
	return $value ;
	}

no warnings ;

sub pl2xml {
	my $o = pop ;
	my $self = shift if @_ && ( ref $_[0] || $_[0] eq __PACKAGE__ ) ;
	$self = ! $self? __PACKAGE__: ref $self? ref $self: $self ;
	my $toplabel = shift ;
	$toplabel ||= 'perldata' ;

	my $top = $self->newelement() ;
	$top->addelement( "\n " ) ;
	$top->addelement( nextpl2xml( bless( {}, $self ), $o, 2 ) ) ;
	$top->addelement( "\n" ) ;

	my $out = $self->newelement() ;
	$out->addelement( $toplabel => $top ) ;
	return $out ;
	}

use warnings ;

sub nextpl2xml {
	my $self = shift;
	my $ref = shift;
	my $indent = shift;

	my $out = $self->newelement() ;

	if ( ref $ref ) {
		local $_ = ref $ref ;
		my $class = '' ;
		my $address = '' ;

		if ( /^(?:SCALAR|HASH|ARRAY)$/ ) {
			( $_, $address) = overload::StrVal( $ref )
					=~ /([^(]+)\(([x0-9A-Fa-f]+)\)/ ;
			}
		else {
			$class = XML::Dumper::xml_escape( ref $ref );
			( $_, $address ) = overload::StrVal( $ref )
					=~ /$class=([^(]+)\(([x0-9A-Fa-f]+)\)/ ;
			}

		my $reused = $address && $self->{xml}{ $address }++ ;
		my $indentstr = "\n" . " " x$indent ;

		$out->[0]->{blessed_package} = $class if $class ;
		$out->[0]->{memory_address} = $address if $address ;

		if ( /^SCALAR$/ && ! $reused ) {
			$out->[0]->{defined} = 'false' unless defined $$ref ;
			$out->addelement( 0 => $$ref ) ;
			}
		elsif ( /^HASH$/ && ! $reused ) {
			foreach my $k ( keys %$ref ) {
				$out->addelement( $indentstr ) ;
				$out->addelement( newitem( $self,
						{ key => $k },
						$ref->{ $k },
						$indent +1 ) ) ;
				}

			$out->addelement( "\n" . " " x( $indent -1 ) ) ;
			}
		elsif ( /^ARRAY$/ && ! $reused ) {
			for ( my $ct = 0 ; $ct < @$ref ; $ct++ ) {
				$out->addelement( $indentstr ) ;
				$out->addelement( newitem( $self,
						{ key => $ct },
						$ref->[ $ct ],
						$indent +1 ) ) ;
				}

			$out->addelement( "\n" . " " x( $indent -1 ) ) ;
			}

		my $key = /^SCALAR$/? 'scalarref':
				/^HASH$/? 'hashref':
				/^ARRAY$/? 'arrayref': '' ;

		return $key => $out ;
		}
	else {
		$out->[0]->{defined} = 'false' unless defined $ref ;
		$out->addelement( 0 => $ref ) ;
		return ( scalar => $out ) ;
		}
	}


sub newitem {
	my $self = shift ;
	my $attribs = shift ;
	my $value = shift ;
	my $indent = shift ;

	$attribs->{defined} = 'false' unless defined $value ;
	my $out = $self->newelement( %$attribs ) ;

	if ( ref $value ) {
		$out->addelement( "\n" . " " x$indent ) ;
		$out->addelement( nextpl2xml( $self, $value, $indent +1 ) ) ;
		$out->addelement( "\n" . " " x( $indent -1 ) ) ;
		}
	else {
		$out->addelement( $value ) ;
		}

	return ( item => $out ) ;
	}

sub newelement {
	my $self = shift if @_ && ( ref $_[0] || $_[0] eq __PACKAGE__ ) ;
	$self = ! $self? __PACKAGE__: ref $self? ref $self: $self ;

	return bless [ { @_ } ], $self ;
	}

sub addelement {
	my $self = shift ;
	my $scalar = pop ;
	my $key = @_? shift @_: 0 ;

	push @$self, $key, $scalar ;
	}

sub nvpdump {
	my $key = @_ > 3? pop( @_ ): '' ;
	my $space = @_ > 2? pop( @_ ): -1 ;
	my $self = pop @_ ;
	my @kids = $self->childnodes ;

	if ( @_ == 0 ) {
		@kids = $self->childnode('perldata')->childnodes ;
		carp( "Data source not from pl2xml" ) && return ""
				unless @kids == 1 ;
		return nvpdump( @{ $kids[0] } ) ;
		}

	my $name = shift ;
	my $pad = ' 'x$space ;

	return join "\n", map { nvpdump( @$_, $space +1 ) } @kids
			if $name eq 'hashref' ;
	return join "\n", map { nvpdump( @$_, $space, $key ) } @kids
			if $name eq 'arrayref' ;

	$key = $key && @kids? $key: $self->getattributes->{key} ;

	my $value = join "\n$pad",
			map { nvpdump( @$_, $space, $key ) } @kids ;
	return $value if @kids && $kids[0][0] eq 'arrayref' ;

	$value = join "\n", '', $value, $pad if $value ;
	$value ||= $self->gettext() ;
	return sprintf "$pad<$key>%s", $value ;
	}

1 ;
__END__