use
version;
our
$VERSION
= qv(
sprintf
'0.7.%d'
,
q$Rev: 321 $
=~ /\d+/gmx );
has
'+extn'
=>
default
=>
q(.xml)
;
has
'root_name'
=>
is
=>
'ro'
,
isa
=>
'Str'
,
default
=>
'config'
;
has
'_arrays'
=>
is
=>
'rw'
,
isa
=>
'F_DC_HashRefOfBools'
,
coerce
=> TRUE,
init_arg
=>
'force_array'
,
default
=>
sub
{
return
{} };
has
'_dtd'
=>
is
=>
'rw'
,
isa
=>
'ArrayRef'
,
init_arg
=>
'dtd'
,
default
=>
sub
{
return
[] };
around
'_meta_pack'
=>
sub
{
my
(
$orig
,
$self
,
$args
) =
@_
;
my
$packed
=
$self
->
$orig
(
$args
);
$self
->_dtd and
$packed
->{_dtd} =
$self
->_dtd;
return
$packed
;
};
around
'_meta_unpack'
=>
sub
{
my
(
$orig
,
$self
,
$packed
) =
@_
;
$packed
||= {};
$self
->_dtd(
exists
$packed
->{_dtd} ?
delete
$packed
->{_dtd} : [] );
return
$self
->
$orig
(
$packed
);
};
sub
_create_or_update {
my
(
$self
,
$path
,
$element_obj
,
$overwrite
,
$condition
) =
@_
;
my
$element
=
$element_obj
->_resultset->source->name;
$self
->validate_params(
$path
,
$element
);
if
(
$self
->_is_array (
$element
)
and not
$self
->_is_in_dtd(
$element
)) {
push
@{
$self
->_dtd },
'<!ELEMENT '
.
$element
.
' (ARRAY)*>'
;
}
return
$self
->
next
::method(
$path
,
$element_obj
,
$overwrite
,
$condition
);
}
sub
_dtd_parse {
my
(
$self
,
$data
) =
@_
;
defined
$self
->_dtd->[ 0 ] and
$self
->_dtd_parse_reset;
$data
or
return
;
while
(
$data
=~ s{ ( <! [^<>]+ > ) }{}msx) {
$1 and
push
@{
$self
->_dtd }, $1;
}
my
$dtd
= XML::DTD->new;
$dtd
->sread(
join
NUL, @{
$self
->_dtd } );
for
my
$el
(
map
{
$dtd
->element(
$_
) } @{
$dtd
->elementnames }) {
$el
->{CMPNTTYPE} eq
q(element)
and
$el
->{CONTENTSPEC}->{eltname} eq ARRAY
and
$self
->_arrays->{
$el
->{NAME} } = TRUE;
}
return
$data
;
}
sub
_dtd_parse_reset {
my
$self
=
shift
;
$self
->_arrays( {} );
$self
->_dtd( [] );
return
;
}
sub
_is_array {
my
(
$self
,
$element
) =
@_
;
return
FALSE;
}
sub
_is_in_dtd {
my
(
$self
,
$candidate
) =
@_
;
my
%elements
;
my
$pattern
=
'<!ELEMENT \s+ (\w+) \s+ \( \s* ARRAY \s* \) \*? \s* >'
;
for
(
grep
{ m{ \A
$pattern
\z }msx } @{
$self
->_dtd } ) {
$elements
{
$_
} = TRUE;
}
return
exists
$elements
{
$candidate
};
}
__PACKAGE__->meta->make_immutable;
no
Moose;
1;