File Coverage

blib/lib/Treex/PML/FSFormat.pm
Criterion Covered Total %
statement 119 227 52.4
branch 38 110 34.5
condition 10 38 26.3
subroutine 20 39 51.2
pod 31 33 93.9
total 218 447 48.7


line stmt bran cond sub pod time code
1              
2             ############################################################
3             #
4             # FS Format
5             # =========
6             #
7             #
8              
9             package Treex::PML::FSFormat;
10 6     6   41 use Carp;
  6         13  
  6         299  
11 6     6   33 use strict;
  6         13  
  6         124  
12              
13 6     6   27 use vars qw($VERSION);
  6         14  
  6         244  
14             BEGIN {
15 6     6   119 $VERSION='2.24'; # version template
16             }
17 6     6   35 use UNIVERSAL::DOES;
  6         14  
  6         15970  
18              
19             my $attr_name_re='[^\\\\ \\n\\r\\t{}(),=|]+';
20              
21             # this is extendible
22             our $SpecialTypes='WNVH';
23             our %Specials = (sentord => 'W', order => 'N', value => 'V', hide => 'H');
24              
25             =head1 NAME
26              
27             Treex::PML::FSFormat - Treex::PML class representing the file header of a FS file.
28              
29             =over 4
30              
31             =item Treex::PML::FSFormat->new (array_ref_or_GLOB)
32              
33             NOTE: Don't call this constructor directly, use
34             Treex::PML::Factory->createFSFormat() instead!
35              
36             Create a new FS format instance object by parsing a given input as a
37             FS file header. If the argument is an ARRAY reference, each element is
38             assumed to represent a single line.
39              
40             =item Treex::PML::FSFormat->new (attributes_hash_ref?, ordered_names_list_ref?, unparsed_header?)
41              
42             NOTE: Don't call this constructor directly, use
43             Treex::PML::Factory->createFSFormat() instead!
44              
45             Create a new FS format instance object and C it with the
46             optional values.
47              
48             =cut
49              
50             sub new {
51 27     27 1 62 my $self = shift;
52 27   33     140 my $class = ref($self) || $self;
53 27         61 my $new = [];
54 27         63 bless $new, $class;
55 27 50 33     151 if (@_==1 and ref($_[0]) and !UNIVERSAL::isa($_[0],'HASH')) {
      33        
56 0         0 $new->initialize();
57 0         0 $new->readFrom(@_);
58             } else {
59 27         108 $new->initialize(@_);
60             }
61 27         83 return $new;
62             }
63              
64             =item Treex::PML::FSFormat->create (@header)
65              
66             NOTE: Don't call this constructor directly, use
67             Treex::PML::Factory->createFSFormat() instead!
68              
69             Same as Treex::PML::FSFormat->new (\@header).
70              
71             =cut
72              
73             sub create {
74 0     0 1 0 my $self = shift;
75 0         0 my $new=$self->new();
76 0         0 $new->readFrom([@_]);
77 0         0 return $new;
78             }
79              
80             =item $format->clone
81              
82             Duplicate FS format instance object.
83              
84             =cut
85              
86             sub clone {
87 0     0 1 0 my ($self) = @_;
88 0 0       0 return unless ref($self);
89             return $self->new(
90 0         0 {%{$self->defs()}},
91             [$self->attributes()],
92 0         0 [@{$self->unparsed()}],
  0         0  
93             undef, # specials
94             );
95             }
96              
97              
98             =pod
99              
100             =item $format->initialize (attributes_hash_ref?, ordered_names_list_ref?, unparsed_header?)
101              
102             Initialize a new FS format instance with given values. See L
103             for more information about attribute hash, ordered names list and unparsed headers.
104              
105             =cut
106              
107             sub initialize {
108 27     27 1 69 my $self = $_[0];
109 27 50       90 return unless ref($self);
110              
111 27 50       117 $self->[0] = ref($_[1]) ? $_[1] : { }; # attribs (hash)
112 27 50       107 $self->[1] = ref($_[2]) ? $_[2] : [ ]; # atord (sorted array)
113 27 50       102 $self->[2] = ref($_[3]) ? $_[3] : [ ]; # unparsed (sorted array)
114 27 50       84 $self->[3] = ref($_[4]) ? $_[4] : undef; # specials
115 27         61 return $self;
116             }
117              
118             =pod
119              
120             =item $format->addNewAttribute (type, colour, name, list)
121              
122             Adds a new attribute definition to the Treex::PML::FSFormat. Type must be one of
123             the letters [KPOVNWLH], colour one of characters [A-Z0-9]. If the type
124             is L, the fourth parameter is a string containing a list of possible
125             values separated by |.
126              
127             =cut
128              
129             sub addNewAttribute {
130 0     0 1 0 my ($self,$type,$color,$name,$list)=@_;
131 0 0       0 $self->list->[$self->count()]=$name if (!defined($self->defs->{$name}));
132 0 0       0 if (index($SpecialTypes, $type)+1) {
133 0         0 $self->set_special($type,$name);
134             }
135 0 0       0 if ($list) {
136 0         0 $self->defs->{$name}.=" $type=$list"; # so we create a list of defchars separated by spaces
137             } else { # a value-list may follow the equation mark
138 0         0 $self->defs->{$name}.=" $type";
139             }
140 0 0       0 if ($color) {
141 0         0 $self->defs->{$name}.=" $color"; # we add a special defchar for color
142             }
143             }
144              
145             =pod
146              
147             =item $format->readFrom (source,output?)
148              
149             Reads FS format instance definition from given source, optionally
150             echoing the unparsed input on the given output. The obligatory
151             argument C must be either a GLOB or list reference.
152             Argument C is optional and if given, it must be a GLOB reference.
153              
154             =cut
155              
156             sub readFrom {
157 2     2 1 5 my ($self,$handle,$out) = @_;
158 2 50       7 return unless ref($self);
159 2         14 require Treex::PML::Backend::FS;
160 2         5 my $read = \&Treex::PML::Backend::FS::ReadEscapedLine;
161 2         4 my %result;
162 2         4 my $count=0;
163 2         4 local $_;
164 2         7 while ($_=$read->($handle)) {
165 114         139 s/\r$//o;
166 114 50       156 if (ref($out)) {
167 0         0 print $out $_;
168             } else {
169 114         106 push @{$self->unparsed}, $_;
  114         152  
170             }
171 114 100       405 if (/^\@([KPOVNWLHE])([A-Z0-9])* (${attr_name_re})(?:\|(.*))?/o) {
    50          
172 112 50       230 if ($1 eq 'E') {
173 0 0       0 unless (defined $self->special('E')) {
174 0         0 $self->set_special('E',$3);
175 0 0       0 if (ref($handle) ne 'ARRAY') {
176 0         0 binmode $handle, ':raw:perlio:encoding('.$3.')';
177 0 0       0 if ($count>0) {
178 0         0 warn "\@E should be on the first line!\n";
179             }
180             }
181             } else {
182 0         0 warn __PACKAGE__.": There should be just one encoding (\@E) and that should occur on the very first line. Ignoring $_!\n";
183             }
184 0         0 next;
185             }
186 112 100       221 if (index($SpecialTypes, $1)+1) {
187 6         14 $self->set_special($1,$3);
188             }
189 112 100       173 $self->list->[$count++]=$3 if (!defined($self->defs->{$3}));
190 112 100       192 if ($4) {
191 2         4 $self->defs->{$3}.=" $1=$4"; # so we create a list of defchars separated by spaces
192             } else { # a value-list may follow the equation mark
193 110         136 $self->defs->{$3}.=" $1";
194             }
195 112 100       204 if ($2) {
196 10         15 $self->defs->{$3}.=" $2"; # we add a special defchar for color
197             }
198 112         177 next;
199             } elsif (/^\r*$/o) {
200 2         4 last;
201             } else {
202 0         0 return 0;
203             }
204             }
205 2         8 return 1;
206             }
207              
208             =item $format->toArray
209              
210             Return FS declaration as an array of FS header declarations.
211              
212             =cut
213              
214             sub toArray {
215 1     1 1 2 my ($self) = @_;
216 1 50       4 return unless ref($self);
217 1         3 my $defs = $self->defs;
218 1         5 my @ad;
219             my @result;
220 1         0 my $l;
221 1         0 my $vals;
222 1         1 foreach (@{$self->list}) {
  1         2  
223 50         83 @ad=split ' ',$defs->{$_};
224 50         68 while (@ad) {
225 56         66 $l='@';
226 56 100       78 if ($ad[0]=~/^L=(.*)/) {
227 1         4 $vals=$1;
228 1         2 shift @ad;
229 1         2 $l.="L";
230 1 50 33     8 $l.=shift @ad if (@ad and $ad[0]=~/^[A0-3]/);
231 1         10 $l.=" $_|$vals\n";
232             } else {
233 55 50       86 $l.=shift @ad if @ad;
234 55 100 100     104 $l.=shift @ad if (@ad and $ad[0]=~/^[A0-3]/);
235 55         77 $l.=" $_\n";
236             }
237 56         112 push @result, $l;
238             }
239             }
240 1         4 push @result,"\n";
241 1         25 return @result;
242             }
243              
244             =item $format->writeTo (glob_ref)
245              
246             Write FS declaration to a given file (file handle open for
247             reading must be passed as a GLOB reference).
248              
249             =cut
250              
251             sub writeTo {
252 1     1 1 4 my ($self,$fileref) = @_;
253 1 50       3 return unless ref($self);
254 1         3 print $fileref $self->toArray;
255 1         7 return 1;
256             }
257              
258              
259             =pod
260              
261             =item $format->sentord (), order(), value(), hide()
262              
263             Return names of special attributes declared in FS format as @W, @N,
264             @V, @H respectively.
265              
266             =cut
267              
268             {
269             my ($sub, $key);
270             while (($sub,$key)= each %Specials) {
271 0     0 1 0 eval "sub $sub { \$_[0]->special('$key'); }";
  0     0 1 0  
  0     0 1 0  
  0     0 1 0  
272             }
273             }
274              
275             sub DESTROY {
276 27     27   72 my ($self) = @_;
277 27 50       103 return unless ref($self);
278 27         124 $self->[0]=undef;
279 27         72 $self->[1]=undef;
280 27         75 $self->[2]=undef;
281 27         875 $self=undef;
282             }
283              
284             =pod
285              
286             =item $format->isHidden (node)
287              
288             Return the lowest ancestor-or-self of the given node whose value of
289             the FS attribute declared as @H is either C<'hide'> or 1. Return
290             undef, if no such node exists.
291              
292             =cut
293              
294             sub isHidden {
295             # Tests if given node is hidden or not
296             # Returns the ancesor that hides it or undef
297 0     0 1 0 my ($self,$node)=@_;
298 0         0 my $hide=$self->special('H');
299 0 0       0 return unless defined $hide;
300 0         0 my $h;
301 0   0     0 while ($node and !(($h = $node->get_member($hide)) eq 'hide'
      0        
302             or $h eq 'true'
303             or $h == 1 )) {
304 0         0 $node=$node->parent;
305             }
306 0   0     0 return ($node||undef);
307             }
308              
309             =pod
310              
311             =item $format->defs
312              
313             Return a reference to the internally stored attribute hash.
314              
315             =cut
316              
317             sub defs {
318 403     403 1 508 my ($self) = @_;
319 403 50       1104 return ref($self) ? $self->[0] : undef;
320             }
321              
322             =pod
323              
324             =item $format->list
325              
326             Return a reference to the internally stored attribute names list.
327              
328             =cut
329              
330             sub list {
331 147     147 1 181 my ($self) = @_;
332 147 50       400 return ref($self) ? $self->[1] : undef;
333             }
334              
335             =pod
336              
337             =item $format->unparsed
338              
339             Return a reference to the internally stored unparsed FS header. Note,
340             that this header must B correspond to the defs and attributes if
341             any changes are made to the definitions or names at run-time by hand.
342              
343             =cut
344              
345             sub unparsed {
346 114     114 1 187 my ($self) = @_;
347 114 50       229 return ref($self) ? $self->[2] : undef;
348             }
349              
350              
351             =pod
352              
353             =item $format->renew_specials
354              
355             Refresh special attribute hash.
356              
357             =cut
358              
359             sub renew_specials {
360 2     2 1 5 my ($self)=@_;
361 2         6 my $re = " ([$SpecialTypes])";
362 2         3 my %spec;
363 2         6 my $defs = $self->[0]; # defs
364 2         3 my ($k,$v);
365 2         12 while (($k,$v)=each %$defs) {
366 12 50       55 $spec{$1} = $k if $v=~/$re/o;
367             }
368 2         8 return $self->[3] = \%spec;
369             }
370              
371             # obsolete
372             sub findSpecialDef {
373 0     0 0 0 my ($self,$defchar)=@_;
374 0         0 my $defs = $self->defs;
375 0         0 foreach (keys %{$defs}) {
  0         0  
376 0 0       0 return $_ if (index($defs->{$_}," $defchar")>=0);
377             }
378 0         0 return undef; # we want an explicit undef here!!
379             }
380              
381             =item $format->specials
382              
383             Return a reference to a hash of attributes of special types. Keys
384             of the hash are special attribute types and values are their names.
385              
386             =cut
387              
388             sub specials {
389 0     0 1 0 my ($self) = @_;
390 0   0     0 return ($self->[3] || $self->renew_specials());
391             }
392              
393             =pod
394              
395             =item $format->attributes
396              
397             Return a list of all attribute names (in the order given by FS
398             instance declaration).
399              
400             =cut
401              
402             sub attributes {
403 4     4 1 9 my ($self) = @_;
404 4         6 return @{$self->list};
  4         8  
405             }
406              
407             =pod
408              
409             =item $format->atno (n)
410              
411             Return the n'th attribute name (in the order given by FS
412             instance declaration).
413              
414             =cut
415              
416              
417             sub atno {
418 0     0 1 0 my ($self,$index) = @_;
419 0 0       0 return ref($self) ? $self->list->[$index] : undef;
420             }
421              
422             =pod
423              
424             =item $format->atdef (attribute_name)
425              
426             Return the definition string for the given attribute.
427              
428             =cut
429              
430             sub atdef {
431 0     0 1 0 my ($self,$name) = @_;
432 0 0       0 return ref($self) ? $self->defs->{$name} : undef;
433             }
434              
435             =pod
436              
437             =item $format->count
438              
439             Return the number of declared attributes.
440              
441             =cut
442              
443             sub count {
444 0     0 1 0 my ($self) = @_;
445 0 0       0 return ref($self) ? $#{$self->list}+1 : undef;
  0         0  
446             }
447              
448             =pod
449              
450             =item $format->isList (attribute_name)
451              
452             Return true if given attribute is assigned a list of all possible
453             values.
454              
455             =cut
456              
457             sub isList {
458 100     100 1 131 my ($self,$attrib)=@_;
459 100 100       141 return (index($self->defs->{$attrib}," L")>=0) ? 1 : 0;
460             }
461              
462             =pod
463              
464             =item $format->listValues (attribute_name)
465              
466             Return the list of all possible values for the given attribute.
467              
468             =cut
469              
470             sub listValues {
471 2     2 1 7 my ($self,$attrib)=@_;
472 2 50       8 return unless ref($self);
473              
474 2         6 my $defs = $self->defs;
475 2         19 my ($I,$b,$e);
476 2         6 $b=index($defs->{$attrib}," L=");
477 2 50       7 if ($b>=0) {
478 2         4 $e=index($defs->{$attrib}," ",$b+1);
479 2 50       4 if ($e>=0) {
480 2         110 return split /\|/,substr($defs->{$attrib},$b+3,$e-$b-3);
481             } else {
482 0         0 return split /\|/,substr($defs->{$attrib},$b+3);
483             }
484 0         0 } else { return (); }
485             }
486              
487             =pod
488              
489             =item $format->color (attribute_name)
490              
491             Return one of C, C and C depending on the
492             color assigned to the given attribute in the FS format instance.
493              
494             =cut
495              
496             sub color {
497 0     0 1 0 my ($self,$arg) = @_;
498 0 0       0 return unless ref($self);
499              
500 0 0       0 if (index($self->defs->{$arg}," 1")>=0) {
    0          
    0          
501 0         0 return "Shadow";
502             } elsif (index($self->defs->{$arg}," 2")>=0) {
503 0         0 return "Hilite";
504             } elsif (index($self->defs->{$arg}," 3")>=0) {
505 0         0 return "XHilite";
506             } else {
507 0         0 return "normal";
508             }
509             }
510              
511             =pod
512              
513             =item $format->special (letter)
514              
515             Return name of a special attribute declared in FS definition with a
516             given letter. See also sentord() and similar.
517              
518             =cut
519              
520             sub special {
521 2     2 1 19 my ($self,$defchar)=@_;
522 2   33     8 return ($self->[3]||$self->renew_specials)->{$defchar};
523             }
524              
525             sub set_special {
526 6     6 0 19 my ($self,$defchar,$value)=@_;
527 6   66     21 my $spec = ($self->[3]||$self->renew_specials);
528 6         14 $spec->{$defchar}=$value;
529 6         10 return;
530             }
531              
532             =pod
533              
534             =item $format->indexOf (attribute_name)
535              
536             Return index of the given attribute (in the order given by FS
537             instance declaration).
538              
539             =cut
540              
541             sub indexOf {
542 0     0 1   my ($self,$arg)=@_;
543             return
544 0 0         ref($self) ? Treex::PML::Index($self->list,$arg) : undef;
545             }
546              
547             =item $format->exists (attribute_name)
548              
549             Return true if an attribute of the given name exists.
550              
551             =cut
552              
553             sub exists {
554 0     0 1   my ($self,$arg)=@_;
555             return
556             ref($self) ?
557             (exists($self->defs->{$arg}) &&
558 0 0 0       defined($self->defs->{$arg})) : undef;
559             }
560              
561              
562             =pod
563              
564             =item $format->make_sentence (root_node,separator)
565              
566             Return a string containing the content of value (special) attributes
567             of the nodes of the given tree, separated by separator string, sorted by
568             value of the (special) attribute sentord or (if sentord does not exist) by
569             (special) attribute order.
570              
571             =cut
572              
573             sub make_sentence {
574 0     0 1   my ($self,$root,$separator)=@_;
575 0 0         return unless ref($self);
576 0 0         $separator=' ' unless defined($separator);
577 0           my @nodes=();
578 0   0       my $sentord = $self->sentord || $self->order;
579 0           my $value = $self->value;
580 0           my $node=$root;
581 0           while ($node) {
582 0           push @nodes,$node;
583 0           $node=$node->following($root);
584             }
585             return join ($separator,
586 0           map { $_->getAttribute($value) }
587 0           sort { $a->getAttribute($sentord) <=> $b->getAttribute($sentord) } @nodes);
  0            
588             }
589              
590              
591             =pod
592              
593             =item $format->clone_node
594              
595             Create a copy of the given node.
596              
597             =cut
598              
599             sub clone_node {
600 0     0 1   my ($self,$node)=@_;
601 0           my $new = ref($node)->new();
602 0 0         if ($node->type) {
603 0           foreach my $atr ($node->type->get_normal_fields,'#name') {
604 0 0         if (ref($node->{$atr})) {
605 0           $new->{$atr} = Treex::PML::CloneValue($node->{$atr});
606             } else {
607 0           $new->{$atr} = $node->{$atr};
608             }
609             }
610 0           $new->set_type($node->type);
611             } else {
612 0           foreach (@{$self->list}) {
  0            
613 0           $new->{$_}=$node->{$_};
614             }
615             }
616 0           return $new;
617             }
618              
619             =item $format->clone_subtree
620              
621             Create a deep copy of the given subtree.
622              
623             =cut
624              
625             sub clone_subtree {
626 0     0 1   my ($self,$node)=@_;
627 0           my $nc;
628 0 0         return 0 unless $node;
629 0           my $prev_nc=0;
630 0           my $nd=$self->clone_node($node);
631 0           foreach ($node->children()) {
632 0           $nc=$self->clone_subtree($_);
633 0           $nc->set_parent($nd);
634 0 0         if ($prev_nc) {
635 0           $nc->set_lbrother($prev_nc);
636 0           $prev_nc->set_rbrother($nc);
637             } else {
638 0           $nd->set_firstson($nc);
639             }
640 0           $prev_nc=$nc;
641             }
642 0           return $nd;
643             }
644              
645              
646             =pod
647              
648             =back
649              
650             =cut
651              
652             =head1 SEE ALSO
653              
654             L, L, L, L
655              
656             =head1 COPYRIGHT AND LICENSE
657              
658             Copyright (C) 2006-2010 by Petr Pajas
659              
660             This library is free software; you can redistribute it and/or modify
661             it under the same terms as Perl itself, either Perl version 5.8.2 or,
662             at your option, any later version of Perl 5 you may have available.
663              
664             =cut
665              
666              
667             1;