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