File Coverage

blib/lib/Treex/PML/Seq.pm
Criterion Covered Total %
statement 42 134 31.3
branch 5 40 12.5
condition 2 12 16.6
subroutine 12 28 42.8
pod 21 21 100.0
total 82 235 34.8


line stmt bran cond sub pod time code
1              
2             package Treex::PML::Seq;
3 6     6   43 use Carp;
  6         12  
  6         308  
4 6     6   33 use warnings;
  6         13  
  6         172  
5              
6 6     6   35 use vars qw($VERSION);
  6         13  
  6         252  
7             BEGIN {
8 6     6   151 $VERSION='2.24'; # version template
9             }
10 6     6   36 use strict;
  6         12  
  6         131  
11 6     6   32 use Treex::PML::List;
  6         12  
  6         143  
12 6     6   2265 use Treex::PML::Seq::Element;
  6         16  
  6         8351  
13              
14              
15             =head1 NAME
16              
17             Treex::PML::Seq - sequence of PML values of various types
18              
19             =head1 DESCRIPTION
20              
21             This class implements the data type 'sequence'. A sequence contains of
22             zero or more elements (L), each consisting of
23             a name and value. The ordering of elements in a sequence may be
24             constrained by a regular-expression-like pattern operating on element
25             names. Validation of a sequence against this constraint pattern is not
26             automatic but can be performed at any time on demand.
27              
28             =over 4
29              
30             =item Treex::PML::Seq->new (element_array_ref?, content_pattern?,$reuse?)
31              
32             NOTE: Don't call this constructor directly, use Treex::PML::Factory->createSeq() instead!
33              
34             Create a new sequence (optionally populated with elements from a given
35             array_ref). Each element should be a Treex::PML::Element::Seq object. The
36             second optional argument is a regular expression constraint which can
37             be stored in the object and used later for validating content (see
38             validate() method below). The C<$reuse> argument is a boolean flag
39             indicating whether the passed array reference can be used directly (if
40             C<$reuse> is true) or copied (if C<$reuse> ise false).
41              
42             =cut
43              
44             sub new {
45 665     665 1 1506 my ($class,$array,$content_pattern,$reuse) = @_;
46 665 100       1583 $array = [] unless defined($array);
47 665         1923 return bless [Treex::PML::List->new_from_ref($array,$reuse), # a list consisting of [name,value] pairs
48             $content_pattern # a content_pattern constraint
49             ],$class;
50             }
51              
52             =item $seq->elements ($name?)
53              
54             Return a list of [ name, value ] pairs representing the sequence
55             elements. If the optional $name argument is given, select
56             only elements whose name is $name.
57              
58             =cut
59              
60             sub elements {
61 33     33 1 5168 my ($self,$name)=@_;
62 33 50 33     141 if (defined $name and $name ne '*') {
63 0         0 return grep { $_->[0] eq $name } @{$_[0]->[0]};
  0         0  
  0         0  
64             } else {
65 33         74 return @{$_[0]->[0]};
  33         138  
66             }
67             }
68              
69             =item $seq->elements_list ()
70              
71             Like C without a name, only this method returns directly the
72             Treex::PML::List object associated with this sequence.
73              
74             =cut
75              
76             sub elements_list {
77 0     0 1 0 return $_[0]->[0];
78             }
79              
80              
81             =item $seq->content_pattern ()
82              
83             Return the regular expression constraint stored in the sequence object (if any).
84              
85             =cut
86              
87             sub content_pattern {
88 0     0 1 0 return $_[0]->[1];
89             }
90              
91             =item $seq->set_content_pattern ()
92              
93             Store a regular expression constraint in the sequence object. This
94             expression can be used later to validate sequence content (see
95             validate() method).
96              
97             =cut
98              
99             sub set_content_pattern {
100 0     0 1 0 $_[0]->[1] = $_[1];
101             }
102              
103              
104             =item $seq->values (name?)
105              
106             If no name is given, return a list of values of all elements of the
107             sequence. If a name is given, return a list consisting of values of
108             elements with the given name.
109              
110             In array context, the returned value is a list, in scalar
111             context the result is a Treex::PML::List object.
112              
113             =cut
114              
115             sub values {
116 22     22 1 73 my ($self,$name)=@_;
117 0         0 my @values = map { $_->[1] } ((defined($name) and length($name))
118 0         0 ? (grep $_->[0] eq $name, @{$self->[0]})
119 22 50 33     96 : @{$self->[0]});
  22         84  
120 22 50       140 return wantarray ? @values : bless \@values, 'Treex::PML::List'; #->new_from_ref(\@values,1);
121             }
122              
123             =item $seq->names ()
124              
125             Return a list of names of all elements of the sequence. In array
126             context, the returned value is a list, in scalar context the result is
127             a Treex::PML::List object.
128              
129             =cut
130              
131             sub names {
132 0     0 1 0 my @names = map { $_->[0] } $_[0][0]->values;
  0         0  
133 0 0       0 return wantarray ? @names : bless \@names, 'Treex::PML::List'; #Treex::PML::List->new_from_ref(\@names,1);
134             }
135              
136             =item $seq->element_at (index)
137              
138             Return the element of the sequence on the position specified by a
139             given index. Elements in the sequence are indexed as elements in Perl
140             arrays, i.e. starting from $[, which defaults to 0 and nobody sane
141             should ever want to change it.
142              
143             =cut
144              
145             sub element_at {
146 0     0 1 0 my ($self, $index)=@_;
147 0         0 return $self->[0][$index];
148             }
149              
150              
151             =item $seq->name_at (index)
152              
153             Return the name of the element on a given position.
154              
155             =cut
156              
157             sub name_at {
158 0     0 1 0 my ($self, $index)=@_;
159 0         0 my $el = $self->[0][$index];
160 0 0       0 return $el->[0] if $el;
161             }
162              
163             =item $seq->value_at (index)
164              
165             Return the value of the element on a given position.
166              
167             =cut
168              
169             sub value_at {
170 0     0 1 0 my ($self, $index)=@_;
171 0         0 my $el = $self->[0][$index];
172 0 0       0 return $el->[1] if $el;
173             }
174              
175             =item $seq->delegate_names (key?)
176              
177             If all element values are HASH-references, then it is possible to
178             store each element's name in its value under a given key (that is, to
179             delegate the name to the HASH value). The default value for key is
180             C<#name>. It is a fatal error to try to delegate names if some of the
181             values is not a HASH reference.
182              
183             =cut
184              
185             sub delegate_names {
186 0     0 1 0 my ($self,$key) = @_;
187 0 0       0 $key = '#name' unless defined $key;
188 0 0       0 if (grep { !UNIVERSAL::isa($_->[1],'HASH') } @{$self->[0]}) {
  0         0  
  0         0  
189 0         0 croak("Error: sequence contains a non-HASH element (Treex::PML::Seq can only delegate names to values if all values are HASH refs)!");
190             }
191 0         0 foreach my $element (@{$self->[0]}) {
  0         0  
192 0         0 $element->[1]{$key} = $element->[0]; # store element's name in key $key of its value
193             }
194             }
195              
196              
197             =item $seq->validate (content_pattern?)
198              
199             Check that content of the sequence satisfies a constraint specified
200             by means of a regular expression C. If no content_pattern is
201             given, the one stored with the object is used (if any; otherwise undef
202             is returned).
203              
204             Returns: 1 if the content satisfies the constraint, 0 otherwise.
205              
206             =cut
207              
208             sub validate {
209 0     0 1 0 my ($self,$re) = @_;
210 0 0       0 $re = $self->content_pattern if !defined($re);
211 0 0       0 return unless defined $re;
212 0         0 my $content = join "",map { "<$_>"} $self->names;
  0         0  
213 0         0 $re=~s/\#/\\\#/g;
214 0         0 $re=~s/,/ /g;
215 0         0 $re=~s/\s+/ /g;
216 0         0 $re=~s/([^()?+*|,\s]+)/(?:<$1>)/g;
217             # warn "'$content' VERSUS /$re/\n";
218 0 0       0 return $content=~m/^$re$/x ? 1 : 0;
219             }
220              
221             =item $seq->push_element (name, value)
222              
223             Append a given name-value pair to the sequence.
224              
225             =cut
226              
227             sub push_element {
228 0     0 1 0 my ($self,$name,$value)=@_;
229 0         0 push @{$self->[0]},Treex::PML::Seq::Element->new($name,$value);
  0         0  
230             }
231              
232             =item $seq->push_element_obj (obj)
233              
234             Append a given Treex::PML::Seq::Element object to the sequence.
235              
236             =cut
237              
238             sub push_element_obj {
239 19     19 1 56 my ($self,$obj)=@_;
240 19         36 push @{$self->[0]},$obj;
  19         79  
241             }
242              
243             =item $seq->unshift_element (name, value)
244              
245             Prepend a given name-value pair to the sequence.
246              
247             =cut
248              
249             sub unshift_element {
250 0     0 1 0 my ($self,$name,$value)=@_;
251 0         0 unshift @{$self->[0]},Treex::PML::Seq::Element->new($name,$value);
  0         0  
252             }
253              
254             =item $seq->unshift_element_obj (obj)
255              
256             Unshift a given Treex::PML::Seq::Element object to the sequence.
257              
258             =cut
259              
260             sub unshift_element_obj {
261 0     0 1 0 my ($self,$obj)=@_;
262 0         0 unshift @{$self->[0]},$obj;
  0         0  
263             }
264              
265             =item $seq->delete_element (element)
266              
267             Find and remove (all occurences) of a given Treex::PML::Seq::Element object
268             in the sequence. Returns the number of elements removed.
269              
270             =cut
271              
272             =item $seq->delete_element (element)
273              
274             Find and remove (all occurences) of a given Treex::PML::Seq::Element object
275             in the sequence. Returns the number of elements removed.
276              
277             =cut
278              
279             sub delete_element {
280 0     0 1 0 my ($self,$element)=@_;
281 0         0 my $start = @{$self->[0]};
  0         0  
282 0         0 @{$self->[0]} = grep { $_ != $element } @{$self->[0]};
  0         0  
  0         0  
  0         0  
283 0         0 my $end = @{$self->[0]};
  0         0  
284 0         0 return $start-$end;
285             }
286              
287             =item $seq->delete_value (value)
288              
289             Find and remove all elements with a given value. Returns the number of
290             elements removed.
291              
292             =cut
293              
294             sub delete_value {
295 0     0 1 0 my ($self,$value)=@_;
296 0         0 my $start = @{$self->[0]};
  0         0  
297 0         0 my $v;
298 0 0       0 if (ref($value)) {
299 0 0       0 @{$self->[0]} = grep { $v = $_->value; ref($v) and ($v != $value) } @{$self->[0]};
  0         0  
  0         0  
  0         0  
  0         0  
300             } else {
301 0 0       0 @{$self->[0]} = grep { $v = $_->value; !ref($v) and ($v ne $value) } @{$self->[0]};
  0         0  
  0         0  
  0         0  
  0         0  
302             }
303 0         0 my $end = @{$self->[0]};
  0         0  
304 0         0 return $start-$end;
305             }
306              
307             =item $seq->index_of ($value)
308              
309             Search the sequence for a particular value
310             and return the index of its first occurence in the sequence.
311              
312             Note: Use $seq->elements_list->index_of($element) to search for a Treex::PML::Seq::Element.
313              
314             =cut
315              
316             sub index_of {
317 0     0 1 0 my ($self,$value)=@_;
318 0 0       0 die 'Usage: Treex::PML::Seq->index_of($value) (wrong number of arguments!)'
319             if @_!=2;
320 0         0 my $list = $self->[0];
321 0 0       0 if (ref($value)) {
322 0         0 my $v;
323 0         0 for my $i (0..$#$list) {
324 0         0 $v = $list->[$i]->value;
325 0 0 0     0 return $i if ref($v) and $value == $v;
326             }
327             } else {
328 0         0 my $v;
329 0         0 for my $i (0..$#$list) {
330 0         0 $v = $list->[$i]->value;
331 0 0 0     0 return $i if !ref($v) and $value eq $v;
332             }
333             }
334 0         0 return;
335             }
336              
337             # sub splice {
338             # # TODO
339             # }
340             # sub delete_element_at {
341             # # TODO
342             # }
343             # sub store_element_at {
344             # # TODO
345             # }
346              
347             =item $list->empty ()
348              
349             Remove all values from the sequence.
350              
351             =cut
352              
353             sub empty {
354 0 0   0 1 0 die 'Usage: Treex::PML::Seq->empty() (wrong number of arguments!)'
355             if @_!=1;
356 0         0 my $self = shift;
357 0         0 $self->[0]->empty;
358 0         0 return $self;
359             }
360              
361             =back
362              
363             =head1 AUXILIARY FUNCTIONS
364              
365             =over 5
366              
367             =item Treex::PML::Seq::content_pattern2regexp($pattern)
368              
369             This utility function converts a given sequence content pattern string
370             into a Perl regular expression. The resulting expression matches
371             a list of element 'tags', where a tag is an element name surrounded by < and >.
372             For example, the content pattern 'A,#TEXT,(B+|C)*' translates roughly
373             to '<\#TEXT>(?:(?:)+(?:))*' and matches (a substring of) each of the following strings:
374              
375             '<#TEXT>'
376             'foo<#TEXT>bar'
377             '<#TEXT>'
378              
379             =back
380              
381             =cut
382              
383              
384             sub content_pattern2regexp {
385 9     9 1 26 my ($re)=@_;
386 9         84 $re=~s/[\${}\\]//g; # sanity
387 9         31 $re=~s/\(\?//g; # safety
388 9         26 $re=~s/\#/\\\#/g;
389 9         42 $re=~s/,/ /g;
390 9         74 $re=~s/\s+/ /g;
391 9         118 $re=~s/([^()?+*|,\s]+)/(?:<$1>)/g;
392 9         49 $re=~s/ //g;
393 9         45 return $re;
394             }
395              
396              
397             =head1 SEE ALSO
398              
399             L, L, L, L, L
400              
401             =head1 COPYRIGHT AND LICENSE
402              
403             Copyright (C) 2006-2010 by Petr Pajas
404              
405             This library is free software; you can redistribute it and/or modify
406             it under the same terms as Perl itself, either Perl version 5.8.2 or,
407             at your option, any later version of Perl 5 you may have available.
408              
409             =cut
410              
411              
412             1;