comparison Lib/IMPL/DOM/Node.pm @ 104:196bf443b5e1

DOM::Schema RC0 inflators support, validation and some other things, Minor and major fixes almost for everything. A 'Source' property of the ValidationErrors generated from a NodeSet or a NodeList is subject to change in the future.
author wizard
date Tue, 11 May 2010 02:42:59 +0400
parents cf3b6ef2be22
children c6fb6964de4c
comparison
equal deleted inserted replaced
103:c289ed9662ca 104:196bf443b5e1
19 public _direct property childNodes => { get => \&_getChildNodes }; # prop_list 19 public _direct property childNodes => { get => \&_getChildNodes }; # prop_list
20 public _direct property parentNode => prop_get ; 20 public _direct property parentNode => prop_get ;
21 private _direct property _propertyMap => prop_all ; 21 private _direct property _propertyMap => prop_all ;
22 } 22 }
23 23
24 our %Axes = (
25 parent => \&selectParent,
26 siblings => \&selectSiblings,
27 child => \&childNodes,
28 document => \&selectDocument
29 );
30
24 sub CTOR { 31 sub CTOR {
25 my ($this,%args) = @_; 32 my ($this,%args) = @_;
26 33
27 $this->{$nodeName} = delete $args{nodeName} or die new IMPL::InvalidArgumentException("A name is required"); 34 $this->{$nodeName} = delete $args{nodeName} or die new IMPL::InvalidArgumentException("A name is required");
28 $this->{$nodeValue} = delete $args{nodeValue} if exists $args{nodeValue}; 35 $this->{$nodeValue} = delete $args{nodeValue} if exists $args{nodeValue};
168 $this->{$childNodes} = @newSet ? bless \@newSet ,'IMPL::Object::List' : undef; 175 $this->{$childNodes} = @newSet ? bless \@newSet ,'IMPL::Object::List' : undef;
169 176
170 return wantarray ? @result : \@result; 177 return wantarray ? @result : \@result;
171 } 178 }
172 179
180 sub resolveAxis {
181 my ($this,$axis) = @_;
182 return $Axes{$axis}->($this)
183 }
184
173 sub selectNodes { 185 sub selectNodes {
174 my ($this,$query) = @_; 186 my ($this,$query,$axis) = @_;
187
188 $axis ||= 'child';
189
190 die new IMPL::InvalidOperationException('Unknown axis',$axis) unless exists $Axes{$axis};
191
192 my $nodes = $this->resolveAxis($axis);
175 193
176 my @result; 194 my @result;
177 195
178 if (ref $query eq 'CODE') { 196 if (ref $query eq 'CODE') {
179 @result = grep &$query($_), @{$this->childNodes}; 197 @result = grep &$query($_), @{$nodes};
180 } elsif (ref $query eq 'ARRAY' ) { 198 } elsif (ref $query eq 'ARRAY' ) {
181 my %keys = map (($_,1),@$query); 199 my %keys = map (($_,1),@$query);
182 @result = grep $keys{$_->nodeName}, @{$this->childNodes}; 200 @result = grep $keys{$_->nodeName}, @{$nodes};
201 } elsif (ref $query eq 'HASH') {
202 while( my ($axis,$filter) = each %$query ) {
203 push @result, $this->selectNodes($filter,$axis);
204 }
183 } elsif (defined $query) { 205 } elsif (defined $query) {
184 @result = grep $_->nodeName eq $query, @{$this->childNodes}; 206 @result = grep $_->nodeName eq $query, @{$nodes};
185 } else { 207 } else {
186 if (wantarray) { 208 return wantarray ? @{$nodes} : $nodes;
187 return @{$this->childNodes};
188 } else {
189 @result = $this->childNodes;
190 return \@result;
191 }
192 } 209 }
193 210
194 return wantarray ? @result : \@result; 211 return wantarray ? @result : \@result;
212 }
213
214 sub selectPath {
215 my ($this,$path) = @_;
216
217 my @set = ($this);
218
219 while (my $query = shift @$path) {
220 @set = map $_->selectNodes($query), @set;
221 }
222
223 return wantarray ? @set : \@set;
224 }
225
226 sub selectParent {
227 my ($this) = @_;
228
229 if ($this->parentNode) {
230 return wantarray ? $this->parentNode : [$this->parentNode];
231 } else {
232 return wantarray ? () : [];
233 }
234 }
235
236 sub selectSiblings {
237 my ($this) = @_;
238
239 if ($this->parentNode) {
240 return $this->parentNode->selectNodes( sub { $_ != $this } );
241 } else {
242 return wantarray ? () : [];
243 }
244 }
245
246 sub selectDocument {
247 my ($this) = @_;
248
249 if ($this->document) {
250 return wantarray ? $this->document : [$this->document];
251 } else {
252 return wantarray ? () : [];
253 }
195 } 254 }
196 255
197 sub firstChild { 256 sub firstChild {
198 @_ >=2 ? $_[0]->replaceNodeAt(0,$_[1]) : $_[0]->childNodes->[0]; 257 @_ >=2 ? $_[0]->replaceNodeAt(0,$_[1]) : $_[0]->childNodes->[0];
199 } 258 }