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   my $new = bless({ config => $config }, $class);
  10   $new->BUILDALL($data);
  11   $new;
  12 }
  13
  14 sub BUILDALL {
  15   my ($self, $data) = @_;
  16   my $targ = ref($self);
  17   my @targ;
  18   while ($targ->isa(__PACKAGE__) and $targ ne __PACKAGE__) {
  19     push(@targ, "${targ}::BUILD")
  20       if do {
  21            no strict 'refs'; no warnings 'once';
  22            defined *{"${targ}::BUILD"}{CODE}
  23          };
  24     my @targ_isa = do { no strict 'refs'; @{"${targ}::ISA"} };
  25     die "${targ} uses Multiple Inheritance: ISA is: ".join ', ', @targ_isa
  26       if @targ_isa > 1;
  27     $targ = $targ_isa[0];
  28   }
  29   $self->$_($data) for reverse @targ;
  30   return;
  31 }
  32
  33 sub _setup_default_config {
  34   my $class = shift;
  35   {
  36     no strict 'refs';
  37     if (${"${class}::_default_config"}{CODE}) {
  38       $class->_cannot_call_twice('_setup_default_config', 'default_config');
  39     }
  40   }
  41   my @defaults = (@_, $class->_default_config);
  42   {
  43     no strict 'refs';
  44     *{"${class}::_default_config"} = sub { @defaults };
  45   }
  46 }
  47
  48 sub _default_config { () }
  49
  50 sub config {
  51   shift->{config};
  52 }
  53
  54 sub _construct_response_filter {
  55   my ($class, $code) = @_;
  56   my $self = do { no strict 'refs'; ${"${class}::self"} };
  57   require Web::Dispatch::Wrapper;
  58   Web::Dispatch::Wrapper->from_code(sub {
  59     my @result = $_[1]->($_[0]);
  60     if (@result) {
  61       $self->_run_with_self($code, @result);
  62     } else {
  63       @result;
  64     }
  65   });
  66 }
  67
  68 sub _construct_redispatch {
  69   my ($class, $new_path) = @_;
  70   require Web::Dispatch::Wrapper;
  71   Web::Dispatch::Wrapper->from_code(sub {
  72     $_[1]->({ %{$_[0]}, PATH_INFO => $new_path });
  73   });
  74 }
  75
  76 sub _build_dispatch_parser {
  77   require Web::Dispatch::Parser;
  78   return Web::Dispatch::Parser->new;
  79 }
  80
  81 sub _cannot_call_twice {
  82   my ($class, $method, $sub) = @_;
  83   my $error = "Cannot call ${method} twice for ${class}";
  84   if ($sub) {
  85     $error .= " - did you call Web::Simple's ${sub} export twice?";
  86   }
  87   die $error;
  88 }
  89
  90 sub _setup_dispatcher {
  91   my ($class, $dispatcher) = @_;
  92   {
  93     no strict 'refs';
  94     if (${"${class}::_dispatcher"}{CODE}) {
  95       $class->_cannot_call_twice('_setup_dispatcher', 'dispatch');
  96     }
  97   }
  98   {
  99     no strict 'refs';
 100     *{"${class}::dispatch_request"} = $dispatcher;
 101   }
 102 }
 103
 104 sub _build_final_dispatcher {
 105   [ 404, [ 'Content-type', 'text/plain' ], [ 'Not found' ] ]
 106 }
 107
 108 sub _run_with_self {
 109   my ($self, $run, @args) = @_;
 110   my $class = ref($self);
 111   no strict 'refs';
 112   local *{"${class}::self"} = \$self;
 113   $self->$run(@args);
 114 }
 115
 116 sub run_if_script {
 117   # ->as_psgi_app is true for require() but also works for plackup
 118   return $_[0]->as_psgi_app if caller(1);
 119   my $self = ref($_[0]) ? $_[0] : $_[0]->new;
 120   $self->run(@_);
 121 }
 122
 123 sub _run_cgi {
 124   my $self = shift;
 125   require Plack::Server::CGI;
 126   Plack::Server::CGI->run($self->as_psgi_app);
 127 }
 128
 129 sub _run_fcgi {
 130   my $self = shift;
 131   require Plack::Server::FCGI;
 132   Plack::Server::FCGI->run($self->as_psgi_app);
 133 }
 134
 135 sub as_psgi_app {
 136   my $self = ref($_[0]) ? $_[0] : $_[0]->new;
 137   require Web::Dispatch;
 138   require Web::Simple::DispatchNode;
 139   my $final = $self->_build_final_dispatcher;
 140   Web::Dispatch->new(
 141     app => sub { $self->dispatch_request(@_), $final },
 142     node_class => 'Web::Simple::DispatchNode',
 143     node_args => { app_object => $self }
 144   )->to_app;
 145 }
 146
 147 sub run {
 148   my $self = shift;
 149   if ($ENV{PHP_FCGI_CHILDREN} || $ENV{FCGI_ROLE} || $ENV{FCGI_SOCKET_PATH}) {
 150     return $self->_run_fcgi;
 151   } elsif ($ENV{GATEWAY_INTERFACE}) {
 152     return $self->_run_cgi;
 153   }
 154   unless (@ARGV && $ARGV[0] =~ m{^/}) {
 155     return $self->_run_cli(@ARGV);
 156   }
 157
 158   my $path = shift @ARGV;
 159
 160   require HTTP::Request::Common;
 161   require Plack::Test;
 162   local *GET = \&HTTP::Request::Common::GET;
 163
 164   my $request = GET($path);
 165   my $response;
 166   Plack::Test::test_psgi($self->as_psgi_app, sub { $response = shift->($request) });
 167   print $response->as_string;
 168 }
 169
 170 sub _run_cli {
 171   my $self = shift;
 172   die $self->_cli_usage;
 173 }
 174
 175 sub _cli_usage {
 176   "To run this script in CGI test mode, pass a URL path beginning with /:\n".
 177   "\n".
 178   "  $0 /some/path\n".
 179   "  $0 /\n"
 180 }
 181
 182 1;