{
use
5.008;
no
warnings
qw(recursion)
;
BEGIN {
our
$VERSION
=
'2.05'
;
}
my
(
%handlers
,
%src
,
%handler_cache
,
@handler_cache
,
);
our
$CACHE_HANDLERS
=1;
our
$MAX_SCHEMA_CACHE_SIZE
=50;
our
$VALIDATE_CDATA
=0;
our
$SAVE_REFFILES
= 1;
our
$WITH_TREES
= 1;
our
$KEEP_KNIT
= 0;
our
$WRITE_SINGLE_LM
= 0;
our
$WRITE_SINGLE_CHILDREN_LM
= 0;
our
$INDENT
= 2;
sub
_get_handlers_cache_key {
my
(
$schema
)=
@_
;
my
$key
=
"$schema"
;
$key
=~s/.*=//;
return
[
$key
,
join
','
,
$key
,
$INDENT
|| 0,
$VALIDATE_CDATA
|| 0,
$SAVE_REFFILES
|| 0,
$WITH_TREES
|| 0,
$WRITE_SINGLE_LM
|| 0,
$KEEP_KNIT
|| 0,
$WRITE_SINGLE_CHILDREN_LM
|| 0,
];
}
sub
get_cached_handlers {
my
(
$key
)=
@_
;
my
$subkey
=
$key
->[1];
my
$cached
=
$handler_cache
{
$key
->[0] }{
$subkey
};
if
(
$cached
and
$handler_cache
[-1][1] ne
$subkey
) {
@handler_cache
= ((
grep
{
$_
->[1] ne
$subkey
}
@handler_cache
),
$key
);
}
return
$cached
;
}
sub
cache_handlers {
my
(
$key
,
$handlers
)=
@_
;
my
$subkey
=
$key
->[1];
push
@handler_cache
,
$key
;
$handler_cache
{
$key
->[0]}{
$subkey
} =
$handlers
;
if
(
@handler_cache
>
$MAX_SCHEMA_CACHE_SIZE
) {
my
$del
=
shift
@handler_cache
;
delete
$handler_cache
{
$del
->[0] }{
$del
->[1] };
}
}
sub
forget_schema {
my
(
$schema
)=
@_
;
delete
$handler_cache
{
$schema
};
@handler_cache
=
grep
{
$_
->[0] ne
$schema
}
@handler_cache
;
}
sub
_indent {
if
(
$INDENT
>=0) {
return
q{"\n".('}
.('
' x $INDENT).q{'
x
$indent_level
).}
}
else
{
return
q()
}
}
sub
_indent_inc {
if
(
$INDENT
>0) {
return
q`
$indent_level++;`
;
}
else
{
return
q()
}
}
sub
_indent_dec {
if
(
$INDENT
>0) {
return
q`
$indent_level--;`
;
}
else
{
return
q()
}
}
sub
save {
my
(
$ctxt
,
$opts
)=
@_
;
my
$fh
=
$opts
->{fh};
local
$VALIDATE_CDATA
=
$opts
->{validate_cdata}
if
exists
$opts
->{validate_cdata};
$ctxt
->set_filename(
$opts
->{filename})
if
$opts
->{filename};
my
$href
=
$ctxt
->{
'_filename'
};
$fh
=\
*STDOUT
if
(
$href
eq
'-'
and !
$fh
);
my
$config
=
$opts
->{config};
if
(
$config
and
ref
(
my
$load_opts
=
$config
->get_data(
'options/save'
))) {
$opts
= {
%$load_opts
,
%$opts
};
}
local
$KEEP_KNIT
= 1
if
$opts
->{keep_knit};
local
$WRITE_SINGLE_LM
= 1
if
$opts
->{write_single_LM};
local
$WRITE_SINGLE_CHILDREN_LM
= 1
if
$opts
->{write_single_children_LM};
local
$INDENT
=
$opts
->{indent}
if
defined
$opts
->{indent};
unless
(
$fh
) {
if
(
defined
(
$href
) and
length
(
$href
)) {
eval
{
rename_uri(
$href
,
$href
.
"~"
)
unless
$href
=~/^ntred:/;
};
my
$ok
= 0;
my
$res
;
eval
{
$fh
= open_backend(
$href
,
'w'
)
||
die
"Cannot open $href for writing: $!"
;
if
(
$fh
) {
binmode
$fh
;
$res
=
$ctxt
->save({
%$opts
,
fh
=>
$fh
});
close_backend(
$fh
);
$ok
= 1;
}
};
unless
(
$ok
) {
my
$err
= $@;
eval
{
rename_uri(
$href
.
"~"
,
$href
)
unless
$href
=~/^ntred:/;
};
die
(
$err
.
"$@\n"
)
if
$err
;
}
return
$res
;
}
else
{
die
(
"Usage: $ctxt->save({filename=>...,[fh => ...]})"
);
}
}
$ctxt
->{
'_refs_save'
} ||=
$opts
->{
'refs_save'
};
binmode
$fh
if
$fh
;
my
$transform_id
=
$ctxt
->{
'_transform_id'
};
my
(
$out_xsl_href
,
$out_xsl
,
$orig_fh
);
my
$xsl_source
=
''
;
if
(
$config
and
defined
$transform_id
and
length
$transform_id
) {
my
$transform
=
$config
->lookup_id(
$transform_id
);
if
(
$transform
) {
(
$out_xsl
) =
$transform
->{
'out'
};
if
(
$out_xsl
->{
'type'
} ne
'xslt'
) {
die
(__PACKAGE__.
": unsupported output transformation $transform_id (only type='xslt') transformations are supported)"
);
}
$out_xsl_href
= URI->new(Encode::encode_utf8(
$out_xsl
->get_member(
'href'
)));
$out_xsl_href
= Treex::PML::ResolvePath(
$config
->{_filename},
$out_xsl_href
, 1);
unless
(
defined
$out_xsl_href
and
length
$out_xsl_href
) {
die
(__PACKAGE__.
": no output transformation defined for $transform_id"
);
}
$orig_fh
=
$fh
;
open
(
my
$pml_fh
,
'>'
, \
$xsl_source
) or
die
"Cannot open scalar for writing!"
;
$fh
=
$pml_fh
;
}
else
{
die
(__PACKAGE__.
": Couldn't find PML transform with ID $transform_id"
);
}
}
my
$refs_to_save
=
$ctxt
->{
'_refs_save'
};
my
@refs_to_save
=
grep
{ (
$_
->{readas}||
''
) eq
'dom'
or (
$_
->{readas}||
''
) eq
'pml'
}
$ctxt
->get_reffiles();
if
(
ref
(
$refs_to_save
)) {
@refs_to_save
=
grep
{
exists
$refs_to_save
->{
$_
->{id}} }
@refs_to_save
;
for
(
@refs_to_save
) {
unless
(
defined
$refs_to_save
->{
$_
->{id}}) {
$refs_to_save
->{
$_
->{id}}=
$_
->{href};
}
}
}
else
{
$refs_to_save
= {};
}
my
$references
=
$ctxt
->{
'_references'
};
$ctxt
->{
'_parser'
} ||=
$ctxt
->_xml_parser();
foreach
my
$ref
(
@refs_to_save
) {
if
(
$ref
->{readas} eq
'dom'
) {
$ctxt
->readas_dom(
$ref
->{id},
$ref
->{href});
}
}
binmode
$fh
,
":utf8"
if
$fh
;
local
$WITH_TREES
=
$ctxt
->{
'_no_read_trees'
} ? 0 : 1;
prepare_handlers(
$ctxt
);
dump_handlers(
$ctxt
)
if
$opts
->{dump_handlers} or
$ENV
{PML_COMPILE_DUMP};;
$handlers
{
'#initialize'
}->(
$ctxt
,
$refs_to_save
,
$fh
);
eval
{
$handlers
{
'#root'
}->(
$ctxt
->{_root});
if
(
$ctxt
->{
'_pi'
}) {
my
(
$n
,
$v
);
for
my
$pi
(@{
$ctxt
->{
'_pi'
}}) {
print
$fh
qq(<?@$pi?>\n)
;
}
}
};
(
$handlers
{
'#cleanup'
}||
sub
{})->();
%handlers
=();
$fh
=
$orig_fh
if
defined
$orig_fh
;
die
$@
if
$@;
if
(
$xsl_source
and
$out_xsl_href
) {
my
$xslt
= XML::LibXSLT->new;
my
$params
=
$out_xsl
->content;
my
%params
;
%params
=
map
{
$_
->{
'name'
} =>
$_
->value }
$params
->
values
if
$params
;
my
$out_xsl_parsed
=
$xslt
->parse_stylesheet_file(
$out_xsl_href
);
my
$dom
= XML::LibXML->new()->parse_string(
$xsl_source
);
my
$result
=
$out_xsl_parsed
->transform(
$dom
,
%params
);
if
(UNIVERSAL::can(
$result
,
'toFH'
)) {
$result
->toFH(
$fh
,1);
}
else
{
$out_xsl_parsed
->output_fh(
$result
,
$fh
);
}
return
1;
}
if
(
ref
(
$ctxt
->{
'_ref'
})) {
foreach
my
$ref
(
@refs_to_save
) {
if
(
$ref
->{readas} eq
'dom'
) {
my
$dom
=
$ctxt
->{
'_ref'
}->{
$ref
->{id}};
my
$href
;
if
(
defined
(
$refs_to_save
->{
$ref
->{id}})) {
$href
=
$refs_to_save
->{
$ref
->{id}};
}
else
{
$href
=
$ref
->{href}
}
if
(
ref
(
$dom
)) {
eval
{
rename_uri(
$href
,
$href
.
"~"
)
unless
$href
=~/^ntred:/;
};
my
$ok
= 0;
eval
{
my
$ref_fh
= open_backend(
$href
,
"w"
);
if
(
$ref_fh
) {
binmode
$ref_fh
;
$dom
->toFH(
$ref_fh
,1);
close_backend(
$ref_fh
);
$ok
= 1;
}
};
unless
(
$ok
) {
my
$err
= $@;
eval
{
rename_uri(
$href
.
"~"
,
$href
)
unless
$href
=~/^ntred:/;
};
_die(
$err
.
"$@"
)
if
$err
;
}
}
}
elsif
(
$ref
->{readas} eq
'pml'
) {
my
$ref_id
=
$ref
->{id};
my
$pml
=
$ctxt
->{
'_ref'
}->{
$ref_id
};
if
(
$pml
) {
my
$href
;
if
(
exists
(
$refs_to_save
->{
$ref_id
})) {
$href
=
$refs_to_save
->{
$ref_id
};
}
else
{
$href
=
$ref
->{href}
}
$pml
->save({
%$opts
,
refs_save
=>{
map
{
my
$k
=
$_
;
$k
=~s%^\Q
$ref_id
\E/%% ? (
$k
=>
$refs_to_save
->{
$_
}) : () }
keys
%$refs_to_save
},
filename
=>
$href
,
fh
=>
undef
});
}
}
}
}
return
$ctxt
;
}
sub
prepare_handlers {
my
(
$ctxt
)=
@_
;
%handlers
=();
my
$schema
=
$ctxt
->{
'_schema'
};
my
$key
=_get_handlers_cache_key(
$schema
);
my
$cached
= get_cached_handlers(
$key
);
if
(
$cached
) {
%handlers
=
@$cached
;
}
else
{
compile_schema(
$schema
);
cache_handlers(
$key
,[
%handlers
])
if
$CACHE_HANDLERS
;
}
}
sub
dump_handlers {
my
$dir
=
'.pml_compile.d'
;
(-d
$dir
) ||
mkdir
(
$dir
) ||
die
"Can't dump to $dir: $!\n"
;
for
my
$f
(
keys
%src
) {
my
$dump_file
= File::Spec->catfile(
$dir
,
$f
);
open
(
my
$fh
,
'>:utf8'
,
$dump_file
)
||
die
"Can't write to $dump_file: $!\n"
;
my
$sub
=
$src
{
$f
};
$sub
=~s/^\s*
print
$fh
(
$sub
);
close
$fh
;
}
}
sub
_write_seq {
my
(
$decl
,
$path
,
$seq
)=
@_
;
my
$sub
=
''
;
local
$INDENT
=-1
if
$decl
->is_mixed;
$sub
.=
q`
for my $el (`
.
$seq
.
q`->elements) {
($k,$v)=@$el;
if (defined $v and (ref $v or length $v)) {
$handlers{ '`
.
$path
.'/
'.q`'
.
$k
}->(
$k
,
$v
);
}
else
{
print
$out
`._indent().
q`"<$k/>";
}
}`
;
return
$sub
;
}
sub
_write_trees_seq {
my
(
$decl
)=
@_
;
my
$path
=
$decl
->get_decl_path;
$path
=~ s/^!//
if
$path
;
return
q`
my $prolog = $ctxt->{'_pml_prolog'};
if ($prolog) {`
._write_seq(
$decl
,
$path
,
'$prolog'
).
q`
}
for $v (@{$ctxt->{'_trees'}}) {
if (ref $v) {
$k=$v->{'#name'};
$handlers{ '`
.
$path
.'/
'.q`'
.
$k
}->(
$k
,
$v
);
}
}
my
$epilog
=
$ctxt
->{
'_pml_epilog'
};
if
(
$epilog
) {`._write_seq(
$decl
,
$path
,
'$epilog'
).
q`
}`
;
}
sub
_write_trees_list {
my
(
$decl
)=
@_
;
my
$path
=
$decl
->get_content_decl->get_decl_path;
$path
=~ s/^!//
if
$path
;
return
q`
for $v (@{$ctxt->{'_trees'}}) {
$handlers{ '`
.
$path
.
q`' }->('LM',$v);
}`
;
}
sub
_write_children_seq {
my
(
$tag
,
$decl
)=
@_
;
my
$path
=
$decl
->get_decl_path;
$path
=~ s/^!//
if
$path
;
my
$sub
=
q`
if ($v = $data->firstson) {`
;
$sub
.=
q`
print $out `
._indent().
q`"<`
.
$tag
.
q`>";`
if
defined
$tag
;
$sub
.= _indent_inc().
q`
my $name;
while ($v) {
$name = $v->{'#name'};
$handlers{ '`
.
$path
.'/
'.q`'
.
$name
}->(
$name
,
$v
);
$v
=
$v
->rbrother;
}`._indent_dec();
$sub
.=
q`
print $out `
._indent().
q`"</`
.
$tag
.
q`>";`
if
defined
$tag
;
$sub
.=
q`
}`
;
return
$sub
;
}
sub
_write_children_list {
my
(
$tag
,
$decl
)=
@_
;
$decl
=
$decl
->get_content_decl;
my
$path
=
$decl
->get_decl_path;
$path
=~ s/^!//
if
$path
;
my
$sub
=
q`
if ($v = $data->firstson) {`
;
if
(
defined
$tag
) {
if
(!
$WRITE_SINGLE_LM
and !
$WRITE_SINGLE_CHILDREN_LM
) {
$sub
.=
q`
if ($v && !$v->rbrother && keys(%$v)) {
$handlers{ '`
.
$path
.
q`' }->('`
.
$tag
.
q`',$v);
} else {`
;
}
$sub
.=
q`
print $out `
._indent().
q`"<`
.
$tag
.
q`>";`
;
}
$sub
.=_indent_inc().
q`
while ($v) {
$handlers{ '`
.
$path
.
q`' }->('LM',$v);
$v = $v->rbrother;
}`
._indent_dec();
if
(
defined
$tag
) {
$sub
.=
q`
print $out `
._indent().
q`"</`
.
$tag
.
q`>";`
;
$sub
.=
q`
}`
if
!
$WRITE_SINGLE_LM
and !
$WRITE_SINGLE_CHILDREN_LM
;
}
$sub
.=
q`
}`
;
return
$sub
;
}
sub
_knit_code {
my
(
$knit_decl
,
$knit_decl_path
,
$name
)=
@_
;
my
$idM
= Treex::PML::Instance::Reader::_fix_id_member(
$knit_decl
);
if
(
$idM
) {
my
$idM_name
=
$idM
->get_name;
return
q`
my $knit_id = $v->{'`
.
$idM_name
.
q`'};
my $prefix;
unless (defined $knit_id) {
warn "Cannot KNIT back: `
.
$idM_name
.
q` not defined on object `
.
$knit_decl_path
.
q`!";
} elsif ($knit_id =~ s/^(.*?)#//) {
$prefix=$1;
} else {
$prefix = $v->{'#knit_prefix'};
}
print $out `
._indent().
q`'<`
.
$name
.
q`>'.($prefix ? $prefix.'#'.$knit_id : $knit_id).'</`
.
$name
.
q`>';
if ($prefix and !UNIVERSAL::DOES::does($ctxt->{'_ref'}{$prefix},'Treex::PML::Instance')) {
# DOM KNIT
my $rf_href = $refs_to_save->{$prefix};
if ( $rf_href ) {
my $indeces = $ctxt->{'_ref-index'};
if ($indeces and $indeces->{$prefix}) {
my $knit = $indeces->{$prefix}{$knit_id};
if ($knit) {
my $save_out = $out;
my $xml='';
open my $new_out, '>:utf8', \$xml; # perl 5.8.0
$out = $new_out;
local $INDENT=-1;
$handlers{'`
.
$knit_decl_path
.
q`' }->($knit->nodeName,$v);
close $new_out;
$out = $save_out;
$xml='<x xmlns="`
.PML_NS.
q`">'.$xml.'</x>';
my $new = $ctxt->{'_parser'}->parse_string($xml)->documentElement->firstChild;
$new->setAttribute('`
.
$idM_name
.
q`',$knit_id);
$knit->ownerDocument->adoptNode( $new );
$knit->parentNode->insertAfter($new,$knit);
$knit->unbindNode;
$indeces->{$prefix}{$knit_id}=$new;
} else {
_warn("Didn't find ID '$knit_id' in '$rf_href' ('$prefix') - cannot knit back!\n");
}
} else {
_warn("Knit-file '$rf_href' ('$prefix') has no index - cannot knit back!\n");
}
}
}`
;
}
else
{
warn
(
"Cannot KNIT "
.
$knit_decl_path
.
" if there is no member/attribute with role='#ID'!"
);
}
}
sub
compile_schema {
my
(
$schema
)=
@_
;
my
(
$ctxt
,
$refs_to_save
,
$out
,
$pml_trees_type
,
$have_trees
,
$indent_level
);
my
$schema_name
=
$schema
->get_root_decl->get_name;
$handlers
{
'#cleanup'
}=
sub
{
undef
$_
for
(
$ctxt
,
$refs_to_save
,
$out
);
};
$handlers
{
'#initialize'
}=
sub
{
my
(
$instance
,
$refs_save
,
$fh
)=
@_
;
$ctxt
=
$instance
;
$refs_to_save
=
$refs_save
;
$out
=
$fh
;
$have_trees
= 0;
$pml_trees_type
=
$ctxt
->{
'_pml_trees_type'
};
$indent_level
=0;
};
$schema
->for_each_decl(
sub
{
my
(
$decl
)=
@_
;
my
$decl_type
=
$decl
->get_decl_type;
my
$path
=
$decl
->get_decl_path;
$path
=~ s/^!//
if
$path
;
return
if
$decl_type
== PML_ATTRIBUTE_DECL ||
$decl_type
== PML_MEMBER_DECL ||
$decl_type
== PML_TYPE_DECL ||
$decl_type
== PML_ELEMENT_DECL;
if
(
$decl_type
== PML_ROOT_DECL) {
my
$name
=
$decl
->get_name;
my
$cdecl
=
$decl
->get_content_decl;
my
$cdecl_type
=
$cdecl
->get_decl_type;
my
$cpath
=
$cdecl
->get_decl_path;
$cpath
=~ s/^!//;
my
$src
=
$schema_name
.
'__generated_write_root'
;
my
$sub
=
q`#line 1 ".pml_compile.d/`
.
$src
.
q`"
sub {
my ($data)=@_;
my $v;
print $out '<?xml version="1.0" encoding="UTF-8"?>'."\n";
print $out '<`
.
$decl
->get_name.
q` xmlns="`
.PML_NS.
q`"';`
;
if
(
$cdecl_type
== PML_CONSTANT_DECL ||
$cdecl_type
== PML_STRUCTURE_DECL) {
for
my
$attr
(
$cdecl
->get_attributes) {
if
(
$attr
->is_required) {
$sub
.=
q`
$v = $data->{'`
.
$attr
->get_name.
q`'};
$v = '' unless defined $v;
$v =~ s/&/&/g; $v=~s/</</g; $v=~s/"/"/g;
print $out ' `
.
$attr
->get_name.
q`="'.$v.'"';
`
;
}
else
{
$sub
.=
q`
$v = $data->{'`
.
$attr
->get_name.
q`'};
if (defined($v) && length($v)) {
$v=~s/&/&/g; $v=~s/</</g; $v=~s/"/"/g;
print $out ' `
.
$attr
->get_name.
q`="'.$v.'"';
}
`
;
}
}
}
my
$no_end_indent
=
(
$cdecl_type
== PML_SEQUENCE_DECL and
$cdecl
->is_mixed);
my
$psub
=
q`
print $out ">\n",
"_^_<head>\n";
my $inline = $ctxt->{'_schema-inline'};
if (defined $inline and length $inline) {
print $out qq(_^__^_<schema>\n),$inline,qq( </schema>\n);
} else {
$v = $ctxt->{'_schema-url'};
if (defined $v and length $v) {
$v=Treex::PML::IO::make_relative_URI($ctxt->{'_schema-url'},$ctxt->{'_filename'});
$v=~s/&/&/g; $v=~s/</</g; $v=~s/"/"/g;
print $out qq(_^__^_<schema href="$v" />\n);
} else {
print $out qq(_^__^_<schema>\n);
$ctxt->{'_schema'}->write({fh=>$out});
print $out qq(_^__^_</schema>\n);
}
}
my $references = $ctxt->{'_references'};
if (ref($references) and keys(%$references)) {
my $named = $ctxt->{'_refnames'};
my %names = $named ? (map {
my $name = $_;
map { $_ => $name } (ref($named->{$_}) ? @{$named->{$_}} : $named->{$_})
} keys %$named) : ();
print $out qq(_^__^_<references>\n);
foreach my $id (sort keys %$references) {
my $href;
if (exists($refs_to_save->{$id})) {
# effectively rename the file reference
$href = $references->{$id} = $refs_to_save->{$id}
} else {
$href = $references->{$id};
}
$href=Treex::PML::IO::make_relative_URI($href,$ctxt->{_filename});
my $name = $names{$id};
for ($id,$href, (defined $name ? $name : ())) { s/&/&/g; s/</</g; s/"/"/g; }
print $out qq(_^__^__^_<reffile id="${id}").(defined $name ? qq( name="${name}") : ()).qq( href="${href}" />\n);
}
print $out qq(_^__^_</references>\n);
}
print $out "_^_</head>";
$handlers{ '`
.
$cpath
.
q`' }->(undef,$data);
print $out `
.(
$no_end_indent
?
''
: _indent()).
q`'</`
.
$decl
->get_name.
q`>'."\n";
}`
;
my
$indent
=
$INDENT
>0 ?
' '
x
$INDENT
:
''
;
$psub
=~s/_\^_/
$indent
/g;
$sub
.=
$psub
;
$src
{
$src
}=
$sub
;
$handlers
{
'#root'
}=
eval
$sub
;
die
_nl(
$sub
).
"\n"
.$@.
' '
if
$@;
}
elsif
(
$decl_type
== PML_STRUCTURE_DECL) {
my
$src
=
$schema_name
.
'__generated_write_structure@'
.
$path
;
$src
=~y{/}{@};
my
$sub
=
q`#line 1 ".pml_compile.d/`
.
$src
.
q`"
sub {
my ($tag,$data)=@_;
my ($v,$k);
unless (defined $data) {
print $out defined $tag ? '/>' : '>' if !$tag;
return;
}
my $close;
if (defined $tag) {
$close = '/>';
print $out `
._indent().
q`'<'.$tag if length $tag;`
;
for
my
$attr
(
$decl
->get_attributes) {
my
$name
=
$attr
->get_name;
if
(
$attr
->is_required) {
$sub
.=
q`
$v = $data->{'`
.
$name
.
q`'};
$v='' unless defined $v;
$v=~s/&/&/g; $v=~s/</</g; $v=~s/"/"/g;
print $out ' `
.
$name
.
q`'.'="'.$v.'"';
`
;
}
else
{
$sub
.=
q`
$v = $data->{'`
.
$name
.
q`'};
if (defined($v) && length($v)) {
$v=~s/&/&/g; $v=~s/</</g; $v=~s/"/"/g;
print $out ' `
.
$name
.
q`'.'="'.$v.'"';
}
`
;
}
}
$sub
.=
q`
}`
._indent_inc();
my
$this_trees_type
;
for
my
$m
(
$decl
->get_members) {
next
if
$m
->is_attribute;
my
$name
=
$m
->get_name;
my
$mdecl
=
$m
->get_content_decl;
my
$mdecl_type
=
$mdecl
->get_decl_type;
$sub
.=
q`
$v = $data->{'`
.
$name
.
q`'};`
;
my
$close_brace
=0;
my
$ignore_required
=0;
if
(
$WITH_TREES
and
$decl
->get_role eq
'#NODE'
and
$m
->get_role eq
'#CHILDNODES'
) {
$close_brace
=1;
$sub
.=
q`
if (UNIVERSAL::DOES::does($data,'Treex::PML::Node')) {
if (defined $close) { undef $close; print $out '>'; }`
;
if
(
$mdecl_type
== PML_SEQUENCE_DECL) {
$sub
.= _write_children_seq(
$name
,
$mdecl
);
}
elsif
(
$mdecl_type
== PML_LIST_DECL) {
$sub
.= _write_children_list(
$name
,
$mdecl
);
}
$sub
.=
q`
} else { `
;
}
elsif
(
$WITH_TREES
and (
$m
->get_role eq
'#TREES'
or
$mdecl
->get_role eq
'#TREES'
)) {
$close_brace
=1;
$this_trees_type
=
$mdecl
;
$ignore_required
=1;
$sub
.=
q`
if (!$have_trees and !defined $v and (!defined($pml_trees_type) or $pml_trees_type==$this_trees_type)) {
$have_trees=1;`
;
if
(
$m
->is_required) {
$sub
.=
q`
warn "Member '`
.
$path
.'/
'.$name.q`'
with
role
if
!
$ctxt
->{_trees} and @{
$ctxt
->{_trees}};`;
}
$sub
.=
q`
if (defined $close) { undef $close; print $out '>'; }
print $out `
._indent().
q`'<`
.
$name
.
q`>';`
._indent_inc();
if
(
$mdecl_type
== PML_SEQUENCE_DECL) {
$sub
.= _write_trees_seq(
$mdecl
);
}
elsif
(
$mdecl_type
== PML_LIST_DECL) {
$sub
.= _write_trees_list(
$mdecl
);
}
$sub
.=_indent_dec().
q`
if (defined $close) { undef $close; print $out '>'; }
print $out `
._indent().
q`'</`
.
$name
.
q`>';
} else { `
;
}
if
(
$mdecl_type
== PML_CONSTANT_DECL and !
$m
->is_required) {
$sub
.=
q`
if (defined $v and (ref($v) or length $v and $v ne "`
.
quotemeta
(
$mdecl
->get_value).
q`")) {
warn "Disregarding invalid constant value in member '`
.
$name
.
q`': '$v'!\n";
}`
;
}
elsif
(
$m
->get_role eq
'#KNIT'
) {
my
$knit_name
=
$m
->get_knit_name;
my
$knit_decl
=
$m
->get_knit_content_decl();
my
$knit_decl_path
=
$knit_decl
->get_decl_path;
$knit_decl_path
=~s/^!//;
$sub
.=
q`
if (defined $v and !ref $v and length $v) {
if (defined $close) { undef $close; print $out '>'; }
$handlers{'`
.
$path
.'/
'.$name.q`'
}->(
'`.$name.q`'
,
$v
);
}
else
{`;
unless
(
$name
eq
$knit_name
) {
$sub
.=
q`
$v = $data->{'`
.
$knit_name
.
q`'};`
;
}
$sub
.=
q`
if (defined $close) { undef $close; print $out '>'; }
if (ref $v) {`
;
if
(
$KEEP_KNIT
) {
$sub
.=
q`
$handlers{'`
.
$knit_decl_path
.
q`' }->('`
.
$name
.
q`',$v);`
;
}
else
{
$sub
.=_knit_code(
$knit_decl
,
$knit_decl_path
,
$name
);
}
$sub
.=
q`
}`
;
if
(
$m
->is_required) {
$sub
.=
q` else {
warn "Required member '`
.
$path
.'/
'.$knit_name.q`'
missing, writing empty tag!\n";
print
$out
`._indent().
q`'<`
.
$knit_name
.
q`/>';
}`
;
}
$sub
.=
q`
}`
;
$sub
.=
q`
}`
if
$close_brace
;
}
elsif
(
$mdecl_type
== PML_LIST_DECL and
$mdecl
->get_role eq
'#KNIT'
) {
my
$knit_name
=
$m
->get_knit_name;
my
$knit_decl
=
$mdecl
->get_knit_content_decl();
my
$knit_decl_path
=
$knit_decl
->get_decl_path;
$knit_decl_path
=~s/^!//;
if
(
$name
ne
$knit_name
) {
$sub
.=
q`
if (ref $v) {
if (defined $close) { undef $close; print $out '>'; }
$handlers{'`
.
$path
.'/
'.$name.q`'
}->(
'`.$name.q`'
,
$v
);
}
else
{
$v
=
$data
->{
'`.$knit_name.q`'
};`;
}
if
(
$m
->is_required) {
$sub
.=
q` if (!ref $v) {
warn "Required member '`
.
$path
.'/
'.$knit_name.q`'
missing, writing empty tag!\n";
if
(
defined
$close
) {
undef
$close
;
print
$out
'>'
; }
print
$out
`._indent().
q`'<`
.
$knit_name
.
q`/>';
} else {`
;
}
else
{
$sub
.=
q`
if (ref $v) {
if (defined $close) { undef $close; print $out '>'; }`
;
}
if
(
$KEEP_KNIT
) {
if
(!
$WRITE_SINGLE_LM
) {
$sub
.=
q`
if (@$v==1 and defined($v->[0]) and !(UNIVERSAL::isa($v->[0],'HASH') and keys(%{$v->[0]})==0)) {
$handlers{'`
.
$knit_decl_path
.
q`' }->('`
.
$name
.
q`',$v->[0]);
} else {`
;
}
$sub
.=
q`
print $out `
._indent().
q`'<`
.
$name
.
q`>';`
._indent_inc().
q`
$handlers{'`
.
$knit_decl_path
.
q`' }->('LM',$_) for @$v;`
._indent_dec().
q`
print $out `
._indent().
q`'</`
.
$name
.
q`>';`
;
$sub
.=
q`
}`
if
!
$WRITE_SINGLE_LM
;
}
else
{
if
(!
$WRITE_SINGLE_LM
) {
$sub
.=
q`
if (@$v==1) {
if (defined $close) { undef $close; print $out '>'; }
$v=$v->[0];
`
._knit_code(
$knit_decl
,
$knit_decl_path
,
$name
).
q`
} else {`
;
}
$sub
.=
q`
if (defined $close) { undef $close; print $out '>'; }
print $out `
._indent().
q`'<`
.
$name
.
q`>';`
._indent_inc().
q`
my $l = $v;
for $v (@$l) {`
._knit_code(
$knit_decl
,
$knit_decl_path
,
'LM'
).
q`
}`
._indent_dec().
q`
print $out `
._indent().
q`'</`
.
$name
.
q`>';`
;
$sub
.=
q`
}`
if
!
$WRITE_SINGLE_LM
;
}
$sub
.=
q`
}`
;
if
(
$name
ne
$knit_name
) {
$sub
.=
q`
}`
;
}
$sub
.=
q`
}`
if
$close_brace
;
}
else
{
$sub
.=
q`
if (defined $v and (ref $v or length $v)) {
if (defined $close) { undef $close; print $out '>'; }
$handlers{'`
.
$path
.'/
'.$name.q`'
}->(
'`.$name.q`'
,
$v
);
}`;
if
(
$m
->is_required and !
$ignore_required
) {
$sub
.=
q` else {
warn "Required member '`
.
$path
.'/
'.$name.q`'
missing, writing empty tag!\n";
if
(
defined
$close
) {
undef
$close
;
print
$out
'>'
; }
print
$out
`._indent().
q`'<`
.
$name
.
q`/>';
}`
;
}
}
$sub
.=
q`
}`
if
$close_brace
;
}
$sub
.= _indent_dec().
q`
if (defined $tag and length $tag) {
print $out (defined($close) ? $close : `
._indent().
q`"</$tag>");
}
}`
;
$src
{
$src
}=
$sub
;
$handlers
{
$path
} =
eval
(
$sub
);
die
_nl(
$sub
).
"\n"
.$@.
' '
if
$@;
}
elsif
(
$decl_type
== PML_CONTAINER_DECL) {
my
$src
=
$schema_name
.
'__generated_write_container@'
.
$path
;
$src
=~y{/}{@};
my
$sub
=
q`#line 1 ".pml_compile.d/`
.
$src
.
q`"
sub {
my ($tag,$data)=@_;
my $v;
unless (defined $data) {
print $out defined $tag ? '/>' : '>' if !$tag;
return;
}
my $close;
my $ctag=$tag;`
;
my
@attributes
=
$decl
->get_attributes;
if
(
@attributes
) {
$sub
.=
q`
if (defined $tag) {
print $out `
._indent().
q`'<'.$tag ; $close = '>'; $ctag='';`
;
for
my
$attr
(
@attributes
) {
my
$name
=
$attr
->get_name;
if
(
$attr
->is_required) {
$sub
.=
q`
$v = $data->{'`
.
$name
.
q`'};
$v='' unless defined $v;
$v=~s/&/&/g; $v=~s/</</g; $v=~s/"/"/g;
print $out ' `
.
$name
.
q`'.'="'.$v.'"';
`
;
}
else
{
$sub
.=
q`
$v = $data->{'`
.
$name
.
q`'};
if (defined($v) && length($v)) {
$v=~s/&/&/g; $v=~s/</</g; $v=~s/"/"/g;
print $out ' `
.
$name
.
q`'.'="'.$v.'"';
}
`
;
}
}
$sub
.=
q`
}`
;
}
else
{
$sub
.=
q`undef $tag;`
;
}
my
$cdecl
=
$decl
->get_content_decl;
if
(
$cdecl
) {
my
$cdecl_type
=
$cdecl
->get_decl_type;
my
$cpath
=
$cdecl
->get_decl_path;
$cpath
=~ s/^!//;
my
$close_brace
=0;
if
(
$WITH_TREES
and
$decl
->get_role eq
'#NODE'
and
$cdecl
->get_role eq
'#CHILDNODES'
) {
$close_brace
=1;
$sub
.=
q`
if (UNIVERSAL::DOES::does($data,'Treex::PML::Node')) {
undef $close;
if (defined($ctag)) {
if (!length($ctag)) {
print $out '>';
} elsif ($data->firstson) {
print $out `
._indent().
q`qq{<$ctag>};
} else {
print $out `
._indent().
q`qq{<$ctag/>};
}
}`
;
if
(
$cdecl_type
== PML_SEQUENCE_DECL) {
$sub
.= _write_children_seq(
undef
,
$cdecl
);
}
elsif
(
$cdecl_type
== PML_LIST_DECL) {
$sub
.= _write_children_list(
undef
,
$cdecl
);
}
$sub
.=
q`
if ($data->firstson) {
if (defined($ctag) and length($ctag)) {
print $out `
._indent().
q`qq{</$ctag>};
} else {
print $out `
._indent().
q`'';
}
}
} else { `
;
}
$sub
.=
q`
$v = $data->{'#content'};`
;
$sub
.=
q`
undef $close;
if (defined $v and (ref $v or length $v)) {
$handlers{'`
.
$cpath
.
q`' }->($ctag,$v);
my $ref = ref($v);
print $out `
._indent().
q`'' if !$ctag and $ref and !((UNIVERSAL::DOES::does($v,'Treex::PML::Alt')`
.(
$WRITE_SINGLE_LM
?
''
:
q` or UNIVERSAL::DOES::does($v,'Treex::PML::List')`
)
.
q`) and @$v==1 and defined($v->[0]) and !(UNIVERSAL::isa($v->[0],'HASH') and keys(%{$v->[0]})==0));
} else {
if (defined($ctag) and length($ctag)) { print $out `
._indent().
q`qq{<$ctag/>} } else { $close='/>'; }
}`
;
$sub
.=
q`
}`
if
$close_brace
;
}
else
{
$sub
.=
q`
if (defined($ctag) and length($ctag)) { print $out `
._indent().
q`qq{<$ctag/>} } else {
$close='/>'; }`
;
}
$sub
.=
q`
if (defined $tag and length $tag) {
print $out (defined($close) ? $close : "</$tag>");
}
}`
;
$src
{
$src
}=
$sub
;
$handlers
{
$path
} =
eval
(
$sub
);
die
_nl(
$sub
).
"\n"
.$@.
' '
if
$@;
}
elsif
(
$decl_type
== PML_SEQUENCE_DECL) {
my
$src
=
$schema_name
.
'__generated_write_sequence@'
.
$path
;
$src
=~y{/}{@};
local
$INDENT
=-1
if
$decl
->is_mixed;
my
$sub
=
q`#line 1 ".pml_compile.d/`
.
$src
.
q`"
sub {
my ($tag,$data)=@_;
my ($k,$v);
unless (defined $data) {`
;
if
(
$WITH_TREES
and
$decl
->get_role eq
'#TREES'
) {
$sub
.=
q`
if (!$have_trees and (!defined($pml_trees_type) or $pml_trees_type==$decl)) {
print $out (length($tag) ? `
._indent().
q`"<$tag>" : '>') if defined $tag;
$have_trees=1;`
._indent_inc()._write_trees_seq(
$decl
)._indent_dec().
q`
print $out (length($tag) ? `
._indent().
q`"</$tag>" : '>') if defined $tag;
} else {
print $out defined $tag ? '/>' : '>' if !$tag;
}`
;
}
else
{
$sub
.=
q`
print $out defined $tag ? '/>' : '>' if !$tag;`
;
}
$sub
.=
q`
return;
}
print $out (length($tag) ? `
._indent().
q`"<$tag>" : '>') if defined $tag;`
._indent_inc()._write_seq(
$decl
,
$path
,
'$data'
)._indent_dec();
$sub
.=
q`
if (defined $tag and length $tag) {
print $out `
._indent().
q`"</$tag>";
}
}`
;
$src
{
$src
}=
$sub
;
$handlers
{
$path
} =
eval
(
$sub
);
die
_nl(
$sub
).
"\n"
.$@.
' '
if
$@;
$handlers
{
$path
.
'/#TEXT'
} =
eval
q`sub { print $out ($_[1]); }`
if
$decl
->is_mixed;
}
elsif
(
$decl_type
== PML_LIST_DECL) {
my
$cdecl
=
$decl
->get_content_decl;
my
$cpath
=
$cdecl
->get_decl_path;
$cpath
=~s/^!//;
my
$src
=
$schema_name
.
'__generated_write_list@'
.
$path
;
$src
=~y{/}{@};
my
$sub
=
q`#line 1 ".pml_compile.d/`
.
$src
.
q`"
sub {
my ($tag,$data)=@_;
my ($v);
if (!defined $data or !@$data) {`
;
if
(
$WITH_TREES
and
$decl
->get_role eq
'#TREES'
) {
$sub
.=
q`
if (!$have_trees and (!defined($pml_trees_type) or $pml_trees_type==$decl)) {
print $out (length($tag) ? `
._indent().
q`"<$tag>" : '>') if defined $tag;
$have_trees=1;`
._indent_inc()._write_trees_list(
$decl
)._indent_dec().
q`
print $out `
._indent().
q`"</$tag>" if defined $tag and length $tag;
return;
} else {
print $out defined $tag ? '/>' : '>' if !$tag;
return;
} `
;
}
else
{
$sub
.=
q`
print $out defined $tag ? '/>' : '>' if !$tag;
return;`
;
}
if
(!
$WRITE_SINGLE_LM
) {
$sub
.=
q`
} elsif (@$data==1 and defined($data->[0]) and !(UNIVERSAL::isa($data->[0],'HASH') and keys(%{$data->[0]})==0)) {
print $out '>' if defined $tag and !length $tag;
$handlers{ '`
.
$cpath
.
q`' }->($tag || 'LM',$data->[0]);`
;
}
$sub
.=
q`
} else {
print $out (length($tag) ? `
._indent().
q`"<$tag>" : '>') if defined $tag;`
._indent_inc().
q`
for $v (@$data) {
if (defined $v and (ref $v or length $v)) {
$handlers{ '`
.
$cpath
.
q`' }->('LM',$v);
} else {
print $out `
._indent().
q`"<LM/>";
}
}`
._indent_dec().
q`
print $out `
._indent().
q`"</$tag>" if defined $tag and length $tag;
}
}`
;
$src
{
$src
}=
$sub
;
$handlers
{
$path
} =
eval
(
$sub
);
die
_nl(
$sub
).
"\n"
.$@.
' '
if
$@;
}
elsif
(
$decl_type
== PML_ALT_DECL) {
my
$cdecl
=
$decl
->get_content_decl;
my
$cpath
=
$cdecl
->get_decl_path;
$cpath
=~s/^!//;
my
$src
=
$schema_name
.
'__generated_write_alt@'
.
$path
;
$src
=~y{/}{@};
my
$sub
=
q`#line 1 ".pml_compile.d/`
.
$src
.
q`"
sub {
my ($tag,$data)=@_;
unless (defined $data) {
print $out defined $tag ? '/>' : '>' if !$tag;
return;
}
if (!UNIVERSAL::DOES::does($data, 'Treex::PML::Alt')) {
print $out '>' if defined $tag and !length $tag;
$handlers{ '`
.
$cpath
.
q`' }->($tag || 'AM',$data);
} elsif (@$data==1) {
print $out '>' if defined $tag and !length $tag;
$handlers{ '`
.
$cpath
.
q`' }->($tag || 'AM',$data->[0]);
} elsif (@$data==0) {
print $out defined $tag ? '/>' : '>' if !$tag;
return;
} else {
my $v;
print $out (length($tag) ? `
._indent().
q`"<$tag>" : '>') if defined $tag;`
._indent_inc().
q`
for $v (@$data) {
if (defined $v and (ref $v or length $v)) {
$handlers{ '`
.
$cpath
.
q`' }->('AM',$v);
} else {
print $out `
._indent().
q`"<AM/>";
}
}`
._indent_dec().
q`
print $out `
._indent().
q`"</$tag>" if defined $tag and length $tag;
}
}`
;
$src
{
$src
}=
$sub
;
$handlers
{
$path
} =
eval
(
$sub
);
die
_nl(
$sub
).
"\n"
.$@.
' '
if
$@;
}
elsif
(
$decl_type
== PML_CDATA_DECL) {
my
$src
=
$schema_name
.
'__generated_write_cdata@'
.
$path
;
$src
=~y{/}{@};
my
$sub
=
q`#line 1 ".pml_compile.d/`
.
$src
.
q`"
sub {
my ($tag,$data)=@_;
print $out (length($tag) ? `
._indent().
q`"<$tag>" : '>') if defined $tag;
if (defined $data and length $data) {
$data=~s/&/&/g;$data=~s/</</g;
print $out $data;
}
print $out "</$tag>" if defined $tag and length $tag;
}`
;
$src
{
$src
}=
$sub
;
$handlers
{
$path
} =
eval
(
$sub
);
die
_nl(
$sub
).
"\n"
.$@.
' '
if
$@;
}
elsif
(
$decl_type
== PML_CHOICE_DECL) {
my
$value_hash
=
$decl
->{value_hash};
unless
(
$value_hash
) {
$value_hash
={};
@{
$value_hash
}{@{
$decl
->{
values
}}}=();
$decl
->{value_hash}=
$value_hash
;
}
my
$src
=
$schema_name
.
'__generated_write_choice@'
.
$path
;
$src
=~y{/}{@};
my
$sub
=
q`#line 1 ".pml_compile.d/`
.
$src
.
q`"
sub {
my ($tag,$data)=@_;
print $out (length($tag) ? `
._indent().
q`"<$tag>" : '>') if defined $tag;
if (defined $data and length $data) {
warn("Value: '$data' not allowed for choice type '`
.
$path
.
q`'; writing anyway!") if !exists $value_hash->{$data};
$data=~s/&/&/g;$data=~s/</</g;
print $out $data;
}
print $out "</$tag>" if defined $tag and length $tag;
}`
;
$src
{
$src
}=
$sub
;
$handlers
{
$path
} =
eval
(
$sub
);
die
_nl(
$sub
).
"\n"
.$@.
' '
if
$@;
}
elsif
(
$decl_type
== PML_CONSTANT_DECL) {
my
$value
=
quotemeta
(
$decl
->{value});
my
$src
=
$schema_name
.
'__generated_write_choice@'
.
$path
;
$src
=~y{/}{@};
my
$sub
=
q`#line 1 ".pml_compile.d/`
.
$src
.
q`"
sub {
my ($tag,$data)=@_;
print $out (length($tag) ? `
._indent().
q`"<$tag>" : '>') if defined $tag;
if (defined $data and length $data) {
warn("Invalid value '$data' in a constant type '`
.
$path
.
q`', should be '`
.
$value
.
q`'; writing anyway!") if $data ne "`
.
$value
.
q`";
$data=~s/&/&/g;$data=~s/</</g;
print $out $data;
}
print $out "</$tag>" if defined $tag and length $tag;
}`
;
$src
{
$src
}=
$sub
;
$handlers
{
$path
} =
eval
(
$sub
);
die
_nl(
$sub
).
"\n"
.$@.
' '
if
$@;
}
});
$schema
->for_each_decl(
sub
{
my
(
$decl
)=
@_
;
my
$decl_type
=
$decl
->get_decl_type;
if
(
$decl_type
== PML_ATTRIBUTE_DECL ||
$decl_type
== PML_MEMBER_DECL ||
$decl_type
== PML_ELEMENT_DECL
) {
my
$parent
=
$decl
->get_parent_decl;
my
$path
=
$parent
->get_decl_path .
'/'
.
$decl
->get_name;
$path
=~ s/^!//
if
$path
;
my
$mdecl
;
if
(!
exists
(
$handlers
{
$path
})) {
$mdecl
||=
$decl
->get_content_decl;
my
$mpath
=
$mdecl
->get_decl_path;
$mpath
=~ s/^!//
if
$mpath
;
$handlers
{
$path
} =
$handlers
{
$mpath
};
}
}
});
}
}
sub
_nl {
my
(
$str
)=
@_
;
my
$i
=0;
return
join
"\n"
,
map
sprintf
(
"%4d\t"
,
$i
++).
$_
,
split
/\n/,
$str
;
}
1;
Hide Show 56 lines of Pod