Commit | Line | Data |
5c33dda5 |
1 | package Web::Simple::Application; |
2 | |
3 | use strict; |
4 | use warnings FATAL => 'all'; |
5 | |
3583ca04 |
6 | { |
7 | package Web::Simple::Dispatcher; |
8 | |
9 | sub _is_dispatcher { |
10 | ref($_[1]) |
11 | and "$_[1]" =~ /\w+=[A-Z]/ |
12 | and $_[1]->isa(__PACKAGE__); |
13 | } |
14 | |
15 | sub next { |
16 | @_ > 1 |
17 | ? $_[0]->{next} = $_[1] |
18 | : shift->{next} |
19 | } |
20 | |
21 | sub set_next { |
22 | $_[0]->{next} = $_[1]; |
23 | $_[0] |
24 | } |
25 | |
26 | sub dispatch { |
27 | my ($self, $env, @args) = @_; |
795c4698 |
28 | my $next = $self->_has_match ? $self->next : undef; |
3583ca04 |
29 | if (my ($env_delta, @match) = $self->_match_against($env)) { |
bb436cfb |
30 | if (my ($result) = $self->_execute_with(@args, @match, $env)) { |
3583ca04 |
31 | if ($self->_is_dispatcher($result)) { |
32 | $next = $result->set_next($next); |
33 | $env = { %$env, %$env_delta }; |
34 | } else { |
35 | return $result; |
36 | } |
37 | } |
38 | } |
795c4698 |
39 | return () unless $next; |
3583ca04 |
40 | return $next->dispatch($env, @args); |
41 | } |
42 | |
795c4698 |
43 | sub call { |
44 | @_ > 1 |
45 | ? $_[0]->{call} = $_[1] |
46 | : shift->{call} |
47 | } |
48 | |
49 | sub _has_match { $_[0]->{match} } |
50 | |
3583ca04 |
51 | sub _match_against { |
81a5b03e |
52 | return ({}, $_[1]) unless $_[0]->{match}; |
53 | $_[0]->{match}->($_[1]); |
3583ca04 |
54 | } |
55 | |
56 | sub _execute_with { |
57 | $_[0]->{call}->(@_); |
58 | } |
59 | } |
60 | |
5c33dda5 |
61 | sub new { |
62 | my ($class, $data) = @_; |
63 | my $config = { $class->_default_config, %{($data||{})->{config}||{}} }; |
14ebaf8a |
64 | my $new = bless({ config => $config }, $class); |
65 | $new->BUILDALL($data); |
66 | $new; |
67 | } |
68 | |
69 | sub BUILDALL { |
70 | my ($self, $data) = @_; |
71 | my $targ = ref($self); |
72 | my @targ; |
73 | while ($targ->isa(__PACKAGE__) and $targ ne __PACKAGE__) { |
74 | push(@targ, "${targ}::BUILD") |
64a6f950 |
75 | if do { |
76 | no strict 'refs'; no warnings 'once'; |
77 | defined *{"${targ}::BUILD"}{CODE} |
78 | }; |
14ebaf8a |
79 | my @targ_isa = do { no strict 'refs'; @{"${targ}::ISA"} }; |
80 | die "${targ} uses Multiple Inheritance: ISA is: ".join ', ', @targ_isa |
81 | if @targ_isa > 1; |
82 | $targ = $targ_isa[0]; |
83 | } |
84 | $self->$_($data) for reverse @targ; |
85 | return; |
5c33dda5 |
86 | } |
87 | |
44db8e76 |
88 | sub _setup_default_config { |
89 | my $class = shift; |
90 | { |
91 | no strict 'refs'; |
92 | if (${"${class}::_default_config"}{CODE}) { |
93 | $class->_cannot_call_twice('_setup_default_config', 'default_config'); |
94 | } |
95 | } |
96 | my @defaults = (@_, $class->_default_config); |
97 | { |
98 | no strict 'refs'; |
99 | *{"${class}::_default_config"} = sub { @defaults }; |
100 | } |
101 | } |
102 | |
3d5e4d2d |
103 | sub _default_config { () } |
104 | |
5c33dda5 |
105 | sub config { |
106 | shift->{config}; |
107 | } |
108 | |
109 | sub _construct_response_filter { |
3583ca04 |
110 | my $code = $_[1]; |
111 | $_[0]->_build_dispatcher({ |
112 | call => sub { |
113 | my ($d, $self, $env) = (shift, shift, shift); |
795c4698 |
114 | my @next = $d->next->dispatch($env, $self, @_); |
115 | return unless @next; |
116 | $self->_run_with_self($code, @next); |
3583ca04 |
117 | }, |
118 | }); |
5c33dda5 |
119 | } |
120 | |
39119082 |
121 | sub _construct_redispatch { |
3583ca04 |
122 | my ($self, $new_path) = @_; |
123 | $self->_build_dispatcher({ |
124 | call => sub { |
125 | shift; |
126 | my ($self, $env) = @_; |
44db8e76 |
127 | $self->_dispatch({ %{$env}, PATH_INFO => $new_path }) |
3583ca04 |
128 | } |
129 | }) |
39119082 |
130 | } |
131 | |
44db8e76 |
132 | sub _build_dispatch_parser { |
d63bcdae |
133 | require Web::Dispatch::Parser; |
134 | return Web::Dispatch::Parser->new; |
5c33dda5 |
135 | } |
136 | |
44db8e76 |
137 | sub _cannot_call_twice { |
138 | my ($class, $method, $sub) = @_; |
139 | my $error = "Cannot call ${method} twice for ${class}"; |
140 | if ($sub) { |
141 | $error .= " - did you call Web::Simple's ${sub} export twice?"; |
142 | } |
143 | die $error; |
144 | } |
145 | |
146 | sub _setup_dispatcher { |
795c4698 |
147 | my ($class, $dispatch_specs) = @_; |
44db8e76 |
148 | { |
149 | no strict 'refs'; |
150 | if (${"${class}::_dispatcher"}{CODE}) { |
151 | $class->_cannot_call_twice('_setup_dispatcher', 'dispatch'); |
152 | } |
153 | } |
795c4698 |
154 | my $chain = $class->_build_dispatch_chain( |
155 | [ @$dispatch_specs, $class->_build_final_dispatcher ] |
156 | ); |
157 | { |
158 | no strict 'refs'; |
159 | *{"${class}::_dispatcher"} = sub { $chain }; |
160 | } |
161 | } |
162 | |
163 | sub _construct_subdispatch { |
164 | my ($class, $dispatch_spec) = @_; |
165 | my $disp = $class->_build_dispatcher_from_spec($dispatch_spec); |
166 | my $call = $disp->call; |
167 | $disp->call(sub { |
168 | my @res = $call->(@_); |
169 | return unless @res; |
170 | my $chain = $class->_build_dispatch_chain(@res); |
171 | return $class->_build_dispatcher({ |
172 | call => sub { |
eec9636a |
173 | my ($d, $self, $env) = (shift, shift, shift); pop; # lose trailing $env |
795c4698 |
174 | return $chain->dispatch($env, $self, @_); |
175 | } |
176 | }); |
177 | }); |
178 | return $class->_build_dispatcher({ |
179 | call => sub { |
eec9636a |
180 | my ($d, $self, $env) = (shift, shift, shift); pop; # lose trailing $env |
795c4698 |
181 | my @sub = $disp->dispatch($env, $self, @_); |
182 | return @sub if @sub; |
183 | return unless (my $next = $d->next); |
184 | return $next->dispatch($env, $self, @_); |
185 | }, |
186 | }); |
187 | } |
188 | |
189 | sub _build_dispatcher_from_spec { |
190 | my ($class, $spec) = @_; |
191 | return $spec unless ref($spec) eq 'CODE'; |
192 | my $proto = prototype $spec; |
44db8e76 |
193 | my $parser = $class->_build_dispatch_parser; |
795c4698 |
194 | my $matcher = ( |
a9a99c24 |
195 | defined($proto) && length($proto) |
d63bcdae |
196 | ? $parser->parse($proto) |
bb436cfb |
197 | : sub { ({}, $_[1]) } |
795c4698 |
198 | ); |
199 | return $class->_build_dispatcher({ |
200 | match => $matcher, |
201 | call => sub { shift; |
202 | shift->_run_with_self($spec, @_) |
203 | }, |
204 | }); |
205 | } |
206 | |
207 | sub _build_dispatch_chain { |
208 | my ($class, $dispatch_specs) = @_; |
3583ca04 |
209 | my ($root, $last); |
795c4698 |
210 | foreach my $dispatch_spec (@$dispatch_specs) { |
211 | my $new = $class->_build_dispatcher_from_spec($dispatch_spec); |
3583ca04 |
212 | $root ||= $new; |
213 | $last = $last ? $last->next($new) : $new; |
5c33dda5 |
214 | } |
795c4698 |
215 | return $root; |
5c33dda5 |
216 | } |
217 | |
3583ca04 |
218 | sub _build_dispatcher { |
219 | bless($_[1], 'Web::Simple::Dispatcher'); |
5c33dda5 |
220 | } |
221 | |
3583ca04 |
222 | sub _build_final_dispatcher { |
223 | shift->_build_dispatcher({ |
224 | call => sub { |
225 | [ |
53d47b78 |
226 | 404, [ 'Content-type', 'text/plain' ], |
227 | [ 'Not found' ] |
3583ca04 |
228 | ] |
5c33dda5 |
229 | } |
3583ca04 |
230 | }) |
231 | } |
232 | |
44db8e76 |
233 | sub _dispatch { |
3583ca04 |
234 | my ($self, $env) = @_; |
44db8e76 |
235 | $self->_dispatcher->dispatch($env, $self); |
5c33dda5 |
236 | } |
237 | |
238 | sub _run_with_self { |
239 | my ($self, $run, @args) = @_; |
240 | my $class = ref($self); |
241 | no strict 'refs'; |
242 | local *{"${class}::self"} = \$self; |
243 | $self->$run(@args); |
244 | } |
245 | |
246 | sub run_if_script { |
d3a61609 |
247 | # ->as_psgi_app is true for require() but also works for plackup |
248 | return $_[0]->as_psgi_app if caller(1); |
e27ab5c5 |
249 | my $self = ref($_[0]) ? $_[0] : $_[0]->new; |
5c33dda5 |
250 | $self->run(@_); |
251 | } |
252 | |
913a9cf9 |
253 | sub _run_cgi { |
5c33dda5 |
254 | my $self = shift; |
e27ab5c5 |
255 | require Plack::Server::CGI; |
d3a61609 |
256 | Plack::Server::CGI->run($self->as_psgi_app); |
257 | } |
258 | |
e27ab5c5 |
259 | sub _run_fcgi { |
260 | my $self = shift; |
261 | require Plack::Server::FCGI; |
262 | Plack::Server::FCGI->run($self->as_psgi_app); |
263 | } |
264 | |
d3a61609 |
265 | sub as_psgi_app { |
bc57805c |
266 | my $self = ref($_[0]) ? $_[0] : $_[0]->new; |
267 | sub { $self->_dispatch(@_) }; |
5c33dda5 |
268 | } |
269 | |
913a9cf9 |
270 | sub run { |
271 | my $self = shift; |
e27ab5c5 |
272 | if ($ENV{PHP_FCGI_CHILDREN} || $ENV{FCGI_ROLE} || $ENV{FCGI_SOCKET_PATH}) { |
273 | return $self->_run_fcgi; |
274 | } elsif ($ENV{GATEWAY_INTERFACE}) { |
2514ad17 |
275 | return $self->_run_cgi; |
913a9cf9 |
276 | } |
d104fb1d |
277 | unless (@ARGV && $ARGV[0] =~ m{^/}) { |
db2899c3 |
278 | return $self->_run_cli(@ARGV); |
d104fb1d |
279 | } |
280 | |
281 | my $path = shift @ARGV; |
913a9cf9 |
282 | |
913a9cf9 |
283 | require HTTP::Request::Common; |
e27ab5c5 |
284 | require Plack::Test; |
913a9cf9 |
285 | local *GET = \&HTTP::Request::Common::GET; |
286 | |
287 | my $request = GET($path); |
e27ab5c5 |
288 | my $response; |
289 | Plack::Test::test_psgi($self->as_psgi_app, sub { $response = shift->($request) }); |
290 | print $response->as_string; |
913a9cf9 |
291 | } |
292 | |
d104fb1d |
293 | sub _run_cli { |
294 | my $self = shift; |
295 | die $self->_cli_usage; |
296 | } |
297 | |
298 | sub _cli_usage { |
299 | "To run this script in CGI test mode, pass a URL path beginning with /:\n". |
300 | "\n". |
301 | " $0 /some/path\n". |
302 | " $0 /\n" |
303 | } |
304 | |
5c33dda5 |
305 | 1; |