File Coverage

blib/lib/XML/Handler/Trees.pm

Criterion	Covered	Total	%
statement	9	281	3.2
branch	0	84	0.0
condition	0	59	0.0
subroutine	3	45	6.6
pod			n/a
total	12	469	2.5

use strict;

package XML::Handler::Trees;
use vars qw/$VERSION/;
$VERSION = '0.02';

package XML::Handler::Tree;

sub new {
  my $class = ref($_[0]) || $_[0];
  bless {},$class;
}

sub start_document {
  my $self=shift;
  $self->{Lists}=[];
  $self->{Curlist}=$self->{Tree}=[];
}

sub start_element {
  my ($self,$element)=@_;
  my $newlist;
  if (exists $element->{LocalName}) {
    # namespaces are available!
    $newlist = [{}];
    foreach my $attr (values %{$element->{Attributes}}) {
      if ($attr->{NamespaceURI}) {
        $newlist->[0]{"{$attr->{NamespaceURI}}$attr->{LocalName}"} = $attr->{Value};
      }
      else {
        $newlist->[0]{$attr->{Name}} = $attr->{Value};
      }
    }
  }
  elsif (ref $element->{Attributes} eq 'HASH') {
    $newlist=[{map {$_=>$element->{Attributes}{$_}} keys %{$element->{Attributes}}}];
  }
  else {
    $newlist=[{map {$_=>$element->{Attributes}{$_}{Value}} keys %{$element->{Attributes}}}];
  }
  push @{ $self->{Lists} }, $self->{Curlist};
  if (exists($element->{LocalName}) && $element->{NamespaceURI}) {
    push @{ $self->{Curlist} }, "{$element->{NamespaceURI}}$element->{LocalName}" => $newlist;
  }
  else {
    push @{ $self->{Curlist} }, $element->{Name} => $newlist;
  }
  $self->{Curlist} = $newlist;
}

sub end_element {
  my ($self,$element)=@_;
  $self->{Curlist}=pop @{$self->{Lists}};
}

sub characters {
  my ($self,$text)=@_;
  my $clist = $self->{Curlist};
  my $pos = $#$clist;
  if ($pos>0 and $clist->[$pos-1] eq '0') {
    $clist->[$pos].=$text->{Data};
  }
  else {
    push @$clist,0=>$text->{Data};
  }
}

sub comment {}

sub processing_instruction {}

sub end_document {
  my $self=shift;
  delete $self->{Curlist};
  delete $self->{Lists};
  $self->{Tree};
}

package XML::Handler::EasyTree;

sub new {
  my $class=shift;
  $class=ref($class) || $class;
  my $self={Noempty=>0,Latin=>0,Searchable=>0,@_};
  $self->{Noempty}||=$self->{Searchable};
  bless $self,$class;
}

sub start_document {
  my $self = shift;
  $self->{Lists} = [];
  $self->{Curlist} = $self->{Tree} = [];
}

sub start_element {
  my ($self,$element)=@_;
  $self->checkempty();
  my $newlist=[];
  my $newnode;
  if ($self->{Searchable}) {
    $newnode= XML::Handler::EasyTree::Searchable->new( Name => $self->nsname($element), Content => $newlist );
  }
  else {
    $newnode={type=>'e',attrib=>{},name=>$self->nsname($element),content=>$newlist};
  }
  if (exists $element->{LocalName}) {
    while (my ($name,$obj) = each %{$element->{Attributes}}) {
      $newnode->{attrib}{$name} = $self->encode($obj->{Value});
    }
  }
  elsif (ref $element->{Attributes} eq 'HASH') {
    while (my ($name,$val)=each %{$element->{Attributes}}) {
      $newnode->{attrib}{$self->nsname($name)}=$self->encode($val);
    }
  }
  else {
    foreach my $att (keys %{$element->{Attributes}}) {
      $newnode->{attrib}{$self->nsname($element->{Attributes}{$att})}=$self->encode($element->{Attributes}{$att}{Value});
    }
  }
  push @{ $self->{Lists} }, $self->{Curlist};
  push @{ $self->{Curlist} }, $newnode;
  $self->{Curlist} = $newlist;
}

sub end_element {
  my $self=shift;
  $self->checkempty();
  $self->{Curlist}=pop @{$self->{Lists}};
}

sub characters {
  my ($self,$text)=@_;
  my $clist=$self->{Curlist};
  if (!@$clist || $clist->[-1]{type} ne 't') {
    push @$clist,{type=>'t',content=>''};
  }
  $clist->[-1]{content}.=$self->encode($text->{Data});
}

sub processing_instruction {
  my ($self,$pi)=@_;
  $self->checkempty();
  my $clist=$self->{Curlist};
  push @$clist,{type=>'p',target=>$self->encode($pi->{Target}),content=>$self->encode($pi->{Data})};
}

sub comment {}

sub end_document {
  my $self = shift;
  $self->checkempty();
  delete $self->{Curlist};
  delete $self->{Lists};
  if ($self->{Searchable}) {
    return XML::Handler::EasyTree::Searchable->new( Name => '__TOPLEVEL__', Content => $self->{Tree} );
  }
  $self->{Tree};
}

sub nsname {
  my ($self,$name)=@_;
  if (ref $name) {
    if (defined $name->{NamespaceURI}) {
      $name="{$name->{NamespaceURI}}$name->{LocalName}";
    }
    else {
      $name=$name->{Name};
    }
  }
  return $self->encode($name);
}

sub encode {
  my ($self,$text)=@_;
  if ($self->{Latin}) {
    $text=~s{([\xc0-\xc3])(.)}{
      my $hi = ord($1);
      my $lo = ord($2);
      chr((($hi & 0x03) <<6) | ($lo & 0x3F))
     }ge;
  }
  $text;
}

sub checkempty() {
  my $self=shift;
  if ($self->{Noempty}) {
    my $clist=$self->{Curlist};
    if (@$clist && $clist->[-1]{type} eq 't' && $clist->[-1]{content}=~/^\s+$/) {
      pop @$clist;
    }
  }
}

package XML::Handler::EasyTree::Searchable;

#
# new() returns a new node with the same structure at the `newnode'
# hashref
#
# Usage: XML::Handler::EasyTree::Searchable->new( Name => $name, Content => $content );
#
sub new {
  my $type = shift;
  my $class = ref($type) || $type || die "must supply a object type" ;

  my %opts = @_;

  my $name = $opts{Name} || '';
  my $content = $opts{Content} || undef;

  return bless ( {
		  type    => 'e',
		  attrib  => {},
		  name    => $name,
		  content => $content,
		 }, $class);
}

#
# name() returns the name of the node. Ideally, it should return a
# "fully qualified" name, but it doesn't
#
sub name {
  my $self = shift;
  return $self->{name};
}

#
# value() returns the value associated with an object
#
sub value {
  my $self = shift;

  return( undef )
    unless( ( exists $self->{content} ) && ( defined $self->{content} ) );

  my $possible = $self->{content};

  die "not an array" unless( "$possible" =~ /ARRAY/ );

  $possible = $possible->[0];

  return( undef )
    unless( ( exists $possible->{type} ) && ( $possible->{type} eq 't' ) );

  return( undef )
    unless( ( exists $possible->{content} ) && ( defined $possible->{content} ) );

  return $possible->{content};
}

#
# usage: $newobj = $obj->child( $name );
#
# child() returns a child (elements only) of the object with the $name
#
# for the case where there is more than one child that match $name,
# the array context semantics haven't been completely worked out:
# - in an array context, all children are returned.
# - in scalar context, the first child matching $name is returned.
#
# In a scalar context, The XML::Parser::SimpleObj class returns an
# object containing all the children matching $name, unless there is
# only one child in which case it returns that child (see commented
# code). I find that behavior confusing.
#
sub child {
  my $self = shift;
  my $spec = shift || '';

  my $array = $self->{content};

  my @rv;
  if( $spec ) {
    @rv = grep { $_->{name} eq $spec } grep { $_->{type} eq 'e' } @$array;
  } else {
    @rv = grep { $_->{type} eq 'e' } @$array;
  }

  my $num = scalar( @rv );

  if( wantarray() ) {
    return @rv;
  } else {
    return '' unless( $num );
    return $rv[0] if( $num == 1 );
    # my $class = ref( $self );
    # return $class->new( Name => "__magic_child_list_object__", Content => [ @rv ] );
  }
}

#
# usage: @children = $obj->children( $name );
#
# children() returns a list of all children (elements only) of the
# $obj that match $name -- in the order in which they appeared in the
# original xml text.
#
sub children {
  my $self = shift;
  my $array = $self->{content};
  my $spec = shift || '';


  my @rv;
  if( $spec ) {
    @rv = grep { $_->{name} eq $spec } grep { $_->{type} eq 'e' } @$array;
  } else {
    @rv = grep { $_->{type} eq 'e' } @$array;
  }

  return @rv;
}

#
# usage: @children_names = $obj->children_names();
#
# children_names() returns a list of all the names of the objects
# children (elements only) in the order in which they appeared in the
# original text
#
sub children_names {
  my $self = shift;
  my $array = $self->{content};

  return map { $_->{name} } grep { $_->{type} eq 'e' } @$array;
}

#
# usage: $attrib = $obj->attribute( $att_name );
#
# attribute() returns the string associated with the attribute of the
# object. If not found returns a null string.
#
sub attribute {
  my $self = shift;
  my $spec = shift || return '';

  return '' unless( ( exists $self->{attrib} ) && ( defined $self->{attrib} ) );

  my $attrib = $self->{attrib};
  return '' unless( ( exists $attrib->{$spec} ) && ( defined $attrib->{$spec} ) );

  return $attrib->{$spec};
}

#
# usage: @attribute_list = $obj->attribute_list();
#
# attribute_list() returns a list (in no particular order) of the
# attribute names associated with the object
#
sub attribute_list {
  my $self = shift;

  return '' unless( ( exists $self->{attrib} ) && ( defined $self->{attrib} ) );

  my $attrib = $self->{attrib};
  return '' unless( "$attrib" =~ /HASH/ );

  return keys %$attrib;
}

#
# usage: $text = $obj->dump_tree();
#
# dump_tree() returns a textual representation (in xml form) of the
# object's heirarchy. Only elements are processed.
#
#
sub dump_tree {
  my $self = shift;
  my %opts = @_;

  my $pretty = delete $opts{-pretty};

  my $name	= $self->name();
  my $value	= $self->value();
  my @children	= $self->children();

  my $text = '';
  unless( $name eq '__TOPLEVEL__' ) {
      $text .= "<$name";
      for my $att ( $self->attribute_list() ) {
	  $text .= sprintf( " %s=\"%s\"", $att, encode($self->attribute( $att )) );
      }
      $text .= ">";

      if( $value ) {
	  $text .= encode($value);
      }
  }


  for my $child ( @children ) {
    $text .= $child->dump_tree();
  }

  unless( $name eq '__TOPLEVEL__' ) {
      $text .= "";
  }

  return $text;
}

#
# usage: $text = $obj->pretty_dump_tree();
#
# pretty_dump_tree() is identical to dump_tree(), except that newline
# and indentation embellishments are added
#
sub pretty_dump_tree {
  my $self = shift;
  my $tab = shift || 0;

  my $indent = " " x ( 2 * $tab );

  my $name	= $self->name();
  my $value	= $self->value();
  my @children	= $self->children();

  my $text = '';
  unless( $name eq '__TOPLEVEL__' ) {
      $text .= "$indent<$name";
      for my $att ( $self->attribute_list() ) {
	  $text .= sprintf( " %s=\"%s\"", $att, encode($self->attribute( $att )) );
      }
      $text .= ">";

      if( defined $value ) {
	  $text .= encode($value);
	  $text .= "\n";
	  return $text;
      } else {
	  $text .= "\n";
      }
  }

  for my $child ( @children ) {
    $text .= $child->pretty_dump_tree( $tab + 1 );
  }

  unless( $name eq '__TOPLEVEL__' ) {
      $text .= "$indent\n";
  }

  return $text;
}

sub encode {
  my $encstr=shift;
  my %encodings=('&'=>'amp','<'=>'lt','>'=>'gt','"'=>'quot',"'"=>'apos');
  $encstr=~s/([&<>"'])/&$encodings{$1};/g;
  $encstr;
}

package XML::Handler::TreeBuilder;

use vars qw(@ISA);
@ISA=qw(XML::Element);

sub new {
  require XML::Element;
  my $class = ref($_[0]) || $_[0];
  my $self = XML::Element->new('NIL');
  $self->{'_element_class'} = 'XML::Element';
  $self->{'_store_comments'}     = 0;
  $self->{'_store_pis'}          = 0;
  $self->{'_store_declarations'} = 0;
  $self->{_stack}=[];
  bless $self, $class;
}

sub start_document {}

sub start_element {
  my ($self,$element)=@_;
  my @attlist;
  if (exists $element->{LocalName}) {
    @attlist=map {$_=>$element->{Attributes}{$_}{Value}} keys %{$element->{Attributes}};
  }
  elsif (ref $element->{Attributes} eq 'HASH') {
    @attlist=map {$_=>$element->{Attributes}{$_}} keys %{$element->{Attributes}};
  }
  else {
    @attlist=map {$_=>$element->{Attributes}{$_}{Value}} keys %{$element->{Attributes}};
  }
  if(@{$self->{_stack}}) {
    push @{$self->{_stack}}, $self->{'_element_class'}->new($element->{Name},@attlist);
    $self->{_stack}[-2]->push_content( $self->{_stack}[-1] );
  }
  else {
    $self->tag($element->{Name});
    while(@attlist) {
      $self->attr(splice(@attlist,0,2));
    }
    push @{$self->{_stack}}, $self;
  }
}

sub end_element {
  my $self=shift;
  pop @{$self->{_stack}};
  return
}

sub characters {
  my ($self,$text)=@_;
  $self->{_stack}[-1]->push_content($text->{Data});
}

sub comment {
  my ($self,$comment)=@_;
  return unless $self->{'_store_comments'};
  (@{$self->{_stack}} ? $self->{_stack}[-1] : $self)->push_content(
      $self->{'_element_class'}->new('~comment', 'text' => $comment->{Data})
    );
  return;
}

sub processing_instruction {
  my ($self,$pi)=@_;
  return unless $self->{'_store_pis'};
  (@{$self->{_stack}} ? $self->{_stack}[-1] : $self)->push_content(
      $self->{'_element_class'}->new('~pi', 'text' => "$pi->{Target} $pi->{Data}")
    );
  return;
}

sub end_document {
  my $self=shift;
  return $self;
}

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

sub store_comments { shift->_elem('_store_comments', @_); }
sub store_declarations { shift->_elem('_store_declarations', @_); }
sub store_pis      { shift->_elem('_store_pis', @_); }

1;
__END__