The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl
#Based upon example found on web

use Test::More tests => 14;
BEGIN { use_ok('Parse::Stallion')};

my $grammar = {
 top => A(qr/^/, 'xml', qr/$/),

 xml => A('plain',M(A('tag','plain'))),

 plain => qr/[^<>&]*/,

 tag => A(qr/\</, {tag1 => qr/\w+/}, M('attributes'),
   O(qr/\s*\/\>/,
    A( qr/\>/, 'xml', qr/\<\//, {tag2=>qr/\w+/}, qr/\>/)
    ),
  E(sub {if ((exists $_[0]->{tag2}) && ($_[0]->{tag2} ne $_[0]->{tag1}))
    {return (undef, 1)}
    return $_[0];
   }),U()
  ),

 attributes => L(qr/\s+\w+\s*\=\s*\"[^"<>]*\"\s*/),

};

my $xml_parser = new Parse::Stallion($grammar);

    my @tests = (
        [1, 'abc'                       ],      # 1
        [1, '<a></a>'                   ],      # 2
        [1, '..<ab>foo</ab>dd'          ],      # 3
        [1, '<a><b>c</b></a>'           ],      # 4
        [1, '<a href="foo"><b>c</b></a>'],      # 5
        [1, '<a empty="" ><b>c</b></a>' ],      # 6
        [1, '<a><b>c</b><c></c></a>'    ],      # 7
        [0, '<'                         ],      # 8
        [0, '<a>b</b>'                  ],      # 9
        [0, '<a>b</a'                   ],      # 10
        [0, '<a>b</a href="">'          ],      # 11
        [1, '<a/>'                      ],      # 12
        [1, '<a />'                     ],      # 13
    );

#    my $count = 1;
    foreach my $t (@tests) {
        my $s = $t->[1];
        my ($M,$r) = $xml_parser->parse_and_evaluate($s);
        my $v = 0;
        if (!($M  xor $t->[0])) {$v = 1};
        is ($v,1, $t->[1]);
#        if (!($M  xor $t->[0])) {
#            print "ok $count - '$s'\n";
#use Data::Dumper;print "M is ".Dumper($M)."\n"; #shows parse tree
#        } else {
#            print "not ok $count - '$s'\n";
#        }
#        $count++;
    }