Mercurial > pub > Impl
changeset 24:7f00786f8210
Первая рабочая реазизация схемы и навигаторов
author | Sergey |
---|---|
date | Mon, 05 Oct 2009 00:48:49 +0400 |
parents | 716b287d4795 |
children | 9dd67fa91ee3 |
files | Lib/IMPL/DOM/Document.pm Lib/IMPL/DOM/Navigator.pm Lib/IMPL/DOM/Navigator/Builder.pm Lib/IMPL/DOM/Navigator/SchemaNavigator.pm Lib/IMPL/DOM/Node.pm Lib/IMPL/DOM/Schema.pm Lib/IMPL/DOM/Schema/AnyNode.pm Lib/IMPL/DOM/Schema/Node.pm Lib/IMPL/DOM/Schema/NodeList.pm Lib/IMPL/DOM/Schema/NodeSet.pm Lib/IMPL/DOM/Schema/Property.pm Lib/IMPL/DOM/Schema/SwitchNode.pm Lib/IMPL/DOM/Schema/ValidationError.pm Lib/IMPL/Object/Abstract.pm _test/Test/DOM/Navigator.pm _test/Test/DOM/Node.pm _test/Test/DOM/Schema.pm |
diffstat | 17 files changed, 616 insertions(+), 98 deletions(-) [+] |
line wrap: on
line diff
--- a/Lib/IMPL/DOM/Document.pm Wed Sep 30 17:43:52 2009 +0400 +++ b/Lib/IMPL/DOM/Document.pm Mon Oct 05 00:48:49 2009 +0400 @@ -11,6 +11,8 @@ $refProps ||= {}; + delete $refProps->{nodeName}; + return $class->new( nodeName => $nodeName, %$refProps
--- a/Lib/IMPL/DOM/Navigator.pm Wed Sep 30 17:43:52 2009 +0400 +++ b/Lib/IMPL/DOM/Navigator.pm Mon Oct 05 00:48:49 2009 +0400 @@ -6,55 +6,206 @@ use IMPL::Class::Property; use IMPL::Class::Property::Direct; BEGIN { - public _direct property Path => prop_get | owner_set; - public _direct property Current => prop_get | owner_set; + private _direct property _path => prop_all; + private _direct property _state => prop_all; + private _direct property _savedstates => prop_all; + public property Current => {get => \&_getCurrent}; } sub CTOR { my ($this,$CurrentNode) = @_; - $this->{$Current} = $CurrentNode or die IMPL::InvalidArgumentException("A starting node is a required paramater"); + die IMPL::InvalidArgumentException("A starting node is a required paramater") unless $CurrentNode; + + $this->{$_state} = { alternatives => [ $CurrentNode ], current => 0 }; +} + +sub _getCurrent { + $_[0]->{$_state}{alternatives}[$_[0]->{$_state}{current}] } sub Navigate { - my ($this,$query) = @_; + my ($this,@path) = @_; + + return unless @path; - if ( my ($newNode) = $this->{$Current}->selectNodes($query) ) { - push @{$this->{$Path}}, $this->{$Current}; - return $this->{$Current} = $newNode; + foreach my $query (@path) { + if (my $current = $this->Current) { + + my @alternatives = $this->Current->selectNodes($query); + + unless (@alternatives) { + $this->advanceNavigator or return undef; + @alternatives = $this->Current->selectNodes($query); + } + + push @{$this->{$_path}},$this->{$_state}; + $this->{$_state} = { + alternatives => \@alternatives, + current => 0, + query => $query + } + } else { + return undef; + } + } + + return $this->Current; +} + +sub selectNodes { + my ($this,@path) = @_; + + return internalSelectNodes($this->Current,@path); +} + +sub internalSelectNodes { + my $node = shift; + my $query = shift; + + if (@_) { + return map internalSelectNodes($_,@_), $node->selectNodes($query); } else { - return undef; + return $node->selectNodes($query); } } -sub _NavigateNode { - my ($this,$newNode) = @_; - push @{$this->{$Path}}, $this->{$Current}; - return $this->{$Current} = $newNode; +sub internalNavigateNodeSet { + my ($this,@nodeSet) = @_; + + push @{$this->{$_path}}, $this->{$_state}; + + $this->{$_state} = { + alternatives => \@nodeSet, + current => 0 + }; + + return $this->Current; +} + +sub fetch { + my ($this) = @_; + + my $result = $this->Current; + $this->advanceNavigator; + return $result; } -sub _NavigateNodeStirct { - my ($this,$newNode) = @_; +sub advanceNavigator { + my ($this) = @_; + + $this->{$_state}{current}++; - die new IMPL::InvalidOperationException("A newNode doesn't belongs to the current") unless $newNode->parentNode == $this->{$Current}; - push @{$this->{$Path}}, $this->{$Current}; - return $this->{$Current} = $newNode; + if (@{$this->{$_state}{alternatives}} <= $this->{$_state}{current}) { + if ( exists $this->{$_state}{query} ) { + my $query = $this->{$_state}{query}; + + $this->Back or return 0; # that meams the end of the history + + undef while ( $this->advanceNavigator and not $this->Navigate($query)); + + return $this->Current ? 1 : 0; + } + return 0; + } + + return 1; +} + +sub doeach { + my ($this,$code) = @_; + local $_; + + do { + for (my $i = $this->{$_state}{current}; $i < @{$this->{$_state}{alternatives}}; $i++) { + $_ = $this->{$_state}{alternatives}[$i]; + $code->(); + } + $this->{$_state}{current} = @{$this->{$_state}{alternatives}}; + } while ($this->advanceNavigator); } sub Back { - my ($this) = @_; + my ($this,$steps) = @_; + + $steps ||= 1; - if ( my $newNode = $this->{$Path} ? pop @{$this->{$Path}} : undef ) { - return $this->{$Current} = $newNode; + if ($this->{$_path} and @{$this->{$_path}}) { + + $steps = @{$this->{$_path}} - 1 if $steps >= @{$this->{$_path}}; + + ($this->{$_state}) = splice @{$this->{$_path}},-$steps; + + $this->Current; } else { return undef; } } sub PathToString { - my $this = shift; + my ($this,$delim) = @_; + + $delim ||= '/'; + + join($delim,map $_->{alternatives}[$_->{current}]->nodeName, $this->{$_path} ? (@{$this->{$_path}}, $this->{$_state}) : $this->{$_state}); +} + +sub clone { + my ($this) = @_; + + my $newNavi = __PACKAGE__->surrogate; + + $newNavi->{$_path} = [ map { { %{ $_ } } } @{$this->{$_path}} ] if $this->{$_path}; + $newNavi->{$_state} = { %{$this->{$_state}} }; + + return $newNavi; + +} + +sub saveState { + my ($this) = @_; + + my %state; + + $state{path} = [ map { { %{ $_ } } } @{$this->{$_path}} ] if $this->{$_path}; + $state{state} = { %{$this->{$_state}} }; - join('/',map $_->nodeName, $this->{$Path} ? (@{$this->{$Path}}, $this->{$Current}) : $this->{$Current}); + push @{$this->{$_savedstates}}, \%state; +} + +sub restoreState { + my ($this) = @_; + + if ( my $state = pop @{$this->{$_savedstates}||[]} ) { + $this->{$_path} = $state->{path}; + $this->{$_state} = $state->{state}; + } +} + +sub applyState { + my ($this) = @_; + + pop @{$this->{$_savedstates}||[]}; +} + +sub dosafe { + my ($this,$transaction) = @_; + + $this->saveState(); + + my $result; + + eval { + $result = $transaction->(); + }; + + if ($@) { + $this->restoreState(); + return undef; + } else { + $this->applyState(); + return $result; + } } 1; @@ -66,6 +217,11 @@ DOM . + (). + + , , + . + =head1 METHODS =over @@ -74,7 +230,7 @@ . -=item C<$obj->Navigate($query)> +=item C<$obj->Navigate([$query,...])> C<$query>. .
--- a/Lib/IMPL/DOM/Navigator/Builder.pm Wed Sep 30 17:43:52 2009 +0400 +++ b/Lib/IMPL/DOM/Navigator/Builder.pm Mon Oct 05 00:48:49 2009 +0400 @@ -5,9 +5,10 @@ use base qw(IMPL::DOM::Navigator); use IMPL::Class::Property; use IMPL::Class::Property::Direct; +require IMPL::DOM::Navigator::SchemaNavigator; BEGIN { - protected _direct property _navigatorSchema => prop_all; + protected _direct property _schemaNavi => prop_all; public _direct property Document => prop_get | owner_set; } @@ -19,30 +20,18 @@ my ($this,$domDocument,$schema) = @_; $this->{$Document} = $domDocument; - $this->{$_navigatorSchema} = new IMPL::DOM::Navigator($schema); + $this->{$_schemaNavi} = $schema; } sub NavigateCreate { my ($this,$nodeName,%props) = @_; - if ( my $nodeSchema = $this->{$_navigatorSchema}->Navigate(sub { $_[0]->nodeName eq $nodeName or $_[0]->isa('IMPL::DOM::Schema::AnyNode') }) ) { - my $class = delete $props{type} || $nodeSchema->type || $nodeName; - - my $node = $this->{$Document}->Create(delete $props{nodeName} || $nodeName, $class, \%props); - - $this->Current()->appendNode($node); - $this->Current($node); - - } else { - die new IMPL::InvalidOperationException("Requested elemnt not found in the schema"); - } + } sub Back { my ($this) = @_; - $this->{$_navigatorSchema}->Back; - return $this->SUPER::Back(); } 1;
--- a/Lib/IMPL/DOM/Navigator/SchemaNavigator.pm Wed Sep 30 17:43:52 2009 +0400 +++ b/Lib/IMPL/DOM/Navigator/SchemaNavigator.pm Mon Oct 05 00:48:49 2009 +0400 @@ -6,10 +6,15 @@ use IMPL::Class::Property; use IMPL::Class::Property::Direct; +require IMPL::DOM::Schema::ComplexType; +require IMPL::DOM::Schema::NodeSet; +require IMPL::DOM::Schema::AnyNode; + __PACKAGE__->PassThroughArgs; BEGIN { public _direct property Schema => prop_get; + private _direct property _historySteps => prop_all; } sub CTOR { @@ -20,19 +25,72 @@ die new IMPL::InvalidArgumentException("A schema object is required") unless $schema->isa('IMPL::DOM::Schema'); } -sub Navigate { - my ($this,$query) = @_; +my $schemaAnyNode = IMPL::DOM::Schema::ComplexType->new(type => '::AnyNodeType', nativeType => 'IMPL::DOM::ComplexNode')->appendRange( + IMPL::DOM::Schema::NodeSet->new()->appendRange( + IMPL::DOM::Schema::AnyNode->new() + ) +); + +sub NavigateName { + my ($this,$name) = @_; - if (my ($newNode) = $this->Current->selectNodes($query)) { - if (ref $newNode eq 'IMPL::DOM::Schema::Node') { - $newNode = $this->{$Schema}->ResolveType($newNode->type) || $newNode; + # perform a safe navigation + return dosafe $this sub { + my $steps = 1; + # navigate to node + if ( + my $node = $this->Navigate( sub { + $_->isa('IMPL::DOM::Schema::Node') and ( + $_->name eq $name + or + $_->nodeName eq 'AnyNode' + or + ( $_->nodeName eq 'SwitchNode' and $_->selectNodes( sub { $_->name eq $name } ) ) + ) + }) + ) { + if ($node->nodeName eq 'AnyNode') { + # if we navigate to the anynode + # assume it to be ComplexType by default + $node = $node->type ? $this->{$Schema}->resolveType($node->type) : $schemaAnyNode; + } elsif ($node->nodeName eq 'SwitchNode') { + # if we are in the switchnode + # navigate to the target node + $node = $this->Navigate(sub { $_->name eq $name }); + $steps ++; + } + + if ($node->nodeName eq 'Node') { + # if we navigate to a reference + # resolve it + $node = $this->{$Schema}->resolveType($node->type); + $this->internalNavigateNodeSet($node); + $steps++; + } + + # if target node is a complex node + if ($node->isa('IMPL::DOM::Schema::ComplexNode')) { + # navigate to it's content + $this->internalNavigateNodeSet($node->content); + $steps ++; + } + + push @{$this->{$_historySteps}},$steps; + + # return found node schema + return $node; + } else { + die; # abort navigation } - return $this->_NavigateNode($newNode); - } else { - return undef; } } +sub SchemaBack { + my ($this) = @_; + + $this->Back(pop @{$this->{$_historySteps}}) if $this->{$_historySteps}; +} + 1; __END__ @@ -40,7 +98,23 @@ =head1 DESCRIPTION - , , <Node nodeName="SomeName" type="ReferencedType"/>. - . + , + . + +=head1 METHODS + +=over + +=item C<< $navi->NavigateName($name) >> + + . C<name> + +=item C<< $navi->SchemaBack >> + + C<NavigateName>. + + . + +=back =cut \ No newline at end of file
--- a/Lib/IMPL/DOM/Node.pm Wed Sep 30 17:43:52 2009 +0400 +++ b/Lib/IMPL/DOM/Node.pm Mon Oct 05 00:48:49 2009 +0400 @@ -167,6 +167,9 @@ if (ref $query eq 'CODE') { @result = grep &$query($_), @{$this->childNodes}; + } elsif (ref $query eq 'ARRAY' ) { + my %keys = map (($_,1),@$query); + @result = grep $keys{$_->nodeName}, @{$this->childNodes}; } elsif (defined $query) { @result = grep $_->nodeName eq $query, @{$this->childNodes}; } else { @@ -246,4 +249,18 @@ } } +sub qname { + $_[0]->{$nodeName}; +} + +sub path { + my ($this) = @_; + + if ($this->parentNode) { + return $this->parentNode->path.'.'.$this->qname; + } else { + return $this->qname; + } +} + 1;
--- a/Lib/IMPL/DOM/Schema.pm Wed Sep 30 17:43:52 2009 +0400 +++ b/Lib/IMPL/DOM/Schema.pm Mon Oct 05 00:48:49 2009 +0400 @@ -10,12 +10,16 @@ require IMPL::DOM::Schema::AnyNode; require IMPL::DOM::Schema::NodeList; require IMPL::DOM::Schema::NodeSet; +require IMPL::DOM::Schema::Property; +require IMPL::DOM::Schema::SwitchNode; use base qw(IMPL::DOM::Document); use IMPL::Class::Property; use IMPL::Class::Property::Direct; -__PACKAGE__->PassThroughArgs; +our %CTOR = ( + 'IMPL::DOM::Document' => sub { nodeName => 'schema' } +); BEGIN { private _direct property _TypesMap => prop_all; @@ -28,7 +32,7 @@ sub Process { my ($this) = @_; - $this->{$_TypesMap} = { map { $_->type, $_ } grep {$_->isa('IMPL::DOM::Schema::Type')} @{$this->childNodes} }; + $this->{$_TypesMap} = { map { $_->type, $_ } $this->selectNodes(sub { $_[0]->nodeName eq 'ComplexType' || $_[0]->nodeName eq 'SimpleType' } ) }; } sub Validate { @@ -37,7 +41,7 @@ if ( my ($schemaNode) = $this->selectNodes(sub { $_[0]->name eq $node->nodeName })) { $schemaNode->Validate($node); } else { - return IMPL::DOM::Schema::VaidationError(Message=> "A specified document doesn't match the schema"); + return IMPL::DOM::Schema::ValidationError(Message=> "A specified document doesn't match the schema"); } } @@ -47,7 +51,7 @@ return $schema if $schema; - $schema = new IMPL::DOM::Schema(nodeName => 'schema'); + $schema = new IMPL::DOM::Schema; $schema->appendRange( IMPL::DOM::Schema::ComplexNode->new(name => 'schema')->appendRange( @@ -57,7 +61,9 @@ IMPL::DOM::Schema::Node->new(name => 'SimpleNode', type => 'SimpleNode', minOccur => 0, maxOccur=>'unbounded'), IMPL::DOM::Schema::Node->new(name => 'SimpleType', type => 'SimpleType', minOccur => 0, maxOccur=>'unbounded'), IMPL::DOM::Schema::SimpleNode->new(name => 'Node', minOccur => 0, maxOccur=>'unbounded'), - IMPL::DOM::Schema::SimpleNode->new(name => 'Include', minOccur => 0, maxOccur=>'unbounded') + IMPL::DOM::Schema::SimpleNode->new(name => 'Include', minOccur => 0, maxOccur=>'unbounded')->appendRange( + IMPL::DOM::Schema::Property->new(name => 'source') + ) ), ), IMPL::DOM::Schema::ComplexType->new(type => 'NodeSet', nativeType => 'IMPL::DOM::Schema::NodeSet')->appendRange( @@ -65,28 +71,45 @@ IMPL::DOM::Schema::Node->new(name => 'ComplexNode', type => 'ComplexNode', minOccur => 0, maxOccur=>'unbounded'), IMPL::DOM::Schema::Node->new(name => 'SimpleNode', type => 'SimpleNode', minOccur => 0, maxOccur=>'unbounded'), IMPL::DOM::Schema::SimpleNode->new(name => 'Node', minOccur => 0, maxOccur=>'unbounded'), + IMPL::DOM::Schema::SwitchNode->new(minOccur => 0, maxOccur => 1)->appendRange( + IMPL::DOM::Schema::SimpleNode->new(name => 'AnyNode'), + IMPL::DOM::Schema::Node->new(name => 'SwitchNode',type => 'SwitchNode') + ) + ) + ), + IMPL::DOM::Schema::ComplexType->new(type => 'SwitchNode', nativeType => 'IMPL::DOM::Schema::SwitchNode')->appendRange( + IMPL::DOM::Schema::NodeSet->new()->appendRange( + IMPL::DOM::Schema::Node->new(name => 'ComplexNode', type=>'ComplexNode', minOccur => 0, maxOccur=>'unbounded'), + IMPL::DOM::Schema::Node->new(name => 'SimpleNode', type=>'SimpleNode', minOccur => 0, maxOccur=>'unbounded'), + IMPL::DOM::Schema::SimpleNode->new(name => 'Node', minOccur => 0, maxOccur=>'unbounded'), ) ), IMPL::DOM::Schema::ComplexType->new(type => 'NodeList', nativeType => 'IMPL::DOM::Schema::NodeList')->appendRange( IMPL::DOM::Schema::NodeSet->new()->appendRange( IMPL::DOM::Schema::Node->new(name => 'ComplexNode', type => 'ComplexNode', minOccur => 0, maxOccur=>'unbounded'), IMPL::DOM::Schema::Node->new(name => 'SimpleNode', type => 'SimpleNode', minOccur => 0, maxOccur=>'unbounded'), + IMPL::DOM::Schema::Node->new(name => 'SwitchNode',type => 'SwitchNode', minOccur => 0, maxOccur=>'unbounded'), IMPL::DOM::Schema::SimpleNode->new(name => 'Node', minOccur => 0, maxOccur=>'unbounded'), + IMPL::DOM::Schema::SimpleNode->new(name => 'AnyNode', minOccur => 0, maxOccur=>'unbounded'), ) ), IMPL::DOM::Schema::ComplexType->new(type => 'ComplexType', nativeType => 'IMPL::DOM::Schema::ComplexType')->appendRange( IMPL::DOM::Schema::NodeList->new()->appendRange( - IMPL::DOM::Schema::Node->new(name => 'NodeSet', minOccur => 0, type => 'NodeSet'), - IMPL::DOM::Schema::Node->new(name => 'NodeList', minOccur => 0, type => 'NodeSet'), - IMPL::DOM::Schema::SimpleNode->new(name => 'Node', minOccur => 0, maxOccur => 'unbounded') + IMPL::DOM::Schema::SwitchNode->new()->appendRange( + IMPL::DOM::Schema::Node->new(name => 'NodeSet', type => 'NodeSet'), + IMPL::DOM::Schema::Node->new(name => 'NodeList',type => 'NodeList'), + ), + IMPL::DOM::Schema::AnyNode->new(maxOccur => 'unbounded', minOccur => 0) ), new IMPL::DOM::Schema::Property(name => 'type') ), IMPL::DOM::Schema::ComplexType->new(type => 'ComplexNode', nativeType => 'IMPL::DOM::Schema::ComplexNode')->appendRange( IMPL::DOM::Schema::NodeList->new()->appendRange( - IMPL::DOM::Schema::Node->new(name => 'NodeSet', minOccur => 0, type => 'NodeSet'), - IMPL::DOM::Schema::Node->new(name => 'NodeList', minOccur => 0, type => 'NodeSet'), - IMPL::DOM::Schema::SimpleNode->new(name => 'Node', minOccur => 0, maxOccur => 'unbounded') + IMPL::DOM::Schema::SwitchNode->new()->appendRange( + IMPL::DOM::Schema::Node->new(name => 'NodeSet', type => 'NodeSet'), + IMPL::DOM::Schema::Node->new(name => 'NodeList',type => 'NodeList'), + ), + IMPL::DOM::Schema::AnyNode->new(maxOccur => 'unbounded', minOccur => 0) ), new IMPL::DOM::Schema::Property(name => 'name') ),
--- a/Lib/IMPL/DOM/Schema/AnyNode.pm Wed Sep 30 17:43:52 2009 +0400 +++ b/Lib/IMPL/DOM/Schema/AnyNode.pm Mon Oct 05 00:48:49 2009 +0400 @@ -5,7 +5,13 @@ use base qw(IMPL::DOM::Schema::Node); our %CTOR = ( - 'IMPL::DOM::Schema::Node' => sub { nodeName => 'AnyNode', name=> 'AnyNode'} + 'IMPL::DOM::Schema::Node' => sub { + my %args = @_; + $args{nodeName} ||= 'AnyNode'; + $args{name} = '::any'; + + %args; + } ); 1; @@ -17,9 +23,20 @@ =head1 DESCRIPTION , - . , - , - , - . + . + + C<IMPL::DOM::Schema::NodeSet> + C<IMPL::DOM::Schema::SwitchNode>. + + <IMPL::DOM::Schema::NodeList> + . + +<NodeList> + <SimpleNode name="firstName"/> + <SimpleNode name="age"/> + <AnyNode type="Notes" minOccur="0" maxOccur="unbounded"/> + <Node name="primaryAddress" type="Address"/> + <AnyNode/> +</NodeList> =cut \ No newline at end of file
--- a/Lib/IMPL/DOM/Schema/Node.pm Wed Sep 30 17:43:52 2009 +0400 +++ b/Lib/IMPL/DOM/Schema/Node.pm Mon Oct 05 00:48:49 2009 +0400 @@ -8,10 +8,10 @@ use IMPL::Class::Property::Direct; BEGIN { - public property minOccur => prop_all; - public property maxOccur => prop_all; - public property type => prop_all; - public property name => prop_all; + public _direct property minOccur => prop_all; + public _direct property maxOccur => prop_all; + public _direct property type => prop_all; + public _direct property name => prop_all; } our %CTOR = ( @@ -21,22 +21,26 @@ sub CTOR { my ($this,%args) = @_; - $this->minOccur(defined $args{minOccur} ? $args{minOccur} : 1); - $this->maxOccur(defined $args{maxOccur} ? $args{maxOccur} : 1); - $this->type($args{type}); - $this->name($args{name}) or die new IMPL::InvalidArgumentException('Argument is required','name'); + $this->{$minOccur} = defined $args{minOccur} ? $args{minOccur} : 1; + $this->{$maxOccur} = defined $args{maxOccur} ? $args{maxOccur} : 1; + $this->{$type} = $args{type}; + $this->{$name} = $args{name} or die new IMPL::InvalidArgumentException('Argument is required','name'); } sub Validate { my ($this,$node) = @_; - if (my $schemaType = $this->type ? $this->rootNode->resolveType($this->type) : undef ) { + if (my $schemaType = $this->{$type} ? $this->rootNode->resolveType($this->{$type}) : undef ) { return $schemaType->Validate($node); } else { return (); } } +sub qname { + $_[0]->nodeName.'[name='.$_[0]->{$name}.']'; +} + 1; __END__
--- a/Lib/IMPL/DOM/Schema/NodeList.pm Wed Sep 30 17:43:52 2009 +0400 +++ b/Lib/IMPL/DOM/Schema/NodeList.pm Mon Oct 05 00:48:49 2009 +0400 @@ -18,15 +18,15 @@ sub CTOR { my ($this,%args) = @_; - $this->messageUnexpected($args{messageUnexpected} || 'A %Node.nodeName% isn\'t allowed here'); - $this->messageNodesRequired($args{messageNodesRequired} || 'A content of the node %Node.nodeName% is incomplete'); + $this->messageUnexpected($args{messageUnexpected} || 'A %Node.nodeName% isn\'t allowed in %Node.parentNode.path%'); + $this->messageNodesRequired($args{messageNodesRequired} || 'A %Schema.name% is required in the node %Node.path%'); } sub Validate { my ($this,$node) = @_; my @nodes = map { - {nodeName => $_->name, anyNode => $_->isa('IMPL::DOM::Schema::AnyNode') , Schema => $_, Min => $_->minOccur eq 'unbounded' ? undef : $_->maxOccur, Max => $_->maxOccur, Seen => 0 } + {nodeName => $_->name, anyNode => $_->isa('IMPL::DOM::Schema::AnyNode') , Schema => $_, Max => $_->maxOccur eq 'unbounded' ? undef : $_->maxOccur, Min => $_->minOccur, Seen => 0 } } @{$this->childNodes}; my $info = shift @nodes; @@ -35,7 +35,7 @@ #skip schema elements while ($info and not $info->{anyNode} and $info->{nodeName} ne $child->nodeName) { # if possible of course :) - return new IMPL::DOM::Schema::VaidationError ( + return new IMPL::DOM::Schema::ValidationError ( Message => $this->messageUnexpected, Node => $child, Schema => $info->{Schema}, @@ -46,40 +46,48 @@ } # return error if no more children allowed - return new IMPL::DOM::Schema::VaidationError ( + return new IMPL::DOM::Schema::ValidationError ( Message => $this->messageUnexpected, Node => $child, Source => $this ) unless $info; - # it's ok, we found schema element for him + # it's ok, we found schema element for child + # but it may be any node or switching node wich would not satisfy current child + + # validate + while (my @errors = $info->{Schema}->Validate($child)) { + if( $info->{anyNode} and $info->{Seen} >= $info->{Min} ) { + # in case of any or switch node, skip it if possible + next if $info = shift @nodes; + } + return @errors; + } + $info->{Seen}++; # check count limits - return new IMPL::DOM::Schema::VaidationError ( + return new IMPL::DOM::Schema::ValidationError ( Error => 1, Message => $this->messageUnexpected, Node => $child, Source => $this, ) if $info->{Max} and $info->{Seen} > $info->{Max}; - - # validate - if (my @errors = $info->{Schema}->Validate($child)) { - return @errors; - } } # no more children left (but may be should :) while ($info) { - return new IMPL::DOM::Schema::VaidationError ( + return new IMPL::DOM::Schema::ValidationError ( Error => 1, Message => $this->messageNodesRequired, Node => $node, - Source => $this + Source => $this, + Schema => $info->{Schema} ) if $info->{Seen} < $info->{Min}; $info = shift @nodes; } + return; } 1;
--- a/Lib/IMPL/DOM/Schema/NodeSet.pm Wed Sep 30 17:43:52 2009 +0400 +++ b/Lib/IMPL/DOM/Schema/NodeSet.pm Mon Oct 05 00:48:49 2009 +0400 @@ -20,7 +20,7 @@ $this->messageMax( $args{messageMax} || 'Too many %Node.nodeName% nodes'); $this->messageMin( $args{messageMin} || '%Schema.name% nodes expected'); - $this->messageUnexpected( $args{messageUnexpected} || 'A %Node.nodeName% isn\'t allowed here'); + $this->messageUnexpected( $args{messageUnexpected} || 'A %Node.nodeName% isn\'t allowed in %Node.parentNode.path%'); } sub Validate { @@ -41,7 +41,7 @@ foreach my $child ( @{$node->childNodes} ) { if (my $info = $nodes{$child->nodeName} || $anyNode) { $info->{Seen}++; - push @errors,new IMPL::DOM::Schema::VaidationError ( + push @errors,new IMPL::DOM::Schema::ValidationError ( Source => $this, Node => $child, Schema => $info->{Schema}, @@ -52,7 +52,7 @@ push @errors,@localErrors; } } else { - push @errors, new IMPL::DOM::Schema::VaidationError ( + push @errors, new IMPL::DOM::Schema::ValidationError ( Source => $this, Node => $child, Schema => $info->{Schema}, @@ -62,7 +62,7 @@ } foreach my $info (values %nodes) { - push @errors, new IMPL::DOM::Schema::VaidationError ( + push @errors, new IMPL::DOM::Schema::ValidationError ( Source => $this, Schema => $info->{Schema}, Node => $node,
--- a/Lib/IMPL/DOM/Schema/Property.pm Wed Sep 30 17:43:52 2009 +0400 +++ b/Lib/IMPL/DOM/Schema/Property.pm Mon Oct 05 00:48:49 2009 +0400 @@ -13,8 +13,8 @@ public property RequiredMessage => prop_all; } -our %CTOR = { - 'IMPL::DOM::Schema::SimleNode' => sub { +our %CTOR = ( + 'IMPL::DOM::Schema::SimpleNode' => sub { my %args = @_; $args{maxOccur} = 1; @@ -23,7 +23,7 @@ return %args; } -}; +); sub CTOR { my ($this,%args) = @_; @@ -39,7 +39,7 @@ my $nodeProp = new IMPL::DOM::Node(nodeName => '::property', nodeValue => $node->$prop() || $node->nodePropety($prop)); if (! $nodeProp->nodeValue) { - return new IMPL::DOM::Schema::VaidationError( + return new IMPL::DOM::Schema::ValidationError( Message => ); }
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/DOM/Schema/SwitchNode.pm Mon Oct 05 00:48:49 2009 +0400 @@ -0,0 +1,54 @@ +package IMPL::DOM::Schema::SwitchNode; +use strict; +use warnings; + +use base qw(IMPL::DOM::Schema::AnyNode); +use IMPL::Class::Property; +require IMPL::DOM::Schema::ValidationError; + +our %CTOR = ( + 'IMPL::DOM::Schema::AnyNode' => sub { + my %args = @_; + + $args{nodeName} ||= 'SwitchNode'; + + %args; + } +); + +BEGIN { + public property messageNoMatch => prop_all; +} + +sub CTOR { + my ($this,%args) = @_; + + $this->messageNoMatch($args{messageNoMatch} || 'A node %Node.nodeName% isn\'t expected in the %Node.parentNode.path%'); +} + +sub Validate { + my ($this,$node) = @_; + + if ( my ($schema) = $this->selectNodes(sub {$_[0]->name eq $node->nodeName} ) ) { + return $schema->Validate($node); + } else { + return new IMPL::DOM::Schema::ValidationError( + Node => $node, + Source => $this, + Message => $this->messageNoMatch + ); + } +} + +1; + +__END__ + +=pod + +=head1 DESCRIPTION + + , , . + C<IMPL::DOM::Schema::AnyNode>. + +=cut
--- a/Lib/IMPL/DOM/Schema/ValidationError.pm Wed Sep 30 17:43:52 2009 +0400 +++ b/Lib/IMPL/DOM/Schema/ValidationError.pm Mon Oct 05 00:48:49 2009 +0400 @@ -1,4 +1,4 @@ -package IMPL::DOM::Schema::VaidationError; +package IMPL::DOM::Schema::ValidationError; use strict; use warnings;
--- a/Lib/IMPL/Object/Abstract.pm Wed Sep 30 17:43:52 2009 +0400 +++ b/Lib/IMPL/Object/Abstract.pm Mon Oct 05 00:48:49 2009 +0400 @@ -80,6 +80,10 @@ @_; } +sub PassArgs { + \&_pass_throgh_mapper; +} + sub PassThroughArgs { my $class = shift; $class = ref $class || $class;
--- a/_test/Test/DOM/Navigator.pm Wed Sep 30 17:43:52 2009 +0400 +++ b/_test/Test/DOM/Navigator.pm Mon Oct 05 00:48:49 2009 +0400 @@ -5,7 +5,39 @@ use IMPL::Test qw(test failed); use IMPL::DOM::Navigator; +use IMPL::DOM::Navigator::SchemaNavigator; use IMPL::DOM::Node; +use IMPL::DOM::Schema; +use IMPL::Class::Property; + +BEGIN { + public property doc => prop_all; +} + +sub CTOR { + my ($this) = @_; + + $this->doc( + IMPL::DOM::Node->new(nodeName => 'root')->appendRange( + IMPL::DOM::Node->new(nodeName=> 'age', nodeValue => 21), + IMPL::DOM::Node->new(nodeName=> 'address')->appendRange( + IMPL::DOM::Node->new(nodeName=>'city', nodeValue=>'moscow'), + IMPL::DOM::Node->new(nodeName=>'street', nodeValue=>'main'), + IMPL::DOM::Node->new(nodeName=>'phone',nodeValue=>'123-456'), + ), + IMPL::DOM::Node->new(nodeName=> 'address')->appendRange( + IMPL::DOM::Node->new(nodeName=>'city', nodeValue=>'San Francisco'), + IMPL::DOM::Node->new(nodeName=>'street', nodeValue=>'Libertador'), + ), + IMPL::DOM::Node->new(nodeName=> 'contacts')->appendRange( + IMPL::DOM::Node->new(nodeName=>'phone',nodeValue=>'123-123'), + IMPL::DOM::Node->new(nodeName=>'phone',nodeValue=>'1-233-434-34-54'), + IMPL::DOM::Node->new(nodeName=>'email',nodeValue=>'some@mail.none') + ) + + ) + ); +} test Creation => sub { my ($this) = @_; @@ -64,8 +96,66 @@ failed ("Current node has a wrong value","Current: $curr","Expected: $doc") if $doc != $curr; }; +test selectNodes1 => sub { + my ($this) = @_; + + my $navi = new IMPL::DOM::Navigator($this->doc); + my @result = $navi->selectNodes('contacts','phone'); + failed "Expected to get two entries, but got:",map($_->nodeName,@result) unless @result == 2; +}; +test selectNodes2 => sub { + my ($this) = @_; + + my $navi = new IMPL::DOM::Navigator($this->doc); + my @result = $navi->selectNodes(undef,'phone'); + failed "Expected to get three entries, but got:",map($_->nodeName,@result) unless @result == 3; +}; +test FetchDoeachState => sub { + my ($this) = @_; + + my $navi = new IMPL::DOM::Navigator($this->doc); + + $navi->Navigate(undef,'phone'); + + $navi->saveState(); + + my @result; + doeach $navi sub { + push @result,$_; + }; + + failed "Expected to get three nodes, but got: ", map($_->nodeName,@result) unless @result == 3; + + $navi->restoreState(); + @result = (); + + push @result, $_ while fetch $navi; + + failed "Expected to get three nodes, but got: ", map($_->nodeName,@result) unless @result == 3; +}; + +test NavigateSchema => sub { + my $navi = new IMPL::DOM::Navigator::SchemaNavigator(IMPL::DOM::Schema->MetaSchema); + + my $root = $navi->NavigateName('schema') or failed "Failed to navigate to the root element"; + + $navi->saveState; + $navi->NavigateName('Node') or failed "Failed to navigate to a simple node"; + $navi->restoreState; + + failed "Can't navigate from simple node" if $navi->NavigateName('Property'); + + $navi->NavigateName('ComplexType') or failed "Failed to navigate to a complex node"; + $navi->NavigateName('NodeSet') or failed "Failed to navigate to NodeSet"; + $navi->SchemaBack(); + $navi->NavigateName('NodeList') or failed "Failed to navigate to NodeList"; + $navi->NavigateName('SimpleNode') or failed "Failed to navigate to SimpleNode"; + $navi->NavigateName('Enum') or failed "Failed to navigate to Enum"; + $navi->NavigateName('Item') or failed "Failed to navigate to Item"; + +}; 1;
--- a/_test/Test/DOM/Node.pm Wed Sep 30 17:43:52 2009 +0400 +++ b/_test/Test/DOM/Node.pm Mon Oct 05 00:48:49 2009 +0400 @@ -86,7 +86,7 @@ test SelectNodesByQuery => sub { my ($this) = @_; - my @result = $this->Root->selectNodes(sub { $_[0]->nodeName =~ /child/i } ); + my @result = $this->Root->selectNodes(sub { $_->nodeName =~ /child/i } ); failed "Wrong number of a selected nodes", "Expected: 2",
--- a/_test/Test/DOM/Schema.pm Wed Sep 30 17:43:52 2009 +0400 +++ b/_test/Test/DOM/Schema.pm Mon Oct 05 00:48:49 2009 +0400 @@ -3,12 +3,17 @@ use warnings; use base qw(IMPL::Test::Unit); -use IMPL::Test qw(test failed); +use IMPL::Test qw(test failed shared); +use IMPL::Class::Property; __PACKAGE__->PassThroughArgs; require IMPL::DOM::Schema; +BEGIN { + shared public property SampleSchema => prop_all; +} + test GetMetaSchema => sub { my $metaSchema = IMPL::DOM::Schema->MetaSchema(); }; @@ -21,4 +26,79 @@ } }; +test VerifyCorrectSchema => sub { + my ($this) = @_; + my $metaSchema = IMPL::DOM::Schema->MetaSchema(); + + my $schema = new IMPL::DOM::Schema; + $schema->appendRange( + IMPL::DOM::Schema::ComplexNode->new( name => 'personInfo' )->appendRange( + IMPL::DOM::Schema::NodeSet->new()->appendRange( + new IMPL::DOM::Schema::SimpleNode( name => 'firstName' ), + new IMPL::DOM::Schema::SimpleNode( name => 'lastName' ), + new IMPL::DOM::Schema::ComplexNode( name => 'address' )->appendRange( + IMPL::DOM::Schema::NodeSet->new()->appendRange( + new IMPL::DOM::Schema::SimpleNode( name => 'street' ), + new IMPL::DOM::Schema::SimpleNode( name => 'line', minOccur => 0 ) + ) + ) + ) + ) + ); + + $this->SampleSchema($schema); + + my @errors = $metaSchema->Validate($schema); + failed "Failed to validate a wellformed schema", map $_->Message, @errors if @errors; +}; + +test VerifyWrongSchema => sub { + my $metaSchema = IMPL::DOM::Schema->MetaSchema(); + + my $schema = new IMPL::DOM::Schema; + $schema->appendRange( + IMPL::DOM::Schema::ComplexNode->new( name => 'personInfo' )->appendRange( + new IMPL::DOM::Schema::ComplexType( type => 'someType' ), + new IMPL::DOM::Schema::SimpleNode( name => 'lastName' ), + new IMPL::DOM::Schema::ComplexNode( name => 'address' )->appendRange( + new IMPL::DOM::Schema::SimpleNode( name => 'street' ), + new IMPL::DOM::Schema::SimpleNode( name => 'line' ) + ) + ) + ); + + my @errors = $metaSchema->Validate($schema); + failed "A not wellformed schema validated correctly" unless @errors; +}; + +test ValidateCorrectData => sub { + my ($this) = @_; + + my $data = IMPL::DOM::Node->new(nodeName => 'personInfo')->appendRange( + IMPL::DOM::Node->new(nodeName => 'firstName', nodeValue => 'John'), + IMPL::DOM::Node->new(nodeName => 'lastName', nodeValue => 'Smith'), + IMPL::DOM::Node->new(nodeName => 'address')->appendRange( + IMPL::DOM::Node->new(nodeName => 'street', nodeValue => 'main road') + ) + ); + + if (my @errors = $this->SampleSchema->Validate($data)) { + failed "Failed to validate a correct data", map $_->Message , @errors; + } +}; + +test ValidateWrongData => sub { + my ($this) = @_; + + my $data = IMPL::DOM::Node->new(nodeName => 'personInfo')->appendRange( + IMPL::DOM::Node->new(nodeName => 'firstName', nodeValue => 'John'), + IMPL::DOM::Node->new(nodeName => 'address')->appendRange( + IMPL::DOM::Node->new(nodeName => 'street', nodeValue => 'main road') + ) + ); + + failed "A wrong data validated corretly" unless $this->SampleSchema->Validate($data); +}; + + 1;