File Coverage

blib/lib/Treex/PML/Schema/Struct.pm
Criterion Covered Total %
statement 25 119 21.0
branch 0 50 0.0
condition 0 12 0.0
subroutine 9 24 37.5
pod 14 15 93.3
total 48 220 21.8


line stmt bran cond sub pod time code
1             package Treex::PML::Schema::Struct;
2              
3 1     1   3 use strict;
  1         1  
  1         21  
4 1     1   3 use warnings;
  1         1  
  1         19  
5              
6 1     1   3 use vars qw($VERSION);
  1         0  
  1         31  
7             BEGIN {
8 1     1   19 $VERSION='2.21'; # version template
9             }
10 1     1   2 no warnings 'uninitialized';
  1         1  
  1         24  
11 1     1   3 use Carp;
  1         1  
  1         37  
12              
13 1     1   3 use Treex::PML::Schema::Constants;
  1         4  
  1         71  
14 1     1   3 use base qw( Treex::PML::Schema::Decl );
  1         1  
  1         55  
15 1     1   3 use UNIVERSAL::DOES;
  1         1  
  1         946  
16              
17             =head1 NAME
18              
19             Treex::PML::Schema::Struct - implements declaration of a structure.
20              
21             =head1 INHERITANCE
22              
23             This class inherits from L.
24              
25             =head1 METHODS
26              
27             See the super-class for the complete list.
28              
29             =over 3
30              
31             =item $decl->get_decl_type ()
32              
33             Returns the constant PML_STRUCTURE_DECL.
34              
35             =item $decl->get_decl_type_str ()
36              
37             Returns the string 'structure'.
38              
39             =item $decl->get_structure_name ()
40              
41             Return declared structure name (if any).
42              
43             =item $decl->get_content_decl ()
44              
45             Returns undef.
46              
47             =item $decl->is_atomic ()
48              
49             Returns 0.
50              
51             =cut
52              
53              
54              
55 0     0 1   sub is_atomic { 0 }
56 0     0 1   sub get_decl_type { return PML_STRUCTURE_DECL; }
57 0     0 1   sub get_decl_type_str { return 'structure'; }
58 0     0 1   sub get_content_decl { return(undef); }
59 0     0 1   sub get_structure_name { return $_[0]->{name}; }
60              
61             sub init {
62 0     0 0   my ($self,$opts)=@_;
63 0           $self->{-parent}{-decl} = 'structure';
64             }
65              
66             =item $decl->get_members ()
67              
68             Return a list of the associated member declarations
69             (C).
70              
71             =cut
72              
73             sub get_members {
74 0     0 1   my $members = $_[0]->{member};
75 0 0         return $members ? map { $_->[0] } sort { $a->[1]<=> $b->[1] } map { [ $_, $_->{'-#'} ] } values %$members : ();
  0            
  0            
  0            
76             }
77              
78             =item $decl->get_member_names ()
79              
80             Return a list of names of all members of the structure.
81              
82             =cut
83              
84             sub get_member_names {
85 0     0 1   my $members = $_[0]->{member};
86 0 0         return $members ? map { $_->[0] } sort { $a->[1]<=> $b->[1] } map { [ $_, $members->{$_}->{'-#'} ] } keys %$members : ();
  0            
  0            
  0            
87             }
88              
89             =item $decl->get_member_by_name (name)
90              
91             Return the declaration of the member with a given name.
92              
93             =cut
94              
95             sub get_member_by_name {
96 0     0 1   my ($self, $name) = @_;
97 0           my $members = $_[0]->{member};
98 0 0         return $members ? $members->{$name} : undef;
99             }
100              
101             =item $decl->get_attributes ()
102              
103             Return a list of member declarations (C) declared
104             as attributes.
105              
106             =cut
107              
108             sub get_attributes {
109 0     0 1   my $members = $_[0]->{member};
110 0           return $members ? map { $_->[0] } sort { $a->[1]<=> $b->[1] } map { [ $_, $_->{'-#'} ] }
  0            
  0            
111 0 0         grep { $_->{as_attribute} } values %$members : ();
  0            
112             }
113              
114             =item $decl->get_attribute_names ()
115              
116             Return a list of names of all members of the structure declared as
117             attributes.
118              
119             =cut
120              
121             sub get_attribute_names {
122 0     0 1   my $members = $_[0]->{member};
123 0           return $members ? map { $_->[0] } sort { $a->[1]<=> $b->[1] } map { [ $_, $members->{$_}->{'-#'} ] }
  0            
  0            
124 0 0         grep { $_->{as_attribute} } keys %$members : ();
  0            
125             }
126              
127              
128              
129             =item $decl->find_members_by_content_decl (decl)
130              
131             Lookup and return those member declarations whose content declaration
132             is decl.
133              
134             =cut
135              
136             sub find_members_by_content_decl {
137 0     0 1   my ($self, $decl) = @_;
138 0           return grep { $decl == $_->get_content_decl } $self->get_members;
  0            
139             }
140              
141             =item $decl->find_members_by_type_name (name)
142              
143             Lookup and return those member declarations whose content is specified
144             via a reference to the named type with a given name.
145              
146             =cut
147              
148             sub find_members_by_type_name {
149 0     0 1   my ($self, $type_name) = @_;
150             # using directly $member->{type}
151 0 0         return grep { defined($_->{type}) and $_->{type} eq $type_name } $self->get_members;
  0            
152             }
153              
154             =item $decl->find_members_by_role (role)
155              
156             Lookup and return declarations of all members with a given role.
157              
158             =cut
159              
160             sub find_members_by_role {
161 0     0 1   my ($self, $role) = @_;
162             # using directly $member->{role}
163 0 0         return grep { defined($_->{role}) and $_->{role} eq $role } $self->get_members;
  0            
164             }
165              
166             sub validate_object {
167 0     0 1   my ($self,$object,$opts) = @_;
168              
169 0           my ($path,$tag,$flags);
170 0           my $log = [];
171 0 0         if (ref($opts)) {
172 0           $flags = $opts->{flags};
173 0           $path = $opts->{path};
174 0           $tag = $opts->{tag};
175 0 0         $path.="/".$tag if $tag ne q{};
176             }
177              
178 0           my $members = $self->get_members;
179 0 0         if (!UNIVERSAL::isa($object,'HASH')) {
180 0           push @$log, "$path: Unexpected content of the structure '$self->{name}': '$object'";
181             } else {
182 0           my @members = $self->get_members;
183 0           foreach my $member (grep { $_->is_attribute } @members) {
  0            
184 0           my $name = $member->get_name;
185 0 0         if (ref $object->{$name}) {
186 0           push @$log,"$path/$name: invalid content for member declared as attribute: ".ref($object->{$name});
187             }
188             }
189 0           foreach my $member (@members) {
190 0           my $name = $member->get_name;
191 0           my $role = $member->get_role;
192 0           my $mtype = $member->get_content_decl;
193 0           my $val = $object->{$name};
194 0           my $knit_name = $member->get_knit_name;
195 0 0 0       if ($role eq '#CHILDNODES' and !($flags & PML_VALIDATE_NO_TREES)) {
    0          
    0          
    0          
196 0 0         if (not UNIVERSAL::DOES::does($object,'Treex::PML::Node')) {
197 0           push @$log, "$path/$name: #CHILDNODES member on a non-node object: $object";
198             }
199 0 0         unless ($flags & PML_VALIDATE_NO_CHILDNODES) {
200 0           my $content;
201 0           my $mtype_is = $mtype->get_decl_type;
202 0 0         if ($mtype_is == PML_SEQUENCE_DECL) {
    0          
203 0           $content = Treex::PML::Factory->createSeq([map { Treex::PML::Seq::Element->new($_->{'#name'},$_) } $object->children]);
  0            
204             } elsif ($mtype_is == PML_LIST_DECL) {
205 0           $content = Treex::PML::Factory->createList([$object->children],1);
206             } else {
207 0           push @$log, "$path: #CHILDNODES should be either a list or sequence type";
208             }
209 0           $mtype->validate_object($content,
210             { flags => $flags,
211             path => $path,
212             tag => $name,
213             log => $log,
214             } );
215             }
216             } elsif ($name ne $knit_name) {
217 0           my $knit_val = $object->{$knit_name};
218 0           my $mtype;
219 0 0 0       if ($knit_val ne q{} and $val ne q{}) {
    0          
220 0           push @$log, "$path/$knit_name: both '$name' and '$knit_name' are present for a #KNIT member";
221             } elsif ($val ne q{}) {
222 0           $knit_name = $name;
223 0           $knit_val = $val;
224 0           $mtype = $member->get_content_decl;
225             } else {
226 0           $mtype = $member->get_knit_content_decl;
227             }
228 0 0         if (defined $mtype) {
229 0 0 0       if ($knit_val ne q{} or $member->is_required) {
230 0           $mtype->validate_object($knit_val,
231             { flags => $flags,
232             path => $path,
233             tag => $knit_name,
234             log => $log
235             });
236             }
237             } else {
238 0           push @$log, "$path/$knit_name: can't determine data type of the #KNIT member";
239             }
240             } elsif ($val ne q{}) {
241 0           $mtype->validate_object($val,
242             { flags => $flags,
243             path => $path,
244             tag => $name,
245             log => $log,
246             } );
247             } elsif ($member->is_required) {
248 0           push @$log, "$path/$name: CDATA member declared as required cannot be empty!";
249             }
250             }
251             }
252 0 0 0       if ($opts and ref($opts->{log})) {
253 0           push @{$opts->{log}}, @$log;
  0            
254             }
255 0 0         return @$log ? 0 : 1;
256             }
257              
258             =back
259              
260             =cut
261              
262              
263             1;
264             __END__