lib/Web/Simple/Application.pm

   1 package Web::Simple::Application;
   2
   3 use strict;
   4 use warnings FATAL => 'all';
   5
   6 {
   7   package Web::Simple::Dispatcher;
   8
   9   sub _is_dispatcher {
  10     ref($_[1])
  11       and "$_[1]" =~ /\w+=[A-Z]/
  12       and $_[1]->isa(__PACKAGE__);
  13   }
  14
  15   sub next {
  16     @_ > 1
  17       ? $_[0]->{next} = $_[1]
  18       : shift->{next}
  19   }
  20
  21   sub set_next {
  22     $_[0]->{next} = $_[1];
  23     $_[0]
  24   }
  25
  26   sub dispatch {
  27     my ($self, $env, @args) = @_;
  28     my $next = $self->_has_match ? $self->next : undef;
  29     if (my ($env_delta, @match) = $self->_match_against($env)) {
  30       if (my ($result) = $self->_execute_with(@args, @match, $env)) {
  31         if ($self->_is_dispatcher($result)) {
  32           $next = $result->set_next($next);
  33           $env = { %$env, %$env_delta };
  34         } else {
  35           return $result;
  36         }
  37       }
  38     }
  39     return () unless $next;
  40     return $next->dispatch($env, @args);
  41   }
  42
  43   sub call {
  44     @_ > 1
  45       ? $_[0]->{call} = $_[1]
  46       : shift->{call}
  47   }
  48
  49   sub _has_match { $_[0]->{match} }
  50
  51   sub _match_against {
  52      return ({}, $_[1]) unless $_[0]->{match};
  53      $_[0]->{match}->($_[1]);
  54   }
  55
  56   sub _execute_with {
  57     $_[0]->{call}->(@_);
  58   }
  59 }
  60
  61 sub new {
  62   my ($class, $data) = @_;
  63   my $config = { $class->_default_config, %{($data||{})->{config}||{}} };
  64   my $new = bless({ config => $config }, $class);
  65   $new->BUILDALL($data);
  66   $new;
  67 }
  68
  69 sub BUILDALL {
  70   my ($self, $data) = @_;
  71   my $targ = ref($self);
  72   my @targ;
  73   while ($targ->isa(__PACKAGE__) and $targ ne __PACKAGE__) {
  74     push(@targ, "${targ}::BUILD")
  75       if do {
  76            no strict 'refs'; no warnings 'once';
  77            defined *{"${targ}::BUILD"}{CODE}
  78          };
  79     my @targ_isa = do { no strict 'refs'; @{"${targ}::ISA"} };
  80     die "${targ} uses Multiple Inheritance: ISA is: ".join ', ', @targ_isa
  81       if @targ_isa > 1;
  82     $targ = $targ_isa[0];
  83   }
  84   $self->$_($data) for reverse @targ;
  85   return;
  86 }
  87
  88 sub _setup_default_config {
  89   my $class = shift;
  90   {
  91     no strict 'refs';
  92     if (${"${class}::_default_config"}{CODE}) {
  93       $class->_cannot_call_twice('_setup_default_config', 'default_config');
  94     }
  95   }
  96   my @defaults = (@_, $class->_default_config);
  97   {
  98     no strict 'refs';
  99     *{"${class}::_default_config"} = sub { @defaults };
 100   }
 101 }
 102
 103 sub _default_config { () }
 104
 105 sub config {
 106   shift->{config};
 107 }
 108
 109 sub _construct_response_filter {
 110   my $code = $_[1];
 111   $_[0]->_build_dispatcher({
 112     call => sub {
 113       my ($d, $self, $env) = (shift, shift, shift);
 114       my @next = $d->next->dispatch($env, $self, @_);
 115       return unless @next;
 116       $self->_run_with_self($code, @next);
 117     },
 118   });
 119 }
 120
 121 sub _construct_redispatch {
 122   my ($self, $new_path) = @_;
 123   $self->_build_dispatcher({
 124     call => sub {
 125       shift;
 126       my ($self, $env) = @_;
 127       $self->_dispatch({ %{$env}, PATH_INFO => $new_path })
 128     }
 129   })
 130 }
 131
 132 sub _build_dispatch_parser {
 133   require Web::Dispatch::Parser;
 134   return Web::Dispatch::Parser->new;
 135 }
 136
 137 sub _cannot_call_twice {
 138   my ($class, $method, $sub) = @_;
 139   my $error = "Cannot call ${method} twice for ${class}";
 140   if ($sub) {
 141     $error .= " - did you call Web::Simple's ${sub} export twice?";
 142   }
 143   die $error;
 144 }
 145
 146 sub _setup_dispatcher {
 147   my ($class, $dispatch_specs) = @_;
 148   {
 149     no strict 'refs';
 150     if (${"${class}::_dispatcher"}{CODE}) {
 151       $class->_cannot_call_twice('_setup_dispatcher', 'dispatch');
 152     }
 153   }
 154   my $chain = $class->_build_dispatch_chain(
 155     [ @$dispatch_specs, $class->_build_final_dispatcher ]
 156   );
 157   {
 158     no strict 'refs';
 159     *{"${class}::_dispatcher"} = sub { $chain };
 160   }
 161 }
 162
 163 sub _construct_subdispatch {
 164   my ($class, $dispatch_spec) = @_;
 165   my $disp = $class->_build_dispatcher_from_spec($dispatch_spec);
 166   my $call = $disp->call;
 167   $disp->call(sub {
 168     my @res = $call->(@_);
 169     return unless @res;
 170     my $chain = $class->_build_dispatch_chain(@res);
 171     return $class->_build_dispatcher({
 172       call => sub {
 173         my ($d, $self, $env) = (shift, shift, shift); pop; # lose trailing $env
 174         return $chain->dispatch($env, $self, @_);
 175       }
 176     });
 177   });
 178   return $class->_build_dispatcher({
 179     call => sub {
 180       my ($d, $self, $env) = (shift, shift, shift); pop; # lose trailing $env
 181       my @sub = $disp->dispatch($env, $self, @_);
 182       return @sub if @sub;
 183       return unless (my $next = $d->next);
 184       return $next->dispatch($env, $self, @_);
 185     },
 186   });
 187 }
 188
 189 sub _build_dispatcher_from_spec {
 190   my ($class, $spec) = @_;
 191   return $spec unless ref($spec) eq 'CODE';
 192   my $proto = prototype $spec;
 193   my $parser = $class->_build_dispatch_parser;
 194   my $matcher = (
 195     defined($proto) && length($proto)
 196       ? $parser->parse($proto)
 197       : sub { ({}, $_[1]) }
 198   );
 199   return $class->_build_dispatcher({
 200     match => $matcher,
 201     call => sub { shift;
 202       shift->_run_with_self($spec, @_)
 203     },
 204   });
 205 }
 206
 207 sub _build_dispatch_chain {
 208   my ($class, $dispatch_specs) = @_;
 209   my ($root, $last);
 210   foreach my $dispatch_spec (@$dispatch_specs) {
 211     my $new = $class->_build_dispatcher_from_spec($dispatch_spec);
 212     $root ||= $new;
 213     $last = $last ? $last->next($new) : $new;
 214   }
 215   return $root;
 216 }
 217
 218 sub _build_dispatcher {
 219   bless($_[1], 'Web::Simple::Dispatcher');
 220 }
 221
 222 sub _build_final_dispatcher {
 223   shift->_build_dispatcher({
 224     call => sub {
 225       [
 226         404, [ 'Content-type', 'text/plain' ],
 227         [ 'Not found' ]
 228       ]
 229     }
 230   })
 231 }
 232
 233 sub _dispatch {
 234   my ($self, $env) = @_;
 235   $self->_dispatcher->dispatch($env, $self);
 236 }
 237
 238 sub _run_with_self {
 239   my ($self, $run, @args) = @_;
 240   my $class = ref($self);
 241   no strict 'refs';
 242   local *{"${class}::self"} = \$self;
 243   $self->$run(@args);
 244 }
 245
 246 sub run_if_script {
 247   # ->as_psgi_app is true for require() but also works for plackup
 248   return $_[0]->as_psgi_app if caller(1);
 249   my $self = ref($_[0]) ? $_[0] : $_[0]->new;
 250   $self->run(@_);
 251 }
 252
 253 sub _run_cgi {
 254   my $self = shift;
 255   require Plack::Server::CGI;
 256   Plack::Server::CGI->run($self->as_psgi_app);
 257 }
 258
 259 sub _run_fcgi {
 260   my $self = shift;
 261   require Plack::Server::FCGI;
 262   Plack::Server::FCGI->run($self->as_psgi_app);
 263 }
 264
 265 sub as_psgi_app {
 266   my $self = ref($_[0]) ? $_[0] : $_[0]->new;
 267   sub { $self->_dispatch(@_) };
 268 }
 269
 270 sub run {
 271   my $self = shift;
 272   if ($ENV{PHP_FCGI_CHILDREN} || $ENV{FCGI_ROLE} || $ENV{FCGI_SOCKET_PATH}) {
 273     return $self->_run_fcgi;
 274   } elsif ($ENV{GATEWAY_INTERFACE}) {
 275     return $self->_run_cgi;
 276   }
 277   unless (@ARGV && $ARGV[0] =~ m{^/}) {
 278     return $self->_run_cli(@ARGV);
 279   }
 280
 281   my $path = shift @ARGV;
 282
 283   require HTTP::Request::Common;
 284   require Plack::Test;
 285   local *GET = \&HTTP::Request::Common::GET;
 286
 287   my $request = GET($path);
 288   my $response;
 289   Plack::Test::test_psgi($self->as_psgi_app, sub { $response = shift->($request) });
 290   print $response->as_string;
 291 }
 292
 293 sub _run_cli {
 294   my $self = shift;
 295   die $self->_cli_usage;
 296 }
 297
 298 sub _cli_usage {
 299   "To run this script in CGI test mode, pass a URL path beginning with /:\n".
 300   "\n".
 301   "  $0 /some/path\n".
 302   "  $0 /\n"
 303 }
 304
 305 1;