# HG changeset patch
# User Sergey
# Date 1254689329 -14400
# Node ID 7f00786f8210a1e87be2cca27d78f4c69735480a
# Parent 716b287d479586b064602114e595e1ba8cc69147
Первая рабочая реазизация схемы и навигаторов
diff -r 716b287d4795 -r 7f00786f8210 Lib/IMPL/DOM/Document.pm
--- 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
diff -r 716b287d4795 -r 7f00786f8210 Lib/IMPL/DOM/Navigator.pm
--- 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>.
.
diff -r 716b287d4795 -r 7f00786f8210 Lib/IMPL/DOM/Navigator/Builder.pm
--- 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;
diff -r 716b287d4795 -r 7f00786f8210 Lib/IMPL/DOM/Navigator/SchemaNavigator.pm
--- 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
- , , .
- .
+ ,
+ .
+
+=head1 METHODS
+
+=over
+
+=item C<< $navi->NavigateName($name) >>
+
+ . C
+
+=item C<< $navi->SchemaBack >>
+
+ C.
+
+ .
+
+=back
=cut
\ No newline at end of file
diff -r 716b287d4795 -r 7f00786f8210 Lib/IMPL/DOM/Node.pm
--- 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;
diff -r 716b287d4795 -r 7f00786f8210 Lib/IMPL/DOM/Schema.pm
--- 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')
),
diff -r 716b287d4795 -r 7f00786f8210 Lib/IMPL/DOM/Schema/AnyNode.pm
--- 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
+ C.
+
+
+ .
+
+
+
+
+
+
+
+
=cut
\ No newline at end of file
diff -r 716b287d4795 -r 7f00786f8210 Lib/IMPL/DOM/Schema/Node.pm
--- 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__
diff -r 716b287d4795 -r 7f00786f8210 Lib/IMPL/DOM/Schema/NodeList.pm
--- 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;
diff -r 716b287d4795 -r 7f00786f8210 Lib/IMPL/DOM/Schema/NodeSet.pm
--- 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,
diff -r 716b287d4795 -r 7f00786f8210 Lib/IMPL/DOM/Schema/Property.pm
--- 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 =>
);
}
diff -r 716b287d4795 -r 7f00786f8210 Lib/IMPL/DOM/Schema/SwitchNode.pm
--- /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.
+
+=cut
diff -r 716b287d4795 -r 7f00786f8210 Lib/IMPL/DOM/Schema/ValidationError.pm
--- 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;
diff -r 716b287d4795 -r 7f00786f8210 Lib/IMPL/Object/Abstract.pm
--- 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;
diff -r 716b287d4795 -r 7f00786f8210 _test/Test/DOM/Navigator.pm
--- 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;
diff -r 716b287d4795 -r 7f00786f8210 _test/Test/DOM/Node.pm
--- 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",
diff -r 716b287d4795 -r 7f00786f8210 _test/Test/DOM/Schema.pm
--- 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;