File Coverage

blib/lib/Treex/PML/Schema/Decl.pm
Criterion Covered Total %
statement 25 197 12.6
branch 0 100 0.0
condition 0 29 0.0
subroutine 9 33 27.2
pod 22 24 91.6
total 56 383 14.6


line stmt bran cond sub pod time code
1             package Treex::PML::Schema::Decl;
2              
3             ########################################################################
4             # PML Schema type declaration
5             ########################################################################
6              
7 1     1   3 use strict;
  1         1  
  1         22  
8 1     1   2 use warnings;
  1         1  
  1         19  
9              
10 1     1   3 use vars qw($VERSION);
  1         0  
  1         36  
11             BEGIN {
12 1     1   12 $VERSION='2.22'; # version template
13             }
14 1     1   6 no warnings 'uninitialized';
  1         1  
  1         30  
15 1     1   3 use Scalar::Util qw( weaken );
  1         1  
  1         32  
16 1     1   3 use Carp;
  1         0  
  1         37  
17 1     1   3 use Treex::PML::Schema::Constants;
  1         1  
  1         76  
18 1     1   3 use base qw(Treex::PML::Schema::XMLNode);
  1         1  
  1         1547  
19              
20             =head1 NAME
21              
22             Treex::PML::Schema::Decl - implements PML schema type declaration
23              
24             =head1 DESCRIPTION
25              
26             This is an abstract class from which all specific type declaration
27             classes inherit.
28              
29             =head1 INHERITANCE
30              
31             This class inherits from L.
32              
33             =head1 METHODS
34              
35             =over 3
36              
37             =cut
38              
39 0     0 0   sub new { croak("Can't create ".__PACKAGE__) }
40              
41             # compatibility with old Treex::PML::Type
42              
43 0     0 0   sub type_decl { return $_[0] };
44              
45             =item $decl->get_schema ()
46              
47             =item $decl->schema ()
48              
49             Return C the declaration belongs to.
50              
51             =cut
52              
53 0     0 1   sub schema { return $_[0]->{-schema} }
54              
55             =item $decl->get_schema ()
56              
57             Same as C<< $decl->schema() >>.
58              
59             =cut
60              
61 0     0 1   sub get_schema { return $_[0]->schema }
62              
63             =item $decl->get_decl_type ()
64              
65             Return the type of declaration as an integer constant (see
66             L).
67              
68             =item $decl->get_decl_type_str ()
69              
70             Return the type of declaration as string; one of: type, root,
71             structure, container, sequence, list, alt, cdata, choice, constant,
72             attribute, member, element.
73              
74             =cut
75              
76 0     0 1   sub get_decl_type { return(undef); } # VIRTUAL
77 0     0 1   sub get_decl_type_str { return(undef); } # VIRTUAL
78              
79             =item $decl->is_atomic ()
80              
81             Return 1 if the declaration is of atomic type (cdata, choice,
82             constant), 0 if it is a structured type (structure, container,
83             sequence, list, alt), or undef, if it is an auxiliary declaration
84             (root, type, attribute, member, element).
85              
86             =cut
87              
88 0     0 1   sub is_atomic { croak "is_atomic(): UNKNOWN TYPE"; } # VIRTUAL
89              
90             =item $decl->get_content_decl ()
91              
92             For declarations with content (type, root, container, list, alt,
93             attribute, member, element), return the content declaration; return
94             undef for other declarations. This method transparently resolves
95             references to named types.
96              
97             =cut
98              
99             sub get_content_decl {
100 0     0 1   my $self = shift;
101 0           my $no_resolve = shift;
102 0 0         if ($self->{-decl}) {
    0          
    0          
103 0           return $self->{ $self->{-decl} };
104             } elsif (my $resolved = $self->{-resolved}) {
105 0           return $resolved;
106             } elsif (my $type_ref = $self->{type}) {
107 0           my $schema = $self->{-schema};
108 0 0         if ($schema) {
109 0           my $type = $schema->{type}{ $type_ref };
110 0 0         if ($no_resolve) {
    0          
111 0           return $type;
112             } elsif ($type) {
113 0           weaken($self->{-resolved} = $type->get_content_decl);
114 0           return $self->{-resolved};
115             } else {
116 0           return undef;
117             }
118             } else {
119 0           croak "Declaration not associated with a schema";
120             }
121             }
122 0           return(undef);
123             }
124              
125             =item $decl->get_knit_content_decl ()
126              
127             If the data type has a role '#KNIT', return a type declaration for the
128             knitted content (Note: PML 1.1.2 allows role '#KNIT' role on list,
129             element, and member declarations, but element knitting is not
130             currenlty implemented). Otherwise return the same as get_content_decl.
131              
132             =cut
133              
134              
135             sub get_knit_content_decl {
136 0     0 1   my $self = shift;
137 0 0 0       return (defined($self->{role}) and $self->{role} eq '#KNIT') ?
138             $self->get_type_ref_decl
139             : $self->get_content_decl;
140             }
141              
142             =item $decl->get_type_ref ()
143              
144             If the declaration has content and the content is specified via a
145             reference to a named type, return the name of the referred type.
146             Otherwise return undef.
147              
148             =cut
149              
150             sub get_type_ref {
151 0     0 1   return $_[0]->{type};
152             }
153              
154             =item $decl->get_type_ref_decl ()
155              
156             Retrun content declaration object (if any), but only if it is
157             specified via a reference to a named type. In all other cases, return
158             undef.
159              
160             =cut
161              
162             sub get_type_ref_decl {
163 0     0 1   my $self = shift;
164 0           my $no_resolve = shift;
165 0 0         if (my $resolved = $self->{-resolved}) {
    0          
166 0           return $resolved;
167             } elsif (my $type_ref = $self->{type}) {
168 0           my $schema = $self->{-schema};
169 0 0         if ($schema) {
170 0           my $type = $schema->{type}{ $type_ref };
171             return $no_resolve ? $type
172             : $type ?
173 0 0         ($self->{-resolved} = $type->get_content_decl)
    0          
174             : undef ;
175             }
176             }
177 0           return(undef);
178             }
179              
180             =item $decl->get_base_type_name ()
181              
182             If the declaration is a nested (even deeply) part of a named type
183             declaration, return the name of that named type.
184              
185             =cut
186              
187             sub get_base_type_name {
188 0     0 1   my $path = $_[0]->{-path};
189 0 0         if ($path=~m{^!([^/]+)}) {
190 0           return $1;
191             } else {
192 0           return(undef);
193             }
194             }
195              
196             =item $decl->get_parent_decl ()
197              
198             If this declaration is nested, return its parent declaration.
199              
200             =cut
201              
202 0     0 1   sub get_parent_decl { return $_[0]->{-parent} }
203              
204             =item $decl->get_decl_path ()
205              
206             Return a cannonical attribute path leading to the declaration
207             (starting either at a named type or the root type declaration).
208              
209             =cut
210              
211 0     0 1   sub get_decl_path { return $_[0]->{-path}; }
212              
213             =item $decl->get_role
214              
215             If the declaration is associated with a role, return it.
216              
217             =cut
218              
219 0   0 0 1   sub get_role { return $_[0]->{role}||'' }
220              
221              
222             =item $decl->find (attribute-path,noresolve)
223              
224             Locate a nested declaration specified by C starting
225             from the current type. See C<$schema-Efind_type_by_path> for details
226             about locating declarations.
227              
228             =cut
229              
230             sub find {
231 0     0 1   my ($self, $path,$noresolve) = @_;
232             # find node type
233 0           my $type = $self->type_decl;
234 0           return $self->schema->find_type_by_path($path,$noresolve,$type);
235             }
236              
237             =item $decl->find_role (role, opts)
238              
239             Search declarations with a given role nested within this declaration.
240             In scalar context, return the first declaration that matches, in array
241             context return all such declarations.
242              
243             The last argument C can be used to pass some flags to the
244             algorithm. Currently only the flag C is available. If
245             true, then the function never recurses into content declaration of
246             declarations with the role #CHILDNODES.
247              
248             =cut
249              
250             sub find_role {
251 0     0 1   my ($self, $role, $opts) = @_;
252 0           return $self->schema->find_role($role,$self->type_decl,$opts);
253             }
254              
255             =item $decl->convert_from_hash (class, hash, schema, path)
256              
257             Compatibility method building the schema object from a nested hash
258             structure created by XML::Simple which was used in older
259             implementations. This is useful for upgrading objects stored in old
260             binary dumps. Not to be used directly.
261              
262             =cut
263              
264             sub convert_from_hash {
265 0     0 1   my ($class, $decl, $schema, $path) = @_;
266 0           my $sub;
267             my $decl_type;
268 0 0         if ($sub = $decl->{structure}) {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
269 0           $decl_type = 'structure';
270 0           bless $sub, 'Treex::PML::Schema::Struct';
271 0           $sub->{'-attributes'}=[qw(role name type)];
272 0 0         if (my $members = $sub->{member}) {
273 0           my ($name, $mdecl);
274 0           while (($name, $mdecl) = each %$members) {
275 0           bless $mdecl, 'Treex::PML::Schema::Member';
276 0           $mdecl->{'-xml_name'}='member';
277 0           $mdecl->{'-attributes'}=[qw(name required as_attribute type role)];
278 0           weaken($mdecl->{-parent}=$sub);
279 0           weaken($mdecl->{-schema}=$schema);
280 0           $class->convert_from_hash($mdecl,
281             $schema,
282             $path.'/'.$name
283             );
284 0 0 0       if (!$mdecl->{-decl} and $mdecl->{role} eq '#KNIT') {
285             # warn("Member $decl->{-parent}{-path}/$decl->{-name} with role=\"#KNIT\" must have a content type declaration: assuming !\n");
286 0           Treex::PML::Schema::__fix_knit_type($schema,$mdecl);
287             }
288             }
289             }
290             } elsif ($sub = $decl->{container}) {
291 0           $decl_type = 'container';
292 0           bless $sub, 'Treex::PML::Schema::Container';
293 0           $sub->{'-attributes'}=[qw(role name type)];
294 0 0         if (my $members = $sub->{attribute}) {
295 0           my ($name, $mdecl);
296 0           while (($name, $mdecl) = each %$members) {
297 0           bless $mdecl, 'Treex::PML::Schema::Attribute';
298 0           $mdecl->{'-xml_name'}='attribute';
299 0           $mdecl->{'-attributes'}=[qw(name required type role)];
300 0           weaken($mdecl->{-schema}=$schema);
301 0           weaken($mdecl->{-parent}=$sub);
302 0           $class->convert_from_hash($mdecl,
303             $schema,
304             $path.'/'.$name
305             );
306             }
307             }
308 0           $class->convert_from_hash($sub, $schema, $path.'/#content');
309             } elsif ($sub = $decl->{sequence}) {
310 0           $decl_type = 'sequence';
311 0           bless $sub, 'Treex::PML::Schema::Seq';
312 0           $sub->{'-attributes'}=[qw(role content_pattern type)];
313 0 0         if (my $members = $sub->{element}) {
314 0           my ($name, $mdecl);
315 0           while (($name, $mdecl) = each %$members) {
316 0           bless $mdecl, 'Treex::PML::Schema::Element';
317 0           $mdecl->{'-xml_name'}='element';
318 0           $mdecl->{'-attributes'}=[qw(name type role)];
319 0           weaken($mdecl->{-schema}=$schema);
320 0           weaken($mdecl->{-parent}=$sub);
321 0           $class->convert_from_hash($mdecl,
322             $schema,
323             $path.'/'.$name
324             );
325             }
326             }
327             } elsif ($sub = $decl->{list}) {
328 0           $decl_type = 'list';
329 0           bless $sub, 'Treex::PML::Schema::List';
330 0           $sub->{'-attributes'}=[qw(role ordered type)];
331 0           $class->convert_from_hash($sub, $schema, $path.'/LM');
332 0 0 0       if (!$sub->{-decl} and $sub->{role} eq '#KNIT') {
333             # warn("List $sub->{-name} with role=\"#KNIT\" must have a content type declaration: assuming !\n");
334 0           Treex::PML::Schema::__fix_knit_type($schema,$sub,$path.'/LM');
335             }
336             } elsif ($sub = $decl->{alt}) {
337 0           $decl_type = 'alt';
338 0           bless $sub, 'Treex::PML::Schema::Alt';
339 0           $sub->{'-attributes'}=[qw(role type)];
340 0           $class->convert_from_hash($sub, $schema, $path.'/AM');
341             } elsif ($sub = $decl->{choice}) {
342 0           $decl_type = 'choice';
343             # convert from an ARRAY to a hash
344 0 0         if (ref($sub) eq 'ARRAY') {
    0          
345             $sub = $decl->{choice} = bless { values => [
346             map {
347 0 0         ref($_) eq 'HASH' ? $_->{content} : $_
  0            
348             } @$sub
349             ],
350             }, 'Treex::PML::Schema::Choice';
351             } elsif (ref($sub)) {
352 0           bless $sub, 'Treex::PML::Schema::Choice';
353 0 0         if (ref($sub->{value}) eq 'ARRAY') {
354             $sub->{values} = [
355 0           map { $_->{content} } @{$sub->{value}}
  0            
  0            
356             ];
357 0           delete $sub->{value};
358             }
359             } else {
360 0           croak __PACKAGE__.": Invalid element in type '$path'?\n";
361             }
362             } elsif ($sub = $decl->{cdata}) {
363 0           $decl_type = 'cdata';
364 0           bless $sub, 'Treex::PML::Schema::CDATA';
365 0           $sub->{'-attributes'}=['format'];
366             } elsif (exists $decl->{constant}) { # can be 0
367 0           $sub = $decl->{constant};
368 0           $decl_type = 'constant';
369 0 0         unless (ref($sub)) {
370 0           $sub = $decl->{constant} = bless { value => $sub }, 'Treex::PML::Schema::Constant';
371             }
372             ## this is just a scalar value
373             # bless $sub, 'Treex::PML::Schema::Constant';
374             }
375 0           $sub->{'-xml_name'}=$decl_type;
376 0           weaken( $decl->{-schema} = $schema );
377 0           $decl->{-decl} = $decl_type;
378 0 0 0       unless (exists($sub->{-schema}) and exists($sub->{-parent})) {
379 0 0         weaken( $sub->{-schema} = $schema ) unless $sub->{-schema};
380 0 0         weaken( $sub->{-parent} = $decl ) unless $sub->{-parent};
381 0           $sub->{-path} = $path;
382             }
383 0           return $decl;
384             }
385              
386              
387             =item $decl->get_normal_fields ()
388              
389             This method is provided for convenience.
390              
391             For a structure type, return names of its members, for a container
392             return names of its attributes plus the name '#content' referring to
393             the container's content value. In both cases, eliminate fields of
394             values with role C<#CHILDNODES> and strip a possible C<.rf> suffix of
395             fields with role C<#KNIT>.
396              
397             =cut
398              
399             sub get_normal_fields {
400 0     0 1   my ($self,$path)=@_;
401 0 0         my $type = defined($path) ? $self->find($path) : $self;
402 0           my $struct;
403             my $members;
404 0 0         return unless ref $type;
405 0           my $decl_is = $type->get_decl_type;
406 0 0 0       if ($decl_is == PML_TYPE_DECL ||
      0        
      0        
      0        
407             $decl_is == PML_ROOT_DECL ||
408             $decl_is == PML_ATTRIBUTE_DECL ||
409             $decl_is == PML_MEMBER_DECL ||
410             $decl_is == PML_ELEMENT_DECL ) {
411 0 0         if ($type = $type->get_content_decl) {
412 0           $decl_is = $type->get_decl_type;
413             } else {
414 0           return ();
415             }
416             }
417 0           my @members = ();
418 0 0         if ($decl_is == PML_STRUCTURE_DECL) {
    0          
419             @members =
420 0           map { $_->get_knit_name }
421 0           grep { $_->get_role ne '#CHILDNODES' }
  0            
422             $type->get_members;
423             } elsif ($decl_is == PML_CONTAINER_DECL) {
424 0           my $cdecl = $type->get_content_decl;
425 0 0 0       @members = ($type->get_attribute_names,
426             ($cdecl && $type->get_role ne '#CHILDNODES') ? '#content' : ());
427             }
428             }
429              
430             =item $decl->get_childnodes_decls ()
431              
432             If the $decl has the role #NODE, this method locates a sub-declaration
433             with role #CHILDNODES and returns a list of declarations of the child
434             nodes.
435              
436             =cut
437              
438             sub get_childnodes_decls {
439 0     0 1   my ($self) = @_;
440 0 0         if ($self->get_decl_type == PML_ELEMENT_DECL) {
441 0           $self = $self->get_content_decl;
442             }
443 0 0         return unless $self->get_role eq '#NODE';
444 0           my ($ch) = $self->find_members_by_role('#CHILDNODES');
445 0 0         if ($ch) {
446 0           my $ch_is = $ch->get_decl_type;
447 0 0         if ($ch_is == PML_MEMBER_DECL) {
448 0           $ch = $ch->get_content_decl;
449 0           $ch_is = $ch->get_decl_type;
450             }
451 0 0         if ($ch_is == PML_SEQUENCE_DECL) {
    0          
452 0           return $ch->get_elements;
453             } elsif ($ch_is == PML_LIST_DECL) {
454 0           return $ch->get_content_decl;
455             }
456             }
457 0           return;
458             }
459              
460              
461             =item $decl->get_attribute_paths (\%opts)
462              
463             Return attribute paths leading from this declaration to all (possibly
464             deeply) nested declarations of atomic type. This method is an alias for
465              
466             $decl->schema->get_paths_to_atoms([$decl],\%opts)
467              
468             See L for details.
469              
470             =cut
471              
472             sub get_attribute_paths { # OLD NAME
473 0     0 1   my ($self,$opts)=@_;
474 0           return $self->get_paths_to_atoms($opts);
475             }
476              
477             =item $decl->get_paths_to_atoms (\%opts)
478              
479             Same as
480              
481             $decl->schema->get_paths_to_atoms([$decl],\%opts)
482              
483             See L for details.
484              
485             =cut
486              
487             sub get_paths_to_atoms {
488 0     0 1   my ($self,$opts)=@_;
489 0           return $self->schema->get_paths_to_atoms([$self],$opts);
490             }
491              
492             =item $decl->validate_object($object);
493              
494             See C method of L.
495              
496             =cut
497              
498             sub validate_object {
499 0     0 1   croak "Not implemented for the class ".__PACKAGE__;
500             }
501              
502             =item $decl->for_each_decl (sub{ ... })
503              
504             This method traverses all nested sub-declarations and calls a given
505             subroutine passing the sub-declaration object as a parameter.
506              
507             =cut
508              
509             sub for_each_decl {
510 0     0 1   my ($self,$sub)=@_;
511 0           $sub->($self);
512             # (a container or #KNIT member can have both type and children)
513             # traverse descendant type declarations
514 0           for my $d (qw(member attribute element)) {
515 0 0         if (ref $self->{$d}) {
516 0           foreach (values %{$self->{$d}}) {
  0            
517 0           $_->for_each_decl($sub);
518             }
519 0 0         last if $d eq 'attribute'; # there may be content
520 0           return; # otherwise
521             }
522             }
523 0           for my $d (qw(list alt structure container sequence),
524             qw(cdata choice constant)) {
525 0 0         if (exists $self->{$d}) {
526 0           $self->{$d}->for_each_decl($sub);
527 0           return;
528             }
529             }
530             }
531              
532             =item $decl->write ({option => value})
533              
534             This method serializes a declaration to XML. See Treex::PML::Schema->write for
535             details and Treex::PML::Schema::XMLNode->write for implementation.
536              
537             =cut
538              
539              
540             =back
541              
542             =cut
543              
544              
545             1;
546             __END__