Mercurial > pub > Impl
changeset 7:94d47b388442
Улучшены тесты
Исправлены ошибки
Улучшена документация
Работа над схемой DOM
| author | Sergey |
|---|---|
| date | Mon, 24 Aug 2009 01:05:34 +0400 |
| parents | e2cd73ccc5bd |
| children | fffb153be599 |
| files | Lib/IMPL/DOM/FixedNode.pm Lib/IMPL/DOM/Node.pm Lib/IMPL/DOM/Property.pm Lib/IMPL/DOM/Schema/ComplexNode.pm Lib/IMPL/DOM/Schema/Item.pm Lib/IMPL/DOM/Schema/NodeSet.pm Lib/IMPL/DOM/Schema/SimpleNode.pm Lib/IMPL/DOM/Transform/PostToDOM.pm Lib/IMPL/Object/EventSource.pm Lib/IMPL/Transform.pm Lib/IMPL/Tree/Batch.pm Lib/IMPL/Web/TDocument.pm _test/Resources/simple.tt _test/Resources/simple.txt _test/Resources/test.form _test/Test/Web/TDocument.pm _test/Web.t impl.kpf |
| diffstat | 18 files changed, 669 insertions(+), 27 deletions(-) [+] |
line wrap: on
line diff
--- a/Lib/IMPL/DOM/FixedNode.pm Fri Aug 14 16:14:13 2009 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,12 +0,0 @@ -package IMPL::DOM::FixedNode; -use strict; -use warnings; - -use base qw(IMPL::DOM::Node); - -sub Validate { - -} - - -1;
--- a/Lib/IMPL/DOM/Node.pm Fri Aug 14 16:14:13 2009 +0400 +++ b/Lib/IMPL/DOM/Node.pm Mon Aug 24 01:05:34 2009 +0400 @@ -61,6 +61,29 @@ } } +sub replaceNodeAt { + my ($this,$index,$node) = @_; + + my $nodeOld = $this->childNodes->[$index]; + + die new IMPL::InvalidOperationException("You can't insert the node to itselft") if $this == $node; + + # unlink node from previous parent + $node->{$parentNode}->removeNode($node) if ($node->{$parentNode}); + + # replace (or set) old node + $this->childNodes->[$index] = $node; + + # save new parent + $node->_setParent( $this ); + + # unlink old node if we have one + $nodeOld->{$parentNode} = undef if $nodeOld; + + # return old node + return $nodeOld; +} + sub removeAt { my ($this,$pos) = @_; @@ -80,6 +103,10 @@ return wantarray ? @result : \@result; } +sub firstChild { + @_ >=2 ? $_[0]->replaceNodeAt(0,$_[1]) : $_[0]->childNodes->[0]; +} + sub _getIsComplex { $_[0]->childNodes->Count ? 1 : 0; }
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/DOM/Property.pm Mon Aug 24 01:05:34 2009 +0400 @@ -0,0 +1,73 @@ +package IMPL::DOM::Property; +use strict; +use warnings; + +use IMPL::Class::Property; +require IMPL::Exception; + +use base qw(Exporter); +our @EXPORT_OK = qw(_dom); + +sub _dom($) { + my ($prop_info) = @_; + $prop_info->Implementor( 'IMPL::DOM::Property' ); + return $prop_info; +} + +sub Make { + my ($self,$propInfo) = @_; + + my ($class,$name,$virt,$access,$mutators) = $propInfo->get qw(Class Name Virtual Access Mutators); + + die new IMPL::InvalidOperationException("DOM properties can be declared only for the DOM objects") unless $class->isa('IMPL::DOM::Node'); + + no strict 'refs'; + die new IMPL::InvalidOperationException("Custom mutators are not allowed","${class}::$name") if ref $mutators; + if (($mutators & prop_all) == prop_all) { + *{"${class}::$name"} = sub { + $_[0]->Property($name,@_[1..$#_]); + }; + $propInfo->canGet(1); + $propInfo->canSet(1); + } elsif( $mutators & prop_get ) { + *{"${class}::$name"} = sub { + die new IMPL::InvalidOperationException("This is a readonly property", "${class}::$name") if @_>1; + $_[0]->Property($name); + }; + $propInfo->canGet(1); + $propInfo->canSet(0); + } elsif( $mutators & prop_set ) { + *{"${class}::$name"} = sub { + die new IMPL::InvalidOperationException("This is a writeonly property", "${class}::$name") if @_<2; + $_[0]->Property($name,@_[1..$#_]); + }; + $propInfo->canGet(0); + $propInfo->canSet(1); + } else { + die new IMPL::InvalidOperationException("Invalid value for the property mutators","${class}::$name",$mutators); + } +} + +1; +__END__ +=pod + +=head1 SYNOPSIS + +package TypedNode; + +use base qw(IMPL::DOM::Node); +use IMPL::DOM::Property qw(_dom); + +BEGIN { + public _dom property Age => prop_all; + public _dom property Address => prop_all; + public property ServiceData => prop_all; +} + +=head1 DESCRIPTION + + , +. + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/DOM/Schema/ComplexNode.pm Mon Aug 24 01:05:34 2009 +0400 @@ -0,0 +1,79 @@ +package IMPL::DOM::Schema::ComplexNode; +use strict; +use warnings; + +use base qw(IMPL::DOM::Schema::Item); +use IMPL::Class::Property; + +BEGIN { + public property nodeType => prop_all; + public property content => { + get => \&_getContent, + set => \&_setContent + } +} + +__PACKAGE__->PassThroughArgs; + +sub _getContent { + $_[0]->firstChild; +} + +sub _setContent { + $_[0]->firstChild($_[1]); +} + +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}; + + if (@errors and $this->Message) { + return { + Error => 1, + Message => $this->formatMessage($node), + InnerErrors => \@errors + }; + } else { + return @errors; + } + } +} + +1; + +__END__ + +=pod + +=head1 DESCRIPTION + + . , +. + + .. + , . C<content> + +=head2 PROPERTIES + +=over + +=item C<nodeType> + + , . + C<content> . + +=item C<content> + + , C<IMPL::DOM::Schema::NodeSet> +C<IMPL::DOM::Schema::NodeList>, . + . + +=back + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/DOM/Schema/Item.pm Mon Aug 24 01:05:34 2009 +0400 @@ -0,0 +1,44 @@ +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/NodeSet.pm Mon Aug 24 01:05:34 2009 +0400 @@ -0,0 +1,71 @@ +package IMPL::DOM::Schema::NodeSet; +use strict; +use warnings; + +use base qw(IMPL::DOM::Schema::Item); +use IMPL::Class::Property; + +BEGIN { + public property UnexpectedMessage => prop_all; + public property MaxMessage => prop_all; + public property MinMessage => prop_all; +} + +sub Validate { + my ($this,$node) = @_; + + my @errors; + + my %nodes = map { + $_->nodeName , + {Schema => $_, Min => $_->minOccur, Max => $_->maxOccur, Seen => 0 } + } @{$this->childNodes}; + + foreach my $child ( @{$node->childNodes} ) { + if (my $info = $nodes{$child->nodeName}) { + $info->{Seen}++; + push @errors,{ + Error => 1, + Source => $this, + Node => $child, + Message => $this->MaxMessage + } if ($info->{Seen} > $info->{Max}); + + push @errors,$info->{Schema}->Validate($child); + } else { + push @errors, { + Error => 1, + Source => $this, + Node => $child, + Message => $this->UnexpectedMessage + } + } + } + + foreach my $info (values %nodes) { + push @errors, { + Error => 1, + Source => $this, + Message => $this->MinMessage + } if $info->{Min} > $info->{Seen}; + } + + return @errors; +} + +1; + +__END__ + +=pod + +=head1 DESCRIPTION + + . . + C<IMPL::DOM::Schema::ComplexNode> C<IMPL::DOM::Schema::SimpleNode>. + + , + , + . + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/DOM/Schema/SimpleNode.pm Mon Aug 24 01:05:34 2009 +0400 @@ -0,0 +1,21 @@ +package IMPL::DOM::Schema::SimpleNode; +use strict; +use warnings; + +use base qw(IMPL::DOM::Schema::Item); + +__PACKAGE__->PassThroughArgs; + +1; + +__END__ + +=pod + +=head1 DESCRIPTION + + . + . + + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/DOM/Transform/PostToDOM.pm Mon Aug 24 01:05:34 2009 +0400 @@ -0,0 +1,36 @@ +package IMPL::DOM::Post2DOM; +use strict; +use warnings; + +use IMPL::DOM::Navigator; +use IMPL::Class::Property; + +use base qw(IMPL::Transform); + +BEGIN { + public property Navigator => prop_get | owner_set; +} + +our %CTOR = ( + 'IMPL::Transform' => sub { + return ( + HASH => \&TransfromPostData + ); + } +); + +sub TransformPostData { + my ($this,$data) = @_; + + my $navi = $this->Navigator; + + while (my ($key,$value) = each %$data) { + my $node = $navi->Navigate($key); + $node->nodeValue($value); + } + + return $navi->Document; +} + + +1;
--- a/Lib/IMPL/Object/EventSource.pm Fri Aug 14 16:14:13 2009 +0400 +++ b/Lib/IMPL/Object/EventSource.pm Mon Aug 24 01:05:34 2009 +0400 @@ -51,7 +51,7 @@ no strict 'refs'; *{"${class}::$event"} = sub { - my $class = shift; + shift; if (not @_) { if (not defined wantarray and caller(1) eq $class) { $globalEventTable->Invoke($class); @@ -59,7 +59,7 @@ return $globalEventTable; } } else { - $globalEventTable->Invoke(@_); + $globalEventTable->Invoke($class,@_); } }; } @@ -131,3 +131,63 @@ return delete $this->{$Handlers}{$id}; } 1; + +__END__ +=pod +=head1 SYNOPSIS +package Foo; +use base qw(IMPL::Object IMPL::Object::EventSource); + +# declare events +__PACKAGE__->CreateEvent('OnUpdate'); +__PACKAGE__->CreateStaticEvent('OnNewObject'); + +sub CTOR { + my $this = shift; + // rise static event + $this->OnNewObject(); +} + +sub Update { + my ($this,$val) = @_; + + // rise object event + $this->OnUpdate($val); +} + +package Bar; + +// subscribe static event +Foo->OnNewObject->Subscribe(sub { warn "New $_[0] created" } ); + +sub LookForFoo { + my ($this,$foo) = @_; + + // subscribe object event + $foo->OnUpdate->Subscribe($this,'OnFooUpdate'); +} + +// event handler +sub OnFooUpdate { + my ($this,$sender,$value) = @_; +} + +=head1 DESCRIPTION + . +. + . + , , . + + ( ) +. , + ( ). + , + . + +=head1 METHODS +=level 4 +=back + +=head1 EventTable + +=cut \ No newline at end of file
--- a/Lib/IMPL/Transform.pm Fri Aug 14 16:14:13 2009 +0400 +++ b/Lib/IMPL/Transform.pm Mon Aug 24 01:05:34 2009 +0400 @@ -1,5 +1,5 @@ package IMPL::Transform; -use base qw(IMPL::Object IMPL::Object::Autofill); +use base qw(IMPL::Object); use IMPL::Class::Property; use IMPL::Class::Property::Direct; @@ -10,7 +10,14 @@ protected _direct property Plain => prop_all; } -__PACKAGE__->PassThroughArgs; +sub CTOR { + my ($this,%args) = @_; + + $this->{$Plain} = delete $args{-plain}; + $this->{$Default} = delete $args{-default}; + + $this->{$Templates} = \%args; +} sub Transform { my ($this,$object) = @_; @@ -56,9 +63,19 @@ DocClass => sub { my ($this,$object) = @_; return new DocPreview(Author => $object->Author, Text => $object->Data); + }, + -default => sub { + my ($this,$object) = @_; + return $object; + }, + -plain => sub { + my ($this,$object) = @_; + return $object; } ); +my $result = $t->Transform($obj); + =head1 Summary .
--- a/Lib/IMPL/Tree/Batch.pm Fri Aug 14 16:14:13 2009 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3 +0,0 @@ -package IMPL::Tree::Batch; -use strict; -use base qw(IMP::Object); \ No newline at end of file
--- a/Lib/IMPL/Web/TDocument.pm Fri Aug 14 16:14:13 2009 +0400 +++ b/Lib/IMPL/Web/TDocument.pm Mon Aug 24 01:05:34 2009 +0400 @@ -2,26 +2,144 @@ use strict; use warnings; -use base qw(IMPL::DOM::Node); +use base qw(IMPL::DOM::Node IMPL::Object::Disposable); use Template::Context; use Template::Provider; use IMPL::Class::Property; use File::Spec; BEGIN { - public property Templates => prop_get | owner_set; - public property Context => prop_get | owner_set; + private property _Provider => prop_all; + private property _Context => prop_all; + public property Template => prop_get | owner_set; } our %CTOR = ( 'IMPL::DOM::Node' => sub { nodeName => 'document' } ); -sub load { - my ($this,$file) = @_; +sub Provider { + my ($this,%args) = @_; + + if (my $provider = $this->_Provider) { + return $provider; + } else { + return $this->_Provider(new Template::Provider( + \%args + )); + } +} + +sub Context { + my ($this) = @_; + + if (my $ctx = $this->_Context) { + return $ctx; + } else { + return $this->_Context ( + new Template::Context( + VARIABLES => { + document => $this + }, + TRIM => 1, + RECURSION => 1, + LOAD_TEMPLATES => [$this->Provider] + ) + ) + } +} + +sub loadFile { + my ($this,$filePath,$encoding) = @_; + + die new IMPL::InvalidArgumentException("A filePath parameter is required") unless $filePath; - $file = File::Spec->rel2abs($file); + $encoding ||= 'utf8'; + + $this->_Context(undef); + $this->_Provider(undef); + + my ($vol,$dir,$fileName) = File::Spec->splitpath($filePath); + + my $inc = File::Spec->catpath($vol,$dir,''); + + $this->Provider( + ENCODING => $encoding, + INTERPOLATE => 1, + PRE_CHOMP => 1, + POST_CHOMP => 1, + INCLUDE_PATH => $inc + ); + $this->Template($this->Context->template($fileName)); +} + +sub Title { + $_[0]->Template->Title; +} + +sub Render { + my ($this) = @_; + + return $this->Template->process($this->Context); +} + +sub Dispose { + my ($this) = @_; + + $this->Template(undef); + $this->_Context(undef); + $this->_Provider(undef); + + $this->SUPER::Dispose(); } 1; +__END__ +=pod + +=head1 SYNOPSIS + +// create new document +my $doc = new IMPL::Web::TDocument; + +// load template +$doc->loadFile('Templates/index.tt'); + +// render file +print $doc->Render(); + +=head1 DESCRIPTION + +, Template::Toolkit. , + . C<IMPL::DOM::Node>, +.. DOM . + + C<document> . + , + C<Dispose> . + +=head1 METHODS + +=level 4 + +=item C<new()> + + + +=item C<$doc->loadFile($fileName,$encoding)> + + C<$fileName>, C<$encoding>. + , utf-8. + +=item C<$doc->Render()> + + . + +=item C<$doc->Dispose()> + + . + +=back + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/_test/Resources/simple.tt Mon Aug 24 01:05:34 2009 +0400 @@ -0,0 +1,2 @@ +[% META Title = " 1" %] + $document.Title \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/_test/Resources/simple.txt Mon Aug 24 01:05:34 2009 +0400 @@ -0,0 +1,1 @@ + 1 \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/_test/Resources/test.form Mon Aug 24 01:05:34 2009 +0400 @@ -0,0 +1,9 @@ +<form> + <name>Peter</name> + <passport> + <code>sssddd-ffd-ssd</code> + </passport> + <passport> + <code></code> + </passport> +</form> \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/_test/Test/Web/TDocument.pm Mon Aug 24 01:05:34 2009 +0400 @@ -0,0 +1,34 @@ +package Test::Web::TDocument; +use strict; +use warnings; +use encoding 'cp1251'; + +use base qw(IMPL::Test::Unit); +use IMPL::Test qw(test failed); +use IMPL::Web::TDocument; +__PACKAGE__->PassThroughArgs; + +test Creation => sub { + my $document = new IMPL::Web::TDocument(); + + failed "Failed to create document" unless $document; +}; + +test SimpleTemplate => sub { + my $document = new IMPL::Web::TDocument(); + + failed "Failed to create document" unless $document; + + $document->loadFile('Resources/simple.tt','cp1251'); + + my $out = $document->Render; + + open my $hFile,'<:encoding(cp1251)',"Resources/simple.txt" or die "Failed to open etalon file: $!"; + local $/; + my $eta = <$hFile>; + + failed "Rendered data doesn't match the etalon data","Expected:\n$eta","Actual:\n$out" if $out ne $eta; +}; + + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/_test/Web.t Mon Aug 24 01:05:34 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::Web::TDocument +); + +$plan->AddListener(new IMPL::Test::TAPListener); +$plan->Prepare(); +$plan->Run();
--- a/impl.kpf Fri Aug 14 16:14:13 2009 +0400 +++ b/impl.kpf Mon Aug 24 01:05:34 2009 +0400 @@ -3,8 +3,6 @@ <project id="66c7d414-175f-45b6-92fe-dbda51c64843" kpf_version="4" name="impl.kpf"> <file id="c255e877-43b0-4625-a9f2-fbf8e65179c8" idref="66c7d414-175f-45b6-92fe-dbda51c64843/Lib/IMPL/DOM" name="Node.pm" url="Lib/IMPL/DOM/Node.pm"> </file> -<file id="91cab186-0c9b-4ed6-98e8-3de5c132e296" idref="66c7d414-175f-45b6-92fe-dbda51c64843/Lib/IMPL/Object" name="Node.pm" url="Lib/IMPL/DOM/Node.pm"> -</file> <preference-set idref="155f1fd9-8a20-46fe-90d5-8fbe879632d8"> <preference-set id="Invocations"> <preference-set id="default"> @@ -120,6 +118,32 @@ </preference-set> </preference-set> </preference-set> +<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/Lib/IMPL/DOM/Schema/Item.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/Item.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/Object.pm"> <preference-set id="Invocations"> <preference-set id="default"> @@ -146,6 +170,32 @@ </preference-set> <string id="lastInvocation">default</string> </preference-set> +<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/_test/Web.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/Web.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/object.t"> <preference-set id="Invocations"> <preference-set id="default">