Mercurial > pub > Impl
changeset 104:196bf443b5e1
DOM::Schema RC0 inflators support, validation and some other things,
Minor and major fixes almost for everything.
A 'Source' property of the ValidationErrors generated from a NodeSet or a NodeList is subject to change in the future.
author | wizard |
---|---|
date | Tue, 11 May 2010 02:42:59 +0400 |
parents | c289ed9662ca |
children | a6e9759ff88a |
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/InflateFactory.pm Lib/IMPL/DOM/Schema/Node.pm Lib/IMPL/DOM/Schema/Property.pm Lib/IMPL/DOM/Schema/SimpleNode.pm Lib/IMPL/DOM/Schema/SimpleType.pm Lib/IMPL/DOM/Schema/ValidationError.pm Lib/IMPL/DOM/Schema/Validator/Compare.pm Lib/IMPL/DOM/Schema/Validator/RegExp.pm Lib/IMPL/DOM/XMLReader.pm Lib/IMPL/Resources/Format.pm _test/temp.pl |
diffstat | 17 files changed, 544 insertions(+), 88 deletions(-) [+] |
line wrap: on
line diff
--- a/Lib/IMPL/DOM/Document.pm Fri May 07 18:17:40 2010 +0400 +++ b/Lib/IMPL/DOM/Document.pm Tue May 11 02:42:59 2010 +0400 @@ -17,6 +17,7 @@ delete $refProps->{nodeName}; + die new IMPL::Exception("class is not specified") unless $class; return $class->new( nodeName => $nodeName, document => $this,
--- a/Lib/IMPL/DOM/Navigator.pm Fri May 07 18:17:40 2010 +0400 +++ b/Lib/IMPL/DOM/Navigator.pm Tue May 11 02:42:59 2010 +0400 @@ -165,6 +165,21 @@ join($delim,map $_->{alternatives}[$_->{current}]->nodeName, $this->{$_path} ? (@{$this->{$_path}}, $this->{$_state}) : $this->{$_state}); } +sub pathLength { + my ($this) = @_; + $this->{$_path} ? scalar @{$this->{$_path}} : 0; +} + +sub GetNodeFromHistory { + my ($this,$index) = @_; + + if (my $state = $this->{$_path} ? $this->{$_path}->[$index] : undef ) { + return $state->{alternatives}[$state->{current}] + } else { + return undef; + } +} + sub clone { my ($this) = @_;
--- a/Lib/IMPL/DOM/Navigator/Builder.pm Fri May 07 18:17:40 2010 +0400 +++ b/Lib/IMPL/DOM/Navigator/Builder.pm Tue May 11 02:42:59 2010 +0400 @@ -6,12 +6,14 @@ use IMPL::Class::Property; use IMPL::Class::Property::Direct; require IMPL::DOM::Navigator::SchemaNavigator; +require IMPL::DOM::Schema::ValidationError; BEGIN { private _direct property _schemaNavi => prop_all; private _direct property _nodesPath => prop_all; private _direct property _nodeCurrent => prop_all; private _direct property _docClass => prop_all; + public _direct property BuildErrors => prop_get | prop_list; public _direct property Document => prop_get | owner_set; } @@ -26,8 +28,9 @@ my ($this,$nodeName,%props) = @_; if (my $schemaNode = $this->{$_schemaNavi}->NavigateName($nodeName)) { - my $class = $schemaNode->can('nativeType') ? $schemaNode->nativeType : 'IMPL::DOM::Node'; - $this->inflateProperties($schemaNode,\%props); + my $class = $schemaNode->can('nativeType') ? $schemaNode->nativeType || 'IMPL::DOM::Node' : 'IMPL::DOM::Node'; + + my @errors = $this->inflateProperties($schemaNode,\%props); my $node; if (! $this->{$Document}) { @@ -41,6 +44,20 @@ $this->{$_nodeCurrent} = $node; + if (@errors) { + $this->BuildErrors->Append( + map { + IMPL::DOM::Schema::ValidationError->new( + Node => $node, + Source => $this->{$_schemaNavi}->SourceSchemaNode, + Schema => $schemaNode, + Message => $schemaNode->messageInflateError, + Error => $_ + ) + } @errors + ); + } + return $node; } else { die new IMPL::InvalidOperationException("The specified node is undefined", $nodeName); @@ -49,22 +66,36 @@ 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 - } - ); + my @errors; + foreach my $schemaProp ( $schemaNode->selectNodes('Property') ) { + next if not exists $refProps->{$schemaProp->name}; + my $result = eval {$schemaProp->inflateValue($refProps->{$schemaProp->name}) }; + if (my $e = $@) { + push @errors, $e; + } else { + $refProps->{$schemaProp->name} = $result; + } + } + return @errors; } sub inflateValue { - my ($this,$value) = @_; - my $schemaNode = $this->{$_schemaNavi}->Current; - if ($schemaNode->can('inflator') and my $inflator = $schemaNode->inflator) { - return $inflator->new($value); + my ($this,$value,$node) = @_; + + my $nodeSchema = $this->{$_schemaNavi}->Current; + + my $result = eval { $nodeSchema->inflateValue($value) }; + if (my $e=$@) { + $this->BuildErrors->Append(new IMPL::DOM::Schema::ValidationError( + Schema => $nodeSchema, + Node => $node, + Error => $e, + Message => $nodeSchema->messageInflateError, + Source => $this->{$_schemaNavi}->SourceSchemaNode + )); + return $value; } else { - return $value; + return $result; } }
--- a/Lib/IMPL/DOM/Navigator/SchemaNavigator.pm Fri May 07 18:17:40 2010 +0400 +++ b/Lib/IMPL/DOM/Navigator/SchemaNavigator.pm Tue May 11 02:42:59 2010 +0400 @@ -38,7 +38,15 @@ # perform a safe navigation #return dosafe $this sub { - my $steps = 1; + my $steps = 0; + # if we are currently in a ComplexNode, first go to it's content + if ($this->Current->isa('IMPL::DOM::Schema::ComplexNode')) { + # navigate to it's content + # ComplexNode + $this->internalNavigateNodeSet($this->Current->content); + $steps ++; + } + # navigate to node if ( my $node = $this->Navigate( sub { @@ -51,10 +59,13 @@ ) }) ) { + $steps ++; 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; + $this->internalNavigateNodeSet($node); + $steps ++; } elsif ($node->nodeName eq 'SwitchNode') { # if we are in the switchnode # navigate to the target node @@ -70,13 +81,6 @@ $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 @@ -93,6 +97,19 @@ $this->Back(pop @{$this->{$_historySteps}}) if $this->{$_historySteps}; } +sub SourceSchemaNode { + my ($this) = @_; + + if ($this->Current->isa('IMPL::DOM::Schema::SimpleType') or + $this->Current->isa('IMPL::DOM::Schema::ComplexType') + ) { + # we a redirected + return $this->GetNodeFromHistory(-1); + } else { + return $this->Current; + } +} + 1; __END__ @@ -107,16 +124,21 @@ =over -=item C<< $navi->NavigateName($name) >> +=item C<NavigateName($name)> Переходит на схему узла с указанным именем. Тоесть использует свойство C<name>. -=item C<< $navi->SchemaBack >> +=item C<SchemaBack> Возвращается на позицию до последней операции C<NavigateName>. Данный метод нужен посокольку операция навигации по элементам описываемым схемой может приводить к нескольким операциям навигации по самой схеме. +=item C<SourceSchemaNode> + +Получает схему узла из которого было выполнено перенаправление, например, C<IMPL::DOM::Schema::Node>. +В остальных случаях совпадает со свойством C<Current>. + =back =cut
--- a/Lib/IMPL/DOM/Node.pm Fri May 07 18:17:40 2010 +0400 +++ b/Lib/IMPL/DOM/Node.pm Tue May 11 02:42:59 2010 +0400 @@ -21,6 +21,13 @@ private _direct property _propertyMap => prop_all ; } +our %Axes = ( + parent => \&selectParent, + siblings => \&selectSiblings, + child => \&childNodes, + document => \&selectDocument +); + sub CTOR { my ($this,%args) = @_; @@ -170,30 +177,82 @@ return wantarray ? @result : \@result; } +sub resolveAxis { + my ($this,$axis) = @_; + return $Axes{$axis}->($this) +} + sub selectNodes { - my ($this,$query) = @_; + my ($this,$query,$axis) = @_; + + $axis ||= 'child'; + + die new IMPL::InvalidOperationException('Unknown axis',$axis) unless exists $Axes{$axis}; + + my $nodes = $this->resolveAxis($axis); my @result; if (ref $query eq 'CODE') { - @result = grep &$query($_), @{$this->childNodes}; + @result = grep &$query($_), @{$nodes}; } elsif (ref $query eq 'ARRAY' ) { my %keys = map (($_,1),@$query); - @result = grep $keys{$_->nodeName}, @{$this->childNodes}; + @result = grep $keys{$_->nodeName}, @{$nodes}; + } elsif (ref $query eq 'HASH') { + while( my ($axis,$filter) = each %$query ) { + push @result, $this->selectNodes($filter,$axis); + } } elsif (defined $query) { - @result = grep $_->nodeName eq $query, @{$this->childNodes}; + @result = grep $_->nodeName eq $query, @{$nodes}; } else { - if (wantarray) { - return @{$this->childNodes}; - } else { - @result = $this->childNodes; - return \@result; - } + return wantarray ? @{$nodes} : $nodes; } return wantarray ? @result : \@result; } +sub selectPath { + my ($this,$path) = @_; + + my @set = ($this); + + while (my $query = shift @$path) { + @set = map $_->selectNodes($query), @set; + } + + return wantarray ? @set : \@set; +} + +sub selectParent { + my ($this) = @_; + + if ($this->parentNode) { + return wantarray ? $this->parentNode : [$this->parentNode]; + } else { + return wantarray ? () : []; + } +} + +sub selectSiblings { + my ($this) = @_; + + if ($this->parentNode) { + return $this->parentNode->selectNodes( sub { $_ != $this } ); + } else { + return wantarray ? () : []; + } +} + +sub selectDocument { + my ($this) = @_; + + if ($this->document) { + return wantarray ? $this->document : [$this->document]; + } else { + return wantarray ? () : []; + } +} + sub firstChild { @_ >=2 ? $_[0]->replaceNodeAt(0,$_[1]) : $_[0]->childNodes->[0]; }
--- a/Lib/IMPL/DOM/Schema.pm Fri May 07 18:17:40 2010 +0400 +++ b/Lib/IMPL/DOM/Schema.pm Tue May 11 02:42:59 2010 +0400 @@ -15,6 +15,7 @@ require IMPL::DOM::Schema::Validator; require IMPL::DOM::Navigator::Builder; require IMPL::DOM::XMLReader; +require IMPL::DOM::Schema::InflateFactory; use base qw(IMPL::DOM::Document); use IMPL::Class::Property; @@ -110,7 +111,7 @@ sub Validate { my ($this,$node) = @_; - if ( my ($schemaNode) = $this->selectNodes(sub { $_[0]->name eq $node->nodeName })) { + if ( my ($schemaNode) = $this->selectNodes(sub { $_->isa('IMPL::DOM::Schema::Node') and $_[0]->name eq $node->nodeName })) { $schemaNode->Validate($node); } else { return new IMPL::DOM::Schema::ValidationError(Message=> "A specified document doesn't match the schema"); @@ -132,7 +133,7 @@ IMPL::DOM::Schema::Node->new(name => 'ComplexType', type => 'ComplexType', minOccur => 0, maxOccur=>'unbounded'), 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::Node->new(name => 'Node', type => 'Node', minOccur => 0, maxOccur=>'unbounded'), IMPL::DOM::Schema::SimpleNode->new(name => 'Include', minOccur => 0, maxOccur=>'unbounded')->appendRange( IMPL::DOM::Schema::Property->new(name => 'source') ) @@ -142,9 +143,9 @@ 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::Node->new(name => 'Node', type=>'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 => 'AnyNode', type => 'AnyNode'), IMPL::DOM::Schema::Node->new(name => 'SwitchNode',type => 'SwitchNode') ) ) @@ -153,7 +154,7 @@ 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::Node->new(name => 'Node', type=>'Node', minOccur => 0, maxOccur=>'unbounded'), ) ), IMPL::DOM::Schema::ComplexType->new(type => 'NodeList', nativeType => 'IMPL::DOM::Schema::NodeList')->appendRange( @@ -161,8 +162,8 @@ 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::Node->new(name => 'Node', type => 'Node', minOccur => 0, maxOccur=>'unbounded'), + IMPL::DOM::Schema::Node->new(name => 'AnyNode', type => 'AnyNode', minOccur => 0, maxOccur=>'unbounded'), ) ), IMPL::DOM::Schema::ComplexType->new(type => 'ComplexType', nativeType => 'IMPL::DOM::Schema::ComplexType')->appendRange( @@ -192,14 +193,16 @@ IMPL::DOM::Schema::Node->new(name => 'Property', type=>'Property', maxOccur=>'unbounded', minOccur=>0), IMPL::DOM::Schema::AnyNode->new(maxOccur => 'unbounded', minOccur => 0, type=>'Validator') ), - new IMPL::DOM::Schema::Property(name => 'type') + new IMPL::DOM::Schema::Property(name => 'type'), + new IMPL::DOM::Schema::Property(name => 'inflator', optional => 1, inflator => 'IMPL::DOM::Schema::InflateFactory') ), IMPL::DOM::Schema::ComplexType->new(type => 'SimpleNode', nativeType => 'IMPL::DOM::Schema::SimpleNode')->appendRange( IMPL::DOM::Schema::NodeList->new()->appendRange( IMPL::DOM::Schema::Node->new(name => 'Property', type=>'Property', maxOccur=>'unbounded', minOccur=>0), IMPL::DOM::Schema::AnyNode->new(maxOccur => 'unbounded', minOccur => 0, type=>'Validator') ), - new IMPL::DOM::Schema::Property(name => 'name') + new IMPL::DOM::Schema::Property(name => 'name'), + new IMPL::DOM::Schema::Property(name => 'inflator', optional => 1, inflator => 'IMPL::DOM::Schema::InflateFactory') ), IMPL::DOM::Schema::ComplexType->new(type => 'Validator', nativeType => 'IMPL::DOM::Schema::Validator')->appendRange( IMPL::DOM::Schema::NodeList->new()->appendRange( @@ -210,8 +213,14 @@ IMPL::DOM::Schema::NodeList->new()->appendRange( IMPL::DOM::Schema::AnyNode->new(maxOccur => 'unbounded', minOccur => 0) ), - IMPL::DOM::Schema::Property->new(name => 'name') - ) + IMPL::DOM::Schema::Property->new(name => 'name'), + new IMPL::DOM::Schema::Property(name => 'inflator', optional => 1, inflator => 'IMPL::DOM::Schema::InflateFactory') + ), + IMPL::DOM::Schema::SimpleType->new(type => 'Node', nativeType => 'IMPL::DOM::Schema::Node')->appendRange( + IMPL::DOM::Schema::Property->new(name => 'name'), + IMPL::DOM::Schema::Property->new(name => 'type') + ), + IMPL::DOM::Schema::SimpleType->new(type => 'AnyNode', nativeType => 'IMPL::DOM::Schema::AnyNode') ); $schema->Process;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/DOM/Schema/InflateFactory.pm Tue May 11 02:42:59 2010 +0400 @@ -0,0 +1,17 @@ +package IMPL::DOM::Schema::InflateFactory; +use strict; + +require IMPL::Exception; +require IMPL::Object::Factory; + +sub new { + my ($self,$value) = @_; + + if ($value =~ /^(\w+(?:::\w+)*)(?:\.(\w+))?$/) { + return IMPL::Object::Factory->new($1,undef,$2); + } else { + die new IMPL::InvalidArgumentException("Expected value in the format PACKAGE::NAME.method_name",$value); + } +} + +1; \ No newline at end of file
--- a/Lib/IMPL/DOM/Schema/Node.pm Fri May 07 18:17:40 2010 +0400 +++ b/Lib/IMPL/DOM/Schema/Node.pm Tue May 11 02:42:59 2010 +0400 @@ -37,13 +37,18 @@ my ($this,$node) = @_; if (my $schemaType = $this->{$type} ? $this->document->resolveType($this->{$type}) : undef ) { - return $schemaType->Validate($node); + my @errors = $schemaType->Validate($node,{Source => $this}); + return @errors; } else { return (); } } -sub inflator { undef; } +sub inflateValue { + $_[1]; +} + +sub inflator { undef } sub qname { $_[0]->nodeName.'[name='.$_[0]->{$name}.']'; @@ -56,8 +61,8 @@ =head1 SYNOPSIS -package Restriction; -use base qw(IMPL::DOM::Schema::Item); +package SchemaEntity; +use base qw(IMPL::DOM::Schema::Node); sub Validate { my ($this,$node) = @_;
--- a/Lib/IMPL/DOM/Schema/Property.pm Fri May 07 18:17:40 2010 +0400 +++ b/Lib/IMPL/DOM/Schema/Property.pm Tue May 11 02:42:59 2010 +0400 @@ -10,7 +10,7 @@ __PACKAGE__->PassThroughArgs; BEGIN { - public property RequiredMessage => prop_all; + public property messageRequired => prop_all; } our %CTOR = ( @@ -20,6 +20,7 @@ $args{maxOccur} = 1; $args{minOccur} = delete $args{optional} ? 0 : 1; $args{nodeName} ||= 'Property'; + $args{messageInflateError} ||= "Failed to inflate a property '%Schema.name%' of a node '%Node.path%': %Error.Message%"; return %args; } @@ -28,11 +29,11 @@ sub CTOR { my ($this,%args) = @_; - $this->RequiredMessage($args{RequiredMessage} || 'A property %Schema.name% is required in the %Node.qname%'); + $this->messageRequired($args{messageRequired} || 'A property %Schema.name% is required in the %Node.qname%'); } sub Validate { - my ($this,$node) = @_; + my ($this,$node,$ctx) = @_; my $prop = $this->name; @@ -41,16 +42,17 @@ if ($nodeProp->nodeValue) { # we have a value so validate it - return $this->SUPER::Validate($nodeProp); + return $this->SUPER::Validate($nodeProp,$ctx); } elsif($this->minOccur) { # we don't have a value but it's a mandatory property return new IMPL::DOM::Schema::ValidationError( - Message => $this->RequiredMessage, + Message => $this->messageRequired, Node => $node, - Schema => $this + Schema => $this, + Source => $ctx && $ctx->{Source} || $this ); } - + return (); } 1;
--- a/Lib/IMPL/DOM/Schema/SimpleNode.pm Fri May 07 18:17:40 2010 +0400 +++ b/Lib/IMPL/DOM/Schema/SimpleNode.pm Tue May 11 02:42:59 2010 +0400 @@ -8,6 +8,7 @@ BEGIN { public _direct property inflator => prop_get; + public _direct property messageInflateError => prop_get; } our %CTOR = ( @@ -17,13 +18,28 @@ sub CTOR { my ($this,%args) = @_; - $this->{$inflator} = $args{inflator} if $args{iflator}; + $this->{$inflator} = $args{inflator} if $args{inflator}; + $this->{$messageInflateError} = $args{messageInflateError} || 'Failed to inflate nodeValue %Node.path%: %Error%'; } sub Validate { - my ($this,$node) = @_; + my ($this,$node,$ctx) = @_; + + my @result; + + push @result, $_->Validate($node,$ctx) foreach $this->childNodes; - return map $_->Validate($node), @{$this->childNodes}; + return @result; +} + +sub inflateValue { + my ($this,$value) = @_; + + if ( my $inflator = $this->inflator ) { + return $inflator->new($value); + } else { + return $value; + } } 1;
--- a/Lib/IMPL/DOM/Schema/SimpleType.pm Fri May 07 18:17:40 2010 +0400 +++ b/Lib/IMPL/DOM/Schema/SimpleType.pm Tue May 11 02:42:59 2010 +0400 @@ -25,17 +25,17 @@ sub CTOR { my ($this,%args) = @_; - $this->{$nativeType} = $args{nativeType}; + $this->{$nativeType} = $args{nativeType} if $args{nativeType}; $this->{$messageWrongType} = $args{messageWrongType} || "A simple node '%Node.path%' is expected to be %Schema.nativeType%"; } sub Validate { - my ($this, $node) = @_; + my ($this, $node, $ctx) = @_; if ($this->{$nativeType}) { return new IMPL::DOM::Schema::ValidationError( Node => $node, - Source => $this, + Source => $ctx && $ctx->{Source} || $this, Schema => $this, Message => $this->messageWrongType ) unless $node->isa($this->{$nativeType});
--- a/Lib/IMPL/DOM/Schema/ValidationError.pm Fri May 07 18:17:40 2010 +0400 +++ b/Lib/IMPL/DOM/Schema/ValidationError.pm Tue May 11 02:42:59 2010 +0400 @@ -2,17 +2,21 @@ use strict; use warnings; +use overload + '""' => \&toString, + 'fallback' => 1; + 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 Parent => prop_get; - public _direct property Message => prop_get; + public _direct property Node => prop_get; # target document node (if exists) + public _direct property Schema => prop_get; # a schema for the target node (if exists) + public _direct property Source => prop_get; # a schema which triggered this error (can be equal to the Schema) + public _direct property Parent => prop_get; + public _direct property Message => prop_get; # displayable message } sub CTOR { @@ -25,4 +29,9 @@ $this->{$Message} = FormatMessage(delete $args{Message}, \%args) if $args{Message}; } +sub toString { + (my $this) = @_; + return $this->Message; +} + 1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/DOM/Schema/Validator/Compare.pm Tue May 11 02:42:59 2010 +0400 @@ -0,0 +1,237 @@ +package IMPL::DOM::Schema::Validator::Compare; +use strict; + +use base qw(IMPL::DOM::Schema::Validator); + +use IMPL::Resources::Format qw(FormatMessage); +use IMPL::Class::Property; + +BEGIN { + public property targetProperty => prop_all; + public property op => prop_all; + public property nodePath => prop_get | owner_set; + public property optional => prop_all; + private property _pathTranslated => prop_all; + private property _targetNode => prop_all; + public property message => prop_all; +} + +our %CTOR = ( + 'IMPL::DOM::Schema::Validator' => sub { + my %args = @_; + $args{nodeName} ||= 'Compare'; + %args; + } +); + +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% %Source.op% %Value% (%Source.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*(=|!=|=~|!~)\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 + },\&_resovleProperty) + ) or return 0 foreach @parsedFilters; + + }; + } 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; + + $this->_targetNode($node); + + my $query = $this->_pathTranslated() || $this->_pathTranslated($this->TranslatePath($this->nodePath)); + + my ($foreignNode) = $node->selectPath($query); + + my $Source = $ctx && $ctx->{Source} || $this->parentNode; + + 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, new IMPL::DOM::Schema::ValidationError( + Node => $node, + ForeignNode => $foreignNode, + Value => $value, + Source => $Source, + Schema => $this->parentNode, + Message => $this->message + ) unless $this->op->(_resovleProperty($node,$this->targetProperty),$value); + } elsif (not $this->optional) { + push @result, new IMPL::DOM::Schema::ValidationError( + Node => $node, + Value => '', + Source => $Source, + Schema => $this->parentNode, + Message => $this->message + ); + } + + $this->_targetNode(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]; +} + +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% необходимо задать свойство %Source.name%"/> + <Compare op="eq" nodePath="sibling:*[nodeName eq '%Node.linkedNode%']"/> + </SimpleType> +</schema> + +=begin code xml + +=head1 DESCRIPTION + +Позволяет сравнивать значение текущего узла со значением другого узла. + +=cut \ No newline at end of file
--- a/Lib/IMPL/DOM/Schema/Validator/RegExp.pm Fri May 07 18:17:40 2010 +0400 +++ b/Lib/IMPL/DOM/Schema/Validator/RegExp.pm Tue May 11 02:42:59 2010 +0400 @@ -17,21 +17,22 @@ } sub CTOR { - my ($this) = @_; + my ($this,%args) = @_; - $this->message("A %Node.nodeName% doesn't match to the format %Schema.name%"); + $this->message($args{message} || "A %Node.nodeName% doesn't match to the format %Schema.display%"); } sub Validate { - my ($this,$node) = @_; + my ($this,$node,$ctx) = @_; my $rx = $this->nodeValue; return new IMPL::DOM::Schema::ValidationError( Node => $node, - Source => $this, + Source => ( $ctx && $ctx->{Source} ) || $this->parentNode, Schema => $this->parentNode, Message => $this->message ) unless (not $node->isComplex) and $node->nodeValue =~ /$rx/; + return (); } 1; \ No newline at end of file
--- a/Lib/IMPL/DOM/XMLReader.pm Fri May 07 18:17:40 2010 +0400 +++ b/Lib/IMPL/DOM/XMLReader.pm Tue May 11 02:42:59 2010 +0400 @@ -6,6 +6,9 @@ use IMPL::Class::Property; use IMPL::Class::Property::Direct; use XML::Parser; +require IMPL::DOM::Schema; +require IMPL::DOM::Navigator::Builder; +require IMPL::DOM::Navigator::SimpleBuilder; __PACKAGE__->PassThroughArgs; @@ -44,7 +47,6 @@ $parser->parsefile($in); } - sub _OnBegin { my ($this,$element,%attrs) = @_; @@ -55,8 +57,7 @@ sub _OnEnd { my ($this,$element) = @_; - - $this->{$_current}->nodeValue($this->Navigator->inflateValue( $this->{$_text} ) ) if length $this->{$_text}; + $this->{$_current}->nodeValue($this->Navigator->inflateValue( $this->{$_text}, $this->{$_current} ) ) if length $this->{$_text}; $this->{$_text} = pop @{$this->{$_textHistory}}; $this->{$_current} = $this->Navigator->Back; } @@ -66,6 +67,34 @@ $this->{$_text} .= $val; } +sub LoadDocument { + my ($self,$file,$schema) = @_; + + my $parser; + if ($schema) { + $schema = IMPL::DOM::Schema->LoadSchema($schema) if not ref $schema; + $parser = $self->new( + Navigator => IMPL::DOM::Navigator::Builder->new( + 'IMPL::DOM::Document', + $schema + ) + ); + } else { + $parser = $self->new( + Navigator => IMPL::DOM::Navigator::SimpleBuilder->new() + ); + } + + $parser->ParseFile($file); + my $doc = $parser->Navigator->Document; + if ($schema) { + my @errors = $parser->Navigator->BuildErrors; + push @errors, $schema->Validate($doc); + die new IMPL::Exception("Loaded document doesn't match the schema", @errors) if @errors; + } + return $doc; +} + 1; __END__
--- a/Lib/IMPL/Resources/Format.pm Fri May 07 18:17:40 2010 +0400 +++ b/Lib/IMPL/Resources/Format.pm Tue May 11 02:42:59 2010 +0400 @@ -7,26 +7,33 @@ our @EXPORT_OK = qw(&FormatMessage); sub FormatMessage { - my ($string,$args) = @_; + my ($string,$args,$resolver) = @_; - $string =~ s/%(\w+(?:\.\w+)*)%/_getvalue($args,$1,"\[$1\]")/ge; + $resolver ||= \&_defaultResolver; + + $string =~ s/%(\w+(?:\.\w+)*)%/_getvalue($args,$1,"\[$1\]",$resolver)/ge; return $string; } sub _getvalue { - my ($obj,$path,$default) = @_; + my ($obj,$path,$default,$resolver) = @_; foreach my $chunk (split /\./,$path) { - if (eval { $obj->can( $chunk ) } ) { - $obj = $obj->$chunk(); - } elsif (UNIVERSAL::isa($obj,'HASH')) { + return $default unless $obj; + if (ref $obj eq 'HASH') { $obj = $obj->{$chunk}; } else { - return $default; + $obj = $resolver->($obj,$chunk); } } return $obj; } +sub _defaultResolver { + my ($obj,$prop) = @_; + + return ( eval { $obj->can($prop) } ? $obj->$prop() : undef ); +} + 1;
--- a/_test/temp.pl Fri May 07 18:17:40 2010 +0400 +++ b/_test/temp.pl Tue May 11 02:42:59 2010 +0400 @@ -1,11 +1,7 @@ #!/usr/bin/perl use strict; -local $@; +my $var = " some stuff"; -{ - eval 'die "boolshit"'; - my $e = $@; - - die "msg: $e" if $e; -} \ No newline at end of file +$var =~ tr/f/ome/; +print $var; \ No newline at end of file