File Coverage

blib/lib/Treex/PML/Node.pm
Criterion Covered Total %
statement 19 21 90.4
branch n/a
condition n/a
subroutine 8 8 100.0
pod n/a
total 27 29 93.1


line stmt bran cond sub pod time code
1             package Treex::PML::Node;
2              
3 1     1   686 use 5.008;
  1         2  
4 1     1   3 use strict;
  1         1  
  1         14  
5 1     1   2 use warnings;
  1         1  
  1         20  
6              
7 1     1   3 use vars qw($VERSION);
  1         1  
  1         32  
8             BEGIN {
9 1     1   10 $VERSION='2.21'; # version template
10             }
11 1     1   3 use Carp;
  1         1  
  1         47  
12              
13 1     1   3 use base qw(Treex::PML::Struct);
  1         1  
  1         59  
14              
15 1     1   29 use Treex::PML::Schema;
  0            
  0            
16             require Treex::PML::Instance;
17             use UNIVERSAL::DOES;
18             use Scalar::Util qw(weaken);
19              
20             our ($parent, $firstson, $lbrother, $rbrother, $TYPE) = qw(_P_ _S_ _L_ _R_ _T_);
21              
22             =pod
23              
24             =head1 NAME
25              
26             Treex::PML::Node - Treex::PML class representing a node.
27              
28             =head1 DESCRIPTION
29              
30             This class implements a node in a tree. The node has zero or one
31             parent node (C) (if it has no parent, it is a root of a
32             tree), zero or more child nodes (the left-most of them returned by
33             C) and zero or more siblings (C is the
34             immediate sibling the left and C is the immediate sibling
35             the right).
36              
37             A node can also be associated with a PML type (contianer or structure)
38             and may carry named attributes (with atomic or complex values).
39              
40             =head2 Representation of trees
41              
42             L provides representation for oriented rooted trees (such as
43             dependency trees or constituency trees).
44              
45             In L, each tree is represented by its root-node. A node is a
46             Treex::PML::Node object, which is underlined by a usual Perl hash
47             reference whose hash keys represent node attributes (name-value
48             pairs).
49              
50             The set of available attributes at each node is specified in the data
51             format (which, depending on I/O backend, is represented either by a
52             L or L object; whereas
53             L uses a fixed set of attributes for all nodes
54             with text values (or alternating text values), in
55             L the set of attributes may depend on the type of
56             the node and a wide range of data-structures is supported for
57             attribute values. In particular, attribute values may be plain
58             scalars or L data objects (L,
59             L, L, L,
60             L.
61              
62             FS format also allows to declare some attributes as representants of
63             extra features, such as total ordering on a tree, text value of a
64             node, indicator for "hidden" nodes, etc. Similarly, in PML schema,
65             some attributes may be associated with roles, e.g. the role '#ID' for
66             an attribute carrying a unique identifier of the node, or '#ORDER' for
67             an integer attribute representing the order of the node in the
68             horizontal ordering of the tree.
69              
70             The tree structure can be modified and traversed by various
71             Treex::PML::Node object methods, such as C, C,
72             C, C, C, C, C,
73             C, C, and C.
74              
75             Four special hash keys are reserved for representing the tree
76             structure in the Treex::PML::Node hash. These keys are defined in
77             global variables: C<$Treex::PML::Node::parent>, C<$Treex::PML::Node::firstson>,
78             C<$Treex::PML::Node::rbrother>, and C<$Treex::PML::Node::lbrother>. Another
79             special key C<$Treex::PML::Node::type> is reserved for storing data type
80             information. It is highly recommended to use Treex::PML::Node
81             object methods instead of accessing these hash keys directly. By
82             default, the values of these special keys in order are C<_P_>, C<_S_>,
83             C<_R_>, C<_L_>, C<_T_>.
84              
85             Although arbitrary non-attribute non-special keys may be added to the
86             node hashes at run-time, such keys are not normally preserved via I/O
87             backends and extreme care must be taken to aviod conflicts with
88             attribute names or the special hash keys described above.
89              
90             =head1 METHODS
91              
92             =over 4
93              
94             =item Treex::PML::Node->new($hash?,$reuse?)
95              
96             NOTE: Don't call this constructor directly, use Treex::PML::Factory->createTypedNode() or
97             Treex::PML::Factory->createNode() instead!
98              
99             Create a new Treex::PML::Node object. Treex::PML::Node is basically a hash reference. This
100             means that node's attributes can be accessed simply as
101             C<$node->>C<{attribute}>.
102              
103             If a hash-reference is passed as the 1st argument, all its keys and
104             values are are copied to the new Treex::PML::Node.
105              
106             An optional 2nd argument $reuse can be set to a true value to indicate
107             that the passed hash-reference can be used directly as the underlying
108             hash-reference for the new Treex::PML::Node object (which avoids copying). It
109             is, however, not guaranteed that the hash-reference will be reused;
110             the caller thus must even in this case work with the object returned
111             by the constructor rather that the hash-reference passed.
112              
113             Returns the newly created Treex::PML::Node object.
114              
115             =cut
116              
117              
118             sub new {
119             my $self = shift;
120             my $class = ref($self) || $self;
121             my $new = shift;
122             if (ref($new)) {
123             my $reuse=shift;
124             unless ($reuse) {
125             $new={%$new};
126             }
127             } else {
128             my $size=$new;
129             croak("Usage: ".__PACKAGE__."->new(key=>value, ...) - got ",join(', ',map ref($_).qq{= '$_'},@_)) if scalar(@_)/2!=0;
130             $new = {@_};
131             keys (%$new) = $size + 5 if defined($size);
132             }
133             bless $new, $class;
134             return $new;
135             }
136              
137             =pod
138              
139             =item $node->destroy
140              
141             This function destroys a Treex::PML::Node (and all its descendants).
142             If the node has a parent, it is cut from it first.
143              
144             =cut
145              
146             sub destroy {
147             my ($top) = @_;
148             $top->cut() if $top->{$parent};
149             undef %$_ for ($top->descendants,$top);
150             return;
151             }
152              
153             =item $node->destroy_leaf
154              
155             This function destroys a leaf Treex::PML::Node and fails if the node is not a leaf (has children).
156             If the node has a parent, it is cut from it first.
157              
158             =cut
159              
160             sub destroy_leaf {
161             my ($node) = @_;
162             unless ($node->firstson) {
163             $node->cut;
164             undef %$node;
165             undef $node;
166             return 1;
167             } else {
168             croak(ref($node)."->destroy_leaf: Not a leaf node");
169             }
170             }
171              
172             {
173             no warnings qw(recursion); # disable deep recursion warnings in Treex::PML::Node::DESTROY (btw, no recursion there:-))
174             sub DESTROY {
175             my ($self) = @_;
176             return unless ref($self);
177             %{$self}=(); # this should not be needed, but
178             # without it, perl 5.10 leaks on weakened
179             # structures, try:
180             # Scalar::Util::weaken({}) while 1
181             return 1;
182             }
183             }
184              
185             =pod
186              
187             =item $node->parent
188              
189             Return node's parent node (C if none).
190              
191             =cut
192              
193             sub parent {
194             return shift()->{$parent};
195             }
196              
197             =pod
198              
199             =item $node->type (attr-path?)
200              
201             If called without an argument or if C is empty, return
202             node's data-type declaration (C if none). If C is
203             non-empty, return the data-type declaration of the value reachable
204             from C<$node> under the attribute-path C.
205              
206             =cut
207              
208              
209             sub type {
210             my ($self,$attr) = @_;
211             my $type = $self->{$TYPE};
212             if (defined $attr and length $attr) {
213             return $type ? $type->find($attr,1) : undef;
214             } else {
215             return $type;
216             }
217             }
218              
219             =item $node->root
220              
221             Find and return the root of the node's tree.
222              
223             =cut
224              
225              
226             sub root {
227             my ($node) = @_;
228             while (my $p = $node->{$parent}) {
229             $node=$p;
230             }
231             return $node;
232             }
233              
234             =item $node->level
235              
236             Calculate node's level (root-level is 0).
237              
238             =cut
239              
240             sub level {
241             my ($node) = @_;
242             my $level=-1;
243             while ($node) {
244             $node=$node->parent;
245             $level++;
246             } return $level;
247             }
248              
249              
250             =pod
251              
252             =item $node->lbrother
253              
254             Return node's left brother node (C if none).
255              
256             =cut
257              
258             sub lbrother {
259             return shift()->{$lbrother};
260             }
261              
262             =pod
263              
264             =item $node->rbrother
265              
266             Return node's right brother node (C if none).
267              
268             =cut
269              
270             sub rbrother {
271             return shift()->{$rbrother};
272             }
273              
274             =pod
275              
276             =item $node->firstson
277              
278             Return node's first dependent node (C if none).
279              
280             =cut
281              
282             sub firstson {
283             return shift()->{$firstson};
284             }
285              
286             sub set_parent {
287             my ($node,$p) = @_;
288             if (ref( $p )) {
289             weaken( $node->{$parent} = $p );
290             } else {
291             $node->{$parent} = undef;
292             }
293             return $p;
294             }
295              
296             sub set_lbrother {
297             my ($node,$p) = @_;
298             if (ref( $p )) {
299             weaken( $node->{$lbrother} = $p );
300             } else {
301             $node->{$lbrother} = undef;
302             }
303             return $p;
304             }
305              
306             sub set_rbrother {
307             my ($node,$p) = @_;
308             $node->{$rbrother}= ref($p) ? $p : undef;
309             }
310              
311             sub set_firstson {
312             my ($node,$p) = @_;
313             $node->{$firstson}=ref($p) ? $p : undef;
314             }
315              
316             =item $node->set_type (type)
317              
318             Wherever possible, avoid using this method directly; instead
319             create a typed nodes using Treex::PML::Factory->createTypedNode().
320              
321             Associate Treex::PML::Node object with a type declaration-object (see
322             L class).
323              
324             =cut
325              
326             sub set_type {
327             my ($node,$t) = @_;
328             $node->{$TYPE}=$t;
329             }
330              
331             =item $node->set_type_by_name (schema,type-name)
332              
333             Lookup a structure or container declaration in the given Treex::PML::Schema
334             by its type name and associate the corresponding type-declaration
335             object with the Treex::PML::Node.
336              
337             =cut
338              
339             sub set_type_by_name {
340             if (@_!=3) {
341             croak('Usage: $node->set_type_by_name($schema, $type_name)');
342             }
343             my ($node,$schema,$name) = @_;
344             my $type = $schema->get_type_by_name($name);
345             if (ref($type)) {
346             my $decl_type = $type->get_decl_type;
347             if ($decl_type == PML_MEMBER_DECL() ||
348             $decl_type == PML_ELEMENT_DECL() ||
349             $decl_type == PML_TYPE_DECL() ||
350             $decl_type == PML_ROOT_DECL() ) {
351             $type = $type->get_content_decl;
352             }
353             $decl_type = $type->get_decl_type;
354             if ($decl_type == PML_CONTAINER_DECL() ||
355             $decl_type == PML_STRUCTURE_DECL()) {
356             $node->set_type($type);
357             } else {
358             croak __PACKAGE__."::set_type_by_name: Incompatible type '$name' (neither a structure nor a container)";
359             }
360             } else {
361             croak __PACKAGE__."::set_type_by_name: Type not found '$name'";
362             }
363             }
364              
365             =item $node->validate (attr-path?,log?)
366              
367             This method requires C<$node> to be associated with a type declaration.
368              
369             Validates the content of the node according to the associated type and
370             schema. If attr-path is non-empty, validate only attribute selected by
371             the attribute path. An array reference may be passed as the 2nd
372             argument C to obtain a detailed report of all validation errors.
373              
374             Note: this method does not validate descendants of the node. Use e.g.
375              
376             $node->validate_subtree(\@log);
377              
378             to validate the complete subtree.
379              
380             Returns: 1 if the content validates, 0 otherwise.
381              
382             =cut
383              
384             sub validate {
385             my ($node, $path, $log) = @_;
386             if (defined $log and UNIVERSAL::isa($log,'ARRAY')) {
387             croak __PACKAGE__."::validate: log must be an ARRAY reference";
388             }
389             my $type = $node->type;
390             if (!ref($type)) {
391             croak __PACKAGE__."::validate: Cannot determine node data type!";
392             }
393             if ($path eq q{}) {
394             $type->validate_object($node,{ log=>$log, no_childnodes => 1 });
395             } else {
396             my $mtype = $type->find($path);
397             if ($mtype) {
398             $mtype->validate_object($node->attr($path),
399             {
400             path => $path,
401             log=>$log
402             });
403             } else {
404             croak __PACKAGE__."::validate: can't determine data type from attribute-path '$path'!";
405             }
406             }
407             }
408              
409             =item $node->validate_subtree (log?)
410              
411             This method requires C<$node> to be associated with a type declaration.
412              
413             Validates the content of the node and all its descendants according to
414             the associated type and schema. An array reference C may be
415             passed as an argument to obtain a detailed report of all validation
416             errors.
417              
418             Returns: 1 if the subtree validates, 0 otherwise.
419              
420             =cut
421              
422             sub validate_subtree {
423             my ($node, $log) = @_;
424             if (defined $log and ! UNIVERSAL::isa($log,'ARRAY')) {
425             croak __PACKAGE__."::validate: log must be an ARRAY reference";
426             }
427             my $type = $node->type;
428             if (!ref($type)) {
429             croak __PACKAGE__."::validate: Cannot determine node data type!";
430             }
431             $type->validate_object($node,{ log=>$log });
432             }
433              
434             =item $node->attribute_paths
435              
436             This method requires C<$node> to be associated with a type declaration.
437              
438             This method is similar to Treex::PML::Schema->attributes but for a single
439             node. It returns attribute paths valid for the current node. That is,
440             it returns paths to all atomic subtypes of the type of the current
441             node.
442              
443              
444             =cut
445              
446             sub attribute_paths {
447             my ($node) = @_;
448             my $type = $node->type;
449             return unless $type;
450             return $type->schema->get_paths_to_atoms([$type],{ no_childnodes => 1 });
451             }
452              
453              
454             =pod
455              
456             =item $node->following (top?)
457              
458             Return the next node of the subtree in the order given by structure
459             (C if none). If any descendant exists, the first one is
460             returned. Otherwise, right brother is returned, if any. If the given
461             node has neither a descendant nor a right brother, the right brother
462             of the first (lowest) ancestor for which right brother exists, is
463             returned.
464              
465             =cut
466              
467             sub following {
468             my ($node,$top) = @_;
469             if ($node->{$firstson}) {
470             return $node->{$firstson};
471             }
472             $top||=0; # for ==
473             do {
474             return if ($node==$top or !$node->{$parent});
475             return $node->{$rbrother} if $node->{$rbrother};
476             $node = $node->{$parent};
477             } while ($node);
478             return;
479             }
480              
481             =pod
482              
483             =item $node->following_visible (FSFormat_object,top?)
484              
485             Return the next visible node of the subtree in the order given by
486             structure (C if none). A node is considered visible if it has
487             no hidden ancestor. Requires FSFormat object as the first parameter.
488              
489             =cut
490              
491             sub following_visible {
492             my ($self,$fsformat,$top) = @_;
493             return unless ref($self);
494             my $node=$self->following($top);
495             return $node unless ref($fsformat);
496             my $hiding;
497             while ($node) {
498             return $node unless ($hiding=$fsformat->isHidden($node));
499             $node=$hiding->following_right_or_up($top);
500             }
501             }
502              
503             =pod
504              
505             =item $node->following_right_or_up (top?)
506              
507             Return the next node of the subtree in the order given by
508             structure (C if none), but not descending.
509              
510             =cut
511              
512             sub following_right_or_up {
513             my ($self,$top) = @_;
514             return unless ref($self);
515              
516             my $node=$self;
517             while ($node) {
518             return 0 if (defined($top) and $node==$top or !$node->parent);
519             return $node->rbrother if $node->rbrother;
520             $node = $node->parent;
521             }
522             }
523              
524              
525             =pod
526              
527             =item $node->previous (top?)
528              
529             Return the previous node of the subtree in the order given by
530             structure (C if none). The way of searching described in
531             C is used here in reversed order.
532              
533             =cut
534              
535             sub previous {
536             my ($node,$top) = @_;
537             return unless ref $node;
538             $top||=0;
539             if ($node->{$lbrother}) {
540             $node = $node->{$lbrother};
541             DIGDOWN: while ($node->{$firstson}) {
542             $node = $node->{$firstson};
543             LASTBROTHER: while ($node->{$rbrother}) {
544             $node = $node->{$rbrother};
545             next LASTBROTHER;
546             }
547             next DIGDOWN;
548             }
549             return $node;
550             }
551             return if ($node == $top or !$node->{$parent});
552             return $node->{$parent};
553             }
554              
555              
556             =pod
557              
558             =item $node->previous_visible (FSFormat_object,top?)
559              
560             Return the next visible node of the subtree in the order given by
561             structure (C if none). A node is considered visible if it has
562             no hidden ancestor. Requires FSFormat object as the first parameter.
563              
564             =cut
565              
566             sub previous_visible {
567             my ($self,$fsformat,$top) = @_;
568             return unless ref($self);
569             my $node=$self->previous($top);
570             my $hiding;
571             return $node unless ref($fsformat);
572             while ($node) {
573             return $node unless ($hiding=$fsformat->isHidden($node));
574             $node=$hiding->previous($top);
575             }
576             }
577              
578              
579             =pod
580              
581             =item $node->rightmost_descendant (node)
582              
583             Return the rightmost lowest descendant of the node (or
584             the node itself if the node is a leaf).
585              
586             =cut
587              
588             sub rightmost_descendant {
589             my ($self) = @_;
590             return unless ref($self);
591             my $node=$self;
592             DIGDOWN: while ($node->firstson) {
593             $node = $node->firstson;
594             LASTBROTHER: while ($node->rbrother) {
595             $node = $node->rbrother;
596             next LASTBROTHER;
597             }
598             next DIGDOWN;
599             }
600             return $node;
601             }
602              
603              
604             =pod
605              
606             =item $node->leftmost_descendant (node)
607              
608             Return the leftmost lowest descendant of the node (or
609             the node itself if the node is a leaf).
610              
611             =cut
612              
613             sub leftmost_descendant {
614             my ($self) = @_;
615             return unless ref($self);
616             my $node=$self;
617             $node=$node->firstson while ($node->firstson);
618             return $node;
619             }
620              
621             =pod
622              
623             =item $node->getAttribute (attr_name)
624              
625             Return value of the given attribute.
626              
627             =cut
628              
629             # compatibility
630             sub getAttribute { shift()->get_member(@_) }
631              
632             =item $node->attr (path)
633              
634             Retrieve first value matching a given attribute path.
635              
636             $node->attr($path)
637              
638             is an alias for
639              
640             Treex::PML::Instance::get_data($node,$path);
641              
642             See L for details.
643              
644             =cut
645              
646             sub attr {
647             &Treex::PML::Instance::get_data;
648             }
649              
650             =item $node->all (path)
651              
652             Retrieve all values matching a given attribute path.
653              
654             $node->all($path)
655              
656             is an alias for
657              
658             Treex::PML::Instance::get_all($node,$path);
659              
660             See L for details.
661              
662             =cut
663              
664             sub all {
665             &Treex::PML::Instance::get_all;
666             }
667              
668             sub flat_attr {
669             my ($node,$path) = @_;
670             return "$node" unless ref($node);
671             my ($step,$rest) = split /\//, $path,2;
672             if (UNIVERSAL::DOES::does($node,'Treex::PML::List') or
673             UNIVERSAL::DOES::does($node,'Treex::PML::Alt')) {
674             if ($step =~ /^\[(\d+)\]$/) {
675             return flat_attr($node->[$1-1],$rest);
676             } else {
677             return join "|",map { flat_attr($_,$rest) } @$node;
678             }
679             } else {
680             return flat_attr($node->{$step},$rest);
681             }
682             }
683              
684             =item $node->set_attr (path,value,strict?)
685              
686             Store a given value to a possibly nested attribute of $node specified
687             by path. The path argument uses the XPath-like syntax described in
688             L.
689              
690             =cut
691              
692             sub set_attr {
693             &Treex::PML::Instance::set_data;
694             }
695              
696             =pod
697              
698             =item $node->setAttribute (name,value)
699              
700             Set value of the given attribute.
701              
702             =cut
703              
704             # compatibility
705             BEGIN {
706             *setAttribute = \&set_member;
707             }
708              
709             =pod
710              
711             =item $node->children
712              
713             Return a list of dependent nodes.
714              
715             =cut
716              
717             sub children {
718             my $self = $_[0];
719             my @children=();
720             my $child=$self->firstson;
721             while ($child) {
722             push @children, $child;
723             $child=$child->rbrother;
724             }
725             return @children;
726             }
727              
728             =pod
729              
730             =item $node->visible_children (fsformat)
731              
732             Return a list of visible dependent nodes.
733              
734             =cut
735              
736             sub visible_children {
737             my ($self,$fsformat) = @_;
738             croak "required parameter missing for visible_children(fsformat)" unless $fsformat;
739             my @children=();
740             unless ($fsformat->isHidden($self)) {
741             my $hid=$fsformat->hide;
742             my $child=$self->firstson;
743             while ($child) {
744             my $hidden = $child->getAttribute($hid);
745             push @children, $child unless defined($hidden) and length($hidden);
746             $child=$child->rbrother;
747             }
748             }
749             return @children;
750             }
751              
752              
753             =item $node->descendants
754              
755             Return a list recursively dependent nodes.
756              
757             =cut
758              
759             sub descendants {
760             my $self = $_[0];
761             my @kin=();
762             my $desc=$self->following($self);
763             while ($desc) {
764             push @kin, $desc;
765             $desc=$desc->following($self);
766             }
767             return @kin;
768             }
769              
770             =item $node->visible_descendants (fsformat)
771              
772             Return a list recursively dependent visible nodes.
773              
774             =cut
775              
776             sub visible_descendants {
777             my ($self,$fsformat) = @_;
778             croak "required parameter missing for visible_descendants(fsfile)" unless $fsformat;
779             my @kin=();
780             my $desc=$self->following_visible($fsformat,$self);
781             while ($desc) {
782             push @kin, $desc;
783             $desc=$desc->following_visible($fsformat,$self);
784             }
785             return @kin;
786             }
787              
788             =item $node->ancestors
789              
790             Return a list of ancestor nodes of $node, e.g. the list of nodes on
791             the path from the node's parent to the root of the tree.
792              
793             =cut
794              
795             sub ancestors {
796             my ($self)=@_;
797             $self = $self->parent;
798             my @ancestors;
799             while ($self) {
800             push @ancestors,$self;
801             $self = $self->parent;
802             }
803             return @ancestors;
804             }
805              
806              
807             =item $node->cut ()
808              
809             Disconnect the node from its parent and siblings. Returns the node
810             itself.
811              
812             =cut
813              
814             sub cut {
815             my ($node)=@_;
816             my $p = $node->{$parent};
817             if ($p and $node==$p->{$firstson}) {
818             $p->{$firstson}=$node->{$rbrother};
819             }
820             $node->{$lbrother}->set_rbrother($node->{$rbrother}) if ($node->{$lbrother});
821             $node->{$rbrother}->set_lbrother($node->{$lbrother}) if ($node->{$rbrother});
822             $node->{$parent}=$node->{$lbrother}=$node->{$rbrother}=undef;
823             return $node;
824             }
825              
826              
827             =item $node->paste_on (new-parent,ord-attr)
828              
829             Attach a new or previously disconnected node to a new parent, placing
830             it to the position among the other child nodes corresponding to a
831             numerical value obtained from the ordering attribute specified in
832             C. If C is not given, the node becomes the
833             left-most child of its parent.
834              
835             This method does not check node types, but one can use
836             C<$parent-Etest_child_type($node)> before using this method to verify
837             that the node is of a permitted child-type for the parent node.
838              
839             Returns the node itself.
840              
841             =cut
842              
843             sub paste_on {
844             my ($node,$p,$fsformat)=@_;
845             my $aord = ref($fsformat) ? $fsformat->order : $fsformat;
846             my $ordnum = defined($aord) ? $node->{$aord} : undef;
847             my $b=$p->{$firstson};
848             if ($b and defined($ordnum) and $ordnum>($b->{$aord}||0)) {
849             $b=$b->{$rbrother} while ($b->{$rbrother} and $ordnum>$b->{$rbrother}->{$aord});
850             my $rb = $b->{$rbrother};
851             $node->{$rbrother}=$rb;
852             # $rb->set_lbrother( $node ) if $rb;
853             weaken( $rb->{$lbrother} = $node ) if $rb;
854             $b->{$rbrother}=$node;
855             #$node->set_lbrother( $b );
856             weaken( $node->{$lbrother} = $b );
857             #$node->set_parent( $p );
858             weaken( $node->{$parent} = $p );
859             } else {
860             $node->{$rbrother}=$b;
861             $p->{$firstson}=$node;
862             $node->{$lbrother}=undef;
863             #$b->set_lbrother( $node ) if ($b);
864             weaken( $b->{$lbrother} = $node ) if $b;
865             #$node->set_parent( $p );
866             weaken( $node->{$parent} = $p );
867             }
868             return $node;
869             }
870              
871             =item $node->paste_after (ref-node)
872              
873             Attach a new or previously disconnected node to ref-node's parent node
874             as a closest right sibling of ref-node in the structural order of
875             sibling nodes.
876              
877             This method does not check node types, but one can use
878             C<$ref_node-Eparent->test_child_type($node)> before using this method
879             to verify that the node is of a permitted child-type for the parent
880             node.
881              
882             Returns the node itself.
883              
884             =cut
885              
886             sub paste_after {
887             my ($node,$ref_node)=@_;
888             croak(__PACKAGE__."->paste_after: ref_node undefined") unless $ref_node;
889             my $p = $ref_node->{$parent};
890             croak(__PACKAGE__."->paste_after: ref_node has no parent") unless $p;
891              
892             my $rb = $ref_node->{$rbrother};
893             $node->{$rbrother}=$rb;
894             # $rb->set_lbrother( $node ) if $rb;
895             weaken( $rb->{$lbrother} = $node ) if $rb;
896             $ref_node->{$rbrother}=$node;
897             #$node->set_lbrother( $ref_node );
898             weaken( $node->{$lbrother} = $ref_node );
899             #$node->set_parent( $p );
900             weaken( $node->{$parent} = $p );
901             return $node;
902             }
903              
904             =item $node->paste_before (ref-node)
905              
906             Attach a new or previously disconnected node to ref-node's parent node
907             as a closest left sibling of ref-node in the structural order of
908             sibling nodes.
909              
910             This method does not check node types, but one can use
911             C<$ref_node-Eparent->test_child_type($node)> before using this method
912             to verify that the node is of a permitted child-type for the parent
913             node.
914              
915             Returns the node itself.
916              
917             =cut
918              
919             sub paste_before {
920             my ($node,$ref_node)=@_;
921              
922             croak(__PACKAGE__."->paste_before: ref_node undefined") unless $ref_node;
923             my $p = $ref_node->{$parent};
924             croak(__PACKAGE__."->paste_before: ref_node has no parent") unless $p;
925              
926             my $lb = $ref_node->{$lbrother};
927             # $node->set_lbrother( $lb );
928             if ($lb) {
929             weaken( $node->{$lbrother} = $lb );
930             $lb->{$rbrother}=$node;
931             } else {
932             $node->{$lbrother}=undef;
933             $p->{$firstson}=$node;
934             }
935             # $ref_node->set_lbrother( $node );
936             weaken( $ref_node->{$lbrother} = $node );
937             $node->{$rbrother}=$ref_node;
938             weaken( $node->{$parent} = $p );
939             return $node;
940             }
941              
942             =item $node->test_child_type ( test_node )
943              
944             This method can be used before a C or a similar operation to
945             test if the node provided as an argument is of a type that is valid
946             for children of the current node. More specifically, return 1 if the
947             current node is not associated with a type declaration or if it has
948             a #CHILDNODES member which is of a list or sequence type and the list
949             or sequence can contain members of the type of C.
950             Otherwise return 0.
951              
952             A type-declaration object can be passed directly instead of
953             C.
954              
955             =cut
956              
957             sub test_child_type {
958             my ($self, $obj) = @_;
959             die 'Usage: $node->test_child_type($node_or_decl)' unless ref($obj);
960             my $type = $self->type;
961             return 1 unless $type;
962             if (UNIVERSAL::DOES::does($obj,'Treex::PML::Schema::Decl')) {
963             if ($obj->get_decl_type == PML_TYPE_DECL) {
964             # a named type decl passed, no problem
965             $obj = $obj->get_content_decl;
966             }
967             } else {
968             # assume it's a node
969             $obj = $obj->type;
970             return 0 unless $obj;
971             }
972             if ($type->get_decl_type == PML_ELEMENT_DECL) {
973             $type = $type->get_content_decl;
974             }
975             my ($ch) = $type->find_members_by_role('#CHILDNODES');
976             if ($ch) {
977             my $ch_is = $ch->get_decl_type;
978             if ($ch_is == PML_MEMBER_DECL) {
979             $ch = $ch->get_content_decl;
980             $ch_is = $ch->get_decl_type;
981             }
982             if ($ch_is == PML_SEQUENCE_DECL) {
983             return 1 if $ch->find_elements_by_content_decl($obj);
984             } elsif ($ch_is == PML_LIST_DECL) {
985             return 1 if $ch->get_content_decl == $obj;
986             }
987             } else {
988             return 0;
989             }
990             }
991              
992             =item $node->get_order
993              
994             For a typed node return value of the ordering attribute on the node
995             (i.e. the one with role #ORDER). Returns undef for untyped nodes (for
996             untyped nodes the name of the ordering attribute can be obtained
997             from the FSFormat object).
998              
999             =cut
1000              
1001             sub get_order {
1002             my $self = $_[0];
1003             my $oattr = $self->get_ordering_member_name;
1004             return defined $oattr ? $self->{$oattr} : undef;
1005             }
1006              
1007             =item $node->get_ordering_member_name
1008              
1009             For a typed node return name of the ordering attribute on the node
1010             (i.e. the one with role #ORDER). Returns undef for untyped nodes (for
1011             untyped nodes the name of the ordering attribute can be obtained
1012             from the FSFormat object).
1013              
1014             =cut
1015              
1016             sub get_ordering_member_name {
1017             my $self = $_[0];
1018             my $type = $self->type;
1019             return undef unless $type;
1020             if ($type->get_decl_type == PML_ELEMENT_DECL) {
1021             $type = $type->get_content_decl;
1022             }
1023             my ($omember) = $type->find_members_by_role('#ORDER');
1024             if ($omember) {
1025             return ($omember->get_name);
1026             }
1027             return undef; # we want this undef
1028             }
1029              
1030             =item $node->get_id
1031              
1032             For a typed node return value of the ID attribute on the node
1033             (i.e. the one with role #ID). Returns undef for untyped nodes (for
1034             untyped nodes the name of the ID attribute can be obtained
1035             from the FSFormat object).
1036              
1037             =cut
1038              
1039             sub get_id {
1040             my $self = $_[0];
1041             my $oattr = $self->get_id_member_name;
1042             return defined $oattr ? $self->{$oattr} : undef;
1043             }
1044              
1045             =item $node->get_id_member_name
1046              
1047             For a typed node return name of the ID attribute on the node
1048             (i.e. the one with role #ID). Returns undef for untyped nodes (for
1049             untyped nodes the name of the ID attribute can be obtained
1050             from the FSFormat object).
1051              
1052             =cut
1053              
1054             sub get_id_member_name {
1055             my $self = $_[0];
1056             my $type = $self->type;
1057             return undef unless $type;
1058             if ($type->get_decl_type == PML_ELEMENT_DECL) {
1059             $type = $type->get_content_decl;
1060             }
1061             my ($omember) = $type->find_members_by_role('#ID');
1062             if ($omember) {
1063             return ($omember->get_name);
1064             }
1065             return undef; # we want this undef
1066             }
1067              
1068             sub _weakenLinks {
1069             my ($node)=@_;
1070             for ($node->{$lbrother}, $node->{$parent}) {
1071             weaken( $_ ) if $_
1072             }
1073             }
1074              
1075             ######################################################################
1076              
1077             eval << 'EO_XPATH' if ($ENV{'TREEX_PML_ENABLE_XPATH_EXTENSION'});
1078             *getRootNode = *root;
1079             *getParentNode = *parent;
1080             *getNextSibling = *rbrother;
1081             *getPreviousSibling = *lbrother;
1082             *getChildNodes = sub { wantarray ? $_[0]->children : [ $_[0]->children ] };
1083              
1084             sub getElementById { }
1085             sub isElementNode { 1 }
1086             sub get_global_pos { 0 }
1087             sub getNamespaces { return wantarray ? () : []; }
1088             sub isTextNode { 0 }
1089             sub isPINode { 0 }
1090             sub isCommentNode { 0 }
1091             sub getNamespace { undef }
1092             sub getValue { undef }
1093             sub getName { "node" }
1094             *getLocalName = *getName;
1095             *string_value = *getValue;
1096              
1097             sub getAttributes {
1098             my ($self) = @_;
1099             my @attribs = map {
1100             Treex::PML::Attribute->new($self,$_,$self->{$_})
1101             } keys %$self;
1102             return wantarray ? @attribs : \@attribs;
1103             }
1104              
1105             sub find {
1106             my ($node,$path) = @_;
1107             require XML::XPath;
1108             local $_; # XML::XPath isn't $_-safe
1109             my $xp = XML::XPath->new(); # new is v. lightweight
1110             return $xp->find($path, $node);
1111             }
1112              
1113             sub findvalue {
1114             my ($node,$path) = @_;
1115             require XML::XPath;
1116             local $_; # XML::XPath isn't $_-safe
1117             my $xp = XML::XPath->new();
1118             return $xp->findvalue($path, $node);
1119             }
1120              
1121             sub findnodes {
1122             my ($node,$path) = @_;
1123             require XML::XPath;
1124             local $_; # XML::XPath isn't $_-safe
1125             my $xp = XML::XPath->new();
1126             return $xp->findnodes($path, $node);
1127             }
1128              
1129             sub matches {
1130             my ($node,$path,$context) = @_;
1131             require XML::XPath;
1132             local $_; # XML::XPath isn't $_-safe
1133             my $xp = XML::XPath->new();
1134             return $xp->matches($node, $path, $context);
1135             }
1136              
1137             package Treex::PML::Attribute;
1138             use Carp;
1139              
1140             sub new { # node, name, value
1141             my $class = shift;
1142             return bless [@_],$class;
1143             }
1144             sub getElementById { $_[0]->getElementById($_[1]) }
1145             sub getLocalName { $_[0][1] }
1146             BEGIN { *getName = \&getLocalName; }
1147             sub string_value { $_[0][2] }
1148             BEGIN { *getValue = \&string_value; }
1149             sub getRootNode { $_[0][0]->getRootNode() }
1150             sub getParentNode { $_[0][0] }
1151             sub getNamespace { undef }
1152              
1153             EO_XPATH
1154              
1155              
1156             1;
1157              
1158             =back
1159              
1160             =cut
1161              
1162             __END__