Mercurial > pub > Impl

comparison _test/temp.pl @ 209:a8db61d0ed33

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
IMPL::Class::Meta refactoring
author cin
date Mon, 28 May 2012 19:58:56 +0400
parents 68a59c3358ff
children 6adaeb86945d
comparison
equal deleted inserted replaced
208:3d433a977e3b 209:a8db61d0ed33
1 #!/usr/bin/perl 1 print "asd::asd" =~ /^[a-zA-Z]+(?:::[a-zA-Z]+)*$/;
2 use strict;
3
4 use Data::Dumper();
5
6 =pod
7
8 {
9 bar => {
10 next => {
11 foo => {
12 data => 'teo'
13 },
14 baz => {
15 data => 'ioh'
16 }
17 },
18 data => 'duo'
19 },
20 wee => {
21 data => 'iwy'
22 }
23 }
24
25 =cut
26
27 my $tree = {};
28
29 foreach my $selector(
30 { path => [qw( foo bar )], data => 'teo' },
31 { path => [qw( {x:.*} zoo bar )], data => 'view/{x}'},
32 { path => [qw( foo >zoo >bar )], data => 'ilo' },
33 { path => [qw( bar )], data => 'duo' },
34 { path => [qw( wee )], data => 'iwy'},
35 { path => [qw( foo wee )], data => 'fwy'},
36 { path => [qw( {x:\w+} )], data => 'x:{x}'},
37 { path => [qw( boo {x:\w+} )], data => 'boo/{x}'},
38 ) {
39 my $t = $tree;
40 my @path = reverse @{$selector->{path}};
41 my $last = pop @path;
42 my $level = 1;
43 foreach my $prim (@path ) {
44 $t = ($t->{$prim}->{next} ||= {});
45 $level ++;
46 }
47 $t->{$last}->{level} = $level;
48 $t->{$last}->{data} = $selector->{data};
49 }
50
51 my @target = qw( foo zoo bar );
52 my @results;
53 my $alternatives = [ { selector => $tree, immediate => 1 } ];
54
55 $alternatives = MatchAlternatives($_,$alternatives,\@results) foreach reverse @target;
56
57
58 sub MatchAlternatives {
59 my ($segment,$alternatives,$results) = @_;
60
61 warn "alternatives: ", scalar @$alternatives,", segment: $segment";
62
63 my @next;
64
65 foreach my $alt (@$alternatives) {
66 while (my ($selector,$match) = each %{$alt->{selector}} ) {
67 warn $selector;
68
69 warn "\timmediate" if $alt->{immediate};
70 warn "\thas children" if $match->{next};
71
72 my $context = {
73 vars => \%{ $alt->{vars} || {} },
74 selector => $match->{next}
75 };
76
77 if ($selector =~ s/^>//) {
78 $context->{immediate} = 1;
79 }
80
81 if (my ($name,$rx) = ($selector =~ m/^\{(?:(\w+)\:)?(.*)\}$/) ) {
82 #this is a regexp
83 warn "\tregexp: [$name] $rx";
84
85 if ( my @captures = ($segment =~ m/($rx)/) ) {
86 $context->{success} = 1;
87
88 warn "\t",join(',',@captures);
89
90 if ($name) {
91 $context->{vars}->{$name} = \@captures;
92 }
93 }
94 } else {
95 #this is a segment name
96 if ($segment eq $selector) {
97 $context->{success} = 1;
98 }
99 }
100
101 # test if there were a match
102 if (delete $context->{success}) {
103 warn "\tmatch";
104 if (my $data = $match->{data}) {
105 # interpolate data
106 $data =~ s/{(\w+)(?:\:(\d+))?}/
107 my ($name,$index) = ($1,$2 || 0);
108
109 if ($context->{vars}{$name}) {
110 $context->{vars}{$name}[$index];
111 } else {
112 "";
113 }
114 /gex;
115
116 push @$results, { level => $match->{level}, result => $data };
117 }
118 warn "\tnext" if $context->{selector};
119 push @next, $context if $context->{selector};
120 } else {
121 #repeat current alternative if it's not required to be immediate
122 push @next, {
123 selector => { $selector, $match },
124 vars => $alt->{vars}
125 } unless $alt->{immediate};
126 }
127 }
128 }
129
130 warn "end, next trip: ",scalar @next, " alternatives";
131
132 return \@next;
133 }
134
135 print Data::Dumper->Dump([$tree,\@results],[qw(tree results)]);