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