# HG changeset patch # User sergey # Date 1335362771 -14400 # Node ID 68a59c3358ffb2512af6a9abf8e03bb5eeee1eda # Parent 5146e17a7b76583bd47187477d44eca82396c206 Implemented templates selection mechanism diff -r 5146e17a7b76 -r 68a59c3358ff Lib/IMPL/Web/Handler/TTView.pm --- a/Lib/IMPL/Web/Handler/TTView.pm Wed Apr 25 02:49:23 2012 +0400 +++ b/Lib/IMPL/Web/Handler/TTView.pm Wed Apr 25 18:06:11 2012 +0400 @@ -12,7 +12,17 @@ BEGIN { public property contentType => PROP_GET | PROP_OWNERSET; - public property templates => 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; +} + +sub CTOR { + my ($this) = @_; + + $this->indexResource('index') unless $this->indexResource; } sub Invoke { @@ -20,7 +30,7 @@ my $result = $next ? $next->($action) : undef; - my $doc = $this->templates->document( + my $doc = $this->loader->document( 'default', { data => $result, @@ -34,6 +44,172 @@ print $hout $doc->Render(); } +sub SelectView { + my ($this,$action,$class) = @_; + + my @path = split /\//, $action->query->path_info(), -1; + + my $last = pop @path; + $last =~ s/\.\w+$//; + $last = $this->indexResource; + push @path,$last; + + my $cache = $this->_selectorsCache; + + my $alternatives = [ map { + {selectors => $cache->{$_}, immediate => 1} + } grep $cache->{$_}, ( $class ? (_GetHierarchy($class), '-default') : '-plain' ) + ]; + + my @results; + + $alternatives = $this->MatchAlternatives($_,$alternatives,\@results) foreach @path; + + @results = sort { $b->{level} <=> $a->{level} } @results; +} + +sub _GetHierarchy { + my ($class) = @_; + return unless $class; + + no strict 'refs'; + + return $class, map { _GetHierarchy($_) } @{"${class}::ISA"}; +} + +sub BuildCache { + my ($this) = @_; + + my @selectors; + + foreach my $selector ($this->selectors) { + if (not ref $selector) { + + my ($path,$data) = split(/\s*=>\s*/, $selector); + + my @path = split(/\s+/,$path); + + my $class; + + if ($path[$#path-1] =~ m/^\@(.*)/) { + $class = $1; + shift @path; + } else { + $class = '-default'; + } + + if (@path) { + + @path = reverse @path; + my $last = pop @path; + + } else { + # todo + } + + } + } + + foreach my $selector( + { path => [qw( foo bar )], data => 'teo' }, + { path => [qw( {x:.*} zoo bar )], data => 'view/{x}'}, + { path => [qw( foo >zoo >bar )], data => 'ilo' }, + { path => [qw( bar )], data => 'duo' }, + { path => [qw( wee )], data => 'iwy'}, + { path => [qw( foo wee )], data => 'fwy'}, + { path => [qw( {x:\w+} )], data => 'x:{x}'}, + { path => [qw( boo {x:\w+} )], data => 'boo/{x}'}, + ) { + my $t = $tree; + my @path = reverse @{$selector->{path}}; + my $last = pop @path; + my $level = 1; + foreach my $prim (@path ) { + $t = ($t->{$prim}->{next} ||= {}); + $level ++; + } + $t->{$last}->{level} = $level; + $t->{$last}->{data} = $selector->{data}; + } +} + +sub MatchAlternatives { + my ($this,$segment,$alternatives,$results) = @_; + + warn "alternatives: ", scalar @$alternatives,", segment: $segment"; + + my @next; + + foreach my $alt (@$alternatives) { + while (my ($selector,$match) = each %{$alt->{selector}} ) { + warn $selector; + + warn "\timmediate" if $alt->{immediate}; + warn "\thas children" if $match->{next}; + + my $context = { + vars => \%{ $alt->{vars} || {} }, + selector => $match->{next} + }; + + if ($selector =~ s/^>//) { + $context->{immediate} = 1; + } + + if (my ($name,$rx) = ($selector =~ m/^\{(?:(\w+)\:)?(.*)\}$/) ) { + #this is a regexp + warn "\tregexp: [$name] $rx"; + + if ( my @captures = ($segment =~ m/($rx)/) ) { + $context->{success} = 1; + + warn "\t",join(',',@captures); + + if ($name) { + $context->{vars}->{$name} = \@captures; + } + } + } else { + #this is a segment name + if ($segment eq $selector) { + $context->{success} = 1; + } + } + + # test if there were a match + if (delete $context->{success}) { + warn "\tmatch"; + 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 }; + } + warn "\tnext" if $context->{selector}; + 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}; + } + } + } + + warn "end, next trip: ",scalar @next, " alternatives"; + + return \@next; +} + 1; __END__ @@ -71,6 +247,9 @@ shoes * => product/list {action:*.} @My::Data::Product => product/{action} +stuff/list => product/list +/123/details => product/details + =end text diff -r 5146e17a7b76 -r 68a59c3358ff _test/temp.pl --- a/_test/temp.pl Wed Apr 25 02:49:23 2012 +0400 +++ b/_test/temp.pl Wed Apr 25 18:06:11 2012 +0400 @@ -1,4 +1,135 @@ #!/usr/bin/perl use strict; -print join ',', "-some::mod::here" =~ m/^(-)?(\w+(?:::\w+)*)$/; \ No newline at end of file +use Data::Dumper(); + +=pod + +{ + bar => { + next => { + foo => { + data => 'teo' + }, + baz => { + data => 'ioh' + } + }, + data => 'duo' + }, + wee => { + data => 'iwy' + } +} + +=cut + +my $tree = {}; + +foreach my $selector( + { path => [qw( foo bar )], data => 'teo' }, + { path => [qw( {x:.*} zoo bar )], data => 'view/{x}'}, + { path => [qw( foo >zoo >bar )], data => 'ilo' }, + { path => [qw( bar )], data => 'duo' }, + { path => [qw( wee )], data => 'iwy'}, + { path => [qw( foo wee )], data => 'fwy'}, + { path => [qw( {x:\w+} )], data => 'x:{x}'}, + { path => [qw( boo {x:\w+} )], data => 'boo/{x}'}, +) { + my $t = $tree; + my @path = reverse @{$selector->{path}}; + my $last = pop @path; + my $level = 1; + foreach my $prim (@path ) { + $t = ($t->{$prim}->{next} ||= {}); + $level ++; + } + $t->{$last}->{level} = $level; + $t->{$last}->{data} = $selector->{data}; +} + +my @target = qw( foo zoo bar ); +my @results; +my $alternatives = [ { selector => $tree, immediate => 1 } ]; + +$alternatives = MatchAlternatives($_,$alternatives,\@results) foreach reverse @target; + + +sub MatchAlternatives { + my ($segment,$alternatives,$results) = @_; + + warn "alternatives: ", scalar @$alternatives,", segment: $segment"; + + my @next; + + foreach my $alt (@$alternatives) { + while (my ($selector,$match) = each %{$alt->{selector}} ) { + warn $selector; + + warn "\timmediate" if $alt->{immediate}; + warn "\thas children" if $match->{next}; + + my $context = { + vars => \%{ $alt->{vars} || {} }, + selector => $match->{next} + }; + + if ($selector =~ s/^>//) { + $context->{immediate} = 1; + } + + if (my ($name,$rx) = ($selector =~ m/^\{(?:(\w+)\:)?(.*)\}$/) ) { + #this is a regexp + warn "\tregexp: [$name] $rx"; + + if ( my @captures = ($segment =~ m/($rx)/) ) { + $context->{success} = 1; + + warn "\t",join(',',@captures); + + if ($name) { + $context->{vars}->{$name} = \@captures; + } + } + } else { + #this is a segment name + if ($segment eq $selector) { + $context->{success} = 1; + } + } + + # test if there were a match + if (delete $context->{success}) { + warn "\tmatch"; + 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 }; + } + warn "\tnext" if $context->{selector}; + 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}; + } + } + } + + warn "end, next trip: ",scalar @next, " alternatives"; + + return \@next; +} + +print Data::Dumper->Dump([$tree,\@results],[qw(tree results)]); \ No newline at end of file