lib/Web/Simple/Application.pm

   1 package Web::Simple::Application;
   2
   3 use strict;
   4 use warnings FATAL => 'all';
   5
   6 sub new {
   7   my ($class, $data) = @_;
   8   my $config = { $class->_default_config, %{($data||{})->{config}||{}} };
   9   bless({ config => $config }, $class);
  10 }
  11
  12 sub _default_config { () }
  13
  14 sub config {
  15   shift->{config};
  16 }
  17
  18 sub _construct_response_filter {
  19   bless($_[1], 'Web::Simple::ResponseFilter');
  20 }
  21
  22 sub _is_response_filter {
  23   # simple blessed() hack
  24   "$_[1]" =~ /\w+=[A-Z]/
  25     and $_[1]->isa('Web::Simple::ResponseFilter');
  26 }
  27
  28 sub _construct_redispatch {
  29   bless(\$_[1], 'Web::Simple::Redispatch');
  30 }
  31
  32 sub _is_redispatch {
  33   return unless
  34     "$_[1]" =~ /\w+=[A-Z]/
  35       and $_[1]->isa('Web::Simple::Redispatch');
  36   return ${$_[1]};
  37 }
  38
  39 sub _dispatch_parser {
  40   require Web::Simple::DispatchParser;
  41   return Web::Simple::DispatchParser->new;
  42 }
  43
  44 sub _setup_dispatchables {
  45   my ($class, $dispatch_subs) = @_;
  46   my $parser = $class->_dispatch_parser;
  47   my @dispatchables;
  48   foreach my $dispatch_sub (@$dispatch_subs) {
  49     my $proto = prototype $dispatch_sub;
  50     my $matcher = (
  51       defined($proto)
  52         ? $parser->parse_dispatch_specification($proto)
  53         : sub { ({}) }
  54     );
  55     push @dispatchables, [ $matcher, $dispatch_sub ];
  56   }
  57   {
  58     no strict 'refs';
  59     *{"${class}::_dispatchables"} = sub { @dispatchables };
  60   }
  61 }
  62
  63 sub handle_request {
  64   my ($self, $env) = @_;
  65   $self->_run_dispatch_for($env, [ $self->_dispatchables ]);
  66 }
  67
  68 sub _run_dispatch_for {
  69   my ($self, $env, $dispatchables) = @_;
  70   my @disp = @$dispatchables;
  71   while (my $disp = shift @disp) {
  72     my ($match, $run) = @{$disp};
  73     if (my ($env_delta, @args) = $match->($env)) {
  74       my $new_env = { %$env, %$env_delta };
  75       if (my ($result) = $self->_run_with_self($run, @args)) {
  76         if ($self->_is_response_filter($result)) {
  77           return $self->_run_with_self(
  78             $result,
  79             $self->_run_dispatch_for($new_env, \@disp)
  80           );
  81         } elsif (my $path = $self->_is_redispatch($result)) {
  82           $new_env->{PATH_INFO} = $path;
  83           return $self->_run_dispatch_for($new_env, $dispatchables);
  84         }
  85         return $result;
  86       }
  87     }
  88   }
  89   return [
  90     500, [ 'Content-type', 'text/plain' ],
  91     [ 'The management apologises but we have no idea how to handle that' ]
  92   ];
  93 }
  94
  95 sub _run_with_self {
  96   my ($self, $run, @args) = @_;
  97   my $class = ref($self);
  98   no strict 'refs';
  99   local *{"${class}::self"} = \$self;
 100   $self->$run(@args);
 101 }
 102
 103 sub run_if_script {
 104   return 1 if caller(1); # 1 so we can be the last thing in the file
 105   my $class = shift;
 106   my $self = $class->new;
 107   $self->run(@_);
 108 }
 109
 110 sub _run_cgi {
 111   my $self = shift;
 112   require Web::Simple::HackedPlack;
 113   Plack::Server::CGI->run(sub { $self->handle_request(@_) });
 114 }
 115
 116 sub run {
 117   my $self = shift;
 118   if ($ENV{GATEWAY_INTERFACE}) {
 119     $self->_run_cgi;
 120   }
 121   my $path = shift(@ARGV);
 122
 123   require HTTP::Request::AsCGI;
 124   require HTTP::Request::Common;
 125   local *GET = \&HTTP::Request::Common::GET;
 126
 127   my $request = GET($path);
 128   my $c = HTTP::Request::AsCGI->new($request)->setup;
 129   $self->_run_cgi;
 130   $c->restore;
 131   print $c->response->as_string;
 132 }
 133
 134 1;