File Coverage

blib/lib/Treex/PML/Schema.pm
Criterion Covered Total %
statement 84 86 97.6
branch n/a
condition n/a
subroutine 28 28 100.0
pod n/a
total 112 114 98.2


line stmt bran cond sub pod time code
1             # -*- cperl -*-
2             package Treex::PML::Schema;
3              
4              
5 1     1   3 use strict;
  1         1  
  1         25  
6 1     1   3 use warnings;
  1         1  
  1         23  
7 1     1   2 no warnings 'uninitialized';
  1         1  
  1         25  
8              
9 1     1   400 use UNIVERSAL::DOES;
  1         392  
  1         34  
10              
11 1     1   4 use Carp;
  1         1  
  1         45  
12 1     1   332 use Treex::PML::Schema::Constants;
  1         1  
  1         139  
13              
14             BEGIN {
15 1     1   1 our $VERSION = '2.22'; # version template
16 1         3 require Exporter;
17 1         8 import Exporter qw(import);
18 1         4 our @EXPORT = (
19             @Treex::PML::Schema::Constants::EXPORT,
20             qw(PML_VERSION_SUPPORTED),
21             );
22 1         17 our %EXPORT_TAGS = (
23             'constants' => [ @EXPORT ],
24             );
25             } # BEGIN
26              
27 1     1   3 use constant PML_VERSION_SUPPORTED => "1.2";
  1         1  
  1         40  
28              
29 1     1   336 use Treex::PML::Schema::XMLNode;
  1         1  
  1         23  
30 1     1   349 use Treex::PML::Schema::Decl;
  1         1  
  1         20  
31 1     1   310 use Treex::PML::Schema::Root;
  1         1  
  1         19  
32 1     1   322 use Treex::PML::Schema::Template;
  1         1  
  1         34  
33 1     1   338 use Treex::PML::Schema::Derive;
  1         2  
  1         21  
34 1     1   323 use Treex::PML::Schema::Copy;
  1         2  
  1         19  
35 1     1   326 use Treex::PML::Schema::Import;
  1         2  
  1         22  
36 1     1   327 use Treex::PML::Schema::Type;
  1         2  
  1         20  
37 1     1   336 use Treex::PML::Schema::Struct;
  1         2  
  1         21  
38 1     1   338 use Treex::PML::Schema::Container;
  1         5  
  1         23  
39 1     1   327 use Treex::PML::Schema::Seq;
  1         1  
  1         20  
40 1     1   306 use Treex::PML::Schema::List;
  1         2  
  1         19  
41 1     1   312 use Treex::PML::Schema::Alt;
  1         2  
  1         20  
42 1     1   307 use Treex::PML::Schema::Choice;
  1         1  
  1         19  
43 1     1   354 use Treex::PML::Schema::CDATA;
  1         1  
  1         48  
44 1     1   367 use Treex::PML::Schema::Constant;
  1         2  
  1         21  
45 1     1   347 use Treex::PML::Schema::Member;
  1         2  
  1         21  
46 1     1   322 use Treex::PML::Schema::Element;
  1         2  
  1         19  
47 1     1   302 use Treex::PML::Schema::Attribute;
  1         2  
  1         21  
48 1     1   365 use Treex::PML::Schema::Reader;
  0            
  0            
49             use Treex::PML::IO;
50             use XML::Writer;
51              
52             use base qw(Treex::PML::Schema::Template);
53              
54             use Scalar::Util qw(weaken isweak);
55             require Treex::PML;
56              
57             =head1 NAME
58              
59             Treex::PML::Schema - Perl implements a PML schema.
60              
61             =head2 DESCRIPTION
62              
63             This class implements PML schemas. PML schema consists of a set of
64             type declarations of several kinds, represented by objects inheriting
65             from a common base class C.
66              
67             =head2 INHERITANCE
68              
69             This class inherits from L.
70              
71             =head3 Attribute Paths
72              
73             Some methods use so called 'attribute paths' to navigate through
74             nested and referenced type declarations. An attribute path is a
75             '/'-separated sequence of steps, where step can be one of the
76             following:
77              
78             =over 3
79              
80             =item CI
81              
82             '!' followed by name of a named type (this step can only occur
83             as the very first step
84              
85             =item I
86              
87             name (of a member of a structure, element of a sequence or attribute
88             of a container), specifying the type declaration of the specified
89             named component
90              
91             =item C<#content>
92              
93             the string '#content', specifying the content type declaration
94             of a container
95              
96             =item C
97              
98             specifying the type declaration of a list
99              
100             =item C
101              
102             specifying the type declaration of an alt
103              
104             =item C<[>IC<]>
105              
106             where I is a decimal number (ignored) are an equivalent of LM or AM
107              
108             =back
109              
110             Steps of the form LM, AM, and [NNN] (except when occuring at the end
111             of an attribute path) may be omitted.
112              
113             =head2 EXPORT
114              
115             This module exports constants for declaration types.
116              
117             =head2 EXPORT TAGS
118              
119             =over 3
120              
121             =item :constants
122              
123             Export constant symbols (exported by default, too).
124              
125             =back
126              
127             =head2 CONSTANTS
128              
129             See Treex::PML::Schema::Constants.
130              
131             =cut
132              
133             =head1 METHODS
134              
135             =over 3
136              
137             =item Treex::PML::Schema->new ({ option => value, ... })
138              
139             NOTE: Don't call this constructor directly, use Treex::PML::Factory->createPMLSchema() instead!
140              
141             Parses an XML representation of a PML Schema
142             from a string, filehandle, local file, or URL,
143             processing the modular instructions as described in
144              
145             L
146              
147             and returns the corresponding C object.
148              
149             One of the following options must be given:
150              
151             =over 5
152              
153             =item C
154              
155             a XML string to parse
156              
157             =item C
158              
159             a file name or URL
160              
161             =item C
162              
163             a file-handle (IO::File, IO::Pipe, etc.) open for reading
164              
165             =back
166              
167             The following options are optional:
168              
169             =over 5
170              
171             =item C
172              
173             base URL for referred schemas (usefull when parsing from a file-handle or a string)
174              
175             =item C
176              
177             if this option is used with a true value, the parser will attempt to
178             locate referred schemas also in L resource paths.
179              
180             =item C, C, C
181              
182             constraints to the revision number of the schema.
183              
184             =item C
185              
186             if this option is used with a true value, the parser will validate the
187             schema on the fly using a RelaxNG grammar given using the
188             C parameter; if C is not given, the
189             file 'pml_schema_inline.rng' searched for in L resource paths
190             is assumed.
191              
192             =item C
193              
194             a particular RelaxNG grammar to validate against. The value may be an
195             URL or filename for the grammar in the RelaxNG XML format, or a
196             XML::LibXML::RelaxNG object representation. The compact format is not
197             supported.
198              
199             =back
200              
201             =cut
202              
203             BEGIN{
204             my %parse_opts = (
205             KeyAttr => {
206             "member" => "name",
207             "attribute" => "name",
208             "element" => "name",
209             "type" => "name",
210             "template" => "name",
211             "derive" => "name",
212             "let" => "param",
213             "param" => "name",
214             },
215             TextOnly => {
216             description => 'content',
217             revision => 'content',
218             value => 'content',
219             delete => 'content',
220             constant => 'value',
221             },
222             Stringify => {
223             description => 'content',
224             revision => 'content',
225             value => 'content',
226             delete => 'content',
227             },
228             Solitary => {
229             map { $_ => 1 }
230             qw(description revision root cdata structure container sequence constant list alt choice)
231             },
232             Bless => {
233             member => 'Treex::PML::Schema::Member',
234             attribute => 'Treex::PML::Schema::Attribute',
235             element => 'Treex::PML::Schema::Element',
236             type => 'Treex::PML::Schema::Type',
237             root => 'Treex::PML::Schema::Root',
238             structure => 'Treex::PML::Schema::Struct',
239             container => 'Treex::PML::Schema::Container',
240             sequence => 'Treex::PML::Schema::Seq',
241             list => 'Treex::PML::Schema::List',
242             alt => 'Treex::PML::Schema::Alt',
243             cdata => 'Treex::PML::Schema::CDATA',
244             constant => 'Treex::PML::Schema::Constant',
245             choice => 'Treex::PML::Schema::Choice',
246             template => 'Treex::PML::Schema::Template',
247             copy => 'Treex::PML::Schema::Copy',
248             import => 'Treex::PML::Schema::Import',
249             derive => 'Treex::PML::Schema::Derive',
250             '*' => 'Treex::PML::Schema::XMLNode',
251             },
252             DefaultNs => PML_SCHEMA_NS,
253             );
254              
255             sub new {
256             my ($class,$opts, $more_opts)=@_;
257             if (!ref $opts) {
258             # compatibility with older API
259             $more_opts ||= {};
260             $opts = { %$more_opts, string => $opts };
261             }
262              
263             my $file = $opts->{filename};
264              
265             my $base = $opts->{base_url};
266             if (defined $base and length $base) {
267             $file = Treex::PML::ResolvePath($base,$file,$opts->{use_resources});
268             } elsif ($opts->{use_resources}) {
269             $file = Treex::PML::FindInResources($file);
270             }
271             my $schema;
272             my $revision_opts = {
273             map { $_ => delete($opts->{$_}) }
274             qw(revision_error revision minimal_revision maximal_revision)
275             };
276             if (defined($file) and ref($schema = $opts->{schemas}{$file})) {
277             print STDERR "schema $file already hashed\n" if $Treex::PML::Debug;
278             $schema->check_revision($revision_opts);
279             return $schema;
280             }
281             my $parse_opts = {%parse_opts,%$opts};
282             $parse_opts->{Bless}{pml_schema}=$class;
283             $parse_opts->{URL} = $file;
284              
285             my $pml_reader = Treex::PML::Schema::Reader->new($parse_opts);
286             my $reader = $pml_reader->reader;
287             my $version;
288             eval {
289             unless ( $reader->nextElement('pml_schema', PML_SCHEMA_NS)==1 ) {
290             die "Not a PML schema: $file!\n";
291             }
292             $version = $reader->getAttribute('version');
293             $reader->moveToElement;
294             $schema = $pml_reader->parse_element();
295             };
296             if ($@) {
297             die "Treex::PML::Schema::Reader error while parsing: $file near line ".$reader->lineNumber."\n$@\n";
298             return;
299             }
300             if (defined $version and length $version) {
301             unless (cmp_revisions($version,PML_VERSION_SUPPORTED)<=0) {
302             die "Unsupported version of PML schema '$file': this module supports versions up to ".PML_VERSION_SUPPORTED."\n";
303             }
304             } else {
305             warn "WARNING: PML schema '$file' does not specify version! Assuming ".PML_VERSION_SUPPORTED."\n";
306             }
307             $schema->check_revision($revision_opts);
308             $schema->{-VERSION}=$Treex::PML::Schema::VERSION;
309             return $schema;
310             }
311             } # BEGIN
312              
313              
314             =item Treex::PML::Schema->readFrom (filename,opts)
315              
316             An obsolete alias for Treex::PML::Schema->new({%$opts, filename=>$filename}).
317              
318             =cut
319              
320             sub readFrom {
321             my ($self,$file,$opts)=@_;
322             return $self->new({%$opts, filename=>$file});
323             }
324              
325             =item $schema->write ({option => value})
326              
327             This method serializes the Treex::PML::Schema object to XML. See Treex::PML::Schema::XMLNode->write for implementation.
328              
329             IMPORTANT: The resulting schema is simplified, that is all modular instructions
330             are processed and removed from it, see L
331              
332             One of the following options must be given:
333              
334             =over 5
335              
336             =item C
337              
338             a scalar reference to which the XML is to be stored as a string
339              
340             =item C
341              
342             a file name
343              
344             =item C
345              
346             a file-handle (IO::File, IO::Pipe, etc.) open for writing
347              
348             =back
349              
350             One of the following options are optional:
351              
352             =over 5
353              
354             =item C
355              
356             if this option is used with a true value, the writer will not attempt
357             to create backup (tilda) files when overwriting an existing file.
358              
359             =item C
360              
361             if this option is used with a true value, the writer will not add
362             additional newlines and indentatin white-space to the result XML.
363              
364             =back
365              
366             =cut
367              
368             # for implementation see XMLNode.pm
369              
370              
371             =item $schema->get_url ()
372              
373             Return location of the PML schema file.
374              
375             =cut
376              
377             sub get_url { return $_[0]->{URL}; }
378              
379             =item $schema->set_url ($URI)
380              
381             Set location of the PML schema file.
382              
383             =cut
384              
385             sub set_url { return $_[0]->{URL} = Treex::PML::IO::make_URI($_[1]) }
386              
387              
388             =item $schema->get_pml_version ()
389              
390             Return PML version the schema conforms to.
391              
392             =cut
393              
394             sub get_pml_version { return $_[0]->{version}; }
395              
396              
397             =item $schema->get_revision ()
398              
399             Return PML schema revision.
400              
401             =cut
402              
403             sub get_revision { return $_[0]->{revision}; }
404              
405             =item $schema->get_description ()
406              
407             Return PML schema description.
408              
409             =cut
410              
411             sub get_description { return $_[0]->{description}; }
412              
413             =item $schema->get_root_decl ()
414              
415             Return the root type declaration (see C).
416              
417             =cut
418              
419             sub get_root_decl { return $_[0]->{root}; }
420              
421             =item $schema->get_root_type ()
422              
423             Like $schema->get_root_decl->get_content_decl.
424              
425             =cut
426              
427             sub get_root_type {
428             my ($self,$name) = @_;
429             return $self->{root}->get_content_decl;
430             }
431             *get_root_type_obj = \&get_root_type;
432              
433              
434             sub _internal_api_version { return $_[0]->{'-api_version'} }
435              
436             =item $decl->get_decl_type ()
437              
438             Return the constant PML_SCHEMA_DECL (for compatibility with the Treex::PML::Schema::Decl interface).
439              
440             =item $decl->get_decl_type_str ()
441              
442             Return the string 'schema' (for compatibility with the Treex::PML::Schema::Decl interface).
443              
444             =cut
445              
446             sub get_decl_type { return(PML_SCHEMA_DECL); }
447             sub get_decl_type_str { return('schema'); }
448              
449             =item $schema->get_root_name ()
450              
451             Return name of the root element for PML instance.
452              
453             =cut
454              
455             sub get_root_name {
456             my $root = $_[0]->{root};
457             return $root ? $root->{name} : undef;
458             }
459              
460             =item $schema->get_type_names ()
461              
462             Return names of all named type declarations.
463              
464             =cut
465              
466             sub get_type_names {
467             my $types = $_[0]->{type};
468             return $types ? keys(%$types) : ();
469             }
470              
471             =item $schema->get_named_references ()
472              
473             This method returns a list of HASHrefs containing
474             information about a named references to PML instances
475             (each hash will currently have the keys 'name' and 'readas').
476              
477             =cut
478              
479             sub get_named_references {
480             my ($self, $name) = @_;
481             if ($self->{reference}) {
482             return map { my $r=$_; my $h = { map { ($_=>$r->{$_}) } @{$r->{'-attributes'}} }; $h }
483             @{$self->{reference}} ;
484             }
485             return;
486             }
487              
488             =item $schema->get_named_reference_info (name)
489              
490             This method retrieves information about a specific named instance
491             reference as a hash (currently with keys 'name' and 'readas').
492              
493             =cut
494              
495             sub get_named_reference_info {
496             my ($self, $name) = @_;
497             if ($self->{reference}) {
498             return { map { my $r=$_; map { $_=>$r->{$_} } @{$r->{'-attributes'}} }
499             grep { defined($_->{name}) and $_->{name} eq $name } @{$self->{reference}} };
500             }
501             return;
502             }
503              
504             =item Treex::PML::Schema::cmp_revisions($A, $B)
505              
506             This function compares two schema revision strings according to the
507             ruls described in the PML specification. Returns -1 if revision $A
508             precedes revision $B, 0 if the revisions are equal (equivalent), and 1
509             if revision $A follows revision $B.
510              
511             =cut
512              
513             # compare two revision numbers
514             sub cmp_revisions {
515             my ($my_revision,$revision)=@_;
516             my @my_revision = split(/\./,$my_revision);
517             my @revision = split(/\./,$revision);
518             my $cmp=0;
519             while ($cmp==0 and (@my_revision or @revision)) {
520             $cmp = (shift(@my_revision) <=> shift(@revision));
521             }
522             return $cmp;
523             }
524              
525             # compare schema revision number with a given revision number
526             sub _match_revision {
527             my ($self,$revision)=@_;
528             my $my_revision=$self->{revision} || 0;
529             return cmp_revisions($self->{revision} || 0, $revision);
530             }
531              
532             # for internal use only
533             sub _resolve_type {
534             my ($self,$type)=@_;
535             return $type unless ref($type);
536             my $ref = $type->{type};
537             if ($ref) {
538             my $rtype = $self->{type}{$ref};
539             if (ref($rtype)) {
540             return $rtype;
541             } else {
542             # couldn't resolve
543             warn "No declaration for type '$ref' in schema '".$self->get_url."'\n";
544             return $type->{type};
545             }
546             } else {
547             return $type;
548             }
549             }
550              
551             =item $schema->for_each_decl (sub{...})
552              
553             This method traverses all nested declarations and sub-declarations and
554             calls a given subroutine passing the sub-declaration object as a
555             parameter.
556              
557             =cut
558              
559             sub for_each_decl {
560             my ($self,$sub) = @_;
561             if (ref $self->{root}) {
562             $self->{root}->for_each_decl($sub);
563             }
564             for my $d (qw(template type)) {
565             if (ref $self->{$d}) {
566             foreach (values %{$self->{$d}}) {
567             $_->for_each_decl($sub);
568             }
569             }
570             }
571             }
572              
573             # traverse type data structure and collect types referred via
574             # type="type-name" declarations in the refferred hash
575             sub _get_referred_types {
576             my ($self,$type,$referred) = @_;
577             $type->for_each_decl(
578             sub {
579             my ($type)=@_;
580             return unless ref($type);
581             if (defined($type->{type}) and length($type->{type}) and !exists($referred->{$type->{type}})) {
582             # this type declaration reffers to another type - get it
583             my $resolved = $self->_resolve_type($type);
584             $referred->{$type->{type}} = $resolved;
585             $self->_get_referred_types($resolved,$referred) if ref $resolved;
586             }
587             });
588             }
589              
590             # import given named type and all named types it requires
591             # from src_schema into the current schema (self)
592             sub _import_type {
593             my ($self,$src_schema, $name) = @_;
594             unless (exists $src_schema->{type}{$name}) {
595             croak "Cannot import type '$name' from '$src_schema->{URL}' to '$self->{URL}': type not declared in the source schema\n";
596             }
597             my $type = $src_schema->{type}{$name};
598             my %referred = ($name => $type);
599             $src_schema->_get_referred_types($type,\%referred);
600             foreach my $n (keys %referred) {
601             unless (exists $self->{type}{$n}) {
602             my $parent = $referred{$n}->{-parent};
603             if (defined $parent) {
604             $self->{type}{$n}=Treex::PML::CloneValue($referred{$n},[$parent], [$self]);
605             } else {
606             $self->{type}{$n}=Treex::PML::CloneValue($referred{$n});
607             }
608             } else {
609            
610             }
611             }
612             }
613              
614             sub __fmt {
615             my ($string,$fmt) =@_;
616             $string =~ s{%(.)}{ $1 eq "%" ? "%" :
617             exists($fmt->{$1}) ? $fmt->{$1} : "%$1" }eg;
618             return $string;
619             }
620              
621             =item $schema->check_revision({ option=>value })
622              
623             Check that schema revision satisfies given constraints. The following options are suported:
624              
625             C: exact revision number to match
626              
627             C: minimal revision number to match
628              
629             C: maximal revision number to match
630              
631             C: an optional error message format string with %f
632             mark for the schema filename or URL and %e for the error
633             string. Defaults to 'Error: wrong schema revision of %f: %e';
634              
635             =cut
636              
637             sub check_revision {
638             my ($self,$opts)=@_;
639              
640             my $error = $opts->{revision_error} || 'Error: wrong schema revision of %f: %e';
641             if ($opts->{revision} and
642             $self->_match_revision($opts->{revision})!=0) {
643             croak(__fmt($error, { 'e' => "required $opts->{revision}, got $self->{revision}",
644             'f' => $self->{URL}}));
645             } else {
646             if ($opts->{minimal_revision} and
647             $self->_match_revision($opts->{minimal_revision})<0) {
648             croak(__fmt($error, { 'e' => "required at least $opts->{minimal_revision}, got $self->{revision}",
649             'f' => $self->{URL}}));
650             }
651             if ($opts->{maximal_revision} and
652             $self->_match_revision($opts->{maximal_revision})>0) {
653             croak(__fmt($error, { 'e' => "required at most $opts->{maximal_revision}, got $self->{revision}",
654             'f' => $self->{URL}}));
655             }
656             }
657             }
658              
659             =item $schema->convert_from_hash
660              
661             Compatibility method building the schema object from a nested hash
662             structure created by XML::Simple which was used in older
663             implementations. This is useful for upgrading objects stored in old
664             binary dumps.
665              
666             =cut
667              
668             sub convert_from_hash {
669             my $class = shift;
670             my $schema_hash;
671             if (ref($class)) {
672             $schema_hash = $class;
673             $class = ref( $schema_hash );
674             } else {
675             $schema_hash = shift;
676             bless $schema_hash,$class;
677             }
678             $schema_hash->{-api_version} ||= '2.0';
679             $schema_hash->{'-xml_name'}='pml_schema';
680             $schema_hash->{-attributes}=[qw(xmlns version)];
681             if (ref $schema_hash->{reference}) {
682             for my $ref (@{$schema_hash->{reference}}) {
683             $ref->{'-xml_name'}='reference';
684             $ref->{'-attributes'}=[qw(name readas)];
685             bless $ref,'Treex::PML::Schema::XMLNode';
686             weaken($ref->{-parent}=$schema_hash);
687             }
688             }
689             my $root = $schema_hash->{root};
690             if (defined($root)) {
691             bless $root, 'Treex::PML::Schema::Root';
692             weaken($root->{-parent}=$schema_hash);
693             $root->{'-xml_name'}='root';
694             $root->{'-attributes'}=['name','type'];
695             Treex::PML::Schema::Decl->convert_from_hash($root,
696             $schema_hash,
697             undef # path = '' for root
698             );
699             }
700             my $types = $schema_hash->{type};
701             if ($types) {
702             my ($name, $decl);
703             while (($name, $decl) = each %$types) {
704             bless $decl, 'Treex::PML::Schema::Type';
705             $decl->{'-xml_name'}='type';
706             $decl->{'-attributes'}=['name'];
707             Treex::PML::Schema::Decl->convert_from_hash($decl,
708             $schema_hash,
709             '!'.$name
710             );
711             }
712             }
713             return $schema_hash;
714             }
715              
716              
717             =item $schema->find_type_by_path (attribute-path,noresolve,decl)
718              
719             Locate a declaration specified by C starting from
720             declaration C. If C is undefined the root type declaration
721             is used. (Note that attribute paths starting with '/' are always
722             evaluated startng from the root declaration and paths starting with
723             '!' followed by a name of a named type are evaluated starting from
724             that type.) All references to named types are transparently resolved
725             in each step.
726              
727             The caller should pass a true value in C to enforce Member,
728             Attribute, Element, Type, or Root declaration objects to be returned
729             rather than declarations of their content.
730              
731             Attribute path is a '/'-separated sequence of steps (member,
732             attribute, element names or strings matching [\d*]) which identifying
733             a certain nested type declaration. A step of the aforementioned form
734             [\d*] is match the content declaration of a List or Alt. Note however, that
735             named stepsdive into List or Alt declarations automatically, too.
736              
737             =cut
738              
739             sub find_type_by_path {
740             my ($schema, $path, $noresolve, $decl) = @_;
741             if (defined($path) and length($path)) {
742             if ($path=~s{^!([^/]+)/?}{}) {
743             $decl = $schema->get_type_by_name($1);
744             if (defined $decl) {
745             $decl = $decl->get_content_decl;
746             } else {
747             return;
748             }
749             } elsif ($path=~s{^/}{} or !$decl) {
750             $decl = $schema->get_root_decl->get_content_decl;
751             }
752             for my $step (split /\//, $path,-1) {
753             next if $step eq '.';
754             if (ref($decl)) {
755             my $decl_is = $decl->get_decl_type;
756             if ($decl_is == PML_ATTRIBUTE_DECL ||
757             $decl_is == PML_MEMBER_DECL ||
758             $decl_is == PML_ELEMENT_DECL ||
759             $decl_is == PML_TYPE_DECL ) {
760             $decl = $decl->get_knit_content_decl;
761             next unless defined($step) and length($step);
762             redo;
763             }
764             if ($decl_is == PML_LIST_DECL ||
765             $decl_is == PML_ALT_DECL ) {
766             $decl = $decl->get_knit_content_decl;
767             next if ($step =~ /^\[[-+]?\d+\]$/ or
768             (($decl_is == PML_LIST_DECL) ?
769             ($step eq 'LM' or $step eq '[LIST]')
770             :($step eq 'AM' or $step eq '[ALT]')));
771             redo;
772             }
773             if ($decl_is == PML_STRUCTURE_DECL) {
774             my $member = $decl->get_member_by_name($step);
775             if ($member) {
776             $decl = $member;
777             } else {
778             $member = $decl->get_member_by_name($step.'.rf');
779             return unless $member;
780             if ($member->get_knit_name eq $step) {
781             $decl = $member;
782             } else {
783             return;
784             }
785             }
786             } elsif ($decl_is == PML_CONTAINER_DECL) {
787             if ($step eq '#content') {
788             $decl = $decl->get_content_decl;
789             next;
790             }
791             my $attr = $decl->get_attribute_by_name($step);
792             $decl = $attr;
793             } elsif ($decl_is == PML_SEQUENCE_DECL) {
794             $step =~ s/^\[\d+\]//; # name must follow
795             $decl = $decl->get_element_by_name($step);
796             } elsif ($decl_is == PML_ROOT_DECL) {
797             if (!(defined($step) and length($step)) or ($step eq $decl->get_name)) {
798             $decl = $decl->get_content_decl;
799             } else {
800             return;
801             }
802             } else {
803             return;
804             }
805             } else {
806             # warn "Can't follow type path '$path' (step '$step')\n";
807             return(undef); # ERROR
808             }
809             }
810             } elsif (!$decl) {
811             $decl ||= $schema->get_root_decl->get_content_decl;
812             }
813             my $decl_is = $decl && $decl->get_decl_type;
814             return $noresolve ? $decl :
815             $decl && (
816             $decl_is == PML_ATTRIBUTE_DECL ||
817             $decl_is == PML_MEMBER_DECL ||
818             $decl_is == PML_ELEMENT_DECL ||
819             $decl_is == PML_TYPE_DECL ||
820             $decl_is == PML_ROOT_DECL
821             )
822             ? ($decl->get_knit_content_decl) : $decl;
823             }
824              
825              
826             =item $schema->find_types_by_role (role,start_decls)
827              
828             Return a list of declarations (objects derived from Treex::PML::Schema::Decl)
829             that have role equal to C.
830              
831             If C is specified, it must be an ARRAY reference of
832             declarations; in that case, only declarations nested below the listed
833             ones are considered.
834              
835             =cut
836              
837             sub find_types_by_role {
838             my ($self,$role,$start_decls)=@_;
839             my @decls;
840             my $sub = sub { push @decls, $_[0] if $_[0]->{role} eq $role };
841             if (defined($start_decls)) {
842             for (@$start_decls) {
843             $_->for_each_decl($sub);
844             }
845             } else {
846             $self->for_each_decl($sub);
847             }
848             return @decls;
849             }
850              
851             =item $schema->find_role (role,start_decl,opts)
852              
853             WARINING: this function can be very slow, esp. if the type
854             declarations are recursive.
855              
856             Return a list of attribute paths leading to nested type declarations
857             of C with role equal to C.
858              
859             This is equivalent to
860              
861             $schema->find_decl($decl,sub{ $_[0]->{role} eq $role },$opts);
862              
863             Please, see the documentation for C for more information.
864              
865             =cut
866              
867             sub find_role {
868             my ($self, $role, $decl, $opts)=@_;
869             if (!$decl and wantarray()) {
870             $self->{-ROLE_CACHE}{$role} ||= [ $self->_find_role($role,$decl,$opts) ];
871             return @{$self->{-ROLE_CACHE}{$role}};
872             }
873             return $self->_find_role($role,$decl,$opts);
874             }
875              
876             sub _find_role {
877             my ($self, $role, $decl, $opts)=@_;
878             return $self->find_decl(sub{ defined($_[0]->{role}) and $_[0]->{role} eq $role },$decl,$opts);
879             }
880              
881             =item $schema->find_decl (callback,start_decl,opts)
882              
883             WARINING: this function can be very slow, esp. if the type
884             declarations are recursive.
885              
886             Return a list of attribute paths leading to nested type declarations
887             of C for which a given callback returns a true value. The tested
888             type declaration is passed to the callback as the first (and only)
889             argument.
890              
891             If C is specified, it must be an ARRAY reference of
892             declarations; in that case, only declarations nested or referred to
893             from the listed ones are considered.
894              
895             In array context return all matching nested declarations are
896             returned. In scalar context only the first one is returned (with early
897             stopping).
898              
899             The last argument C can be used to pass some flags to the
900             algorithm. Currently only the flag C is available. If
901             true, then the function never recurses into content declaration of
902             declarations with the role #CHILDNODES.
903              
904             =cut
905              
906             sub find_decl {
907             my ($self, $sub, $decl, $opts)=@_;
908             $decl ||= $self->{root};
909             my $first = not(wantarray);
910             my @res = grep { defined } $self->_find($decl,$sub,$first,{},$opts);
911             return $first ? $res[0] : @res;
912             }
913              
914              
915             sub _find {
916             my ($self, $decl, $test, $first, $cache, $opts)=@_;
917              
918             my @result = ();
919              
920             return () unless ref $decl;
921              
922              
923             if ($cache->{'#RECURSE'}{ $decl }) {
924             return ()
925             }
926             local $cache->{'#RECURSE'}{ $decl } = 1;
927              
928             if ( ref $opts and $opts->{no_childnodes} and defined($decl->{role}) and $decl->{role} eq '#CHILDNODES') {
929             return ();
930             }
931              
932             if ( $test->($decl) ) {
933             if ($first) {
934             return '';
935             } else {
936             push @result, '';
937             }
938             }
939             my $type_ref = $decl->get_type_ref;
940             my $decl_is = $decl->get_decl_type;
941             my $seq_bracket = $opts->{with_Seq_brackets} ? '[0]' : '';
942              
943             if ($type_ref) {
944             my $cached = $cache->{ $type_ref };
945             unless ($cached) {
946             $cached = $cache->{ $type_ref } = [ $self->_find( $self->get_type_by_name($type_ref),
947             $test, $first, $cache, $opts ) ];
948             }
949             if ($decl_is == PML_CONTAINER_DECL) {
950             push @result, map { (defined($_) and length($_)) ? '#content/'.$_ : '#content' } @$cached;
951             } elsif ($decl_is == PML_LIST_DECL) {
952             push @result, map { (defined($_) and length($_)) ? 'LM/'.$_ : 'LM' } @$cached;
953             } elsif ($decl_is == PML_ALT_DECL) {
954             push @result, map { (defined($_) and length($_)) ? 'AM/'.$_ : 'AM' } @$cached;
955             } else {
956             push @result, @$cached;
957             }
958             return $result[0] if ($first and @result);
959             }
960             if ($decl_is == PML_STRUCTURE_DECL) {
961             foreach my $member ($decl->get_members) {
962             my @res = map { (defined($_) and length($_)) ? $member->get_name.'/'.$_ : $member->get_name }
963             $self->_find($member, $test, $first, $cache, $opts);
964             return $res[0] if ($first and @res);
965             push @result,@res;
966             }
967             } elsif ($decl_is == PML_CONTAINER_DECL) {
968             my $cdecl = $decl->get_content_decl;
969             foreach my $attr ($decl->get_attributes) {
970             my @res = map { (defined($_) and length($_)) ? $attr->get_name.'/'.$_ : $attr->get_name }
971             $self->_find($attr, $test, $first, $cache, $opts);
972             return $res[0] if ($first and @res);
973             push @result,@res;
974             }
975             if ($cdecl) {
976             push @result, map { (defined($_) and length($_)) ? '#content/'.$_ : '#content' }
977             $self->_find($cdecl, $test, $first, $cache, $opts);
978             return $result[0] if ($first and @result);
979             }
980             } elsif ($decl_is == PML_SEQUENCE_DECL) {
981             foreach my $element ($decl->get_elements) {
982             my @res = map { (defined($_) and length($_)) ? $element->get_name.$seq_bracket.'/'.$_ : $element->get_name.$seq_bracket }
983             $self->_find($element, $test, $first, $cache, $opts);
984             return $res[0] if ($first and @res);
985             push @result,@res;
986             }
987             } elsif ($decl_is == PML_LIST_DECL) {
988             push @result, map { (defined($_) and length($_)) ? 'LM/'.$_ : 'LM' }
989             $self->_find($decl->get_content_decl, $test, $first, $cache, $opts);
990             } elsif ($decl_is == PML_ALT_DECL) {
991             push @result, map { (defined($_) and length($_)) ? 'AM/'.$_ : 'AM' }
992             $self->_find($decl->get_content_decl, $test, $first, $cache, $opts);
993             } elsif ($decl_is == PML_TYPE_DECL ||
994             $decl_is == PML_ROOT_DECL ||
995             $decl_is == PML_ATTRIBUTE_DECL ||
996             $decl_is == PML_MEMBER_DECL ||
997             $decl_is == PML_ELEMENT_DECL ) {
998             push @result, $self->_find($decl->get_content_decl, $test, $first, $cache, $opts);
999             }
1000             my %uniq;
1001             return $first ? (@result ? $result[0] : ())
1002             : grep { !$uniq{$_} && ($uniq{$_}=1) } @result;
1003             }
1004              
1005             =item $schema->node_types ()
1006              
1007             Return a list of all type declarations with the role C<#NODE>.
1008              
1009             =cut
1010              
1011             sub node_types {
1012             my ($self) = @_;
1013             my @result;
1014             return $self->find_types_by_role('#NODE');
1015             }
1016              
1017              
1018              
1019             =item $schema->get_type_by_name (name)
1020              
1021             Return the declaration of the named type with a given name (see
1022             C).
1023              
1024             =cut
1025              
1026             sub get_type_by_name {
1027             my ($self,$name) = @_;
1028             return $self->{type}{$name};
1029             }
1030             *get_type_by_name_obj = \&get_type_by_name;
1031              
1032              
1033             # OBSOLETE: for backward compatibility only
1034             sub type {
1035             my ($self,$decl)=@_;
1036             if (UNIVERSAL::DOES::does($decl,'Treex::PML::Schema::Decl')) {
1037             return $decl
1038             } else {
1039             return Treex::PML::Type->new($self,$decl);
1040             }
1041             }
1042              
1043             =item $schema->validate_object (object, type_decl, log, flags)
1044              
1045             Validates the data content of the given object against a specified
1046             type declaration. The type_decl argument must either be an object
1047             derived from the C class or the name of a named
1048             type.
1049              
1050             An array reference may be passed as the optional 3rd argument C
1051             to obtain a detailed report of all validation errors.
1052              
1053             The C argument can specify flags that influance the
1054             validation. The following constants can binary-OR'ed to obtain the
1055             fags:
1056              
1057             PML_VALIDATE_NO_TREES - do not validate nested data with roles
1058             #CHIDLNODES or #TREES and do not require that objects with the role
1059             #NODE implement the Treex::PML::Node role.
1060              
1061             PML_VALIDATE_NO_CHILDNODES - do not validate nested data with the
1062             role #CHIDLNODES.
1063              
1064             Returns: 1 if the content conforms, 0 otherwise.
1065              
1066             =cut
1067              
1068             sub validate_object { # (path, base_type)
1069             my ($schema, $object, $type,$log)=@_;
1070             if (defined $log and UNIVERSAL::isa($log,'ARRAY')) {
1071             croak "Treex::PML::Schema::validate_object: log must be an ARRAY reference";
1072             }
1073             $type ||= $schema->get_type_by_name($type);
1074             if (!ref($type)) {
1075             croak "Treex::PML::Schema::validate_object: Cannot determine data type";
1076             }
1077             return $type->validate_object($object,{log => $log});
1078             }
1079              
1080              
1081             =item $schema->validate_field (object, attr-path, type, log)
1082              
1083             This method is similar to C, but in this case the
1084             validation is restricted to the data substructure of C
1085             specified by the C argument.
1086              
1087             C is the type of C specified either by the name of a
1088             named type, or as a Treex::PML::Type, or a type declaration.
1089              
1090             An array reference may be passed as the optional 3rd argument C
1091             to obtain a detailed report of all validation errors.
1092              
1093             Returns: 1 if the content conforms, 0 otherwise.
1094              
1095             =cut
1096              
1097             sub validate_field {
1098             my ($schema, $object, $path, $type, $log) = @_;
1099             if (defined $log and UNIVERSAL::isa($log,'ARRAY')) {
1100             croak "Treex::PML::Schema::validate_field: log must be an ARRAY reference";
1101             }
1102             if (!ref($type)) {
1103             my $named_type = $schema->get_type_by_name($type);
1104             croak "Treex::PML::Schema::validate_field: Cannot find type '$type'"
1105             unless $named_type;
1106             $type = $named_type;
1107             }
1108             if (!(defined($path) and length($path))) {
1109             return $type->validate_object($object, { log => $log });
1110             }
1111             $type = $type->find($path);
1112             croak "Treex::PML::Schema::validate_field: Cannot determine data type for attribute-path '$path'" unless $type;
1113             return
1114             $type->validate_object(Treex::PML::Instance::get_data($object,$path),{ path => $path,
1115             log => $log
1116             });
1117             }
1118              
1119              
1120             =item $schema->get_paths_to_atoms (\@decls, \%opts)
1121              
1122             This method returns a list of all non-periodic canonical paths leading
1123             from given types to atomic values. Currently only the following options
1124             are supported:
1125              
1126             no_childnodes => $bool
1127              
1128             If true, the method does not descent to member types with the role
1129             #CHILDNODES.
1130              
1131             no_nodes => $bool
1132              
1133             If true, the method does not descent to member types with the role
1134             #NODE (except for the starting types).
1135              
1136             with_LM => $bool
1137              
1138             If true, the paths will include a LM step for each List type on the path.
1139              
1140             with_AM => $bool
1141              
1142             If true, the paths will include a AM step for each Alt type on the path.
1143              
1144             with_Seq_brackets => $bool
1145              
1146             If true, the paths will append a [0] after each step representing a sequence element
1147              
1148             =cut
1149              
1150             sub get_paths_to_atoms {
1151             my ($self,$types,$opts) = @_;
1152             # find node type
1153              
1154             unless (defined $types) {
1155             $types = [ $self->node_types ];
1156             }
1157             $opts||={};
1158             return $self->_get_paths_to_atoms($types,{},$opts);
1159             }
1160              
1161             sub _get_paths_to_atoms {
1162             my ($self,$types,$seen,$opts)=@_;
1163             my @result;
1164             my $no_children = $opts->{no_childnodes};
1165             my $no_nodes = $opts->{no_nodes};
1166             my $with_LM = $opts->{with_LM};
1167             my $with_AM = $opts->{with_AM};
1168             my $with_Seq_brackets = $opts->{with_Seq_brackets};
1169             foreach my $type (@$types) {
1170             next if $seen->{$type};
1171             my $decl_is = $type->get_decl_type;
1172             next if $no_children and $type->get_role eq '#CHILDNODES';
1173             if ($decl_is == PML_TYPE_DECL ||
1174             $decl_is == PML_ROOT_DECL ||
1175             $decl_is == PML_ATTRIBUTE_DECL ||
1176             $decl_is == PML_MEMBER_DECL ||
1177             $decl_is == PML_ELEMENT_DECL ||
1178             (!$with_LM && $decl_is == PML_LIST_DECL) ||
1179             (!$with_AM && $decl_is == PML_ALT_DECL)) {
1180             $type = $type->get_knit_content_decl;
1181             next if $no_nodes and $type->get_role eq '#NODE';
1182             redo;
1183             }
1184             next unless ref($type);
1185             my @members;
1186             if ($decl_is == PML_STRUCTURE_DECL) {
1187             @members = map { [$_,$_->get_knit_name] } $type->get_members;
1188             } elsif ($decl_is == PML_CONTAINER_DECL) {
1189             my $cdecl = $type->get_knit_content_decl;
1190             @members = ((map { [ $_, $_->get_name ] } $type->get_attributes),
1191             ($cdecl ? [$cdecl, '#content'] : ()));
1192             } elsif ($decl_is == PML_SEQUENCE_DECL) {
1193             if ($with_Seq_brackets) {
1194             @members = map { [ $_, $_->get_name.'[0]' ] } $type->get_elements;
1195             } else {
1196             @members = map { [ $_, $_->get_name ] } $type->get_elements;
1197             }
1198             } elsif ($decl_is == PML_LIST_DECL) {
1199             @members = [$type->get_knit_content_decl,'LM'];
1200             } elsif ($decl_is == PML_ALT_DECL) {
1201             @members = [$type->get_knit_content_decl,'AM'];
1202             } else {
1203             push @result, qq{};
1204             }
1205             if (@members) {
1206             for my $m (@members) {
1207             my ($mdecl,$name) = @$m;
1208             local $seen->{$type}=1;
1209             push @result, map { (defined($_) and length($_)) ? $name."/".$_ : $name }
1210             $self->_get_paths_to_atoms([$mdecl],$seen,$opts);
1211             }
1212             }
1213             }
1214             my %uniq;
1215             return grep { !$uniq{$_} && ($uniq{$_}=1) } @result;
1216             }
1217              
1218              
1219             =item $schema->attributes (decl...)
1220              
1221             This function tries to emulate the behavior of
1222             C<<< Treex::PML::FSFormat->attributes >>> to some extent.
1223              
1224             Return attribute paths to all atomic subtypes of given type
1225             declarations. If no type declaration objects are given, then types
1226             with role C<#NODE> are assumed. This function never descends to
1227             subtypes with role C<#CHILDNODES>.
1228              
1229             =cut
1230              
1231             sub attributes {
1232             my ($self,@types) = @_;
1233             # find node type
1234             return $self->get_paths_to_atoms(@types ? \@types : undef, { no_childnodes => 1 });
1235             }
1236              
1237              
1238              
1239             sub init {
1240             my ($schema,$opts)=@_;
1241             $schema->{URL} = $opts->{URL};
1242             $schema->{-api_version} = '2.0';
1243             }
1244              
1245              
1246             # these functions are used internally by the serializer
1247             sub serialize_exclude_keys {
1248             return qw(URL revision description);
1249             }
1250             sub serialize_get_children {
1251             my ($self,$opts)=@_;
1252             my @children = $self->SUPER::serialize_get_children($opts);
1253             return (
1254             (grep { defined($_->[1]) and length($_->[1]) } (
1255             ['revision',$self->{revision}],
1256             ['description',$self->{description}]
1257             )
1258             ),
1259             (grep { $_->[0] eq 'reference' } @children),
1260             (grep { $_->[0] eq 'root' } @children),
1261             (grep { $_->[0] !~ /^(?:root|reference)$/ } @children)
1262             );
1263             }
1264              
1265             =item $schema->post_process($options)
1266              
1267             Auxiliary method used internally by the PML Schema parser. It
1268             simplifies the schema and for each declaration object creates back
1269             references to its parent declaration and schema and pre-computes the
1270             type attribute path returned by $decl->get_decl_path().
1271              
1272             =cut
1273              
1274             sub post_process {
1275             my ($schema,$opts)=@_;
1276             $schema->simplify($opts);
1277             $schema->for_each_decl(sub{
1278             my ($decl)=@_;
1279             weaken( $decl->{-schema} = $schema );
1280             my $parent = $decl->{-parent};
1281             my $decl_is = $decl->get_decl_type;
1282             if (
1283             $decl_is == PML_STRUCTURE_DECL ||
1284             $decl_is == PML_CONTAINER_DECL ||
1285             $decl_is == PML_SEQUENCE_DECL ||
1286             $decl_is == PML_LIST_DECL ||
1287             $decl_is == PML_ALT_DECL ||
1288             $decl_is == PML_CHOICE_DECL ||
1289             $decl_is == PML_CONSTANT_DECL ||
1290             $decl_is == PML_CDATA_DECL
1291             ) {
1292             my $parent_is = $parent->get_decl_type;
1293             if ($parent_is == PML_TYPE_DECL) {
1294             $decl->{-path} = '!'.$parent->get_name;
1295             } elsif ($parent_is == PML_ROOT_DECL) {
1296             $decl->{-path} = '';
1297             } elsif ($parent_is == PML_ATTRIBUTE_DECL ||
1298             $parent_is == PML_MEMBER_DECL ||
1299             $parent_is == PML_ELEMENT_DECL) {
1300             $decl->{-path} = $parent->{-parent}{-path}.'/'.$parent->get_name;
1301             } elsif ($parent_is == PML_CONTAINER_DECL and $decl_is != PML_ATTRIBUTE_DECL) {
1302             $decl->{-path} = $parent->{-path}.'/#content';
1303             } elsif ($parent_is == PML_LIST_DECL) {
1304             $decl->{-path} = $parent->{-path}.'/LM';
1305             } elsif ($parent_is == PML_ALT_DECL) {
1306             $decl->{-path} = $parent->{-path}.'/AM';
1307             }
1308             if ($decl_is == PML_LIST_DECL and !$decl->{-decl} and $decl->{role} eq '#KNIT') {
1309             # warn ("List $decl->{-path} with role=\"#KNIT\" must have a content type declaration: assuming !\n");
1310             __fix_knit_type($schema,$decl,$decl->{-path}.'/LM');
1311             }
1312             } elsif ($decl_is == PML_MEMBER_DECL) {
1313             if (!$decl->{-decl} and $decl->{role} eq '#KNIT') {
1314             # warn ("Member $decl->{-parent}{-path}/$decl->{-name} with role=\"#KNIT\" must have a content type declaration: assuming !\n");
1315             __fix_knit_type($schema,$decl);
1316             }
1317             }
1318             });
1319             }
1320              
1321             sub __fix_knit_type {
1322             my ($schema,$decl,$path)=@_;
1323             $decl->{-decl}='cdata';
1324             my $cdata = $decl->{cdata}= bless {
1325             format => 'PMLREF',
1326             -xml_name => 'cdata',
1327             -attributes => [ 'format' ],
1328             }, 'Treex::PML::Schema::CDATA';
1329             weaken( $cdata->{-schema} = $schema );
1330             weaken( $cdata->{-parent} = $decl );
1331             if (defined $path) {
1332             $cdata->{-path} = $path;
1333             } elsif ($decl->{-parent} and $decl->{-name}) {
1334             $cdata->{-path} = "$decl->{-parent}{-path}/$decl->{-name}";
1335             }
1336             }
1337              
1338             sub _traverse_data {
1339             my ($data,$sub,$seen,$hashes_only)=@_;
1340             $seen->{$data}=1;
1341             if (UNIVERSAL::isa($data,'ARRAY')) {
1342             $sub->($data,0) unless $hashes_only;
1343             foreach my $val (@$data) {
1344             if (ref($val) and !exists $seen->{$val}) {
1345             _traverse_data($val,$sub,$seen,$hashes_only);
1346             }
1347             }
1348             } elsif (UNIVERSAL::isa($data,'HASH')) {
1349             $sub->($data,1);
1350             foreach my $val (values %$data) {
1351             if (ref($val) and !exists $seen->{$val}) {
1352             _traverse_data($val,$sub,$seen,$hashes_only);
1353             }
1354             }
1355             }
1356             }
1357              
1358              
1359              
1360             =back
1361              
1362             =head1 CLASSES FOR TYPE DECLARATIONS
1363              
1364             =over 3
1365              
1366             =item L
1367              
1368             =item L
1369              
1370             =item L
1371              
1372             =item L
1373              
1374             =item L
1375              
1376             =item L
1377              
1378             =item L
1379              
1380             =item L
1381              
1382             =item L
1383              
1384             =item L
1385              
1386             =item L
1387              
1388             =item L
1389              
1390             =item L
1391              
1392             =item L
1393              
1394             =back
1395              
1396             =cut
1397              
1398             1;
1399              
1400             __END__