lib/Web/Simple/Application.pm

   1 package Web::Simple::Application;
   2
   3 use strict;
   4 use warnings FATAL => 'all';
   5
   6 {
   7   package Web::Simple::Dispatcher;
   8
   9   sub _is_dispatcher {
  10     ref($_[1])
  11       and "$_[1]" =~ /\w+=[A-Z]/
  12       and $_[1]->isa(__PACKAGE__);
  13   }
  14
  15   sub next {
  16     @_ > 1
  17       ? $_[0]->{next} = $_[1]
  18       : shift->{next}
  19   }
  20
  21   sub set_next {
  22     $_[0]->{next} = $_[1];
  23     $_[0]
  24   }
  25
  26   sub dispatch {
  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 };
  34         } else {
  35           return $result;
  36         }
  37       }
  38     }
  39     return () unless $next;
  40     return $next->dispatch($env, @args);
  41   }
  42
  43   sub call {
  44     @_ > 1
  45       ? $_[0]->{call} = $_[1]
  46       : shift->{call}
  47   }
  48
  49   sub _has_match { $_[0]->{match} }
  50
  51   sub _match_against {
  52      return ({}, $_[1]) unless $_[0]->{match};
  53      $_[0]->{match}->($_[1]);
  54   }
  55
  56   sub _execute_with {
  57     $_[0]->{call}->(@_);
  58   }
  59 }
  60
  61 sub new {
  62   my ($class, $data) = @_;
  63   my $config = { $class->_default_config, %{($data||{})->{config}||{}} };
  64   bless({ config => $config }, $class);
  65 }
  66
  67 sub _setup_default_config {
  68   my $class = shift;
  69   {
  70     no strict 'refs';
  71     if (${"${class}::_default_config"}{CODE}) {
  72       $class->_cannot_call_twice('_setup_default_config', 'default_config');
  73     }
  74   }
  75   my @defaults = (@_, $class->_default_config);
  76   {
  77     no strict 'refs';
  78     *{"${class}::_default_config"} = sub { @defaults };
  79   }
  80 }
  81
  82 sub _default_config { () }
  83
  84 sub config {
  85   shift->{config};
  86 }
  87
  88 sub _construct_response_filter {
  89   my $code = $_[1];
  90   $_[0]->_build_dispatcher({
  91     call => sub {
  92       my ($d, $self, $env) = (shift, shift, shift);
  93       my @next = $d->next->dispatch($env, $self, @_);
  94       return unless @next;
  95       $self->_run_with_self($code, @next);
  96     },
  97   });
  98 }
  99
 100 sub _construct_redispatch {
 101   my ($self, $new_path) = @_;
 102   $self->_build_dispatcher({
 103     call => sub {
 104       shift;
 105       my ($self, $env) = @_;
 106       $self->_dispatch({ %{$env}, PATH_INFO => $new_path })
 107     }
 108   })
 109 }
 110
 111 sub _build_dispatch_parser {
 112   require Web::Simple::DispatchParser;
 113   return Web::Simple::DispatchParser->new;
 114 }
 115
 116 sub _cannot_call_twice {
 117   my ($class, $method, $sub) = @_;
 118   my $error = "Cannot call ${method} twice for ${class}";
 119   if ($sub) {
 120     $error .= " - did you call Web::Simple's ${sub} export twice?";
 121   }
 122   die $error;
 123 }
 124
 125 sub _setup_dispatcher {
 126   my ($class, $dispatch_specs) = @_;
 127   {
 128     no strict 'refs';
 129     if (${"${class}::_dispatcher"}{CODE}) {
 130       $class->_cannot_call_twice('_setup_dispatcher', 'dispatch');
 131     }
 132   }
 133   my $chain = $class->_build_dispatch_chain(
 134     [ @$dispatch_specs, $class->_build_final_dispatcher ]
 135   );
 136   {
 137     no strict 'refs';
 138     *{"${class}::_dispatcher"} = sub { $chain };
 139   }
 140 }
 141
 142 sub _construct_subdispatch {
 143   my ($class, $dispatch_spec) = @_;
 144   my $disp = $class->_build_dispatcher_from_spec($dispatch_spec);
 145   my $call = $disp->call;
 146   $disp->call(sub {
 147     my @res = $call->(@_);
 148     return unless @res;
 149     my $chain = $class->_build_dispatch_chain(@res);
 150     return $class->_build_dispatcher({
 151       call => sub {
 152         my ($d, $self, $env) = (shift, shift, shift);
 153         return $chain->dispatch($env, $self, @_);
 154       }
 155     });
 156   });
 157   return $class->_build_dispatcher({
 158     call => sub {
 159       my ($d, $self, $env) = (shift, shift, shift);
 160       my @sub = $disp->dispatch($env, $self, @_);
 161       return @sub if @sub;
 162       return unless (my $next = $d->next);
 163       return $next->dispatch($env, $self, @_);
 164     },
 165   });
 166 }
 167
 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;
 173   my $matcher = (
 174     defined($proto)
 175       ? $parser->parse_dispatch_specification($proto)
 176       : undef
 177   );
 178   return $class->_build_dispatcher({
 179     match => $matcher,
 180     call => sub { shift;
 181       shift->_run_with_self($spec, @_)
 182     },
 183   });
 184 }
 185
 186 sub _build_dispatch_chain {
 187   my ($class, $dispatch_specs) = @_;
 188   my ($root, $last);
 189   foreach my $dispatch_spec (@$dispatch_specs) {
 190     my $new = $class->_build_dispatcher_from_spec($dispatch_spec);
 191     $root ||= $new;
 192     $last = $last ? $last->next($new) : $new;
 193   }
 194   return $root;
 195 }
 196
 197 sub _build_dispatcher {
 198   bless($_[1], 'Web::Simple::Dispatcher');
 199 }
 200
 201 sub _build_final_dispatcher {
 202   shift->_build_dispatcher({
 203     call => sub {
 204       [
 205         404, [ 'Content-type', 'text/plain' ],
 206         [ 'Not found' ]
 207       ]
 208     }
 209   })
 210 }
 211
 212 sub _dispatch {
 213   my ($self, $env) = @_;
 214   $self->_dispatcher->dispatch($env, $self);
 215 }
 216
 217 sub _run_with_self {
 218   my ($self, $run, @args) = @_;
 219   my $class = ref($self);
 220   no strict 'refs';
 221   local *{"${class}::self"} = \$self;
 222   $self->$run(@args);
 223 }
 224
 225 sub run_if_script {
 226   # ->as_psgi_app is true for require() but also works for plackup
 227   return $_[0]->as_psgi_app if caller(1);
 228   my $class = shift;
 229   my $self = $class->new;
 230   $self->run(@_);
 231 }
 232
 233 sub _run_cgi {
 234   my $self = shift;
 235   require Web::Simple::HackedPlack;
 236   Plack::Server::CGI->run($self->as_psgi_app);
 237 }
 238
 239 sub as_psgi_app {
 240   my $self = shift;
 241   ref($self) ? sub { $self->_dispatch(@_) } : sub { $self->new->_dispatch(@_) }
 242 }
 243
 244 sub run {
 245   my $self = shift;
 246   if ($ENV{GATEWAY_INTERFACE}) {
 247     return $self->_run_cgi;
 248   }
 249   my $path = shift(@ARGV) or die "No path passed - use $0 / for root";
 250
 251   require HTTP::Request::AsCGI;
 252   require HTTP::Request::Common;
 253   local *GET = \&HTTP::Request::Common::GET;
 254
 255   my $request = GET($path);
 256   my $c = HTTP::Request::AsCGI->new($request)->setup;
 257   $self->_run_cgi;
 258   $c->restore;
 259   print $c->response->as_string;
 260 }
 261
 262 1;