Mercurial > pub > Impl
annotate _test/temp.pl @ 208:3d433a977e3b
corrected RestController for empty PAT_INFO
corrected charset for ErrorHandler
| author | sergey |
|---|---|
| date | Fri, 18 May 2012 18:43:00 +0400 |
| parents | 68a59c3358ff |
| children | a8db61d0ed33 |
| rev | line source |
|---|---|
| 83 | 1 #!/usr/bin/perl |
| 93 | 2 use strict; |
|
197
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
194
diff
changeset
|
3 |
| 203 | 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)]); |