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 _default_config { () }
  59
  60 sub config {
  61   shift->{config};
  62 }
  63
  64 sub _construct_response_filter {
  65   my $code = $_[1];
  66   $_[0]->_build_dispatcher({
  67     call => sub {
  68       my ($d, $self, $env) = (shift, shift, shift);
  69       $self->_run_with_self($code, $d->next->dispatch($env, $self, @_));
  70     },
  71   });
  72 }
  73
  74 sub _construct_redispatch {
  75   my ($self, $new_path) = @_;
  76   $self->_build_dispatcher({
  77     call => sub {
  78       shift;
  79       my ($self, $env) = @_;
  80       $self->handle_request({ %{$env}, PATH_INFO => $new_path })
  81     }
  82   })
  83 }
  84
  85 sub _dispatch_parser {
  86   require Web::Simple::DispatchParser;
  87   return Web::Simple::DispatchParser->new;
  88 }
  89
  90 sub _setup_dispatchables {
  91   my ($class, $dispatch_subs) = @_;
  92   my $parser = $class->_dispatch_parser;
  93   my @dispatchables;
  94   my ($root, $last);
  95   foreach my $dispatch_sub (@$dispatch_subs) {
  96     my $proto = prototype $dispatch_sub;
  97     my $matcher = (
  98       defined($proto)
  99         ? $parser->parse_dispatch_specification($proto)
 100         : undef
 101     );
 102     my $new = $class->_build_dispatcher({
 103       match => $matcher,
 104       call => sub { shift;
 105         shift->_run_with_self($dispatch_sub, @_)
 106       },
 107     });
 108     $root ||= $new;
 109     $last = $last ? $last->next($new) : $new;
 110     push @dispatchables, [ $matcher, $dispatch_sub ];
 111   }
 112   $last->next($class->_build_final_dispatcher);
 113   {
 114     no strict 'refs';
 115     *{"${class}::_dispatch_root"} = sub { $root };
 116   }
 117 }
 118
 119 sub _build_dispatcher {
 120   bless($_[1], 'Web::Simple::Dispatcher');
 121 }
 122
 123 sub _build_final_dispatcher {
 124   shift->_build_dispatcher({
 125     call => sub {
 126       [
 127         500, [ 'Content-type', 'text/plain' ],
 128         [ 'The management apologises but we have no idea how to handle that' ]
 129       ]
 130     }
 131   })
 132 }
 133
 134 sub handle_request {
 135   my ($self, $env) = @_;
 136   $self->_dispatch_root->dispatch($env, $self);
 137 }
 138
 139 sub _run_with_self {
 140   my ($self, $run, @args) = @_;
 141   my $class = ref($self);
 142   no strict 'refs';
 143   local *{"${class}::self"} = \$self;
 144   $self->$run(@args);
 145 }
 146
 147 sub run_if_script {
 148   return 1 if caller(1); # 1 so we can be the last thing in the file
 149   my $class = shift;
 150   my $self = $class->new;
 151   $self->run(@_);
 152 }
 153
 154 sub _run_cgi {
 155   my $self = shift;
 156   require Web::Simple::HackedPlack;
 157   Plack::Server::CGI->run(sub { $self->handle_request(@_) });
 158 }
 159
 160 sub run {
 161   my $self = shift;
 162   if ($ENV{GATEWAY_INTERFACE}) {
 163     $self->_run_cgi;
 164   }
 165   my $path = shift(@ARGV) or die "No path passed - use $0 / for root";
 166
 167   require HTTP::Request::AsCGI;
 168   require HTTP::Request::Common;
 169   local *GET = \&HTTP::Request::Common::GET;
 170
 171   my $request = GET($path);
 172   my $c = HTTP::Request::AsCGI->new($request)->setup;
 173   $self->_run_cgi;
 174   $c->restore;
 175   print $c->response->as_string;
 176 }
 177
 178 1;