Mercurial > pub > Impl
annotate Lib/IMPL/DOM/Node.pm @ 31:d59526f6310e
Small fixes to Test framework (correct handlinf of the compilation errors in the test units)
Imported and refactored SQL DB schema from the old project
| author | Sergey |
|---|---|
| date | Mon, 09 Nov 2009 01:39:16 +0300 |
| parents | dd4d72600c69 |
| children | a8086f85a571 |
| rev | line source |
|---|---|
| 0 | 1 package IMPL::DOM::Node; |
| 2 use strict; | |
| 3 use warnings; | |
| 4 | |
| 11 | 5 use base qw(IMPL::Object); |
| 0 | 6 |
| 4 | 7 use IMPL::Object::List; |
| 0 | 8 use IMPL::Class::Property; |
| 9 use IMPL::Class::Property::Direct; | |
| 10 use Scalar::Util qw(weaken); | |
| 11 | |
| 1 | 12 use IMPL::Exception; |
| 13 | |
| 0 | 14 BEGIN { |
| 4 | 15 public _direct property nodeName => prop_get | owner_set; |
| 16 public _direct property isComplex => { get => \&_getIsComplex } ; | |
| 17 public _direct property nodeValue => prop_all; | |
| 18 public _direct property childNodes => { get => \&_getChildNodes }; | |
| 19 public _direct property parentNode => prop_get ; | |
| 18 | 20 public _direct property rootNode => { get => \&_getRootNode}; |
| 21 private _direct property _propertyMap => prop_all ; | |
| 0 | 22 } |
| 23 | |
| 24 sub CTOR { | |
| 11 | 25 my ($this,%args) = @_; |
| 0 | 26 |
| 11 | 27 $this->nodeName($args{nodeName}) or die new IMPL::InvalidArgumentException("A name is required"); |
| 18 | 28 $this->nodeValue($args{nodeValue}); |
| 0 | 29 } |
| 30 | |
| 31 sub insertNode { | |
| 32 my ($this,$node,$pos) = @_; | |
| 4 | 33 |
| 34 die new IMPL::InvalidOperationException("You can't insert the node to itselft") if $this == $node; | |
| 35 | |
| 36 $node->{$parentNode}->removeNode($node) if ($node->{$parentNode}); | |
| 37 | |
| 38 $this->childNodes->InsertAt($pos,$node); | |
| 39 | |
| 40 $node->_setParent( $this ); | |
| 41 | |
| 42 return $node; | |
| 43 } | |
| 44 | |
| 30 | 45 sub appendChild { |
|
16
75d55f4ee263
Окончательная концепция описания схем и построения DOM документов
Sergey
parents:
14
diff
changeset
|
46 my ($this,$node) = @_; |
| 14 | 47 |
| 48 die new IMPL::InvalidOperationException("You can't insert the node to itselft") if $this == $node; | |
| 49 | |
| 50 $node->{$parentNode}->removeNode($node) if ($node->{$parentNode}); | |
| 51 | |
| 18 | 52 my $children = $this->childNodes; |
| 53 $children->Append($node); | |
| 14 | 54 |
| 55 $node->_setParent( $this ); | |
| 56 | |
| 57 return $node; | |
| 58 } | |
| 59 | |
| 30 | 60 sub appendNode { |
| 61 goto &appendChild; | |
| 62 } | |
| 63 | |
|
16
75d55f4ee263
Окончательная концепция описания схем и построения DOM документов
Sergey
parents:
14
diff
changeset
|
64 sub appendRange { |
|
75d55f4ee263
Окончательная концепция описания схем и построения DOM документов
Sergey
parents:
14
diff
changeset
|
65 my ($this,@range) = @_; |
|
75d55f4ee263
Окончательная концепция описания схем и построения DOM документов
Sergey
parents:
14
diff
changeset
|
66 |
|
75d55f4ee263
Окончательная концепция описания схем и построения DOM документов
Sergey
parents:
14
diff
changeset
|
67 die new IMPL::InvalidOperationException("You can't insert the node to itselft") if grep $_ == $this, @range; |
|
75d55f4ee263
Окончательная концепция описания схем и построения DOM документов
Sergey
parents:
14
diff
changeset
|
68 |
|
75d55f4ee263
Окончательная концепция описания схем и построения DOM документов
Sergey
parents:
14
diff
changeset
|
69 foreach my $node (@range) { |
|
75d55f4ee263
Окончательная концепция описания схем и построения DOM документов
Sergey
parents:
14
diff
changeset
|
70 $node->{$parentNode}->removeNode($node) if ($node->{$parentNode}); |
|
75d55f4ee263
Окончательная концепция описания схем и построения DOM документов
Sergey
parents:
14
diff
changeset
|
71 $node->_setParent( $this ); |
|
75d55f4ee263
Окончательная концепция описания схем и построения DOM документов
Sergey
parents:
14
diff
changeset
|
72 } |
|
75d55f4ee263
Окончательная концепция описания схем и построения DOM документов
Sergey
parents:
14
diff
changeset
|
73 |
|
75d55f4ee263
Окончательная концепция описания схем и построения DOM документов
Sergey
parents:
14
diff
changeset
|
74 $this->childNodes->Append(@range); |
|
75d55f4ee263
Окончательная концепция описания схем и построения DOM документов
Sergey
parents:
14
diff
changeset
|
75 |
|
75d55f4ee263
Окончательная концепция описания схем и построения DOM документов
Sergey
parents:
14
diff
changeset
|
76 return $this; |
|
75d55f4ee263
Окончательная концепция описания схем и построения DOM документов
Sergey
parents:
14
diff
changeset
|
77 } |
|
75d55f4ee263
Окончательная концепция описания схем и построения DOM документов
Sergey
parents:
14
diff
changeset
|
78 |
| 4 | 79 sub _getChildNodes { |
| 80 my ($this) = @_; | |
| 81 | |
| 82 $this->{$childNodes} = new IMPL::Object::List() unless $this->{$childNodes}; | |
| 18 | 83 return $this->{$childNodes}; |
| 0 | 84 } |
| 85 | |
| 86 sub removeNode { | |
| 87 my ($this,$node) = @_; | |
| 4 | 88 |
| 89 if ($this == $node->{$parentNode}) { | |
| 90 $this->childNodes->RemoveItem($node); | |
| 18 | 91 $node->_setParent(undef); |
| 92 return $node; | |
| 4 | 93 } else { |
| 94 die new IMPL::InvalidOperationException("The specified node isn't belong to this node"); | |
| 95 } | |
| 0 | 96 } |
| 97 | |
| 7 | 98 sub replaceNodeAt { |
| 99 my ($this,$index,$node) = @_; | |
| 100 | |
| 101 my $nodeOld = $this->childNodes->[$index]; | |
| 102 | |
| 103 die new IMPL::InvalidOperationException("You can't insert the node to itselft") if $this == $node; | |
| 104 | |
| 105 # unlink node from previous parent | |
| 106 $node->{$parentNode}->removeNode($node) if ($node->{$parentNode}); | |
| 107 | |
| 108 # replace (or set) old node | |
| 109 $this->childNodes->[$index] = $node; | |
| 110 | |
| 18 | 111 # set new parent |
| 7 | 112 $node->_setParent( $this ); |
| 113 | |
| 114 # unlink old node if we have one | |
| 18 | 115 $nodeOld->_setParent(undef) if $nodeOld; |
| 7 | 116 |
| 117 # return old node | |
| 118 return $nodeOld; | |
| 119 } | |
| 120 | |
| 0 | 121 sub removeAt { |
| 122 my ($this,$pos) = @_; | |
| 4 | 123 |
| 124 if ( my $node = $this->childNodes->RemoveAt($pos) ) { | |
| 18 | 125 $node->_setParent(undef); |
| 126 return $node; | |
| 127 } else { | |
| 128 return undef; | |
| 129 } | |
| 130 } | |
| 131 | |
| 132 sub removeLast { | |
| 133 my ($this) = @_; | |
| 134 | |
| 135 if ( my $node = $this->{$childNodes} ? $this->{$childNodes}->RemoveLast() : undef) { | |
| 136 $node->_setParent(undef); | |
| 4 | 137 return $node; |
| 138 } else { | |
| 139 return undef; | |
| 140 } | |
| 0 | 141 } |
| 142 | |
| 18 | 143 sub removeSelected { |
| 144 my ($this,$query) = @_; | |
| 145 | |
| 146 my @newSet; | |
| 147 my @result; | |
| 148 | |
| 149 if (ref $query eq 'CODE') { | |
| 150 &$query($_) ? push @result, $_ : push @newSet, $_ foreach @{$this->childNodes}; | |
| 151 } elsif (defined $query) { | |
| 152 $_->nodeName eq $query ? push @result, $_ : push @newSet, $_ foreach @{$this->childNodes}; | |
| 153 } else { | |
| 154 my $children = $this->childNodes; | |
| 155 $_->_setParent(undef) foreach @$children; | |
| 156 delete $this->{$childNodes}; | |
| 157 return wantarray ? @$children : $children; | |
| 158 } | |
| 159 | |
| 160 $_->_setParent(undef) foreach @result; | |
| 161 | |
| 162 $this->{$childNodes} = @newSet ? bless \@newSet ,'IMPL::Object::List' : undef; | |
| 163 | |
| 164 return wantarray ? @result : \@result; | |
| 165 } | |
| 166 | |
| 0 | 167 sub selectNodes { |
| 14 | 168 my ($this,$query) = @_; |
| 18 | 169 |
| 14 | 170 my @result; |
| 4 | 171 |
| 14 | 172 if (ref $query eq 'CODE') { |
| 173 @result = grep &$query($_), @{$this->childNodes}; | |
| 24 | 174 } elsif (ref $query eq 'ARRAY' ) { |
| 175 my %keys = map (($_,1),@$query); | |
| 176 @result = grep $keys{$_->nodeName}, @{$this->childNodes}; | |
| 18 | 177 } elsif (defined $query) { |
| 178 @result = grep $_->nodeName eq $query, @{$this->childNodes}; | |
| 14 | 179 } else { |
| 18 | 180 if (wantarray) { |
| 181 return @{$this->childNodes}; | |
| 182 } else { | |
| 183 @result = $this->childNodes; | |
| 184 return \@result; | |
| 185 } | |
| 14 | 186 } |
| 4 | 187 |
| 188 return wantarray ? @result : \@result; | |
| 0 | 189 } |
| 190 | |
| 7 | 191 sub firstChild { |
| 192 @_ >=2 ? $_[0]->replaceNodeAt(0,$_[1]) : $_[0]->childNodes->[0]; | |
| 193 } | |
| 194 | |
| 4 | 195 sub _getIsComplex { |
| 196 $_[0]->childNodes->Count ? 1 : 0; | |
| 197 } | |
| 198 | |
| 18 | 199 sub _getRootNode { |
| 200 $_[0]->{$rootNode} || $_[0]; | |
| 201 } | |
| 202 | |
| 203 sub _updateRootRefs { | |
| 204 my ($this) = @_; | |
| 205 | |
| 206 if ( my $newRoot = $this->{$parentNode} ? $this->{$parentNode}->rootNode : undef) { | |
| 207 if ($this->{$rootNode} ? $this->{$rootNode} != $newRoot : 1 ) { | |
| 208 $this->{$rootNode} = $newRoot; | |
| 209 weaken($this->{$rootNode}); | |
| 210 if ($this->{$childNodes}) { | |
| 211 $_->_updateRootRefs foreach @{$this->{$childNodes}}; | |
| 212 } | |
| 213 } | |
| 214 } elsif($this->{$rootNode}) { | |
| 215 delete $this->{$rootNode}; | |
| 216 if ($this->{$childNodes}) { | |
| 217 $_->_updateRootRefs foreach @{$this->{$childNodes}}; | |
| 218 } | |
| 219 } | |
| 220 } | |
| 221 | |
| 4 | 222 sub _setParent { |
| 11 | 223 my ($this,$node) = @_; |
| 4 | 224 |
| 18 | 225 |
| 226 if (($node || 0) != ($this->{$parentNode} || 0)) { | |
| 227 if ($node) { | |
| 228 $this->{$parentNode} = $node; | |
| 229 # prevent from creating cyclicreferences | |
| 230 weaken($this->{$parentNode}); | |
| 231 } else { | |
| 232 delete $this->{$parentNode}; | |
| 233 } | |
| 234 $this->_updateRootRefs; | |
| 235 } | |
| 0 | 236 } |
| 237 | |
| 238 sub text { | |
| 239 my ($this) = @_; | |
| 4 | 240 |
| 18 | 241 join '', $this->nodeValue || '', map $_->nodeValue || '', @{$this->childNodes}; |
| 0 | 242 } |
| 243 | |
| 21 | 244 sub nodeProperty { |
| 0 | 245 my $this = shift; |
| 246 my $name = shift; | |
| 247 | |
| 248 if (@_) { | |
| 249 # set | |
| 6 | 250 return $this->{$_propertyMap}{$name} = shift; |
| 0 | 251 } else { |
| 6 | 252 return $this->{$_propertyMap}{$name}; |
| 0 | 253 } |
| 254 } | |
| 255 | |
| 24 | 256 sub qname { |
| 257 $_[0]->{$nodeName}; | |
| 258 } | |
| 259 | |
| 260 sub path { | |
| 261 my ($this) = @_; | |
| 262 | |
| 263 if ($this->parentNode) { | |
| 264 return $this->parentNode->path.'.'.$this->qname; | |
| 265 } else { | |
| 266 return $this->qname; | |
| 267 } | |
| 268 } | |
| 269 | |
| 0 | 270 1; |