# HG changeset patch
# User wizard
# Date 1273241860 -14400
# Node ID c289ed9662caf5573299d05e3e0a2b75897de6f4
# Parent  cf3b6ef2be22ece13f25b50626557097560378a1
Schema beta 2
More strict validation, support for inflating a simple nodes and properties

diff -r cf3b6ef2be22 -r c289ed9662ca Lib/IMPL/DOM/Navigator/Builder.pm
--- a/Lib/IMPL/DOM/Navigator/Builder.pm	Fri May 07 08:05:23 2010 +0400
+++ b/Lib/IMPL/DOM/Navigator/Builder.pm	Fri May 07 18:17:40 2010 +0400
@@ -11,7 +11,7 @@
     private _direct property _schemaNavi => prop_all;
     private _direct property _nodesPath => prop_all;
     private _direct property _nodeCurrent => prop_all;
-    private _direct property _docClass => prop_all
+    private _direct property _docClass => prop_all;
     public _direct property Document => prop_get | owner_set;
 }
 
@@ -27,6 +27,7 @@
     
     if (my $schemaNode = $this->{$_schemaNavi}->NavigateName($nodeName)) {
         my $class = $schemaNode->can('nativeType') ? $schemaNode->nativeType : 'IMPL::DOM::Node';
+        $this->inflateProperties($schemaNode,\%props);
         
         my $node;
         if (! $this->{$Document}) {
@@ -42,11 +43,31 @@
         
         return $node;
     } else {
-    	warn $nodeName;
         die new IMPL::InvalidOperationException("The specified node is undefined", $nodeName);
     }
 }
 
+sub inflateProperties {
+	my ($this,$schemaNode,$refProps) = @_;
+	
+	$refProps->{$_->name} = $_->inflator->new($refProps->{$_->name})
+		foreach $schemaNode->selectNodes(
+			sub {
+				$_->nodeName eq 'Property' and exists $refProps->{$_->name} and $_->inflator 
+			}
+		);
+}
+
+sub inflateValue {
+	my ($this,$value) = @_;
+	my $schemaNode = $this->{$_schemaNavi}->Current;
+	if ($schemaNode->can('inflator') and my $inflator = $schemaNode->inflator) {
+		return $inflator->new($value);
+	} else {
+		return $value;
+	}
+}
+
 sub Back {
     my ($this) = @_;
     
diff -r cf3b6ef2be22 -r c289ed9662ca Lib/IMPL/DOM/Navigator/SchemaNavigator.pm
--- a/Lib/IMPL/DOM/Navigator/SchemaNavigator.pm	Fri May 07 08:05:23 2010 +0400
+++ b/Lib/IMPL/DOM/Navigator/SchemaNavigator.pm	Fri May 07 18:17:40 2010 +0400
@@ -110,8 +110,6 @@
 =item C<< $navi->NavigateName($name) >>
 
 Переходит на схему узла с указанным именем. Тоесть использует свойство C<name>.
-В данном случае всегда происходит безопасная навигация, тоесть в случае неудачи,
-навигатор останется на прежней позиции.
 
 =item C<< $navi->SchemaBack >>
 
diff -r cf3b6ef2be22 -r c289ed9662ca Lib/IMPL/DOM/Navigator/SimpleBuilder.pm
--- a/Lib/IMPL/DOM/Navigator/SimpleBuilder.pm	Fri May 07 08:05:23 2010 +0400
+++ b/Lib/IMPL/DOM/Navigator/SimpleBuilder.pm	Fri May 07 18:17:40 2010 +0400
@@ -34,4 +34,8 @@
     return $node;
 }
 
+sub inflateValue {
+	$_[1];
+}
+
 1;
diff -r cf3b6ef2be22 -r c289ed9662ca Lib/IMPL/DOM/Schema.pm
--- a/Lib/IMPL/DOM/Schema.pm	Fri May 07 08:05:23 2010 +0400
+++ b/Lib/IMPL/DOM/Schema.pm	Fri May 07 18:17:40 2010 +0400
@@ -29,7 +29,6 @@
     private _direct property _TypesMap => prop_all;
     public _direct property baseDir => prop_all;
     public _direct property BaseSchemas => prop_get | owner_set;
-    private _direct property _Validators => prop_all;
 }
 
 sub resolveType {
diff -r cf3b6ef2be22 -r c289ed9662ca Lib/IMPL/DOM/Schema/ComplexType.pm
--- a/Lib/IMPL/DOM/Schema/ComplexType.pm	Fri May 07 08:05:23 2010 +0400
+++ b/Lib/IMPL/DOM/Schema/ComplexType.pm	Fri May 07 18:17:40 2010 +0400
@@ -8,6 +8,7 @@
 
 BEGIN {
     public _direct property nativeType => prop_get;
+    public _direct property messageWrongType => prop_get;
 }
 
 our %CTOR = (
@@ -25,10 +26,25 @@
     my ($this,%args) = @_;
     
     $this->{$nativeType} = $args{nativeType};
+    $this->{$messageWrongType} = $args{messageWrongType} || "A complex node '%Node.path%' is expected to be %Schema.nativeType%";
+}
+
+sub Validate {
+	my ($this, $node) = @_;
+	
+	if ($this->{$nativeType}) {
+		return new IMPL::DOM::Schema::ValidationError(
+			Node => $node,
+			Source => $this,
+			Schema => $this,
+			Message => $this->messageWrongType
+		) unless $node->isa($this->{$nativeType});
+	}
+	return $this->SUPER::Validate($node);
 }
 
 sub qname {
-	$_[0]->nodeName.'[name='.$_[0]->type.']';
+	$_[0]->nodeName.'[type='.$_[0]->type.']';
 }
 
 
diff -r cf3b6ef2be22 -r c289ed9662ca Lib/IMPL/DOM/Schema/Node.pm
--- a/Lib/IMPL/DOM/Schema/Node.pm	Fri May 07 08:05:23 2010 +0400
+++ b/Lib/IMPL/DOM/Schema/Node.pm	Fri May 07 18:17:40 2010 +0400
@@ -43,6 +43,8 @@
     }
 }
 
+sub inflator { undef; }
+
 sub qname {
     $_[0]->nodeName.'[name='.$_[0]->{$name}.']';
 }
diff -r cf3b6ef2be22 -r c289ed9662ca Lib/IMPL/DOM/Schema/Property.pm
--- a/Lib/IMPL/DOM/Schema/Property.pm	Fri May 07 08:05:23 2010 +0400
+++ b/Lib/IMPL/DOM/Schema/Property.pm	Fri May 07 18:17:40 2010 +0400
@@ -34,21 +34,23 @@
 sub Validate {
     my ($this,$node) = @_;
     
-    if ($this->minOccur) {
-        my $prop = $this->name;
-        my $nodeProp = new IMPL::DOM::Node(nodeName => '::property', nodeValue => eval { $node->$prop() } || $node->nodeProperty($prop));
+    my $prop = $this->name;
+    
+    # buld a pseudo node for the property value 
+    my $nodeProp = new IMPL::DOM::Node(nodeName => '::property', nodeValue => eval { $node->$prop() } || $node->nodeProperty($prop));
         
-        if (! $nodeProp->nodeValue) {
-            return new IMPL::DOM::Schema::ValidationError(
-                Message => $this->RequiredMessage,
-                Node => $node,
-                Schema => $this
-            );
-        }
-        return $this->SUPER::Validate($nodeProp);
-    } else {
-        return ();
+    if ($nodeProp->nodeValue) {
+    	# we have a value so validate it
+    	return $this->SUPER::Validate($nodeProp);
+    } elsif($this->minOccur) {
+    	# we don't have a value but it's a mandatory property
+        return new IMPL::DOM::Schema::ValidationError(
+            Message => $this->RequiredMessage,
+            Node => $node,
+            Schema => $this
+        );
     }
+    
 }
 
 1;
diff -r cf3b6ef2be22 -r c289ed9662ca Lib/IMPL/DOM/Schema/SimpleNode.pm
--- a/Lib/IMPL/DOM/Schema/SimpleNode.pm	Fri May 07 08:05:23 2010 +0400
+++ b/Lib/IMPL/DOM/Schema/SimpleNode.pm	Fri May 07 18:17:40 2010 +0400
@@ -3,15 +3,27 @@
 use warnings;
 
 use base qw(IMPL::DOM::Schema::Node);
+use IMPL::Class::Property;
+use IMPL::Class::Property::Direct;
+
+BEGIN {
+	public _direct property inflator => prop_get;
+}
 
 our %CTOR = (
     'IMPL::DOM::Schema::Node' => sub {my %args = @_; $args{nodeName} ||= 'SimpleNode'; %args}
-);  
+);
+
+sub CTOR {
+	my ($this,%args) = @_;
+	
+	$this->{$inflator} = $args{inflator} if $args{iflator};
+}
 
 sub Validate {
     my ($this,$node) = @_;
     
-    map $_->Validate($node), @{$this->childNodes};    
+    return map $_->Validate($node), @{$this->childNodes};
 }
 
 1;
@@ -20,10 +32,18 @@
 
 =pod
 
+=head1 NAME
+
+C<IMPL::DOM::SimpleNode> - узел с текстом.
+
 =head1 DESCRIPTION
 
 Узел имеющий простое значение. Данный узел может содержать ограничения
 на простое значение.
 
+Производит валидацию содержимого, при постоении DOM модели не имеет специального
+типа и будет создан в виде C<IMPL::DOM::Node>.
+
+Также определяет как будет воссоздано значение узла в DOM модели.
 
 =cut
diff -r cf3b6ef2be22 -r c289ed9662ca Lib/IMPL/DOM/Schema/SimpleType.pm
--- a/Lib/IMPL/DOM/Schema/SimpleType.pm	Fri May 07 08:05:23 2010 +0400
+++ b/Lib/IMPL/DOM/Schema/SimpleType.pm	Fri May 07 18:17:40 2010 +0400
@@ -8,6 +8,7 @@
 
 BEGIN {
     public _direct property nativeType => prop_get;
+    public _direct property messageWrongType => prop_get;
 }
 
 our %CTOR = (
@@ -25,11 +26,55 @@
     my ($this,%args) = @_;
     
     $this->{$nativeType} = $args{nativeType};
+    $this->{$messageWrongType} = $args{messageWrongType} || "A simple node '%Node.path%' is expected to be %Schema.nativeType%"; 
+}
+
+sub Validate {
+	my ($this, $node) = @_;
+	
+	if ($this->{$nativeType}) {
+		return new IMPL::DOM::Schema::ValidationError(
+			Node => $node,
+			Source => $this,
+			Schema => $this,
+			Message => $this->messageWrongType
+		) unless $node->isa($this->{$nativeType});
+	}
+	return $this->SUPER::Validate($node);
 }
 
 sub qname {
-	$_[0]->nodeName.'[name='.$_[0]->type.']';
+	$_[0]->nodeName.'[type='.$_[0]->type.']';
 }
 
+1;
 
-1;
+__END__
+
+=pod
+
+=head1 NAME
+
+C<IMPL::DOM::Schema::SimpleType> - тип для простых узлов.
+
+=head1 DESCRIPTION
+
+Используется для описания простых узлов, которые можно отобразить в узлы
+определенного типа при построении DOM документа.
+
+=head1 MEMBERS
+
+=over
+
+=item C<nativeType>
+
+Имя класса который будет представлять узел в DOM модели.
+
+=item C<messageWrongType>
+
+Формат сообщения которое будет выдано, если узел в дом модели не будет
+соответствовать свойству C<nativeType>.
+
+=back
+
+=cut
diff -r cf3b6ef2be22 -r c289ed9662ca Lib/IMPL/DOM/XMLReader.pm
--- a/Lib/IMPL/DOM/XMLReader.pm	Fri May 07 08:05:23 2010 +0400
+++ b/Lib/IMPL/DOM/XMLReader.pm	Fri May 07 18:17:40 2010 +0400
@@ -56,7 +56,7 @@
 sub _OnEnd {
     my ($this,$element) = @_;
     
-    $this->{$_current}->nodeValue($this->{$_text}) if length $this->{$_text};
+    $this->{$_current}->nodeValue($this->Navigator->inflateValue( $this->{$_text} ) ) if length $this->{$_text};
     $this->{$_text} = pop @{$this->{$_textHistory}};
     $this->{$_current} = $this->Navigator->Back;
 }
diff -r cf3b6ef2be22 -r c289ed9662ca _test/Resources/types.xml
--- a/_test/Resources/types.xml	Fri May 07 08:05:23 2010 +0400
+++ b/_test/Resources/types.xml	Fri May 07 18:17:40 2010 +0400
@@ -1,10 +1,9 @@
 <schema>
-	<SimpleType type="email" nativeType="SCALAR">
+	<SimpleType type="email">
 		<RegExp message="Неверный формат %Node.name_no%">^\w+(\.\w+)*@$\w+(\.\w+)+</RegExp>
-		<Property name='locale'/>
 	</SimpleType>
-	<SimpleType type="scalar" nativeType="SCALAR"/>
-	<SimpleType type="date" nativeType="DateTime">
+	<SimpleType type="scalar"/>
+	<SimpleType type="date" inflate="DateTime">
 		<Property name="timezone" optional="1"/>
 		<Property name="locale" optional="1"/>
 	</SimpleType>
diff -r cf3b6ef2be22 -r c289ed9662ca _test/any.pl
--- a/_test/any.pl	Fri May 07 08:05:23 2010 +0400
+++ b/_test/any.pl	Fri May 07 18:17:40 2010 +0400
@@ -4,6 +4,7 @@
 
 require IMPL::DOM::Navigator::SimpleBuilder;
 require IMPL::DOM::XMLReader;
+require IMPL::DOM::Schema;
 
 my $builder = IMPL::DOM::Navigator::SimpleBuilder->new();
     
@@ -59,6 +60,10 @@
     $reader2->ParseFile("Resources/person_info.xml");
     print "Parsing small Xml file: ",tv_interval($t,[gettimeofday]),"\n";
     
+    $t = [gettimeofday];
+    IMPL::DOM::Schema->LoadSchema('Resources/form.xml') for 1..10;
+    print "Load a small schema 10 times: ",tv_interval($t,[gettimeofday]),"\n";
+    
 sub selectAll {
     my $node = shift;
     $node,map selectAll($_),@{$node->childNodes};