--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lib/IMPL/DOM/Schema/Validator/Compare.pm	Fri Sep 04 19:40:23 2015 +0300
@@ -0,0 +1,264 @@
+package IMPL::DOM::Schema::Validator::Compare;
+use strict;
+
+use IMPL::Const qw(:prop);
+use IMPL::declare {
+	require => {
+		Label => 'IMPL::DOM::Schema::Label',
+		ValidationError => 'IMPL::DOM::Schema::ValidationError'
+	},
+	base => [
+		'IMPL::DOM::Schema::Validator' => sub {
+	        my %args = @_;
+	        $args{nodeName} ||= 'Compare';
+	        delete @args{qw(targetProperty op nodePath optional message)};
+	        %args;
+	    }
+	],
+	props => [
+		targetProperty => PROP_RW,
+		op => PROP_RW,
+		nodePath => PROP_RW,
+		optional => PROP_RW,
+		_pathTranslated => PROP_RW,
+		_targetNode => PROP_RW,
+		_schemaNode => PROP_RW,
+		message => PROP_RW
+	] 
+};
+use IMPL::Resources::Format qw(FormatMessage);
+
+our %Ops = (
+    '='  => \&_equals,
+    'eq' => \&_equalsString,
+    '!=' => \&_notEquals,
+    'ne' => \&_notEqualsString,
+    '=~' => \&_matchRx,
+    '!~' => \&_notMatchRx,
+    '<'  => \&_less,
+    '>'  => \&_greater,
+    'lt' => \&_lessString,
+    'gt' => \&_greaterString
+);
+
+my $rxOps = map qr/$_/, join( '|', keys %Ops );
+
+sub CTOR {
+    my ($this,%args) = @_;
+    
+    $this->targetProperty($args{targetProperty} || 'nodeValue');
+    $this->op( $Ops{ $args{op} || '=' } ) or die new IMPL::InvalidArgumentException("Invalid parameter value",'op',$args{op},$this->path);
+    $this->nodePath($args{nodePath}) or die new IMPL::InvalidArgumentException("The argument is required", 'nodePath', $this->path);
+    $this->message($args{message} || 'The value of %node.path% %schemaNode.op% %value% (%schemaNode.nodePath%)' );
+    $this->optional($args{optional}) if $args{optional};
+}
+
+sub TranslatePath {
+    my ($this,$path) = @_;
+    
+    $path ||= '';
+    
+    my @selectQuery;
+    
+    my $i = 0;
+    
+    foreach my $chunk (split /\//,$path) {
+        $chunk = 'document:*' if $i == 0 and not length $chunk;
+        next if not length $chunk;
+        
+        my $query;        
+        my ($axis,$filter) = ( $chunk =~ /^(?:(\w+):)?(.*)$/);
+        
+        if ($filter =~ /^\w+|\*$/ ) {
+            $query = $filter eq '*' ? undef : $filter;
+        } elsif ( $filter =~ /^(\w+|\*)\s*((?:\[\s*\w+\s*(?:=|!=|=~|!~|eq|ne|lt|gt)\s*["'](?:[^\\'"]|\\[\\"'])*["']\])+)$/) {
+            my ($nodeName,$filterArgs) = ($1,$2);
+
+            
+            my @parsedFilters = map {
+                my ($prop,$op,$value) = ($_ =~ /\s*(\w+)\s*(=|!=|=~|!~|eq|ne|lt|gt)\s*(?:["']((?:[^\\'"]|\\[\\"'])*)["'])/);
+
+                $value =~ s/\\[\\'"]/$1/g;
+                {
+                    prop => $prop,
+                    op => $Ops{$op},
+                    value => $value
+                }
+            } grep ( $_, split ( /[\]\[]+/,$filterArgs ) );
+            
+            $query = sub {
+                my ($node) = shift;
+                
+                $node->nodeName eq $nodeName or return 0 if $nodeName ne '*';
+                $_->{op}->(
+                        _resovleProperty($node,$_->{prop}),
+                        FormatMessage($_->{value},{
+                            Schema => $this->parentNode,
+                            Node => $this->_targetNode,
+                            schema => $this->parentNode,
+                            schemaType => $this->parentNode,
+                            node => $this->_targetNode,
+                            source => $this->_schemaNode,
+                            schemaNode => $this->_schemaNode
+                        },\&_resovleProperty)
+                    ) or return 0 foreach @parsedFilters;
+                return 1;
+            };
+        } else {
+            die new IMPL::Exception("Invalid query syntax",$path,$chunk);
+        }
+        
+        push @selectQuery, $axis ? { $axis => $query } : $query;
+        
+        $i++;
+    }
+    
+    return \@selectQuery;
+}
+
+sub Validate {
+    my ($this,$node,$ctx) = @_;
+    
+    my @result;
+    
+    my $schemaNode = $ctx->{schemaNode};
+    my $schemaType = $ctx->{schemaType};
+    
+    $this->_schemaNode($schemaNode);
+    
+    $this->_targetNode($node);
+    
+    my $query = $this->_pathTranslated() || $this->_pathTranslated($this->TranslatePath($this->nodePath));
+    
+    my ($foreignNode) = $node->selectNodes(@$query);
+    
+    
+    
+    if ($foreignNode) {
+        my $value = $this->nodeValue;
+        
+        if ($value) {
+            $value = FormatMessage($value, { Schema => $this->parentNode, Node => $this->_targetNode, ForeignNode => $foreignNode },\&_resovleProperty);
+        } else {
+            $value = $foreignNode->nodeValue;
+        }
+        
+        push @result, ValidationError->new(
+            node => $node,
+            foreignNode => $foreignNode,
+            value => $value,
+            schemaNode => $schemaNode,
+            schemaType => $schemaType,
+            message => $this->_MakeLabel($this->message)
+        ) unless $this->op->(_resovleProperty($node,$this->targetProperty),$value);
+    } elsif (not $this->optional) {
+        push @result, ValidationError->new(
+            node => $node,
+            value => '',
+            schemaNode => $schemaNode,
+            schemaType => $schemaType,
+            message => $this->_MakeLabel( $this->message )
+        );
+    }
+    
+    $this->_targetNode(undef);
+    $this->_schemaNode(undef);
+    
+    return @result;
+}
+
+sub _resovleProperty {
+    my ($node,$prop) = @_;
+    
+    return $node->can($prop) ? $node->$prop() : $node->nodeProperty($prop);
+}
+
+sub _matchRx {
+    $_[0] =~ $_[1];
+}
+
+sub _notMatchRx {
+    $_[0] !~ $_[1];
+}
+
+sub _equals {
+    $_[0] == $_[1];
+}
+
+sub _notEquals {
+    $_[0] != $_[0];
+}
+
+sub _equalsString {
+    $_[0] eq $_[1];
+}
+
+sub _notEqualsString {
+    $_[0] ne $_[1];
+}
+
+sub _less {
+    $_[0] < $_[1];
+}
+
+sub _greater {
+    $_[0] > $_[1];
+}
+
+sub _lessString {
+    $_[0] lt $_[1];
+}
+
+sub _greaterString {
+    $_[0] gt $_[1];
+}
+
+sub _lessEq {
+    $_[0] <= $_[1];
+}
+
+sub _greaterEq {
+    $_[0] >= $_[1];
+}
+
+sub _MakeLabel {
+	my ($this,$label) = @_;
+	
+	if ($label =~ /^ID:(\w+)$/) {
+		return Label->new($this->document->stringMap, $1);
+	} else {
+		return $label;
+	}
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+C<IMPL::DOM::Schema::Validator::Compare> - ограничение на содержимое текущего узла,
+сравнивая его со значением другого узла.
+
+=head1 SYNOPSIS
+
+Пример типа описания поля с проверочным полем
+
+=begin code xml
+
+<schema>
+    <SimpleType type="retype_field">
+        <Property name="linkedNode" message="Для узла %node.nodeName% необходимо задать свойство %schemaNode.name%"/>
+        <Compare op="eq" nodePath="sibling:*[nodeName eq '%node.linkedNode%']"/>
+    </SimpleType>
+</schema>
+
+=begin code xml
+
+=head1 DESCRIPTION
+
+Позволяет сравнивать значение текущего узла со значением другого узла. 
+
+=cut