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