Commit | Line | Data |
5c33dda5 |
1 | package Web::Simple::Application; |
2 | |
3 | use strict; |
4 | use warnings FATAL => 'all'; |
5 | |
6 | sub new { |
7 | my ($class, $data) = @_; |
8 | my $config = { $class->_default_config, %{($data||{})->{config}||{}} }; |
14ebaf8a |
9 | my $new = bless({ config => $config }, $class); |
10 | $new->BUILDALL($data); |
11 | $new; |
12 | } |
13 | |
14 | sub BUILDALL { |
15 | my ($self, $data) = @_; |
16 | my $targ = ref($self); |
17 | my @targ; |
18 | while ($targ->isa(__PACKAGE__) and $targ ne __PACKAGE__) { |
19 | push(@targ, "${targ}::BUILD") |
64a6f950 |
20 | if do { |
21 | no strict 'refs'; no warnings 'once'; |
22 | defined *{"${targ}::BUILD"}{CODE} |
23 | }; |
14ebaf8a |
24 | my @targ_isa = do { no strict 'refs'; @{"${targ}::ISA"} }; |
25 | die "${targ} uses Multiple Inheritance: ISA is: ".join ', ', @targ_isa |
26 | if @targ_isa > 1; |
27 | $targ = $targ_isa[0]; |
28 | } |
29 | $self->$_($data) for reverse @targ; |
30 | return; |
5c33dda5 |
31 | } |
32 | |
44db8e76 |
33 | sub _setup_default_config { |
34 | my $class = shift; |
35 | { |
36 | no strict 'refs'; |
37 | if (${"${class}::_default_config"}{CODE}) { |
38 | $class->_cannot_call_twice('_setup_default_config', 'default_config'); |
39 | } |
40 | } |
41 | my @defaults = (@_, $class->_default_config); |
42 | { |
43 | no strict 'refs'; |
44 | *{"${class}::_default_config"} = sub { @defaults }; |
45 | } |
46 | } |
47 | |
3d5e4d2d |
48 | sub _default_config { () } |
49 | |
5c33dda5 |
50 | sub config { |
51 | shift->{config}; |
52 | } |
53 | |
54 | sub _construct_response_filter { |
4ed4fb42 |
55 | my ($class, $code) = @_; |
56 | my $self = do { no strict 'refs'; ${"${class}::self"} }; |
57 | require Web::Dispatch::Wrapper; |
58 | Web::Dispatch::Wrapper->from_code(sub { |
59 | my @result = $_[1]->($_[0]); |
60 | if (@result) { |
61 | $self->_run_with_self($code, @result); |
62 | } else { |
63 | @result; |
64 | } |
3583ca04 |
65 | }); |
5c33dda5 |
66 | } |
67 | |
39119082 |
68 | sub _construct_redispatch { |
4ed4fb42 |
69 | my ($class, $new_path) = @_; |
70 | require Web::Dispatch::Wrapper; |
71 | Web::Dispatch::Wrapper->from_code(sub { |
72 | $_[1]->({ %{$_[0]}, PATH_INFO => $new_path }); |
73 | }); |
39119082 |
74 | } |
75 | |
44db8e76 |
76 | sub _build_dispatch_parser { |
d63bcdae |
77 | require Web::Dispatch::Parser; |
78 | return Web::Dispatch::Parser->new; |
5c33dda5 |
79 | } |
80 | |
44db8e76 |
81 | sub _cannot_call_twice { |
82 | my ($class, $method, $sub) = @_; |
83 | my $error = "Cannot call ${method} twice for ${class}"; |
84 | if ($sub) { |
85 | $error .= " - did you call Web::Simple's ${sub} export twice?"; |
86 | } |
87 | die $error; |
88 | } |
89 | |
90 | sub _setup_dispatcher { |
4ed4fb42 |
91 | my ($class, $dispatcher) = @_; |
44db8e76 |
92 | { |
93 | no strict 'refs'; |
94 | if (${"${class}::_dispatcher"}{CODE}) { |
95 | $class->_cannot_call_twice('_setup_dispatcher', 'dispatch'); |
96 | } |
97 | } |
795c4698 |
98 | { |
99 | no strict 'refs'; |
4ed4fb42 |
100 | *{"${class}::dispatch_request"} = $dispatcher; |
5c33dda5 |
101 | } |
5c33dda5 |
102 | } |
103 | |
3583ca04 |
104 | sub _build_final_dispatcher { |
4ed4fb42 |
105 | [ 404, [ 'Content-type', 'text/plain' ], [ 'Not found' ] ] |
5c33dda5 |
106 | } |
107 | |
108 | sub _run_with_self { |
109 | my ($self, $run, @args) = @_; |
110 | my $class = ref($self); |
111 | no strict 'refs'; |
112 | local *{"${class}::self"} = \$self; |
113 | $self->$run(@args); |
114 | } |
115 | |
116 | sub run_if_script { |
d3a61609 |
117 | # ->as_psgi_app is true for require() but also works for plackup |
118 | return $_[0]->as_psgi_app if caller(1); |
e27ab5c5 |
119 | my $self = ref($_[0]) ? $_[0] : $_[0]->new; |
5c33dda5 |
120 | $self->run(@_); |
121 | } |
122 | |
913a9cf9 |
123 | sub _run_cgi { |
5c33dda5 |
124 | my $self = shift; |
e27ab5c5 |
125 | require Plack::Server::CGI; |
d3a61609 |
126 | Plack::Server::CGI->run($self->as_psgi_app); |
127 | } |
128 | |
e27ab5c5 |
129 | sub _run_fcgi { |
130 | my $self = shift; |
131 | require Plack::Server::FCGI; |
132 | Plack::Server::FCGI->run($self->as_psgi_app); |
133 | } |
134 | |
d3a61609 |
135 | sub as_psgi_app { |
bc57805c |
136 | my $self = ref($_[0]) ? $_[0] : $_[0]->new; |
4ed4fb42 |
137 | require Web::Dispatch; |
138 | require Web::Simple::DispatchNode; |
139 | my $final = $self->_build_final_dispatcher; |
140 | Web::Dispatch->new( |
141 | app => sub { $self->dispatch_request(@_), $final }, |
142 | node_class => 'Web::Simple::DispatchNode', |
143 | node_args => { app_object => $self } |
144 | )->to_app; |
5c33dda5 |
145 | } |
146 | |
913a9cf9 |
147 | sub run { |
148 | my $self = shift; |
e27ab5c5 |
149 | if ($ENV{PHP_FCGI_CHILDREN} || $ENV{FCGI_ROLE} || $ENV{FCGI_SOCKET_PATH}) { |
150 | return $self->_run_fcgi; |
151 | } elsif ($ENV{GATEWAY_INTERFACE}) { |
2514ad17 |
152 | return $self->_run_cgi; |
913a9cf9 |
153 | } |
d104fb1d |
154 | unless (@ARGV && $ARGV[0] =~ m{^/}) { |
db2899c3 |
155 | return $self->_run_cli(@ARGV); |
d104fb1d |
156 | } |
157 | |
158 | my $path = shift @ARGV; |
913a9cf9 |
159 | |
913a9cf9 |
160 | require HTTP::Request::Common; |
e27ab5c5 |
161 | require Plack::Test; |
913a9cf9 |
162 | local *GET = \&HTTP::Request::Common::GET; |
163 | |
164 | my $request = GET($path); |
e27ab5c5 |
165 | my $response; |
166 | Plack::Test::test_psgi($self->as_psgi_app, sub { $response = shift->($request) }); |
167 | print $response->as_string; |
913a9cf9 |
168 | } |
169 | |
d104fb1d |
170 | sub _run_cli { |
171 | my $self = shift; |
172 | die $self->_cli_usage; |
173 | } |
174 | |
175 | sub _cli_usage { |
176 | "To run this script in CGI test mode, pass a URL path beginning with /:\n". |
177 | "\n". |
178 | " $0 /some/path\n". |
179 | " $0 /\n" |
180 | } |
181 | |
5c33dda5 |
182 | 1; |