Mercurial > pub > Impl
annotate Lib/IMPL/DOM/Node.pm @ 130:06a34c197b05
Added support for utf-8 and old versions of CGI module
author | wizard |
---|---|
date | Wed, 16 Jun 2010 01:50:56 +0400 |
parents | e30bdd040fe3 |
children | e6447ad85cb4 |
rev | line source |
---|---|
49 | 1 package IMPL::DOM::Node; |
2 use strict; | |
3 use warnings; | |
4 | |
5 use base qw(IMPL::Object); | |
6 | |
7 use IMPL::Object::List; | |
8 use IMPL::Class::Property; | |
9 use IMPL::Class::Property::Direct; | |
10 use Scalar::Util qw(weaken); | |
11 | |
12 use IMPL::Exception; | |
13 | |
14 BEGIN { | |
15 public _direct property nodeName => prop_get; | |
16 public _direct property document => prop_get; | |
17 public _direct property isComplex => { get => \&_getIsComplex } ; | |
18 public _direct property nodeValue => prop_all; | |
102 | 19 public _direct property childNodes => { get => \&_getChildNodes }; # prop_list |
49 | 20 public _direct property parentNode => prop_get ; |
21 private _direct property _propertyMap => prop_all ; | |
116 | 22 |
23 __PACKAGE__->class_data(property_bind => {}); | |
49 | 24 } |
25 | |
104
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
26 our %Axes = ( |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
27 parent => \&selectParent, |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
28 siblings => \&selectSiblings, |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
29 child => \&childNodes, |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
30 document => \&selectDocument |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
31 ); |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
32 |
49 | 33 sub CTOR { |
34 my ($this,%args) = @_; | |
35 | |
36 $this->{$nodeName} = delete $args{nodeName} or die new IMPL::InvalidArgumentException("A name is required"); | |
37 $this->{$nodeValue} = delete $args{nodeValue} if exists $args{nodeValue}; | |
38 if ( exists $args{document} ) { | |
39 $this->{$document} = delete $args{document}; | |
40 weaken($this->{$document}); | |
41 } | |
42 | |
124 | 43 while ( my ($key,$value) = each %args ) { |
44 $this->nodeProperty($key,$value); | |
45 } | |
49 | 46 } |
47 | |
48 sub insertNode { | |
49 my ($this,$node,$pos) = @_; | |
50 | |
51 die new IMPL::InvalidOperationException("You can't insert the node to itselft") if $this == $node; | |
52 | |
53 $node->{$parentNode}->removeNode($node) if ($node->{$parentNode}); | |
54 | |
55 $this->childNodes->InsertAt($pos,$node); | |
56 | |
57 $node->_setParent( $this ); | |
58 | |
59 return $node; | |
60 } | |
61 | |
62 sub appendChild { | |
63 my ($this,$node) = @_; | |
64 | |
65 die new IMPL::InvalidOperationException("You can't insert the node to itselft") if $this == $node; | |
66 | |
67 $node->{$parentNode}->removeNode($node) if ($node->{$parentNode}); | |
68 | |
69 my $children = $this->childNodes; | |
70 $children->Append($node); | |
71 | |
72 $node->_setParent( $this ); | |
73 | |
74 return $node; | |
75 } | |
76 | |
77 sub appendNode { | |
78 goto &appendChild; | |
79 } | |
80 | |
81 sub appendRange { | |
82 my ($this,@range) = @_; | |
83 | |
84 die new IMPL::InvalidOperationException("You can't insert the node to itselft") if grep $_ == $this, @range; | |
85 | |
86 foreach my $node (@range) { | |
87 $node->{$parentNode}->removeNode($node) if ($node->{$parentNode}); | |
88 $node->_setParent( $this ); | |
89 } | |
90 | |
91 $this->childNodes->Append(@range); | |
92 | |
93 return $this; | |
94 } | |
95 | |
96 sub _getChildNodes { | |
97 my ($this) = @_; | |
98 | |
99 $this->{$childNodes} = new IMPL::Object::List() unless $this->{$childNodes}; | |
102 | 100 return wantarray ? @{ $this->{$childNodes} } : $this->{$childNodes}; |
49 | 101 } |
102 | |
109
ddf0f037d460
IMPL::DOM::Node updated to support TT, (added childNodesRef and selectNodesRef for using from TT)
wizard
parents:
108
diff
changeset
|
103 sub childNodesRef { |
ddf0f037d460
IMPL::DOM::Node updated to support TT, (added childNodesRef and selectNodesRef for using from TT)
wizard
parents:
108
diff
changeset
|
104 my ($this) = @_; |
ddf0f037d460
IMPL::DOM::Node updated to support TT, (added childNodesRef and selectNodesRef for using from TT)
wizard
parents:
108
diff
changeset
|
105 return scalar $this->_getChildNodes; |
ddf0f037d460
IMPL::DOM::Node updated to support TT, (added childNodesRef and selectNodesRef for using from TT)
wizard
parents:
108
diff
changeset
|
106 } |
ddf0f037d460
IMPL::DOM::Node updated to support TT, (added childNodesRef and selectNodesRef for using from TT)
wizard
parents:
108
diff
changeset
|
107 |
49 | 108 sub removeNode { |
109 my ($this,$node) = @_; | |
110 | |
111 if ($this == $node->{$parentNode}) { | |
112 $this->childNodes->RemoveItem($node); | |
113 $node->_setParent(undef); | |
114 return $node; | |
115 } else { | |
116 die new IMPL::InvalidOperationException("The specified node isn't belong to this node"); | |
117 } | |
118 } | |
119 | |
120 sub replaceNodeAt { | |
121 my ($this,$index,$node) = @_; | |
122 | |
123 my $nodeOld = $this->childNodes->[$index]; | |
124 | |
125 die new IMPL::InvalidOperationException("You can't insert the node to itselft") if $this == $node; | |
126 | |
127 # unlink node from previous parent | |
128 $node->{$parentNode}->removeNode($node) if ($node->{$parentNode}); | |
129 | |
130 # replace (or set) old node | |
131 $this->childNodes->[$index] = $node; | |
132 | |
133 # set new parent | |
134 $node->_setParent( $this ); | |
135 | |
136 # unlink old node if we have one | |
137 $nodeOld->_setParent(undef) if $nodeOld; | |
138 | |
139 # return old node | |
140 return $nodeOld; | |
141 } | |
142 | |
143 sub removeAt { | |
144 my ($this,$pos) = @_; | |
145 | |
146 if ( my $node = $this->childNodes->RemoveAt($pos) ) { | |
147 $node->_setParent(undef); | |
148 return $node; | |
149 } else { | |
150 return undef; | |
151 } | |
152 } | |
153 | |
154 sub removeLast { | |
155 my ($this) = @_; | |
156 | |
157 if ( my $node = $this->{$childNodes} ? $this->{$childNodes}->RemoveLast() : undef) { | |
158 $node->_setParent(undef); | |
159 return $node; | |
160 } else { | |
161 return undef; | |
162 } | |
163 } | |
164 | |
165 sub removeSelected { | |
166 my ($this,$query) = @_; | |
167 | |
168 my @newSet; | |
169 my @result; | |
170 | |
171 if (ref $query eq 'CODE') { | |
172 &$query($_) ? push @result, $_ : push @newSet, $_ foreach @{$this->childNodes}; | |
173 } elsif (defined $query) { | |
174 $_->nodeName eq $query ? push @result, $_ : push @newSet, $_ foreach @{$this->childNodes}; | |
175 } else { | |
176 my $children = $this->childNodes; | |
177 $_->_setParent(undef) foreach @$children; | |
178 delete $this->{$childNodes}; | |
179 return wantarray ? @$children : $children; | |
180 } | |
181 | |
182 $_->_setParent(undef) foreach @result; | |
183 | |
184 $this->{$childNodes} = @newSet ? bless \@newSet ,'IMPL::Object::List' : undef; | |
185 | |
186 return wantarray ? @result : \@result; | |
187 } | |
188 | |
104
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
189 sub resolveAxis { |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
190 my ($this,$axis) = @_; |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
191 return $Axes{$axis}->($this) |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
192 } |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
193 |
49 | 194 sub selectNodes { |
108 | 195 my $this = shift; |
122 | 196 my $path; |
108 | 197 |
122 | 198 if (@_ == 1) { |
199 $path = $this->translatePath($_[0]); | |
200 } else { | |
201 $path = [@_]; | |
202 } | |
108 | 203 |
204 my @set = ($this); | |
205 | |
122 | 206 while (@$path) { |
207 my $query = shift @$path; | |
108 | 208 @set = map $_->selectNodesAxis($query), @set; |
209 } | |
210 | |
211 return wantarray ? @set : \@set; | |
212 } | |
213 | |
113 | 214 sub selectSingleNode { |
215 my $this = shift; | |
216 my @result = $this->selectNodes(@_); | |
217 return $result[0]; | |
218 } | |
219 | |
109
ddf0f037d460
IMPL::DOM::Node updated to support TT, (added childNodesRef and selectNodesRef for using from TT)
wizard
parents:
108
diff
changeset
|
220 sub selectNodesRef { |
ddf0f037d460
IMPL::DOM::Node updated to support TT, (added childNodesRef and selectNodesRef for using from TT)
wizard
parents:
108
diff
changeset
|
221 my $this = shift; |
ddf0f037d460
IMPL::DOM::Node updated to support TT, (added childNodesRef and selectNodesRef for using from TT)
wizard
parents:
108
diff
changeset
|
222 |
ddf0f037d460
IMPL::DOM::Node updated to support TT, (added childNodesRef and selectNodesRef for using from TT)
wizard
parents:
108
diff
changeset
|
223 my @result = $this->selectNodes(@_); |
ddf0f037d460
IMPL::DOM::Node updated to support TT, (added childNodesRef and selectNodesRef for using from TT)
wizard
parents:
108
diff
changeset
|
224 return \@result; |
ddf0f037d460
IMPL::DOM::Node updated to support TT, (added childNodesRef and selectNodesRef for using from TT)
wizard
parents:
108
diff
changeset
|
225 } |
ddf0f037d460
IMPL::DOM::Node updated to support TT, (added childNodesRef and selectNodesRef for using from TT)
wizard
parents:
108
diff
changeset
|
226 |
108 | 227 sub translatePath { |
228 my ($this,$path) = @_; | |
229 | |
230 # TODO: Move path compilation here from IMPL::DOM::Schema::Validator::Compare | |
231 return [$path]; | |
232 } | |
233 | |
234 sub selectNodesAxis { | |
235 my ($this,$query,$axis) = @_; | |
104
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
236 |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
237 $axis ||= 'child'; |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
238 |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
239 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
|
240 |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
241 my $nodes = $this->resolveAxis($axis); |
49 | 242 |
243 my @result; | |
244 | |
245 if (ref $query eq 'CODE') { | |
104
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
246 @result = grep &$query($_), @{$nodes}; |
49 | 247 } elsif (ref $query eq 'ARRAY' ) { |
248 my %keys = map (($_,1),@$query); | |
104
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
249 @result = grep $keys{$_->nodeName}, @{$nodes}; |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
250 } elsif (ref $query eq 'HASH') { |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
251 while( my ($axis,$filter) = each %$query ) { |
108 | 252 push @result, $this->selectNodesAxis($filter,$axis); |
104
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
253 } |
49 | 254 } elsif (defined $query) { |
104
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
255 @result = grep $_->nodeName eq $query, @{$nodes}; |
49 | 256 } else { |
104
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
257 return wantarray ? @{$nodes} : $nodes; |
49 | 258 } |
259 | |
260 return wantarray ? @result : \@result; | |
261 } | |
262 | |
104
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
263 sub selectParent { |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
264 my ($this) = @_; |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
265 |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
266 if ($this->parentNode) { |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
267 return wantarray ? $this->parentNode : [$this->parentNode]; |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
268 } else { |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
269 return wantarray ? () : []; |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
270 } |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
271 } |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
272 |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
273 sub selectSiblings { |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
274 my ($this) = @_; |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
275 |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
276 if ($this->parentNode) { |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
277 return $this->parentNode->selectNodes( sub { $_ != $this } ); |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
278 } else { |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
279 return wantarray ? () : []; |
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 } |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
282 |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
283 sub selectDocument { |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
284 my ($this) = @_; |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
285 |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
286 if ($this->document) { |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
287 return wantarray ? $this->document : [$this->document]; |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
288 } else { |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
289 return wantarray ? () : []; |
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 } |
196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
wizard
parents:
102
diff
changeset
|
292 |
49 | 293 sub firstChild { |
294 @_ >=2 ? $_[0]->replaceNodeAt(0,$_[1]) : $_[0]->childNodes->[0]; | |
295 } | |
296 | |
297 sub _getIsComplex { | |
298 $_[0]->childNodes->Count ? 1 : 0; | |
299 } | |
300 | |
301 sub _updateDocRefs { | |
302 my ($this) = @_; | |
303 | |
304 # this method is called by the parent node on his children, so we need no to check parent | |
305 $this->{$document} = $this->{$parentNode}->document; | |
306 | |
307 # prevent cyclic | |
308 weaken($this->{$document}) if $this->{$document}; | |
309 | |
310 $_->_updateDocRefs foreach @{$this->{$childNodes}}; | |
311 } | |
312 | |
313 sub _setParent { | |
314 my ($this,$node) = @_; | |
315 | |
316 | |
317 if (($node || 0) != ($this->{$parentNode} || 0)) { | |
318 my $newOwner; | |
319 if ($node) { | |
320 $this->{$parentNode} = $node; | |
321 $newOwner = $node->document || 0; | |
322 | |
323 # prevent from creating cyclicreferences | |
324 weaken($this->{$parentNode}); | |
325 | |
326 } else { | |
327 delete $this->{$parentNode}; | |
75 | 328 |
329 #keep document | |
330 $newOwner = $this->{$document}; | |
49 | 331 } |
332 | |
333 if (($this->{$document}||0) != $newOwner) { | |
334 $this->{$document} = $newOwner; | |
335 weaken($this->{$document}) if $newOwner; | |
336 $_->_updateDocRefs foreach @{$this->childNodes}; | |
337 } | |
338 } | |
339 } | |
340 | |
341 sub text { | |
342 my ($this) = @_; | |
343 | |
344 join ('', $this->nodeValue || '', map ($_->text || '', @{$this->childNodes})); | |
345 } | |
346 | |
347 sub nodeProperty { | |
348 my $this = shift; | |
349 my $name = shift; | |
350 | |
122 | 351 if (my $method = $this->can($name)) { |
352 return &$method($this,@_); | |
353 } | |
354 | |
49 | 355 if (@_) { |
122 | 356 # set |
357 return $this->{$_propertyMap}{$name} = shift; | |
358 } else { | |
359 return $this->{$_propertyMap}{$name}; | |
49 | 360 } |
361 } | |
362 | |
122 | 363 sub listProperties { |
364 my ($this) = @_; | |
365 | |
366 my %props = map {$_->Name, 1} $this->get_meta(typeof IMPL::Class::PropertyInfo, sub { $_->Attributes->{domProperty}},1); | |
367 | |
368 return (keys %props,keys %{$this->{$_propertyMap}}); | |
369 } | |
370 | |
49 | 371 sub qname { |
372 $_[0]->{$nodeName}; | |
373 } | |
374 | |
375 sub path { | |
376 my ($this) = @_; | |
377 | |
378 if ($this->parentNode) { | |
379 return $this->parentNode->path.'.'.$this->qname; | |
380 } else { | |
381 return $this->qname; | |
382 } | |
383 } | |
384 | |
385 1; | |
75 | 386 |
387 __END__ | |
388 | |
389 =pod | |
390 | |
391 =head1 NAME | |
392 | |
393 C<IMPL::DOM::Node> Элемент DOM модели | |
394 | |
395 =head1 DESCRIPTION | |
396 | |
397 Базовый узел DOM модели. От него можно наследовать другие элементы DOM модели. | |
398 | |
399 =head1 MEMBERS | |
400 | |
401 =head2 PROPERTIES | |
402 | |
403 =over | |
404 | |
405 =item C<[get] nodeName> | |
406 | |
407 Имя узла. Задается при создании. | |
408 | |
409 =item C<[get] document> | |
410 | |
411 Документ к которому принадлежит узел. Задается при поздании узла. | |
412 | |
413 =item C<[get] isComplex> | |
414 | |
415 Определяет является ли узел сложным (тоесть есть ли дети). | |
416 | |
417 C<true> - есть, C<false> - нет. | |
418 | |
419 =item C<[get,set] nodeValue> | |
420 | |
421 Значение узла, обычно простой скаляр, но ничто не мешает туда | |
422 устанавливать любое значение. | |
423 | |
424 =item C<[get,list] childNodes> | |
425 | |
426 Список детей, является списокм C<IMPL::Object::List>. | |
427 | |
428 =item C<[get] parentNode> | |
429 | |
430 Ссылка на родительский элемент, если таковой имеется. | |
431 | |
432 =head2 METHODS | |
433 | |
434 =cut |