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   my $new = bless({ config => $config }, $class);
  65   $new->BUILDALL($data);
  66   $new;
  67 }
  68
  69 sub BUILDALL {
  70   my ($self, $data) = @_;
  71   my $targ = ref($self);
  72   my @targ;
  73   while ($targ->isa(__PACKAGE__) and $targ ne __PACKAGE__) {
  74     push(@targ, "${targ}::BUILD")
  75       if do { no strict 'refs'; defined *{"${targ}::BUILD"}{CODE} };
  76     my @targ_isa = do { no strict 'refs'; @{"${targ}::ISA"} };
  77     die "${targ} uses Multiple Inheritance: ISA is: ".join ', ', @targ_isa
  78       if @targ_isa > 1;
  79     $targ = $targ_isa[0];
  80   }
  81   $self->$_($data) for reverse @targ;
  82   return;
  83 }
  84
  85 sub _setup_default_config {
  86   my $class = shift;
  87   {
  88     no strict 'refs';
  89     if (${"${class}::_default_config"}{CODE}) {
  90       $class->_cannot_call_twice('_setup_default_config', 'default_config');
  91     }
  92   }
  93   my @defaults = (@_, $class->_default_config);
  94   {
  95     no strict 'refs';
  96     *{"${class}::_default_config"} = sub { @defaults };
  97   }
  98 }
  99
 100 sub _default_config { () }
 101
 102 sub config {
 103   shift->{config};
 104 }
 105
 106 sub _construct_response_filter {
 107   my $code = $_[1];
 108   $_[0]->_build_dispatcher({
 109     call => sub {
 110       my ($d, $self, $env) = (shift, shift, shift);
 111       my @next = $d->next->dispatch($env, $self, @_);
 112       return unless @next;
 113       $self->_run_with_self($code, @next);
 114     },
 115   });
 116 }
 117
 118 sub _construct_redispatch {
 119   my ($self, $new_path) = @_;
 120   $self->_build_dispatcher({
 121     call => sub {
 122       shift;
 123       my ($self, $env) = @_;
 124       $self->_dispatch({ %{$env}, PATH_INFO => $new_path })
 125     }
 126   })
 127 }
 128
 129 sub _build_dispatch_parser {
 130   require Web::Simple::DispatchParser;
 131   return Web::Simple::DispatchParser->new;
 132 }
 133
 134 sub _cannot_call_twice {
 135   my ($class, $method, $sub) = @_;
 136   my $error = "Cannot call ${method} twice for ${class}";
 137   if ($sub) {
 138     $error .= " - did you call Web::Simple's ${sub} export twice?";
 139   }
 140   die $error;
 141 }
 142
 143 sub _setup_dispatcher {
 144   my ($class, $dispatch_specs) = @_;
 145   {
 146     no strict 'refs';
 147     if (${"${class}::_dispatcher"}{CODE}) {
 148       $class->_cannot_call_twice('_setup_dispatcher', 'dispatch');
 149     }
 150   }
 151   my $chain = $class->_build_dispatch_chain(
 152     [ @$dispatch_specs, $class->_build_final_dispatcher ]
 153   );
 154   {
 155     no strict 'refs';
 156     *{"${class}::_dispatcher"} = sub { $chain };
 157   }
 158 }
 159
 160 sub _construct_subdispatch {
 161   my ($class, $dispatch_spec) = @_;
 162   my $disp = $class->_build_dispatcher_from_spec($dispatch_spec);
 163   my $call = $disp->call;
 164   $disp->call(sub {
 165     my @res = $call->(@_);
 166     return unless @res;
 167     my $chain = $class->_build_dispatch_chain(@res);
 168     return $class->_build_dispatcher({
 169       call => sub {
 170         my ($d, $self, $env) = (shift, shift, shift);
 171         return $chain->dispatch($env, $self, @_);
 172       }
 173     });
 174   });
 175   return $class->_build_dispatcher({
 176     call => sub {
 177       my ($d, $self, $env) = (shift, shift, shift);
 178       my @sub = $disp->dispatch($env, $self, @_);
 179       return @sub if @sub;
 180       return unless (my $next = $d->next);
 181       return $next->dispatch($env, $self, @_);
 182     },
 183   });
 184 }
 185
 186 sub _build_dispatcher_from_spec {
 187   my ($class, $spec) = @_;
 188   return $spec unless ref($spec) eq 'CODE';
 189   my $proto = prototype $spec;
 190   my $parser = $class->_build_dispatch_parser;
 191   my $matcher = (
 192     defined($proto) && length($proto)
 193       ? $parser->parse_dispatch_specification($proto)
 194       : undef
 195   );
 196   return $class->_build_dispatcher({
 197     match => $matcher,
 198     call => sub { shift;
 199       shift->_run_with_self($spec, @_)
 200     },
 201   });
 202 }
 203
 204 sub _build_dispatch_chain {
 205   my ($class, $dispatch_specs) = @_;
 206   my ($root, $last);
 207   foreach my $dispatch_spec (@$dispatch_specs) {
 208     my $new = $class->_build_dispatcher_from_spec($dispatch_spec);
 209     $root ||= $new;
 210     $last = $last ? $last->next($new) : $new;
 211   }
 212   return $root;
 213 }
 214
 215 sub _build_dispatcher {
 216   bless($_[1], 'Web::Simple::Dispatcher');
 217 }
 218
 219 sub _build_final_dispatcher {
 220   shift->_build_dispatcher({
 221     call => sub {
 222       [
 223         404, [ 'Content-type', 'text/plain' ],
 224         [ 'Not found' ]
 225       ]
 226     }
 227   })
 228 }
 229
 230 sub _dispatch {
 231   my ($self, $env) = @_;
 232   $self->_dispatcher->dispatch($env, $self);
 233 }
 234
 235 sub _run_with_self {
 236   my ($self, $run, @args) = @_;
 237   my $class = ref($self);
 238   no strict 'refs';
 239   local *{"${class}::self"} = \$self;
 240   $self->$run(@args);
 241 }
 242
 243 sub run_if_script {
 244   # ->as_psgi_app is true for require() but also works for plackup
 245   return $_[0]->as_psgi_app if caller(1);
 246   my $class = shift;
 247   my $self = $class->new;
 248   $self->run(@_);
 249 }
 250
 251 sub _run_cgi {
 252   my $self = shift;
 253   require Web::Simple::HackedPlack;
 254   Plack::Server::CGI->run($self->as_psgi_app);
 255 }
 256
 257 sub as_psgi_app {
 258   my $self = shift;
 259   ref($self) ? sub { $self->_dispatch(@_) } : sub { $self->new->_dispatch(@_) }
 260 }
 261
 262 sub run {
 263   my $self = shift;
 264   if ($ENV{GATEWAY_INTERFACE}) {
 265     return $self->_run_cgi;
 266   }
 267   my $path = shift(@ARGV) or die "No path passed - use $0 / for root";
 268
 269   require HTTP::Request::AsCGI;
 270   require HTTP::Request::Common;
 271   local *GET = \&HTTP::Request::Common::GET;
 272
 273   my $request = GET($path);
 274   my $c = HTTP::Request::AsCGI->new($request)->setup;
 275   $self->_run_cgi;
 276   $c->restore;
 277   print $c->response->as_string;
 278 }
 279
 280 1;