File Coverage

blib/lib/XML/Simple/Tree.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package XML::Simple::Tree;
## Aaron Dancygier
## $Id: Tree.pm,v 1.17 2005/11/09 01:21:53 aaron Exp $

use strict;

use Carp;
use XML::Simple;
use Storable qw(dclone);
use Class::MethodMaker [
  scalar => [
    { '*_get' => 'get_*', '*_set' => '_set_*', }, 'pos',
    { '*_get' => 'get_*', '*_set' => '_set_*', }, 'level',
    { '*_get' => 'get_*', '*_set' => '_set_*', }, 'rnode',
    { '*_get' => 'get_*', '*_set' => '_set_*', }, 'pnode',
    { '*_get' => 'get_*', '*_set' => '_set_*', }, 'cnode',
    { '*_get' => 'get_*', '*_set' => '_set_*', }, 'wnode',
    { '*_get' => 'get_*', '*_set' => '_set_*', }, 'node_key',
    { '*_get' => 'get_*', '*_set' => '_set_*', }, 'target_key',
    { '*_get' => 'get_*', '*_set' => '_set_*', }, 'file',
    { '*_get' => 'get_*', '*_set' => '_set_*', }, 'string'
  ]
] ;

our ($VERSION);

$VERSION = '0.03';

sub new {
  my ($class, %data) = @_;

  my $self = \%data;

  bless $self, $class;

  ($self->file_isset() && -e $self->get_file()) ||
    ($self->string_isset()) ||
      croak "file or string field must be set\n";

  $self->_set_rnode(
    XMLin(
      ($self->file_isset()) ? $self->get_file() : $self->get_string(),
      forcearray => 1
    ) ||
      croak "can't create XML::Tree::Simple object\n"
  );

  ($self->node_key_isset()) ||
    croak "must specify node key\n";

  ($self->target_key_isset()) ||
    croak "must specify target key\n";

  $self->_set_cnode($self->get_rnode());

  return $self;
}

sub find_node {
  my ($self, $name) = @_;

  my $cnode = $self->get_cnode();
  my $target_key = $self->get_target_key(); # ex name
  my $node_key = $self->get_node_key(); ## ex gallery
  return undef unless(exists ($cnode->{$node_key}));

  foreach ($self->children()) {
    if ($_->{$target_key}[0] eq $name) {
      # set parent node of wanted  node
      $self->_set_pnode($cnode);
      $self->_set_wnode($_);
      last;
    }

    unless (exists($_->{$node_key})) {
      next;
    }

    $self->_set_cnode($_);

    # recurse the next level
    $self->find_node($name);
  }

  ## reset current node to root
  $self->_set_cnode($self->get_rnode());

  return $self->get_wnode() || undef;
}

sub children {
  my ($self) = @_;

  my $cnode = $self->get_cnode();
  my $node_key = $self->get_node_key(); ## ex gallery

  return undef unless (exists($cnode->{$node_key}));

  return @{$cnode->{$node_key}};
}

sub siblings {
  my ($self) = @_;

  my $pnode = $self->get_pnode();
  my $node_key = $self->get_node_key();

  return undef unless (exists($pnode->{$node_key}));

  return @{$pnode->{$node_key}};
}

sub cut_node {
  my ($self, $name) = @_;

  $self->find_node($name) || return undef;
  my $pnode = $self->get_pnode();

  my $index = 0;
  my $found = 0;

  my $target_key = $self->get_target_key();
  my $node_key = $self->get_node_key();

  foreach ($self->siblings()) {
    if ($_->{$target_key}[0] eq $name) {
      $found = 1;
      last;
    }
    $index ++;
  }
  splice(@{$pnode->{$node_key}}, $index, 1) if ($found);
}

sub move_node {
  my ($self, $name, $direction) = @_;

  $self->find_node($name) || return undef;
  my $pnode = $self->get_pnode();

  my $index = 0;
  my $found = 0;

  my $target_key = $self->get_target_key();
  my $node_key = $self->get_node_key();

  foreach ($self->siblings()) {
    if ($_->{$target_key}[0] eq $name) {
      $found = 1;
      last;
    }
    $index ++;
  }

  my $new_index = 0;

  if ($direction eq 'up') {
    $new_index = $index - 1;
  } elsif ($direction eq 'down') {
    $new_index =
      ($index == $#{$pnode->{$node_key}})
	? 0
	: $index + 1
    ;
  }

  my $cloned_node = dclone($pnode->{$node_key}[$new_index]);

  $pnode->{$node_key}[$new_index] = $pnode->{$node_key}[$index];
  $pnode->{$node_key}[$index] = $cloned_node;
}

sub copy_node {
  my ($self, $name) = @_;

  return dclone($self->find_node($name));
}

sub paste_node {
  my ($self, $want, $paste_node) = @_;
  my $target_node = $self->find_node($want) || $self->get_rnode();

  my $node_key = $self->get_node_key();
  push (@{$target_node->{$node_key}}, $paste_node);
}

sub traverse {
  my ($self, $level) = @_;
  # depth-first pre order traversal

  $level ||= 0;
  my $i = 0;
  my $cnode = $self->get_cnode();
  my $node_key = $self->get_node_key();

  return undef unless(exists ($cnode->{$node_key}));

  foreach ($self->children()) {
    $self->_set_cnode($_);
    $self->_set_pnode($cnode);
    $self->_set_pos($i++);

    $self->_set_level($level);
    $self->do_node();

    if ($self->is_leaf()) {
      # if last child or outmost level
      $self->do_leaf();
      next;
    }

    $self->traverse($level + 1);
  }
}

sub post_traversal {
  my ($self, $level) = @_;
  # depth-first post order traversal

  $level ||= 0;
  my $i = 0;
  my $cnode = $self->get_cnode();
  my $node_key = $self->get_node_key();

  return undef unless(exists ($cnode->{$node_key}));

  foreach ($self->children()) {
    $self->_set_level($level);
    $i++;
    $self->_set_cnode($_);
    $self->post_traversal($self->get_level() + 1);
    $self->_set_cnode($_);
    $self->_set_pnode($cnode);
    $self->_set_pos($i - 1);
    $self->do_node();

    if ($self->is_leaf()) {
      # if last child or outmost level
      $self->do_leaf();
    }
    $self->_set_level($self->get_level() - 1);
  }
}

sub set_do_node {
  my ($self, $do_node) = @_;

  $self->{do_node} = $do_node;

  {
    local $^W = 0;
    no strict;
    *{ ref($self) . '::' . 'do_node' } = $self->{do_node};
  };
}

sub set_do_leaf {
  my ($self, $do_leaf) = @_;

  $self->{do_leaf} = $do_leaf;
  {
    local $^W = 0;
    no strict;
    *{ ref($self) . '::' . 'do_leaf' } = $self->{do_leaf};
  };
}

sub is_leaf {
  my $self = shift;

  my $cnode = $self->get_cnode();
  my $node_key = $self->get_node_key();

  return +( ! exists($cnode->{$node_key}) ) ? 1 : 0
}

## wrapper function for XMLout.
sub toXML {
  my $self = shift;

  my $rnode = $self->get_rnode();
  my $target_key = $self->get_target_key();

  my $xml;

  if (ref($_[0]) eq 'HASH') {
    if (exists($_[0]->{$target_key})) {
      $xml = XMLout(@_);
    }
  } else {
    $xml = XMLout($rnode, @_);
  }

  return $xml;
}

1;

__END__