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