##################################################################### # Copyright (C) 2004 Jörg Tiedemann # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA # # $Author: joerg72 $ # $Id: Data.pm,v 1.4 2005/03/04 13:12:20 joerg72 Exp $ # ########################################################################### # ########################################################################### package Uplug::Data; use strict; use vars qw( @ISA @EXPORT $VERSION $DEFAULTDELIMITER $DEFAULTROOTLABEL); use Exporter; use Data::Dumper; use Uplug::Data::Node; use Uplug::Encoding; @ISA=qw( Exporter); @EXPORT = qw( $DEFAULTDELIMITER $DEFAULTROOTLABEL); $VERSION = 0.1; $DEFAULTDELIMITER=' '; $DEFAULTROOTLABEL='text'; sub DESTROY{ my $self=shift; if (ref($self->{ROOT})){$self->{ROOT}->DESTROY();} delete $self->{ROOT}; } sub new{ my $class=shift; my $self={}; bless $self,$class; $self->init(@_); return $self; } #--------------------------------- # init(label,attributes,option => value, ...) # label ..... data root label # attr ...... root node attributes # options: # sub init{ my $self=shift; my ($label,$attr,%options)=@_; if (defined $label){$self->setRoot($self->createNode($label,$attr));} else{$self->setRoot(undef);} foreach (keys %options){$self->{$_}=$options{$_};} } #--------------------------------------------- sub option{return $_[0]->{$_[1]};} # get object-property sub setOption{$_[0]->{$_[1]}=$_[2];} # set object-property #--------------------------------------------- sub root{return $_[0]->{ROOT};} # get root node sub getRootNode{return $_[0]->root();} # get root node sub setRoot{ if (ref($_[0]->{ROOT})){ # if there's a root node $_[0]->{ROOT}->DESTROY(); # destroy it! } delete $_[0]->{ROOT}; $_[0]->{ROOT}=$_[1]; # set the new root node } #---------------------------------------------- sub header{return $_[0]->{HEADER};} # get data header (string) sub setHeader{$_[0]->{HEADER}=$_[1];} # set data header sub addHeader{$_[0]->{HEADER}.=$_[1];} # add string to data header sub tail{return $_[0]->{TAIL};} # data tail (string) sub setTail{$_[0]->{TAIL}=$_[1];} sub addTail{$_[0]->{TAIL}.=$_[1];} #-------------------------------------------------- # parent($NODE) ............... return parent of node $NODE # setParent($NODE,$PARENT) .... set parent of node $NODE sub parent{if (ref($_[1])){return $_[1]->parent();}} sub setParent{if (ref($_[1])){return $_[1]->setParent($_[2]);}} #-------------------------------------------------------------------- # createNode # createNode(label,attr,content,parent) # label ..... data label # attr ...... optional reference to an attribute hash # content ... optional content string # parent .... optional reference to parent node # sub createNode{ my ($self,$label,$attr,$content,$parent)=@_; my $node=Uplug::Data::Node->new($label,$attr,$parent); if (defined $content){$node->addTextNode($content);} return $node; } #-------------------------------------------------------------------- # createTextNode # sub createTextNode{ my ($self,$content,$node)=@_; if (not ref($node)){$node=Uplug::Data::Node->new();} return $node->createTextNode($content); } #-------------------------------------------------------------------- # delNode .... detach a node from its parent sub delNode{ my $self=shift; my $node=shift; if (not ref($node)){return undef;} $node->detach(); } #-------------------------------------------------------------------- # addNode # 1) addNode(child) ................... add a child to the root node # 2) addNode(parent,child) ............ add a child to parent # 3) addNode(label,attr,content) ...... add a new child node to the root node # 4) addNode(parent,label,attr,content) add a new child node to parent # sub addNode{ my $self=shift; my $parent; if (ref($_[0]) and (@_==1)){$parent=$self->root();} # 1) child to root elsif (not ref($_[0])){$parent=$self->root();} # 3) get root else{$parent=shift;} # 2) & 4) my @nodes=(); if (ref($_[0])){@nodes=@_;} # all arguments are children nodes else{$nodes[0]=$self->createNode(@_);} # create a new child-node my @added=(); if (not ref($parent)){ # no parent? --> there is no root! $self->setRoot(shift(@nodes)); # --> set first node as root push (@added,$self->root()); } foreach my $n (@nodes){ # add all nodes push (@added,$parent->addContent($n)); $self->setParent($n,$parent); # set parent } return wantarray ? @added : $added[-1]; } #-------------------------------------------------------------------- # findNodes .... find nodes with certain labels and attributes # # 1) @nodes = $data->findNodes() # 2) @nodes = $data->findNodes($labelRE) # 3) @nodes = $data->findNodes($labelRE,\%attr) # # # $labelRE: label pattern (regular expression) # %attr: attribute value pairs for matching a node (hash) # # @nodes: array of nodes # sub findNodes{ my $self=shift; my ($labelRE,$attr,$node,$match)=@_; if (not defined $labelRE){$labelRE='.*';} # default: match all! if (not defined $node){$node=$self->root();} # start at root if (not defined $node){return undef;} # no root node found! if (not defined $match){$match=[];} # initialize return-array my $label=$node->label(); # get the node-label if ($label=~/^$labelRE$/){ # and check it if ((ref($attr) ne 'HASH') or # if the attribute-pattern ($node->matchAttr($attr))){ # is set --> try to push (@{$match},$node); # match it } } foreach my $c ($node->children()){ # check all children nodes if (not ref($c)){next;} # (only if not scalar) $self->findNodes($labelRE,$attr,$c,$match); } return @{$match}; } #-------------------------------------------------------------------- # delNodes ..... delete nodes # # 1) delNodes(@NODES) .......... delete all nodes in @NODES # 2) delNodes(labelRE,$attr).... delete all nodes which match labelRE & attr # (uses findNodes) # sub delNodes{ my $self=shift; my @nodes=(); if (ref($_[0])){@nodes=@_;} else{@nodes=$self->findNodes(@_);} foreach my $n (@nodes){$self->delNode($n);} } #-------------------------------------------------------------------- # contentNodes .... return all content nodes # # @nodes = $data->contentNodes() # # sub contentNodes{ my $self=shift; my ($node,$match)=@_; if (not ref($node)){$node=$self->root();} # no node --> root node if (not ref($node)){return undef;} # no root node --> return if (not defined $match){$match=[];} # initialize return-array if ($node->isTextNode()){ # check if the current push (@{$match},$node); # node is a text node } foreach my $c ($node->children()){ # check all children nodes if (not ref($c)){next;} # (only if not scalar) $self->contentNodes($c,$match); } return @{$match}; } #-------------------------------------------------------------------- # contentElements .... return all nodes that contain a text-node! # # @nodes = $data->contentElements() # # sub contentElements{ my $self=shift; my @nodes=$self->contentNodes(@_); my @elements=(); foreach my $n (@nodes){ if (not ref($n)){next;} my $parent=$n->parent(); if ($parent){push (@elements,$parent);} } return @elements; } #-------------------------------------------------------------------- # attribute .... return value of a node attribute # # 1) attribute(node,key) ..... return value of attribute 'key' in node # 2) attribute(key) .......... return value of attribute 'key' in root-node # 3) attribute(\@nodes,key) .. return values of attribute 'key' in all nodes # # if key is undefined ---> return reference to attribute-value hash! sub attribute{ my $self=shift; if (ref($_[0]) eq 'ARRAY'){ # 3) first argument = node-array my $nodes=shift;my @attr=(); # --> collect all attributes foreach my $n (@{$nodes}){ # from all nodes push (@attr,$self->attribute($n,@_)); } return wantarray ? @attr : \@attr; } my $node; if (ref($_[0])){$node=shift;} # 1) node is psecified else{$node=$self->root();} # 2) node=root-node if (not ref($node)){return undef;} # no node found -> return undef if (defined $_[0]){return $node->attribute($_[0]);} # return attr.-value else{return $node->attributes();} # return attr.-hash } #-------------------------------------------------------------------- # setAttribute .... set attribute value in a node # # 1) setAttribute(node,key,value,...) ..... set attributes in node 'node' # 2) setAttribute(key,value,...) .......... set attributes in root-node # 3) setAttribute($node,\%hash) ........... set attribute 'key' in 'node' # 4) setAttribute(\%hash) ................. set attribute 'key' in root-node sub setAttribute{ my $self=shift; my $node; if (ref($_[0]) and (ref($_[0]) ne 'HASH')){$node=shift;} # 1) node as arg. else{$node=$self->root();} # 2) root-node if (not ref($node)){$node=$self->addNode();}# undefined node -> new root! if (not ref($node)){return undef;} # still undefined? -> return my %attr=(); if (ref($_[0]) eq 'HASH'){%attr=%{$_[0]};} # first argument=hash-reference else{%attr=@_;} # arguments=attribute-hash return $node->setAttribute(%attr); # set attributes of the node } #-------------------------------------------------------------------- # setAttributes .... set attributes in several nodes # # setAttributes(\@nodes,@attr) # # @nodes ..... array of nodes # @attr ...... array of attribute-value hashs sub setAttributes{ my $self=shift; my $nodes=shift; my $attr=shift; if (ref($nodes) ne 'ARRAY'){return;} if (ref($attr) ne 'ARRAY'){return;} foreach (0..$#{$nodes}){ if (ref($attr->[$_]) ne 'HASH'){next;} $self->setAttribute($nodes->[$_],%{$attr->[$_]}); } } #-------------------------------------------------------------------- # setContentAttribute .... set attribute value in content nodes # # setContentAttribute($attr,@values) # setContentAttribute($attr,\@values) # sub setContentAttribute{ my $self=shift; my $attr=shift; my @val=@_; if (ref($_[0]) eq 'ARRAY'){@val=@{$_[0]};} my @nodes=$self->contentElements(); foreach my $n (@nodes){ $self->setAttribute($n,$attr,shift(@val)); if (not @val){last;} } } #-------------------------------------------------------------------- # delAttribute .... delete an attribute in a node # # 1) delAttribute(node,key) ..... delete attribute 'key' in node 'node' # 2) delAttribute(key) .......... delete attribute 'key' in root-node sub delAttribute{ my $self=shift; my $node; if (ref($_[0])){$node=shift;} # 1) node is psecified else{$node=$self->root();} # 2) node=root-node if (not ref($node)){return undef;} # 3) no node found -> return undef return $node->delAttribute(@_); # set attribute-value of the node } #-------------------------------------------------------------------- # content ...... return content-string # # 1) content(@NODES) ........ return content of all nodes @NODES # 2) content(\@NODES) ....... return content of all nodes @NODES # # if @NODES is undefined --> return content of root-node # # return value: # @content ..... 'array of content strings' in array context # $content ..... content-string for all nodes joined together # (using CONTENTDELIMITER string) # sub content{ my $self=shift; my @nodes=(); if (ref($_[0]) eq 'ARRAY'){@nodes=@{$_[0]};} elsif (ref($_[0])){@nodes=@_;} else{$nodes[0]=$self->root();} my $del=$DEFAULTDELIMITER; my @content=(); foreach my $n (@nodes){ if (not ref($n)){next;} my @children=$n->content($del); push (@content,@children); } return wantarray ? @content : join ($del,@content); } #-------------------------------------------------------------------- # setContent # # 1) setContent($string,$label) ........ set content in root node # 2) setContent($node,$string,$label) ... set content in specific $node # # string ...... content string (create a text node as one and only child-node) # label ....... optional! change label of the node sub setContent{ my $self=shift; my $node; if (ref($_[0])){$node=shift;} # 1st argument = reference -> node-reference else{$node=$self->root();} # else -> get root-node my $string=shift; if (not ref($node)){ $node=$self->createNode($DEFAULTROOTLABEL); $self->setRoot($node); } # create a new text-node as the one and only content if (defined $string){$node->setContent($node->createTextNode($string));} # or delete all content else{$node->delContent();} # set a label if specified if (defined $_[0]){$node->setLabel($_[0]);} } #------------------------------------------- # addContent sub addContent{ my $self=shift; my $node; if (ref($_[0])){$node=shift;} else{$node=$self->root();} if (not ref($node)){$node->addNode(@_);} # no root node --> create new one if (defined $_[0]){$node->addTextNode($_[0]);} # add a new text node } #-------------------------------------------------- # label ...... return data label of a node # # 1) label(node) ........ label of node # 2) label() ............ label of root node # sub label{ my $self=shift; my $node; if (ref($_[0])){$node=shift;} else{$node=$self->root;} if (ref($node)){$node->label($_[0]);} } #-------------------------------------------------- # setLabel ...... set label of a node # # 1) setLabel(node,label) ....... set label of node # 2) setLabel(label) ............ set label of root node # sub setLabel{ my $self=shift; my $node; if (ref($_[0])){$node=shift;} else{$node=$self->root;} if (ref($node)){$node->setLabel($_[0]);} } #-------------------------------------------------------------------- # taken from Object::Clone # http://usr.bin.dk/~jonasbn/perl/ObjectClone.html # # use Data::Dumper; # sub clone { # my $self = shift; # # my $VAR1; # my $copy_dump = Dumper $self; # eval $copy_dump; warn $@ if $@; # return $VAR1; # } sub clone{return Uplug::Data->new();} # return $_[0]->new(); #-------------------------------------------------------------------- # subData .... return a sub-data object # # 1) $subdata=subData($subData,$labelRE,\%attr) # 2) $subdata=subData($labelRE,\%attr) # # subdata is a clone of this object # the root of subdata is the first node that matches labelRE and attr # (using findNodes) # sub subData{ my $self=shift; my $data; if (ref($_[0])){$data=shift;} else{$data=$self->clone();} if (not ref($data)){return undef;} # could not clone myself my ($node)=$self->findNodes(@_); # find first matching node $data->setRoot($node); # set root-node return $data; # return subdata object } #-------------------------------------------------------------------- # splitContent # # 1) @NewNodes = $object->splitContent($node,$label,\@segments) # 2) @NewNodes = $object->splitContent($labeRE,\%NodeAttr,$label,\@segments) # # $node: parent node # $label: label for new children nodes (string) # @segments: array of strings to replace the former content (array) # %NodeAttr: attribute-value pairs for finding a node (hash) # # @NewNodes: array of new nodes # # Note: # if splitContent finds more than one node that matches $labelRE and # %NodeAttr ---> splitContent splits only the first node! # sub splitContent{ my $self=shift; my $node=shift; if (not ref($node)){ my $labelRE=$node; my $attr=shift; ($node)=$self->findNodes($labelRE,$attr); } if (not ref($node)){return ();} my $label=shift; my $segments=shift; if (ref($segments) ne 'ARRAY'){return ();} #------------------------------------------------------------------------ my @contentNodes=$self->contentNodes(); # get all content nodes my @content=$self->content(@contentNodes); # and their content my @children=(); #------------------------------------------------------------------------ foreach my $s (@{$segments}){ # foreach text-segment: my @chunk=(shift @contentNodes); # - take the next text-node my @chunkContent=(shift @content); # - save its content my $text=$chunkContent[-1]; # - the text my $pat=quotemeta($s); # - pattern of the segment while ($text!~/$pat/s){ # - add more text nodes if (not @contentNodes){last;} # as long as the segment push(@chunkContent,shift @content); # is not completely push(@chunk,shift @contentNodes); # included in the text $text.=$DEFAULTDELIMITER; # (text-node deilimiter!) $text.=$chunkContent[-1]; # (append new text) } if (not @chunk){next;} # - no nodes -> next segment #------------------------------------------------------------------------ if ($text=~/($pat)(.*)$/s){ # - there's something behind my $str1=$1; # the text-segment which my $str2=$2; # has to be removed from my $pat2=quotemeta($str2); # the last text-node my $this=$chunkContent[-1]; # * this is the last text-node # if ($this=~/^(.*)$pat2$/s){ # which has to be split # $str1=$1; # between $str1 and $str2 # } if ($this=~/(.*)$pat2$/s){ # which has to be split $str1=$1; # between $str1 and $str2 } #------------------------------------------------------------------------ my ($before,$after)= # split the last text-node $self->splitContentNode($chunk[-1], # between str1 and str2 $str1, # before and after are the $str2); # new text-nodes! $chunk[-1]=$before; # last node in the chunk $chunkContent[-1]= $self->content($chunk[-1]); # and its content #------------------------------------------------------------------------ if (defined $after){ # if there is something my $afterStr=$self->content($after); # behind it unshift(@contentNodes,$after); # push it into the unshift(@content,$afterStr); # text-node array } #------------------------------------------------------------------------ $text=join ($DEFAULTDELIMITER,@chunkContent); # check the text of my $this=quotemeta($chunkContent[0]); # the current chunk! while ($text=~/$this$pat$/){ # - remove all shift(@chunk); # initial nodes shift(@chunkContent); # before the text- if (not @chunk){last;} # segment $text=join ($DEFAULTDELIMITER,@chunkContent); $this=quotemeta($chunkContent[0]); } #------------------------------------------------------------------------ if (not @chunk){next;} # no node left -> next segment if ($text=~/^(.+)$pat$/s){ # there's something in front my $str1=$1; # of the text segment my $pat=quotemeta($str1); # --> split the first text- my $this=$chunkContent[0]; # node into two nodes if ($this=~/^($pat)(.*)$/s){ # and remove the prefix- my $str2=$2; # node from the chunk my ($before,$after)= $self->splitContentNode($chunk[0],$str1,$str2); $chunk[0]=$after; } } #------------------------------------------------------------------------ # finally: add the parent-label around all nodes in the chunk # if possible (check addParent) # push(@children,$self->addParent(\@chunk,$label)); } } return @children; } #------------------------------------------------------------------------ sub splitContentNode{ my $self=shift; my ($node,$before,$after)=@_; if (not ref($node)){return $node;} my $parent=$node->parent(); if (not ref($parent)){return $node;} if ((defined $before) and (defined $after)){ my $child=$parent->createTextNode($before); my $child=$self->createTextNode($before); $child=$parent->insertBefore($child,$node); $node->setNodeValue($after); return ($child,$node); } return $node; } #-------------------------------------------------------------------- # addParent # # 1) insertParent(\@children,$label,\%attr) # 2) insertParent($label,\%attr,$childLabelRE,$childrenAttr,$label,\%attr) # # $label ........ label for the new parent # %attr ......... attribute-value-hash for the new parent # @children ..... list of nodes to be the children of the new parent # $childLabelRE . regular expression to match labels of nodes (=children) # $childrenAttr . attributes to be matched with nodes (=>children) # sub addParent{ my $self=shift; my $children; my $parentLabel; # label of the new parent my $parentAttr; # attribute-value hash for the parent if (not ref($_[0])){ $parentLabel=shift; $parentAttr=shift; #--------------------------------------- # childLabelRE: # label of the node (reg exp) # childrenAttr: # array of attribute-value hashs OR # hash of attribute-value pairs # (for matching children-nodes) # - optional! #--------------------------------------- my ($childLabelRE,$childrenAttr)=@_; $children=[]; @{$children}=$self->findNodes($childLabelRE,$childrenAttr); } else{ $children=shift; $parentLabel=shift; $parentAttr=shift; } if (not @{$children}){return undef;} if (not defined $children->[0]){return undef;} my $text=$self->content($children); my $root=$children->[0]->parent(); foreach my $i (1..$#{$children}){ if (not defined $children->[$i]){next;} if (not defined $children->[$i-1]){next;} my $child1=$children->[$i-1]; my $child2=$children->[$i]; ($root,$children->[$i-1],$children->[$i])= $self->findCommonParent($children->[$i-1],$children->[$i]); if (($child1 ne $children->[$i-1]) or ($child2 ne $children->[$i])){ #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! # here should be some test if the common parent # does not take to much content # (content before <=> after ...) #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! # something like this: ... my ($before,$after); if ($child1 ne $children->[$i-1]){ $before=$self->content($child1); $after=$self->content($children->[$i-1]); } else{ $before=$self->content($child2); $after=$self->content($children->[$i]); } if ($before ne $after){return undef;} # (addParent fails) # could maybe split the parent-node .... #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! return $self->addParent($children,$parentLabel,$parentAttr); } if (not defined $root){last;} } my @childNodes=(); foreach my $i (0..$#{$children}){ if (ref($children->[$i])){ push(@childNodes,$children->[$i]); } } if (defined $root){ return $self->insertParent($root,\@childNodes, $parentLabel,$parentAttr); # return $self->insertParent($root,$children,$parentLabel,$parentAttr); } } sub findCommonParent{ my $self=shift; my ($node1,$node2)=@_; my $parent1=$node1->parent(); if (not defined $parent1){return undef;} my $parent2=$node2->parent(); if (not defined $parent2){return undef;} if ($parent1 eq $parent2){ return ($parent1,$node1,$node2); } if ($parent2->isAncestor($parent1)){ # this is NOT (!!!) DOM my $child=$parent1; my $parent=$child->parent(); while ($parent ne $parent2){ $child=$parent; if (not ref($child)){last;} $parent=$child->parent(); } return ($parent,$child,$node2); } if ($parent1->isAncestor($parent2)){ # this is NOT (!!!) DOM my $child=$parent2; my $parent=$child->parent(); while ($parent ne $parent1){ $child=$parent; if (not ref($child)){last;} $parent=$child->parent(); } return ($parent,$node1,$child); } return $self->findCommonParent($parent1,$parent2); return undef; } #-------------------------------------------------------------------- # insertParent # sub insertParent{ my $self=shift; my ($oldParent,$children,$parentLabel,$parentAttr)=@_; my $newParent=$self->createNode($parentLabel,$parentAttr); # $self->createNode(\$newParent,$parentLabel,$parentAttr); if (ref($children) eq 'ARRAY'){ if ($children->[0]->parent() eq $oldParent){ $oldParent->insertBefore($newParent,$children->[0]); } else{ $oldParent->insertBefore($newParent); } foreach (0..$#{$children}){ # if (not ref($children->[$_]->getParentNode())){next;} if (not ref($children->[$_])){next;} if ($children->[$_]->parent eq $oldParent){ $children->[$_]=$oldParent->removeChild($children->[$_]); $newParent->appendChild($children->[$_]); } } } else{ $children=$oldParent->replaceChild($newParent,$children); $newParent->appendChild($children); } return $newParent; } #....... end of insertParent!!!!!!!!!!!!!!!!!!!!!!!! #-------------------------- # walk the tree ... # make all steps in a path! # a path is a sequence of steps which makeStep understands # (all steps have to be joined with ':' as delimiter symbol!) # sub moveTo{ my $self=shift; my $node=shift; my $path=shift; my @steps=split(/\:/,$path); foreach (@steps){ $node=$self->makeStep($node,$_); } return $node; } #-------------------------- # walk the tree ... # # up: one step up # down: one step down (left-most = first child) # downright: one step down (right-most = last child) # top: go to the top (root node) # bottom: do 'down' as often as possible (go the first leaf) # bottomright: do 'downright' as often as possible (last leaf) # $tag: go up until a node with the tag $tag is reached # left: go the left neighbour # if no neighbour exists: do 'up-left-downright' # left($tag): go the left neighbour with the tag $tag # right: go the right neighbour # if no neighbour exists: do 'up-right-down' # right($tag): go the left neighbour with the tag $tag # # makeSteps returns the start-node if no appropriate node is found! # (exception: left($tag) & right($tag): returns undef if nothing found) # sub makeStep{ my $self=shift; my $node=shift; my $step=shift; # print STDERR "$step:"; if (not ref($node)){return $node;} if ($step=~/up/i){ return $node->getParentNode(); } elsif ($step=~/top/i){ return $self->getRootNode(); } elsif ($step=~/downright/i){ my $down=$node->getLastChild(); if (not ref($down)){return $down;} # this return undef!!! if ($self->isEmptyNode($down)){ # print STDERR "empty:"; return $self->makeStep($down,'left'); } return $down; } elsif ($step=~/down/i){ my $down=$node->getFirstChild(); if (not ref($down)){return $down;} # this return undef!!! if ($self->isEmptyNode($down)){ # print STDERR "empty:"; return $self->makeStep($down,'right'); } return $down; } elsif ($step=~/bottomright/i){ while ($node->hasChildNodes()){ my $down=$self->makeStep($node,'downright'); if (ref($down)){$node=$down;} } return $node; } elsif ($step=~/bottom/i){ while ($node->hasChildNodes()){ my $down=$self->makeStep($node,'down'); if (ref($down)){$node=$down;} } return $node; } elsif ($step=~/left$/i){ my $left=$node->getPreviousSibling(); if (not ref($left)){ return $self->moveTo($node,'up:left:downright'); } if ($self->isEmptyNode($left)){ # print STDERR "empty:"; return $self->makeStep($left,$step); } return $left; } elsif ($step=~/left\((.*)\)/i){ # left neighbour with tag $tag! my $tag=$1; my $left=$node->getPreviousSibling(); if (ref($left)){ if ($left->getNodeName() eq $tag){ return $left; } } my @nodes=$self->findNodes($tag); foreach (0..$#nodes){ if ($node==$nodes[$_]){ if ($_){return $nodes[$_-1];} else{return undef;} } } } elsif ($step=~/right$/i){ my $right=$node->getNextSibling(); if (not ref($right)){ return $self->moveTo($node,'up:right:down'); } if ($self->isEmptyNode($right)){ # print STDERR "empty:"; return $self->makeStep($right,$step); } return $right; } elsif ($step=~/right\((.*)\)/i){ # right neighbour with tag $tag! my $tag=$1; my $left=$node->getNextSibling(); if (ref($left)){ if ($left->getNodeName() eq $tag){ return $left; } } my @nodes=$self->findNodes($tag); foreach (0..$#nodes){ if ($node==$nodes[$_]){ return $nodes[$_+1]; } } } my $current=$node; while (ref($current)){ # $step is a tag name! $current=$current->getParentNode(); # go up the tree until we find if (not ref($current)){last;} my $name=$current->getNodeName(); if ($name=~/$step/){ # the element or we reach return $current; # the root node } } return $node # nothing happened! return the $node } sub isEmptyNode{ my $self=shift; my $node=shift; if (not ref($node)){return undef;} if ($node->getNodeName eq '#text'){ my $text=$node->getNodeValue(); if ($text!~/\S/s){return 1;} } return 0; } ###################################################################### ###################################################################### ###################################################################### # .............. # # should look through these functions some day # ###################################################################### #---------------------------------------------- # return a complex data structure sub data{ my $self=shift; my $root=$self->root(); if (not ref($root)){return undef;} return $root->data(); # return $self->attribute(); # get all root attributes } #---------------------------------------------- # read a complex data structure into a Data-object sub setData{ my $self=shift; my $root=$self->root(); if (not ref($root)){$root=$self->addNode();} if (not ref($root)){return undef;} return $root->setData(@_); # return $self->setAttribute(@_); } sub keepAttributes{ my $self=shift; my $names=shift; if (ref($names) ne 'ARRAY'){return;} my $attr=$self->attribute(); # get all root attributes if (ref($attr) ne 'HASH'){return;} foreach my $a (keys %{$attr}){ if (not grep (/^$a$/,@{$names})){ # delete matching attributes $self->delAttribute($a); } } } sub delEmptyFields{ # delete empty fields ('') my $self=shift; # get attributes ... delete empty attributes... !!!!!!! # !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! # ... this is just for right now ... my $data=$self->data; foreach (keys %{$data}){ if (not defined $$data{$_}){delete $$data{$_};} if ($$data{$_} eq ''){delete $$data{$_};} } } #-------------------------------------------------- # matchData: does not really match all data in this object # matches only the root attributes with the select pattern sub matchData{ my $self=shift; my $pattern=shift; my $root=$self->root(); if (not ref($root)){return 0;} return $root->matchAttr($pattern); } #----------------------------------------- # experimental: convert to HTML-tables sub toHTML{ my $self=shift; my $dom=shift; my $indent=shift; my %colors=('default' => '#FFFFFF', 's' => '#EEEEEE', 'chunk' => '#E4EEFF', 'c' => '#E4EEFF', 'source' => '#FFFFEE', 'target' => '#FFFFEE', 'w' => '#FFEEDD'); if (not defined $dom){ $dom=$self->root(); } my $html="$indent"; $html.="$indent"; foreach my $n ($dom->getChildNodes()){ my $name=$n->getNodeName; if (defined $colors{$name}){ $html.="$indent'; } $html.="$indent$indent"; #-------------------- # process children foreach my $n ($dom->getChildNodes()){ $html.="$indent"; } $html.="$indent$indent
"; } else{ $html.="$indent"; if ($name!~/^\#/){ $html.="$name
"; } } if ($name eq '#text'){ my $str=$n->getNodeValue; if ($str=~/\S/){ $html.="$str"; } } elsif ($name eq '#comment'){ my $str=$n->getNodeValue; if ($str=~/\S/){ $html.=''; } } else{ my $attr=$n->attributes(); # $html.="$name"; if (ref($attr) eq 'HASH'){ # $html.=''; delete $$attr{id}; # skip ID and byte-spans! delete $$attr{span}; $html.=join '
',values %{$attr}; # foreach (sort keys %{$attr}){ # $html.="
$_='$attr->{$_}'"; # } # $html.=''; } } $html.=$indent.'
"; # $indent.=' '; $indent=''; $html.=$self->toHTML($n,$indent); $html.="$indent
\n"; return $html; } ###################################################################### ###################################################################### ###################################################################### ###################################################################### #-------------------------------------------------------------------- # finally: return a true value # 1;