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 _dispatch_parser {
  27   require Web::Simple::DispatchParser;
  28   return Web::Simple::DispatchParser->new;
  29 }
  30
  31 sub _setup_dispatchables {
  32   my ($class, $dispatch_subs) = @_;
  33   my $parser = $class->_dispatch_parser;
  34   my @dispatchables;
  35   foreach my $dispatch_sub (@$dispatch_subs) {
  36     my $proto = prototype $dispatch_sub;
  37     my $matcher = (
  38       defined($proto)
  39         ? $parser->parse_dispatch_specification($proto)
  40         : sub { ({}) }
  41     );
  42     push @dispatchables, [ $matcher, $dispatch_sub ];
  43   }
  44   {
  45     no strict 'refs';
  46     *{"${class}::_dispatchables"} = sub { @dispatchables };
  47   }
  48 }
  49
  50 sub handle_request {
  51   my ($self, $env) = @_;
  52   $self->_run_dispatch_for($env, [ $self->_dispatchables ]);
  53 }
  54
  55 sub _run_dispatch_for {
  56   my ($self, $env, $dispatchables) = @_;
  57   my @disp = @$dispatchables;
  58   while (my $disp = shift @disp) {
  59     my ($match, $run) = @{$disp};
  60     if (my ($env_delta, @args) = $match->($env)) {
  61       my $new_env = { %$env, %$env_delta };
  62       if (my ($result) = $self->_run_with_self($run, @args)) {
  63         if ($self->_is_response_filter($result)) {
  64           return $self->_run_with_self(
  65             $result,
  66             $self->_run_dispatch_for($new_env, \@disp)
  67           );
  68         }
  69         return $result;
  70       }
  71     }
  72   }
  73   return [
  74     500, [ 'Content-type', 'text/plain' ],
  75     'The management apologises but we have no idea how to handle that'
  76   ];
  77 }
  78
  79 sub _run_with_self {
  80   my ($self, $run, @args) = @_;
  81   my $class = ref($self);
  82   no strict 'refs';
  83   local *{"${class}::self"} = \$self;
  84   $self->$run(@args);
  85 }
  86
  87 sub run_if_script {
  88   return 1 if caller(1); # 1 so we can be the last thing in the file
  89   my $class = shift;
  90   my $self = $class->new;
  91   $self->run(@_);
  92 }
  93
  94 sub run {
  95   my $self = shift;
  96   unless ($ENV{GATEWAY_INTERFACE}) {
  97     die "mst is an idiot and didn't fix non-CGI yet";
  98   }
  99   require Web::Simple::HackedPlack;
 100   Plack::Server::CGI->run(sub { $self->handle_request(@_) });
 101 }
 102
 103 1;