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