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