Mercurial > pub > Impl
changeset 18:818c74b038ae
DOM Schema + tests
author | Sergey |
---|---|
date | Thu, 10 Sep 2009 17:42:47 +0400 |
parents | 7f88e01b58f8 |
children | 1ca530e5c9c5 |
files | Lib/IMPL/DOM/Document.pm Lib/IMPL/DOM/Navigator.pm Lib/IMPL/DOM/Navigator/SchemaNavigator.pm Lib/IMPL/DOM/Node.pm Lib/IMPL/DOM/Schema.pm Lib/IMPL/DOM/Schema/ComplexNode.pm Lib/IMPL/DOM/Schema/Item.pm Lib/IMPL/DOM/Schema/Node.pm Lib/IMPL/Object/List.pm Lib/IMPL/Resources/Format.pm _test/DOM.t _test/Resources.t _test/Test/DOM/Node.pm _test/Test/Resources/Format.pm _test/any.pl _test/run_tests.pl impl.kpf |
diffstat | 17 files changed, 472 insertions(+), 78 deletions(-) [+] |
line wrap: on
line diff
--- a/Lib/IMPL/DOM/Document.pm Wed Sep 09 17:43:31 2009 +0400 +++ b/Lib/IMPL/DOM/Document.pm Thu Sep 10 17:42:47 2009 +0400 @@ -24,6 +24,14 @@ =head1 DESCRIPTION +=head1 METHODS + +=over + +=item C<<$doc->Create>> + Создает узел определеннго типа с определенным именем и свойствами. +=back + =cut \ No newline at end of file
--- a/Lib/IMPL/DOM/Navigator.pm Wed Sep 09 17:43:31 2009 +0400 +++ b/Lib/IMPL/DOM/Navigator.pm Thu Sep 10 17:42:47 2009 +0400 @@ -27,6 +27,20 @@ } } +sub _NavigateNode { + my ($this,$newNode) = @_; + push @{$this->{$Path}}, $this->{$Current}; + return $this->{$Current} = $newNode; +} + +sub _NavigateNodeStirct { + my ($this,$newNode) = @_; + + 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; +} + sub Back { my ($this) = @_;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/DOM/Navigator/SchemaNavigator.pm Thu Sep 10 17:42:47 2009 +0400 @@ -0,0 +1,46 @@ +package IMPL::DOM::Navigator::SchemaNavigator; +use strict; +use warnings; + +use base qw(IMPL::DOM::Navigator); +use IMPL::Class::Property; +use IMPL::Class::Property::Direct; + +__PACKAGE__->PassThroughArgs; + +BEGIN { + public _direct property Schema => prop_get; +} + +sub CTOR { + my ($this,$schema) = @_; + + $this->{$Schema} = $schema; + + die new IMPL::InvalidArgumentException("A schema object is required") unless $schema->isa('IMPL::DOM::Schema'); +} + +sub Navigate { + my ($this,$query) = @_; + + if (my ($newNode) = $this->Current->selectNodes($query)) { + if (ref $newNode eq 'IMPL::DOM::Schema::Node') { + $newNode = $this->{$Schema}->ResolveType($newNode->type) || $newNode; + } + return $this->_NavigateNode($newNode); + } else { + return undef; + } +} + +1; +__END__ + +=pod + +=head1 DESCRIPTION + +Навигатор для схемы, отличается от стандартного тем, что переходит по ссылкам вида <Node nodeName="SomeName" type="ReferencedType"/>. +При этом имя узла в который перешли будет отличаться от указанного в поисковом критерии. + +=cut \ No newline at end of file
--- a/Lib/IMPL/DOM/Node.pm Wed Sep 09 17:43:31 2009 +0400 +++ b/Lib/IMPL/DOM/Node.pm Thu Sep 10 17:42:47 2009 +0400 @@ -17,13 +17,15 @@ public _direct property nodeValue => prop_all; public _direct property childNodes => { get => \&_getChildNodes }; public _direct property parentNode => prop_get ; - private _direct property _propertyMap => prop_get ; + public _direct property rootNode => { get => \&_getRootNode}; + private _direct property _propertyMap => prop_all ; } sub CTOR { my ($this,%args) = @_; $this->nodeName($args{nodeName}) or die new IMPL::InvalidArgumentException("A name is required"); + $this->nodeValue($args{nodeValue}); } sub insertNode { @@ -47,7 +49,8 @@ $node->{$parentNode}->removeNode($node) if ($node->{$parentNode}); - $this->childNodes->Append($node); + my $children = $this->childNodes; + $children->Append($node); $node->_setParent( $this ); @@ -73,7 +76,7 @@ my ($this) = @_; $this->{$childNodes} = new IMPL::Object::List() unless $this->{$childNodes}; - $this->{$childNodes}; + return $this->{$childNodes}; } sub removeNode { @@ -81,8 +84,8 @@ if ($this == $node->{$parentNode}) { $this->childNodes->RemoveItem($node); - $node->{$parentNode} = undef; - return $this; + $node->_setParent(undef); + return $node; } else { die new IMPL::InvalidOperationException("The specified node isn't belong to this node"); } @@ -101,11 +104,11 @@ # replace (or set) old node $this->childNodes->[$index] = $node; - # save new parent + # set new parent $node->_setParent( $this ); # unlink old node if we have one - $nodeOld->{$parentNode} = undef if $nodeOld; + $nodeOld->_setParent(undef) if $nodeOld; # return old node return $nodeOld; @@ -115,21 +118,64 @@ my ($this,$pos) = @_; if ( my $node = $this->childNodes->RemoveAt($pos) ) { - $node->{$parentNode} = undef; + $node->_setParent(undef); + return $node; + } else { + return undef; + } +} + +sub removeLast { + my ($this) = @_; + + if ( my $node = $this->{$childNodes} ? $this->{$childNodes}->RemoveLast() : undef) { + $node->_setParent(undef); return $node; } else { return undef; } } +sub removeSelected { + my ($this,$query) = @_; + + my @newSet; + my @result; + + if (ref $query eq 'CODE') { + &$query($_) ? push @result, $_ : push @newSet, $_ foreach @{$this->childNodes}; + } elsif (defined $query) { + $_->nodeName eq $query ? push @result, $_ : push @newSet, $_ foreach @{$this->childNodes}; + } else { + my $children = $this->childNodes; + $_->_setParent(undef) foreach @$children; + delete $this->{$childNodes}; + return wantarray ? @$children : $children; + } + + $_->_setParent(undef) foreach @result; + + $this->{$childNodes} = @newSet ? bless \@newSet ,'IMPL::Object::List' : undef; + + return wantarray ? @result : \@result; +} + sub selectNodes { my ($this,$query) = @_; + my @result; if (ref $query eq 'CODE') { @result = grep &$query($_), @{$this->childNodes}; + } elsif (defined $query) { + @result = grep $_->nodeName eq $query, @{$this->childNodes}; } else { - @result = grep $_->nodeName eq $query, @{$this->childNodes}; + if (wantarray) { + return @{$this->childNodes}; + } else { + @result = $this->childNodes; + return \@result; + } } return wantarray ? @result : \@result; @@ -143,18 +189,49 @@ $_[0]->childNodes->Count ? 1 : 0; } +sub _getRootNode { + $_[0]->{$rootNode} || $_[0]; +} + +sub _updateRootRefs { + my ($this) = @_; + + if ( my $newRoot = $this->{$parentNode} ? $this->{$parentNode}->rootNode : undef) { + if ($this->{$rootNode} ? $this->{$rootNode} != $newRoot : 1 ) { + $this->{$rootNode} = $newRoot; + weaken($this->{$rootNode}); + if ($this->{$childNodes}) { + $_->_updateRootRefs foreach @{$this->{$childNodes}}; + } + } + } elsif($this->{$rootNode}) { + delete $this->{$rootNode}; + if ($this->{$childNodes}) { + $_->_updateRootRefs foreach @{$this->{$childNodes}}; + } + } +} + sub _setParent { my ($this,$node) = @_; - $this->{$parentNode} = $node; - # prevent from creating cyclicreferences - weaken($this->{$parentNode}); + + if (($node || 0) != ($this->{$parentNode} || 0)) { + if ($node) { + $this->{$parentNode} = $node; + # prevent from creating cyclicreferences + weaken($this->{$parentNode}); + } else { + delete $this->{$parentNode}; + } + $this->_updateRootRefs; + } } sub text { my ($this) = @_; - join '', $this->nodeValue, map $_->nodeValue, @{$this->childNodes}; + join '', $this->nodeValue || '', map $_->nodeValue || '', @{$this->childNodes}; } sub Property {
--- a/Lib/IMPL/DOM/Schema.pm Wed Sep 09 17:43:31 2009 +0400 +++ b/Lib/IMPL/DOM/Schema.pm Thu Sep 10 17:42:47 2009 +0400 @@ -16,6 +16,12 @@ $_[0]->{$_TypesMap}->{$_[1]}; } +sub Process { + my ($this) = @_; + + $this->{$_TypesMap} = { map { $_->type, $_ } grep {$_->isa('IMPL::DOM::Schema::Type')} @{$this->childNodes} }; +} + sub MetaSchema { my $schema = new IMPL::DOM::Schema(nodeName => 'schema'); @@ -70,6 +76,8 @@ ) ); + $schema->Process; + return $schema; } @@ -79,6 +87,24 @@ =pod +=head1 DESCRIPTION + +Схема документа. Наследует C<IMPL::DOM::Document> + +=head1 METHODS + +=over + +=item C<< $obj->Process() >> + +Обновляет таблицу типов из содержимого. + +=item C<< $obj->ResolveType($typeName) >> + +Возвращает схему типа c именем C<$typeName>. + +=back + =head1 META SCHEMA Схема для описания схемы, эта схема используется для постороения других схем
--- a/Lib/IMPL/DOM/Schema/ComplexNode.pm Wed Sep 09 17:43:31 2009 +0400 +++ b/Lib/IMPL/DOM/Schema/ComplexNode.pm Thu Sep 10 17:42:47 2009 +0400 @@ -2,7 +2,7 @@ use strict; use warnings; -use base qw(IMPL::DOM::Schema::Item); +use base qw(IMPL::DOM::Schema::Node); use IMPL::Class::Property; BEGIN {
--- a/Lib/IMPL/DOM/Schema/Item.pm Wed Sep 09 17:43:31 2009 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,44 +0,0 @@ -package IMPL::DOM::Schema::Item; -use strict; -use warnings; - -use base qw(IMPL::DOM::Node); -use IMPL::Class::Property; -use IMPL::DOM::Property qw(_dom); -use IMPL::Class::Property::Direct; - -BEGIN { - public _dom property minOccur => prop_all; - public _dom property maxOccur => prop_all; - public _direct property Schema => prop_get; -} - -__PACKAGE__->PassThroughArgs; - -sub CTOR { - my ($this,%args) = @_; - - $this->minOccur($args{minOcuur}); - $this->maxOccur($args{maxOccur}); - $this->{$Schema} = $args{Schema} or die new IMPL::InvalidArgumentException("A schema should be specified"); -} - -1; - -__END__ -=pod - -=head1 SYNOPSIS - -package Restriction; -use base qw(IMPL::DOM::Schema::Item); - -sub Validate { - my ($this,$node) = @_; -} - -=head1 DESCRIPTION - -Базовый класс для элементов схемы. Содержит в себе базовые методы - -=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/DOM/Schema/Node.pm Thu Sep 10 17:42:47 2009 +0400 @@ -0,0 +1,44 @@ +package IMPL::DOM::Schema::Node; +use strict; +use warnings; + +use base qw(IMPL::DOM::Node); +use IMPL::Class::Property; +use IMPL::DOM::Property qw(_dom); +use IMPL::Class::Property::Direct; + +BEGIN { + public _dom property minOccur => prop_all; + public _dom property maxOccur => prop_all; + public _dom property type => prop_all +} + +__PACKAGE__->PassThroughArgs; + +sub CTOR { + my ($this,%args) = @_; + + $this->minOccur($args{minOcuur}); + $this->maxOccur($args{maxOccur}); + $this->type($args{type}); +} + +1; + +__END__ +=pod + +=head1 SYNOPSIS + +package Restriction; +use base qw(IMPL::DOM::Schema::Item); + +sub Validate { + my ($this,$node) = @_; +} + +=head1 DESCRIPTION + +Базовый класс для элементов схемы. Содержит в себе базовые методы + +=cut
--- a/Lib/IMPL/Object/List.pm Wed Sep 09 17:43:31 2009 +0400 +++ b/Lib/IMPL/Object/List.pm Thu Sep 10 17:42:47 2009 +0400 @@ -19,7 +19,7 @@ } sub Append { - push @{$_[0]}, @_{1 .. @$_-1}; + push @{$_[0]}, @_[1 .. $#_]; } sub RemoveLast {
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Resources/Format.pm Thu Sep 10 17:42:47 2009 +0400 @@ -0,0 +1,32 @@ +package IMPL::Resources::Format; +use strict; +use warnings; + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw(&FormatMessage); + +sub FormatMessage { + my ($string,$args) = @_; + + $string =~ s/%(\w+(?:\.\w+)*)%/_getvalue($args,$1,"\[$1\]")/ge; + + return $string; +} + +sub _getvalue { + my ($obj,$path,$default) = @_; + + foreach my $chunk (split /\./,$path) { + if (eval { $obj->can( $chunk ) } ) { + $obj = $obj->$chunk(); + } elsif (UNIVERSAL::isa($obj,'HASH')) { + $obj = $obj->{$chunk}; + } else { + return $default; + } + } + return $obj; +} + +1;
--- a/_test/DOM.t Wed Sep 09 17:43:31 2009 +0400 +++ b/_test/DOM.t Thu Sep 10 17:42:47 2009 +0400 @@ -7,8 +7,8 @@ use IMPL::Test::TAPListener; my $plan = new IMPL::Test::Plan qw( + Test::DOM::Node Test::DOM::Navigator - Test::DOM::Node ); $plan->AddListener(new IMPL::Test::TAPListener);
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/_test/Resources.t Thu Sep 10 17:42:47 2009 +0400 @@ -0,0 +1,15 @@ +#!/usr/bin/perl -w +use strict; +use lib '../Lib'; +use lib '.'; + +use IMPL::Test::Plan; +use IMPL::Test::TAPListener; + +my $plan = new IMPL::Test::Plan qw( + Test::Resources::Format +); + +$plan->AddListener(new IMPL::Test::TAPListener); +$plan->Prepare(); +$plan->Run(); \ No newline at end of file
--- a/_test/Test/DOM/Node.pm Wed Sep 09 17:43:31 2009 +0400 +++ b/_test/Test/DOM/Node.pm Thu Sep 10 17:42:47 2009 +0400 @@ -3,7 +3,7 @@ use warnings; use base qw(IMPL::Test::Unit); -use IMPL::Test qw(test shared failed); +use IMPL::Test qw(test shared failed cmparray); use IMPL::Class::Property; require IMPL::DOM::Node; @@ -20,14 +20,105 @@ $this->Root(new IMPL::DOM::Node(nodeName => 'Root')) or failed "Failed to create a node"; }; +test InsertNode => sub { + my ($this) = @_; + my $child = $this->Root->insertNode(new IMPL::DOM::Node(nodeName => 'Child')) or failed "Failed to insert a child node"; + failed "fiestChild returned incorrect results" unless ($this->Root->firstChild || 0) == $child; +}; + test AppendNode => sub { my ($this) = @_; my $child = $this->Root->appendNode(new IMPL::DOM::Node(nodeName => 'Child')) or failed "Failed to append a child node"; - my $firstChild = $this->Root->firstChild; + my $lastChild = $this->Root->removeLast; + + failed "removeLast returned incorrect results" unless $lastChild == $child; +}; + +test GetRootNode => sub { + my ($this) = @_; + + my $child = $this->Root->firstChild->appendNode(new IMPL::DOM::Node(nodeName => 'GrandChild')) or failed "Failed to append a child node"; + + failed "rootNode is undef" unless $child->rootNode; + failed "rootNode returned incorrect value" unless $child->rootNode == $this->Root; +}; + +test MoveNode => sub { + my ($this) = @_; + + my $grandChild = $this->Root->firstChild->firstChild; + $this->Root->appendNode($grandChild); + + failed "incorrect new parentNode value" unless ($grandChild->parentNode || 0) == $this->Root; + failed "incorrect new rootNode value" unless ($grandChild->rootNode || 0) == $this->Root; +}; + +test AppendRange => sub { + my ($this) = @_; + + my $count = $this->Root->childNodes->Count; + + $this->Root->appendRange( + map IMPL::DOM::Node->new(nodeName => "Item", nodeValue => $_),1..10 + ); + + failed + "Wrong number of a child nodes", + "Expected: ".($count+10), + "Actual: ".$this->Root->childNodes->Count + unless $count + 10 == $this->Root->childNodes->Count; +}; + +test SelectNodes => sub { + my ($this) = @_; - failed "firstChild returned incorrect results" unless $firstChild == $child; + my @result = $this->Root->selectNodes("Item"); + + failed + "Wrong number of a selected nodes", + "Expected: 10", + "Actual: ".scalar(@result) + unless @result == 10; +}; + +test SelectNodesByQuery => sub { + my ($this) = @_; + + my @result = $this->Root->selectNodes(sub { $_[0]->nodeName =~ /child/i } ); + failed + "Wrong number of a selected nodes", + "Expected: 2", + "Actual: ".scalar(@result) + unless @result == 2; +}; + +test CheckNodesValues => sub { + my ($this) = @_; + + my @expected = (1..10); + + my @result = map $_->nodeValue, grep $_->nodeValue, $this->Root->selectNodes("Item"); + + failed + "Some nodes returned wrong node values or in a wrong order", + "Expected: ".join(', ',@expected), + "Recieved: ".join(', ',@result) + unless cmparray(\@expected,\@result); + + failed + "a text property of a root node returned a wrong value", + "Expected: @expected", + "Recieved: ". $this->Root->text + unless $this->Root->text eq join '',@expected; +}; + +test isComplex => sub { + my ($this) = @_; + + failed "property isComplex returned false for the root node" unless $this->Root->isComplex; + failed "property isComplex returned true for a simple node", $this->Root->firstChild->nodeName if $this->Root->firstChild->isComplex; }; 1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/_test/Test/Resources/Format.pm Thu Sep 10 17:42:47 2009 +0400 @@ -0,0 +1,39 @@ +package Test::Resources::Format; +use strict; +use warnings; + +use base qw(IMPL::Test::Unit); +use IMPL::Test qw(test failed); +use IMPL::Resources::Format qw(FormatMessage); + +__PACKAGE__->PassThroughArgs; + +{ + package Args; + use base qw(IMPL::Object); + + sub foo { + return { name => 'Args::foo', value => 'some value'} + } +} + +test FormatMessage => sub { + my $format = 'This is a %name% message. %args.foo.name% has %args.foo.value% and %some.unknown.param%'; + + my $args = { + name => 'Test', + args => new Args() + }; + + my $result = FormatMessage($format,$args); + my $expected = 'This is a Test message. Args::foo has some value and [some.unknown.param]'; + + failed + "Format message returned unexpected results", + "Expected: $expected", + "Recieved: $result" + unless $result eq $expected; +}; + + +1;
--- a/_test/any.pl Wed Sep 09 17:43:31 2009 +0400 +++ b/_test/any.pl Thu Sep 10 17:42:47 2009 +0400 @@ -1,19 +1,10 @@ #!/usr/bin/perl -w -#use strict; +use strict; -use HTML::Element; -$a = HTML::Element->new('a', href => 'http://www.perl.com/'); -$a->push_content("The Perl Homepage"); +my @data = (1,2,3,4); -$tag = $a->tag; -print "$tag starts out as:", $a->starttag, "\n"; -print "$tag ends as:", $a->endtag, "\n"; -print "$tag\'s href attribute is: ", $a->attr('href'), "\n"; +sub func { + return \@data; +} -$links_r = $a->extract_links(); -print "Hey, I found ", scalar(@$links_r), " links.\n"; - -print "And that, as HTML, is: ", $a->as_HTML, "\n"; -$a = $a->delete; - - +print "$_\n" and $data[3]=0 foreach @{func()};
--- a/_test/run_tests.pl Wed Sep 09 17:43:31 2009 +0400 +++ b/_test/run_tests.pl Thu Sep 10 17:42:47 2009 +0400 @@ -2,6 +2,9 @@ use strict; use warnings; +use lib '../Lib'; +use lib '.'; + use IMPL::Test::HarnessRunner; use IMPL::Test::Straps;
--- a/impl.kpf Wed Sep 09 17:43:31 2009 +0400 +++ b/impl.kpf Thu Sep 10 17:42:47 2009 +0400 @@ -248,6 +248,32 @@ </preference-set> <string id="lastInvocation">default</string> </preference-set> +<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/_test/Resources.t"> +<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">_test/Resources.t</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/_test/Test/DOM/Node.pm"> <preference-set id="Invocations"> <preference-set id="default"> @@ -300,6 +326,32 @@ </preference-set> <string id="lastInvocation">default</string> </preference-set> +<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/_test/any.pl"> +<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">_test/any.pl</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/_test/object.t"> <preference-set id="Invocations"> <preference-set id="default">