|
407
|
1 package IMPL::DOM::Node;
|
|
|
2 use strict;
|
|
|
3 use warnings;
|
|
|
4
|
|
|
5 use Scalar::Util qw(weaken);
|
|
|
6
|
|
|
7 use IMPL::lang;
|
|
|
8 use IMPL::Object::List;
|
|
|
9
|
|
|
10 use IMPL::Exception();
|
|
|
11 use IMPL::Const qw(:prop);
|
|
|
12 use IMPL::declare {
|
|
|
13 require => {
|
|
|
14 PropertyInfo => '-IMPL::Class::PropertyInfo'
|
|
|
15 },
|
|
|
16 base => [
|
|
|
17 'IMPL::Object' => undef
|
|
|
18 ],
|
|
|
19 props => [
|
|
|
20 nodeName => PROP_RO | PROP_DIRECT,
|
|
|
21 document => PROP_RO | PROP_DIRECT,
|
|
|
22 isComplex => { get => \&_getIsComplex },
|
|
|
23 nodeValue => PROP_RW | PROP_DIRECT,
|
|
|
24 childNodes => { get => \&_getChildNodes, isList => 1, direct => 1 },
|
|
|
25 parentNode => PROP_RO | PROP_DIRECT,
|
|
|
26 schemaNode => PROP_RO | PROP_DIRECT,
|
|
|
27 schemaType => PROP_RO | PROP_DIRECT,
|
|
|
28 _propertyMap => PROP_RW | PROP_DIRECT
|
|
|
29 ]
|
|
|
30 };
|
|
|
31
|
|
|
32 our %Axes = (
|
|
|
33 parent => \&selectParent,
|
|
|
34 siblings => \&selectSiblings,
|
|
|
35 child => \&childNodes,
|
|
|
36 document => \&selectDocument,
|
|
|
37 ancestor => \&selectAncestors,
|
|
|
38 descendant => \&selectDescendant
|
|
|
39 );
|
|
|
40
|
|
|
41 sub CTOR {
|
|
|
42 my ($this,%args) = @_;
|
|
|
43
|
|
|
44 $this->{$nodeName} = delete $args{nodeName} or die new IMPL::InvalidArgumentException("A name is required");
|
|
|
45 $this->{$nodeValue} = delete $args{nodeValue} if exists $args{nodeValue};
|
|
|
46 if ( exists $args{document} ) {
|
|
|
47 $this->{$document} = delete $args{document};
|
|
|
48 weaken($this->{$document});
|
|
|
49 }
|
|
|
50
|
|
|
51 while ( my ($key,$value) = each %args ) {
|
|
|
52 $this->nodeProperty($key,$value);
|
|
|
53 }
|
|
|
54 }
|
|
|
55
|
|
|
56 sub insertNode {
|
|
|
57 my ($this,$node,$pos) = @_;
|
|
|
58
|
|
|
59 die new IMPL::InvalidOperationException("You can't insert the node to itselft") if $this == $node;
|
|
|
60
|
|
|
61 $node->{$parentNode}->removeNode($node) if ($node->{$parentNode});
|
|
|
62
|
|
|
63 $this->childNodes->InsertAt($pos,$node);
|
|
|
64
|
|
|
65 $node->_setParent( $this );
|
|
|
66
|
|
|
67 return $node;
|
|
|
68 }
|
|
|
69
|
|
|
70 sub appendChild {
|
|
|
71 my ($this,$node) = @_;
|
|
|
72
|
|
|
73 die new IMPL::InvalidOperationException("You can't insert the node to itselft") if $this == $node;
|
|
|
74
|
|
|
75 $node->{$parentNode}->removeNode($node) if ($node->{$parentNode});
|
|
|
76
|
|
|
77 my $children = $this->childNodes;
|
|
|
78 $children->Push($node);
|
|
|
79
|
|
|
80 $node->_setParent( $this );
|
|
|
81
|
|
|
82 return $node;
|
|
|
83 }
|
|
|
84
|
|
|
85 sub appendNode {
|
|
|
86 goto &appendChild;
|
|
|
87 }
|
|
|
88
|
|
|
89 sub appendRange {
|
|
|
90 my ($this,@range) = @_;
|
|
|
91
|
|
|
92 die new IMPL::InvalidOperationException("You can't insert the node to itselft") if grep $_ == $this, @range;
|
|
|
93
|
|
|
94 foreach my $node (@range) {
|
|
|
95 $node->{$parentNode}->removeNode($node) if ($node->{$parentNode});
|
|
|
96 $node->_setParent( $this );
|
|
|
97 }
|
|
|
98
|
|
|
99 $this->childNodes->Push(@range);
|
|
|
100
|
|
|
101 return $this;
|
|
|
102 }
|
|
|
103
|
|
|
104 sub _getChildNodes {
|
|
|
105 my ($this) = @_;
|
|
|
106
|
|
|
107 $this->{$childNodes} = new IMPL::Object::List() unless $this->{$childNodes};
|
|
|
108 return wantarray ? @{ $this->{$childNodes} } : $this->{$childNodes};
|
|
|
109 }
|
|
|
110
|
|
|
111 sub childNodesRef {
|
|
|
112 my ($this) = @_;
|
|
|
113 return scalar $this->_getChildNodes;
|
|
|
114 }
|
|
|
115
|
|
|
116 sub removeNode {
|
|
|
117 my ($this,$node) = @_;
|
|
|
118
|
|
|
119 if ($this == $node->{$parentNode}) {
|
|
|
120 $this->childNodes->RemoveItem($node);
|
|
|
121 $node->_setParent(undef);
|
|
|
122 return $node;
|
|
|
123 } else {
|
|
|
124 die new IMPL::InvalidOperationException("The specified node isn't belong to this node");
|
|
|
125 }
|
|
|
126 }
|
|
|
127
|
|
|
128 sub replaceNodeAt {
|
|
|
129 my ($this,$index,$node) = @_;
|
|
|
130
|
|
|
131 my $nodeOld = $this->childNodes->[$index];
|
|
|
132
|
|
|
133 die new IMPL::InvalidOperationException("You can't insert the node to itselft") if $this == $node;
|
|
|
134
|
|
|
135 # unlink node from previous parent
|
|
|
136 $node->{$parentNode}->removeNode($node) if ($node->{$parentNode});
|
|
|
137
|
|
|
138 # replace (or set) old node
|
|
|
139 $this->childNodes->[$index] = $node;
|
|
|
140
|
|
|
141 # set new parent
|
|
|
142 $node->_setParent( $this );
|
|
|
143
|
|
|
144 # unlink old node if we have one
|
|
|
145 $nodeOld->_setParent(undef) if $nodeOld;
|
|
|
146
|
|
|
147 # return old node
|
|
|
148 return $nodeOld;
|
|
|
149 }
|
|
|
150
|
|
|
151 sub removeAt {
|
|
|
152 my ($this,$pos) = @_;
|
|
|
153
|
|
|
154 if ( my $node = $this->childNodes->RemoveAt($pos) ) {
|
|
|
155 $node->_setParent(undef);
|
|
|
156 return $node;
|
|
|
157 } else {
|
|
|
158 return undef;
|
|
|
159 }
|
|
|
160 }
|
|
|
161
|
|
|
162 sub removeLast {
|
|
|
163 my ($this) = @_;
|
|
|
164
|
|
|
165 if ( my $node = $this->{$childNodes} ? $this->{$childNodes}->RemoveLast() : undef) {
|
|
|
166 $node->_setParent(undef);
|
|
|
167 return $node;
|
|
|
168 } else {
|
|
|
169 return undef;
|
|
|
170 }
|
|
|
171 }
|
|
|
172
|
|
|
173 sub removeSelected {
|
|
|
174 my ($this,$query) = @_;
|
|
|
175
|
|
|
176 my @newSet;
|
|
|
177 my @result;
|
|
|
178
|
|
|
179 if (ref $query eq 'CODE') {
|
|
|
180 &$query($_) ? push @result, $_ : push @newSet, $_ foreach @{$this->childNodes};
|
|
|
181 } elsif (defined $query) {
|
|
|
182 $_->nodeName eq $query ? push @result, $_ : push @newSet, $_ foreach @{$this->childNodes};
|
|
|
183 } else {
|
|
|
184 my $children = $this->childNodes;
|
|
|
185 $_->_setParent(undef) foreach @$children;
|
|
|
186 delete $this->{$childNodes};
|
|
|
187 return wantarray ? @$children : $children;
|
|
|
188 }
|
|
|
189
|
|
|
190 $_->_setParent(undef) foreach @result;
|
|
|
191
|
|
|
192 $this->{$childNodes} = @newSet ? bless \@newSet ,'IMPL::Object::List' : undef;
|
|
|
193
|
|
|
194 return wantarray ? @result : \@result;
|
|
|
195 }
|
|
|
196
|
|
|
197 sub resolveAxis {
|
|
|
198 my ($this,$axis) = @_;
|
|
|
199 return $Axes{$axis}->($this)
|
|
|
200 }
|
|
|
201
|
|
|
202 sub selectNodes {
|
|
|
203 my $this = shift;
|
|
|
204 my $path;
|
|
|
205
|
|
|
206 if (@_ == 1) {
|
|
|
207 $path = $this->translatePath($_[0]);
|
|
|
208 } else {
|
|
|
209 $path = [@_];
|
|
|
210 }
|
|
|
211
|
|
|
212 my @set = ($this);
|
|
|
213
|
|
|
214 while (@$path) {
|
|
|
215 my $query = shift @$path;
|
|
|
216 @set = map $_->selectNodesAxis($query), @set;
|
|
|
217 }
|
|
|
218
|
|
|
219 return wantarray ? @set : \@set;
|
|
|
220 }
|
|
|
221
|
|
|
222 sub selectSingleNode {
|
|
|
223 my $this = shift;
|
|
|
224 my @result = $this->selectNodes(@_);
|
|
|
225 return $result[0];
|
|
|
226 }
|
|
|
227
|
|
|
228 sub selectNodesRef {
|
|
|
229 my $this = shift;
|
|
|
230
|
|
|
231 my @result = $this->selectNodes(@_);
|
|
|
232 return \@result;
|
|
|
233 }
|
|
|
234
|
|
|
235 sub translatePath {
|
|
|
236 my ($this,$path) = @_;
|
|
|
237
|
|
|
238 # TODO: Move path compilation here from IMPL::DOM::Schema::Validator::Compare
|
|
|
239 return [$path];
|
|
|
240 }
|
|
|
241
|
|
|
242 sub selectNodesAxis {
|
|
|
243 my ($this,$query,$axis) = @_;
|
|
|
244
|
|
|
245 $axis ||= 'child';
|
|
|
246
|
|
|
247 die new IMPL::InvalidOperationException('Unknown axis',$axis) unless exists $Axes{$axis};
|
|
|
248
|
|
|
249 my $nodes = $this->resolveAxis($axis);
|
|
|
250
|
|
|
251 my @result;
|
|
|
252
|
|
|
253 if (ref $query eq 'CODE') {
|
|
|
254 @result = grep &$query($_), @{$nodes};
|
|
|
255 } elsif (ref $query eq 'ARRAY' ) {
|
|
|
256 my %keys = map (($_,1),@$query);
|
|
|
257 @result = grep $keys{$_->nodeName}, @{$nodes};
|
|
|
258 } elsif (ref $query eq 'HASH') {
|
|
|
259 while( my ($axis,$filter) = each %$query ) {
|
|
|
260 push @result, $this->selectNodesAxis($filter,$axis);
|
|
|
261 }
|
|
|
262 } elsif (defined $query) {
|
|
|
263 @result = grep $_->nodeName eq $query, @{$nodes};
|
|
|
264 } else {
|
|
|
265 return wantarray ? @{$nodes} : $nodes;
|
|
|
266 }
|
|
|
267
|
|
|
268 return wantarray ? @result : \@result;
|
|
|
269 }
|
|
|
270
|
|
|
271 sub selectParent {
|
|
|
272 my ($this) = @_;
|
|
|
273
|
|
|
274 if ($this->parentNode) {
|
|
|
275 return wantarray ? $this->parentNode : [$this->parentNode];
|
|
|
276 } else {
|
|
|
277 return wantarray ? () : [];
|
|
|
278 }
|
|
|
279 }
|
|
|
280
|
|
|
281 sub selectSiblings {
|
|
|
282 my ($this) = @_;
|
|
|
283
|
|
|
284 if ($this->parentNode) {
|
|
|
285 return $this->parentNode->selectNodes( sub { $_ != $this } );
|
|
|
286 } else {
|
|
|
287 return wantarray ? () : [];
|
|
|
288 }
|
|
|
289 }
|
|
|
290
|
|
|
291 sub selectDocument {
|
|
|
292 my ($this) = @_;
|
|
|
293
|
|
|
294 if ($this->document) {
|
|
|
295 return wantarray ? $this->document : [$this->document];
|
|
|
296 } else {
|
|
|
297 return wantarray ? () : [];
|
|
|
298 }
|
|
|
299 }
|
|
|
300
|
|
|
301 sub selectDescendant {
|
|
|
302 wantarray ?
|
|
|
303 map $_->selectAll(), $_[0]->childNodes :
|
|
|
304 [map $_->selectAll(), $_[0]->childNodes]
|
|
|
305 }
|
|
|
306
|
|
|
307 sub selectAll {
|
|
|
308 map(selectAll($_),@{$_[0]->childNodes}) , $_[0]
|
|
|
309 }
|
|
|
310
|
|
|
311 sub selectAncestors {
|
|
|
312 my $parent = $_[0]->parentNode;
|
|
|
313
|
|
|
314 wantarray ?
|
|
|
315 ($parent ? ($parent->selectAncestors,$parent) : ()) :
|
|
|
316 [$parent ? ($parent->selectAncestors,$parent) : ()]
|
|
|
317 }
|
|
|
318
|
|
|
319 sub firstChild {
|
|
|
320 @_ >=2 ? $_[0]->replaceNodeAt(0,$_[1]) : $_[0]->childNodes->[0];
|
|
|
321 }
|
|
|
322
|
|
|
323 sub _getIsComplex {
|
|
|
324 ($_[0]->{$childNodes} and $_[0]->{$childNodes}->Count) ? 1 : 0;
|
|
|
325 }
|
|
|
326
|
|
|
327 sub _updateDocRefs {
|
|
|
328 my ($this) = @_;
|
|
|
329
|
|
|
330 # this method is called by the parent node on his children, so we need no to check parent
|
|
|
331 $this->{$document} = $this->{$parentNode}->document;
|
|
|
332
|
|
|
333 # prevent cyclic
|
|
|
334 weaken($this->{$document}) if $this->{$document};
|
|
|
335
|
|
|
336 map $_->_updateDocRefs, @{$this->{$childNodes}} if $this->{$childNodes};
|
|
|
337 }
|
|
|
338
|
|
|
339 sub _setParent {
|
|
|
340 my ($this,$node) = @_;
|
|
|
341
|
|
|
342
|
|
|
343 if (($node || 0) != ($this->{$parentNode} || 0)) {
|
|
|
344 my $newOwner;
|
|
|
345 if ($node) {
|
|
|
346 $this->{$parentNode} = $node;
|
|
|
347 $newOwner = $node->document || 0;
|
|
|
348
|
|
|
349 # prevent from creating cyclicreferences
|
|
|
350 weaken($this->{$parentNode});
|
|
|
351
|
|
|
352 } else {
|
|
|
353 delete $this->{$parentNode};
|
|
|
354
|
|
|
355 #keep document
|
|
|
356 $newOwner = $this->{$document};
|
|
|
357 }
|
|
|
358
|
|
|
359 if (($this->{$document}||0) != $newOwner) {
|
|
|
360 $this->{$document} = $newOwner;
|
|
|
361 weaken($this->{$document}) if $newOwner;
|
|
|
362 $_->_updateDocRefs foreach @{$this->childNodes};
|
|
|
363 }
|
|
|
364 }
|
|
|
365 }
|
|
|
366
|
|
|
367 sub text {
|
|
|
368 my ($this) = @_;
|
|
|
369
|
|
|
370 join ('', $this->nodeValue || '', map ($_->text || '', @{$this->childNodes}));
|
|
|
371 }
|
|
|
372
|
|
|
373 sub nodeProperty {
|
|
|
374 my $this = shift;
|
|
|
375 my $name = shift;
|
|
|
376
|
|
|
377 return unless defined $name;
|
|
|
378
|
|
|
379 if (my $method = $this->can($name)) {
|
|
|
380 unshift @_,$this;
|
|
|
381 # use goto to preserve calling context
|
|
|
382 goto &$method;
|
|
|
383 }
|
|
|
384 # dynamic property
|
|
|
385 if (@_) {
|
|
|
386 # set
|
|
|
387 return $this->{$_propertyMap}{$name} = shift;
|
|
|
388 } else {
|
|
|
389 return $this->{$_propertyMap}{$name};
|
|
|
390 }
|
|
|
391 }
|
|
|
392
|
|
|
393 sub listProperties {
|
|
|
394 my ($this) = @_;
|
|
|
395
|
|
|
396 my %props = map {$_->name, 1} $this->GetMeta(PropertyInfo, sub { $_->attributes->{dom} },1);
|
|
|
397
|
|
|
398 return (keys %props,keys %{$this->{$_propertyMap}});
|
|
|
399 }
|
|
|
400
|
|
|
401 sub save {
|
|
|
402 my ($this,$writer) = @_;
|
|
|
403
|
|
|
404 if ( not ( $this->isComplex or defined $this->{$nodeValue} ) ) {
|
|
|
405 $writer->emptyTag(
|
|
|
406 $this->{$nodeName},
|
|
|
407 map {
|
|
|
408 $_,
|
|
|
409 $this->nodeProperty($_)
|
|
|
410 } grep defined $this->nodeProperty($_), $this->listProperties
|
|
|
411 );
|
|
|
412 } else {
|
|
|
413 $writer->startTag(
|
|
|
414 $this->{$nodeName},
|
|
|
415 map {
|
|
|
416 $_,
|
|
|
417 $this->nodeProperty($_)
|
|
|
418 } grep defined $this->nodeProperty($_), $this->listProperties
|
|
|
419 );
|
|
|
420 $writer->characters($this->{$nodeValue}) if $this->{$nodeValue};
|
|
|
421
|
|
|
422 $_->save($writer) foreach $this->childNodes;
|
|
|
423
|
|
|
424 $writer->endTag($this->{$nodeName});
|
|
|
425 }
|
|
|
426 }
|
|
|
427
|
|
|
428 sub qname {
|
|
|
429 $_[0]->{$nodeName};
|
|
|
430 }
|
|
|
431
|
|
|
432 sub path {
|
|
|
433 my ($this) = @_;
|
|
|
434
|
|
|
435 if ($this->parentNode) {
|
|
|
436 return $this->parentNode->path.'.'.$this->qname;
|
|
|
437 } else {
|
|
|
438 return $this->qname;
|
|
|
439 }
|
|
|
440 }
|
|
|
441
|
|
|
442 1;
|
|
|
443
|
|
|
444 __END__
|
|
|
445
|
|
|
446 =pod
|
|
|
447
|
|
|
448 =head1 NAME
|
|
|
449
|
|
|
450 C<IMPL::DOM::Node> Элемент DOM модели
|
|
|
451
|
|
|
452 =head1 DESCRIPTION
|
|
|
453
|
|
|
454 Базовый узел DOM модели. От него можно наследовать другие элементы DOM модели.
|
|
|
455
|
|
|
456 =head1 MEMBERS
|
|
|
457
|
|
|
458 =head2 PROPERTIES
|
|
|
459
|
|
|
460 =over
|
|
|
461
|
|
|
462 =item C<[get] nodeName>
|
|
|
463
|
|
|
464 Имя узла. Задается при создании.
|
|
|
465
|
|
|
466 =item C<[get] document>
|
|
|
467
|
|
|
468 Документ к которому принадлежит узел. Задается при поздании узла.
|
|
|
469
|
|
|
470 =item C<[get] isComplex>
|
|
|
471
|
|
|
472 Определяет является ли узел сложным (тоесть есть ли дети).
|
|
|
473
|
|
|
474 C<true> - есть, C<false> - нет.
|
|
|
475
|
|
|
476 =item C<[get,set] nodeValue>
|
|
|
477
|
|
|
478 Значение узла, обычно простой скаляр, но ничто не мешает туда
|
|
|
479 устанавливать любое значение.
|
|
|
480
|
|
|
481 =item C<[get,list] childNodes>
|
|
|
482
|
|
|
483 Список детей, является списокм C<IMPL::Object::List>.
|
|
|
484
|
|
|
485 =item C<[get] parentNode>
|
|
|
486
|
|
|
487 Ссылка на родительский элемент, если таковой имеется.
|
|
|
488
|
|
|
489 =item C<[get] schemaType>
|
|
|
490
|
|
|
491 Ссылка на узел из C<IMPL::DOM::Schema>, представляющий схему данных текущего узла. Может быть C<undef>.
|
|
|
492
|
|
|
493 =item C<[get] schemaNode>
|
|
|
494
|
|
|
495 Ссылка на узел из C<IMPL::DOM::Schema>, представляющий элемент схемы, объявляющий данный узел. Может быть C<undef>.
|
|
|
496
|
|
|
497 Отличается от свойства C<schemaType> тем, что узел в случае ссылки на тип узла, данной свойство будет содержать
|
|
|
498 описание ссылки C<IMPL::DOM::Schema::Node>, а свойство C<schema> например будет ссылаться на
|
|
|
499 C<IMPL::DOM::Schema::ComplexType>.
|
|
|
500
|
|
|
501 =back
|
|
|
502
|
|
|
503 =head2 METHODS
|
|
|
504
|
|
|
505 =cut
|
