File Coverage

blib/lib/Treex/PML/Instance/Reader.pm
Criterion Covered Total %
statement 34 36 94.4
branch n/a
condition n/a
subroutine 13 13 100.0
pod n/a
total 47 49 95.9


line stmt bran cond sub pod time code
1             package Treex::PML::Instance::Reader;
2             {
3 1     1   1325 use 5.008;
  1         2  
4 1     1   3 use strict;
  1         2  
  1         13  
5 1     1   3 use warnings;
  1         1  
  1         19  
6 1     1   3 no warnings qw(recursion);
  1         1  
  1         30  
7 1     1   3 use Scalar::Util qw(blessed);
  1         0  
  1         38  
8 1     1   3 use UNIVERSAL::DOES;
  1         1  
  1         22  
9              
10 1     1   3 use Carp;
  1         0  
  1         38  
11 1     1   3 use Data::Dumper;
  1         1  
  1         46  
12              
13             BEGIN {
14 1     1   16 our $VERSION = '2.21'; # version template
15             }
16 1     1   3 use List::Util qw(first);
  1         7  
  1         52  
17 1     1   3 use Scalar::Util qw(weaken);
  1         1  
  1         32  
18 1     1   4 use Treex::PML::Instance::Common qw(:diagnostics :constants);
  1         1  
  1         99  
19 1     1   39 use Treex::PML::Schema;
  0            
  0            
20             use XML::LibXML::Reader;
21             use Treex::PML::IO qw(open_uri close_uri rename_uri);
22             use Encode;
23              
24             use constant {
25             XAT_TYPE => 0,
26             XAT_NAME => 1,
27             XAT_VALUE => 1,
28             XAT_NS => 2,
29             XAT_ATTRS => 3,
30             XAT_CHILDREN => 5,
31             XAT_LINE => 4,
32             };
33              
34             our $STRICT =1;
35             our $XTC_FLAGS;
36             use vars qw( $HAVE_XS );
37             BEGIN {
38             if (!$ENV{PML_COMPILE_NO_XS} && eval {
39             require XML::CompactTree::XS;
40             import XML::CompactTree::XS;
41             $HAVE_XS = 1;
42             1;
43             }) {
44             # print STDERR "Using XML::CompactTree::XS\n" if $HAVE_XS;
45             $XTC_FLAGS = XML::CompactTree::XS::XCT_ATTRIBUTE_ARRAY()|
46             XML::CompactTree::XS::XCT_LINE_NUMBERS()|
47             XML::CompactTree::XS::XCT_IGNORE_COMMENTS();
48             } else {
49             require XML::CompactTree;
50             import XML::CompactTree;
51             $XTC_FLAGS = XML::CompactTree::XCT_ATTRIBUTE_ARRAY()|
52             XML::CompactTree::XCT_LINE_NUMBERS()|
53             XML::CompactTree::XCT_IGNORE_COMMENTS();
54             $HAVE_XS = 0;
55             }
56             }
57              
58             my (%handlers,%src,
59             %handler_cache,@handler_cache,
60             %schema_cache,@schema_cache
61             );
62              
63             # TODO:
64             # - create one handler per cdata+format type
65             # - test inline schemas
66              
67             our $CACHE_HANDLERS=1;
68             our $CACHE_SCHEMAS=1;
69             our $MAX_SCHEMA_CACHE_SIZE=50;
70              
71             our $VALIDATE_CDATA=0;
72             our $VALIDATE_SEQUENCES=1;
73             our $BUILD_TREES = 1;
74             our $LOAD_REFFILES = 1;
75             our $KNIT = 1;
76              
77             our $READER_OPTS = {
78             no_cdata => 1,
79             clean_namespaces => 1,
80             expand_entities => 1,
81             expand_xinclude => 1,
82             no_xinclude_nodes => 1,
83             };
84              
85             require Treex::PML;
86              
87             sub _get_handlers_cache_key {
88             my ($schema)=@_;
89             my $key="$schema"; $key=~s/.*=//; # strip class
90             return
91             [
92             $key,
93             join ',',
94             $key,
95             $VALIDATE_CDATA || 0,
96             $VALIDATE_SEQUENCES || 0,
97             $BUILD_TREES || 0,
98             $LOAD_REFFILES || 0,
99             $KNIT || 0,
100             $Treex::PML::Node::TYPE,
101             $Treex::PML::Node::lbrother,
102             $Treex::PML::Node::rbrother,
103             $Treex::PML::Node::parent,
104             $Treex::PML::Node::firstson,
105             ];
106             }
107              
108             sub _get_schema_cache_key {
109             my ($schema_file)=@_;
110             if ((blessed($schema_file) and $schema_file->isa('URI'))) { # assume URI
111             if (($schema_file->scheme||'') eq 'file') {
112             $schema_file = $schema_file->file
113             } else {
114             return '0 '.$schema_file;
115             }
116             }
117             if (-f $schema_file) {
118             my $mtime = (stat $schema_file)[9];
119             return $mtime.' '.$schema_file;
120             }
121             }
122              
123             sub get_cached_schema {
124             my ($schema_file)=@_;
125             return unless defined $schema_file;
126             my $cached = $schema_cache{$schema_file};
127             if ($cached and $schema_cache[-1] ne $schema_file) {
128             # move the last retrieved schema to the end of the queue
129             @schema_cache = ((grep { $_ ne $schema_file } @schema_cache),$schema_file);
130             }
131             return $cached;
132             }
133              
134             sub cache_schema {
135             my ($key,$schema)=@_;
136             push @schema_cache,$key;
137             $schema_cache{$key} = $schema;
138             if (@schema_cache > $MAX_SCHEMA_CACHE_SIZE) {
139             my $del = delete $schema_cache{ shift @schema_cache };
140             delete $handler_cache{ $del }; # delete also from the handler cache
141             @handler_cache = grep { $_->[0] ne $del } @handler_cache;
142             if (exists &Treex::PML::Instance::Writer::forget_schema) {
143             Treex::PML::Instance::Writer::forget_schema($schema);
144             }
145             }
146             }
147              
148             sub get_cached_handlers {
149             my ($key)=@_;
150             my $subkey = $key->[1];
151             my $cached = $handler_cache{ $key->[0] }{ $subkey };
152             if ($cached and $handler_cache[-1][1] ne $subkey) {
153             # move the last retrieved schema to the end of the queue
154             @handler_cache = ((grep { $_->[1] ne $subkey } @handler_cache),$key);
155             }
156             return $cached;
157             }
158              
159             sub cache_handlers {
160             my ($key,$handlers)=@_;
161             my $subkey = $key->[1];
162             push @handler_cache,$key;
163             $handler_cache{$key->[0]}{$subkey} = $handlers;
164             if (@handler_cache > $MAX_SCHEMA_CACHE_SIZE) {
165             my $del = shift @handler_cache;
166             delete $handler_cache{ $del->[0] }{ $del->[1] };
167             }
168             }
169              
170             sub load {
171             my $ctxt = shift;
172             my $opts = shift;
173             if (ref($opts) ne 'HASH') {
174             croak("Usage: Treex::PML::Instance->load({option=>value,...})\n");
175             }
176             if (!ref($ctxt)) {
177             $ctxt = Treex::PML::Factory->createPMLInstance;
178             }
179             my $config = $opts->{config};
180             if ($config and ref(my $load_opts = $config->get_data('options/load'))) {
181             $opts = {%$load_opts, %$opts};
182             }
183             $Treex::PML::Instance::DEBUG = $config->get_data('options/debug') if (!$Treex::PML::Instance::DEBUG and $config and defined($config->get_data('options/debug')));
184              
185             local $READER_OPTS = { %$READER_OPTS, %{$opts->{parser_options} || {}} };
186              
187             if (exists $opts->{filename}) {
188             $ctxt->set_filename( $opts->{use_resources}
189             ? Treex::PML::FindInResourcePaths($opts->{filename})
190             : $opts->{filename}
191             );
192             }
193             my $reader;
194             my $fh_to_close;
195             # print Dumper($opts),"\n";
196             if (defined $opts->{dom}) {
197             $reader = XML::LibXML::Reader->new(DOM => delete $opts->{dom}, %$READER_OPTS);
198             } elsif (defined $opts->{fh}) {
199             $reader = XML::LibXML::Reader->new(IO => $opts->{fh}, %$READER_OPTS,
200             URI => $ctxt->{'_filename'},
201             %$READER_OPTS
202             );
203             } elsif (defined $opts->{string}) {
204             $reader = XML::LibXML::Reader->new(string => $opts->{string}, %$READER_OPTS,
205             URI => $ctxt->{'_filename'},
206             %$READER_OPTS
207             );
208             } elsif (defined $ctxt->{_filename}) {
209             if ($ctxt->{_filename} eq '-') {
210             $reader = XML::LibXML::Reader->new(FD => \*STDIN,
211             %$READER_OPTS,
212             );
213             } else {
214             $fh_to_close = open_uri($ctxt->{_filename});
215             $reader = XML::LibXML::Reader->new(FD => $fh_to_close,
216             URI => $ctxt->{_filename},
217             %$READER_OPTS,
218             );
219             }
220             } else {
221             croak("Treex::PML::Instance->load: at least one of filename, fh, string, or dom arguments are required!");
222             }
223             eval {
224             # check NS
225             $reader->nextElement();
226             my @transform_map =
227             grep {
228             my $id = $_->{id};
229             if (defined($id) and length($id)) {
230             $_
231             } else {
232             warn(__PACKAGE__.": Skipping PML transform in ".$config->get_url." (required attribute id missing):".Dumper($_));
233             ()
234             }
235             }
236             (eval {
237             ($config and $config->get_root) ? $config->get_root->{transform_map}->values : ()
238             });
239             my $root_element = $reader->localName;
240             my $root_ns = $reader->namespaceURI || '';
241             if ($root_ns ne PML_NS
242             or grep { (($_->{ns}||'') eq PML_NS and ($_->{root}||'') eq $root_element) } @transform_map) {
243             if ($config and $config->get_root) {
244             # TRANSFORM
245             $reader->preserveNode;
246             $reader->finish;
247             my $dom = $reader->document;
248             foreach my $transform (@transform_map) {
249             my $id = $transform->{'id'};
250             my ($in_xsl) = $transform->{in};
251             my $type = $in_xsl && $in_xsl->{'type'};
252             next unless ($type and $type =~ /^(?:xslt|perl|pipe|shell)$/);
253             my $test = $transform->{'test'};
254             _debug("Trying transformation rule '$id'");
255             if (($test or $transform->{ns} or $transform->{root})
256             and (!$transform->{ns} or $transform->{ns} eq $root_ns)
257             and (!$transform->{root} or $transform->{root} eq $root_element)
258             and !$test or eval { $dom->find($test) }) {
259             if ($type eq 'xslt') {
260             die "Buggy libxslt version 10127\n" if XSLT_BUG;
261             if (eval { require XML::LibXSLT; 1 }) {
262             my $in_xsl_href = URI->new(Encode::encode_utf8($in_xsl->get_member('href')));
263             next unless $in_xsl_href;
264             _debug("Transforming to PML with XSLT '$in_xsl_href'");
265             $ctxt->{'_transform_id'} = $id;
266             my $params = $in_xsl->content;
267             my %params;
268             %params = map { $_->{'name'} => $_->value } $params->values if $params;
269             $in_xsl_href = Treex::PML::ResolvePath($config->{'_filename'}, $in_xsl_href, 1);
270             my $xslt = XML::LibXSLT->new;
271             my $in_xsl_parsed = $xslt->parse_stylesheet_file($in_xsl_href)
272             || die("Cannot locate XSL stylesheet '$in_xsl_href' for transformation $id\n");
273             $dom = $in_xsl_parsed->transform($dom,%params);
274             $dom->setBaseURI($ctxt->{'_filename'}) if $dom and $dom->can('setBaseURI');
275             $dom->setURI($ctxt->{'_filename'}) if $dom and $dom->can('setURI');
276             $reader = XML::LibXML::Reader->new(DOM => $dom);
277             $reader->nextElement();
278             last;
279             } else {
280             warn "Cannot use XML::LibXSLT for transformation!\n";
281             }
282             } elsif ($type eq 'perl') {
283             my $code = $in_xsl->get_member('command');
284             next unless $code;
285             _debug("Transforming to PML with Perl code: $code");
286             $ctxt->{'_transform_id'} = $id;
287             my $params = $in_xsl->content;
288             my %params;
289             %params = map { $_->{'name'} => $_->value } $params->values if $params;
290             $dom = perl_transform($code, $dom, %params);
291             die("Perl-based transformation '$id' failed: $@") if $@;
292             die("Perl-based transformation didn't return a XML::LibXML::Document object!\n") unless
293             (blessed($dom) and $dom->isa('XML::LibXML::Document'));
294             $dom->setBaseURI($ctxt->{'_filename'}) if $dom and $dom->can('setBaseURI');
295             $dom->setURI($ctxt->{'_filename'}) if $dom and $dom->can('setURI');
296             $reader = XML::LibXML::Reader->new(DOM => $dom);
297             $reader->nextElement();
298             last;
299             } elsif ($type eq 'pipe' or $type eq 'shell') {
300             my $code = $in_xsl->get_member('command');
301             next unless $code;
302             _debug("Transforming to PML with $type code: $code");
303             $ctxt->{'_transform_id'} = $id;
304             my $params = $in_xsl->content;
305             my @params;
306             @params = grep {defined and length } map { $_->{'name'} => $_->value } $params->values if $params;
307             my $tmp_file_in;
308             if ($type eq 'pipe') {
309             (my $fh, $tmp_file_in) = File::Temp::tempfile();
310             $dom->toFH($fh);
311             close $fh;
312             } else {
313             push @params, $dom->URI;
314             }
315             my $tmp_file_out;
316             {
317             local *OLDIN;
318             local *OLDOUT;
319             open OLDOUT,"<&STDOUT";
320             open OLDIN,"<&STDIN";
321              
322             if ($type eq 'pipe') {
323             open STDIN, '<', $tmp_file_in;
324             } else {
325             close STDIN;
326             }
327             (undef, $tmp_file_out) = File::Temp::tempfile();
328             open STDOUT, '>', $tmp_file_out;
329             system($code,@params);
330             unlink $tmp_file_in if $tmp_file_in;
331             open STDIN,"<&OLDIN";
332             open STDOUT,">&OLDOUT";
333             }
334             {
335             open(my $fh, '<', $tmp_file_out) or die("Failed to read output from pipe transformation: $code\n");
336             unlink $tmp_file_out if $tmp_file_out;
337             $reader = XML::LibXML::Reader->new(IO => $fh, URI => $ctxt->{'_filename'});
338             }
339             $reader->nextElement();
340             last;
341             }
342             } else {
343             _debug("failed");
344             }
345             }
346             }
347             if (($reader->namespaceURI||'') ne PML_NS) {
348             my $f = $ctxt->{'_filename'} || '';
349             die("Root element of '$f' isn't in PML namespace: '".($reader->localName()||'')."' ".($reader->namespaceURI()||''))
350             }
351             }
352              
353             $ctxt->{_root} = read_header($ctxt,$reader,$opts);
354             my $schema = $ctxt->{'_schema'};
355             unless (ref($schema)) {
356             die("Instance doesn't provide PML schema!");
357             }
358             unless (length($schema->{version}||'')) {
359             die("PML Schema file ".$ctxt->{'_schema-url'}." does not specify version!");
360             }
361             if (index(SUPPORTED_PML_VERSIONS," ".$schema->{version}." ")<0) {
362             die("Unsupported PML Schema version ".$schema->{version}." in ".$ctxt->{'_schema-url'});
363             }
364              
365             {
366             # preprocess the options selected_references and selected_keys:
367             # we map the reffile names to reffile id's
368             my $sel_knit = ($ctxt->{_selected_knits} =
369             $opts->{selected_knits});
370             my $sel_refs = ($ctxt->{_selected_references} =
371             $opts->{selected_references});
372             croak("Treex::PML::Instance->load: selected_knits must be a Hash ref!")
373             if defined($sel_knit) && ref($sel_knit) ne 'HASH';
374             croak("Treex::PML::Instance->load: selected_references must be a Hash ref!")
375             if defined($sel_refs) && ref($sel_refs) ne 'HASH';
376             ($ctxt->{'_selected_knits_ids'},
377             $ctxt->{'_selected_references_ids'}) = map {
378             my $sel = $_;
379             my $ret = {
380             (defined($sel) ?
381             (map {
382             my $ids = $ctxt->{'_refnames'}->{$_};
383             my $val = $sel->{$_};
384             map { $_=>$val }
385             defined($ids) ? (ref($ids) ? @$ids : ($ids)) : ()
386             } keys %$sel) : ())
387             };
388             $ret
389             } ($sel_knit,$sel_refs);
390             }
391              
392             $ctxt->read_reffiles({use_resources=>$opts->{use_resources}});
393             $ctxt->{'_no_read_trees'} = $opts->{no_trees};
394             local $BUILD_TREES = $opts->{no_trees} ? 0 : 1;
395             local $LOAD_REFFILES = $opts->{no_references} ? 0 : 1;
396             local $KNIT = $opts->{no_knit} ? 0 : $LOAD_REFFILES;
397             local $VALIDATE_CDATA =$opts->{validate_cdata} ? 1 : 0;
398             local $VALIDATE_SEQUENCES =$opts->{ignore_content_patterns} ? 0 : 1;
399             $ctxt->{'_id-hash'}={};
400              
401             prepare_handlers($ctxt);
402             dump_handlers($ctxt) if $opts->{dump_handlers} or $ENV{PML_COMPILE_DUMP};
403             load_data($ctxt,$reader,$opts);
404             while ($reader->read) {
405             if ($reader->nodeType == XML_READER_TYPE_PROCESSING_INSTRUCTION) {
406             push @{$ctxt->{'_pi'}}, [ $reader->name,$reader->value ];
407             }
408             }
409              
410             $handlers{'#initialize'}->($ctxt);
411             $ctxt->{_root} = $handlers{'#root'}->($ctxt->{_root});
412             };
413             ($handlers{'#cleanup'}||sub{})->();
414             %handlers=();
415             close_uri($fh_to_close) if defined $fh_to_close;
416             die $@ if $@;
417             $ctxt->{'_parser'} = undef;
418             return $ctxt;
419             }
420              
421             ######################################################
422             # $ctxt
423              
424             sub _reader_address {
425             my ($ctxt,$reader)=@_;
426             my $line_number=$reader->lineNumber;
427             return " at ".$ctxt->{'_filename'}." line ".$line_number."\n";
428             }
429              
430             sub read_header {
431             my ($ctxt,$reader,$opts)=@_;
432              
433             # manually extract the root node
434             my $root = [XML_READER_TYPE_ELEMENT,
435             $reader->localName,
436             undef,
437             ];
438             # read root node attributes
439             $root->[XAT_LINE] = 0;
440             $root->[XAT_ATTRS] = readAttributes($reader);
441             my $found_head = 0;
442             while ($reader->read == 1) {
443             my $type = $reader->nodeType;
444             if ($type == XML_READER_TYPE_TEXT) { # no CDATA
445             die "Unexpected content of a root element preceding "._reader_address($ctxt,$reader);
446             } elsif ($type == XML_READER_TYPE_ELEMENT) {
447             if ($reader->localName eq 'head' and $reader->namespaceURI eq PML_NS) {
448             # we have head!
449             $found_head = 1;
450             last;
451             } else {
452             die "Unexpected element '".$reader->name."' precedes PML header "._reader_address($ctxt,$reader);
453             }
454             }
455             }
456             unless ($found_head) {
457             die "Did not find PML element: the document '".$ctxt->{_filename}."' is not a PML instance!";
458             }
459              
460             my (%references,%named_references);
461             while ($reader->read == 1) {
462             last if $reader->depth<=1;
463             my $type = $reader->nodeType;
464             if ($type == XML_READER_TYPE_ELEMENT and $reader->namespaceURI eq PML_NS) {
465             my $name = $reader->localName;
466             if ($name eq 'schema') {
467             if ($ctxt->{'_schema'}) {
468             warn "Multiple elements in a PML !";
469             $reader->nextSibling || last;
470             redo;
471             }
472             # read schema here:
473             my %a = @{ readAttributes($reader) || [] };
474             my $schema_file = delete $a{href};
475             if (defined $schema_file and length $schema_file) {
476             $schema_file = URI->new(Encode::encode_utf8($schema_file));
477             # print "$schema_file\n";
478             $ctxt->{'_schema-url'} = $schema_file; # store the original URL, not the resolved one!
479             my $schema_path = Treex::PML::ResolvePath($ctxt->{'_filename'},$schema_file,1);
480             my $key = _get_schema_cache_key($schema_path);
481             if (!($ctxt->{'_schema'}=get_cached_schema($key))) {
482             # print "loading schema $schema_path\n";
483             $ctxt->{'_schema'} =
484             Treex::PML::Factory->createPMLSchema({
485             filename => $schema_path,
486             use_resources => 1,
487             revision_error =>
488             "Error: ".$ctxt->{'_filename'}." requires different revision of PML schema %f: %e\n",
489             %a, # revision_opts
490             });
491             cache_schema($key, $ctxt->{'_schema'}) if $CACHE_SCHEMAS;
492             }
493             } else {
494             # inline schema
495             $ctxt->{'_schema'} = Treex::PML::Factory->createPMLSchema({
496             reader=>$reader,
497             base_url => $ctxt->{'_filename'},
498             use_resources => 1,
499             revision_error =>
500             "Error: ".($ctxt->{'_filename'}||'document')." requires different revision of PML schema %f: %e\n",
501             %a, # revision_opts
502             });
503             }
504             } elsif ($name eq 'references') {
505             if ($reader->read) {
506             while ($reader->depth==3) {
507             if ($reader->localName eq 'reffile' and
508             $reader->namespaceURI eq PML_NS) {
509             my %a = @{ readAttributes($reader) || [] };
510             my ($id,$name,$href) = @a{qw(id name href)};
511             if (defined($id) and length($id) and
512             defined($href) and length($href)) {
513             if (defined $name and length $name) {
514             my $prev_ids = $named_references{ $name };
515             if (defined $prev_ids) {
516             if (ref($prev_ids)) {
517             push @$prev_ids,$id;
518             } else {
519             $named_references{ $name }=Treex::PML::Factory->createAlt([$prev_ids,$id],1);
520             }
521             } else {
522             $named_references{ $name } = $id;
523             }
524             }
525             # Encode: all filenames must(!) be bytes
526             $references{$id} = Treex::PML::ResolvePath
527             ($ctxt->{'_filename'},
528             URI->new(Encode::encode_utf8($href)),
529             $opts->{use_resources});
530             # Resources are not used for non-readas references,
531             # though, they must be handled manually.
532             } else {
533             warn "Missing id or href attribute on a : ignoring\n";
534             }
535             }
536             $reader->nextSibling || last;
537             }
538             }
539             }
540             }
541             }
542             $ctxt->{'_schema'} or
543             die "Did not find element in PML : the document '".$ctxt->{_filename}."' is not a valid PML instance!";
544             $ctxt->{'_references'} = \%references;
545             $ctxt->{'_refnames'} = \%named_references;
546             return $root;
547             }
548              
549             sub prepare_handlers {
550             my ($ctxt,$opts)=@_;
551             %handlers=();
552             my $schema = $ctxt->{'_schema'};
553             my $key=_get_handlers_cache_key($schema);
554             my $cached = get_cached_handlers($key);
555             if ($cached) {
556             %handlers= @$cached;
557             } else {
558             compile_schema($schema);
559             cache_handlers($key,[%handlers]) if $CACHE_HANDLERS;
560             }
561             }
562              
563             sub dump_handlers {
564             my $dir = '.pml_compile.d';
565             (-d $dir) || mkdir($dir) || die "Can't dump to $dir: $!\n";
566             # print "created $dir\n";
567             for my $f (keys %src) {
568             my $dump_file = File::Spec->catfile($dir,$f);
569             open (my $fh, '>:utf8', $dump_file)
570             || die "Can't write to $dump_file: $!\n";
571             my $sub = $src{$f};
572             $sub=~s/^\s*#line[^\n]*\n//;
573             print $fh ($sub);
574             close $fh;
575             }
576             }
577              
578             sub load_data {
579             my ($ctxt,$reader)=@_;
580             my $root = $ctxt->{_root};
581             my ($children);
582             $reader->read if $reader->nodeType == XML_READER_TYPE_END_ELEMENT;
583             if ($HAVE_XS) {
584             my %ns;
585             $children = XML::CompactTree::XS::readLevelToPerl(
586             $reader,
587             $XTC_FLAGS,
588             \%ns
589             );
590             $root->[XAT_NS]=$ns{(PML_NS)} || -1;
591             } else {
592             my %ns;
593             $children = XML::CompactTree::readLevelToPerl(
594             $reader,
595             $XTC_FLAGS,
596             \%ns
597             );
598             $root->[XAT_NS]=$ns{(PML_NS)} || -1;
599             }
600              
601             $root->[XAT_CHILDREN]=$children;
602             # print Dumper($root);
603              
604             # print Dumper({references => $ctxt->{'_references'},
605             # refnames => $ctxt->{'_refnames'}});
606             return $root;
607             }
608              
609             sub _set_trees_seq {
610             my ($ctxt,$type,$data)=@_;
611             $ctxt->{'_pml_trees_type'} = $type;
612             my $trees = $ctxt->{'_trees'} ||= Treex::PML::Factory->createList;
613             my $prolog = $ctxt->{'_pml_prolog'} ||= Treex::PML::Factory->createSeq;
614             my $epilog = $ctxt->{'_pml_epilog'} ||= Treex::PML::Factory->createSeq;
615             my $phase = 0; # prolog
616             foreach my $element (@$data) {
617             my $val = $element->[1];
618             if (UNIVERSAL::DOES::does($val,'Treex::PML::Node')) {
619             if ($phase == 0) {
620             $phase = 1;
621             }
622             if ($phase == 1) {
623             $val->{'#name'} = $element->[0]; # manually delegate_name on this element
624             push @$trees, $val;
625             } else {
626             $prolog->push_element_obj($element);
627             }
628             } else {
629             if ($phase == 1) {
630             $phase = 2; # start epilog
631             }
632             if ($phase == 0) {
633             $prolog->push_element_obj($element);
634             } else {
635             $epilog->push_element_obj($element);
636             }
637             }
638             }
639             }
640              
641             sub readAttributes {
642             my ($r)=@_;
643             my @attrs;
644             my ($prefix,$name);
645             if ($r->moveToFirstAttribute==1) {
646             do {{
647             $prefix = $r->prefix;
648             $name = $r->localName;
649             push @attrs, ($name,$r->value) unless ($prefix and $prefix eq 'xmlns') or (!$prefix and $name eq 'xmlns');
650             }} while ($r->moveToNextAttribute==1);
651             $r->moveToElement;
652             }
653             \@attrs;
654             }
655              
656              
657             sub _paste_last_code {
658             my ($node,$prev,$p)=@_;
659             return qq`
660             #$node\->{'$Treex::PML::Node::rbrother'}=undef;
661             $prev\->{'$Treex::PML::Node::rbrother'}=$node;
662             weaken( $node\->{'$Treex::PML::Node::lbrother'} = $prev );
663             weaken( $node\->{'$Treex::PML::Node::parent'} = $p );
664             `;
665             }
666             sub _paste_first_code {
667             my ($node,$p)=@_;
668             return qq`
669             #$node\->{'$Treex::PML::Node::rbrother'}=undef;
670             #$node\->{'$Treex::PML::Node::lbrother'}=undef;
671             $p\->{'$Treex::PML::Node::firstson'}=$node;
672             weaken( $node\->{'$Treex::PML::Node::parent'} = $p );
673             `;
674             }
675              
676             sub hash_id_code {
677             my ($key,$value)=@_;
678             return q`
679             for (`.$key.q`) {
680             if (defined and length) {
681             if (exists($ID_HASH->{$ID_PREFIX.$_}) and
682             $ID_HASH->{$ID_PREFIX.$_} != `.$value.q`) {
683             warn("Duplicated ID '$_'");
684             }
685             weaken( $ID_HASH->{$ID_PREFIX.$_} = `.$value.q` );
686             }
687             }`
688             }
689              
690             sub _fix_id_member {
691             my ($decl)=@_;
692             return unless $decl;
693             my ($idM) = $decl->find_members_by_role('#ID');
694             if ($idM) {
695             # what follows is a hack fixing buggy PDT 2.0 schemas
696             my $cdecl = $idM->get_content_decl(1); # no_resolve
697             if ($cdecl and $cdecl->get_decl_type == PML_CDATA_DECL and $cdecl->get_format eq 'ID') {
698             $cdecl->set_format('PMLREF');
699             } elsif ($cdecl = $idM->get_content_decl()) {
700             if ($cdecl and $cdecl->get_decl_type == PML_CDATA_DECL and $cdecl->get_format eq 'ID') {
701             warn "Trying to knit object of type '".$decl->get_decl_path."' which has an #ID-attribute ".
702             "'".$idM->get_name."' declared as . ".
703             "Note that the data-type for #ID-attributes in objects knitted as DOM should be ".
704             " (Hint: redeclare with for imported types).";
705             }
706             }
707             }
708             return $idM;
709             }
710              
711             sub knit_code {
712             my ($decl,$assign,$fail)=@_;
713             my $sub = q`
714             if ($ref) {
715             $ref =~ s/^(?:(.*?)\#)//;
716             my $file_id = $1||'';
717             my $do_knit=$selected_knits->{$file_id};
718             unless (defined($do_knit) and $do_knit==0) {
719             my $target;
720             if (length $file_id) {
721             my $f = $parsed_reffile->{ $file_id };
722             if (ref $f) {
723             if (UNIVERSAL::DOES::does($f,'Treex::PML::Instance')) {
724             $target = $f->{'_id-hash'}->{$ref};
725             $target->{'#knit_prefix'}=$file_id;
726             } else { # DOM`;
727             if ($decl) {
728             my $idM = _fix_id_member($decl);
729             my $idM_name = $idM && $idM->get_name;
730             my $decl_path = $decl->get_decl_path; $decl_path =~ s/^!//;
731             $sub .= q`
732             my $dom_node = $ref_index->{$file_id}{$ref} || $f->getElementsById($ref);
733             if (defined $dom_node) {
734             $target = $ID_HASH->{$ID_PREFIX.$file_id.'#'.$ref};
735             if (!defined $target) {
736             my $p = $ID_PREFIX;
737             $ID_PREFIX.=$file_id.'#';
738             my $r = XML::LibXML::Reader->new(string=>''.$dom_node->toString.'');
739             $r->nextElement;
740             # print $r, $dom_node->toString,"\n";
741             my %ns;
742             my $tree = XML::CompactTree`.($HAVE_XS ? '::XS' : '').q`::readSubtreeToPerl($r,`.$XTC_FLAGS.q`,\%ns);
743             my $index = $pml_ns_index;
744             $pml_ns_index = $ns{'`.PML_NS.q`'} || -1;
745             # print "index: $pml_ns_index\n";
746             # print Dumper($tree->[0][XAT_CHILDREN][0]);
747             $target = $handlers{'`.$decl_path.q`'}->($tree->[XAT_CHILDREN][0]);`;
748             if ($idM) {
749             $sub .= q`
750             $target->{`.$idM_name.q`}=$file_id.'#'.$target->{`.$idM_name.q`} if $target;`;
751             }
752             $sub .= q`
753             $pml_ns_index = $index;
754             $weaken=0;
755             $ID_PREFIX=$p;
756             }
757             }`;
758             } else {
759             $sub .= q`
760             warn("DOM knit error: knit content type not declared in the schema!\n");`;
761             }
762             $sub.=q`
763             }
764             } else {
765             warn("warning: KNIT failed: document '$file_id' not loaded\n");
766             }
767             } else {
768             $target = $ID_HASH->{$ID_PREFIX.$ref};
769             }
770             if (ref $target) {`.$assign.q`
771             } else {
772             warn("warning: KNIT failed: ID $ref not found in reffile '$file_id'\n");`.$fail.q`
773             }
774             }
775             }
776             `;
777             return $sub;
778             }
779              
780             sub _report_error {
781             my ($err)=@_;
782             if ($STRICT) {die $err} else {warn $err};
783             }
784             sub _unhandled {
785             my ($what,$pml_file,$el,$path)=@_;
786             _report_error( "Error: $what not declared for type '$path' at ".$pml_file." line ".$el->[XAT_LINE] );
787             return sub{};
788             }
789              
790             sub compile_schema {
791             my ($schema)=@_;
792             my $schema_name = $schema->get_root_decl->get_name;
793             my ($ctxt,$pml_file,$pml_ns_index,$ID_HASH,$ID_PREFIX,$selected_knits,$ref_index,$parsed_reffile,$trees_type,$have_trees);
794             $handlers{'#cleanup'}= sub {
795             undef $_ for ($ctxt,$pml_file,$pml_ns_index,$ID_HASH,$ID_PREFIX,$selected_knits,$ref_index,$parsed_reffile);
796             };
797             $handlers{'#initialize'}= sub {
798             my ($instance)=@_;
799             $ctxt = $instance;
800             $pml_file = $instance->{'_filename'};
801             $pml_ns_index = $instance->{_root}->[XAT_NS];
802             $selected_knits = $instance->{_selected_knits_ids};
803             $ref_index = $instance->{'_ref-index'};
804             $ID_HASH = $instance->{'_id-hash'};
805             $ID_PREFIX = $instance->{'_id_prefix'} || '';
806             $parsed_reffile=$instance->{'_ref'};
807             $have_trees = 0;
808             };
809             $schema->for_each_decl(sub {
810             my ($decl)=@_;
811             # no warnings 'uninitialized';
812             my $decl_type=$decl->get_decl_type;
813             my $path = $decl->get_decl_path;
814             $path =~ s/^!// if $path;
815             return if $decl_type == PML_ATTRIBUTE_DECL ||
816             $decl_type == PML_MEMBER_DECL ||
817             $decl_type == PML_TYPE_DECL ||
818             $decl_type == PML_ELEMENT_DECL;
819             if ($decl_type == PML_ROOT_DECL) {
820             my $name = $decl->get_name;
821             my $cpath = $decl->get_content_decl->get_decl_path;
822             $cpath =~ s/^!//;
823             my $src = $schema_name.'__generated_read_root';
824             my $sub = q`#line 0 ".pml_compile.d/`.$src.q`"
825             sub {
826             my ($p)=@_;
827             unless (ref($p) and
828             $p->[XAT_TYPE] == XML_READER_TYPE_ELEMENT and
829             $p->[XAT_NS] == $pml_ns_index and
830             $p->[XAT_NAME] eq '`.$name.q`'
831             ) {
832             die q(Did not find expected root element '`.$name.q` in ').$pml_file;
833             }
834             return ($handlers{ '`.$cpath.q`' })->($p);
835             }`;
836             $src{$src}=$sub;
837             $handlers{'#root'}=eval $sub; die _nl($sub)."\n".$@.' ' if $@;
838             } elsif ($decl_type == PML_STRUCTURE_DECL) {
839             # print $path,"\n";
840             my $src = $schema_name.'__generated_read_structure@'.$path;
841             $src=~y{/}{@};
842             my $sub = q`#line 0 ".pml_compile.d/`.$src.q`"
843             sub {
844             my ($p)=@_;
845             my $a=$p->[XAT_ATTRS];
846             my $c=$p->[XAT_CHILDREN];
847             # print join(",",map {defined($_) ? $_ : 'undef'} $p->[XAT_NAME],$p->[XAT_LINE],@$p)."\n";
848             my (%s,$k,$v);`;
849             if ($VALIDATE_CDATA) {
850             $sub .= q`
851             if ($a) {
852             while (@$a) {
853             $k=shift @$a;
854             $v=shift @$a;
855             $s{ $k } = ($handlers{ '`.$path.q`/'.$k }||_unhandled("attribute member '$k'",$pml_file,$p,'`.$path.q`'))->( $v );
856             }
857             }`;
858             } else {
859             $sub .= q`
860             %s = @$a if $a;`;
861             }
862             $sub .= q`
863             if ($c) {
864             for my $el (@$c) {
865             unless (ref($el) and $el->[XAT_TYPE] == XML_READER_TYPE_ELEMENT
866             and $el->[XAT_NS] == $pml_ns_index) {
867             if (!ref($el) || $el->[XAT_TYPE] == XML_READER_TYPE_TEXT || $el->[XAT_TYPE] == XML_READER_TYPE_CDATA) {
868             warn q(Ignoring unexpected text content ').$el->[XAT_VALUE].q(' in a structure '`.$path.q`');
869             } elsif ($el->[XAT_TYPE] == XML_READER_TYPE_ELEMENT) {
870             warn q(Ignoring unexpected element ').$el->[XAT_NAME].q(' in a structure '`.$path.q`');
871             }
872             next;
873             }
874             $k = $el->[XAT_NAME];
875             $s{ $k } = ($handlers{ '`.$path.q`/'.$k }||_unhandled("member '$k'",$pml_file,$el,'`.$path.q`'))->($el);
876             }
877             }`;
878             my ($id, $children_member);
879             for my $member ($decl->get_members) {
880             my $mdecl = $member->get_content_decl;
881             if ($member->is_required) {
882             my $name = $member->get_name;
883             if ($mdecl && $mdecl->get_role eq '#TREES') {
884             # this is a bit of a hack:
885             # in this case, if the trees have been read from the member, the member handler returns
886             # a stub value '#TREES' that will get deleted
887             $sub.=q`
888             ref or ($_ eq '#TREES' and delete($s{'`.$name.q`'})) or warn q(Missing required member '`.$name.q`' in structure '`.$path.q`' at ).$pml_file.' line '.$p->[XAT_LINE] for $s{'`.$name.q`'};`;
889             } else {
890             $sub.=q`
891             ref or defined and length or warn q(Missing required member '`.$name.q`' in structure '`.$path.q`' at ).$pml_file.' line '.$p->[XAT_LINE] for $s{'`.$name.q`'};`;
892             }
893             } elsif ($mdecl and $mdecl->get_decl_type == PML_CONSTANT_DECL) {
894             $sub.=q`
895             defined or $_="`.quotemeta($mdecl->{value}).q`" for $s{'`.$member->get_name.q`'};`;
896             }
897             my $role = $member->get_role;
898             if ($KNIT and !$role) {
899             $mdecl ||= $member->get_content_decl;
900             if ($mdecl and $mdecl->get_decl_type == PML_LIST_DECL and
901             $mdecl->get_role eq '#KNIT') {
902             my $mname = $member->get_name;
903             my $knit_name = $mname; $knit_name=~s/\.rf$//;
904             # warn("#KNIT on list not yet implemented: ".$member->get_name."\n");
905             $sub .=q`
906             my $ref_list = $s{'`.$mname.q`'};
907             if ($ref_list) {
908             my (@knit_list,@weaken,$weaken);
909             for my $ref (@$ref_list) {
910             $weaken=1;`
911             .knit_code($mdecl->get_knit_content_decl(),q`
912             push @knit_list, $target;
913             push @weaken, $weaken;`,
914             q`undef $ref_list; last;`)
915             .q`
916             }
917             if (defined $ref_list) {
918             my $i=0;
919             for (@knit_list) {
920             weaken($_) if $weaken[$i++];
921             }
922             $s{'`.$knit_name.q`'}=Treex::PML::Factory->createList(\@knit_list);`;
923             if ($mname ne $knit_name) {
924             $sub .= q`delete $s{'`.$mname.q`'};`;
925             }
926             $sub .= q`
927             } else {
928             warn("KNIT failed on list '`.$mname.q`'");
929             }
930             }`;
931             next;
932             }
933             }
934             if ($role eq '#ID') {
935             $id = $member->get_name;
936             } elsif (!$trees_type and $role eq '#TREES' and $BUILD_TREES) {
937             $mdecl ||= $member->get_content_decl;
938             my $mtype = $mdecl->get_decl_type;
939             if ($mtype == PML_LIST_DECL) {
940             # check that content type is of role #NODE
941             my $cmdecl = $mdecl->get_content_decl;
942             my $cmdecl_type = $cmdecl->get_decl_type;
943             unless ($cmdecl && ($cmdecl->get_role||'') eq '#NODE' &&
944             ($cmdecl_type == PML_STRUCTURE_DECL or
945             $cmdecl_type == PML_CONTAINER_DECL)) {
946             _report_error("List '$path' with role #TREES may only contain structures or containers with role #NODE in schema ".
947             $decl->get_schema->get_url."\n");
948             }
949             $trees_type = $mdecl;
950             $sub .= q`
951             unless ($have_trees) {
952             $ctxt->{'_pml_trees_type'} = $trees_type;
953             $have_trees=1;
954             $ctxt->{'_trees'} = delete $s{'`.$member->get_name.q`'};
955             }`;
956             } elsif ($mtype == PML_SEQUENCE_DECL) {
957             $trees_type = $mdecl;
958             $sub .= q`
959             unless ($have_trees) {
960             $have_trees=1;
961             defined($_) && _set_trees_seq($ctxt,$trees_type,$_->elements_list) for (delete $s{'`.$member->get_name.q`'});
962             }`;
963             } else {
964             _report_error("#TREES member '$path/".$member->get_name."' is neither a list nor a sequence in schema ".$member->get_schema->get_url."\n");
965             }
966             } elsif ($role eq '#CHILDNODES') {
967             if ($children_member) {
968             _report_error("#CHILDNODES role defined on multiple members of type '$path': '$children_member' and '".$member->get_name."' in schema ".$member->get_schema->get_url."\n");
969             } else {
970             $children_member=$member->get_name;
971             }
972             } elsif ($role eq '#KNIT' and $KNIT) {
973             my $mname = $member->get_name;
974             my $knit_name = $mname; $knit_name=~s/\.rf$//;
975             $sub .= q`
976             my $ref = $s{'`.$mname.q`'}; my $weaken = 1;`
977             .knit_code($member->get_knit_content_decl,q`
978             if ($weaken) {
979             weaken( $s{'`.$knit_name.q`'}=$target );
980             } else {
981             $s{'`.$knit_name.q`'}=$target;
982             } `.
983             ($mname ne $knit_name ? q`delete $s{'`.$mname.q`'};` : ''), '');
984             }
985             }
986             if ($decl->get_role eq '#NODE' and $BUILD_TREES) {
987             $sub .= q`
988             my $node = Treex::PML::Factory->createTypedNode($decl,\%s,1);
989             # my $node = bless \%s, 'Treex::PML::Node';
990             # $node->{`.$Treex::PML::Node::TYPE.q`}=$decl;`;
991             if ($children_member) {
992             my $cdecl = $decl->get_member_by_name($children_member)->get_content_decl;
993             my $ctype = $cdecl->get_decl_type;
994             if ($ctype == PML_LIST_DECL) {
995             my $cmdecl = $cdecl->get_content_decl;
996             my $cmdecl_type = $cmdecl->get_decl_type;
997             unless ($cmdecl->get_role eq '#NODE' &&
998             ($cmdecl_type == PML_STRUCTURE_DECL or
999             $cmdecl_type == PML_CONTAINER_DECL)) {
1000             _report_error("List '$path' with role #CHILDNODES may only contain structures or containers with role #NODE in schema '".
1001             $decl->get_schema->get_url."'; got ".$cmdecl->get_decl_type_str." (".$cmdecl->get_decl_path.") with role '".$cmdecl->get_role."' instead!\n");
1002             }
1003             $sub .= q`
1004             my $content = delete $node->{'`.$children_member.q`'};
1005             if ($content) {
1006             my $prev;
1007             foreach my $son (@{ $content }) {
1008             if ($prev) {
1009             `._paste_last_code(qw($son $prev $node)).q`
1010             } else {
1011             `._paste_first_code(qw($son $node)).q`
1012             }
1013             $prev = $son;
1014             }
1015             }`;
1016             } elsif ($ctype == PML_SEQUENCE_DECL) {
1017             for my $edecl ($cdecl->get_elements) {
1018             my $cmdecl = $edecl->get_content_decl;
1019             my $cmdecl_type = $cmdecl->get_decl_type;
1020             unless ($cmdecl->get_role eq '#NODE' &&
1021             ($cmdecl_type == PML_STRUCTURE_DECL or
1022             $cmdecl_type == PML_CONTAINER_DECL)) {
1023             _report_error("Sequence '$path' with role #CHILDNODES may only contain structures or containers with role #NODE in schema '".
1024             $decl->get_schema->get_url."'; got ".$cmdecl->get_decl_type_str." (".$cmdecl->get_decl_path.") with role '".$cmdecl->get_role."' instead!\n");
1025             }
1026             }
1027             $sub .= q`
1028             my $content = delete $node->{'`.$children_member.q`'};
1029             if ($content) {
1030             # $content->delegate_names('#name');
1031             foreach my $element (@{$content->[0]}) { # manually delegate
1032             $element->[1]{'#name'} = $element->[0]; # store element's name in key $key of its value
1033             }
1034             my $prev;
1035             foreach my $son (map $_->[1], @{$content->[0]}) { # $content->values
1036             if ($prev) {
1037             `._paste_last_code(qw($son $prev $node)).q`
1038             } else {
1039             `._paste_first_code(qw($son $node)).q`
1040             }
1041             $prev = $son;
1042             }
1043             }`;
1044             } else {
1045             _report_error("Role #CHILDNODES can only occur on a structure member of type list or sequence, not on ".$cdecl->get_decl_type_str." '$path' in schema ".$cdecl->get_schema->get_url."\n");
1046             }
1047             }
1048             } else {
1049             $sub.=q`
1050             my $node = Treex::PML::Factory->createStructure(\%s,1);
1051             # my $node = bless \%s, 'Treex::PML::Struct';
1052             `;
1053             }
1054             if (defined $id) {
1055             $sub.=hash_id_code(qq(\$s{'$id'}),'$node');
1056             }
1057             $sub.=q`
1058             return $node;
1059             }`;
1060             # print $sub;
1061             $src{$src}=$sub;
1062             $handlers{$path} = eval($sub); die _nl($sub)."\n".$@.' ' if $@;
1063             } elsif ($decl_type == PML_CONTAINER_DECL) {
1064             my %attributes;
1065             @attributes{ map $_->get_name, $decl->get_attributes } = ();
1066             my $cdecl = $decl->get_content_decl;
1067             my $cpath = $cdecl && $cdecl->get_decl_path;
1068             $cpath=~s/^!// if $cpath;
1069             my $src = $schema_name.'__generated_read_container@'.$path;
1070             $src=~y{/}{@};
1071             my $sub = q`#line 0 ".pml_compile.d/`.$src.q`"
1072             sub {
1073             my ($p)=@_;
1074             my $a=$p->[XAT_ATTRS];
1075             my $c=$p->[XAT_CHILDREN];
1076             my (%s,$k,$v,$content,@a_rest);
1077             if ($a) {
1078             while (@$a) {
1079             $k=shift @$a;
1080             $v=shift @$a;
1081             if (exists $attributes{$k}) {`;
1082             if ($VALIDATE_CDATA) {
1083             $sub .= q`
1084             $s{ $k } = ($handlers{ '`.$path.q`/'.$k }||_unhandled("attribute '$k'",$pml_file,$p,'`.$path.q`'))->( $v );`;
1085             } else {
1086             $sub .= q`
1087             $s{ $k } = $v;`;
1088             }
1089             $sub .= q`
1090             } else {
1091             push @a_rest, $k, $v;
1092             }
1093             }
1094             }
1095             $p->[XAT_ATTRS]=\@a_rest;`;
1096             if ($cdecl) {
1097             $sub .= q`
1098             $content = $handlers{ '`.$cpath.q`' }->($p);`;
1099             } else {
1100             $sub .= q`
1101             !$c or !grep { !($_->[XAT_TYPE] == XML_READER_TYPE_WHITESPACE or $_->[XAT_TYPE] == XML_READER_TYPE_SIGNIFICANT_WHITESPACE) } @$c or _report_error(qq(Unexpected content of an empty container type '`.$path.q`' at ).$pml_file.' line '.$p->[XAT_LINE]);`;
1102             }
1103             my $id;
1104             for my $member ($decl->get_attributes) {
1105             if ($member->is_required) {
1106             my $name = $member->get_name;
1107             $sub.=q`
1108             ref or defined and length or _report_error(q(missing required attribute '`.$name.q`' in container '`.$path.q`' at ).$pml_file.' line '.$p->[XAT_LINE]) for $s{'`.$name.q`'};`;
1109             }
1110             if ($member->get_role eq '#ID') {
1111             $id = $member->get_name;
1112             }
1113             }
1114             if ($decl->get_role eq '#NODE' and $BUILD_TREES) {
1115             $sub .= q`
1116             my $node = Treex::PML::Factory->createTypedNode($decl,\%s,1);
1117             # my $node = bless \%s, 'FSNode';
1118             # $node->{`.$Treex::PML::Node::TYPE.q`}=$decl;`;
1119             if ($cdecl and ($cdecl->get_role||'') eq '#CHILDNODES') {
1120             my $ctype = $cdecl->get_decl_type;
1121             if ($ctype == PML_LIST_DECL) {
1122             my $cmdecl = $cdecl->get_content_decl;
1123             my $cmdecl_type = $cmdecl->get_decl_type;
1124             unless ($cmdecl->get_role eq '#NODE' &&
1125             ($cmdecl_type == PML_STRUCTURE_DECL or
1126             $cmdecl_type == PML_CONTAINER_DECL)) {
1127             _report_error("List '$path' with role #CHILDNODES may only contain structures or containers with role #NODE in schema '".
1128             $decl->get_schema->get_url."'; got ".$cmdecl->get_decl_type_str." (".$cmdecl->get_decl_path.") with role '".$cmdecl->get_role."' instead!\n");
1129             }
1130             $sub .= q`
1131             if ($content) {
1132             my $prev;
1133             foreach my $son (@{ $content }) {
1134             if ($prev) {
1135             `._paste_last_code(qw($son $prev $node)).q`
1136             } else {
1137             `._paste_first_code(qw($son $node)).q`
1138             }
1139             $prev = $son;
1140             }
1141             }`;
1142             } elsif ($ctype == PML_SEQUENCE_DECL) {
1143             for my $edecl ($cdecl->get_elements) {
1144             my $cmdecl = $edecl->get_content_decl or
1145             _report_error("Element '".$edecl->get_name."' of sequence '$path' has no content type declaration");
1146             my $cmdecl_type = $cmdecl->get_decl_type;
1147             unless ($cmdecl->get_role eq '#NODE' &&
1148             ($cmdecl_type == PML_STRUCTURE_DECL or
1149             $cmdecl_type == PML_CONTAINER_DECL)) {
1150             _report_error("Sequence '$path' with role #CHILDNODES may only contain structures or containers with role #NODE in schema '".
1151             $decl->get_schema->get_url."'; got ".$cmdecl->get_decl_type_str." (".$cmdecl->get_decl_path.") with role '".$cmdecl->get_role."' instead!\n");
1152             }
1153             }
1154             $sub .= q`
1155             if ($content) {
1156             # $content->delegate_names('#name');
1157             foreach my $element (@{$content->[0]}) { # manually delegate
1158             $element->[1]{'#name'} = $element->[0]; # store element's name in key $key of its value
1159             }
1160             my $prev;
1161             foreach my $son (map $_->[1], @{$content->[0]}) { # $content->values
1162             if ($prev) {
1163             `._paste_last_code(qw($son $prev $node)).q`
1164             } else {
1165             `._paste_first_code(qw($son $node)).q`
1166             }
1167             $prev = $son;
1168             }
1169             }`;
1170             } else {
1171             _report_error("Role #CHILDNODES can only occur on a container content type if it is a list or sequence, not on a ".$cdecl->get_decl_type_str." '".$path."' in schema ".$cdecl->get_schema->get_url."\n");
1172             }
1173             } elsif ($cdecl) {
1174             $sub .= q`
1175             $node->{'#content'} = $content if $content;`;
1176             }
1177             } else {
1178             $sub.=q`
1179             my $node = Treex::PML::Factory->createContainer($content,\%s,1);
1180             # $s{'#content'}=$content if $content;
1181             # my $node = bless \%s, 'Treex::PML::Container';`;
1182             }
1183             if (defined $id) {
1184             $sub.=hash_id_code(qq(\$s{'$id'}),'$node');
1185             }
1186             $sub.=q`
1187             return $node;
1188             }`;
1189             # print $sub;
1190             $src{$src}=$sub;
1191             $handlers{$path} = eval($sub); die _nl($sub)."\n".$@.' ' if $@;
1192             } elsif ($decl_type == PML_SEQUENCE_DECL) {
1193             my $src = $schema_name.'__generated_read_sequence@'.$path;
1194             $src=~y{/}{@};
1195             my $sub = q`#line 0 ".pml_compile.d/`.$src.q`"
1196             sub {
1197             my ($p)=@_;
1198             my $c=$p->[XAT_CHILDREN];
1199             return undef unless $c and @$c;
1200             my @seq;
1201             my $k;
1202             for my $el (@$c) {
1203             if (ref($el) and $el->[XAT_TYPE] == XML_READER_TYPE_ELEMENT
1204             and $el->[XAT_NS] == $pml_ns_index) {
1205             # print "element: $el->[XAT_NAME]\n";
1206             $k = $el->[XAT_NAME];
1207             push @seq, bless [$k, ($handlers{ '`.$path.q`/'.$k }||_unhandled("element '$k'",$pml_file,$el,'`.$path.q`'))->($el)], 'Treex::PML::Seq::Element';`;
1208             if ($decl->is_mixed) {
1209             $sub .= q`
1210             } elsif (!ref($el)) {`;
1211             $sub .= q`
1212             push @seq, bless ['#TEXT',$el], 'Treex::PML::Seq::Element';
1213             } elsif ($el->[XAT_TYPE] == XML_READER_TYPE_TEXT or $el->[XAT_TYPE] == XML_READER_TYPE_CDATA
1214             or $el->[XAT_TYPE] == XML_READER_TYPE_WHITESPACE or $el->[XAT_TYPE] == XML_READER_TYPE_SIGNIFICANT_WHITESPACE) {
1215             push @seq, bless ['#TEXT',$el->[XAT_VALUE]], 'Treex::PML::Seq::Element';
1216             }`;
1217             } else {
1218             $sub .= q`
1219             } elsif (!ref($el) or $el->[XAT_TYPE] == XML_READER_TYPE_TEXT or $el->[XAT_TYPE] == XML_READER_TYPE_CDATA) {
1220             _report_error(q(Unexpected text content in a non-mixed sequence '`.$path.q`' at ).$pml_file.' line '.$p->[XAT_LINE]);
1221             }`;
1222             }
1223             $sub .= q`
1224             }`;
1225             my $content_pattern = $decl->get_content_pattern;
1226             if ($VALIDATE_SEQUENCES and $content_pattern) {
1227             my $re = Treex::PML::Seq::content_pattern2regexp($content_pattern);
1228             $sub .= q`
1229             unless (join('',map '<'.$_->[0].'>',@seq) =~ m{^`.$re.q`$}ox) {
1230             warn("Sequence content (".join(",",map $_->[0], @seq).") does not follow the pattern `.quotemeta($content_pattern).q` in ".$pml_file.' line '.$p->[XAT_LINE]);
1231             }`;
1232             }
1233             if (!$trees_type and $decl->get_role eq '#TREES' and $BUILD_TREES) {
1234             $trees_type = $decl;
1235             $sub .= q`
1236             unless ($have_trees) {
1237             $have_trees=1;
1238             _set_trees_seq($ctxt,$trees_type,\@seq);
1239             return;
1240             }`;
1241             }
1242             if ($content_pattern) {
1243             $sub .= q`
1244             return Treex::PML::Factory->createSeq(\@seq, "`.quotemeta($content_pattern).q`",1);
1245             }`;
1246             } else {
1247             $sub .= q`
1248             return Treex::PML::Factory->createSeq(\@seq, undef, 1);
1249             }`;
1250             }
1251             $src{$src}=$sub;
1252             $handlers{$path} = eval $sub; die _nl($sub)."\n".$@.' ' if $@;
1253             } elsif ($decl_type == PML_LIST_DECL) {
1254             # print $path."\t@".$decl->get_decl_type_str,"\n";
1255             my $cdecl = $decl->get_content_decl
1256             or croak("Invalid PML Schema: list type without content: ",$decl->get_decl_path);
1257             my $cpath = $cdecl->get_decl_path;
1258             $cpath=~s/^!//;
1259             my $src = $schema_name.'__generated_read_list@'.$path;
1260             $src=~y{/}{@};
1261             my $sub = q`#line 0 ".pml_compile.d/`.$src.q`"
1262             sub {
1263             my ($p)=@_;
1264             my $c=$p->[XAT_CHILDREN];
1265             my $a=$p->[XAT_ATTRS];
1266             return undef unless $c and @$c or $a and @$a;
1267             my @list;
1268             my $singleton = $a && @$a ? 1 : 0;
1269             unless ($singleton) {
1270             for my $el (@$c) {
1271             if (!ref($el) or $el->[XAT_TYPE] == XML_READER_TYPE_TEXT or $el->[XAT_TYPE] == XML_READER_TYPE_CDATA) {
1272             $singleton = 1;
1273             last;
1274             } elsif ($el->[XAT_TYPE] == XML_READER_TYPE_ELEMENT) {
1275             $singleton = 1 if $el->[XAT_NAME] ne 'LM' and $el->[XAT_NS] == $pml_ns_index;
1276             last;
1277             }
1278             }}
1279             if ($singleton) {
1280             @list = ($handlers{ '`.$cpath.q`' }->($p));
1281             } else {
1282             for my $el (@$c) {
1283             if (ref($el) and $el->[XAT_TYPE] == XML_READER_TYPE_ELEMENT and $el->[XAT_NS] == $pml_ns_index) {
1284             $el->[XAT_NAME] eq 'LM' or _report_error(q(Unexpected non-LM element ').$el->[XAT_NAME].q(' in a list: '`.$path.q`' at ).$pml_file.' line '.$p->[XAT_LINE]);
1285             push @list, $handlers{ '`.$cpath.q`' }->($el);
1286             } elsif (!ref($el) or $el->[XAT_TYPE] == XML_READER_TYPE_TEXT or $el->[XAT_TYPE] == XML_READER_TYPE_CDATA) {
1287             _report_error(q(Unexpected text content in a list '`.$path.q`' at ).$pml_file.' line '.$p->[XAT_LINE]);
1288             }
1289             }
1290             }`;
1291             if (!$trees_type and $decl->get_role eq '#TREES' and $BUILD_TREES) {
1292             my $cdecl_type = $cdecl->get_decl_type;
1293             unless ($cdecl && ($cdecl->get_role||'') eq '#NODE' &&
1294             ($cdecl_type == PML_STRUCTURE_DECL or
1295             $cdecl_type == PML_CONTAINER_DECL)) {
1296             _report_error("List '$path' with role #TREES may only contain structures or containers with role #NODE in schema ".
1297             $decl->get_schema->get_url."\n");
1298             }
1299             $trees_type = $decl;
1300             $sub .= q`
1301             unless ($have_trees) {
1302             $have_trees = 1;
1303             $ctxt->{'_pml_trees_type'} = $trees_type;
1304             $ctxt->{'_trees'} = Treex::PML::Factory->createList(\@list,1);
1305             return;
1306             }`;
1307             }
1308             $sub .= q`
1309             return Treex::PML::Factory->createList(\@list,1);
1310             }`;
1311             # print $sub;
1312             $src{$src}=$sub;
1313             $handlers{$path} = eval $sub; die _nl($sub)."\n".$@.' ' if $@;
1314             } elsif ($decl_type == PML_ALT_DECL) {
1315             # print $path."\t@".$decl->get_decl_type_str,"\n";
1316             my $cpath = $decl->get_content_decl->get_decl_path;
1317             $cpath=~s/^!//;
1318             my $src = $schema_name.'__generated_read_alt@'.$path;
1319             $src=~y{/}{@};
1320             my $sub = q`#line 0 ".pml_compile.d/`.$src.q`"
1321             sub {
1322             my ($p)=@_;
1323             my $c=$p->[XAT_CHILDREN];
1324             my $a=$p->[XAT_ATTRS];
1325             return undef unless $c and @$c or $a and @$a;
1326             my $singleton = $a && @$a ? 1 : 0;
1327             unless ($singleton) {
1328             for my $el (@$c) {
1329             if (!ref($el) or $el->[XAT_TYPE] == XML_READER_TYPE_TEXT or $el->[XAT_TYPE] == XML_READER_TYPE_CDATA) {
1330             $singleton = 1;
1331             last;
1332             } elsif ($el->[XAT_TYPE] == XML_READER_TYPE_ELEMENT and $el->[XAT_NS] == $pml_ns_index) {
1333             $singleton = 1 if $el->[XAT_NAME] ne 'AM';
1334             last;
1335             }
1336             }
1337             }
1338             if ($singleton) {
1339             return $handlers{ '`.$cpath.q`' }->($p);
1340             } else {
1341             my @alt;
1342             for my $el (@$c) {
1343             if (ref($el) and $el->[XAT_TYPE] == XML_READER_TYPE_ELEMENT and $el->[XAT_NS] == $pml_ns_index) {
1344             $el->[XAT_NAME] eq 'AM' or _report_error(q(Unexpected non-AM element ').$el->[XAT_NAME].q(' in an alt: '`.$path.q`' at ).$pml_file.' line '.$p->[XAT_LINE]);
1345             push @alt, $handlers{ '`.$cpath.q`' }->($el);
1346             } elsif (!ref($el) or $el->[XAT_TYPE] == XML_READER_TYPE_TEXT or $el->[XAT_TYPE] == XML_READER_TYPE_CDATA) {
1347             _report_error(q(Unexpected text content in an alt: '`.$path.q`' at ).$pml_file.' line '.$p->[XAT_LINE]);
1348             }
1349             }
1350             return @alt == 0 ? undef : @alt == 1 ? $alt[0] :
1351             #return bless \@alt, 'Treex::PML::Alt';
1352             Treex::PML::Factory->createAlt(\@alt,1);
1353             }
1354             }
1355             `;
1356             # print $sub;
1357             $src{$src}=$sub;
1358             $handlers{$path} = eval $sub; die _nl($sub)."\n".$@.' ' if $@;
1359              
1360             } elsif ($decl_type == PML_CDATA_DECL) {
1361             my $src = $schema_name.'__generated_read_cdata@'.$path;
1362             $src=~y{/}{@};
1363             my $sub = q`#line 0 ".pml_compile.d/`.$src.q`"
1364             sub {
1365             my ($p)=@_;
1366             my $text;
1367             if (ref($p)) {
1368             my $c = $p->[XAT_CHILDREN];
1369             return undef unless $c and @$c;
1370             my $type;
1371             $text = join '',
1372             map {
1373             if (ref($_)) {
1374             $type = $_->[XAT_TYPE];
1375             if ($type == XML_READER_TYPE_TEXT ||
1376             $type == XML_READER_TYPE_WHITESPACE ||
1377             $type == XML_READER_TYPE_SIGNIFICANT_WHITESPACE ||
1378             $type == XML_READER_TYPE_CDATA) {
1379             $_->[XAT_VALUE]
1380             } elsif ($type == XML_READER_TYPE_ELEMENT) {
1381             _report_error(q(Element found where only character data were expected in element <).$_->[XAT_NAME].q(> of CDATA type '`.$path.q`' at ).$pml_file.' line '.$p->[XAT_LINE]);
1382             }
1383             } else {
1384             $_
1385             }
1386             } @$c;`;
1387             my $format_checker;
1388             if ($VALIDATE_CDATA and $decl->get_format ne 'any') {
1389             $sub .=q`
1390             } else {
1391             $text = $p;
1392             }`;
1393             $format_checker = $decl->_get_format_checker();
1394             if (defined $format_checker) {
1395             if (ref($format_checker) eq 'CODE') {
1396             $sub .= q`
1397             if (defined $text and length $text and !$format_checker->($text)) {`;
1398             } else {
1399             $sub .= q`
1400             if (defined $text and length $text and $text !~ $format_checker) {`;
1401             }
1402             $sub .= q`
1403             warn("CDATA value '$text' does not conform to format '`.$decl->get_format.q`' at ".$pml_file.' line '.$p->[XAT_LINE]);
1404             }`;
1405             }
1406             $sub .= q`
1407             return $text;
1408             }`;
1409             } else {
1410             $sub .=q`
1411             return $text;
1412             } else {
1413             return $p;
1414             }
1415             }`;
1416             }
1417             # print $sub;
1418             $src{$src}=$sub;
1419             $handlers{$path} = eval $sub; die _nl($sub)."\n".$@.' ' if $@;
1420             } elsif ($decl_type == PML_CHOICE_DECL) {
1421             # print $path,"\n";
1422             my $value_hash = $decl->{value_hash};
1423             unless ($value_hash) {
1424             $value_hash={};
1425             @{$value_hash}{@{$decl->{values}}}=();
1426             $decl->{value_hash}=$value_hash;
1427             }
1428             my $src = $schema_name.'__generated_read_choice@'.$path;
1429             $src=~y{/}{@};
1430             my $sub = q`#line 0 ".pml_compile.d/`.$src.q`"
1431             sub {
1432             my ($p)=@_;
1433             my $text;
1434             if (ref($p)) {
1435             my $c = $p->[XAT_CHILDREN];
1436             return undef unless @$c;
1437             $c=$c->[0];
1438             if (ref($c)) {
1439             my $type = $c->[XAT_TYPE];
1440             if ($type == XML_READER_TYPE_TEXT ||
1441             $type == XML_READER_TYPE_WHITESPACE ||
1442             $type == XML_READER_TYPE_SIGNIFICANT_WHITESPACE ||
1443             $type == XML_READER_TYPE_CDATA) {
1444             $text = $c->[XAT_VALUE]
1445             } elsif ($type == XML_READER_TYPE_ELEMENT) {
1446             _report_error(q(Element found where only character data were expected in element <).$p->[XAT_NAME].q(> of choice type '`.$path.q`' at ).$pml_file.' line '.$p->[XAT_LINE]);
1447             }
1448             } else {
1449             $text = $c;
1450             }
1451             } else {
1452             $text=$p;
1453             }
1454             return undef unless defined $text;
1455             exists($value_hash->{$text}) or _report_error(qq(Invalid value '$text' in element <).$p->[XAT_NAME].q(> of choice type '`.$path.q`' at ).$pml_file.' line '.$p->[XAT_LINE]);
1456             return $text;
1457             }`;
1458             # print $sub;
1459             $src{$src}=$sub;
1460             $handlers{$path} = eval $sub; die _nl($sub)."\n".$@.' ' if $@;
1461             } elsif ($decl_type == PML_CONSTANT_DECL) {
1462             # print $path,"\n";
1463             my $value = quotemeta($decl->{value});
1464             my $src = $schema_name.'__generated_read_constant@'.$path;
1465             $src=~y{/}{@};
1466             my $sub = q`#line 0 ".pml_compile.d/`.$src.q`"
1467             sub {
1468             my ($p)=@_;
1469             my $text;
1470             if (ref($p)) {
1471             my $c = $p->[XAT_CHILDREN];
1472             return undef unless $c and @$c;
1473             $c=$c->[0];
1474             if (ref($c)) {
1475             my $type = $c->[XAT_TYPE];
1476             if ($type == XML_READER_TYPE_TEXT ||
1477             $type == XML_READER_TYPE_WHITESPACE ||
1478             $type == XML_READER_TYPE_SIGNIFICANT_WHITESPACE ||
1479             $type == XML_READER_TYPE_CDATA) {
1480             $text = $c->[XAT_VALUE]
1481             } elsif ($type == XML_READER_TYPE_ELEMENT) {
1482             _report_error(q(Unexpected element occurrence in element <).$p->[XAT_NAME].q(> of constant type '`.$path.q`' at ).$pml_file.' line '.$p->[XAT_LINE]);
1483             }
1484             } else {
1485             $text = $c;
1486             }
1487             } else {
1488             $text=$p;
1489             }
1490             !(defined($text) and length($text)) or ($text eq "`.$value.q`") or
1491             _report_error(qq(Invalid value '$text' in element <).$p->[XAT_NAME].q(> of constant type '`.$path.q`' at ).$pml_file.' line '.$p->[XAT_LINE]);
1492             return $text;
1493             }`;
1494             # print $sub;
1495             $src{$src}=$sub;
1496             $handlers{$path} = eval $sub; die _nl($sub)."\n".$@.' ' if $@;
1497             }
1498             # print "@_\n";
1499             });
1500             $schema->for_each_decl(
1501             sub {
1502             my ($decl)=@_;
1503             my $decl_type=$decl->get_decl_type;
1504             if ($decl_type == PML_ATTRIBUTE_DECL ||
1505             $decl_type == PML_MEMBER_DECL ||
1506             $decl_type == PML_ELEMENT_DECL
1507             ) {
1508             my $parent = $decl->get_parent_decl;
1509             my $path = $parent->get_decl_path . '/'. $decl->get_name;
1510             $path =~ s/^!// if $path;
1511             my $mdecl;
1512             if ($decl_type == PML_MEMBER_DECL and $decl->is_required) {
1513             # a hack that fixes missing content of a required member
1514             # containing a construct with the role #TREES
1515             #
1516             # the modified handler returns string '#TREES' instead
1517             # and the value gets deleted in the structure handler
1518             $mdecl = $decl->get_content_decl;
1519             if ($mdecl->get_role eq '#TREES' and $mdecl==$trees_type) {
1520             my $mpath = $mdecl->get_decl_path;
1521             $mpath =~ s/^!// if $mpath;
1522             my $handler = $handlers{$mpath};
1523             $handlers{$path}=sub {
1524             if (!$have_trees and $BUILD_TREES) {
1525             my $ret = &$handler;
1526             return '#TREES' if $have_trees and !defined($ret);
1527             return $ret;
1528             } else {
1529             return &$handler;
1530             }
1531             };
1532             return;
1533             }
1534             }
1535             # print "$path\n";
1536             if (!exists($handlers{$path})) {
1537             $mdecl ||= $decl->get_content_decl;
1538             my $mpath = $mdecl && $mdecl->get_decl_path;
1539             if ($mpath) {
1540             $mpath =~ s/^!//;
1541             # print "mapping $path -> $mpath ... $handlers{$mpath}\n";
1542             $handlers{$path} = $handlers{$mpath};
1543             }
1544             }
1545             }
1546             });
1547             }
1548              
1549             sub _nl {
1550             my ($str)=@_;
1551             my $i=0;
1552             return join "\n", map sprintf("%4d\t",$i++).$_, split /\n/, $str;
1553             }
1554              
1555             }
1556              
1557             {
1558             # outside the main blog so that we leak no lexicals other than $dom
1559             sub perl_transform {
1560             return eval shift();
1561             }
1562             }
1563              
1564             1;
1565             __END__