@EXPORT_OK
= (
qw(is_xml_ordered)
);
our
$VERSION
=
'0.0.6'
;
sub
new
{
my
$class
=
shift
;
my
$self
= {};
bless
$self
,
$class
;
$self
->_init(
@_
);
return
$self
;
}
sub
_got
{
return
shift
->{got_reader};
}
sub
_expected
{
return
shift
->{expected_reader};
}
sub
_init
{
my
(
$self
,
$args
) =
@_
;
$self
->{got_reader} =
XML::LibXML::Reader->new(@{
$args
->{got_params}});
$self
->{expected_reader} =
XML::LibXML::Reader->new(@{
$args
->{expected_params}});
$self
->{diag_message} =
$args
->{diag_message};
$self
->{got_end} = 0;
$self
->{expected_end} = 0;
return
;
}
sub
_got_end
{
return
shift
->{got_end};
}
sub
_expected_end
{
return
shift
->{expected_end};
}
sub
_read_got
{
my
$self
=
shift
;
if
(
$self
->_got->
read
() <= 0)
{
$self
->{got_end} = 1;
}
return
;
}
sub
_read_expected
{
my
$self
=
shift
;
if
(
$self
->_expected->
read
() <= 0)
{
$self
->{expected_end} = 1;
}
return
;
}
sub
_next_elem
{
my
$self
=
shift
;
$self
->_read_got();
$self
->_read_expected();
return
;
}
sub
_ns
{
my
$elem
=
shift
;
my
$ns
=
$elem
->namespaceURI();
return
defined
(
$ns
) ?
$ns
:
""
;
}
sub
_compare_loop
{
my
$self
=
shift
;
my
$calc_prob
=
sub
{
my
$args
=
shift
;
if
(!
exists
(
$args
->{param}))
{
die
"No 'param' specified."
;
}
return
{
verdict
=> 0,
param
=>
$args
->{param},
(
exists
(
$args
->{got})
? (
got
=>
$args
->{got},
expected
=>
$args
->{expected})
: ()
),
}
};
NODE_LOOP:
while
((!
$self
->_got_end()) && (!
$self
->_expected_end()))
{
my
$type
=
$self
->_got->nodeType();
my
$exp_type
=
$self
->_expected->nodeType();
if
(
$type
== XML_READER_TYPE_SIGNIFICANT_WHITESPACE())
{
$self
->_read_got();
redo
NODE_LOOP;
}
elsif
(
$exp_type
== XML_READER_TYPE_SIGNIFICANT_WHITESPACE())
{
$self
->_read_expected();
redo
NODE_LOOP;
}
elsif
(
$type
!=
$exp_type
)
{
return
$calc_prob
->({
param
=>
"nodeType"
});
}
elsif
(
$type
== XML_READER_TYPE_TEXT())
{
my
$got_text
=
$self
->_got->value();
my
$expected_text
=
$self
->_expected->value();
foreach
my
$t
(
$got_text
,
$expected_text
)
{
$t
=~ s{\A\s+}{}ms;
$t
=~ s{\s+\z}{}ms;
$t
=~ s{\s+}{ }gms;
}
if
(
$got_text
ne
$expected_text
)
{
return
$calc_prob
->(
{
param
=>
"text"
,
got
=>
$got_text
,
expected
=>
$expected_text
,
}
);
}
}
elsif
(
$type
== XML_READER_TYPE_ELEMENT())
{
my
$check
=
sub
{
if
(
$self
->_got->localName() ne
$self
->_expected->localName())
{
return
$calc_prob
->({
param
=>
"element_name"
});
}
if
(_ns(
$self
->_got) ne _ns(
$self
->_expected))
{
return
$calc_prob
->({
param
=>
"mismatch_ns"
});
}
my
$list_attrs
=
sub
{
my
(
$elem
) =
@_
;
my
@list
;
if
(
$elem
->moveToFirstAttribute())
{
my
$add
=
sub
{
my
$ns
= _ns(
$elem
);
{
push
@list
,
{
ns
=>
$ns
,
localName
=>
$elem
->localName() };
}
};
$add
->();
while
(
$elem
->moveToNextAttribute() > 0)
{
$add
->();
}
if
(
$elem
->moveToElement() <= 0)
{
die
"Cannot move back to element."
;
}
}
foreach
my
$attr
(
@list
)
{
$attr
->{value} =
$elem
->getAttributeNs(
$attr
->{localName},
$attr
->{ns},
) //
''
;
}
return
[
sort
{
(
$a
->{ns} cmp
$b
->{ns})
or
(
$a
->{localName} cmp
$b
->{localName})
}
@list
]
;
};
my
@got_attrs
= @{
$list_attrs
->(
$self
->_got())};
my
@exp_attrs
= @{
$list_attrs
->(
$self
->_expected())};
while
(
@got_attrs
and
@exp_attrs
)
{
my
$got_a
=
shift
(
@got_attrs
);
my
$exp_a
=
shift
(
@exp_attrs
);
if
(
$got_a
->{ns} ne
$exp_a
->{ns})
{
return
$calc_prob
->(
{
param
=>
"attr_ns"
,
got
=>
$got_a
->{ns},
expected
=>
$exp_a
->{ns},
}
);
}
if
(
$got_a
->{localName} ne
$exp_a
->{localName})
{
return
$calc_prob
->(
{
param
=>
"attr_localName"
,
got
=>
$got_a
->{localName},
expected
=>
$exp_a
->{localName},
}
);
}
if
(
$got_a
->{value} ne
$exp_a
->{value})
{
return
$calc_prob
->(
{
param
=>
"attr_value"
,
got
=>
$got_a
->{value},
expected
=>
$exp_a
->{value},
}
);
}
}
if
(
@got_attrs
)
{
return
$calc_prob
->(
{
param
=>
"extra_attr_got"
,
got
=>
$self
->_got,
expected
=>
$self
->_expected,
}
);
}
if
(
@exp_attrs
)
{
return
$calc_prob
->(
{
param
=>
"extra_attr_expected"
,
got
=>
$self
->_got,
expected
=>
$self
->_expected,
}
);
}
return
;
};
if
(
my
$ret
=
$check
->())
{
return
$ret
;
}
my
$is_got_empty
=
$self
->_got->isEmptyElement;
my
$is_expected_empty
=
$self
->_expected->isEmptyElement;
if
(
$is_got_empty
&& (!
$is_expected_empty
))
{
$self
->_read_expected();
if
(
my
$ret
=
$check
->())
{
return
$ret
;
}
}
elsif
(
$is_expected_empty
&& (!
$is_got_empty
))
{
$self
->_read_got();
if
(
my
$ret
=
$check
->())
{
return
$ret
;
}
}
}
}
continue
{
$self
->_next_elem();
}
return
{
verdict
=> 1};
}
sub
_get_diag_message
{
my
(
$self
,
$status_struct
) =
@_
;
if
(
$status_struct
->{param} eq
"nodeType"
)
{
return
"Different Node Type!\n"
.
"Got: "
.
$self
->_got->nodeType() .
" at line "
.
$self
->_got->lineNumber()
.
"\n"
.
"Expected: "
.
$self
->_expected->nodeType() .
" at line "
.
$self
->_expected->lineNumber()
;
}
elsif
(
$status_struct
->{param} eq
"text"
)
{
return
"Texts differ: Got <<$status_struct->{got}>> at "
.
$self
->_got->lineNumber().
" ; Expected <<$status_struct->{expected}>> at "
.
$self
->_expected->lineNumber();
}
elsif
(
$status_struct
->{param} eq
"element_name"
)
{
return
"Got name: "
.
$self
->_got->localName().
" at "
.
$self
->_got->lineNumber() .
" ; "
.
"Expected name: "
.
$self
->_expected->localName() .
" at "
.
$self
->_expected->lineNumber();
}
elsif
(
$status_struct
->{param} eq
"mismatch_ns"
)
{
return
"Got Namespace: "
. _ns(
$self
->_got).
" at "
.
$self
->_got->lineNumber() .
" ; "
.
"Expected Namespace: "
. _ns(
$self
->_expected) .
" at "
.
$self
->_expected->lineNumber();
}
elsif
(
$status_struct
->{param} eq
"extra_attr_got"
)
{
return
"Extra attribute for got at "
.
$self
->_got->lineNumber() .
" ; "
.
"Expected at "
.
$self
->_expected->lineNumber();
}
elsif
(
$status_struct
->{param} eq
"attr_localName"
)
{
return
"Got Attribute localName: <<$status_struct->{got}>> at "
.
$self
->_got->lineNumber() .
" ; "
.
"Expected Attribute localName: <<$status_struct->{expected}>> at "
.
$self
->_expected->lineNumber();
}
else
{
die
"Unknown param: $status_struct->{param}"
;
}
}
sub
compare
{
local
$Test::Builder::Level
=
$Test::Builder::Level
+1;
my
$self
=
shift
;
$self
->_next_elem();
my
$status_struct
=
$self
->_compare_loop();
my
$verdict
=
$status_struct
->{verdict};
if
(!
$verdict
)
{
diag(
$self
->_get_diag_message(
$status_struct
));
}
return
ok(
$verdict
,
$self
->{diag_message});
}
sub
is_xml_ordered
{
local
$Test::Builder::Level
=
$Test::Builder::Level
+1;
my
(
$got_params
,
$expected_params
,
$args
,
$message
) =
@_
;
my
$comparator
=
Test::XML::Ordered->new(
{
got_params
=>
$got_params
,
expected_params
=>
$expected_params
,
diag_message
=>
$message
,
}
);
return
$comparator
->compare();
}
1;