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
--- a/_test/Web.t	Thu Feb 14 19:14:02 2013 +0400
+++ b/_test/Web.t	Mon Feb 18 02:55:59 2013 +0400
@@ -12,4 +12,5 @@
 run_plan( qw(
     Test::Web::View
     Test::Web::AutoLocator
+    Test::Web::ViewSelector
 ) );