The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!perl
# vim:ts=2:sw=2:et:ft=perl

use strict;
use warnings;

use XML::Descent;
use Data::Dumper;
use Test::More tests => 4;
use Test::Differences;

my $td = test_data(
  do { local $/; <DATA> }
);

# inherit
{
  ok my $p = XML::Descent->new( Input => \$td->{t1} );
  my @got = ();
  $p->on(
    link => sub {
      my ( $elem, $attr, $ctx ) = @_;
      push @got, [ $p->get_path, $attr ];
    },
    name => sub {
      my ( $elem, $attr, $ctx ) = @_;
      push @got, [ $p->get_path, $attr ];
    },
    nested => sub {
      my ( $elem, $attr, $ctx ) = @_;
      $p->on(
        '*' => sub {
          my ( $elem, $attr, $ctx ) = @_;
          push @got, [ '*', $p->get_path, $attr ];
        }
      )->inherit( 'name' )->walk;
    },
  )->walk;

  my @expect = (
    [ '/root/link', { 'href' => 'http://hexten.net/' } ],
    [ '/root/name', {} ],
    [ '*', '/root/nested/link', { 'href' => 'http://perl.org/' } ],
    [ '/root/nested/name', {} ],
    [ '*', '/root/nested/froob', { 'id' => '2' } ]
  );

  unless ( eq_or_diff \@got, \@expect, 'inherit' ) {
    diag Dumper( \@got );
  }
}

# before/after
{
  ok my $p = XML::Descent->new( Input => \$td->{t1} );
  my @got = ();
  $p->on(
    link => sub {
      my ( $elem, $attr, $ctx ) = @_;
      push @got, [ $p->get_path, $attr ];
    },
    name => sub {
      my ( $elem, $attr, $ctx ) = @_;
      push @got, [ $p->get_path, $attr ];
    },
    nested => sub {
      my ( $elem, $attr, $ctx ) = @_;
      $p->before( link => sub { push @got, 'before link' } );
      $p->after( name => sub { push @got, 'after name' } );
      $p->on(
        froob => sub {
          my ( $elem, $attr, $ctx ) = @_;
          push @got, [ $p->get_path, $attr ];
        }
      );
      $p->after( froob => sub { push @got, 'after froob' } );
      $p->before( froob => sub { push @got, 'before froob' } );
      push @got,
       {
        scope_handlers => [ $p->scope_handlers ],
        all_handlers   => [ $p->all_handlers ]
       };
      $p->walk;
    },
  )->walk;

  my @expect = (
    [ '/root/link', { 'href' => 'http://hexten.net/' } ],
    [ '/root/name', {} ],
    {
      'all_handlers'   => [ 'froob', 'link', 'name', 'nested' ],
      'scope_handlers' => [ 'froob', 'link', 'name' ]
    },
    'before link',
    [ '/root/nested/link', { 'href' => 'http://perl.org/' } ],
    [ '/root/nested/name', {} ],
    'after name',
    'before froob',
    [ '/root/nested/froob', { 'id' => '2' } ],
    'after froob'
  );

  unless ( eq_or_diff \@got, \@expect, 'before/after' ) {
    diag Dumper( \@got );
  }
}

sub test_data {
  my $xml = shift;
  my $td  = {};
  my $p   = XML::Descent->new( Input => \$xml );
  $p->on(
    test => sub {
      my ( $elem, $attr, $ctx ) = @_;
      $td->{ $attr->{id} } = $p->xml;
    }
  )->walk;
  return $td;
}

__DATA__
<tests>
  <test id="t1">
    <root>
      <link href="http://hexten.net/">Hexten</link>
      <name>Horse Fingers</name>
      <froob id="1" />
      <nested>
        <link href="http://perl.org/">Perl</link>
        <name>Providence</name>
        <froob id="2" />
      </nested>
    </root>
  </test>
  <test id="t2">
    <root>
    </root>
  </test>
</tests>