Mercurial > pub > Impl
diff _test/temp.pl @ 203:68a59c3358ff
Implemented templates selection mechanism
author | sergey |
---|---|
date | Wed, 25 Apr 2012 18:06:11 +0400 |
parents | 2ffe6f661605 |
children | a8db61d0ed33 |
line wrap: on
line diff
--- 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