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)) { |
30 | if (my ($result) = $self->_execute_with(@args, @match)) { |
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") |
75 | if do { no strict 'refs'; defined *{"${targ}::BUILD"}{CODE} }; |
76 | my @targ_isa = do { no strict 'refs'; @{"${targ}::ISA"} }; |
77 | die "${targ} uses Multiple Inheritance: ISA is: ".join ', ', @targ_isa |
78 | if @targ_isa > 1; |
79 | $targ = $targ_isa[0]; |
80 | } |
81 | $self->$_($data) for reverse @targ; |
82 | return; |
5c33dda5 |
83 | } |
84 | |
44db8e76 |
85 | sub _setup_default_config { |
86 | my $class = shift; |
87 | { |
88 | no strict 'refs'; |
89 | if (${"${class}::_default_config"}{CODE}) { |
90 | $class->_cannot_call_twice('_setup_default_config', 'default_config'); |
91 | } |
92 | } |
93 | my @defaults = (@_, $class->_default_config); |
94 | { |
95 | no strict 'refs'; |
96 | *{"${class}::_default_config"} = sub { @defaults }; |
97 | } |
98 | } |
99 | |
3d5e4d2d |
100 | sub _default_config { () } |
101 | |
5c33dda5 |
102 | sub config { |
103 | shift->{config}; |
104 | } |
105 | |
106 | sub _construct_response_filter { |
3583ca04 |
107 | my $code = $_[1]; |
108 | $_[0]->_build_dispatcher({ |
109 | call => sub { |
110 | my ($d, $self, $env) = (shift, shift, shift); |
795c4698 |
111 | my @next = $d->next->dispatch($env, $self, @_); |
112 | return unless @next; |
113 | $self->_run_with_self($code, @next); |
3583ca04 |
114 | }, |
115 | }); |
5c33dda5 |
116 | } |
117 | |
39119082 |
118 | sub _construct_redispatch { |
3583ca04 |
119 | my ($self, $new_path) = @_; |
120 | $self->_build_dispatcher({ |
121 | call => sub { |
122 | shift; |
123 | my ($self, $env) = @_; |
44db8e76 |
124 | $self->_dispatch({ %{$env}, PATH_INFO => $new_path }) |
3583ca04 |
125 | } |
126 | }) |
39119082 |
127 | } |
128 | |
44db8e76 |
129 | sub _build_dispatch_parser { |
5c33dda5 |
130 | require Web::Simple::DispatchParser; |
131 | return Web::Simple::DispatchParser->new; |
132 | } |
133 | |
44db8e76 |
134 | sub _cannot_call_twice { |
135 | my ($class, $method, $sub) = @_; |
136 | my $error = "Cannot call ${method} twice for ${class}"; |
137 | if ($sub) { |
138 | $error .= " - did you call Web::Simple's ${sub} export twice?"; |
139 | } |
140 | die $error; |
141 | } |
142 | |
143 | sub _setup_dispatcher { |
795c4698 |
144 | my ($class, $dispatch_specs) = @_; |
44db8e76 |
145 | { |
146 | no strict 'refs'; |
147 | if (${"${class}::_dispatcher"}{CODE}) { |
148 | $class->_cannot_call_twice('_setup_dispatcher', 'dispatch'); |
149 | } |
150 | } |
795c4698 |
151 | my $chain = $class->_build_dispatch_chain( |
152 | [ @$dispatch_specs, $class->_build_final_dispatcher ] |
153 | ); |
154 | { |
155 | no strict 'refs'; |
156 | *{"${class}::_dispatcher"} = sub { $chain }; |
157 | } |
158 | } |
159 | |
160 | sub _construct_subdispatch { |
161 | my ($class, $dispatch_spec) = @_; |
162 | my $disp = $class->_build_dispatcher_from_spec($dispatch_spec); |
163 | my $call = $disp->call; |
164 | $disp->call(sub { |
165 | my @res = $call->(@_); |
166 | return unless @res; |
167 | my $chain = $class->_build_dispatch_chain(@res); |
168 | return $class->_build_dispatcher({ |
169 | call => sub { |
170 | my ($d, $self, $env) = (shift, shift, shift); |
171 | return $chain->dispatch($env, $self, @_); |
172 | } |
173 | }); |
174 | }); |
175 | return $class->_build_dispatcher({ |
176 | call => sub { |
177 | my ($d, $self, $env) = (shift, shift, shift); |
178 | my @sub = $disp->dispatch($env, $self, @_); |
179 | return @sub if @sub; |
180 | return unless (my $next = $d->next); |
181 | return $next->dispatch($env, $self, @_); |
182 | }, |
183 | }); |
184 | } |
185 | |
186 | sub _build_dispatcher_from_spec { |
187 | my ($class, $spec) = @_; |
188 | return $spec unless ref($spec) eq 'CODE'; |
189 | my $proto = prototype $spec; |
44db8e76 |
190 | my $parser = $class->_build_dispatch_parser; |
795c4698 |
191 | my $matcher = ( |
a9a99c24 |
192 | defined($proto) && length($proto) |
795c4698 |
193 | ? $parser->parse_dispatch_specification($proto) |
194 | : undef |
195 | ); |
196 | return $class->_build_dispatcher({ |
197 | match => $matcher, |
198 | call => sub { shift; |
199 | shift->_run_with_self($spec, @_) |
200 | }, |
201 | }); |
202 | } |
203 | |
204 | sub _build_dispatch_chain { |
205 | my ($class, $dispatch_specs) = @_; |
3583ca04 |
206 | my ($root, $last); |
795c4698 |
207 | foreach my $dispatch_spec (@$dispatch_specs) { |
208 | my $new = $class->_build_dispatcher_from_spec($dispatch_spec); |
3583ca04 |
209 | $root ||= $new; |
210 | $last = $last ? $last->next($new) : $new; |
5c33dda5 |
211 | } |
795c4698 |
212 | return $root; |
5c33dda5 |
213 | } |
214 | |
3583ca04 |
215 | sub _build_dispatcher { |
216 | bless($_[1], 'Web::Simple::Dispatcher'); |
5c33dda5 |
217 | } |
218 | |
3583ca04 |
219 | sub _build_final_dispatcher { |
220 | shift->_build_dispatcher({ |
221 | call => sub { |
222 | [ |
53d47b78 |
223 | 404, [ 'Content-type', 'text/plain' ], |
224 | [ 'Not found' ] |
3583ca04 |
225 | ] |
5c33dda5 |
226 | } |
3583ca04 |
227 | }) |
228 | } |
229 | |
44db8e76 |
230 | sub _dispatch { |
3583ca04 |
231 | my ($self, $env) = @_; |
44db8e76 |
232 | $self->_dispatcher->dispatch($env, $self); |
5c33dda5 |
233 | } |
234 | |
235 | sub _run_with_self { |
236 | my ($self, $run, @args) = @_; |
237 | my $class = ref($self); |
238 | no strict 'refs'; |
239 | local *{"${class}::self"} = \$self; |
240 | $self->$run(@args); |
241 | } |
242 | |
243 | sub run_if_script { |
d3a61609 |
244 | # ->as_psgi_app is true for require() but also works for plackup |
245 | return $_[0]->as_psgi_app if caller(1); |
5c33dda5 |
246 | my $class = shift; |
247 | my $self = $class->new; |
248 | $self->run(@_); |
249 | } |
250 | |
913a9cf9 |
251 | sub _run_cgi { |
5c33dda5 |
252 | my $self = shift; |
5c33dda5 |
253 | require Web::Simple::HackedPlack; |
d3a61609 |
254 | Plack::Server::CGI->run($self->as_psgi_app); |
255 | } |
256 | |
257 | sub as_psgi_app { |
258 | my $self = shift; |
259 | ref($self) ? sub { $self->_dispatch(@_) } : sub { $self->new->_dispatch(@_) } |
5c33dda5 |
260 | } |
261 | |
913a9cf9 |
262 | sub run { |
263 | my $self = shift; |
264 | if ($ENV{GATEWAY_INTERFACE}) { |
2514ad17 |
265 | return $self->_run_cgi; |
913a9cf9 |
266 | } |
3583ca04 |
267 | my $path = shift(@ARGV) or die "No path passed - use $0 / for root"; |
913a9cf9 |
268 | |
269 | require HTTP::Request::AsCGI; |
270 | require HTTP::Request::Common; |
271 | local *GET = \&HTTP::Request::Common::GET; |
272 | |
273 | my $request = GET($path); |
274 | my $c = HTTP::Request::AsCGI->new($request)->setup; |
275 | $self->_run_cgi; |
276 | $c->restore; |
277 | print $c->response->as_string; |
278 | } |
279 | |
5c33dda5 |
280 | 1; |