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}||{}} }; |
9 | bless({ config => $config }, $class); |
10 | } |
11 | |
3d5e4d2d |
12 | sub _default_config { () } |
13 | |
5c33dda5 |
14 | sub config { |
15 | shift->{config}; |
16 | } |
17 | |
18 | sub _construct_response_filter { |
19 | bless($_[1], 'Web::Simple::ResponseFilter'); |
20 | } |
21 | |
22 | sub _is_response_filter { |
23 | # simple blessed() hack |
24 | "$_[1]" =~ /\w+=[A-Z]/ |
25 | and $_[1]->isa('Web::Simple::ResponseFilter'); |
26 | } |
27 | |
39119082 |
28 | sub _construct_redispatch { |
29 | bless(\$_[1], 'Web::Simple::Redispatch'); |
30 | } |
31 | |
32 | sub _is_redispatch { |
33 | return unless |
34 | "$_[1]" =~ /\w+=[A-Z]/ |
35 | and $_[1]->isa('Web::Simple::Redispatch'); |
36 | return ${$_[1]}; |
37 | } |
38 | |
5c33dda5 |
39 | sub _dispatch_parser { |
40 | require Web::Simple::DispatchParser; |
41 | return Web::Simple::DispatchParser->new; |
42 | } |
43 | |
44 | sub _setup_dispatchables { |
45 | my ($class, $dispatch_subs) = @_; |
46 | my $parser = $class->_dispatch_parser; |
47 | my @dispatchables; |
48 | foreach my $dispatch_sub (@$dispatch_subs) { |
49 | my $proto = prototype $dispatch_sub; |
50 | my $matcher = ( |
51 | defined($proto) |
52 | ? $parser->parse_dispatch_specification($proto) |
53 | : sub { ({}) } |
54 | ); |
55 | push @dispatchables, [ $matcher, $dispatch_sub ]; |
56 | } |
57 | { |
58 | no strict 'refs'; |
59 | *{"${class}::_dispatchables"} = sub { @dispatchables }; |
60 | } |
61 | } |
62 | |
63 | sub handle_request { |
64 | my ($self, $env) = @_; |
65 | $self->_run_dispatch_for($env, [ $self->_dispatchables ]); |
66 | } |
67 | |
68 | sub _run_dispatch_for { |
69 | my ($self, $env, $dispatchables) = @_; |
70 | my @disp = @$dispatchables; |
71 | while (my $disp = shift @disp) { |
72 | my ($match, $run) = @{$disp}; |
73 | if (my ($env_delta, @args) = $match->($env)) { |
74 | my $new_env = { %$env, %$env_delta }; |
75 | if (my ($result) = $self->_run_with_self($run, @args)) { |
76 | if ($self->_is_response_filter($result)) { |
77 | return $self->_run_with_self( |
78 | $result, |
79 | $self->_run_dispatch_for($new_env, \@disp) |
80 | ); |
39119082 |
81 | } elsif (my $path = $self->_is_redispatch($result)) { |
82 | $new_env->{PATH_INFO} = $path; |
83 | return $self->_run_dispatch_for($new_env, $dispatchables); |
5c33dda5 |
84 | } |
85 | return $result; |
86 | } |
87 | } |
88 | } |
89 | return [ |
90 | 500, [ 'Content-type', 'text/plain' ], |
2dbefe8b |
91 | [ 'The management apologises but we have no idea how to handle that' ] |
5c33dda5 |
92 | ]; |
93 | } |
94 | |
95 | sub _run_with_self { |
96 | my ($self, $run, @args) = @_; |
97 | my $class = ref($self); |
98 | no strict 'refs'; |
99 | local *{"${class}::self"} = \$self; |
100 | $self->$run(@args); |
101 | } |
102 | |
103 | sub run_if_script { |
104 | return 1 if caller(1); # 1 so we can be the last thing in the file |
105 | my $class = shift; |
106 | my $self = $class->new; |
107 | $self->run(@_); |
108 | } |
109 | |
913a9cf9 |
110 | sub _run_cgi { |
5c33dda5 |
111 | my $self = shift; |
5c33dda5 |
112 | require Web::Simple::HackedPlack; |
113 | Plack::Server::CGI->run(sub { $self->handle_request(@_) }); |
114 | } |
115 | |
913a9cf9 |
116 | sub run { |
117 | my $self = shift; |
118 | if ($ENV{GATEWAY_INTERFACE}) { |
119 | $self->_run_cgi; |
120 | } |
121 | my $path = shift(@ARGV); |
122 | |
123 | require HTTP::Request::AsCGI; |
124 | require HTTP::Request::Common; |
125 | local *GET = \&HTTP::Request::Common::GET; |
126 | |
127 | my $request = GET($path); |
128 | my $c = HTTP::Request::AsCGI->new($request)->setup; |
129 | $self->_run_cgi; |
130 | $c->restore; |
131 | print $c->response->as_string; |
132 | } |
133 | |
5c33dda5 |
134 | 1; |