Mercurial > pub > Impl
diff Lib/IMPL/Web/Handler/TTView.pm @ 229:47f77e6409f7
heavily reworked the resource model of the web application:
*some ResourcesContraact functionality moved to Resource
+Added CustomResource
*Corrected action handlers
author | sergey |
---|---|
date | Sat, 29 Sep 2012 02:34:47 +0400 |
parents | c8fe3f84feba |
children | 3cebcf6fdb9b |
line wrap: on
line diff
--- a/Lib/IMPL/Web/Handler/TTView.pm Thu Sep 13 17:55:01 2012 +0400 +++ b/Lib/IMPL/Web/Handler/TTView.pm Sat Sep 29 02:34:47 2012 +0400 @@ -4,195 +4,211 @@ use List::Util qw(first); use IMPL::lang qw(:declare :constants); use IMPL::declare { - require => { - Factory => 'IMPL::Object::Factory' - }, - base => { - 'IMPL::Object' => undef, - 'IMPL::Object::Autofill' => '@_', - 'IMPL::Object::Serializable' => undef - } + require => { + Factory => 'IMPL::Object::Factory', + HttpResponse => 'IMPL::Web::HttpResponse' + }, + base => [ + 'IMPL::Object' => undef, + 'IMPL::Object::Autofill' => '@_', + 'IMPL::Object::Serializable' => undef + ], + + props => [ + contentType => PROP_GET | PROP_OWNERSET, + contentCharset => PROP_GET | PROP_OWNERSET, + loader => PROP_GET | PROP_OWNERSET, + selectors => PROP_GET | PROP_LIST | PROP_OWNERSET, + defaultDocument => PROP_ALL, + indexResource => PROP_ALL, + _selectorsCache => PROP_ALL, + _classTemplates => PROP_ALL + ] }; -BEGIN { - public property contentType => PROP_GET | PROP_OWNERSET; - public property loader => PROP_GET | PROP_OWNERSET; - public property selectors => PROP_GET | PROP_LIST | PROP_OWNERSET; - public property defaultDocument => PROP_ALL; - public property indexResource => PROP_ALL; - private property _selectorsCache => PROP_ALL; - private property _classTemplates => PROP_ALL; -} +sub CTOR { + my ($this) = @_; -sub CTOR { - my ($this) = @_; - - $this->indexResource('index') unless $this->indexResource; + $this->indexResource('index') unless $this->indexResource; } sub Invoke { - my ($this,$action,$next) = @_; - - my $result = $next ? $next->($action) : undef; - - my $vars = { - data => $result, - action => $action, - app => $action->application, + my ( $this, $action, $next ) = @_; + + my $result = $next ? $next->($action) : undef; + + my $vars = { + data => $result, + action => $action, + app => $action->application, LoadFactory => sub { - my $class = shift; - - my $module = $class; - - $module =~ s/::/\//g; - $module .= ".pm"; - - require $module; - return Factory->new($class); + my $class = shift; + + my $module = $class; + + $module =~ s/::/\//g; + $module .= ".pm"; + + require $module; + return Factory->new($class); } - }; - - my $doc = $this->loader->document( - $this->SelectView($action,ref $result), - $vars + }; + + my $doc = + $this->loader->document( $this->SelectView( $action, ref $result ), + $vars ); + + return HttpResponse->new( + type => $this->contentType, + charset => $this->contentCharset, + body => $doc->Render($vars) ); - - $action->response->contentType($this->contentType); - - my $hout = $action->response->streamBody; - - print $hout $doc->Render($vars); } sub SelectView { - my ($this,$action,$class) = @_; - - my @path = split /\//, $action->query->path_info(), -1; - - shift @path; # remove always empty leading segment - - my $last = pop @path; - $last =~ s/\.\w+$//; - $last ||= $this->indexResource; - push @path,$last; - - $this->BuildCache unless $this->_selectorsCache; - my $cache = $this->_selectorsCache; - - @path = reverse @path; - - foreach my $subclass ( $class ? (_GetHierarchy($class), '-default') : '-plain') { - 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; + my ( $this, $action, $class ) = @_; + + my @path = split /\//, $action->query->path_info(), -1; + + shift @path; # remove always empty leading segment + + my $last = pop @path; + $last =~ s/\.\w+$//; + $last ||= $this->indexResource; + push @path, $last; + + $this->BuildCache unless $this->_selectorsCache; + my $cache = $this->_selectorsCache; + + @path = reverse @path; + + foreach + my $subclass ( $class ? ( _GetHierarchy($class), '-default' ) : '-plain' ) + { + 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"}; + 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 ++; + 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; - } - - } - } + $t->{$last}->{data} = $data; + + } + else { + + # we dont have a selector, only class + + $this->_classTemplates->{$class} = $data; + } + + } + } } sub MatchAlternatives { - my ($this,$segment,$alternatives,$results) = @_; - + my ( $this, $segment, $alternatives, $results ) = @_; + my @next; - + foreach my $alt (@$alternatives) { - while (my ($selector,$match) = each %{$alt->{selector}} ) { - - + while ( my ( $selector, $match ) = each %{ $alt->{selector} } ) { + my $context = { vars => \%{ $alt->{vars} || {} }, selector => $match->{next} }; - - if ($selector =~ s/^>//) { + + if ( $selector =~ s/^>// ) { $context->{immediate} = 1; } - - if (my ($name,$rx) = ($selector =~ m/^\{(?:(\w+)\:)?(.*)\}$/) ) { + + if ( my ( $name, $rx ) = + ( $selector =~ m/^\{(?:(\w+)\:)?(.*)\}$/ ) ) + { + #this is a regexp - - if ( my @captures = ($segment =~ m/($rx)/) ) { + + if ( my @captures = ( $segment =~ m/($rx)/ ) ) { $context->{success} = 1; - + if ($name) { $context->{vars}->{$name} = \@captures; } } - } else { + } + else { + #this is a segment name - if ($segment eq $selector) { + if ( $segment eq $selector ) { $context->{success} = 1; } } - + # test if there were a match - if (delete $context->{success}) { - if (my $data = $match->{data}) { + if ( delete $context->{success} ) { + if ( my $data = $match->{data} ) { + # interpolate data $data =~ s/{(\w+)(?:\:(\d+))?}/ my ($name,$index) = ($1,$2 || 0); @@ -203,20 +219,25 @@ ""; } /gex; - - push @$results, { level => $match->{level}, result => $data }; + + push @$results, + { level => $match->{level}, result => $data }; } push @next, $context if $context->{selector}; - } else { + } + else { + #repeat current alternative if it's not required to be immediate - push @next, { + push @next, + { selector => { $selector, $match }, - vars => $alt->{vars} - } unless $alt->{immediate}; + vars => $alt->{vars} + } + unless $alt->{immediate}; } } } - + return \@next; }