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 | |
3d5e4d2d |
58 | sub _default_config { () } |
59 | |
5c33dda5 |
60 | sub config { |
61 | shift->{config}; |
62 | } |
63 | |
64 | sub _construct_response_filter { |
3583ca04 |
65 | my $code = $_[1]; |
66 | $_[0]->_build_dispatcher({ |
67 | call => sub { |
68 | my ($d, $self, $env) = (shift, shift, shift); |
69 | $self->_run_with_self($code, $d->next->dispatch($env, $self, @_)); |
70 | }, |
71 | }); |
5c33dda5 |
72 | } |
73 | |
39119082 |
74 | sub _construct_redispatch { |
3583ca04 |
75 | my ($self, $new_path) = @_; |
76 | $self->_build_dispatcher({ |
77 | call => sub { |
78 | shift; |
79 | my ($self, $env) = @_; |
80 | $self->handle_request({ %{$env}, PATH_INFO => $new_path }) |
81 | } |
82 | }) |
39119082 |
83 | } |
84 | |
5c33dda5 |
85 | sub _dispatch_parser { |
86 | require Web::Simple::DispatchParser; |
87 | return Web::Simple::DispatchParser->new; |
88 | } |
89 | |
90 | sub _setup_dispatchables { |
91 | my ($class, $dispatch_subs) = @_; |
92 | my $parser = $class->_dispatch_parser; |
93 | my @dispatchables; |
3583ca04 |
94 | my ($root, $last); |
5c33dda5 |
95 | foreach my $dispatch_sub (@$dispatch_subs) { |
96 | my $proto = prototype $dispatch_sub; |
97 | my $matcher = ( |
98 | defined($proto) |
99 | ? $parser->parse_dispatch_specification($proto) |
3583ca04 |
100 | : undef |
5c33dda5 |
101 | ); |
3583ca04 |
102 | my $new = $class->_build_dispatcher({ |
81a5b03e |
103 | match => $matcher, |
3583ca04 |
104 | call => sub { shift; |
105 | shift->_run_with_self($dispatch_sub, @_) |
106 | }, |
107 | }); |
108 | $root ||= $new; |
109 | $last = $last ? $last->next($new) : $new; |
5c33dda5 |
110 | push @dispatchables, [ $matcher, $dispatch_sub ]; |
111 | } |
3583ca04 |
112 | $last->next($class->_build_final_dispatcher); |
5c33dda5 |
113 | { |
114 | no strict 'refs'; |
3583ca04 |
115 | *{"${class}::_dispatch_root"} = sub { $root }; |
5c33dda5 |
116 | } |
117 | } |
118 | |
3583ca04 |
119 | sub _build_dispatcher { |
120 | bless($_[1], 'Web::Simple::Dispatcher'); |
5c33dda5 |
121 | } |
122 | |
3583ca04 |
123 | sub _build_final_dispatcher { |
124 | shift->_build_dispatcher({ |
125 | call => sub { |
126 | [ |
127 | 500, [ 'Content-type', 'text/plain' ], |
128 | [ 'The management apologises but we have no idea how to handle that' ] |
129 | ] |
5c33dda5 |
130 | } |
3583ca04 |
131 | }) |
132 | } |
133 | |
134 | sub handle_request { |
135 | my ($self, $env) = @_; |
136 | $self->_dispatch_root->dispatch($env, $self); |
5c33dda5 |
137 | } |
138 | |
139 | sub _run_with_self { |
140 | my ($self, $run, @args) = @_; |
141 | my $class = ref($self); |
142 | no strict 'refs'; |
143 | local *{"${class}::self"} = \$self; |
144 | $self->$run(@args); |
145 | } |
146 | |
147 | sub run_if_script { |
148 | return 1 if caller(1); # 1 so we can be the last thing in the file |
149 | my $class = shift; |
150 | my $self = $class->new; |
151 | $self->run(@_); |
152 | } |
153 | |
913a9cf9 |
154 | sub _run_cgi { |
5c33dda5 |
155 | my $self = shift; |
5c33dda5 |
156 | require Web::Simple::HackedPlack; |
157 | Plack::Server::CGI->run(sub { $self->handle_request(@_) }); |
158 | } |
159 | |
913a9cf9 |
160 | sub run { |
161 | my $self = shift; |
162 | if ($ENV{GATEWAY_INTERFACE}) { |
2514ad17 |
163 | return $self->_run_cgi; |
913a9cf9 |
164 | } |
3583ca04 |
165 | my $path = shift(@ARGV) or die "No path passed - use $0 / for root"; |
913a9cf9 |
166 | |
167 | require HTTP::Request::AsCGI; |
168 | require HTTP::Request::Common; |
169 | local *GET = \&HTTP::Request::Common::GET; |
170 | |
171 | my $request = GET($path); |
172 | my $c = HTTP::Request::AsCGI->new($request)->setup; |
173 | $self->_run_cgi; |
174 | $c->restore; |
175 | print $c->response->as_string; |
176 | } |
177 | |
5c33dda5 |
178 | 1; |