Mercurial > pub > Impl
changeset 285:546957c50a36
*IMPL::Web::Handler::TTView Reworked template selection mechanism
*IMPL::Web::Application: refactoring
-Removed obsolete IMPL::Text modules
author | cin |
---|---|
date | Mon, 18 Feb 2013 02:55:59 +0400 |
parents | f2a6bc5f3184 |
children | d357b5d85d25 |
files | Lib/IMPL/Test.pm Lib/IMPL/Text/Parser/Builder.pm Lib/IMPL/Text/Parser/Chunk.pm Lib/IMPL/Text/Parser/Player.pm Lib/IMPL/Text/Schema.pm Lib/IMPL/Web/Application.pm Lib/IMPL/Web/Application/Resource.pm Lib/IMPL/Web/Application/ResourceContract.pm Lib/IMPL/Web/CGIApplication.pm Lib/IMPL/Web/Handler/TTView.pm Lib/IMPL/Web/View/TTDocument.pm Lib/IMPL/Web/View/TTLoader.pm _test/Test/Web/ViewSelector.pm _test/Web.t |
diffstat | 14 files changed, 402 insertions(+), 651 deletions(-) [+] |
line wrap: on
line diff
--- a/Lib/IMPL/Test.pm Thu Feb 14 19:14:02 2013 +0400 +++ b/Lib/IMPL/Test.pm Mon Feb 18 02:55:59 2013 +0400 @@ -2,12 +2,13 @@ use strict; use warnings; +use IMPL::lang qw(equals_s); use IMPL::Const qw(:access); require IMPL::Test::SkipException; require Exporter; our @ISA = qw(Exporter); -our @EXPORT_OK = qw(&test &shared &failed &cmparray &skip &run_plan &assert &GetCallerSourceLine); +our @EXPORT_OK = qw(&test &shared &failed &cmparray &skip &run_plan &assert &assertarray &GetCallerSourceLine); require IMPL::Test::Unit; require IMPL::Test::Plan; @@ -54,12 +55,26 @@ return 0 unless @$a == @$b; for (my $i=0; $i < @$a; $i++ ) { - return 0 unless $a->[$i] eq $b->[$i]; + return 0 unless + equals_s($a->[$i], $b->[$i]); } return 1; } +sub assertarray { + my ($a,$b) = @_; + + + die IMPL::Test::FailException->new( + "Assert arrays failed", + _GetSourceLine( (caller)[1,2] ), + join(', ', map defined($_) ? $_ : '<undef>', @$a), + join(', ', map defined($_) ? $_ : '<undef>', @$b) + ) + unless cmparray($a,$b); +} + sub _GetSourceLine { my ($file,$line) = @_;
--- a/Lib/IMPL/Text/Parser/Builder.pm Thu Feb 14 19:14:02 2013 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,7 +0,0 @@ -package IMPL::Text::Parser::Builder; -use strict; -use warnings; - - - -1;
--- a/Lib/IMPL/Text/Parser/Chunk.pm Thu Feb 14 19:14:02 2013 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,92 +0,0 @@ -package IMPL::Text::Parser::Chunk; -use strict; -use warnings; - -use parent qw(IMPL::Object IMPL::Object::Autofill); - -use IMPL::Class::Property; - -use constant { - OP_REGEXP => 1, - OP_STRING => 2, - OP_REFERENCE => 3, - OP_CHUNK => 4, - OP_SWITCH => 5, - OP_REPEAT => 7 -}; - -BEGIN { - public _direct property chunkName => prop_get; - public _direct property opStream => prop_get; -} - -sub Regexp { - my ($this,$rx) = @_; - - if (ref $rx eq 'Regexp') { - - } elsif (not ref $rx) { - $rx = q/$rx/; - } else { - die new IMPL::InvalidArgumentException('A regular expression required'); - } - - push @{$this->{$opStream}}, [OP_REGEXP, $rx]; -} - -sub String { - my ($this,$str) = @_; - - die new IMPL::InvalidArgumentException("A simple value is required") if ref $str; - - push @{$this->{$opStream}}, [OP_STRING, $str]; -} - -sub Reference { - my ($this,$ref) = @_; - - die new IMPL::InvalidArgumentException("A simple value is reqiured") if ref $ref; - - push @{$this->{$opStream}}, [OP_REFERENCE, $ref]; -} - -sub Chunk { - my ($this,$chunk) = @_; - - die new IMPL::InvalidArgumentException unless UNIVERSAL::isa($chunk,'IMPL::Text::Parser::Chunk'); - - push @{$this->{$opStream}}, [OP_CHUNK, $chunk]; -} - -sub Switch { - my $this = shift; - - push @{$this->{$opStream}}, [OP_SWITCH, @_]; -} - -sub Repeat { - my ($this,$chunk,$min,$max) = @_; - - die new IMPL::InvalidArgumentException unless UNIVERSAL::isa($chunk,'IMPL::Text::Parser::Chunk'); - - push @{$this->{$opStream}}, [OP_REPEAT, $chunk, $min, $max ]; -} - -1; - -__END__ - -=pod - -=head1 DESCRIPTION -Именованный поток операций - -=head1 MEMBERS - -=level - -=item C<<$obj->>> - -=back - -=cut
--- a/Lib/IMPL/Text/Parser/Player.pm Thu Feb 14 19:14:02 2013 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,216 +0,0 @@ -package IMPL::Text::Parser::Player; -use strict; -use warnings; - -use parent qw(IMPL::Object); -use IMPL::Class::Property; - -use IMPL::Text::Parser::Chunk; - -my %opCodesMap = ( - IMPL::Text::Parser::Chunk::OP_REGEXP , &MatchRegexp , - IMPL::Text::Parser::Chunk::OP_STRING , &MatchString , - IMPL::Text::Parser::Chunk::OP_REFERENCE , &MatchReference , - IMPL::Text::Parser::Chunk::OP_CHUNK , &PlayChunk , - IMPL::Text::Parser::Chunk::OP_SWITCH , &MatchSwitch , - IMPL::Text::Parser::Chunk::OP_REPEAT , &MatchRepeat -); - -BEGIN { - private _direct property _data => prop_all; - private _direct property _current => prop_all; - private _direct property _states => prop_all; - private _direct property _document => prop_all; - - public _direct property errorLast => prop_all; - public _direct property Punctuation => prop_all; - public _direct property Delimier => prop_all; -} - -sub CTOR { - my ($this,$document) = @_; - - $this->{$_document} = $document or die new IMPL::InvalidArgumentException("The first parameter must be a document"); -} - -sub LoadString { - my ($this,$string) = @_; - - my $rxDelim = /(\s+|[.,;!-+*~$^&|%()`@\\\/])/; - - my $line = 0; - - $this->{$_data} = [ - map { - $line++; - map { - [$line,$_] - } split $rxDelim, $_ - } split /\n/, $string - ] -} - -sub Play { - my ($this) = @_; -} - -sub PlayChunk { - my ($this,$chunk) = @_; - - my $end = 0; - - my $name = $chunk->chunkName; - - $this->enter($name) if $name; - - foreach my $op ( @{$chunk->opStream} ) { - $this->leave(0) and return $this->error("no more data") if $end; - - $opCodesMap{shift @$op}->(@$op) || return $this->leave(0) ; - $this->moveNext or $end = 1; - } - - return $this->leave(1); -} - -sub MatchRegexp { - my ($this,$rx) = @_; - - $this->{$_current}{token} =~ $rx ? ($this->data() and return 1) : return $this->error("Expected: $rx"); -} - -sub MatchString { - my ($this,$string) = @_; - - $this->{$_current}{token} eq $string ? ($this->data() and return 1) : return $this->error("Expected: $string"); -} - -sub MatchReference { - my ($this,$name) = @_; - - my $chunk = $this->ResolveChunk($name) || return $this->error("Invalid reference: $name"); - return $this->PlayChunk($chunk); -} - -sub MatchSwitch { - my ($this,@chunks) = @_; - - foreach my $chunk (@chunks) { - $this->save; - if ( $this->PlayChunk($chunk) ) { - $this->apply; - return 1; - } else { - $this->restore; - } - } - - return 0; # passthrough last error -} - -sub MatchRepeat { - my ($this,$chunk, $min, $max) = @_; - - my $count = 0; - - $this->save; - while (1) { - $this->save; - if ($this->PlayChunk($chunk)) { - $count ++; - $this->apply; - $this->apply and return 1 if ($count >= $max) - } else { - $this->restore; - $count >= $min ? - ($this->apply() and return 1) : - ($this->restore() and return $this->error("Expected at least $min occurances, got only $count")); - } - } - - # we should never get here - die new IMPL::InvalidOperationException("unexpected error"); -} - -sub moveNext { - my ($this) = @_; - - my $pos = $this->{$_current}{pos}; - - $pos ++; - - if ($pos < @{$this->{$_data}}) { - - $this->{$_current} = { - pos => $pos, - token => $this->{$_data}[$pos][1], - line => $this->{$_data} - }; - - } else { - $this->{$_current} = {}; - return undef; - } -} - -sub ResolveChunk { - my ($this,$name) = @_; -} - -sub save { - my ($this) = @_; - - push @{$this->{$_states}}, $this->{$_current}; -} - -sub restore { - my ($this) = @_; - - $this->{$_current} = pop @{$this->{$_states}}; -} - -sub apply { - my ($this) = @_; - - pop @{$this->{$_states}}; -} - -sub error { - my ($this,$message) = @_; - - $this->{$errorLast} = { - message => $message, - line => $this->{$_current}{line}, - token => $this->{$_current}{token} - }; - - return 0; -} - -sub __debug { - -} -sub enter { - my ($this,$name) = @_; - - #always return true; - return 1; -} - -sub leave { - my ($this,$isEmpty) = @_; - - #always return true; - return 1; -} - -sub data { - my ($this) = @_; - - my $data = $this->{$_current}{token}; - - # always return true; - return 1; -} - -1;
--- a/Lib/IMPL/Text/Schema.pm Thu Feb 14 19:14:02 2013 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,87 +0,0 @@ -package IMPL::Text::Schema; -use strict; -use warnings; - -use parent qw(IMPL::DOM::Schema); - -__PACKAGE__->PassThroughArgs; - -1; - -__END__ - -=pod - -=head1 SINOPSYS - -<schema> - <ComplexNode name="syntax"> - <Node name="Define" type="Statement" minOccur="1" maxOccur="unbounded"> - <Property name="name" type="Word"/> - </Node> - </ComplexNode> - <ComplexType type="Statement" nativeType="IMPL::Text::Schema::Statement"> - <NodeList> - <SwitchNode minOccur="1" maxOccur="unbounded"> - <Node name="Word" type="Word"/> - <Node name="Statement" type="Word"/> - <Node name="Regexp" type="Regexp"/> - <Node name="Switch" type="Switch"/> - <Node name="Repeat" type="List"/> - </SwitchNode> - </NodeList> - </ComplexType> - <SimpleType type="Word" nativeType="IMPL::Text::Schema::Word"/> - <SimpleType type="Regexp" nativeType="IMPL::Text::Schema::Regexp"/> - <ComplexType type="Switch" nativeType="IMPL::Text::Schema::Switch"> - <NodeList> - <SwitchNode minOccur="1" maxOccur="unbounded"> - <Node name="Word" type="Word"/> - <Node name="Statement" type="Word"/> - <Node name="Regexp" type="Regexp"/> - <Node name="Switch" type="Switch"/> - <Node name="Repeat" type="List"/> - </SwitchNode> - </NodeList> - </ComplexType> - <ComplexType type="Repeat" nativeType="IMPL::Text::Schema::Repeat"> - <NodeList> - <SwitchNode minOccur="1" maxOccur="unbounded"> - <Node name="Word" type="Word"/> - <Node name="Statement" type="Word"/> - <Node name="Regexp" type="Regexp"/> - <Node name="Switch" type="Switch"/> - <Node name="Repeat" type="List"/> - </SwitchNode> - </NodeList> - </CoomplexType> -</schema> - -=head1 DESCRIPTION - -Схема текстового файла, которую можно использовать для разбора содержимого -текстового файла. - -Схема текстового файла состоит из выражений. -1. Регулярное выражение является выражением -2. Строковое значение является выражением. -3. Выражения объединенные логическими операторами также выражение. - -Допускаются следующие операторы -1. Повтор -2. Ветвление - -=head1 METHODS - -=over - -=item C<<$schema->compile()>> - -Возвращает объект для разбора текста. - -=back - -=head1 INTERNALS - - -=cut
--- a/Lib/IMPL/Web/Application.pm Thu Feb 14 19:14:02 2013 +0400 +++ b/Lib/IMPL/Web/Application.pm Mon Feb 18 02:55:59 2013 +0400 @@ -13,12 +13,13 @@ HttpResponse => 'IMPL::Web::HttpResponse', TFactory => '-IMPL::Object::Factory', Exception => 'IMPL::Exception', + ArgException => '-IMPL::InvalidArgumentException', InvalidOperationException => '-IMPL::InvalidOperationException', Loader => 'IMPL::Code::Loader' }, base => [ 'IMPL::Config' => '@_', - 'IMPL::Object::Singleton' => '@_' + 'IMPL::Object::Singleton' => undef ], props => [ baseUrl => PROP_RW, @@ -28,7 +29,8 @@ options => PROP_RW, requestCharset => PROP_RW, output => PROP_RW, - location => PROP_RO + location => PROP_RO, + _handler => PROP_RW ] }; @@ -45,40 +47,41 @@ $this->location(Locator->new(base => $this->baseUrl)); } -sub Run { - my ($this) = @_; - - my $handler; - - $handler = _ChainHandler( $_, $handler ) foreach $this->handlers; - - while ( my $query = $this->FetchRequest() ) { - - my $action = $this->actionFactory->new( - query => $query, - application => $this, - ); - - eval { - my $result = $handler->($action); +sub ProcessRequest { + my ($this,$q) = @_; + + die ArgException->new(q => 'A query is required') + unless $q; + + my $handler = $this->_handler; + unless ($handler) { + $handler = _ChainHandler( $_, $handler ) foreach $this->handlers; + $this->_handler($handler); + } + + my $action = $this->actionFactory->new( + query => $q, + application => $this, + ); - die InvalidOperationException->new( -"Invalid handlers result. A reference to IMPL::Web::HttpResponse is expexted." - ) unless eval { $result->isa(HttpResponse) }; + eval { + my $result = $handler->($action); - $result->PrintResponse( $this->output ); - }; - if ($@) { - my $e = $@; + die InvalidOperationException->new("Invalid handlers result. A reference to IMPL::Web::HttpResponse is expexted.") + unless eval { $result->isa(HttpResponse) }; - HttpResponse->InternalError( - type => 'text/plain', - charset => 'utf-8', - body => $e - )->PrintResponse( $this->output ); + $result->PrintResponse( $this->output ); + }; + if ($@) { + my $e = $@; - } - } + HttpResponse->InternalError( + type => 'text/plain', + charset => 'utf-8', + body => $e + )->PrintResponse( $this->output ); + + } } sub _ChainHandler { @@ -127,11 +130,6 @@ } } -sub FetchRequest { - - return; -} - 1; __END__ @@ -140,32 +138,6 @@ =head1 NAME -C<IMPL::Web::Application> Базовай класс для создания экземпляров приложения - -=head1 SYNOPSIS - -=begin code - -use IMPL::require { - App => 'IMPL::Web::Application' -}; - -my $instance = App->spawn(); # will use ./IMPL/Web/Application.xml as configuration - -$instance->Run; - -=end code - -=head1 DESCRIPTION - -Создает экземпляр объекта, который получает и обрабатывает C<HTTP> запрос. -Приложение можно загрузить из C<xml> файла в котором описано состояние свойств, -для этого используется механизм C<IMPL::Serialization>. - -Приложение представлет собой модульную конструкцию, которая состоит из цепочки -обработчиков. Цепочка обработчиков вызывается снизу вверх, при этом каждый -обработчик самостоятельно рекурсивно вызывает следующий (более высокого уровня). - -См. также C<IMPL::Web::CGIApplication> +C<IMPL::Web::Application> Базовай класс для веб-приложения =cut
--- a/Lib/IMPL/Web/Application/Resource.pm Thu Feb 14 19:14:02 2013 +0400 +++ b/Lib/IMPL/Web/Application/Resource.pm Mon Feb 18 02:55:59 2013 +0400 @@ -58,10 +58,33 @@ # в случае, когда один ресурс вызывает HTTP метод другого ресурса, нужно # сохранить оригинальный resourceLocation $action->context->{resourceLocation} ||= $this->location; + + # это свойство специфично только для REST приложений. + # сохранение текущего ресурса не повлечет за собой существенных расходов, + # т.к. они просто освободятся несколько позже. + if(not $action->context->{resource}) { + $action->context->{resource} = $this; + $action->context->{environment} = sub { $this->PrepareEnvironment() }; + } return _InvokeDelegate($operation, $this, $action ); } +sub PrepareEnvironment { + my ($this) = @_; + + my @stack; + my $env = {}; + + for(my $res = $this; $res; $res = $res->parent) { + push @stack,$res if $res->can('SetupEnvironment'); + } + + map $_->SetupEnvironment($env), reverse @stack; + + return $env; +} + # это реализация по умолчанию, базируется информации о ресурсах, содержащийся # в контракте. sub FetchChildResource {
--- a/Lib/IMPL/Web/Application/ResourceContract.pm Thu Feb 14 19:14:02 2013 +0400 +++ b/Lib/IMPL/Web/Application/ResourceContract.pm Mon Feb 18 02:55:59 2013 +0400 @@ -146,12 +146,12 @@ }, contract => ResourceContract->new( verbs => { - get => OperationContract->new( - binding => sub { - my ($resource,$action) = @_; - return $resource->model; - } - ) + # using method references is also possible + get => sub { + my ($resource,$action) = @_; + return $resource->model; + } + } ) }
--- a/Lib/IMPL/Web/CGIApplication.pm Thu Feb 14 19:14:02 2013 +0400 +++ b/Lib/IMPL/Web/CGIApplication.pm Mon Feb 18 02:55:59 2013 +0400 @@ -1,16 +1,12 @@ package IMPL::Web::CGIApplication; use strict; -use IMPL::Const qw(:prop); use IMPL::declare { require => { CGIWrapper => 'IMPL::Web::CGIWrapper' }, base => [ 'IMPL::Web::Application' => '@_' - ], - props => [ - _queryFetched => PROP_RW ] }; @@ -20,18 +16,14 @@ $this->output(\*STDOUT) unless $this->output; } -sub FetchRequest { +sub Run { my ($this) = @_; - return if $this->_queryFetched; - my $query = CGIWrapper->new(); $query->charset($this->requestCharset) if $this->requestCharset; - $this->_queryFetched(1); - - return $query; + $this->ProcessRequest($query); } 1; \ No newline at end of file
--- a/Lib/IMPL/Web/Handler/TTView.pm Thu Feb 14 19:14:02 2013 +0400 +++ b/Lib/IMPL/Web/Handler/TTView.pm Mon Feb 18 02:55:59 2013 +0400 @@ -2,6 +2,7 @@ use strict; use List::Util qw(first); +use IMPL::lang; use IMPL::Const qw(:prop); use IMPL::declare { require => { @@ -20,18 +21,16 @@ contentType => PROP_RO, contentCharset => PROP_RO, loader => PROP_RO, - selectors => PROP_RO | PROP_LIST, + selectors => PROP_RO, defaultDocument => PROP_RW, - indexResource => PROP_RW, - _selectorsCache => PROP_RW, - _classTemplates => PROP_RW + _selectorsCache => PROP_RW ] }; sub CTOR { my ($this) = @_; - $this->indexResource('index') unless $this->indexResource; + $this->_selectorsCache([ map $this->ParseRule($_), @{$this->selectors || []} ]); } sub Invoke { @@ -53,6 +52,7 @@ model => $model, action => $action, app => $action->application, + env => _cached($action->context->{environment}), ImportClass => sub { my $class = shift; @@ -83,176 +83,158 @@ ); } -sub SelectView { - my ( $this, $action, $class ) = @_; - - my @path = split /\//, $action->query->path_info(), -1; +sub _cached { + my $arg = shift; - shift @path; # remove always empty leading segment - - $this->BuildCache unless $this->_selectorsCache; - my $cache = $this->_selectorsCache; - - @path = reverse @path; - - foreach - my $subclass ( $class ? ( _GetHierarchy($class), '-default' ) : '-default' ) - { - my @results; - push @results, - { result => $this->_classTemplates->{$subclass}, level => 0 } - if $this->_classTemplates->{$subclass}; - - if ( $cache->{$subclass} ) { - my $alternatives = - [ { selector => $cache->{$subclass}, immediate => 1 } ]; - $alternatives = - $this->MatchAlternatives( $_, $alternatives, \@results ) - foreach @path; - } - - if (@results) { - @results = sort { $b->{level} <=> $a->{level} } @results; - return ( shift @results )->{result}; - } - } - - return $this->defaultDocument; -} - -sub _GetHierarchy { - my ($class) = @_; - return unless $class; - - no strict 'refs'; - - return $class, map { _GetHierarchy($_) } @{"${class}::ISA"}; -} - -sub BuildCache { - my ($this) = @_; - - my @selectors; - - my $cache = $this->_selectorsCache( {} ); - $this->_classTemplates( {} ); - - foreach my $selector ( $this->selectors ) { - if ( not ref $selector ) { - - my ( $path, $data ) = split( /\s*=>\s*/, $selector ); - - my @path = split( /\s+/, $path ); - - my $class; - - # if this selector has a class part - if ( $path[$#path] =~ m/^\@(.*)/ ) { - $class = $1; - pop @path; - } - else { - $class = '-default'; - } - - #if this selector has a path - if (@path) { - @path = reverse @path; - my $last = pop @path; - my $t = ( $cache->{$class} ||= {} ); - my $level = 1; - foreach my $prim (@path) { - $t = ( $t->{$prim}->{next} ||= {} ); - $level++; - } - $t->{$last}->{level} = $level; - $t->{$last}->{data} = $data; - - } - else { - - # we dont have a selector, only class - - $this->_classTemplates->{$class} = $data; - } - - } + return $arg unless ref $arg eq 'CODE'; + + return sub { + ref $arg eq 'CODE' ? $arg = &$arg() : $arg; } } -sub MatchAlternatives { - my ( $this, $segment, $alternatives, $results ) = @_; +sub SelectView { + my ($this,$action) = @_; + + my @path; + + for(my $r = $action->context->{resource}; $r ; $r = $r->parent ) { + unshift @path, { + name => $r->id, + class => typeof($r->model) + }; + } + + @path = map { name => $_}, split /\/+/, $action->query->path_info() + unless (@path); + + return $this->MatchPath(\@path,$this->_selectorsCache) || $this->defaultDocument; +} +sub ParseRule { + my ($this, $rule) = @_; + + my ($selector,$data) = split /\s+=>\s+/, $rule; + + my @parts; + my $first = 1; + my $weight = 0; + foreach my $part ( split /\//, $selector ) { + # если первым символом является / + # значит путь в селекторе абсолютный и не нужно + # добавлять "любой" элемент в начало + + if($part) { + $weight ++; + push @parts,{ any => 1 } if $first; + } else { + push @parts,{ any => 1 } unless $first; + next; + } + + my ($name,$class) = split /@/, $part; + + if ( my ( $varName, $rx ) = ( $name =~ m/^\{(?:(\w+)\:)?(.*)\}$/ ) ) { + #this is a regexp + + push @parts, { + rx => $rx, + var => $varName, + class => $class, + }; + } else { + push @parts, { + name => length($name) ? $name : undef, + class => $class, + }; + } + } continue { + $first = 0; + } + + return { selector => \@parts, data => $data, weight => $weight }; +} + +sub MatchPath { + my ($this,$path,$rules) = @_; + + $path ||= []; + $rules ||= []; + my @next; - foreach my $alt (@$alternatives) { - while ( my ( $selector, $match ) = each %{ $alt->{selector} } ) { + foreach my $segment (@$path) { + foreach my $rule (@$rules) { + my @selector = @{$rule->{selector}}; + + my $part = shift @selector; - my $context = { - vars => \%{ $alt->{vars} || {} }, - selector => $match->{next} - }; - - if ( $selector =~ s/^>// ) { - $context->{immediate} = 1; - } + if ($part->{any}) { + #keep the rule for the next try + push @next, $rule; - if ( my ( $name, $rx ) = - ( $selector =~ m/^\{(?:(\w+)\:)?(.*)\}$/ ) ) - { - - #this is a regexp - - if ( my @captures = ( $segment =~ m/($rx)/ ) ) { - $context->{success} = 1; - - if ($name) { - $context->{vars}->{$name} = \@captures; - } + $part = shift @selector while $part->{any}; + } + + # if this rule doesn't have a selector + next unless $part; + + my $newRule = { + selector => \@selector, + data => $rule->{data}, + weight => $rule->{weight}, + vars => { %{$rule->{vars} || {}} } + }; + + my $success = 1; + if (my $class = $part->{class}) { + $success = isclass($segment->{class},$class); + } + + if($success && (my $name = $part->{name})) { + $success = $segment->{name} eq $name; + } elsif ($success && (my $rx = $part->{rx})) { + if( my @captures = ($segment->{name} =~ m/($rx)/) ) { + $newRule->{vars}->{$part->{var}} = \@captures + if $part->{var}; + } else { + $success = 0; } } - else { - - #this is a segment name - if ( $segment eq $selector ) { - $context->{success} = 1; - } + + push @next, $newRule if $success; + + } + $rules = [@next]; + undef @next; + } + + my $result = ( + sort { + $b->{weight} <=> $a->{weight} + } + grep { + scalar(@{$_->{selector}}) == 0 + } + @$rules + )[0]; + + if($result) { + my $data = $result->{data}; + $data =~ s/{(\w+)(?:\:(\d+))?}/ + my ($name,$index) = ($1,$2 || 0); + + if ($result->{vars}{$name}) { + $result->{vars}{$name}[$index]; + } else { + ""; } - - # test if there were a match - if ( delete $context->{success} ) { - if ( my $data = $match->{data} ) { - - # interpolate data - $data =~ s/{(\w+)(?:\:(\d+))?}/ - my ($name,$index) = ($1,$2 || 0); - - if ($context->{vars}{$name}) { - $context->{vars}{$name}[$index]; - } else { - ""; - } - /gex; - - push @$results, - { level => $match->{level}, result => $data }; - } - push @next, $context if $context->{selector}; - } - else { - - #repeat current alternative if it's not required to be immediate - push @next, - { - selector => { $selector, $match }, - vars => $alt->{vars} - } - unless $alt->{immediate}; - } - } + /gex; + + return $data; + } else { + return; } - - return \@next; } 1; @@ -301,14 +283,47 @@ выборе используется принцип похожий на селекторы C<CSS>, основывающийся на именах ресурсов и их типах данных. +Данный обработчик понимает определенные свойства контекста: + +=over + +=item * C<resourceLocation> + +В данном свойстве может быть передана информация о текущем расположении ресурса, +для которого строится представление. Эта информация будет доступна в шаблоне +через свойство документа C<location>. + +=item * C<environment> + +В данном совойстве контекста передается дополнительная информация об окружении +ресурса, например, которую задали родительские ресурсы. Использование данного +свойства позволяет не загромождать ресурс реализацией функциональности по +поддержке окружения. Это свойство может быть ссылкой на функцию, что позволяет +формировать контекст только по необходимости, при этом указанная функция будет +выполнена только один раз, при первом обращении. + +=back + =head1 SELECTORS =begin text -[url-template] [class] => template +syntax::= selector => template + +selector::= ([>]segment-template[@class-name]) + +segment-template::= {'{'name:regular-expr'}'|segment-name} + +name::= \w+ + +segment-name::= \S+ + +class-name::= name[(::name)] + +url-template@class => template shoes => product/list -{action:*.} @My::Data::Product => product/{action} +/shop//{action:*.}@My::Data::Product => product/{action} stuff >list => product/list details => product/details
--- a/Lib/IMPL/Web/View/TTDocument.pm Thu Feb 14 19:14:02 2013 +0400 +++ b/Lib/IMPL/Web/View/TTDocument.pm Mon Feb 18 02:55:59 2013 +0400 @@ -57,8 +57,6 @@ $doc->RequireControl(@_); }); - $this->templateVars(context => $vars); - $this->templateVars(document => sub { $self } ); $this->InitInstance($vars); }
--- a/Lib/IMPL/Web/View/TTLoader.pm Thu Feb 14 19:14:02 2013 +0400 +++ b/Lib/IMPL/Web/View/TTLoader.pm Mon Feb 18 02:55:59 2013 +0400 @@ -95,7 +95,7 @@ my ($tt,$error) = $this->provider->fetch($name); if (defined $error and $error == STATUS_DECLINED) { - die KeyNotFoundException->($name); + die KeyNotFoundException->new($name); } elsif (defined $error and $error == STATUS_ERROR) { die Exception->new("Failed to load a template", $name, $tt); }
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/_test/Test/Web/ViewSelector.pm Mon Feb 18 02:55:59 2013 +0400 @@ -0,0 +1,137 @@ +package Test::Web::ViewSelector; +use strict; + +use Scalar::Util qw(reftype); +use IMPL::Test qw(test assert assertarray); +use IMPL::declare { + require => { + TTView => 'IMPL::Web::Handler::TTView' + }, + base => [ + 'IMPL::Test::Unit' => '@_' + ] +}; + +test TestParseRules => sub { + my $rule = TTView->ParseRule('/category/item => item.html'); + + assert(reftype($rule) eq 'HASH'); + assert(reftype($rule->{selector}) eq 'ARRAY'); + assertarray([map $_->{name}, @{$rule->{selector}}], [qw(category item)]); + assert($rule->{data} eq 'item.html'); + assert($rule->{weight} == 2); + + $rule = TTView->ParseRule('category//item => item.html'); + + assert(reftype($rule) eq 'HASH'); + assert(reftype($rule->{selector}) eq 'ARRAY'); + assertarray([map $_->{name}, @{$rule->{selector}}], [undef, 'category', undef ,'item']); + assert($rule->{data} eq 'item.html'); + assert($rule->{weight} == 2); + + $rule = TTView->ParseRule('///category//item///// => item.html'); + # trailing slashes must be ignored + assertarray([map $_->{name}, @{$rule->{selector}}], [undef,undef, 'category', undef ,'item']); + + $rule = TTView->ParseRule('{cat:\w+}@OrgClass/products/@My::PoductClass/view => view.html'); + + assert(reftype($rule) eq 'HASH'); + assert(reftype($rule->{selector}) eq 'ARRAY'); + assert($rule->{data} eq 'view.html'); + assert($rule->{weight} == 4); + assert($rule->{selector}[0]->{any}); + assert($rule->{selector}[1]->{rx}); + assert($rule->{selector}[1]->{var} eq 'cat'); + assert($rule->{selector}[1]->{class} eq 'OrgClass'); + assert($rule->{selector}[3]->{class} eq 'My::PoductClass'); + assertarray([map $_->{name}, @{$rule->{selector}}], [undef,undef, 'products', undef ,'view']); + + $rule = TTView->ParseRule('/ => index.html'); + assert($rule->{weight} == 0); +}; + +test TestNamesMatch => sub { + my @rules = map TTView->ParseRule($_), + 'view => view.html', # weight 1 + 'shoes/view => shoes/view.html', # weight 2 + '/root/org/items/add => add.html'; # weight 4 + + assert( + TTView->MatchPath( + [ map { name => $_ }, qw(root view)], + \@rules + ) eq 'view.html' + ); + + assert( + TTView->MatchPath( + [ map { name => $_ }, qw(root shoes view)], + \@rules + ) eq 'shoes/view.html' + ); + + assert( + TTView->MatchPath( + [ map { name => $_ }, qw(root org products shoes view)], + \@rules + ) eq 'shoes/view.html' + ); + + assert( + TTView->MatchPath( + [ map { name => $_ }, qw(root org items add)], + \@rules + ) eq 'add.html' + ); +}; + +{ + package Test::Web::ViewSelector::Container; + + package Test::Web::ViewSelector::Orgs; + use IMPL::declare { + base => ['-Test::Web::ViewSelector::Container' => undef] + }; +} + +test TestComplexMatch => sub { + my @rules = map TTView->ParseRule($_), + '{container:.*}@Test::Web::ViewSelector::Container/{item:.*}/{action:.*} => {container}/{item}/{action}.html', # weight 3 + '/root//orgs/{org:.*}/info => orgs/{org}.html', # weight 4 + '@Test::Web::ViewSelector::Container => container.html'; + + my $path = [ + { name => 'root'}, + { name => 'list', class => 'Test::Web::ViewSelector::Container'}, + { name => 'hp' }, + { name => 'info'} + ]; + + my $result = TTView->MatchPath($path,\@rules); + my $expected = 'list/hp/info.html'; + + assert( $result eq $expected, "Expected: $expected", "Got: $result" ); + + $path = [ + { name => 'root'}, + { name => 'orgs', class => 'Test::Web::ViewSelector::Orgs'}, + { name => 'ms' }, + { name => 'info'} + ]; + $result = TTView->MatchPath($path,\@rules); + $expected = 'orgs/ms.html'; + + assert( $result eq $expected, "Expected: $expected", "Got: $result" ); + + $path = [ + { name => 'root'}, + { name => 'service'}, + { name => 'orgs', class => 'Test::Web::ViewSelector::Container' } + ]; + $result = TTView->MatchPath($path,\@rules); + $expected = 'container.html'; + + assert( $result eq $expected, "Expected: $expected", "Got: $result" ); +}; + +1; \ No newline at end of file