Mercurial > pub > Impl
annotate Lib/IMPL/DOM/Node.pm @ 340:c090d9102a38
web application security refactoring
author | cin |
---|---|
date | Fri, 21 Jun 2013 02:43:56 +0400 |
parents | 77df11605d3a |
children | 4edd36025051 |
rev | line source |
---|---|
49 | 1 package IMPL::DOM::Node; |
2 use strict; | |
3 use warnings; | |
4 | |
315 | 5 use Scalar::Util qw(weaken); |
49 | 6 |
280 | 7 use IMPL::lang; |
49 | 8 use IMPL::Object::List; |
9 | |
315 | 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 schema => PROP_RO | PROP_DIRECT, | |
27 schemaSource => PROP_RO | PROP_DIRECT, | |
28 _propertyMap => PROP_RW | PROP_DIRECT | |
29 ] | |
30 }; | |
49 | 31 |
104
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
32 our %Axes = ( |
194 | 33 parent => \&selectParent, |
34 siblings => \&selectSiblings, | |
35 child => \&childNodes, | |
36 document => \&selectDocument, | |
37 ancestor => \&selectAncestors, | |
38 descendant => \&selectDescendant | |
104
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
39 ); |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
40 |
49 | 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 | |
124 | 51 while ( my ($key,$value) = each %args ) { |
194 | 52 $this->nodeProperty($key,$value); |
124 | 53 } |
49 | 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->Append($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->Append(@range); | |
100 | |
101 return $this; | |
102 } | |
103 | |
104 sub _getChildNodes { | |
105 my ($this) = @_; | |
106 | |
107 $this->{$childNodes} = new IMPL::Object::List() unless $this->{$childNodes}; | |
102 | 108 return wantarray ? @{ $this->{$childNodes} } : $this->{$childNodes}; |
49 | 109 } |
110 | |
109
ddf0f037d460
IMPL::DOM::Node updated to support TT, (added childNodesRef and selectNodesRef for using from TT)
wizard
parents:
108
diff
changeset
|
111 sub childNodesRef { |
194 | 112 my ($this) = @_; |
113 return scalar $this->_getChildNodes; | |
109
ddf0f037d460
IMPL::DOM::Node updated to support TT, (added childNodesRef and selectNodesRef for using from TT)
wizard
parents:
108
diff
changeset
|
114 } |
ddf0f037d460
IMPL::DOM::Node updated to support TT, (added childNodesRef and selectNodesRef for using from TT)
wizard
parents:
108
diff
changeset
|
115 |
49 | 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 | |
104
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
197 sub resolveAxis { |
194 | 198 my ($this,$axis) = @_; |
199 return $Axes{$axis}->($this) | |
104
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
200 } |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
201 |
49 | 202 sub selectNodes { |
194 | 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; | |
108 | 220 } |
221 | |
113 | 222 sub selectSingleNode { |
194 | 223 my $this = shift; |
224 my @result = $this->selectNodes(@_); | |
225 return $result[0]; | |
113 | 226 } |
227 | |
109
ddf0f037d460
IMPL::DOM::Node updated to support TT, (added childNodesRef and selectNodesRef for using from TT)
wizard
parents:
108
diff
changeset
|
228 sub selectNodesRef { |
194 | 229 my $this = shift; |
230 | |
231 my @result = $this->selectNodes(@_); | |
232 return \@result; | |
109
ddf0f037d460
IMPL::DOM::Node updated to support TT, (added childNodesRef and selectNodesRef for using from TT)
wizard
parents:
108
diff
changeset
|
233 } |
ddf0f037d460
IMPL::DOM::Node updated to support TT, (added childNodesRef and selectNodesRef for using from TT)
wizard
parents:
108
diff
changeset
|
234 |
108 | 235 sub translatePath { |
194 | 236 my ($this,$path) = @_; |
237 | |
238 # TODO: Move path compilation here from IMPL::DOM::Schema::Validator::Compare | |
239 return [$path]; | |
108 | 240 } |
241 | |
242 sub selectNodesAxis { | |
194 | 243 my ($this,$query,$axis) = @_; |
104
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
244 |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
245 $axis ||= 'child'; |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
246 |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
247 die new IMPL::InvalidOperationException('Unknown axis',$axis) unless exists $Axes{$axis}; |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
248 |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
249 my $nodes = $this->resolveAxis($axis); |
49 | 250 |
251 my @result; | |
252 | |
253 if (ref $query eq 'CODE') { | |
104
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
254 @result = grep &$query($_), @{$nodes}; |
49 | 255 } elsif (ref $query eq 'ARRAY' ) { |
256 my %keys = map (($_,1),@$query); | |
104
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
257 @result = grep $keys{$_->nodeName}, @{$nodes}; |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
258 } elsif (ref $query eq 'HASH') { |
194 | 259 while( my ($axis,$filter) = each %$query ) { |
260 push @result, $this->selectNodesAxis($filter,$axis); | |
261 } | |
49 | 262 } elsif (defined $query) { |
104
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
263 @result = grep $_->nodeName eq $query, @{$nodes}; |
49 | 264 } else { |
104
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
265 return wantarray ? @{$nodes} : $nodes; |
49 | 266 } |
267 | |
268 return wantarray ? @result : \@result; | |
269 } | |
270 | |
104
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
271 sub selectParent { |
194 | 272 my ($this) = @_; |
273 | |
274 if ($this->parentNode) { | |
275 return wantarray ? $this->parentNode : [$this->parentNode]; | |
276 } else { | |
277 return wantarray ? () : []; | |
278 } | |
104
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
279 } |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
280 |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
281 sub selectSiblings { |
194 | 282 my ($this) = @_; |
283 | |
284 if ($this->parentNode) { | |
285 return $this->parentNode->selectNodes( sub { $_ != $this } ); | |
286 } else { | |
287 return wantarray ? () : []; | |
288 } | |
104
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
289 } |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
290 |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
291 sub selectDocument { |
194 | 292 my ($this) = @_; |
293 | |
294 if ($this->document) { | |
295 return wantarray ? $this->document : [$this->document]; | |
296 } else { | |
297 return wantarray ? () : []; | |
298 } | |
104
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
299 } |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
300 |
148
e6447ad85cb4
DOM objects now have a schema and schemaSource properties
wizard
parents:
124
diff
changeset
|
301 sub selectDescendant { |
194 | 302 wantarray ? |
303 map $_->selectAll(), $_[0]->childNodes : | |
304 [map $_->selectAll(), $_[0]->childNodes] | |
148
e6447ad85cb4
DOM objects now have a schema and schemaSource properties
wizard
parents:
124
diff
changeset
|
305 } |
e6447ad85cb4
DOM objects now have a schema and schemaSource properties
wizard
parents:
124
diff
changeset
|
306 |
e6447ad85cb4
DOM objects now have a schema and schemaSource properties
wizard
parents:
124
diff
changeset
|
307 sub selectAll { |
e6447ad85cb4
DOM objects now have a schema and schemaSource properties
wizard
parents:
124
diff
changeset
|
308 map(selectAll($_),@{$_[0]->childNodes}) , $_[0] |
e6447ad85cb4
DOM objects now have a schema and schemaSource properties
wizard
parents:
124
diff
changeset
|
309 } |
e6447ad85cb4
DOM objects now have a schema and schemaSource properties
wizard
parents:
124
diff
changeset
|
310 |
e6447ad85cb4
DOM objects now have a schema and schemaSource properties
wizard
parents:
124
diff
changeset
|
311 sub selectAncestors { |
194 | 312 my $parent = $_[0]->parentNode; |
313 | |
314 wantarray ? | |
315 ($parent ? ($parent->selectAncestors,$parent) : ()) : | |
316 [$parent ? ($parent->selectAncestors,$parent) : ()] | |
148
e6447ad85cb4
DOM objects now have a schema and schemaSource properties
wizard
parents:
124
diff
changeset
|
317 } |
e6447ad85cb4
DOM objects now have a schema and schemaSource properties
wizard
parents:
124
diff
changeset
|
318 |
49 | 319 sub firstChild { |
320 @_ >=2 ? $_[0]->replaceNodeAt(0,$_[1]) : $_[0]->childNodes->[0]; | |
321 } | |
322 | |
323 sub _getIsComplex { | |
152 | 324 ($_[0]->{$childNodes} and $_[0]->{$childNodes}->Count) ? 1 : 0; |
49 | 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 | |
173 | 336 map $_->_updateDocRefs, @{$this->{$childNodes}} if $this->{$childNodes}; |
49 | 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}; | |
75 | 354 |
355 #keep document | |
356 $newOwner = $this->{$document}; | |
49 | 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 | |
188 | 377 return unless defined $name; |
378 | |
122 | 379 if (my $method = $this->can($name)) { |
194 | 380 unshift @_,$this; |
381 # use goto to preserve calling context | |
382 goto &$method; | |
122 | 383 } |
148
e6447ad85cb4
DOM objects now have a schema and schemaSource properties
wizard
parents:
124
diff
changeset
|
384 # dynamic property |
49 | 385 if (@_) { |
194 | 386 # set |
387 return $this->{$_propertyMap}{$name} = shift; | |
388 } else { | |
389 return $this->{$_propertyMap}{$name}; | |
49 | 390 } |
391 } | |
392 | |
122 | 393 sub listProperties { |
194 | 394 my ($this) = @_; |
395 | |
315 | 396 my %props = map {$_->name, 1} $this->GetMeta(PropertyInfo, sub { $_->attributes->{domProperty}},1); |
194 | 397 |
398 return (keys %props,keys %{$this->{$_propertyMap}}); | |
122 | 399 } |
400 | |
152 | 401 sub save { |
194 | 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 } | |
152 | 426 } |
427 | |
49 | 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; | |
75 | 443 |
444 __END__ | |
445 | |
446 =pod | |
447 | |
448 =head1 NAME | |
449 | |
180 | 450 C<IMPL::DOM::Node> Элемент DOM модели |
75 | 451 |
452 =head1 DESCRIPTION | |
453 | |
180 | 454 Базовый узел DOM модели. От него можно наследовать другие элементы DOM модели. |
75 | 455 |
456 =head1 MEMBERS | |
457 | |
458 =head2 PROPERTIES | |
459 | |
460 =over | |
461 | |
462 =item C<[get] nodeName> | |
463 | |
180 | 464 Имя узла. Задается при создании. |
75 | 465 |
466 =item C<[get] document> | |
467 | |
180 | 468 Документ к которому принадлежит узел. Задается при поздании узла. |
75 | 469 |
470 =item C<[get] isComplex> | |
471 | |
180 | 472 Определяет является ли узел сложным (тоесть есть ли дети). |
75 | 473 |
180 | 474 C<true> - есть, C<false> - нет. |
75 | 475 |
476 =item C<[get,set] nodeValue> | |
477 | |
180 | 478 Значение узла, обычно простой скаляр, но ничто не мешает туда |
479 устанавливать любое значение. | |
75 | 480 |
481 =item C<[get,list] childNodes> | |
482 | |
180 | 483 Список детей, является списокм C<IMPL::Object::List>. |
75 | 484 |
485 =item C<[get] parentNode> | |
486 | |
180 | 487 Ссылка на родительский элемент, если таковой имеется. |
75 | 488 |
148
e6447ad85cb4
DOM objects now have a schema and schemaSource properties
wizard
parents:
124
diff
changeset
|
489 =item C<[get] schema> |
e6447ad85cb4
DOM objects now have a schema and schemaSource properties
wizard
parents:
124
diff
changeset
|
490 |
180 | 491 Ссылка на узел из C<IMPL::DOM::Schema>, представляющий схему данных текущего узла. Может быть C<undef>. |
148
e6447ad85cb4
DOM objects now have a schema and schemaSource properties
wizard
parents:
124
diff
changeset
|
492 |
e6447ad85cb4
DOM objects now have a schema and schemaSource properties
wizard
parents:
124
diff
changeset
|
493 =item C<[get] schema> |
e6447ad85cb4
DOM objects now have a schema and schemaSource properties
wizard
parents:
124
diff
changeset
|
494 |
180 | 495 Ссылка на узел из C<IMPL::DOM::Schema>, представляющий элемент схемы, объявляющий данный узел. Может быть C<undef>. |
148
e6447ad85cb4
DOM objects now have a schema and schemaSource properties
wizard
parents:
124
diff
changeset
|
496 |
180 | 497 Отличается от свойства C<schema> тем, что узел в случае ссылки на тип узла, данной свойство будет содержать |
498 описание ссылки C<IMPL::DOM::Schema::Node>, а свойство C<schema> например будет ссылаться на | |
148
e6447ad85cb4
DOM objects now have a schema and schemaSource properties
wizard
parents:
124
diff
changeset
|
499 C<IMPL::DOM::Schema::ComplexType>. |
e6447ad85cb4
DOM objects now have a schema and schemaSource properties
wizard
parents:
124
diff
changeset
|
500 |
e6447ad85cb4
DOM objects now have a schema and schemaSource properties
wizard
parents:
124
diff
changeset
|
501 =back |
e6447ad85cb4
DOM objects now have a schema and schemaSource properties
wizard
parents:
124
diff
changeset
|
502 |
75 | 503 =head2 METHODS |
504 | |
180 | 505 =cut |