File Coverage

blib/lib/Treex/PML/Instance/Writer.pm
Criterion Covered Total %
statement 31 33 93.9
branch n/a
condition n/a
subroutine 12 12 100.0
pod n/a
total 43 45 95.5


line stmt bran cond sub pod time code
1             package Treex::PML::Instance::Writer;
2             {
3 1     1   1415 use 5.008;
  1         2  
4 1     1   4 use strict;
  1         1  
  1         15  
5 1     1   3 use warnings;
  1         1  
  1         24  
6 1     1   3 no warnings qw(recursion);
  1         1  
  1         21  
7 1     1   3 use Carp;
  1         1  
  1         47  
8 1     1   3 use Data::Dumper;
  1         1  
  1         31  
9 1     1   3 use Scalar::Util qw(blessed);
  1         4  
  1         34  
10 1     1   4 use UNIVERSAL::DOES;
  1         1  
  1         38  
11              
12             BEGIN {
13 1     1   13 our $VERSION = '2.22'; # version template
14             }
15 1     1   4 use List::Util qw(first);
  1         4  
  1         57  
16 1     1   5 use Treex::PML::Instance::Common qw(:diagnostics :constants);
  1         0  
  1         105  
17 1     1   31 use Treex::PML::Schema;
  0            
  0            
18             use Treex::PML::IO qw(open_backend close_backend rename_uri);
19             use Encode;
20              
21             my (
22             %handlers,
23             %src,
24             %handler_cache,
25             @handler_cache,
26             );
27              
28             # TODO:
29             # - test inline schemas
30             # - content_pattern and cdata validation on save
31             # - mixed content
32             # - decorate
33              
34             our $CACHE_HANDLERS=1;
35             our $MAX_SCHEMA_CACHE_SIZE=50;
36              
37             our $VALIDATE_CDATA=0;
38             our $SAVE_REFFILES = 1;
39             our $WITH_TREES = 1;
40             our $KEEP_KNIT = 0;
41             our $WRITE_SINGLE_LM = 0;
42             our $WRITE_SINGLE_CHILDREN_LM = 0;
43             our $INDENT = 2;
44              
45             require Treex::PML;
46              
47             sub _get_handlers_cache_key {
48             my ($schema)=@_;
49             my $key="$schema"; $key=~s/.*=//; # strip class
50             return
51             [
52             $key,
53             join ',',
54             $key,
55             $INDENT || 0,
56             $VALIDATE_CDATA || 0,
57             $SAVE_REFFILES || 0,
58             $WITH_TREES || 0,
59             $WRITE_SINGLE_LM || 0,
60             $KEEP_KNIT || 0,
61             $WRITE_SINGLE_CHILDREN_LM || 0,
62             ];
63             }
64              
65             sub get_cached_handlers {
66             my ($key)=@_;
67             my $subkey = $key->[1];
68             my $cached = $handler_cache{ $key->[0] }{ $subkey };
69             if ($cached and $handler_cache[-1][1] ne $subkey) {
70             # move the last retrieved schema to the end of the queue
71             @handler_cache = ((grep { $_->[1] ne $subkey } @handler_cache),$key);
72             }
73             return $cached;
74             }
75              
76             sub cache_handlers {
77             my ($key,$handlers)=@_;
78             my $subkey = $key->[1];
79             push @handler_cache,$key;
80             $handler_cache{$key->[0]}{$subkey} = $handlers;
81             if (@handler_cache > $MAX_SCHEMA_CACHE_SIZE) {
82             my $del = shift @handler_cache;
83             delete $handler_cache{ $del->[0] }{ $del->[1] };
84             }
85             }
86              
87             sub forget_schema {
88             my ($schema)=@_;
89             delete $handler_cache{ $schema }; # delete also from the handler cache
90             @handler_cache = grep { $_->[0] ne $schema } @handler_cache;
91             }
92              
93             sub _indent {
94             if ($INDENT>=0) {
95             return q{"\n".('}.(' ' x $INDENT).q{' x $indent_level).}
96             } else {
97             return q()
98             }
99             }
100             sub _indent_inc {
101             if ($INDENT>0) {
102             return q`
103             $indent_level++;`;
104             } else {
105             return q()
106             }
107             }
108             sub _indent_dec {
109             if ($INDENT>0) {
110             return q`
111             $indent_level--;`;
112             } else {
113             return q()
114             }
115             }
116              
117             sub save {
118             my ($ctxt,$opts)=@_;
119             my $fh = $opts->{fh};
120             local $VALIDATE_CDATA=$opts->{validate_cdata} if
121             exists $opts->{validate_cdata};
122              
123             $ctxt->set_filename($opts->{filename}) if $opts->{filename};
124             my $href = $ctxt->{'_filename'};
125              
126             $fh=\*STDOUT if ($href eq '-' and !$fh);
127             my $config = $opts->{config};
128             if ($config and ref(my $load_opts = $config->get_data('options/save'))) {
129             $opts = {%$load_opts, %$opts};
130             }
131              
132             local $KEEP_KNIT = 1 if $opts->{keep_knit};
133             local $WRITE_SINGLE_LM = 1 if $opts->{write_single_LM};
134             local $WRITE_SINGLE_CHILDREN_LM = 1 if $opts->{write_single_children_LM};
135             local $INDENT = $opts->{indent} if defined $opts->{indent};
136             unless ($fh) {
137             if (defined($href) and length($href)) {
138             eval {
139             rename_uri($href,$href."~") unless $href=~/^ntred:/;
140             };
141             my $ok = 0;
142             my $res;
143             eval {
144             $fh = open_backend($href,'w')
145             || die "Cannot open $href for writing: $!";
146             if ($fh) {
147             binmode $fh;
148             $res = $ctxt->save({%$opts, fh=> $fh});
149             close_backend($fh);
150             $ok = 1;
151             }
152             };
153             unless ($ok) {
154             my $err = $@;
155             eval {
156             rename_uri($href."~",$href) unless $href=~/^ntred:/;
157             };
158             die($err."$@\n") if $err;
159             }
160             return $res;
161             } else {
162             die("Usage: $ctxt->save({filename=>...,[fh => ...]})");
163             }
164             }
165             $ctxt->{'_refs_save'} ||= $opts->{'refs_save'};
166             binmode $fh if $fh;
167              
168             my $transform_id = $ctxt->{'_transform_id'};
169             my ($out_xsl_href,$out_xsl,$orig_fh);
170             my $xsl_source='';
171             if ($config and defined $transform_id and length $transform_id) {
172             my $transform = $config->lookup_id( $transform_id );
173             if ($transform) {
174             ($out_xsl) = $transform->{'out'};
175             if ($out_xsl->{'type'} ne 'xslt') {
176             die(__PACKAGE__.": unsupported output transformation $transform_id (only type='xslt') transformations are supported)");
177             }
178             $out_xsl_href = URI->new(Encode::encode_utf8($out_xsl->get_member('href')));
179             $out_xsl_href = Treex::PML::ResolvePath($config->{_filename}, $out_xsl_href, 1);
180             unless (defined $out_xsl_href and length $out_xsl_href) {
181             die(__PACKAGE__.": no output transformation defined for $transform_id");
182             }
183             $orig_fh = $fh;
184             open(my $pml_fh, '>', \$xsl_source) or die "Cannot open scalar for writing!";
185             $fh=$pml_fh;
186             } else {
187             die(__PACKAGE__.": Couldn't find PML transform with ID $transform_id");
188             }
189             }
190              
191             # dump embedded DOM documents
192             my $refs_to_save = $ctxt->{'_refs_save'};
193             # save_reffiles must be a id=>href hash reference
194              
195             my @refs_to_save = grep { ($_->{readas}||'') eq 'dom' or ($_->{readas}||'') eq 'pml' } $ctxt->get_reffiles();
196             if (ref($refs_to_save)) {
197             @refs_to_save = grep { exists $refs_to_save->{$_->{id}} } @refs_to_save;
198             for (@refs_to_save) {
199             unless (defined $refs_to_save->{$_->{id}}) {
200             $refs_to_save->{$_->{id}}=$_->{href};
201             }
202             }
203             } else {
204             $refs_to_save = {};
205             }
206              
207             my $references = $ctxt->{'_references'};
208              
209             # update all DOM trees to be saved
210             $ctxt->{'_parser'} ||= $ctxt->_xml_parser();
211             foreach my $ref (@refs_to_save) {
212             if ($ref->{readas} eq 'dom') {
213             $ctxt->readas_dom($ref->{id},$ref->{href});
214             }
215             # NOTE:
216             # if ($refs_to_save->{$ref->{id}} ne $ref->{href}),
217             # then the ref-file is going to be renamed.
218             # Although we don't parse it as PML, it can be a PML file.
219             # If it is, we might try to update it's references too,
220             # but the snag here is, that we don't know if the
221             # resources it references aren't moved along with it by
222             # other means (e.g. by user making the copy).
223             }
224              
225             binmode $fh,":utf8" if $fh;
226             local $WITH_TREES = $ctxt->{'_no_read_trees'} ? 0 : 1;
227             prepare_handlers($ctxt);
228             dump_handlers($ctxt) if $opts->{dump_handlers} or $ENV{PML_COMPILE_DUMP};;
229             $handlers{'#initialize'}->($ctxt,$refs_to_save,$fh);
230             eval {
231             $handlers{'#root'}->($ctxt->{_root});
232             if ($ctxt->{'_pi'}) {
233             my ($n,$v);
234             for my $pi (@{$ctxt->{'_pi'}}) {
235             # ($n,$v)=@$pi;
236             # for ($n,$v) { s/&/&/g; s/
237             print $fh qq(\n);
238             }
239             }
240             };
241             ($handlers{'#cleanup'}||sub{})->();
242             %handlers=();
243             # close_uri($fh);
244             $fh = $orig_fh if defined $orig_fh;
245             die $@ if $@;
246              
247             if ($xsl_source and $out_xsl_href) {
248             die "Buggy libxslt version 10127\n" if XSLT_BUG;
249             my $xslt = XML::LibXSLT->new;
250             my $params = $out_xsl->content;
251             my %params;
252             %params = map { $_->{'name'} => $_->value } $params->values
253             if $params;
254             my $out_xsl_parsed = $xslt->parse_stylesheet_file($out_xsl_href);
255             my $dom = XML::LibXML->new()->parse_string($xsl_source);
256             my $result = $out_xsl_parsed->transform($dom,%params);
257             if (UNIVERSAL::can($result,'toFH')) {
258             $result->toFH($fh,1);
259             } else {
260             $out_xsl_parsed->output_fh($result,$fh);
261             }
262             return 1;
263             }
264              
265             # dump DOM trees to save
266             if (ref($ctxt->{'_ref'})) {
267             foreach my $ref (@refs_to_save) {
268             if ($ref->{readas} eq 'dom') {
269             my $dom = $ctxt->{'_ref'}->{$ref->{id}};
270             my $href;
271             if (defined($refs_to_save->{$ref->{id}})) {
272             $href = $refs_to_save->{$ref->{id}};
273             } else {
274             $href = $ref->{href}
275             }
276             if (ref($dom)) {
277             eval {
278             rename_uri($href,$href."~") unless $href=~/^ntred:/;
279             };
280             my $ok = 0;
281             eval {
282             my $ref_fh = open_backend($href,"w");
283             if ($ref_fh) {
284             binmode $ref_fh;
285             $dom->toFH($ref_fh,1);
286             close_backend($ref_fh);
287             $ok = 1;
288             }
289             };
290             unless ($ok) {
291             my $err = $@;
292             eval {
293             rename_uri($href."~",$href) unless $href=~/^ntred:/;
294             };
295             _die($err."$@") if $err;
296             }
297             }
298             } elsif ($ref->{readas} eq 'pml') {
299             my $ref_id = $ref->{id};
300             my $pml = $ctxt->{'_ref'}->{$ref_id};
301             if ($pml) {
302             my $href;
303             if (exists($refs_to_save->{$ref_id})) {
304             $href = $refs_to_save->{$ref_id};
305             } else {
306             $href = $ref->{href}
307             }
308             $pml->save({ %$opts,
309             refs_save=>{
310             map { my $k=$_; $k=~s%^\Q$ref_id\E/%% ? ($k=>$refs_to_save->{$_}) : () } keys %$refs_to_save
311             },
312             filename => $href, fh=>undef });
313             }
314             }
315             }
316             }
317             return $ctxt;
318             }
319              
320             ######################################################
321              
322             sub prepare_handlers {
323             my ($ctxt)=@_;
324             %handlers=();
325             my $schema = $ctxt->{'_schema'};
326             my $key=_get_handlers_cache_key($schema);
327             my $cached = get_cached_handlers($key);
328             if ($cached) {
329             %handlers= @$cached;
330             } else {
331             compile_schema($schema);
332             cache_handlers($key,[%handlers]) if $CACHE_HANDLERS;
333             }
334             }
335              
336             sub dump_handlers {
337             my $dir = '.pml_compile.d';
338             (-d $dir) || mkdir($dir) || die "Can't dump to $dir: $!\n";
339             # print "created $dir\n";
340             for my $f (keys %src) {
341             my $dump_file = File::Spec->catfile($dir,$f);
342             open (my $fh, '>:utf8', $dump_file)
343             || die "Can't write to $dump_file: $!\n";
344             my $sub = $src{$f};
345             $sub=~s/^\s*#line[^\n]*\n//;
346             print $fh ($sub);
347             close $fh;
348             }
349             }
350              
351             sub _write_seq {
352             my ($decl,$path,$seq)=@_;
353             my $sub='';
354             local $INDENT=-1 if $decl->is_mixed;
355             $sub .= q`
356             for my $el (`.$seq.q`->elements) {
357             ($k,$v)=@$el;
358             if (defined $v and (ref $v or length $v)) {
359             $handlers{ '`.$path.'/'.q`'.$k }->($k,$v);
360             } else {
361             print $out `._indent().q`"<$k/>";
362             }
363             }`;
364             return $sub;
365             }
366              
367             sub _write_trees_seq {
368             my ($decl)=@_;
369             my $path = $decl->get_decl_path;
370             $path =~ s/^!// if $path;
371             return q`
372             my $prolog = $ctxt->{'_pml_prolog'};
373             if ($prolog) {`._write_seq($decl,$path,'$prolog').q`
374             }
375             for $v (@{$ctxt->{'_trees'}}) {
376             if (ref $v) {
377             $k=$v->{'#name'};
378             $handlers{ '`.$path.'/'.q`'.$k }->($k,$v);
379             }
380             }
381             my $epilog = $ctxt->{'_pml_epilog'};
382             if ($epilog) {`._write_seq($decl,$path,'$epilog').q`
383             }`;
384             }
385              
386             sub _write_trees_list {
387             my ($decl)=@_;
388             my $path = $decl->get_content_decl->get_decl_path;
389             $path =~ s/^!// if $path;
390             return q`
391             for $v (@{$ctxt->{'_trees'}}) {
392             $handlers{ '`.$path.q`' }->('LM',$v);
393             }`;
394             }
395              
396             sub _write_children_seq {
397             my ($tag,$decl)=@_;
398             my $path = $decl->get_decl_path;
399             $path =~ s/^!// if $path;
400             my $sub = q`
401             if ($v = $data->firstson) {`;
402             $sub .= q`
403             print $out `._indent().q`"<`.$tag.q`>";` if defined $tag;
404             $sub .= _indent_inc().q`
405             my $name;
406             while ($v) {
407             $name = $v->{'#name'};
408             $handlers{ '`.$path.'/'.q`'.$name }->($name,$v);
409             $v = $v->rbrother;
410             }`._indent_dec();
411             $sub .= q`
412             print $out `._indent().q`"";` if defined $tag;
413             $sub.=q`
414             }`;
415             return $sub;
416             }
417              
418             sub _write_children_list {
419             my ($tag,$decl)=@_;
420             $decl = $decl->get_content_decl;
421             my $path = $decl->get_decl_path;
422             $path =~ s/^!// if $path;
423             my $sub = q`
424             if ($v = $data->firstson) {`;
425             if (defined $tag) {
426             if (!$WRITE_SINGLE_LM and !$WRITE_SINGLE_CHILDREN_LM) {
427             $sub .= q`
428             if ($v && !$v->rbrother && keys(%$v)) {
429             $handlers{ '`.$path.q`' }->('`.$tag.q`',$v);
430             } else {`;
431             }
432             $sub .= q`
433             print $out `._indent().q`"<`.$tag.q`>";` ;
434             }
435             $sub.=_indent_inc().q`
436             while ($v) {
437             $handlers{ '`.$path.q`' }->('LM',$v);
438             $v = $v->rbrother;
439             }`._indent_dec();
440             if (defined $tag) {
441             $sub .= q`
442             print $out `._indent().q`"";`;
443             $sub .= q`
444             }` if !$WRITE_SINGLE_LM and !$WRITE_SINGLE_CHILDREN_LM;
445             }
446             $sub.=q`
447             }`;
448             return $sub;
449             }
450              
451              
452             sub _knit_code {
453             my ($knit_decl,$knit_decl_path,$name)=@_;
454             my $idM = Treex::PML::Instance::Reader::_fix_id_member($knit_decl);
455             if ($idM) {
456             my $idM_name=$idM->get_name;
457             return q`
458             my $knit_id = $v->{'`.$idM_name.q`'};
459             my $prefix;
460             unless (defined $knit_id) {
461             warn "Cannot KNIT back: `.$idM_name.q` not defined on object `.$knit_decl_path.q`!";
462             } elsif ($knit_id =~ s/^(.*?)#//) {
463             $prefix=$1;
464             } else {
465             $prefix = $v->{'#knit_prefix'};
466             }
467             print $out `._indent().q`'<`.$name.q`>'.($prefix ? $prefix.'#'.$knit_id : $knit_id).'';
468             if ($prefix and !UNIVERSAL::DOES::does($ctxt->{'_ref'}{$prefix},'Treex::PML::Instance')) {
469             # DOM KNIT
470             my $rf_href = $refs_to_save->{$prefix};
471             if ( $rf_href ) {
472             my $indeces = $ctxt->{'_ref-index'};
473             if ($indeces and $indeces->{$prefix}) {
474             my $knit = $indeces->{$prefix}{$knit_id};
475             if ($knit) {
476             my $save_out = $out;
477             my $xml='';
478             open my $new_out, '>:utf8', \$xml; # perl 5.8.0
479             $out = $new_out;
480             local $INDENT=-1;
481             $handlers{'`.$knit_decl_path.q`' }->($knit->nodeName,$v);
482             close $new_out;
483             $out = $save_out;
484             $xml=''.$xml.'';
485             my $new = $ctxt->{'_parser'}->parse_string($xml)->documentElement->firstChild;
486             $new->setAttribute('`.$idM_name.q`',$knit_id);
487             $knit->ownerDocument->adoptNode( $new );
488             $knit->parentNode->insertAfter($new,$knit);
489             $knit->unbindNode;
490             $indeces->{$prefix}{$knit_id}=$new;
491             } else {
492             _warn("Didn't find ID '$knit_id' in '$rf_href' ('$prefix') - cannot knit back!\n");
493             }
494             } else {
495             _warn("Knit-file '$rf_href' ('$prefix') has no index - cannot knit back!\n");
496             }
497             }
498             }`;
499             } else {
500             warn("Cannot KNIT ".$knit_decl_path." if there is no member/attribute with role='#ID'!");
501             }
502             }
503              
504             sub simplify {
505             my $filename = shift;
506             my $up = File::Spec->updir;
507             my $sep = File::Spec->catfile(q(), q());
508             while($filename =~ /\Q$sep$up$sep/) {
509             $filename =~ s/\Q$sep\E?[^$sep]*\Q$sep$up$sep/$sep/;
510             }
511             return $filename;
512             }
513              
514             sub compile_schema {
515             my ($schema)=@_;
516             my ($ctxt,$refs_to_save,$out,$pml_trees_type,$have_trees,$indent_level);
517             my $schema_name = $schema->get_root_decl->get_name;
518             $handlers{'#cleanup'}= sub {
519             undef $_ for ($ctxt,$refs_to_save,$out);
520             };
521             $handlers{'#initialize'}= sub {
522             my ($instance,$refs_save,$fh)=@_;
523             $ctxt = $instance;
524             $refs_to_save = $refs_save;
525             $out = $fh;
526             $have_trees = 0;
527             $pml_trees_type = $ctxt->{'_pml_trees_type'};
528             $indent_level=0;
529             };
530             $schema->for_each_decl(sub {
531             my ($decl)=@_;
532             # no warnings 'uninitialized';
533             my $decl_type=$decl->get_decl_type;
534             my $path = $decl->get_decl_path;
535             $path =~ s/^!// if $path;
536             return if $decl_type == PML_ATTRIBUTE_DECL ||
537             $decl_type == PML_MEMBER_DECL ||
538             $decl_type == PML_TYPE_DECL ||
539             $decl_type == PML_ELEMENT_DECL;
540             if ($decl_type == PML_ROOT_DECL) {
541             my $name = $decl->get_name;
542             my $cdecl = $decl->get_content_decl;
543             my $cdecl_type = $cdecl->get_decl_type;
544             my $cpath = $cdecl->get_decl_path;
545             $cpath =~ s/^!//;
546             my $src = $schema_name.'__generated_write_root';
547             my $sub = q`#line 1 ".pml_compile.d/`.$src.q`"
548             sub {
549             my ($data)=@_;
550             my $v;
551             print $out ''."\n";
552             print $out '<`.$decl->get_name.q` xmlns="`.PML_NS.q`"';`;
553             # we need to know attributes now
554             if ($cdecl_type == PML_CONSTANT_DECL ||
555             $cdecl_type == PML_STRUCTURE_DECL) {
556             for my $attr ($cdecl->get_attributes) {
557             if ($attr->is_required) {
558             $sub.=q`
559             $v = $data->{'`.$attr->get_name.q`'};
560             $v = '' unless defined $v;
561             $v =~ s/&/&/g; $v=~s/
562             print $out ' `.$attr->get_name.q`="'.$v.'"';
563             `;
564             } else {
565             $sub.=q`
566             $v = $data->{'`.$attr->get_name.q`'};
567             if (defined($v) && length($v)) {
568             $v=~s/&/&/g; $v=~s/
569             print $out ' `.$attr->get_name.q`="'.$v.'"';
570             }
571             `;
572             }
573             }
574             }
575             # NOTE: using _^_ as indentation replacement!
576             my $no_end_indent =
577             ($cdecl_type == PML_SEQUENCE_DECL and
578             $cdecl->is_mixed);
579             my $psub = q`
580             print $out ">\n",
581             "_^_\n";
582             my $inline = $ctxt->{'_schema-inline'};
583              
584             # remove /../ from filename, URI::rel gives strange results for base containing them
585             my $filename = $ctxt->{_filename};
586             $filename = $filename->path if ref $filename and index($filename,'file:/') == 0;
587             $filename = simplify($filename) if -e $filename;
588              
589             if (defined $inline and length $inline) {
590             print $out qq(_^__^_\n),$inline,qq( \n);
591             } else {
592             $v = $ctxt->{'_schema-url'};
593             if (defined $v and length $v) {
594             $v=Treex::PML::IO::make_relative_URI($ctxt->{'_schema-url'},$filename);
595             $v=~s/&/&/g; $v=~s/
596             print $out qq(_^__^_\n);
597             } else {
598             print $out qq(_^__^_\n);
599             $ctxt->{'_schema'}->write({fh=>$out});
600             print $out qq(_^__^_\n);
601             }
602             }
603             my $references = $ctxt->{'_references'};
604             if (ref($references) and keys(%$references)) {
605             my $named = $ctxt->{'_refnames'};
606             my %names = $named ? (map {
607             my $name = $_;
608             map { $_ => $name } (ref($named->{$_}) ? @{$named->{$_}} : $named->{$_})
609             } keys %$named) : ();
610             print $out qq(_^__^_\n);
611             foreach my $id (sort keys %$references) {
612             my $href;
613             if (exists($refs_to_save->{$id})) {
614             # effectively rename the file reference
615             $href = $references->{$id} = $refs_to_save->{$id}
616             } else {
617             $href = $references->{$id};
618             }
619             $href=Treex::PML::IO::make_relative_URI($href,$filename);
620             my $name = $names{$id};
621             for ($id,$href, (defined $name ? $name : ())) { s/&/&/g; s/
622             print $out qq(_^__^__^_\n);
623             }
624             print $out qq(_^__^_\n);
625             }
626             print $out "_^_";
627             $handlers{ '`.$cpath.q`' }->(undef,$data);
628             print $out `.($no_end_indent ? '' : _indent()).q`'get_name.q`>'."\n";
629             }`;
630             my $indent = $INDENT>0 ? ' ' x $INDENT : '';
631             $psub=~s/_\^_/$indent/g;
632             $sub.=$psub;
633             $src{$src}=$sub;
634             $handlers{'#root'}=eval $sub; die _nl($sub)."\n".$@.' ' if $@;
635             } elsif ($decl_type == PML_STRUCTURE_DECL) {
636             # print $path,"\n";
637             my $src = $schema_name.'__generated_write_structure@'.$path;
638             $src=~y{/}{@};
639             my $sub = q`#line 1 ".pml_compile.d/`.$src.q`"
640             sub {
641             my ($tag,$data)=@_;
642             my ($v,$k);
643             unless (defined $data) {
644             print $out defined $tag ? '/>' : '>' if !$tag;
645             return;
646             }
647             my $close;
648             if (defined $tag) {
649             $close = '/>';
650             print $out `._indent().q`'<'.$tag if length $tag;`;
651             for my $attr ($decl->get_attributes) {
652             my $name = $attr->get_name;
653             if ($attr->is_required) {
654             $sub.=q`
655             $v = $data->{'`.$name.q`'};
656             $v='' unless defined $v;
657             $v=~s/&/&/g; $v=~s/
658             print $out ' `.$name.q`'.'="'.$v.'"';
659             `;
660             } else {
661             $sub.=q`
662             $v = $data->{'`.$name.q`'};
663             if (defined($v) && length($v)) {
664             $v=~s/&/&/g; $v=~s/
665             print $out ' `.$name.q`'.'="'.$v.'"';
666             }
667             `;
668             }
669             }
670             $sub .= q`
671             }`._indent_inc();
672             my $this_trees_type;
673             for my $m ($decl->get_members) {
674             next if $m->is_attribute;
675             my $name = $m->get_name;
676             my $mdecl = $m->get_content_decl;
677             my $mdecl_type = $mdecl->get_decl_type;
678             $sub.=q`
679             $v = $data->{'`.$name.q`'};`;
680             my $close_brace=0;
681             my $ignore_required=0;
682             if ($WITH_TREES and $decl->get_role eq '#NODE' and $m->get_role eq '#CHILDNODES') {
683             $close_brace=1;
684             $sub.=q`
685             if (UNIVERSAL::DOES::does($data,'Treex::PML::Node')) {
686             if (defined $close) { undef $close; print $out '>'; }`;
687             if ($mdecl_type == PML_SEQUENCE_DECL) {
688             $sub .= _write_children_seq($name,$mdecl);
689             } elsif ($mdecl_type == PML_LIST_DECL) {
690             $sub .= _write_children_list($name,$mdecl);
691             }
692             $sub.=q`
693             } else { `;
694             } elsif ($WITH_TREES and ($m->get_role eq '#TREES' or $mdecl->get_role eq '#TREES')) {
695             $close_brace=1;
696             $this_trees_type = $mdecl;
697             $ignore_required=1;
698             $sub.=q`
699             if (!$have_trees and !defined $v and (!defined($pml_trees_type) or $pml_trees_type==$this_trees_type)) {
700             $have_trees=1;`;
701             if ($m->is_required) {
702             $sub.=q`
703             warn "Member '`.$path.'/'.$name.q`' with role #TREES is required but there are no trees, writing empty tag!\n"
704             if !$ctxt->{_trees} and @{$ctxt->{_trees}};`;
705             }
706             $sub.=q`
707             if (defined $close) { undef $close; print $out '>'; }
708             print $out `._indent().q`'<`.$name.q`>';`._indent_inc();
709             if ($mdecl_type == PML_SEQUENCE_DECL) {
710             $sub .= _write_trees_seq($mdecl);
711             } elsif ($mdecl_type == PML_LIST_DECL) {
712             $sub .= _write_trees_list($mdecl);
713             }
714             $sub.=_indent_dec().q`
715             if (defined $close) { undef $close; print $out '>'; }
716             print $out `._indent().q`'';
717             } else { `;
718             }
719             if ($mdecl_type == PML_CONSTANT_DECL and !$m->is_required) {
720             # do not write
721             $sub.=q`
722             if (defined $v and (ref($v) or length $v and $v ne "`.quotemeta($mdecl->get_value).q`")) {
723             warn "Disregarding invalid constant value in member '`.$name.q`': '$v'!\n";
724             }`;
725             } elsif ($m->get_role eq '#KNIT') {
726             my $knit_name = $m->get_knit_name;
727             my $knit_decl = $m->get_knit_content_decl();
728             my $knit_decl_path = $knit_decl->get_decl_path;
729             $knit_decl_path=~s/^!//;
730             $sub.=q`
731             if (defined $v and !ref $v and length $v) {
732             if (defined $close) { undef $close; print $out '>'; }
733             $handlers{'`.$path.'/'.$name.q`' }->('`.$name.q`',$v);
734             } else {`;
735             unless ($name eq $knit_name) {
736             $sub .= q`
737             $v = $data->{'`.$knit_name.q`'};`;
738             }
739             $sub .= q`
740             if (defined $close) { undef $close; print $out '>'; }
741             if (ref $v) {`;
742             if ($KEEP_KNIT) {
743             $sub .= q`
744             $handlers{'`.$knit_decl_path.q`' }->('`.$name.q`',$v);`;
745             } else {
746             $sub.=_knit_code($knit_decl,$knit_decl_path,$name);
747             }
748             $sub .= q`
749             }`;
750             if ($m->is_required) {
751             $sub.=q` else {
752             warn "Required member '`.$path.'/'.$knit_name.q`' missing, writing empty tag!\n";
753             print $out `._indent().q`'<`.$knit_name.q`/>';
754             }`;
755             }
756             $sub.=
757             q`
758             }`;
759             $sub .= q`
760             }` if $close_brace;
761             } elsif ($mdecl_type == PML_LIST_DECL and $mdecl->get_role eq '#KNIT') {
762             my $knit_name = $m->get_knit_name;
763             my $knit_decl = $mdecl->get_knit_content_decl();
764             my $knit_decl_path = $knit_decl->get_decl_path;
765             $knit_decl_path=~s/^!//;
766             if ($name ne $knit_name) {
767             $sub.=q`
768             if (ref $v) {
769             if (defined $close) { undef $close; print $out '>'; }
770             $handlers{'`.$path.'/'.$name.q`' }->('`.$name.q`',$v);
771             } else {
772             $v = $data->{'`.$knit_name.q`'};`;
773             }
774             if ($m->is_required) {
775             $sub.=q` if (!ref $v) {
776             warn "Required member '`.$path.'/'.$knit_name.q`' missing, writing empty tag!\n";
777             if (defined $close) { undef $close; print $out '>'; }
778             print $out `._indent().q`'<`.$knit_name.q`/>';
779             } else {`;
780             } else {
781             $sub .= q`
782             if (ref $v) {
783             if (defined $close) { undef $close; print $out '>'; }`;
784             }
785             if ($KEEP_KNIT) {
786             if (!$WRITE_SINGLE_LM) {
787             $sub .= q`
788             if (@$v==1 and defined($v->[0]) and !(UNIVERSAL::isa($v->[0],'HASH') and keys(%{$v->[0]})==0)) {
789             $handlers{'`.$knit_decl_path.q`' }->('`.$name.q`',$v->[0]);
790             } else {`;
791             }
792             $sub .= q`
793             print $out `._indent().q`'<`.$name.q`>';`._indent_inc().q`
794             $handlers{'`.$knit_decl_path.q`' }->('LM',$_) for @$v;`._indent_dec().q`
795             print $out `._indent().q`'';`;
796             $sub .= q`
797             }` if !$WRITE_SINGLE_LM;
798             } else {
799             if (!$WRITE_SINGLE_LM) {
800             $sub .= q`
801             if (@$v==1) {
802             if (defined $close) { undef $close; print $out '>'; }
803             $v=$v->[0];
804             `._knit_code($knit_decl,$knit_decl_path,$name).q`
805             } else {`;
806             }
807             $sub .= q`
808             if (defined $close) { undef $close; print $out '>'; }
809             print $out `._indent().q`'<`.$name.q`>';`._indent_inc().q`
810             my $l = $v;
811             for $v (@$l) {`._knit_code($knit_decl,$knit_decl_path,'LM').q`
812             }`._indent_dec().q`
813             print $out `._indent().q`'';`;
814             $sub .= q`
815             }` if !$WRITE_SINGLE_LM;
816             }
817             $sub.=
818             q`
819             }`;
820             if ($name ne $knit_name) {
821             $sub.=q`
822             }`;
823             }
824             $sub .= q`
825             }` if $close_brace;
826             } else {
827             # if ($mdecl->get_role eq '#TREES') {
828             # $sub.=q`
829             # $handlers{'`.$path.'/'.$name.q`' }->('`.$name.q`',$v);`;
830             # } else {
831             $sub.=q`
832             if (defined $v and (ref $v or length $v)) {
833             if (defined $close) { undef $close; print $out '>'; }
834             $handlers{'`.$path.'/'.$name.q`' }->('`.$name.q`',$v);
835             }`;
836             # }
837             if ($m->is_required and !$ignore_required ) {
838             $sub.=q` else {
839             warn "Required member '`.$path.'/'.$name.q`' missing, writing empty tag!\n";
840             if (defined $close) { undef $close; print $out '>'; }
841             print $out `._indent().q`'<`.$name.q`/>';
842             }`;
843             }
844             }
845             $sub .= q`
846             }` if $close_brace;
847             }
848             $sub .= _indent_dec().q`
849             if (defined $tag and length $tag) {
850             print $out (defined($close) ? $close : `._indent().q`"");
851             }
852             }`;
853             # print $sub;
854             $src{$src}=$sub;
855             $handlers{$path} = eval($sub); die _nl($sub)."\n".$@.' ' if $@;
856             } elsif ($decl_type == PML_CONTAINER_DECL) {
857             my $src = $schema_name.'__generated_write_container@'.$path;
858             $src=~y{/}{@};
859             my $sub = q`#line 1 ".pml_compile.d/`.$src.q`"
860             sub {
861             my ($tag,$data)=@_;
862             my $v;
863             unless (defined $data) {
864             print $out defined $tag ? '/>' : '>' if !$tag;
865             return;
866             }
867             my $close;
868             my $ctag=$tag;`;
869             my @attributes = $decl->get_attributes;
870             if (@attributes) {
871             $sub.=q`
872             if (defined $tag) {
873             print $out `._indent().q`'<'.$tag ; $close = '>'; $ctag='';`;
874             for my $attr (@attributes) {
875             my $name = $attr->get_name;
876             if ($attr->is_required) {
877             $sub.=q`
878             $v = $data->{'`.$name.q`'};
879             $v='' unless defined $v;
880             $v=~s/&/&/g; $v=~s/
881             print $out ' `.$name.q`'.'="'.$v.'"';
882             `;
883             } else {
884             $sub.=q`
885             $v = $data->{'`.$name.q`'};
886             if (defined($v) && length($v)) {
887             $v=~s/&/&/g; $v=~s/
888             print $out ' `.$name.q`'.'="'.$v.'"';
889             }
890             `;
891             }
892             }
893             $sub .= q`
894             }`;
895             } else {
896             $sub .= q`undef $tag;`;
897             }
898             my $cdecl = $decl->get_content_decl;
899             # TODO: #TREES
900             if ($cdecl) {
901             my $cdecl_type = $cdecl->get_decl_type;
902             my $cpath = $cdecl->get_decl_path;
903             $cpath =~ s/^!//;
904             my $close_brace=0;
905             if ($WITH_TREES and $decl->get_role eq '#NODE' and $cdecl->get_role eq '#CHILDNODES') {
906             $close_brace=1;
907             $sub.=q`
908             if (UNIVERSAL::DOES::does($data,'Treex::PML::Node')) {
909             undef $close;
910             if (defined($ctag)) {
911             if (!length($ctag)) {
912             print $out '>';
913             } elsif ($data->firstson) {
914             print $out `._indent().q`qq{<$ctag>};
915             } else {
916             print $out `._indent().q`qq{<$ctag/>};
917             }
918             }`;
919             if ($cdecl_type == PML_SEQUENCE_DECL) {
920             $sub .= _write_children_seq(undef,$cdecl);
921             } elsif ($cdecl_type == PML_LIST_DECL) {
922             $sub .= _write_children_list(undef,$cdecl);
923             }
924             $sub.=q`
925             if ($data->firstson) {
926             if (defined($ctag) and length($ctag)) {
927             print $out `._indent().q`qq{};
928             } else {
929             print $out `._indent().q`'';
930             }
931             }
932             } else { `;
933             }
934             $sub.=q`
935             $v = $data->{'#content'};`;
936             $sub.=q`
937             undef $close;
938             if (defined $v and (ref $v or length $v)) {
939             $handlers{'`.$cpath.q`' }->($ctag,$v);
940             my $ref = ref($v);
941             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')`)
942             .q`) and @$v==1 and defined($v->[0]) and !(UNIVERSAL::isa($v->[0],'HASH') and keys(%{$v->[0]})==0));
943             } else {
944             if (defined($ctag) and length($ctag)) { print $out `._indent().q`qq{<$ctag/>} } else { $close='/>'; }
945             }`;
946             $sub .= q`
947             }` if $close_brace;
948             } else {
949             $sub .= q`
950             if (defined($ctag) and length($ctag)) { print $out `._indent().q`qq{<$ctag/>} } else {
951             $close='/>'; }`;
952             }
953             $sub .= q`
954             if (defined $tag and length $tag) {
955             print $out (defined($close) ? $close : "");
956             }
957             }`;
958             $src{$src}=$sub;
959             $handlers{$path} = eval($sub); die _nl($sub)."\n".$@.' ' if $@;
960             } elsif ($decl_type == PML_SEQUENCE_DECL) {
961             # print $path,"\n";
962             my $src = $schema_name.'__generated_write_sequence@'.$path;
963             $src=~y{/}{@};
964             # TODO: check it's a Seq, warn about on undefined element
965             local $INDENT=-1 if $decl->is_mixed;
966             my $sub = q`#line 1 ".pml_compile.d/`.$src.q`"
967             sub {
968             my ($tag,$data)=@_;
969             my ($k,$v);
970             unless (defined $data) {`;
971             if ($WITH_TREES and $decl->get_role eq '#TREES') {
972             $sub .= q`
973             if (!$have_trees and (!defined($pml_trees_type) or $pml_trees_type==$decl)) {
974             print $out (length($tag) ? `._indent().q`"<$tag>" : '>') if defined $tag;
975             $have_trees=1;`._indent_inc()._write_trees_seq($decl)._indent_dec().q`
976             print $out (length($tag) ? `._indent().q`"" : '>') if defined $tag;
977             } else {
978             print $out defined $tag ? '/>' : '>' if !$tag;
979             }`;
980             } else {
981             $sub .= q`
982             print $out defined $tag ? '/>' : '>' if !$tag;`;
983             }
984             $sub .= q`
985             return;
986             }
987             print $out (length($tag) ? `._indent().q`"<$tag>" : '>') if defined $tag;`
988             ._indent_inc()._write_seq($decl,$path,'$data')._indent_dec();
989             $sub.=q`
990             if (defined $tag and length $tag) {
991             print $out `._indent().q`"";
992             }
993             }`;
994             $src{$src}=$sub;
995             $handlers{$path} = eval($sub); die _nl($sub)."\n".$@.' ' if $@;
996             $handlers{$path.'/#TEXT'} = eval q`sub { print $out ($_[1]); }` if $decl->is_mixed;
997             } elsif ($decl_type == PML_LIST_DECL) {
998             my $cdecl = $decl->get_content_decl;
999             my $cpath = $cdecl->get_decl_path;
1000             $cpath=~s/^!//;
1001             my $src = $schema_name.'__generated_write_list@'.$path;
1002             $src=~y{/}{@};
1003             # TODO: check it's a List
1004             my $sub = q`#line 1 ".pml_compile.d/`.$src.q`"
1005             sub {
1006             my ($tag,$data)=@_;
1007             my ($v);
1008             if (!defined $data or !@$data) {`;
1009             if ($WITH_TREES and $decl->get_role eq '#TREES') {
1010             $sub .= q`
1011             if (!$have_trees and (!defined($pml_trees_type) or $pml_trees_type==$decl)) {
1012             print $out (length($tag) ? `._indent().q`"<$tag>" : '>') if defined $tag;
1013             $have_trees=1;`._indent_inc()._write_trees_list($decl)._indent_dec().q`
1014             print $out `._indent().q`"" if defined $tag and length $tag;
1015             return;
1016             } else {
1017             print $out defined $tag ? '/>' : '>' if !$tag;
1018             return;
1019             } `;
1020             } else {
1021             $sub .= q`
1022             print $out defined $tag ? '/>' : '>' if !$tag;
1023             return;`;
1024             }
1025             if (!$WRITE_SINGLE_LM) {
1026             $sub .= q`
1027             } elsif (@$data==1 and defined($data->[0]) and !(UNIVERSAL::isa($data->[0],'HASH') and keys(%{$data->[0]})==0)) {
1028             print $out '>' if defined $tag and !length $tag;
1029             $handlers{ '`.$cpath.q`' }->($tag || 'LM',$data->[0]);`;
1030             }
1031             $sub .= q`
1032             } else {
1033             print $out (length($tag) ? `._indent().q`"<$tag>" : '>') if defined $tag;`._indent_inc().q`
1034             for $v (@$data) {
1035             if (defined $v and (ref $v or length $v)) {
1036             $handlers{ '`.$cpath.q`' }->('LM',$v);
1037             } else {
1038             print $out `._indent().q`"";
1039             }
1040             }`._indent_dec().q`
1041             print $out `._indent().q`"" if defined $tag and length $tag;
1042             }
1043             }`;
1044             $src{$src}=$sub;
1045             $handlers{$path} = eval($sub); die _nl($sub)."\n".$@.' ' if $@;
1046             } elsif ($decl_type == PML_ALT_DECL) {
1047             my $cdecl = $decl->get_content_decl;
1048             my $cpath = $cdecl->get_decl_path;
1049             $cpath=~s/^!//;
1050             my $src = $schema_name.'__generated_write_alt@'.$path;
1051             $src=~y{/}{@};
1052             # TODO: check it's an Alt
1053             my $sub = q`#line 1 ".pml_compile.d/`.$src.q`"
1054             sub {
1055             my ($tag,$data)=@_;
1056             unless (defined $data) {
1057             print $out defined $tag ? '/>' : '>' if !$tag;
1058             return;
1059             }
1060             if (!UNIVERSAL::DOES::does($data, 'Treex::PML::Alt')) {
1061             print $out '>' if defined $tag and !length $tag;
1062             $handlers{ '`.$cpath.q`' }->($tag || 'AM',$data);
1063             } elsif (@$data==1) {
1064             print $out '>' if defined $tag and !length $tag;
1065             $handlers{ '`.$cpath.q`' }->($tag || 'AM',$data->[0]);
1066             } elsif (@$data==0) {
1067             print $out defined $tag ? '/>' : '>' if !$tag;
1068             return;
1069             } else {
1070             my $v;
1071             print $out (length($tag) ? `._indent().q`"<$tag>" : '>') if defined $tag;`._indent_inc().q`
1072             for $v (@$data) {
1073             if (defined $v and (ref $v or length $v)) {
1074             $handlers{ '`.$cpath.q`' }->('AM',$v);
1075             } else {
1076             print $out `._indent().q`"";
1077             }
1078             }`._indent_dec().q`
1079             print $out `._indent().q`"" if defined $tag and length $tag;
1080             }
1081             }`;
1082             $src{$src}=$sub;
1083             $handlers{$path} = eval($sub); die _nl($sub)."\n".$@.' ' if $@;
1084             } elsif ($decl_type == PML_CDATA_DECL) {
1085             # TODO: CDATA FORMAT VALIDATION
1086             my $src = $schema_name.'__generated_write_cdata@'.$path;
1087             $src=~y{/}{@};
1088             my $sub = q`#line 1 ".pml_compile.d/`.$src.q`"
1089             sub {
1090             my ($tag,$data)=@_;
1091             print $out (length($tag) ? `._indent().q`"<$tag>" : '>') if defined $tag;
1092             if (defined $data and length $data) {
1093             $data=~s/&/&/g;$data=~s//]]>/g;
1094             print $out $data;
1095             }
1096             print $out "" if defined $tag and length $tag;
1097             }`;
1098             $src{$src}=$sub;
1099             $handlers{$path} = eval($sub); die _nl($sub)."\n".$@.' ' if $@;
1100             } elsif ($decl_type == PML_CHOICE_DECL) {
1101             my $value_hash = $decl->{value_hash};
1102             unless ($value_hash) {
1103             $value_hash={};
1104             @{$value_hash}{@{$decl->{values}}}=();
1105             $decl->{value_hash}=$value_hash;
1106             }
1107             my $src = $schema_name.'__generated_write_choice@'.$path;
1108             $src=~y{/}{@};
1109             my $sub = q`#line 1 ".pml_compile.d/`.$src.q`"
1110             sub {
1111             my ($tag,$data)=@_;
1112             print $out (length($tag) ? `._indent().q`"<$tag>" : '>') if defined $tag;
1113             if (defined $data and length $data) {
1114             warn("Value: '$data' not allowed for choice type '`.$path.q`'; writing anyway!") if !exists $value_hash->{$data};
1115             $data=~s/&/&/g;$data=~s/
1116             print $out $data;
1117             }
1118             print $out "" if defined $tag and length $tag;
1119             }`;
1120             $src{$src}=$sub;
1121             $handlers{$path} = eval($sub); die _nl($sub)."\n".$@.' ' if $@;
1122             } elsif ($decl_type == PML_CONSTANT_DECL) {
1123             my $value = quotemeta($decl->{value});
1124             my $src = $schema_name.'__generated_write_choice@'.$path;
1125             $src=~y{/}{@};
1126             my $sub = q`#line 1 ".pml_compile.d/`.$src.q`"
1127             sub {
1128             my ($tag,$data)=@_;
1129             print $out (length($tag) ? `._indent().q`"<$tag>" : '>') if defined $tag;
1130             if (defined $data and length $data) {
1131             warn("Invalid value '$data' in a constant type '`.$path.q`', should be '`.$value.q`'; writing anyway!") if $data ne "`.$value.q`";
1132             $data=~s/&/&/g;$data=~s/
1133             print $out $data;
1134             }
1135             print $out "" if defined $tag and length $tag;
1136             }`;
1137             $src{$src}=$sub;
1138             $handlers{$path} = eval($sub); die _nl($sub)."\n".$@.' ' if $@;
1139             }
1140             # print "@_\n";
1141             });
1142             $schema->for_each_decl(
1143             sub {
1144             my ($decl)=@_;
1145             my $decl_type=$decl->get_decl_type;
1146             if ($decl_type == PML_ATTRIBUTE_DECL ||
1147             $decl_type == PML_MEMBER_DECL ||
1148             $decl_type == PML_ELEMENT_DECL
1149             ) {
1150             my $parent = $decl->get_parent_decl;
1151             my $path = $parent->get_decl_path . '/'. $decl->get_name;
1152             $path =~ s/^!// if $path;
1153             my $mdecl;
1154             if (!exists($handlers{$path})) {
1155             $mdecl ||= $decl->get_content_decl;
1156             my $mpath = $mdecl->get_decl_path;
1157             $mpath =~ s/^!// if $mpath;
1158             # print "mapping $path -> $mpath ... $handlers{$mpath}\n";
1159             $handlers{$path} = $handlers{$mpath};
1160             }
1161             }
1162             });
1163             }
1164              
1165              
1166             }
1167              
1168             sub _nl {
1169             my ($str)=@_;
1170             my $i=0;
1171             return join "\n", map sprintf("%4d\t",$i++).$_, split /\n/, $str;
1172             }
1173              
1174             1;
1175             __END__