1 package Web::Simple::Application;
4 use warnings FATAL => 'all';
7 package Web::Simple::Dispatcher;
11 and "$_[1]" =~ /\w+=[A-Z]/
12 and $_[1]->isa(__PACKAGE__);
17 ? $_[0]->{next} = $_[1]
22 $_[0]->{next} = $_[1];
27 my ($self, $env, @args) = @_;
28 my $next = $self->_has_match ? $self->next : undef;
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 };
39 return () unless $next;
40 return $next->dispatch($env, @args);
45 ? $_[0]->{call} = $_[1]
49 sub _has_match { $_[0]->{match} }
52 return ({}, $_[1]) unless $_[0]->{match};
53 $_[0]->{match}->($_[1]);
62 my ($class, $data) = @_;
63 my $config = { $class->_default_config, %{($data||{})->{config}||{}} };
64 bless({ config => $config }, $class);
67 sub _setup_default_config {
71 if (${"${class}::_default_config"}{CODE}) {
72 $class->_cannot_call_twice('_setup_default_config', 'default_config');
75 my @defaults = (@_, $class->_default_config);
78 *{"${class}::_default_config"} = sub { @defaults };
82 sub _default_config { () }
88 sub _construct_response_filter {
90 $_[0]->_build_dispatcher({
92 my ($d, $self, $env) = (shift, shift, shift);
93 my @next = $d->next->dispatch($env, $self, @_);
95 $self->_run_with_self($code, @next);
100 sub _construct_redispatch {
101 my ($self, $new_path) = @_;
102 $self->_build_dispatcher({
105 my ($self, $env) = @_;
106 $self->_dispatch({ %{$env}, PATH_INFO => $new_path })
111 sub _build_dispatch_parser {
112 require Web::Simple::DispatchParser;
113 return Web::Simple::DispatchParser->new;
116 sub _cannot_call_twice {
117 my ($class, $method, $sub) = @_;
118 my $error = "Cannot call ${method} twice for ${class}";
120 $error .= " - did you call Web::Simple's ${sub} export twice?";
125 sub _setup_dispatcher {
126 my ($class, $dispatch_specs) = @_;
129 if (${"${class}::_dispatcher"}{CODE}) {
130 $class->_cannot_call_twice('_setup_dispatcher', 'dispatch');
133 my $chain = $class->_build_dispatch_chain(
134 [ @$dispatch_specs, $class->_build_final_dispatcher ]
138 *{"${class}::_dispatcher"} = sub { $chain };
142 sub _construct_subdispatch {
143 my ($class, $dispatch_spec) = @_;
144 my $disp = $class->_build_dispatcher_from_spec($dispatch_spec);
145 my $call = $disp->call;
147 my @res = $call->(@_);
149 my $chain = $class->_build_dispatch_chain(@res);
150 return $class->_build_dispatcher({
152 my ($d, $self, $env) = (shift, shift, shift);
153 return $chain->dispatch($env, $self, @_);
157 return $class->_build_dispatcher({
159 my ($d, $self, $env) = (shift, shift, shift);
160 my @sub = $disp->dispatch($env, $self, @_);
162 return unless (my $next = $d->next);
163 return $next->dispatch($env, $self, @_);
168 sub _build_dispatcher_from_spec {
169 my ($class, $spec) = @_;
170 return $spec unless ref($spec) eq 'CODE';
171 my $proto = prototype $spec;
172 my $parser = $class->_build_dispatch_parser;
175 ? $parser->parse_dispatch_specification($proto)
178 return $class->_build_dispatcher({
181 shift->_run_with_self($spec, @_)
186 sub _build_dispatch_chain {
187 my ($class, $dispatch_specs) = @_;
189 foreach my $dispatch_spec (@$dispatch_specs) {
190 my $new = $class->_build_dispatcher_from_spec($dispatch_spec);
192 $last = $last ? $last->next($new) : $new;
197 sub _build_dispatcher {
198 bless($_[1], 'Web::Simple::Dispatcher');
201 sub _build_final_dispatcher {
202 shift->_build_dispatcher({
205 404, [ 'Content-type', 'text/plain' ],
213 my ($self, $env) = @_;
214 $self->_dispatcher->dispatch($env, $self);
218 my ($self, $run, @args) = @_;
219 my $class = ref($self);
221 local *{"${class}::self"} = \$self;
226 # ->as_psgi_app is true for require() but also works for plackup
227 return $_[0]->as_psgi_app if caller(1);
229 my $self = $class->new;
235 require Web::Simple::HackedPlack;
236 Plack::Server::CGI->run($self->as_psgi_app);
241 ref($self) ? sub { $self->_dispatch(@_) } : sub { $self->new->_dispatch(@_) }
246 if ($ENV{GATEWAY_INTERFACE}) {
247 return $self->_run_cgi;
249 my $path = shift(@ARGV) or die "No path passed - use $0 / for root";
251 require HTTP::Request::AsCGI;
252 require HTTP::Request::Common;
253 local *GET = \&HTTP::Request::Common::GET;
255 my $request = GET($path);
256 my $c = HTTP::Request::AsCGI->new($request)->setup;
259 print $c->response->as_string;