File Coverage

blib/lib/Treex/PML/Instance.pm
Criterion Covered Total %
statement 26 28 92.8
branch n/a
condition n/a
subroutine 10 10 100.0
pod n/a
total 36 38 94.7


line stmt bran cond sub pod time code
1             package Treex::PML::Instance;
2              
3 1     1   1332 use 5.008;
  1         3  
4 1     1   4 use strict;
  1         1  
  1         16  
5 1     1   3 use warnings;
  1         1  
  1         26  
6 1     1   3 use Carp;
  1         2  
  1         46  
7 1     1   4 use Cwd;
  1         1  
  1         216  
8              
9             BEGIN {
10              
11 1     1   6 require Exporter;
12 1         28 import Exporter qw(import);
13              
14             }
15              
16 1     1   3 use Scalar::Util qw(weaken blessed);
  1         1  
  1         38  
17 1     1   4 use UNIVERSAL::DOES;
  1         1  
  1         25  
18 1     1   321 use Treex::PML::Instance::Common qw(:all);
  1         2  
  1         171  
19 1     1   32 use Treex::PML::Schema;
  0            
  0            
20             use Encode;
21             use File::Spec;
22             use URI;
23             use URI::file;
24             our $DEFAULT_ENCODING = 'utf-8';
25              
26             BEGIN {
27              
28             =begin comment
29              
30             TODO
31              
32             Note: correct writing with XSLT requires XML::LibXML >= 1.59 (!!!)
33              
34             (GENERAL):
35              
36             - improve reading/writing trees (use the live object)
37             Postponing because:
38             1/ sequences of tree/no-tree objects are problematic
39             2/ changing this would break binary compatibility
40              
41             - Treex::PML:
42             find_role_in_data,
43             traverse_data($node, $decl, sub($data,$decl,$decl_resolved))
44              
45             - readas DOM => readas PML, where #KNITting means pointing to the same data (if possible).
46             test implementation: breaks old Undo/Redo, but ok with the new "object-preserving" one
47              
48             (XSLT):
49              
50             - support for external xslt processors (maybe a common wrapper)
51             - with LibXSLT, cache the parsed stylesheets
52              
53             DONE:
54              
55             - hash by #ID into appData('id-hash')/{'id-hash'} (knitted instances could be hashed with prefix#,
56             knitted-knitted instances with prefix1#prefix2#...)
57             (this is temporary)
58              
59             =end comment
60              
61             =cut
62              
63             }
64              
65             our %EXPORT_TAGS = (
66             'functions' => [ qw( get_data set_data count_matches for_each_match get_all_matches ) ],
67             'constants' => $Treex::PML::Instance::Common::EXPORT_TAGS{constants},
68             'diagnostics' => $Treex::PML::Instance::Common::EXPORT_TAGS{diagnostics},
69             );
70             $EXPORT_TAGS{'all'} = [ @{ $EXPORT_TAGS{'constants'} },
71             @{ $EXPORT_TAGS{'diagnostics'} },
72             @{ $EXPORT_TAGS{'functions'} },
73             qw( $DEBUG )
74             ];
75              
76             our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
77             our @EXPORT = qw( );
78             our $VERSION = '2.22'; # version template
79              
80             BEGIN {
81             require Treex::PML::IO;
82             require Treex::PML;
83              
84              
85             # FIELDS:
86             use fields qw(
87             _schema
88             _schema-url
89             _schema-inline
90             _types
91             _dom
92             _root
93             _parser
94             _writer
95             _filename
96             _transform_id
97             _status
98             _readas-trees
99             _references
100             _refnames
101             _ref
102             _ref-index
103             _pml_trees_type
104             _no_read_trees
105             _no_references
106             _no_knit
107             _selected_references
108             _selected_references_ids
109             _selected_knits
110             _selected_knits_ids
111             _trees
112             _pml_prolog
113             _pml_epilog
114             _id-hash
115             _log
116             _id_prefix
117             _trees_written
118             _refs_save
119             _save_flags
120             _pi
121             );
122              
123             } # BEGIN
124              
125             use Treex::PML::Instance::Reader;
126             use Treex::PML::Instance::Writer;
127              
128             # PML Instance File
129             sub get_filename {
130             my $filename= $_[0]->{'_filename'};
131             if (blessed($filename) and $filename->isa('URI')
132             and $filename->scheme eq 'file') {
133             return $filename->file;
134             }
135             return $filename;
136             }
137             sub get_url {
138             my $filename= $_[0]->{'_filename'};
139             if ($filename and not (blessed($filename) and $filename->isa('URI'))) {
140             return Treex::PML::IO::make_URI($filename);
141             }
142             return $filename;
143             }
144              
145             sub set_filename {
146             $_[0]->{'_filename'} = Treex::PML::IO::make_abs_URI($_[1]); # 1K faster than cwd
147             }
148             sub get_transform_id { $_[0]->{'_transform_id'}; }
149             sub set_transform_id { $_[0]->{'_transform_id'} = $_[1]; }
150              
151             # Schema
152             sub schema { $_[0]->{'_schema'} }
153             *get_schema = \&schema;
154             sub set_schema { $_[0]->{'_schema'} = $_[1] }
155             sub get_schema_url { $_[0]->{'_schema-url'} }
156             sub set_schema_url { $_[0]->{'_schema-url'} = $_[1]; }
157              
158             # Data
159             sub get_root { $_[0]->{'_root'}; }
160             sub set_root { $_[0]->{'_root'} = $_[1]; }
161             sub get_trees { $_[0]->{'_trees'}; }
162             #sub set_trees { $_[0]->{'_trees'} = $_[1]; }
163             sub get_trees_prolog { $_[0]->{'_pml_prolog'}; }
164             #sub set_trees_prolog { $_[0]->{'_pml_prolog'} = $_[1]; }
165             sub get_trees_epilog { $_[0]->{'_pml_epilog'}; }
166             #sub set_trees_epilog { $_[0]->{'_pml_epilog'} = $_[1]; }
167             sub get_trees_type { $_[0]->{'_pml_trees_type'}; }
168             #sub set_trees_type { $_[0]->{'_pml_trees_type'} = $_[1]; }
169              
170             # References
171             sub get_references_hash {
172             return ($_[0]->{'_references'}||={});
173             }
174             sub set_references_hash { $_[0]->{'_references'} = $_[1]; }
175             sub get_ref_ids_by_name {
176             my ($self,$name)=@_;
177             my $refs = $self->get_refname_hash->{$name};
178             return ref($refs) ? @$refs : ($refs);
179             }
180             sub get_refs_by_name {
181             my ($self,$name)=@_;
182             return map {$self->get_ref($_)} $self->get_ref_ids_by_name;
183             }
184             sub get_refname_hash {
185             return ($_[0]->{'_refnames'}||={});
186             }
187             sub set_refname_hash { $_[0]->{'_refnames'} = $_[1]; }
188             sub get_ref {
189             my ($self,$id)=@_;
190             my $refs = $self->{'_ref'};
191             return $refs ? $refs->{$id} : undef;
192             }
193             sub set_ref {
194             my ($self,$id,$obj)=@_;
195             my $refs = $self->{'_ref'};
196             $self->{'_ref'} = $refs = {} unless ($refs);
197             return $refs->{$id}=$obj;
198             }
199              
200             # Status=1 (if parsed fine)
201             sub get_status { $_[0]->{'_status'}; }
202             #sub set_status { $_[0]->{'_status'} = $_[1]; }
203              
204             sub get_reffiles {
205             my ($ctxt)=@_;
206             my $references = [$ctxt->{'_schema'}->get_named_references];
207             my @refs;
208             if ($references) {
209             foreach my $reference (@$references) {
210             my $refids = $ctxt->{'_refnames'}->{$reference->{name}};
211             if ($refids) {
212             foreach my $refid (ref($refids) ? @$refids : ($refids)) {
213             my $href = $ctxt->{'_references'}->{$refid};
214             if ($href) {
215             _debug("Found '$reference->{name}' as $refid# = '$href'");
216             push @refs,{
217             readas => $reference->{readas},
218             name => $reference->{name},
219             id => $refid,
220             href => $href
221             };
222             } else {
223             _die("No href for $refid# ($reference->{name})")
224             }
225             }
226             } else {
227             _warn("Didn't find any reference to '".$reference->{name}."'\n");
228             }
229             }
230             }
231             return @refs;
232             }
233              
234             sub read_reffiles {
235             my ($ctxt,$opts) = @_;
236             foreach my $ref ($ctxt->get_reffiles()) {
237             my $id = $ref->{id};
238             my $selected = $ctxt->{'_selected_references_ids'}{$id};
239             next if (defined($selected) ? $selected==0 : $ctxt->{'_no_references'});
240             my $readas = $ref->{readas};
241             if (defined $readas) {
242             if ($readas eq 'dom') {
243             $ctxt->readas_dom($id,$ref->{href},$opts);
244             } elsif($readas eq 'trees') {
245             # when translating to Treex::PML::Document,
246             # push to fs-require [$id,$ref->{href}];
247             } elsif($readas eq 'pml') {
248             $ctxt->readas_pml($id,$ref->{href},$opts);
249             } elsif (length($readas)) {
250             _warn("Ignoring references with unknown readas method: '$readas' for reffile id='$id', href='$ref->{href}'\n");
251             }
252             }
253             }
254             }
255              
256             sub readas_pml {
257             my ($ctxt,$refid,$href,$opts)=@_;
258             # embed PML documents
259             my $ref_data;
260             _debug("readas_pml: $refid => $href");
261             my $pml = Treex::PML::Instance->load({
262             filename => $href,
263             no_knit => $ctxt->{_no_knit},
264             selected_knits => $ctxt->{_selected_knits},
265             no_references => $ctxt->{_no_references},
266             selected_references => $ctxt->{_selected_references},
267             ($opts ? %$opts : ()),
268             });
269             $ctxt->{'_ref'} ||= {};
270             $ctxt->{'_ref'}->{$refid}=$pml;
271             $ctxt->{'_ref-index'} ||= {};
272             weaken( $ctxt->{'_ref-index'}->{$refid} = $pml->{'_id-hash'} );
273             1;
274             }
275              
276             # $ctxt, $refid, $href
277             sub readas_dom {
278             my ($ctxt,$refid,$href,$opts)=@_;
279             # embed DOM documents
280             my $ref_data;
281             # if ($opts and $opts->{use_resources}) {
282             # $href = Treex::PML::FindInResourcePaths($href);
283             # }
284              
285             my ($local_file,$remove_file) = Treex::PML::IO::fetch_file($href);
286             my $ref_fh = Treex::PML::IO::open_uri($local_file);
287             _die("Cannot open $href for reading") unless $ref_fh;
288             _debug("readas_dom: $refid => $href");
289             my $parser = $ctxt->{'_parser'} || $ctxt->_xml_parser();
290             if ($ref_fh){
291             eval {
292             $ref_data = $parser->parse_fh($ref_fh, $href);
293             };
294             _die("Error parsing $href $ref_fh $local_file ($@)") if $@;
295             $ref_data->setBaseURI($href) if $ref_data and $ref_data->can('setBaseURI');;
296             $parser->process_xincludes($ref_data);
297             Treex::PML::IO::close_uri($ref_fh);
298             $ctxt->{'_ref'} ||= {};
299             $ctxt->{'_ref'}->{$refid}=$ref_data;
300             $ctxt->{'_ref-index'} ||= {};
301             $ctxt->{'_ref-index'}->{$refid}=_index_by_id($ref_data);
302             if ($href ne $local_file and $remove_file) {
303             local $!;
304             unlink $local_file || _warn("couldn't unlink tmp file $local_file: $!\n");
305             }
306             } else {
307             if ($href ne $local_file and $remove_file) {
308             local $!;
309             unlink $local_file || _warn("couldn't unlink tmp file $local_file: $!\n");
310             }
311             _die("Couldn't open '".$href."': $!");
312             }
313             1;
314             }
315              
316             sub _xml_parser {
317             my ($self,$opts) = @_;
318             my $parser = XML::LibXML->new();
319             $parser->keep_blanks(0);
320             $parser->line_numbers(1);
321             $parser->load_ext_dtd(0);
322             $parser->validation(0);
323             if (ref($opts) and $parser->can('set_options')) {
324             $parser->set_options($opts);
325             }
326             return $parser;
327             }
328              
329             ###################################
330             # CONSTRUCTOR
331             ####################################
332              
333             sub new {
334             my $class = shift;
335             _die('Usage: ' . __PACKAGE__ . '->new()') if ref($class);
336             return fields::new($class);
337             }
338              
339              
340              
341             ###################################
342             # LOAD
343             ###################################
344              
345             sub load {
346             return &Treex::PML::Instance::Reader::load;
347             }
348              
349             sub save {
350             return &Treex::PML::Instance::Writer::save;
351             }
352              
353             sub lookup_id {
354             my ($ctxt,$id)=@_;
355             my $hash = $ctxt->{'_id-hash'} ||= {};
356             return $hash->{ $id };
357             }
358              
359             sub hash_id {
360             my ($ctxt,$id,$object,$check_uniq) = @_;
361             return unless defined($id) and length($id);
362             my $prefix = $ctxt->{'_id_prefix'} || '';
363             $id = $prefix . $id;
364             my $hash = $ctxt->{'_id-hash'} ||= {};
365             if ($check_uniq) { # and $prefix eq ''
366             my $current = $hash->{$id};
367             if (defined $current and $current != $object) {
368             _warn("Duplicated ID '$id'");
369             }
370             }
371             if (ref($object)) {
372             weaken( $hash->{$id} = $object );
373             } else {
374             $hash->{$id} = $object;
375             }
376             }
377              
378             sub _index_by_id {
379             my ($dom) = @_;
380             my %index;
381             $dom->indexElements;
382             for my $node (@{$dom->findnodes('//*/@*[name()="id" or name()="xml:id"]')}) {
383             $index{ $node->value }=$node->ownerElement;
384             }
385             return \%index;
386             }
387              
388             ##########################################
389             # Validation
390             #########################################
391              
392             sub validate_object {
393             my ($ctxt, $object, $type, $opts)=@_;
394             $type->validate_object($object,$opts);
395             }
396              
397             ##########################################
398             # Data pulling
399             #########################################
400              
401              
402             sub get_data {
403             my ($node,$path, $strict) = @_;
404             if (UNIVERSAL::DOES::does($node,'Treex::PML::Instance')) {
405             $node = $node->get_root;
406             }
407             my $val = $node;
408             if (!defined $path) {
409             carp("Treex::PML::Instance::get_data : undefined attribute path!");
410             return;
411             }
412             for my $step (split /\//, $path) {
413             next if $step eq '.';
414             my $is_list = UNIVERSAL::DOES::does($val,'Treex::PML::List');
415             if ($is_list or UNIVERSAL::DOES::does($val,'Treex::PML::Alt')) {
416             if ($step =~ /^\[([-+]?\d+)\]/) {
417             $val =
418             $1>0 ? $val->[$1-1] :
419             $1<0 ? $val->[$1] : undef;
420             } elsif ($strict) {
421             # warn "Can't follow attribute path '$path' (step '$step')\n";
422             return; # ERROR
423             } else {
424             $val = $val->[0];
425             redo unless $step eq ($is_list ? LM : AM);
426             }
427             } elsif (UNIVERSAL::DOES::does($val,'Treex::PML::Seq')) {
428             if ($step =~ /^\[([-+]?\d+)\](.*)/) {
429             $val =
430             $1>0 ? $val->elements_list->[$1-1] :
431             $1<0 ? $val->elements_list->[$1] : undef; # element
432             if ($val) {
433             if (defined $2 and length $2) { # optional name test
434             return if $val->[0] ne $2; # ERROR
435             }
436             $val = $val->[1]; # value
437             }
438             } elsif ($step =~ /^([^\[]+)(?:\[([-+]?\d+)\])?/) {
439             my $i = $2;
440             $val = $val->values($1);
441             if ($i ne q{}) {
442             $val = $i>0 ? $val->[$i-1] :
443             $i<0 ? $val->[$i] : undef;
444             }
445             } else {
446             return; # ERROR
447             }
448             } elsif (ref($val)) {
449             $val = $val->{$step};
450             } elsif (defined($val)) {
451             # warn "Can't follow attribute path '$path' (step '$step')\n";
452             return; # ERROR
453             } else {
454             return undef;
455             }
456             }
457             return $val;
458             }
459              
460             sub get_all {
461             my ($node,$path) = @_;
462             if (UNIVERSAL::DOES::does($node,'Treex::PML::Instance')) {
463             $node = $node->get_root;
464             }
465             my @vals = ($node);
466             my $val;
467             my $redo=0;
468             my $dot;
469             for my $step (ref($path) ? @$path : (split /\//, $path)) {
470             $dot= ($step eq '.');
471             next if $dot;
472             $redo=0;
473             @vals = map {
474             $val=$_;
475             my $is_list = UNIVERSAL::DOES::does($val,'Treex::PML::List');
476             if ($is_list or UNIVERSAL::DOES::does($val,'Treex::PML::Alt')) {
477             if ($step =~ /^\[([-+]?\d+)\]/) {
478             $1>0 ? $val->[$1-1] :
479             $1<0 ? $val->[$1] : ();
480             } else {
481             $redo=1 unless $step eq ($is_list ? 'LM' : 'AM');
482             @$val
483             }
484             } elsif (UNIVERSAL::DOES::does($val,'Treex::PML::Seq')) {
485             # grep { $_->[0] eq $step } @{$val->[0]}
486             if ($step =~ /^\[([-+]?\d+)\](.*)/) {
487             $val =
488             $1>0 ? $val->elements_list->[$1-1] :
489             $1<0 ? $val->elements_list->[$1] : undef; # element
490             $val ?
491             (defined $2 and length $2) ?
492             ($val->[0] eq $2) ? ($val->[1]) : ()
493             : $val->[1]
494             :()
495             } elsif ($step =~ /^([^\[]+)(?:\[([-+]?\d+)\])?/) {
496             my $i = $2;
497             $val = $val->values($1);
498             if (defined $i and length $i) {
499             $i>0 ? $val->[$i-1] :
500             $i<0 ? $val->[$i] : ();
501             } else {
502             @$val
503             }
504             } else { () }
505             } elsif (ref($val)) {
506             ($val->{$step});
507             } else {
508             ()
509             }
510             } @vals;
511             redo if $redo;
512             }
513             return @vals if $dot; # a path may end with a /. to prevent expanding trailing lists and alts
514             return map { (UNIVERSAL::DOES::does($_,'Treex::PML::List') or UNIVERSAL::DOES::does($_,'Treex::PML::Alt')) ? __expand_list_alt($_) : ($_) } @vals;
515             }
516             sub __expand_list_alt {
517             return map { (UNIVERSAL::DOES::does($_,'Treex::PML::List') or UNIVERSAL::DOES::does($_,'Treex::PML::Alt')) ? _expand_list_alt($_) : ($_) } @{$_[0]};
518             }
519              
520             sub set_data {
521             my ($node,$path, $value, $strict) = @_;
522             if (UNIVERSAL::DOES::does($node,'Treex::PML::Instance')) {
523             $node = $node->get_root;
524             }
525             my $val = $node;
526             my @steps = split /\//, $path;
527             while (@steps) {
528             my $step = shift @steps;
529             if (UNIVERSAL::DOES::does($val,'Treex::PML::List') or UNIVERSAL::DOES::does($val,'Treex::PML::Alt')) {
530             if ($step =~ /^\[([-+]?\d+)\]/) {
531             if (@steps) {
532             $val =
533             $1>0 ? $val->[$1-1] :
534             $1<0 ? $val->[$1] : undef;
535             } else {
536             return
537             $1>0 ? ($val->[$1-1]=$value) :
538             $1<0 ? ($val->[$1]=$value) : undef;
539             }
540             } elsif ($strict) {
541             my $msg = "Can't follow attribute path '$path' (step '$step')";
542             croak $msg if ($strict==2);
543             warn $msg."\n";
544             return; # ERROR
545             } else {
546             if (@steps) {
547             $val = $val->[0]{$step};
548             } else {
549             $val->[0]{$step} = $value;
550             return $value;
551             }
552             }
553             } elsif (UNIVERSAL::DOES::does($val,'Treex::PML::Seq')) {
554             if ($step =~ /^\[([-+]?\d+)\](.*)/) {
555             my $i = $1;
556             my $el = $i>0 ? $val->elements_list->[$i-1] :
557             $i<0 ? $val->elements_list->[$i] : undef; # element
558             if (defined $el and defined $2 and length $2 and $el->[0] ne $2) { # optional name test
559             my $msg = "Can't follow attribute path '$path' (step '$step')";
560             croak $msg if ($strict==2);
561             warn $msg."\n";
562             return; # ERROR
563             }
564             if (@steps) {
565             $val = $el->[1];
566             } else {
567             if (UNIVERSAL::DOES::does($value,'Treex::PML::Seq::Element')) {
568             $val = $val->elements_list;
569             return
570             $i>0 ? ($val->[$i-1]=$value) :
571             $i<0 ? ($val->[$i]=$value) : undef;
572             } elsif (ref $val->[$i-1]) {
573             $el->[1]=$value;
574             return $value;
575             } else {
576             my $msg = "Can't follow attribute path '$path' (no sequence element found at step '$step')";
577             croak $msg if ($strict==2);
578             warn $msg."\n";
579             return; # ERROR
580             }
581             }
582             } elsif ($step =~ /^([^\[]+)(?:\[([-+]?\d+)\])?/) {
583             my $i = $2;
584             $val = $val->values($1);
585             unless (@steps) {
586             $val = $1>0 ? $val->[$1-1] :
587             $1<0 ? $val->[$1] : undef;
588             if (defined $val) {
589             if (UNIVERSAL::DOES::does($value,'Treex::PML::Seq::Element')) {
590             $val->[0]=$value->[0];
591             $val->[1]=$value->[1];
592             return $val;
593             } else {
594             $val->[1]=$value;
595             return $value;
596             }
597             } else {
598             my $msg = "Can't follow attribute path '$path' (no sequence element found at step '$step')";
599             croak $msg if ($strict==2);
600             warn $msg."\n";
601             return; # ERROR
602             }
603             }
604             } else {
605             return; # ERROR
606             }
607             } elsif (ref($val)) {
608             if (@steps) {
609             if (!defined($val->{$step}) and $steps[0]!~/^\[/) {
610             $val->{$step}=Treex::PML::Factory->createStructure();
611             }
612             $val = $val->{$step};
613             } else {
614             $val->{$step} = $value;
615             return $value;
616             }
617             } elsif (defined($val)) {
618             my $msg = "Can't follow attribute path '$path' (step '$step')";
619             croak $msg if ($strict==2);
620             warn $msg."\n";
621             return; # ERROR
622             } else {
623             return '';
624             }
625             }
626             return;
627             }
628              
629              
630              
631             sub __match_path {
632             my ($match_paths, $step)=@_;
633             my @r;
634             my $s = $step;
635             $s =~ s/^\[\d+\]//;
636             foreach my $m (@$match_paths) {
637             my ($m_step,@rest) = @{$m->[0]};
638             if (defined $m_step and length($m_step)==0) {
639             # handle //
640             push @r,$m, [\@rest=>$m->[1]];
641             } elsif ($m_step eq $step or $m_step eq '*') {
642             push @r,[\@rest=>$m->[1]];
643             } elsif ($m_step !~ /^\[/) {
644             if (!length($s)) {
645             push @r,$m;
646             } elsif ($s eq $m_step) {
647             push @r,[\@rest=>$m->[1]];
648             }
649             }
650             }
651             return \@r;
652             }
653              
654             sub __split_path {
655             my @p = split m{/}, $_[0];
656             if (@p>0 and length($p[0])==0) { shift @p; }
657             return \@p;
658             }
659              
660             sub for_each_match {
661             my ($obj,$paths,$opts) = @_;
662             $opts||={};
663             my @match_paths;
664             if (UNIVERSAL::isa($paths,'HASH')) {
665             @match_paths = map { [ __split_path($_) => $paths->{$_} ] } keys %$paths;
666             } else {
667             croak("Usage: \$pml->for_each_match( { path1 => callback1, path2 => callback2,...} )\n".
668             " or: Treex::PML::Instance::for_each_match( \$obj, { path1 => callback1, ... } )\n");
669             }
670             my $type;
671             if (UNIVERSAL::DOES::does($obj,'Treex::PML::Instance')) {
672             if (exists $opts->{type}) {
673             $type = $opts->{type}
674             } else {
675             $type = $obj->get_schema->get_root_type
676             }
677             $obj = $obj->get_root;
678             } elsif (exists $opts->{type}) {
679             $type = $opts->{type};
680             }
681             __for_each_match_dispatch('','',\@match_paths,$obj,$type) if @match_paths;
682             }
683              
684             sub __for_each_match_dispatch {
685             my ($path, $step, $match_paths, $v, $type)=@_;
686             $path .= $path eq '/' ? $step : '/'.$step;
687             my $match = __match_path($match_paths,$step);
688             my @m;
689             if (defined $type) {
690             my $dt = $type->get_decl_type;
691             if ($dt==PML_ATTRIBUTE_DECL ||
692             $dt==PML_MEMBER_DECL ||
693             $dt==PML_ELEMENT_DECL) {
694             $type = $type->get_content_decl;
695             }
696             }
697             for my $m (@$match) {
698             if ( @{$m->[0]}>0 ) {
699             push @m, $m;
700             } else {
701             my $cb = $m->[1];
702             my @args;
703             if (UNIVERSAL::isa($cb,'ARRAY')) {
704             ($cb,@args) = @$cb;
705             }
706             $cb->({path => $path, value => $v, type=>$type},@args);
707             }
708             }
709             __for_each_match($path,$v,\@m,$type) if (@m);
710             }
711              
712             sub __for_each_match {
713             my ($p, $val, $match_paths,$type)=@_;
714             if ($val) {
715             my $dt = (defined($type)||undef) && $type->get_decl_type;
716             if (defined($type) and $dt == PML_ALT_DECL and !UNIVERSAL::DOES::does($val, 'Treex::PML::Alt')) {
717             $type=$type->get_content_decl;
718             $dt=$type->get_decl_type;
719             }
720             if ((UNIVERSAL::DOES::does($val, 'Treex::PML::List') or UNIVERSAL::DOES::does($val, 'Treex::PML::Alt'))
721             and (!defined($dt) ||
722             $dt == PML_LIST_DECL ||
723             $dt == PML_ALT_DECL)) {
724             my $no = 1;
725             my $content_type =(defined($type)||undef) && $type->get_content_decl;
726             foreach my $v (@$val) {
727             __for_each_match_dispatch($p,"[$no]",$match_paths,
728             $v,$content_type);
729             $no++;
730             }
731             } elsif ((UNIVERSAL::DOES::does($val, 'Treex::PML::Seq'))
732             and (!defined($dt) || $dt == PML_SEQUENCE_DECL)) {
733             my $no = 1;
734             foreach my $e ($val->elements) {
735             my $name = $e->name;
736             my $content_type = (defined($type)||undef) && $type->get_element_by_name($name);
737             if (!defined($type) || defined($content_type)) {
738             __for_each_match_dispatch($p,"[$no]$name",$match_paths,
739             $e->value, $content_type);
740             }
741             $no++;
742             }
743             } elsif (UNIVERSAL::isa($val,'HASH')
744             and (!defined($dt)
745             || $dt == PML_STRUCTURE_DECL
746             || $dt == PML_CONTAINER_DECL)) {
747             foreach my $name (keys %$val) {
748             my $content_type = (defined($type)||undef) && $type->get_member_by_name($name);
749             if (!defined($type) || defined($content_type)) {
750             __for_each_match_dispatch($p,$name,$match_paths,$val->{$name},
751             $content_type);
752             }
753             }
754             }
755             }
756             }
757             sub get_all_matches {
758             my ($obj,$path_list,$opts) = @_;
759              
760             unless (UNIVERSAL::isa($path_list,"ARRAY")) {
761             if (ref($path_list)) {
762             die "Usage: ".__PACKAGE__."::get_all_matches: expected a string or a list, got $path_list";
763             } else {
764             $path_list = [$path_list];
765             }
766             }
767             my @matches;
768             my $sub = sub { push @matches, $_[0] };
769             for_each_match($obj, { map { $_=>$sub } @$path_list }, $opts);
770             return wantarray ? @matches : \@matches;
771             }
772             sub count_matches {
773             my ($obj,$path_list,$opts) = @_;
774              
775             unless (UNIVERSAL::isa($path_list,"ARRAY")) {
776             if (ref($path_list)) {
777             die "Usage: ".__PACKAGE__."::get_all_matches: expected a string or a list, got $path_list";
778             } else {
779             $path_list = [$path_list];
780             }
781             }
782             my $matches;
783             my $sub = sub { $matches++ };
784             for_each_match($obj, { map { $_=>$sub } @$path_list }, $opts);
785             return $matches;
786             }
787              
788              
789             sub traverse_data {
790             my ($value,$decl,$callback,$opts)=@_;
791             $opts||={};
792             die "Usage: traverse_data(\$data,\$type_decl,\$callback,\$option_hash)"
793             unless blessed($value) and $decl->isa('Treex::PML::Schema::Decl')
794             and ref($callback) eq 'CODE'
795             and ref($opts) eq 'HASH';
796             return _traverse_data($value,$decl,$callback,$opts);
797             }
798              
799             sub _traverse_data {
800             my ($value,$decl,$callback,$opts)=@_;
801             my $decl_is = $decl->get_decl_type;
802             my $desc;
803             $callback->($value,$decl,$opts->{data});
804             if ($decl_is == PML_STRUCTURE_DECL) {
805             my @members = $decl->get_members;
806             if ($opts->{no_childnodes}) {
807             @members = grep {
808             my $role = $_->get_role;
809             !defined($role) or $role ne '#CHILDNODES'
810             } $decl->get_members;
811             }
812             if ($opts->{no_trees}) {
813             @members = grep {
814             my $role = $_->get_role;
815             !defined($role) or $role ne '#TREES'
816             } $decl->get_members;
817             }
818             for (@members) {
819             my $n = $_->get_knit_name;
820             my $v = $value->{$n};
821             _traverse_data($v,$_->get_knit_content_decl,$callback,$opts) if defined $v;
822             }
823             } elsif ($decl_is == PML_CONTAINER_DECL) {
824             my @attrs = $decl->get_attributes;
825             for (@attrs) {
826             my $n = $_->get_name;
827             my $v = $value->{$n};
828             _traverse_data($v,$_->get_content_decl,$callback,$opts) if defined $v;
829             }
830             my $content_decl = $decl->get_knit_content_decl;
831             my $v = $value->{'#content'};
832             _traverse_data($v,$content_decl,$callback,$opts) if $v;
833             } elsif ($decl_is == PML_SEQUENCE_DECL) {
834             my @elems = $decl->get_elements;
835             for (@{$value->elements_list}) {
836             my $n = $_->name;
837             my $v = $_->value;
838             my $e = $decl->get_element_by_name($n);
839             _traverse_data($v,$e,$callback,$opts) if $v and $e;
840             }
841             } elsif ($decl_is == PML_LIST_DECL || $decl_is == PML_ALT_DECL) {
842             if ($decl_is == PML_ALT_DECL and not UNIVERSAL::DOES::does($value,'Treex::PML::Alt')) {
843             $value=Treex::PML::Factory->createAlt([$value],1);
844             }
845             my $content_decl=$decl->get_knit_content_decl;
846             for my $v ($value->values) {
847             _traverse_data($v,$content_decl,$callback,$opts) if defined($v);
848             }
849             } elsif ($decl_is == PML_CHOICE_DECL || $decl_is == PML_CONSTANT_DECL || $decl_is == PML_CDATA_DECL) {
850             } else {
851             die "unhandled data type: $decl\n";
852             }
853             return;
854             }
855              
856              
857              
858             ##########################################
859             # Convert to Treex::PML::Document
860             #########################################
861              
862             sub convert_to_fsfile {
863             my ($ctxt,$fsfile,$opts)=@_;
864              
865             my $schema = $ctxt->{'_schema'};
866             $opts||={};
867              
868             unless (ref($fsfile)) {
869             $fsfile = Treex::PML::Factory->createDocument({ backend => 'PML' } );
870             }
871              
872             $fsfile->changeURL( $ctxt->{'_filename'} );
873             $fsfile->changeEncoding($DEFAULT_ENCODING);
874              
875             if ($schema->isa('Treex::PML::Schema') and not UNIVERSAL::DOES::does($schema, 'Treex::PML::Schema')) {
876             # rebless
877             require Treex::PML::Schema;
878             bless $schema, 'Treex::PML::Schema';
879             }
880             $fsfile->changeMetaData( 'schema', $schema );
881             $fsfile->changeMetaData( 'schema-url', $ctxt->{'_schema-url'} );
882             $fsfile->changeMetaData( 'schema-inline', $ctxt->{'_schema-inline'} );
883             $fsfile->changeMetaData( 'pml_transform', $ctxt->{'_transform_id'} );
884             $fsfile->changeMetaData( 'references', $ctxt->{'_references'} );
885             $fsfile->changeMetaData( 'refnames', $ctxt->{'_refnames'} );
886             $fsfile->changeMetaData( 'fs-require',
887             [ map { [$_->{id},$_->{href}] }
888             grep { $_->{readas} eq 'trees' } $ctxt->get_reffiles() ]
889             );
890              
891             $fsfile->changeAppData( 'ref', $ctxt->{'_ref'} || {} );
892             # $fsfile->changeAppData( 'ref-index', $ctxt->{'_ref-index'} || {} );
893             $fsfile->changeAppData( 'id-hash', $ctxt->{'_id-hash'} );
894              
895             $fsfile->changeMetaData( 'pml_root', $ctxt->{'_root'} );
896             $fsfile->changeMetaData( 'pml_trees_type', $ctxt->{'_pml_trees_type'} );
897             $fsfile->changeMetaData( 'pml_prolog', $ctxt->{'_pml_prolog'} );
898             $fsfile->changeMetaData( 'pml_epilog', $ctxt->{'_pml_epilog'} );
899            
900             if ($ctxt->{'_pi'}) {
901             my @patterns = map { $_->[1] } grep { $_->[0] eq 'tred-pattern' } @{$ctxt->{'_pi'}};
902             my ($hint) = map { $_->[1] } grep { $_->[0] eq 'tred-hint' } @{$ctxt->{'_pi'}} ;
903             for (@patterns, $hint) {
904             next unless defined;
905             s/</
906             s/>/>/g;
907             s/&/&/g;
908             }
909             $fsfile->changePatterns( @patterns );
910             $fsfile->changeHint( $hint );
911             }
912              
913             $fsfile->changeTrees( @{$ctxt->{'_trees'}} ) if $ctxt->{'_trees'};
914              
915             my @nodes = $ctxt->{'_schema'}->find_role('#NODE');
916             my (@order,@hide);
917             for my $path (@nodes) {
918             my $node_decl = $schema->find_type_by_path($path);
919             $node_decl or die "Type-path $path does not lead to anything\n";
920              
921             push @order, map { $_->get_name } $node_decl->find_members_by_role('#ORDER');
922             push @hide, map { $_->get_name } $node_decl->find_members_by_role('#HIDE' );
923             }
924             my %uniq;
925             @order = grep { !$uniq{$_} && ($uniq{$_}=1) } @order;
926             %uniq=();
927             @hide = grep { !$uniq{$_} && ($uniq{$_}=1) } @hide;
928             if (@order>1) {
929             _warn("Treex::PML::Document only supports #ORDER members/attributes with a same name: found {",
930             join(',',@order),"}, using $order[0]!");
931             }
932             if (@hide>1) {
933             _warn("Treex::PML::Document only supports #HIDE members/attributes with a same name: found {",
934             join(',',@hide),"} $hide[0]!");
935             }
936             my $defs = $fsfile->FS->defs;
937             $defs->{$order[0]} = ' N' if @order;
938             $defs->{$hide[0]} = ' H' if @hide;
939              
940             return $fsfile;
941             }
942              
943             ##########################################
944             # Convert from Treex::PML::Document
945             ##########################################
946              
947             sub convert_from_fsfile {
948             my ($ctxt,$fsfile)=@_;
949              
950             unless (ref($ctxt)) {
951             $ctxt = $ctxt->new();
952             }
953              
954             $ctxt->{'_transform_id'} = $fsfile->metaData('pml_transform');
955             $ctxt->{'_filename'} = $fsfile->filename;
956             $ctxt->{'_schema'} = $fsfile->metaData('schema');
957             $ctxt->{'_root'} = $fsfile->metaData('pml_root');
958             $ctxt->{'_schema-inline'} = $fsfile->metaData('schema-inline'); # not used anymore
959             $ctxt->{'_schema-url'} = $fsfile->metaData('schema-url');
960             $ctxt->{'_references'} = $fsfile->metaData('references');
961             $ctxt->{'_refnames'} = $fsfile->metaData('refnames');
962             $ctxt->{'_pml_trees_type'} = $fsfile->metaData('pml_trees_type');
963             $ctxt->{'_pml_prolog'} = $fsfile->metaData('pml_prolog');
964             $ctxt->{'_pml_epilog'} = $fsfile->metaData('pml_epilog');
965             $ctxt->{'_trees'} = Treex::PML::Factory->createList( $fsfile->treeList );
966              
967             $ctxt->{'_refs_save'} = $fsfile->appData('refs_save');
968              
969             $ctxt->{'_ref'} = $fsfile->appData('ref');
970             # $ctxt->{'_ref-index'} = $fsfile->appData('ref-index');
971             $ctxt->{'_id-hash'} = $fsfile->appData('id-hash');
972              
973             my $PIs = $ctxt->{'_pi'} = [];
974             for my $pattern ($fsfile->patterns) {
975             $pattern =~ s/&/&/g;
976             $pattern =~ s/
977             $pattern =~ s/>/>/g;
978             push @$PIs, ['tred-pattern', $pattern];
979             }
980             my $hint = $fsfile->hint;
981             if (defined $hint and length $hint) {
982             $hint =~ s/&/&/g;
983             $hint =~ s/
984             $hint =~ s/>/>/g;
985             push @$PIs, [ 'tred-hint', $hint ];
986             }
987            
988             return $ctxt;
989             }
990              
991              
992             1;
993             __END__