--- 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