$VERSION
=
'0.10'
;
use
Log::Report
'xml-compile-cache'
,
syntax
=>
'SHORT'
;
sub
init($)
{
my
(
$self
,
$args
) =
@_
;
$self
->SUPER::init(
$args
);
$self
->{XCC_opts} =
delete
$args
->{opts_rw} || [];
$self
->{XCC_ropts} =
delete
$args
->{opts_readers} || [];
$self
->{XCC_wopts} =
delete
$args
->{opts_writers} || [];
$self
->{XCC_undecl} =
delete
$args
->{allow_undeclared} || 0;
$self
->{XCC_rcode} = {};
$self
->{XCC_wcode} = {};
$self
->{XCC_dropts} = {};
$self
->{XCC_dwopts} = {};
$self
->{XCC_uropts} = {};
$self
->{XCC_uwopts} = {};
$self
->{XCC_readers} = {};
$self
->{XCC_writers} = {};
my
$prefixes
=
delete
$args
->{prefixes} || [];
if
(
ref
$prefixes
eq
'ARRAY'
)
{
$self
->{XCC_prefix} = {
@$prefixes
};
unshift
@{
$self
->{XCC_wopts}},
output_namespaces
=>
$prefixes
;
}
else
{
$self
->{XCC_prefix} =
$prefixes
;
unshift
@{
$self
->{XCC_wopts}},
output_namespaces
=> [
%$prefixes
];
}
$self
;
}
sub
prefixes(@)
{
my
$self
=
shift
;
while
(
@_
)
{
my
$k
=
shift
;
$self
->{XCC_prefix}{
$k
} =
shift
;
}
$self
->{XCC_prefix};
}
sub
allowUndeclared(;$)
{
my
$self
=
shift
;
@_
? (
$self
->{XCC_undecl} =
shift
) :
$self
->{XCC_undecl};
}
sub
declare($$@)
{
my
(
$self
,
$need
,
$names
,
@opts
) =
@_
;
my
$opts
=
@opts
==1 ?
shift
@opts
: \
@opts
;
$opts
= [
%$opts
]
if
ref
$opts
eq
'HASH'
;
my
(
$need_r
,
$need_w
) =
$self
->_need(
$need
);
foreach
my
$name
(
ref
$names
eq
'ARRAY'
?
@$names
:
$names
)
{
my
$type
=
$self
->findName(
$name
);
if
(
$need_r
)
{
defined
$self
->{XCC_dropts}{
$type
}
and warning __x
"reader {name} declared again"
,
name
=>
$name
;
$self
->{XCC_dropts}{
$type
} =
$opts
;
}
if
(
$need_w
)
{
defined
$self
->{XCC_dwopts}{
$type
}
and warning __x
"writer {name} declared again"
,
name
=>
$name
;
$self
->{XCC_dwopts}{
$type
} =
$opts
;
}
}
$self
;
}
sub
compileAll(;$$)
{
my
(
$self
,
$need
,
$usens
) =
@_
;
my
(
$need_r
,
$need_w
) =
$self
->_need(
$need
);
if
(
$need_r
)
{
while
(
my
(
$type
,
$opts
) =
each
%{
$self
->{XCC_dropts}})
{
if
(
defined
$usens
)
{
my
(
$myns
,
$local
) = unpack_type
$type
;
next
if
$usens
eq
$myns
;
}
$self
->{XCC_rcode}{
$type
} ||=
$self
->_createReader(
$type
,
@$opts
);
}
}
if
(
$need_w
)
{
while
(
my
(
$type
,
$opts
) =
each
%{
$self
->{XCC_dwopts}})
{
if
(
defined
$usens
)
{
my
(
$myns
,
$local
) = unpack_type
$type
;
next
if
$usens
eq
$myns
;
}
$self
->{XCC_wcode}{
$type
} ||=
$self
->_createWriter(
$type
,
@$opts
);
}
}
}
sub
findName($)
{
my
(
$self
,
$name
) =
@_
;
my
(
$type
,
$ns
,
$local
);
if
(
$name
=~ m/^\{/)
{ (
$type
,
$ns
,
$local
) = (
$name
, unpack_type
$name
);
}
elsif
(
$name
=~ m/^(\w+)\:(\S+)$/)
{ (
my
$prefix
,
$local
) = ($1, $2);
$ns
=
$self
->{XCC_prefix}{
$prefix
}
or error __x
"unknown protocol name prefix `{prefix}'"
,
prefix
=>
$prefix
;
$type
= pack_type
$ns
,
$local
;
}
else
{ error __x
"protocol name must show namespace or prefix"
;
}
$type
;
}
sub
printIndex(@)
{
my
$self
=
shift
;
my
$fh
=
@_
% 2 ?
shift
:
select
;
my
%args
=
@_
;
my
$decl
=
exists
$args
{show_declared} ?
delete
$args
{show_declared} : 1;
return
$self
->SUPER::printIndex(
$fh
,
%args
)
unless
$decl
;
my
$output
=
''
;
open
my
(
$out
),
'>'
, \
$output
;
$self
->SUPER::printIndex(
$out
,
%args
);
close
$out
;
my
@output
=
split
/(?<=\n)/,
$output
;
my
$ns
=
''
;
foreach
(
@output
)
{
$ns
= $1
if
m/^namespace\:\s+(\S+)/;
my
$local
= m/^\s+(\S+)\s*$/ ? $1 :
next
;
my
$type
= pack_type
$ns
,
$local
;
substr
(
$_
, 1, 1)
=
$self
->{XCC_readers}{
$type
} ?
'R'
:
$self
->{XCC_dropts}{
$type
} ?
'r'
:
' '
;
substr
(
$_
, 2, 1)
=
$self
->{XCC_writers}{
$type
} ?
'W'
:
$self
->{XCC_dwopts}{
$type
} ?
'w'
:
' '
;
}
print
$fh
@output
;
}
sub
reader($@)
{
my
(
$self
,
$name
) = (
shift
,
shift
);
my
$type
=
$self
->findName(
$name
);
my
$readers
=
$self
->{XCC_readers};
if
(
exists
$self
->{XCC_dropts}{
$type
})
{
warn
__x
"ignoring options to pre-declared reader {name}"
,
name
=>
$name
if
@_
;
return
$readers
->{
$type
}
if
$readers
->{
$type
};
}
elsif
(
$self
->{XCC_undecl})
{
if
(
my
$ur
=
$self
->{XCC_uropts}{
$type
})
{
my
$differs
=
@$ur
!=
@_
;
unless
(
$differs
)
{
for
(
my
$i
=0;
$i
<
@$ur
;
$i
++)
{
$differs
++
if
$ur
->[
$i
] ne
$_
[
$i
];
}
}
error __x
"undeclared reader {name} used with different options: before ({was}), now ({this})"
,
name
=>
$name
,
was
=>
$ur
,
this
=> \
@_
if
$differs
;
}
else
{
$self
->{XCC_uropts}{
$type
} = \
@_
;
}
}
elsif
(
exists
$self
->{XCC_dwopts}{
$type
})
{ error __x
"type {name} is only declared as writer"
,
name
=>
$name
;
}
else
{ error __x
"type {name} is not declared"
,
name
=>
$name
;
}
$readers
->{
$type
} ||=
$self
->_createReader(
$type
,
@_
);
}
sub
_createReader($@)
{
my
(
$self
,
$type
) = (
shift
,
shift
);
trace
"create reader for $type"
;
$self
->compile
(
READER
=>
$type
,
$self
->_merge_opts(
$self
->{XCC_opts},
$self
->{XCC_ropts}, \
@_
)
);
}
sub
writer($)
{
my
(
$self
,
$name
) = (
shift
,
shift
);
my
$type
=
$self
->findName(
$name
);
my
$writers
=
$self
->{XCC_writers};
if
(
exists
$self
->{XCC_dwopts}{
$type
})
{
warn
__x
"ignoring options to pre-declared writer {name}"
,
name
=>
$name
if
@_
;
return
$writers
->{
$type
}
if
$writers
->{
$type
};
}
elsif
(
$self
->{XCC_undecl})
{
if
(
my
$ur
=
$self
->{XCC_uwopts}{
$type
})
{
my
$differs
=
@$ur
!=
@_
;
unless
(
$differs
)
{
for
(
my
$i
=0;
$i
<
@$ur
;
$i
++)
{
$differs
++
if
$ur
->[
$i
] ne
$_
[
$i
];
}
}
error __x
"undeclared writer {name} used with different options: before ({was}), now ({this})"
,
name
=>
$name
,
was
=>
$ur
,
this
=> \
@_
if
$differs
;
}
else
{
$self
->{XCC_uwopts}{
$type
} = \
@_
;
}
}
elsif
(
exists
$self
->{XCC_dropts}{
$type
})
{ error __x
"type {name} is only declared as reader"
,
name
=>
$name
;
}
else
{ error __x
"type {name} is not declared"
,
name
=>
$name
;
}
$writers
->{
$type
} ||=
$self
->_createWriter(
$type
,
@_
);
}
sub
_createWriter($)
{
my
(
$self
,
$type
) =
@_
;
trace
"create writer for $type"
;
$self
->compile
(
WRITER
=>
$type
,
$self
->_merge_opts(
$self
->{XCC_opts},
$self
->{XCC_wopts}, \
@_
)
);
}
sub
_merge_opts(@)
{
my
$self
=
shift
;
map
{ !
defined
$_
? () :
ref
$_
eq
'ARRAY'
?
@$_
:
%$_
}
@_
;
}
sub
_need($)
{
$_
[1] eq
'READER'
? (1,0)
:
$_
[1] eq
'WRITER'
? (0,1)
:
$_
[1] eq
'RW'
? (1,1)
: error __x
"use READER, WRITER or RW, not {dir}"
,
dir
=>
$_
[1];
}
1;