Mercurial > pub > Impl
diff _test/temp.pl @ 209:a8db61d0ed33
IMPL::Class::Meta refactoring
author | cin |
---|---|
date | Mon, 28 May 2012 19:58:56 +0400 |
parents | 68a59c3358ff |
children | 6adaeb86945d |
line wrap: on
line diff
--- a/_test/temp.pl Fri May 18 18:43:00 2012 +0400 +++ b/_test/temp.pl Mon May 28 19:58:56 2012 +0400 @@ -1,135 +1,1 @@ -#!/usr/bin/perl -use strict; - -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 +print "asd::asd" =~ /^[a-zA-Z]+(?:::[a-zA-Z]+)*$/; \ No newline at end of file