Mercurial > pub > Impl

comparison Lib/IMPL/Web/Handler/TTView.pm @ 229:47f77e6409f7

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
heavily reworked the resource model of the web application: *some ResourcesContraact functionality moved to Resource +Added CustomResource *Corrected action handlers
author sergey
date Sat, 29 Sep 2012 02:34:47 +0400
parents c8fe3f84feba
children 3cebcf6fdb9b
comparison
equal deleted inserted replaced
228:431db7034a88 229:47f77e6409f7
2 use strict; 2 use strict;
3 3
4 use List::Util qw(first); 4 use List::Util qw(first);
5 use IMPL::lang qw(:declare :constants); 5 use IMPL::lang qw(:declare :constants);
6 use IMPL::declare { 6 use IMPL::declare {
7 require => { 7 require => {
8 Factory => 'IMPL::Object::Factory' 8 Factory => 'IMPL::Object::Factory',
9 }, 9 HttpResponse => 'IMPL::Web::HttpResponse'
10 base => { 10 },
11 'IMPL::Object' => undef, 11 base => [
12 'IMPL::Object::Autofill' => '@_', 12 'IMPL::Object' => undef,
13 'IMPL::Object::Serializable' => undef 13 'IMPL::Object::Autofill' => '@_',
14 } 14 'IMPL::Object::Serializable' => undef
15 ],
16
17 props => [
18 contentType => PROP_GET | PROP_OWNERSET,
19 contentCharset => PROP_GET | PROP_OWNERSET,
20 loader => PROP_GET | PROP_OWNERSET,
21 selectors => PROP_GET | PROP_LIST | PROP_OWNERSET,
22 defaultDocument => PROP_ALL,
23 indexResource => PROP_ALL,
24 _selectorsCache => PROP_ALL,
25 _classTemplates => PROP_ALL
26 ]
15 }; 27 };
16 28
17 BEGIN {
18 public property contentType => PROP_GET | PROP_OWNERSET;
19 public property loader => PROP_GET | PROP_OWNERSET;
20 public property selectors => PROP_GET | PROP_LIST | PROP_OWNERSET;
21 public property defaultDocument => PROP_ALL;
22 public property indexResource => PROP_ALL;
23 private property _selectorsCache => PROP_ALL;
24 private property _classTemplates => PROP_ALL;
25 }
26
27 sub CTOR { 29 sub CTOR {
28 my ($this) = @_; 30 my ($this) = @_;
29 31
30 $this->indexResource('index') unless $this->indexResource; 32 $this->indexResource('index') unless $this->indexResource;
31 } 33 }
32 34
33 sub Invoke { 35 sub Invoke {
34 my ($this,$action,$next) = @_; 36 my ( $this, $action, $next ) = @_;
35 37
36 my $result = $next ? $next->($action) : undef; 38 my $result = $next ? $next->($action) : undef;
37 39
38 my $vars = { 40 my $vars = {
39 data => $result, 41 data => $result,
40 action => $action, 42 action => $action,
41 app => $action->application, 43 app => $action->application,
42 LoadFactory => sub { 44 LoadFactory => sub {
43 my $class = shift; 45 my $class = shift;
44 46
45 my $module = $class; 47 my $module = $class;
46 48
47 $module =~ s/::/\//g; 49 $module =~ s/::/\//g;
48 $module .= ".pm"; 50 $module .= ".pm";
49 51
50 require $module; 52 require $module;
51 return Factory->new($class); 53 return Factory->new($class);
52 } 54 }
53 }; 55 };
54 56
55 my $doc = $this->loader->document( 57 my $doc =
56 $this->SelectView($action,ref $result), 58 $this->loader->document( $this->SelectView( $action, ref $result ),
57 $vars 59 $vars );
60
61 return HttpResponse->new(
62 type => $this->contentType,
63 charset => $this->contentCharset,
64 body => $doc->Render($vars)
58 ); 65 );
59
60 $action->response->contentType($this->contentType);
61
62 my $hout = $action->response->streamBody;
63
64 print $hout $doc->Render($vars);
65 } 66 }
66 67
67 sub SelectView { 68 sub SelectView {
68 my ($this,$action,$class) = @_; 69 my ( $this, $action, $class ) = @_;
69 70
70 my @path = split /\//, $action->query->path_info(), -1; 71 my @path = split /\//, $action->query->path_info(), -1;
71 72
72 shift @path; # remove always empty leading segment 73 shift @path; # remove always empty leading segment
73 74
74 my $last = pop @path; 75 my $last = pop @path;
75 $last =~ s/\.\w+$//; 76 $last =~ s/\.\w+$//;
76 $last ||= $this->indexResource; 77 $last ||= $this->indexResource;
77 push @path,$last; 78 push @path, $last;
78 79
79 $this->BuildCache unless $this->_selectorsCache; 80 $this->BuildCache unless $this->_selectorsCache;
80 my $cache = $this->_selectorsCache; 81 my $cache = $this->_selectorsCache;
81 82
82 @path = reverse @path; 83 @path = reverse @path;
83 84
84 foreach my $subclass ( $class ? (_GetHierarchy($class), '-default') : '-plain') { 85 foreach
85 my @results; 86 my $subclass ( $class ? ( _GetHierarchy($class), '-default' ) : '-plain' )
86 push @results, { result => $this->_classTemplates->{$subclass}, level => 0 } if $this->_classTemplates->{$subclass}; 87 {
87 if ($cache->{$subclass}) { 88 my @results;
88 my $alternatives = [ { selector => $cache->{$subclass}, immediate => 1 } ]; 89 push @results,
89 $alternatives = $this->MatchAlternatives($_,$alternatives,\@results) foreach @path; 90 { result => $this->_classTemplates->{$subclass}, level => 0 }
90 } 91 if $this->_classTemplates->{$subclass};
91 92 if ( $cache->{$subclass} ) {
92 if (@results) { 93 my $alternatives =
93 @results = sort { $b->{level} <=> $a->{level} } @results; 94 [ { selector => $cache->{$subclass}, immediate => 1 } ];
94 return (shift @results)->{result}; 95 $alternatives =
95 } 96 $this->MatchAlternatives( $_, $alternatives, \@results )
96 } 97 foreach @path;
97 98 }
98 return $this->defaultDocument; 99
100 if (@results) {
101 @results = sort { $b->{level} <=> $a->{level} } @results;
102 return ( shift @results )->{result};
103 }
104 }
105
106 return $this->defaultDocument;
99 } 107 }
100 108
101 sub _GetHierarchy { 109 sub _GetHierarchy {
102 my ($class) = @_; 110 my ($class) = @_;
103 return unless $class; 111 return unless $class;
104 112
105 no strict 'refs'; 113 no strict 'refs';
106 114
107 return $class, map { _GetHierarchy($_) } @{"${class}::ISA"}; 115 return $class, map { _GetHierarchy($_) } @{"${class}::ISA"};
108 } 116 }
109 117
110 sub BuildCache { 118 sub BuildCache {
111 my ($this) = @_; 119 my ($this) = @_;
112 120
113 my @selectors; 121 my @selectors;
114 122
115 my $cache = $this->_selectorsCache({}); 123 my $cache = $this->_selectorsCache( {} );
116 $this->_classTemplates({}); 124 $this->_classTemplates( {} );
117 125
118 foreach my $selector ($this->selectors) { 126 foreach my $selector ( $this->selectors ) {
119 if (not ref $selector) { 127 if ( not ref $selector ) {
120 128
121 my ($path,$data) = split(/\s*=>\s*/, $selector); 129 my ( $path, $data ) = split( /\s*=>\s*/, $selector );
122 130
123 my @path = split(/\s+/,$path); 131 my @path = split( /\s+/, $path );
124 132
125 my $class; 133 my $class;
126 134
127 # if this selector has a class part 135 # if this selector has a class part
128 if ($path[$#path] =~ m/^\@(.*)/) { 136 if ( $path[$#path] =~ m/^\@(.*)/ ) {
129 $class = $1; 137 $class = $1;
130 pop @path; 138 pop @path;
131 } else { 139 }
132 $class = '-default'; 140 else {
133 } 141 $class = '-default';
134 142 }
135 #if this selector has a path 143
136 if (@path) { 144 #if this selector has a path
137 @path = reverse @path; 145 if (@path) {
138 my $last = pop @path; 146 @path = reverse @path;
139 my $t = ( $cache->{$class} ||= {} ); 147 my $last = pop @path;
140 my $level = 1; 148 my $t = ( $cache->{$class} ||= {} );
141 foreach my $prim (@path ) { 149 my $level = 1;
142 $t = ($t->{$prim}->{next} ||= {}); 150 foreach my $prim (@path) {
143 $level ++; 151 $t = ( $t->{$prim}->{next} ||= {} );
152 $level++;
144 } 153 }
145 $t->{$last}->{level} = $level; 154 $t->{$last}->{level} = $level;
146 $t->{$last}->{data} = $data; 155 $t->{$last}->{data} = $data;
147 156
148 } else { 157 }
149 # we dont have a selector, only class 158 else {
150 159
151 $this->_classTemplates->{$class} = $data; 160 # we dont have a selector, only class
152 } 161
153 162 $this->_classTemplates->{$class} = $data;
154 } 163 }
155 } 164
165 }
166 }
156 } 167 }
157 168
158 sub MatchAlternatives { 169 sub MatchAlternatives {
159 my ($this,$segment,$alternatives,$results) = @_; 170 my ( $this, $segment, $alternatives, $results ) = @_;
160 171
161 my @next; 172 my @next;
162 173
163 foreach my $alt (@$alternatives) { 174 foreach my $alt (@$alternatives) {
164 while (my ($selector,$match) = each %{$alt->{selector}} ) { 175 while ( my ( $selector, $match ) = each %{ $alt->{selector} } ) {
165 176
166
167 my $context = { 177 my $context = {
168 vars => \%{ $alt->{vars} || {} }, 178 vars => \%{ $alt->{vars} || {} },
169 selector => $match->{next} 179 selector => $match->{next}
170 }; 180 };
171 181
172 if ($selector =~ s/^>//) { 182 if ( $selector =~ s/^>// ) {
173 $context->{immediate} = 1; 183 $context->{immediate} = 1;
174 } 184 }
175 185
176 if (my ($name,$rx) = ($selector =~ m/^\{(?:(\w+)\:)?(.*)\}$/) ) { 186 if ( my ( $name, $rx ) =
187 ( $selector =~ m/^\{(?:(\w+)\:)?(.*)\}$/ ) )
188 {
189
177 #this is a regexp 190 #this is a regexp
178 191
179 if ( my @captures = ($segment =~ m/($rx)/) ) { 192 if ( my @captures = ( $segment =~ m/($rx)/ ) ) {
180 $context->{success} = 1; 193 $context->{success} = 1;
181 194
182 if ($name) { 195 if ($name) {
183 $context->{vars}->{$name} = \@captures; 196 $context->{vars}->{$name} = \@captures;
184 } 197 }
185 } 198 }
186 } else { 199 }
200 else {
201
187 #this is a segment name 202 #this is a segment name
188 if ($segment eq $selector) { 203 if ( $segment eq $selector ) {
189 $context->{success} = 1; 204 $context->{success} = 1;
190 } 205 }
191 } 206 }
192 207
193 # test if there were a match 208 # test if there were a match
194 if (delete $context->{success}) { 209 if ( delete $context->{success} ) {
195 if (my $data = $match->{data}) { 210 if ( my $data = $match->{data} ) {
211
196 # interpolate data 212 # interpolate data
197 $data =~ s/{(\w+)(?:\:(\d+))?}/ 213 $data =~ s/{(\w+)(?:\:(\d+))?}/
198 my ($name,$index) = ($1,$2 || 0); 214 my ($name,$index) = ($1,$2 || 0);
199 215
200 if ($context->{vars}{$name}) { 216 if ($context->{vars}{$name}) {
201 $context->{vars}{$name}[$index]; 217 $context->{vars}{$name}[$index];
202 } else { 218 } else {
203 ""; 219 "";
204 } 220 }
205 /gex; 221 /gex;
206 222
207 push @$results, { level => $match->{level}, result => $data }; 223 push @$results,
224 { level => $match->{level}, result => $data };
208 } 225 }
209 push @next, $context if $context->{selector}; 226 push @next, $context if $context->{selector};
210 } else { 227 }
228 else {
229
211 #repeat current alternative if it's not required to be immediate 230 #repeat current alternative if it's not required to be immediate
212 push @next, { 231 push @next,
232 {
213 selector => { $selector, $match }, 233 selector => { $selector, $match },
214 vars => $alt->{vars} 234 vars => $alt->{vars}
215 } unless $alt->{immediate}; 235 }
236 unless $alt->{immediate};
216 } 237 }
217 } 238 }
218 } 239 }
219 240
220 return \@next; 241 return \@next;
221 } 242 }
222 243
223 1; 244 1;
224 245