File Coverage

blib/lib/Treex/PML/Schema/Seq.pm
Criterion Covered Total %
statement 38 86 44.1
branch 4 30 13.3
condition 0 6 0.0
subroutine 15 23 65.2
pod 13 14 92.8
total 70 159 44.0


line stmt bran cond sub pod time code
1             package Treex::PML::Schema::Seq;
2              
3 6     6   41 use strict;
  6         12  
  6         161  
4 6     6   28 use warnings;
  6         9  
  6         144  
5              
6 6     6   26 use vars qw($VERSION);
  6         11  
  6         222  
7             BEGIN {
8 6     6   93 $VERSION='2.24'; # version template
9             }
10 6     6   26 no warnings 'uninitialized';
  6         10  
  6         398  
11 6     6   196 use Carp;
  6         20  
  6         392  
12              
13 6     6   35 use Treex::PML::Schema::Constants;
  6         10  
  6         550  
14 6     6   35 use base qw( Treex::PML::Schema::Decl );
  6         10  
  6         538  
15 6     6   37 use UNIVERSAL::DOES;
  6         10  
  6         5169  
16              
17             =head1 NAME
18              
19             Treex::PML::Schema::Seq - implements declaration of a sequence.
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_SEQUENCE_DECL.
34              
35             =item $decl->get_decl_type_str ()
36              
37             Returns the string 'sequence'.
38              
39             =item $decl->is_mixed ()
40              
41             Return 1 if the sequence allows text content, otherwise
42             return 0.
43              
44             =item $decl->is_atomic ()
45              
46             Returns 0.
47              
48             =item $decl->get_content_decl ()
49              
50             Returns undef.
51              
52             =item $decl->get_content_pattern ()
53              
54             Return content pattern associated with the declaration (if
55             any). Content pattern specifies possible ordering and occurences of
56             elements in DTD-like content-model grammar.
57              
58             =cut
59              
60 0     0 1 0 sub is_atomic { 0 }
61 428     428 1 859 sub get_decl_type { return PML_SEQUENCE_DECL; }
62 0     0 1 0 sub get_decl_type_str { return 'sequence'; }
63 0     0 1 0 sub get_content_decl { return(undef); }
64 117 100   117 1 557 sub is_mixed { return $_[0]->{text} ? 1 : 0 }
65             sub get_content_pattern {
66 35     35 1 96 return $_[0]->{content_pattern};
67             }
68              
69             sub init {
70 84     84 0 215 my ($self,$opts)=@_;
71 84         268 $self->{-parent}{-decl} = 'sequence';
72             }
73              
74             =item $decl->get_elements ()
75              
76             Return a list of element declarations (C).
77              
78             =cut
79              
80             sub get_elements {
81 42     42 1 103 my $members = $_[0]->{element};
82 42 50       153 return $members ? map { $_->[0] } sort { $a->[1]<=> $b->[1] } map { [ $_, $_->{'-#'} ] } values %$members : ();
  67         174  
  31         94  
  67         268  
83             }
84              
85             =item $decl->get_element_names ()
86              
87             Return a list of names of elements declared for the sequence.
88              
89             =cut
90              
91             sub get_element_names {
92 0     0 1 0 my $members = $_[0]->{element};
93 0 0       0 return $members ? map { $_->[0] } sort { $a->[1]<=> $b->[1] } map { [ $_, $members->{$_}->{'-#'} ] } keys %$members : ();
  0         0  
  0         0  
  0         0  
94             }
95              
96             =item $decl->get_element_by_name (name)
97              
98             Return the declaration of the element with a given name.
99              
100             =cut
101              
102             sub get_element_by_name {
103 163     163 1 321 my ($self, $name) = @_;
104 163         283 my $members = $_[0]->{element};
105 163 50       539 return $members ? $members->{$name} : undef;
106             }
107              
108             =item $decl->find_elements_by_content_decl
109              
110             Lookup and return those element declarations whose content declaration
111             is decl.
112              
113             =cut
114              
115             sub find_elements_by_content_decl {
116 0     0 1   my ($self, $decl) = @_;
117 0           return grep { $decl == $_->get_content_decl } $self->get_elements;
  0            
118             }
119              
120             =item $decl->find_elements_by_type_name
121              
122             Lookup and return those element declarations whose content is
123             specified via a reference to the named type with a given name.
124              
125             =cut
126              
127              
128             sub find_elements_by_type_name {
129 0     0 1   my ($self, $type_name) = @_;
130             # using directly $member->{type}
131 0           return grep { $type_name eq $_->{type} } $self->get_elements;
  0            
132             }
133              
134             =item $decl->find_elements_by_role
135              
136             Lookup and return declarations of all elements with a given role.
137              
138             =cut
139              
140             sub find_elements_by_role {
141 0     0 1   my ($self, $role) = @_;
142             # using directly $member->{role}
143 0           return grep { $role eq $_->{role} } $self->get_elements;
  0            
144             }
145              
146             sub validate_object {
147 0     0 1   my ($self, $object, $opts) = @_;
148              
149 0           my ($path,$tag,$flags);
150 0           my $log = [];
151 0 0         if (ref($opts)) {
152 0           $flags = $opts->{flags};
153 0           $path = $opts->{path};
154 0           $tag = $opts->{tag};
155 0 0         $path.="/".$tag if $tag ne q{};
156             }
157              
158 0 0         if (UNIVERSAL::DOES::does($object,'Treex::PML::Seq')) {
159 0           my $i = 0;
160 0           foreach my $element ($object->elements) {
161 0           $i++;
162 0 0         if (!UNIVERSAL::isa($element,'ARRAY')) {
    0          
163 0           push @$log, "$path: invalid sequence content: ",ref($element);
164             } elsif ($element->[0] eq '#TEXT') {
165 0 0         if ($self->is_mixed) {
166 0 0         if (ref($element->[1])) {
167 0           push @$log, "$path: expected CDATA, got: ",ref($element->[1]);
168             }
169             } else {
170 0           push @$log, "$path: text node not allowed here\n";
171             }
172             } else {
173 0           my $ename = $element->[0];
174 0           my $edecl = $self->get_element_by_name($ename);
175             # KNIT on elements not supported yet
176 0 0         if ($edecl) {
177 0           $edecl->validate_object($element->[1],{
178             flags => $flags,
179             path => $path,
180             tag => "[$i]",
181             log => $log,
182             });
183             } else {
184 0           push @$log, "$path: undefined element '$ename'";
185             }
186             }
187 0           my $content_pattern = $self->get_content_pattern;
188 0 0 0       if ($content_pattern and !$object->validate($content_pattern)) {
189 0           push @$log, "$path: sequence content (".join(",",$object->names).") does not follow the pattern ".$content_pattern;
190             }
191             }
192             } else {
193 0           push @$log, "$path: unexpected content of a sequence: $object";
194             }
195 0 0 0       if ($opts and ref($opts->{log})) {
196 0           push @{$opts->{log}}, @$log;
  0            
197             }
198 0 0         return @$log ? 0 : 1;
199             }
200              
201             =back
202              
203             =cut
204              
205              
206             1;
207             __END__