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
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
83
74bae30eb25e (no commit message)
wizard
parents:
diff changeset
1 #!/usr/bin/perl
93
0667064553ef fixed _is_class in activator
wizard
parents: 86
diff changeset
2 use strict;
197
6b1dda998839 Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents: 194
diff changeset
3
203
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
4 use Data::Dumper();
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
5
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
6 =pod
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
7
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
8 {
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
9 bar => {
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
10 next => {
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
11 foo => {
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
12 data => 'teo'
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
13 },
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
14 baz => {
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
15 data => 'ioh'
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
16 }
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
17 },
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
18 data => 'duo'
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
19 },
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
20 wee => {
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
21 data => 'iwy'
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
22 }
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
23 }
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
24
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
25 =cut
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
26
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
27 my $tree = {};
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
28
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
29 foreach my $selector(
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
30 { path => [qw( foo bar )], data => 'teo' },
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
31 { path => [qw( {x:.*} zoo bar )], data => 'view/{x}'},
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
32 { path => [qw( foo >zoo >bar )], data => 'ilo' },
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
33 { path => [qw( bar )], data => 'duo' },
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
34 { path => [qw( wee )], data => 'iwy'},
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
35 { path => [qw( foo wee )], data => 'fwy'},
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
36 { path => [qw( {x:\w+} )], data => 'x:{x}'},
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
37 { path => [qw( boo {x:\w+} )], data => 'boo/{x}'},
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
38 ) {
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
39 my $t = $tree;
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
40 my @path = reverse @{$selector->{path}};
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
41 my $last = pop @path;
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
42 my $level = 1;
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
43 foreach my $prim (@path ) {
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
44 $t = ($t->{$prim}->{next} ||= {});
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
45 $level ++;
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
46 }
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
47 $t->{$last}->{level} = $level;
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
48 $t->{$last}->{data} = $selector->{data};
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
49 }
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
50
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
51 my @target = qw( foo zoo bar );
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
52 my @results;
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
53 my $alternatives = [ { selector => $tree, immediate => 1 } ];
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
54
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
55 $alternatives = MatchAlternatives($_,$alternatives,\@results) foreach reverse @target;
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
56
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
57
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
58 sub MatchAlternatives {
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
59 my ($segment,$alternatives,$results) = @_;
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
60
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
61 warn "alternatives: ", scalar @$alternatives,", segment: $segment";
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
62
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
63 my @next;
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
64
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
65 foreach my $alt (@$alternatives) {
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
66 while (my ($selector,$match) = each %{$alt->{selector}} ) {
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
67 warn $selector;
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
68
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
69 warn "\timmediate" if $alt->{immediate};
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
70 warn "\thas children" if $match->{next};
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
71
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
72 my $context = {
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
73 vars => \%{ $alt->{vars} || {} },
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
74 selector => $match->{next}
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
75 };
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
76
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
77 if ($selector =~ s/^>//) {
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
78 $context->{immediate} = 1;
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
79 }
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
80
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
81 if (my ($name,$rx) = ($selector =~ m/^\{(?:(\w+)\:)?(.*)\}$/) ) {
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
82 #this is a regexp
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
83 warn "\tregexp: [$name] $rx";
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
84
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
85 if ( my @captures = ($segment =~ m/($rx)/) ) {
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
86 $context->{success} = 1;
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
87
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
88 warn "\t",join(',',@captures);
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
89
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
90 if ($name) {
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
91 $context->{vars}->{$name} = \@captures;
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
92 }
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
93 }
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
94 } else {
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
95 #this is a segment name
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
96 if ($segment eq $selector) {
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
97 $context->{success} = 1;
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
98 }
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
99 }
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
100
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
101 # test if there were a match
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
102 if (delete $context->{success}) {
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
103 warn "\tmatch";
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
104 if (my $data = $match->{data}) {
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
105 # interpolate data
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
106 $data =~ s/{(\w+)(?:\:(\d+))?}/
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
107 my ($name,$index) = ($1,$2 || 0);
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
108
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
109 if ($context->{vars}{$name}) {
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
110 $context->{vars}{$name}[$index];
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
111 } else {
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
112 "";
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
113 }
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
114 /gex;
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
115
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
116 push @$results, { level => $match->{level}, result => $data };
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
117 }
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
118 warn "\tnext" if $context->{selector};
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
119 push @next, $context if $context->{selector};
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
120 } else {
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
121 #repeat current alternative if it's not required to be immediate
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
122 push @next, {
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
123 selector => { $selector, $match },
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
124 vars => $alt->{vars}
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
125 } unless $alt->{immediate};
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
126 }
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
127 }
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
128 }
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
129
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
130 warn "end, next trip: ",scalar @next, " alternatives";
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
131
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
132 return \@next;
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
133 }
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
134
68a59c3358ff Implemented templates selection mechanism
sergey
parents: 198
diff changeset
135 print Data::Dumper->Dump([$tree,\@results],[qw(tree results)]);