Mercurial > pub > Impl

changeset 19:1ca530e5c9c5

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
DOM схема, требует переработки в части схемы для описания схем. Автоверификация не проходит
author Sergey
date Fri, 11 Sep 2009 16:30:39 +0400
parents 818c74b038ae
children 267460284fb3
files Lib/IMPL/DOM/Schema.pm Lib/IMPL/DOM/Schema/AnyNode.pm Lib/IMPL/DOM/Schema/ComplexNode.pm Lib/IMPL/DOM/Schema/ComplexType.pm Lib/IMPL/DOM/Schema/Node.pm Lib/IMPL/DOM/Schema/NodeList.pm Lib/IMPL/DOM/Schema/NodeSet.pm Lib/IMPL/DOM/Schema/SimpleNode.pm Lib/IMPL/DOM/Schema/SimpleType.pm Lib/IMPL/DOM/Schema/ValidationError.pm _test/DOM.t _test/Test/DOM/Schema.pm impl.kpf
diffstat 13 files changed, 282 insertions(+), 67 deletions(-) [+]
line wrap: on
line diff
--- a/Lib/IMPL/DOM/Schema.pm	Thu Sep 10 17:42:47 2009 +0400
+++ b/Lib/IMPL/DOM/Schema.pm	Fri Sep 11 16:30:39 2009 +0400
@@ -2,6 +2,15 @@
 use strict;
 use warnings;
 
+require IMPL::DOM::Schema::ComplexNode;
+require IMPL::DOM::Schema::ComplexType;
+require IMPL::DOM::Schema::SimpleNode;
+require IMPL::DOM::Schema::SimpleType;
+require IMPL::DOM::Schema::Node;
+require IMPL::DOM::Schema::AnyNode;
+require IMPL::DOM::Schema::NodeList;
+require IMPL::DOM::Schema::NodeSet;
+
 use base qw(IMPL::DOM::Document);
 use IMPL::Class::Property;
 use IMPL::Class::Property::Direct;
@@ -12,7 +21,7 @@
     private _direct property _TypesMap => prop_all;
 }
 
-sub ResoveType {
+sub resolveType {
     $_[0]->{$_TypesMap}->{$_[1]};
 }
 
@@ -22,8 +31,19 @@
     $this->{$_TypesMap} = { map { $_->type, $_ } grep {$_->isa('IMPL::DOM::Schema::Type')} @{$this->childNodes} };
 }
 
+sub Validate {
+    my ($this,$node) = @_;
+    
+    #return IMPL::DOM::Schema::NodeSet->new()->appendRange(@{$this->childNodes})->Validate($node);
+}
+
+my $schema;
+
 sub MetaSchema {
-    my $schema = new IMPL::DOM::Schema(nodeName => 'schema');
+    
+    return $schema if $schema;
+    
+    $schema = new IMPL::DOM::Schema(nodeName => 'schema');
     
     $schema->appendRange(
         IMPL::DOM::Schema::ComplexNode->new(nodeName => 'schema')->appendRange(
@@ -34,44 +54,44 @@
                 IMPL::DOM::Schema::Node->new(nodeName => 'SimpleType', type => 'SimpleType', minOccur => 0, maxOccur=>'unbounded'),
                 IMPL::DOM::Schema::SimpleNode->new(nodeName => 'Node', minOccur => 0, maxOccur=>'unbounded'),
                 IMPL::DOM::Schema::SimpleNode->new(nodeName => 'Include', minOccur => 0, maxOccur=>'unbounded')
-            )
+            ),
         ),
-        IMPL::DOM::Schema::ComplexType->new(type => 'NodeSet', native => 'IMPL::DOM::Schema::NodeSet')->appendRange(
+        IMPL::DOM::Schema::ComplexType->new(type => 'NodeSet', nativeType => 'IMPL::DOM::Schema::NodeSet')->appendRange(
             IMPL::DOM::Schema::NodeSet->new()->appendRange(
                 IMPL::DOM::Schema::Node->new(nodeName => 'ComplexNode', type => 'ComplexNode', minOccur => 0, maxOccur=>'unbounded'),
                 IMPL::DOM::Schema::Node->new(nodeName => 'SimpleNode', type => 'SimpleNode', minOccur => 0, maxOccur=>'unbounded'),
                 IMPL::DOM::Schema::SimpleNode->new(nodeName => 'Node', minOccur => 0, maxOccur=>'unbounded'),
             )
         ),
-        IMPL::DOM::Schema::ComplexType->new(type => 'NodeList', native => 'IMPL::DOM::Schema::NodeList')->appendRange(
+        IMPL::DOM::Schema::ComplexType->new(type => 'NodeList', nativeType => 'IMPL::DOM::Schema::NodeList')->appendRange(
             IMPL::DOM::Schema::NodeSet->new()->appendRange(
                 IMPL::DOM::Schema::Node->new(nodeName => 'ComplexNode', type => 'ComplexNode', minOccur => 0, maxOccur=>'unbounded'),
                 IMPL::DOM::Schema::Node->new(nodeName => 'SimpleNode', type => 'SimpleNode', minOccur => 0, maxOccur=>'unbounded'),
                 IMPL::DOM::Schema::SimpleNode->new(nodeName => 'Node', minOccur => 0, maxOccur=>'unbounded'),
             )
         ),
-        IMPL::DOM::Schema::ComplexType->new(type => 'ComplexType', native => 'IMPL::DOM::Schema::ComplexType')->appendRange(
+        IMPL::DOM::Schema::ComplexType->new(type => 'ComplexType', nativeType => 'IMPL::DOM::Schema::ComplexType')->appendRange(
             IMPL::DOM::Schema::NodeList->new()->appendRange(
                 IMPL::DOM::Schema::Node->new(nodeName => 'NodeSet', minOccur => 0, type => 'NodeSet'),
                 IMPL::DOM::Schema::Node->new(nodeName => 'NodeList', minOccur => 0, type => 'NodeSet'),
                 IMPL::DOM::Schema::SimpleNode->new(nodeName => 'Node', minOccur => 0, maxOccur => 'unbounded')
             )
         ),
-        IMPL::DOM::Schema::ComplexType->new(type => 'ComplexNode', native => 'IMPL::DOM::Schema::ComplexNode')->appendRange(
+        IMPL::DOM::Schema::ComplexType->new(type => 'ComplexNode', nativeType => 'IMPL::DOM::Schema::ComplexNode')->appendRange(
             IMPL::DOM::Schema::NodeList->new()->appendRange(
                 IMPL::DOM::Schema::Node->new(nodeName => 'NodeSet', minOccur => 0, type => 'NodeSet'),
                 IMPL::DOM::Schema::Node->new(nodeName => 'NodeList', minOccur => 0, type => 'NodeSet'),
                 IMPL::DOM::Schema::SimpleNode->new(nodeName => 'Node', minOccur => 0, maxOccur => 'unbounded')
             )
         ),
-        IMPL::DOM::Schema::ComplexType->new(type => 'SimpleType', native => 'IMPL::DOM::Schema::SimpleType')->appendRange(
+        IMPL::DOM::Schema::ComplexType->new(type => 'SimpleType', nativeType => 'IMPL::DOM::Schema::SimpleType')->appendRange(
             IMPL::DOM::Schema::NodeSet->new()->appendRange(
-                IMPL::DOM::Schema::AnyNode(maxOccur => 'unbounded', minOccur => 0)
+                IMPL::DOM::Schema::AnyNode->new(maxOccur => 'unbounded', minOccur => 0)
             )
         ),
-        IMPL::DOM::Schema::ComplexType->new(type => 'SimpleNode', native => 'IMPL::DOM::Schema::SimpleNode')->appendRange(
+        IMPL::DOM::Schema::ComplexType->new(type => 'SimpleNode', nativeType => 'IMPL::DOM::Schema::SimpleNode')->appendRange(
             IMPL::DOM::Schema::NodeSet->new()->appendRange(
-                IMPL::DOM::Schema::AnyNode(maxOccur => 'unbounded', minOccur => 0)
+                IMPL::DOM::Schema::AnyNode->new(maxOccur => 'unbounded', minOccur => 0)
             )
         )
     );
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/DOM/Schema/AnyNode.pm	Fri Sep 11 16:30:39 2009 +0400
@@ -0,0 +1,25 @@
+package IMPL::DOM::Schema::AnyNode;
+use strict;
+use warnings;
+
+use base qw(IMPL::DOM::Schema::Node);
+
+our %CTOR = (
+    'IMPL::DOM::Schema::Node' => sub { nodeName => 'AnyNode'}
+);
+
+1;
+
+__END__
+
+=pod
+
+=head1 DESCRIPTION
+
+   ,      
+ .  ,       
+     ,     
+      ,     
+ .
+
+=cut
\ No newline at end of file
--- a/Lib/IMPL/DOM/Schema/ComplexNode.pm	Thu Sep 10 17:42:47 2009 +0400
+++ b/Lib/IMPL/DOM/Schema/ComplexNode.pm	Fri Sep 11 16:30:39 2009 +0400
@@ -25,15 +25,7 @@
 sub Validate {
     my ($this,$node) = @_;
     
-    if (my $type = $this->nodeType) {
-        my $schemaType = $this->Schema->ResolveType($type);
-        return $schemaType->Validate($node);
-    } else {
-        my @errors;
-        push @errors, $_->Validate foreach @{$this->childNodes};
-        
-        return @errors;
-    }
+    map $_->Validate($node), @{$this->childNodes};
 }
 
 1;
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/DOM/Schema/ComplexType.pm	Fri Sep 11 16:30:39 2009 +0400
@@ -0,0 +1,30 @@
+package IMPL::DOM::Schema::ComplexType;
+use strict;
+use warnings;
+
+use base qw(IMPL::DOM::Schema::ComplexNode);
+use IMPL::Class::Property;
+use IMPL::Class::Property::Direct;
+
+BEGIN {
+    public _direct property nativeType => prop_get;
+}
+
+our %CTOR = (
+    'IMPL::DOM::Schema::ComplexNode' => sub {
+        my %args = @_;
+        $args{nodeName} = 'ComplexNode';
+        $args{minOccur} = 0;
+        $args{maxOccur} = 'unbounded';
+        %args
+    }
+);
+
+sub CTOR {
+    my ($this,%args) = @_;
+    
+    $this->{$nativeType} = $args{nativeType};
+}
+
+
+1;
--- a/Lib/IMPL/DOM/Schema/Node.pm	Thu Sep 10 17:42:47 2009 +0400
+++ b/Lib/IMPL/DOM/Schema/Node.pm	Fri Sep 11 16:30:39 2009 +0400
@@ -8,9 +8,9 @@
 use IMPL::Class::Property::Direct;
 
 BEGIN {
-    public _dom property minOccur => prop_all;
-    public _dom property maxOccur => prop_all;
-    public _dom property type => prop_all
+    public property minOccur => prop_all;
+    public property maxOccur => prop_all;
+    public property type => prop_all
 }
 
 __PACKAGE__->PassThroughArgs;
@@ -18,11 +18,19 @@
 sub CTOR {
     my ($this,%args) = @_;
     
-    $this->minOccur($args{minOcuur});
-    $this->maxOccur($args{maxOccur});
+    $this->minOccur(defined $args{minOcuur} ? $args{minOcuur} : 1);
+    $this->maxOccur(defined $args{maxOccur} ? $args{maxOccur} : 1);
     $this->type($args{type});
 }
 
+sub Validate {
+    my ($this,$node) = @_;
+    
+    if (my $schemaType = $this->type ? $this->rootNode->resolveType($this->type) : undef ) {
+        return $schemaType->Validate($node);
+    }
+}
+
 1;
 
 __END__
--- a/Lib/IMPL/DOM/Schema/NodeList.pm	Thu Sep 10 17:42:47 2009 +0400
+++ b/Lib/IMPL/DOM/Schema/NodeList.pm	Fri Sep 11 16:30:39 2009 +0400
@@ -1,55 +1,67 @@
 package IMPL::DOM::Schema::NodeList;
 use strict;
 use warnings;
-use base qw(IMPL::DOM::Schema::Item);
+use base qw(IMPL::DOM::Node);
+
 use IMPL::Class::Property;
+require IMPL::DOM::Schema::ValidationError;
+
+our %CTOR = (
+    'IMPL::DOM::Node' => sub { nodeName => 'NodeList' }
+);
 
 BEGIN {
-    public property MessageUnexpected => prop_all;
-    public property MessageNodesRequired => prop_all;
+    public property messageUnexpected => prop_all;
+    public property messageNodesRequired => prop_all;
+}
+
+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');
 }
 
 sub Validate {
     my ($this,$node) = @_;
     
     my @nodes = map {
-        {nodeName => $_->nodeName, Schema => $_, Min => $_->minOccur, Max => $_->maxOccur, Seen => 0 }
+        {nodeName => $_->nodeName, anyNode => $_->isa('IMPL::DOM::Schema::AnyNode') , Schema => $_, Min => $_->minOccur eq 'unbounded' ? undef : $_->maxOccur, Max => $_->maxOccur, Seen => 0 }
     } @{$this->childNodes};
     
     my $info = shift @nodes;
     
     foreach my $child ( @{$node->childNodes} ) {
         #skip schema elements
-        while ($info and $info->{nodeName} ne $child->nodeName) {
+        while ($info and not $info->{anyNode} and $info->{nodeName} ne $child->nodeName) {
             # if possible of course :)
-            return {
-                Error => 1,
-                Message => $this->MessageUnexpected,
+            return new IMPL::DOM::Schema::VaidationError (
+                Message => $this->messageUnexpected,
                 Node => $child,
+                Schema => $info->{Schema},
                 Source => $this
-            } if $info->{Min} > $info->{Seen};
+            ) if $info->{Min} > $info->{Seen};
             
             $info = shift @nodes;
         }
         
         # return error if no more children allowed
-        return {
-            Error => 1,
-            Message => $this->MessageUnexpected,
+        return new IMPL::DOM::Schema::VaidationError (
+            Message => $this->messageUnexpected,
             Node => $child,
             Source => $this
-        } unless $info;
+        ) unless $info;
         
         # it's ok, we found schema element for him
         $info->{Seen}++;
         
         # check count limits
-        return {
+        return new IMPL::DOM::Schema::VaidationError (
             Error => 1,
-            Message => $this->MessageUnexpected,
+            Message => $this->messageUnexpected,
             Node => $child,
             Source => $this,
-        } if $info->{Seen} > $info->{Max};
+        ) if $info->{Max} and $info->{Seen} > $info->{Max};
         
         # validate
         if (my @errors = $info->{Schema}->Validate($child)) {
@@ -59,11 +71,12 @@
     
     # no more children left (but may be should :)
     while ($info) {
-        return {
+        return new IMPL::DOM::Schema::VaidationError (
             Error => 1,
-            Message => $this->MessageNodesRequired,
+            Message => $this->messageNodesRequired,
+            Node => $node,
             Source => $this
-        } if $info->{Seen} < $info->{Min};
+        ) if $info->{Seen} < $info->{Min};
         
         $info = shift @nodes;
     }
--- a/Lib/IMPL/DOM/Schema/NodeSet.pm	Thu Sep 10 17:42:47 2009 +0400
+++ b/Lib/IMPL/DOM/Schema/NodeSet.pm	Fri Sep 11 16:30:39 2009 +0400
@@ -2,13 +2,25 @@
 use strict;
 use warnings;
 
-use base qw(IMPL::DOM::Schema::Item);
+use base qw(IMPL::DOM::Node);
 use IMPL::Class::Property;
 
+our %CTOR = (
+    'IMPL::DOM::Node' => sub { nodeName => 'NodeSet' }
+);
+
 BEGIN {
-    public property UnexpectedMessage => prop_all;
-    public property MaxMessage => prop_all;
-    public property MinMessage => prop_all;
+    public property messageUnexpected => prop_all;
+    public property messageMax => prop_all;
+    public property messageMin => prop_all;
+}
+
+sub CTOR {
+    my ($this,%args) = @_;
+    
+    $this->messageMax( $args{messageMax} || 'Too many %Node.nodeName% nodes');
+    $this->messageMin( $args{messageMin} || '%Schema.nodeName% nodes expected');
+    $this->messageUnexpected( $args{messageUnexpected} || 'A %Node.nodeName% isn\'t allowed here');
 }
 
 sub Validate {
@@ -16,38 +28,46 @@
     
     my @errors;
     
-    my %nodes = map {
-        $_->nodeName ,
-        {Schema => $_, Min => $_->minOccur, Max => $_->maxOccur, Seen => 0 }
-    } @{$this->childNodes};
+    my %nodes;
+    my $anyNode;
+    foreach (@{$this->childNodes}) {
+        if ($_->isa('IMPL::DOM::Schema::AnyNode')) {
+            $anyNode = {Schema => $_, Min => $_->minOccur, Max => $_->maxOccur eq 'unbounded' ? undef : $_->maxOccur , Seen => 0 };
+        } else {
+            $nodes{$_->nodeName} = {Schema => $_, Min => $_->minOccur, Max => $_->maxOccur eq 'unbounded' ? undef : $_->maxOccur , Seen => 0 };
+        }
+    }
     
     foreach my $child ( @{$node->childNodes} ) {
-        if (my $info = $nodes{$child->nodeName}) {
+        if (my $info = $nodes{$child->nodeName} || $anyNode) {
             $info->{Seen}++;
-            push @errors,{
-                Error => 1,
+            push @errors,new IMPL::DOM::Schema::VaidationError (
                 Source => $this,
                 Node => $child,
-                Message => $this->MaxMessage
-            } if ($info->{Seen} > $info->{Max});
+                Schema => $info->{Schema},
+                Message => $this->messageMax
+            ) if ($info->{Max} and $info->{Seen} > $info->{Max});
             
-            push @errors,$info->{Schema}->Validate($child);
+            if (my @localErrors = $info->{Schema}->Validate($child)) {
+                push @errors,@localErrors;
+            }
         } else {
-            push @errors, {
-                Error => 1,
+            push @errors, new IMPL::DOM::Schema::VaidationError (
                 Source => $this,
                 Node => $child,
-                Message => $this->UnexpectedMessage
-            }
+                Schema => $info->{Schema},
+                Message => $this->messageUnexpected
+            )
         }
     }
     
     foreach my $info (values %nodes) {
-        push @errors, {
-            Error => 1,
+        push @errors, new IMPL::DOM::Schema::VaidationError (
             Source => $this,
-            Message => $this->MinMessage
-        } if $info->{Min} > $info->{Seen};
+            Schema => $info->{Schema},
+            Node => $node,
+            Message => $this->messageMin
+        ) if $info->{Min} > $info->{Seen};
     }
     
     return @errors;
--- a/Lib/IMPL/DOM/Schema/SimpleNode.pm	Thu Sep 10 17:42:47 2009 +0400
+++ b/Lib/IMPL/DOM/Schema/SimpleNode.pm	Fri Sep 11 16:30:39 2009 +0400
@@ -2,7 +2,7 @@
 use strict;
 use warnings;
 
-use base qw(IMPL::DOM::Schema::Item);
+use base qw(IMPL::DOM::Schema::Node);
 
 __PACKAGE__->PassThroughArgs;
 
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/DOM/Schema/SimpleType.pm	Fri Sep 11 16:30:39 2009 +0400
@@ -0,0 +1,30 @@
+package IMPL::DOM::Schema::SimpleType;
+use strict;
+use warnings;
+
+use base qw(IMPL::DOM::Schema::SimpleNode);
+use IMPL::Class::Property;
+use IMPL::Class::Property::Direct;
+
+BEGIN {
+    public _direct property nativeType => prop_get;
+}
+
+our %CTOR = (
+    'IMPL::DOM::Schema::SimpleNode' => sub {
+        my %args = @_;
+        $args{nodeName} = 'ComplexNode';
+        $args{minOccur} = 0;
+        $args{maxOccur} = 'unbounded';
+        %args
+    }
+);
+
+sub CTOR {
+    my ($this,%args) = @_;
+    
+    $this->{$nativeType} = $args{nativeType};
+}
+
+
+1;
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/DOM/Schema/ValidationError.pm	Fri Sep 11 16:30:39 2009 +0400
@@ -0,0 +1,26 @@
+package IMPL::DOM::Schema::VaidationError;
+use strict;
+use warnings;
+
+use base qw(IMPL::Object);
+use IMPL::Class::Property;
+use IMPL::Class::Property::Direct;
+use IMPL::Resources::Format qw(FormatMessage);
+
+BEGIN {
+    public _direct property Node => prop_get;
+    public _direct property Schema => prop_get;
+    public _direct property Source => prop_get;
+    public _direct property Message => prop_get;
+}
+
+sub CTOR {
+    my ($this,%args) = @_;
+    
+    $this->{$Node} = $args{Node} or die new IMPL::InvalidArgumentException("Node is a required parameter");
+    $this->{$Schema} = $args{Schema} if $args{Schema};
+    $this->{$Source} = $args{Source} if $args{Source};
+    $this->{$Message} = FormatMessage(delete $args{Message}, \%args) if $args{Message};
+}
+
+1;
--- a/_test/DOM.t	Thu Sep 10 17:42:47 2009 +0400
+++ b/_test/DOM.t	Fri Sep 11 16:30:39 2009 +0400
@@ -9,6 +9,7 @@
 my $plan = new IMPL::Test::Plan qw(
     Test::DOM::Node
     Test::DOM::Navigator
+    Test::DOM::Schema
 );
 
 $plan->AddListener(new IMPL::Test::TAPListener);
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/_test/Test/DOM/Schema.pm	Fri Sep 11 16:30:39 2009 +0400
@@ -0,0 +1,24 @@
+package Test::DOM::Schema;
+use strict;
+use warnings;
+
+use base qw(IMPL::Test::Unit);
+use IMPL::Test qw(test failed);
+
+__PACKAGE__->PassThroughArgs;
+
+require IMPL::DOM::Schema;
+
+test GetMetaSchema => sub {
+    my $metaSchema = IMPL::DOM::Schema->MetaSchema();
+};
+
+test AutoverifyMetaSchema => sub {
+    my $metaSchema = IMPL::DOM::Schema->MetaSchema();
+    
+    if (my @errors = $metaSchema->Validate($metaSchema)) {
+        failed "Self verification failed", map $_ ? $_->Message : 'unknown', @errors;
+    }
+};
+
+1;
--- a/impl.kpf	Thu Sep 10 17:42:47 2009 +0400
+++ b/impl.kpf	Fri Sep 11 16:30:39 2009 +0400
@@ -144,6 +144,32 @@
 </preference-set>
   <string id="lastInvocation">default</string>
 </preference-set>
+<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/Lib/IMPL/DOM/Schema.pm">
+<preference-set id="Invocations">
+<preference-set id="default">
+  <string id="cookieparams"></string>
+  <string id="cwd"></string>
+  <long id="debugger.io-port">9011</long>
+  <string id="documentRoot"></string>
+  <string id="executable-params"></string>
+  <string relative="path" id="filename">Lib/IMPL/DOM/Schema.pm</string>
+  <string id="getparams"></string>
+  <string id="language">Perl</string>
+  <string id="mpostparams"></string>
+  <string id="params"></string>
+  <string id="postparams"></string>
+  <string id="posttype">application/x-www-form-urlencoded</string>
+  <string id="request-method">GET</string>
+  <boolean id="show-dialog">1</boolean>
+  <boolean id="sim-cgi">0</boolean>
+  <boolean id="use-console">0</boolean>
+  <string id="userCGIEnvironment"></string>
+  <string id="userEnvironment"></string>
+  <string id="warnings">enabled</string>
+</preference-set>
+</preference-set>
+  <string id="lastInvocation">default</string>
+</preference-set>
 <preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/Lib/IMPL/DOM/Schema/Item.pm">
 <preference-set id="Invocations">
 <preference-set id="default">