lib/Web/Simple/Application.pm

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