use
Carp
qw/carp croak cluck confess longmess/
;
our
$VERSION
= version->new(
'0.09'
);
has
xsd_ns
=> (
is
=>
'rw'
,
isa
=>
'Str'
,
);
has
xsd_ns_name
=> (
is
=>
'rw'
,
isa
=>
'Str'
,
predicate
=>
'has_xsd_ns_name'
,
clearer
=>
'clear_xsd_ns_name'
,
builder
=>
'_xsd_ns_name'
,
lazy_build
=> 1,
);
{
my
%required
;
my
$require
=
sub
{
my
(
$module
) =
@_
;
return
if
$required
{
$module
}++;
return
if
eval
{
$module
->can(
'new'
) };
my
$file
=
"$module.pm"
;
$file
=~ s{::}{/}gxms;
require
$file
;
};
around
BUILDARGS
=>
sub
{
my
(
$orig
,
$class
,
@args
) =
@_
;
my
$args
= !
@args
? {}
:
@args
== 1 ?
$args
[0]
: {
@args
};
if
( blessed
$args
&&
$args
->isa(
'XML::LibXML::Node'
) ) {
my
$xml
=
$args
;
my
$child
=
$xml
->firstChild;
my
$map
=
$class
->xml2perl_map;
my
(
$element
) =
$class
=~ /::([^:]+)$/xms;
$args
= {};
while
(
$child
) {
if
(
$child
->nodeName !~ /^[
my
(
$node_ns
,
$node
) = split_ns(
$child
->nodeName);
confess
"Could not get node from ("
.
$child
->nodeName.
" via '$node_ns', '$node')\n"
if
!
$map
->{
$node
};
my
$attrib
=
$map
->{
$node
};
$node
=
$attrib
->name;
my
$module
=
$attrib
->has_xs_perl_module ?
$attrib
->xs_perl_module :
undef
;
$require
->(
$module
)
if
$module
;
my
$value
=
$module
?
$module
->new(
$child
) :
$child
->textContent;
$args
->{
$node
}
= !
exists
$args
->{
$node
} ?
$value
:
ref
$args
->{
$node
} ne
'ARRAY'
? [
$args
->{
$node
} ,
$value
]
: [ @{
$args
->{
$node
}},
$value
];
}
$child
=
$child
->nextSibling;
}
}
return
$class
->
$orig
(
$args
);
};
}
my
%ns_map
;
my
$count
= 0;
sub
_xsd_ns_name {
my
(
$self
) =
@_
;
return
$self
->get_xsd_ns_name(
$self
->xsd_ns);
}
sub
get_xsd_ns_name {
my
(
$self
,
$ns
) =
@_
;
return
$ns_map
{
$ns
}
if
$ns_map
{
$ns
};
return
$ns_map
{
$ns
} =
'WSX'
.
$count
++;
}
sub
_from_xml {
my
(
$class
,
$type
) =
@_
;
my
$xml
=
$_
;
confess
"Unknown conversion "
. ( (
ref
$xml
) ||
$xml
)
if
!
$xml
|| !blessed
$xml
|| !
$xml
->isa(
'XML::LibXML::Node'
);
my
$ret
;
try
{
$ret
=
$type
->new(
$xml
);
}
catch
{
$_
=~ s/\s at \s .*//xms;
warn
"$class Failed in building from $type\->new($xml) : $_\n"
,
"Will use :\n\t'"
,
$xml
->toString,
"'\n\tor\n\t'"
,
$xml
->textContent,
"'\n"
,
'*'
x 222,
"\n"
;
$ret
=
$xml
->textContent;
};
return
$ret
;
}
sub
xml2perl_map {
my
(
$class
) =
@_
;
my
%map
;
for
my
$attr
(
$class
->get_xml_nodes) {
$map
{
$attr
->xs_name} =
$attr
;
}
my
$meta
=
$class
->meta;
for
my
$super
(
$meta
->superclasses ) {
next
if
!
$super
->can(
'xml2perl_map'
) &&
$super
ne __PACKAGE__;
%map
= ( %{
$super
->xml2perl_map },
%map
);
}
return
\
%map
;
}
sub
to_xml {
my
(
$self
,
$xml
) =
@_
;
confess
"No XML document passed to attach nodes to!"
if
!
$xml
;
my
$child
;
my
$meta
=
$self
->meta;
my
@attributes
=
$self
->get_xml_nodes;
my
@nodes
;
$self
->clear_xsd_ns_name;
my
$xsd_ns_name
=
$self
->xsd_ns ?
$self
->xsd_ns_name :
undef
;
for
my
$att
(
@attributes
) {
my
$name
=
$att
->name;
next
if
!
$att
->does(
'W3C::SOAP::XSD'
);
my
$has
=
"has_$name"
;
next
if
!
$self
->
$has
;
my
$xml_name
=
$att
->has_xs_name ?
$att
->xs_name :
$name
;
my
$xml_ns
=
$att
->has_xs_ns ?
$att
->xs_ns :
$self
->xsd_ns;
my
$xml_ns_name
= !
defined
$xml_ns
?
$xsd_ns_name
:
$xml_ns
?
$self
->get_xsd_ns_name(
$xml_ns
)
:
''
;
my
$value
=
ref
$self
->
$name
eq
'ARRAY'
?
$self
->
$name
: [
$self
->
$name
];
for
my
$item
(
@$value
) {
my
$tag
=
$xml
->createElement(
$xml_ns_name
?
$xml_ns_name
.
':'
.
$xml_name
:
$xml_name
);
$tag
->setAttribute(
"xmlns:$xml_ns_name"
=>
$xml_ns
)
if
$xml_ns
;
if
( blessed(
$item
) &&
$item
->can(
'to_xml'
) ) {
my
@children
=
$item
->to_xml(
$xml
);
$tag
->appendChild(
$_
)
for
@children
;
}
elsif
( !
defined
$item
&& !
$att
->has_xs_serialize ) {
$tag
->setAttribute(
'nil'
,
'true'
);
$tag
->setAttribute(
'null'
,
'true'
);
}
else
{
local
$_
=
$item
;
my
$text
=
$att
->has_xs_serialize
?
$att
->xs_serialize->(
$item
)
:
"$item"
;
$tag
->appendChild(
$xml
->createTextNode(
$text
) );
}
push
@nodes
,
$tag
;
}
}
return
@nodes
;
}
sub
to_data {
my
(
$self
,
%option
) =
@_
;
my
$child
;
my
$meta
=
$self
->meta;
my
@attributes
=
$self
->get_xml_nodes;
my
%nodes
;
for
my
$att
(
@attributes
) {
my
$name
=
$att
->name;
next
if
!
$att
->does(
'W3C::SOAP::XSD'
);
my
$has
=
"has_$name"
;
next
if
!
$self
->
$has
;
my
$key_name
=
$att
->has_xs_name &&
$option
{like_xml} ?
$att
->xs_name :
$name
;
my
$value
=
$self
->
$name
;
if
(
ref
$value
eq
'ARRAY'
) {
my
@elements
;
for
my
$element
(
@$value
) {
if
( blessed(
$element
) &&
$element
->can(
'to_data'
) ) {
push
@elements
,
$element
->to_data(
%option
);
}
}
$nodes
{
$key_name
} = \
@elements
;
}
else
{
if
( blessed(
$value
) &&
$value
->can(
'to_data'
) ) {
$value
=
$value
->to_data(
%option
);
}
elsif
( !
defined
$value
&& !
$att
->has_xs_serialize ) {
}
elsif
(
$option
{stringify}) {
local
$_
=
$value
;
my
$text
=
$att
->has_xs_serialize
?
$att
->xs_serialize->(
$value
)
:
"$value"
;
$value
=
defined
$value
?
$text
:
$value
;
}
$nodes
{
$key_name
} =
$value
;
}
}
return
\
%nodes
;
}
sub
get_xml_nodes {
my
(
$self
) =
@_
;
my
$meta
=
$self
->meta;
my
@parent_nodes
;
my
@supers
=
$meta
->superclasses;
for
my
$super
(
@supers
) {
push
@parent_nodes
,
$super
->get_xml_nodes
if
$super
ne __PACKAGE__ &&
eval
{
$super
->can(
'get_xml_nodes'
) };
}
return
@parent_nodes
,
map
{
$meta
->get_attribute(
$_
)
}
sort
{
$meta
->get_attribute(
$a
)->insertion_order <=>
$meta
->get_attribute(
$b
)->insertion_order
}
grep
{
$meta
->get_attribute(
$_
)->does(
'W3C::SOAP::XSD::Traits'
)
}
$meta
->get_attribute_list;
}
my
%types
;
sub
xsd_subtype {
my
(
$self
,
%args
) =
@_
;
my
$parent_type
=
$args
{module} ||
$args
{parent};
$parent_type
=
$parent_type
eq
'xs:date'
?
'xsd:date'
:
$parent_type
eq
'xs:dateTime'
?
'xsd:dateTime'
:
$parent_type
eq
'xs:boolean'
?
'xsd:boolean'
:
$parent_type
eq
'xs:double'
?
'xsd:double'
:
$parent_type
eq
'xs:decimal'
?
'xsd:decimal'
:
$parent_type
eq
'xs:long'
?
'xsd:long'
:
$parent_type
;
my
$parent_type_name
=
$args
{list} ?
"ArrayRef[$parent_type]"
:
$args
{nillable} ?
"Maybe[$parent_type]"
:
$parent_type
;
my
$subtype
=
$parent_type
=~ /^xsd:\w/xms && Moose::Util::TypeConstraints::find_type_constraint(
$parent_type
);
return
$subtype
if
$subtype
&& !
$args
{list};
$subtype
= subtype
as
$parent_type_name
,
message {
"'$_' failed to validate as a $parent_type"
};
if
(
$args
{list} ) {
if
(
$args
{module} ) {
coerce
$subtype
=>
from
'xml_node'
=>
via { [
$parent_type
->new(
$_
)] };
coerce
$subtype
=>
from
'HashRef'
=>
via { [
$parent_type
->new(
$_
)] };
coerce
$subtype
=>
from
'ArrayRef[HashRef]'
=>
via { [
map
{
$parent_type
->new(
$_
) }
@$_
] };
coerce
$subtype
=>
from
$parent_type
=>
via { [
$_
] };
}
else
{
coerce
$subtype
=>
from
'xml_node'
=>
via { [
$_
->textContent] };
coerce
$subtype
=>
from
'ArrayRef[xml_node]'
=>
via { [
map
{
$_
->textContent }
@$_
] };
}
}
elsif
(
$args
{module} ) {
coerce
$subtype
=>
from
'xml_node'
=>
via {
$parent_type
->new(
$_
) };
coerce
$subtype
=>
from
'HashRef'
=>
via {
$parent_type
->new(
$_
) };
}
else
{
coerce
$subtype
=>
from
'xml_node'
=>
via {
$_
->textContent };
}
my
$this_type
=
$subtype
->parent;
if
(
$this_type
->has_parent) {
coerce
$subtype
=> from
'Any'
=> via { !
defined
$_
&&
$args
{nillable} ?
undef
:
$this_type
->parent->coerce(
$_
) };
}
return
$subtype
;
}
1;