{
$PRANG::Graph::Choice::VERSION
=
'0.16'
;
}
use
5.010;
BEGIN {
class_type(
'Moose::Meta::TypeConstraint'
);
}
has
'choices'
=>
is
=>
"ro"
,
isa
=>
"ArrayRef[PRANG::Graph::Node]"
,
default
=>
sub
{ [] },
;
has
'attrName'
=>
is
=>
"ro"
,
isa
=>
"Str"
,
required
=> 1,
;
has
'type_map'
=>
is
=>
"ro"
,
isa
=>
"HashRef[Str|Moose::Meta::TypeConstraint]"
,
predicate
=>
"has_type_map"
,
;
has
'type_map_prefix'
=>
is
=>
"ro"
,
isa
=>
"HashRef[Str]"
,
predicate
=>
"has_type_map_prefix"
,
;
has
'xml_nodeName'
=>
is
=>
"ro"
,
isa
=>
"Str"
,
predicate
=>
"has_xml_nodeName"
,
;
has
'name_attr'
=>
is
=>
"ro"
,
isa
=>
"Str"
,
predicate
=>
"has_name_attr"
,
;
has
'xmlns_attr'
=>
is
=>
"ro"
,
isa
=>
"Str"
,
predicate
=>
"has_xmlns_attr"
,
;
has
'xmlns'
=>
is
=>
"ro"
,
isa
=>
"Str"
,
predicate
=>
"has_xmlns"
,
;
sub
node_ok {
my
$self
=
shift
;
my
(
$node
,
$ctx
) = pos_validated_list(
\
@_
,
{
isa
=>
'XML::LibXML::Node'
},
{
isa
=>
'PRANG::Graph::Context'
},
);
for
my
$choice
( @{
$self
->choices } ) {
if
(
defined
$choice
->node_ok(
$node
,
$ctx
) ) {
return
1;
}
}
return
;
}
sub
accept
{
my
$self
=
shift
;
my
(
$node
,
$ctx
,
$lax
) = pos_validated_list(
\
@_
,
{
isa
=>
'XML::LibXML::Node'
},
{
isa
=>
'PRANG::Graph::Context'
},
{
isa
=>
'Bool'
,
optional
=> 1 },
);
if
(
$ctx
->chosen) {
$ctx
->exception(
"Single child node expected, multiple found"
,
$node
,
);
}
my
$num
;
my
$name
=
$node
->isa(
"XML::LibXML::Text"
)
?
""
:
$node
->localname;
my
$xmlns
=
length
(
$name
) &&
$node
->namespaceURI;
my
(
$key
,
$val
,
$x
,
$ns
);
for
my
$choice
( @{
$self
->choices } ) {
$num
++;
if
(
defined
$choice
->node_ok(
$node
,
$ctx
) ) {
(
$key
,
$val
,
$x
,
$ns
) =
$choice
->
accept
(
$node
,
$ctx
,
$lax
);
}
if
(
$key
) {
$ctx
->chosen(
$num
);
return
(
$key
,
$val
,
$x
||
eval
{
$choice
->nodeName}||
""
,
$ns
);
}
}
return
();
}
sub
complete {
my
$self
=
shift
;
my
(
$ctx
) = pos_validated_list(
\
@_
,
{
isa
=>
'PRANG::Graph::Context'
},
);
$ctx
->chosen;
}
sub
expected {
my
$self
=
shift
;
my
(
$ctx
) = pos_validated_list(
\
@_
,
{
isa
=>
'PRANG::Graph::Context'
},
);
if
(
my
$num
=
$ctx
->chosen ) {
return
$self
->choices->[
$num
-1]->expected(
$ctx
);
}
else
{
my
@choices
;
for
my
$choice
( @{
$self
->choices} ) {
push
@choices
,
$choice
->expected(
$ctx
);
}
return
@choices
;
}
}
our
$REGISTRY
=
Moose::Util::TypeConstraints::get_type_constraint_registry();
sub
output {
my
$self
=
shift
;
my
(
$item
,
$node
,
$ctx
) = pos_validated_list(
[
@_
[0..2]],
{
isa
=>
'Object'
},
{
isa
=>
'XML::LibXML::Element'
},
{
isa
=>
'PRANG::Graph::Context'
},
MX_PARAMS_VALIDATE_CACHE_KEY
=>
'choice-output-positional'
,
);
my
(
$value
,
$slot
) = validated_list(
[
@_
[3..
$#_
]],
value
=> {
isa
=>
'Item'
,
optional
=> 1 },
slot
=> {
isa
=>
'Int'
,
optional
=> 1 },
MX_PARAMS_VALIDATE_CACHE_KEY
=>
'choice-output-named'
,
);
my
$an
=
$self
->attrName;
$value
//=
$item
->
$an
;
my
(
$name
,
$xmlns
);
if
(
$self
->has_name_attr ||
$self
->has_xmlns_attr ) {
if
(
$self
->has_name_attr ) {
my
$x
=
$self
->name_attr;
$name
=
$item
->
$x
;
if
(
defined
$slot
) {
$name
=
$name
->[
$slot
];
}
}
else
{
$name
=
$self
->xml_nodeName //
$an
;
}
if
(
$self
->has_xmlns_attr ) {
my
$attr_getter
=
$self
->xmlns_attr;
$xmlns
=
$item
->
$attr_getter
;
if
(
defined
$slot
) {
$xmlns
=
$xmlns
->[
$slot
];
}
}
else
{
$xmlns
=
$self
->xmlns //
""
;
}
}
elsif
(
$self
->has_type_map ) {
my
$map
=
$self
->type_map;
for
my
$element
(
keys
%$map
) {
my
$type
=
$map
->{
$element
};
if
( !
ref
$type
) {
$type
=
$map
->{
$element
} =
$REGISTRY
->get_type_constraint(
$type
);
}
if
(
$type
->check(
$value
) ) {
$name
=
$element
;
last
;
}
}
}
if
( !
defined
$name
) {
$ctx
->exception(
"don't know what to serialize $value to for slot "
.
$self
->attrName
);
}
if
(
length
$name
) {
if
(
$self
->has_type_map_prefix and
$name
=~ /(.*):(.*)/) {
$name
= $2;
$xmlns
=
$self
->type_map_prefix->{$1};
}
my
$found
;
for
my
$choice
( @{
$self
->choices } ) {
if
(
$xmlns
) {
next
unless
$choice
->has_xmlns;
next
unless
$choice
->xmlns eq
$xmlns
or
$choice
->xmlns eq
"*"
;
}
next
unless
$choice
->nodeName eq
$name
or
$choice
->nodeName eq
"*"
;
$found
++;
$choice
->output(
$item
,
$node
,
$ctx
,
value
=>
$value
,
(
defined
$slot
? (
slot
=>
$slot
) : ()),
name
=>
$name
,
(
defined
$xmlns
? (
xmlns
=>
$xmlns
) : ()),
);
last
;
}
if
( !
$found
) {
$ctx
->exception(
"don't know what to serialize $value to for slot "
.
$self
->attrName
.
" (looked for '$name' node"
.(
$xmlns
?
" xmlns='$xmlns'"
:
""
)
.
")"
,
);
}
}
else
{
my
$tn
=
$node
->ownerDocument->createTextNode(
$value
);
$node
->appendChild(
$tn
);
}
}
1;