#!/usr/local/lib/perl -w
my
(
$doc_root_out
);
my
$doc_string
=
"<a><b>B<c><d>D</d></c></b><b><c>C</c></b></a>"
;
my
$doc
= QB->new(
"doc"
,
$doc_string
);
my
@out
;
sub
p {
push
@out
,
join
scalar
xvalue,
"("
,
")"
};
sub
t {
$doc_root_out
=
undef
;
@out
= ();
$doc
->playback( XML::Filter::Dispatcher->new(
@_
) );
}
sub
my_ok {
my
(
$got
,
$expected
) =
@_
;
@_
= ( 1 )
if
$got
=~
$expected
;
goto
&ok
;
}
my
@tests
= (
sub
{
t(
Rules
=> [
'a[b]'
=> [
'1'
=> \
&p
] ],
);
ok
join
(
","
,
@out
),
"(1)"
;
},
sub
{
t(
Rules
=> [
'a[b]/b[c]'
=> [
'1'
=> \
&p
] ],
);
ok
join
(
","
,
@out
),
"(1),(1)"
;
},
sub
{
t(
Rules
=> [
'string(a/b)'
=> \
&p
],
);
ok
join
(
","
,
@out
),
"(BD)"
;
},
sub
{
t(
Rules
=> [
'a[b]'
=> [
'string()'
=> \
&p
] ],
);
ok
join
(
","
,
@out
),
"(BDC)"
;
},
sub
{
t(
Rules
=> [
'b[c]'
=> [
'1'
=> \
&p
] ],
);
ok
join
(
","
,
@out
),
"(1),(1)"
;
},
sub
{
t(
Rules
=> [
'b[not(c)]'
=> [
'1'
=> \
&p
] ],
);
ok
join
(
","
,
@out
),
""
;
},
sub
{
t(
Rules
=> [
'b[not(c/d)]'
=> [
'1'
=> \
&p
] ],
);
ok
join
(
","
,
@out
),
"(1)"
;
},
sub
{
t(
Rules
=> [
'b[not(c/d)]'
=> [
'string()'
=> \
&p
] ],
);
ok
join
(
","
,
@out
),
"(C)"
;
},
sub
{
t(
Rules
=> [
'b[c/d]'
=> [
'string()'
=> \
&p
] ],
);
ok
join
(
","
,
@out
),
"(BD)"
;
},
);
plan
tests
=>
scalar
@tests
;
$_
->()
for
@tests
;
BEGIN {
@ResultTester::ISA
=
qw( XML::SAX::Base )
; }
sub
end_document {
"result string"
}
use
vars
qw( $AUTOLOAD )
;
sub
new {
my
$self
=
bless
[],
shift
;
my
(
$name
,
$doc
) =
@_
;
my
$cache_fn
= basename( $0 ) .
".cache.$name"
;
if
( -e
$cache_fn
) {
my
$old_self
=
do
$cache_fn
;
return
$old_self
if
defined
$old_self
&&
shift
@$old_self
eq
$doc
;
warn
"$!$@"
unless
defined
$old_self
;
unlink
$cache_fn
;
}
push
@$self
,
$doc
;
my
$p
= XML::SAX::PurePerl->new(
Handler
=>
$self
);
$p
->parse_string(
$doc
);
if
(
open
F,
">$cache_fn"
) {
local
$Data::Dumper::Terse
;
$Data::Dumper::Terse
= 1;
print
F Data::Dumper::Dumper(
$self
);
close
F;
}
shift
@$self
;
return
$self
;
}
sub
DESTROY;
sub
AUTOLOAD {
my
$self
=
shift
;
$AUTOLOAD
=~ s/.*://;
if
(
$AUTOLOAD
eq
"start_element"
) {
push
@$self
, [
$AUTOLOAD
, [ { %{
$_
[0]} } ] ];
}
else
{
push
@$self
, [
$AUTOLOAD
, [
$_
[0] ] ];
}
}
sub
playback {
my
$self
=
shift
;
my
$h
=
shift
;
my
$r
;
for
(
@$self
) {
my
$m
=
$_
->[0];
no
strict
"refs"
;
$r
=
$h
->
$m
( @{
$_
->[1]} );
}
return
$r
;
}