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->next;
  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 $next->dispatch($env, @args);
  40   }
  41
  42   sub _match_against {
  43      return ({}, $_[1]) unless $_[0]->{match};
  44      $_[0]->{match}->($_[1]);
  45   }
  46
  47   sub _execute_with {
  48     $_[0]->{call}->(@_);
  49   }
  50 }
  51
  52 sub new {
  53   my ($class, $data) = @_;
  54   my $config = { $class->_default_config, %{($data||{})->{config}||{}} };
  55   bless({ config => $config }, $class);
  56 }
  57
  58 sub _setup_default_config {
  59   my $class = shift;
  60   {
  61     no strict 'refs';
  62     if (${"${class}::_default_config"}{CODE}) {
  63       $class->_cannot_call_twice('_setup_default_config', 'default_config');
  64     }
  65   }
  66   my @defaults = (@_, $class->_default_config);
  67   {
  68     no strict 'refs';
  69     *{"${class}::_default_config"} = sub { @defaults };
  70   }
  71 }
  72
  73 sub _default_config { () }
  74
  75 sub config {
  76   shift->{config};
  77 }
  78
  79 sub _construct_response_filter {
  80   my $code = $_[1];
  81   $_[0]->_build_dispatcher({
  82     call => sub {
  83       my ($d, $self, $env) = (shift, shift, shift);
  84       $self->_run_with_self($code, $d->next->dispatch($env, $self, @_));
  85     },
  86   });
  87 }
  88
  89 sub _construct_redispatch {
  90   my ($self, $new_path) = @_;
  91   $self->_build_dispatcher({
  92     call => sub {
  93       shift;
  94       my ($self, $env) = @_;
  95       $self->_dispatch({ %{$env}, PATH_INFO => $new_path })
  96     }
  97   })
  98 }
  99
 100 sub _build_dispatch_parser {
 101   require Web::Simple::DispatchParser;
 102   return Web::Simple::DispatchParser->new;
 103 }
 104
 105 sub _cannot_call_twice {
 106   my ($class, $method, $sub) = @_;
 107   my $error = "Cannot call ${method} twice for ${class}";
 108   if ($sub) {
 109     $error .= " - did you call Web::Simple's ${sub} export twice?";
 110   }
 111   die $error;
 112 }
 113
 114 sub _setup_dispatcher {
 115   my ($class, $dispatch_subs) = @_;
 116   {
 117     no strict 'refs';
 118     if (${"${class}::_dispatcher"}{CODE}) {
 119       $class->_cannot_call_twice('_setup_dispatcher', 'dispatch');
 120     }
 121   }
 122   my $parser = $class->_build_dispatch_parser;
 123   my ($root, $last);
 124   foreach my $dispatch_sub (@$dispatch_subs) {
 125     my $proto = prototype $dispatch_sub;
 126     my $matcher = (
 127       defined($proto)
 128         ? $parser->parse_dispatch_specification($proto)
 129         : undef
 130     );
 131     my $new = $class->_build_dispatcher({
 132       match => $matcher,
 133       call => sub { shift;
 134         shift->_run_with_self($dispatch_sub, @_)
 135       },
 136     });
 137     $root ||= $new;
 138     $last = $last ? $last->next($new) : $new;
 139   }
 140   $last->next($class->_build_final_dispatcher);
 141   {
 142     no strict 'refs';
 143     *{"${class}::_dispatcher"} = sub { $root };
 144   }
 145 }
 146
 147 sub _build_dispatcher {
 148   bless($_[1], 'Web::Simple::Dispatcher');
 149 }
 150
 151 sub _build_final_dispatcher {
 152   shift->_build_dispatcher({
 153     call => sub {
 154       [
 155         500, [ 'Content-type', 'text/plain' ],
 156         [ 'The management apologises but we have no idea how to handle that' ]
 157       ]
 158     }
 159   })
 160 }
 161
 162 sub _dispatch {
 163   my ($self, $env) = @_;
 164   $self->_dispatcher->dispatch($env, $self);
 165 }
 166
 167 sub _run_with_self {
 168   my ($self, $run, @args) = @_;
 169   my $class = ref($self);
 170   no strict 'refs';
 171   local *{"${class}::self"} = \$self;
 172   $self->$run(@args);
 173 }
 174
 175 sub run_if_script {
 176   return 1 if caller(1); # 1 so we can be the last thing in the file
 177   my $class = shift;
 178   my $self = $class->new;
 179   $self->run(@_);
 180 }
 181
 182 sub _run_cgi {
 183   my $self = shift;
 184   require Web::Simple::HackedPlack;
 185   Plack::Server::CGI->run(sub { $self->_dispatch(@_) });
 186 }
 187
 188 sub run {
 189   my $self = shift;
 190   if ($ENV{GATEWAY_INTERFACE}) {
 191     return $self->_run_cgi;
 192   }
 193   my $path = shift(@ARGV) or die "No path passed - use $0 / for root";
 194
 195   require HTTP::Request::AsCGI;
 196   require HTTP::Request::Common;
 197   local *GET = \&HTTP::Request::Common::GET;
 198
 199   my $request = GET($path);
 200   my $c = HTTP::Request::AsCGI->new($request)->setup;
 201   $self->_run_cgi;
 202   $c->restore;
 203   print $c->response->as_string;
 204 }
 205
 206 1;