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) = @_; |
28 | my $next = $self->next; |
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 | } |
39 | return $next->dispatch($env, @args); |
40 | } |
41 | |
42 | sub _match_against { |
81a5b03e |
43 | return ({}, $_[1]) unless $_[0]->{match}; |
44 | $_[0]->{match}->($_[1]); |
3583ca04 |
45 | } |
46 | |
47 | sub _execute_with { |
48 | $_[0]->{call}->(@_); |
49 | } |
50 | } |
51 | |
5c33dda5 |
52 | sub new { |
53 | my ($class, $data) = @_; |
54 | my $config = { $class->_default_config, %{($data||{})->{config}||{}} }; |
55 | bless({ config => $config }, $class); |
56 | } |
57 | |
44db8e76 |
58 | sub _setup_default_config { |
59 | my $class = shift; |
60 | { |
61 | no strict 'refs'; |
62 | if (${"${class}::_default_config"}{CODE}) { |
63 | $class->_cannot_call_twice('_setup_default_config', 'default_config'); |
64 | } |
65 | } |
66 | my @defaults = (@_, $class->_default_config); |
67 | { |
68 | no strict 'refs'; |
69 | *{"${class}::_default_config"} = sub { @defaults }; |
70 | } |
71 | } |
72 | |
3d5e4d2d |
73 | sub _default_config { () } |
74 | |
5c33dda5 |
75 | sub config { |
76 | shift->{config}; |
77 | } |
78 | |
79 | sub _construct_response_filter { |
3583ca04 |
80 | my $code = $_[1]; |
81 | $_[0]->_build_dispatcher({ |
82 | call => sub { |
83 | my ($d, $self, $env) = (shift, shift, shift); |
84 | $self->_run_with_self($code, $d->next->dispatch($env, $self, @_)); |
85 | }, |
86 | }); |
5c33dda5 |
87 | } |
88 | |
39119082 |
89 | sub _construct_redispatch { |
3583ca04 |
90 | my ($self, $new_path) = @_; |
91 | $self->_build_dispatcher({ |
92 | call => sub { |
93 | shift; |
94 | my ($self, $env) = @_; |
44db8e76 |
95 | $self->_dispatch({ %{$env}, PATH_INFO => $new_path }) |
3583ca04 |
96 | } |
97 | }) |
39119082 |
98 | } |
99 | |
44db8e76 |
100 | sub _build_dispatch_parser { |
5c33dda5 |
101 | require Web::Simple::DispatchParser; |
102 | return Web::Simple::DispatchParser->new; |
103 | } |
104 | |
44db8e76 |
105 | sub _cannot_call_twice { |
106 | my ($class, $method, $sub) = @_; |
107 | my $error = "Cannot call ${method} twice for ${class}"; |
108 | if ($sub) { |
109 | $error .= " - did you call Web::Simple's ${sub} export twice?"; |
110 | } |
111 | die $error; |
112 | } |
113 | |
114 | sub _setup_dispatcher { |
5c33dda5 |
115 | my ($class, $dispatch_subs) = @_; |
44db8e76 |
116 | { |
117 | no strict 'refs'; |
118 | if (${"${class}::_dispatcher"}{CODE}) { |
119 | $class->_cannot_call_twice('_setup_dispatcher', 'dispatch'); |
120 | } |
121 | } |
122 | my $parser = $class->_build_dispatch_parser; |
3583ca04 |
123 | my ($root, $last); |
5c33dda5 |
124 | foreach my $dispatch_sub (@$dispatch_subs) { |
125 | my $proto = prototype $dispatch_sub; |
126 | my $matcher = ( |
127 | defined($proto) |
128 | ? $parser->parse_dispatch_specification($proto) |
3583ca04 |
129 | : undef |
5c33dda5 |
130 | ); |
3583ca04 |
131 | my $new = $class->_build_dispatcher({ |
81a5b03e |
132 | match => $matcher, |
3583ca04 |
133 | call => sub { shift; |
134 | shift->_run_with_self($dispatch_sub, @_) |
135 | }, |
136 | }); |
137 | $root ||= $new; |
138 | $last = $last ? $last->next($new) : $new; |
5c33dda5 |
139 | } |
3583ca04 |
140 | $last->next($class->_build_final_dispatcher); |
5c33dda5 |
141 | { |
142 | no strict 'refs'; |
44db8e76 |
143 | *{"${class}::_dispatcher"} = sub { $root }; |
5c33dda5 |
144 | } |
145 | } |
146 | |
3583ca04 |
147 | sub _build_dispatcher { |
148 | bless($_[1], 'Web::Simple::Dispatcher'); |
5c33dda5 |
149 | } |
150 | |
3583ca04 |
151 | sub _build_final_dispatcher { |
152 | shift->_build_dispatcher({ |
153 | call => sub { |
154 | [ |
155 | 500, [ 'Content-type', 'text/plain' ], |
156 | [ 'The management apologises but we have no idea how to handle that' ] |
157 | ] |
5c33dda5 |
158 | } |
3583ca04 |
159 | }) |
160 | } |
161 | |
44db8e76 |
162 | sub _dispatch { |
3583ca04 |
163 | my ($self, $env) = @_; |
44db8e76 |
164 | $self->_dispatcher->dispatch($env, $self); |
5c33dda5 |
165 | } |
166 | |
167 | sub _run_with_self { |
168 | my ($self, $run, @args) = @_; |
169 | my $class = ref($self); |
170 | no strict 'refs'; |
171 | local *{"${class}::self"} = \$self; |
172 | $self->$run(@args); |
173 | } |
174 | |
175 | sub run_if_script { |
176 | return 1 if caller(1); # 1 so we can be the last thing in the file |
177 | my $class = shift; |
178 | my $self = $class->new; |
179 | $self->run(@_); |
180 | } |
181 | |
913a9cf9 |
182 | sub _run_cgi { |
5c33dda5 |
183 | my $self = shift; |
5c33dda5 |
184 | require Web::Simple::HackedPlack; |
44db8e76 |
185 | Plack::Server::CGI->run(sub { $self->_dispatch(@_) }); |
5c33dda5 |
186 | } |
187 | |
913a9cf9 |
188 | sub run { |
189 | my $self = shift; |
190 | if ($ENV{GATEWAY_INTERFACE}) { |
2514ad17 |
191 | return $self->_run_cgi; |
913a9cf9 |
192 | } |
3583ca04 |
193 | my $path = shift(@ARGV) or die "No path passed - use $0 / for root"; |
913a9cf9 |
194 | |
195 | require HTTP::Request::AsCGI; |
196 | require HTTP::Request::Common; |
197 | local *GET = \&HTTP::Request::Common::GET; |
198 | |
199 | my $request = GET($path); |
200 | my $c = HTTP::Request::AsCGI->new($request)->setup; |
201 | $self->_run_cgi; |
202 | $c->restore; |
203 | print $c->response->as_string; |
204 | } |
205 | |
5c33dda5 |
206 | 1; |