lib/Web/Dispatch.pm

   1 package Web::Dispatch;
   2
   3 use Sub::Quote;
   4 use Scalar::Util qw(blessed);
   5
   6 sub MAGIC_MIDDLEWARE_KEY { __PACKAGE__.'.middleware' }
   7
   8 use Moo;
   9 use Web::Dispatch::Parser;
  10 use Web::Dispatch::Node;
  11
  12 with 'Web::Dispatch::ToApp';
  13
  14 has dispatch_app => (
  15   is => 'lazy', builder => sub { shift->dispatch_object->to_app }
  16 );
  17 has dispatch_object => (is => 'ro', required => 0);
  18 has parser_class => (
  19   is => 'ro', default => quote_sub q{ 'Web::Dispatch::Parser' }
  20 );
  21 has node_class => (
  22   is => 'ro', default => quote_sub q{ 'Web::Dispatch::Node' }
  23 );
  24 has node_args => (is => 'ro', default => quote_sub q{ {} });
  25 has _parser => (is => 'lazy');
  26
  27 after BUILDARGS => sub {
  28   my ( $self, %args ) = @_;
  29   die "Either dispatch_app or dispatch_object need to be supplied."
  30     if !$args{dispatch_app} and !$args{dispatch_object}
  31 };
  32
  33 sub _build__parser {
  34   my ($self) = @_;
  35   $self->parser_class->new;
  36 }
  37
  38 sub call {
  39   my ($self, $env) = @_;
  40   my $res = $self->_dispatch($env, $self->dispatch_app);
  41   return $res->[0] if ref($res) eq 'ARRAY' and @{$res} == 1 and ref($res->[0]) eq 'CODE';
  42   return $res;
  43 }
  44
  45 sub _dispatch {
  46   my ($self, $env, @match) = @_;
  47   while (defined(my $try = shift @match)) {
  48
  49     return $try if ref($try) eq 'ARRAY';
  50     if (ref($try) eq 'HASH') {
  51       $env = { 'Web::Dispatch.original_env' => $env, %$env, %$try };
  52       next;
  53     }
  54
  55     my @result = $self->_to_try($try, \@match)->($env, @match);
  56     next unless @result and defined($result[0]);
  57
  58     my $first = $result[0];
  59
  60     if (my $res = $self->_have_result($first, \@result, \@match, $env)) {
  61
  62       return $res;
  63     }
  64
  65     # make a copy so we don't screw with it assigning further up
  66     my $env = $env;
  67     unshift @match, sub { $self->_dispatch($env, @result) };
  68   }
  69
  70   return;
  71 }
  72
  73 sub _have_result {
  74   my ($self, $first, $result, $match, $env) = @_;
  75
  76   if (ref($first) eq 'ARRAY') {
  77     return $first;
  78   }
  79   elsif (blessed($first) && $first->isa('Plack::Middleware')) {
  80     return $self->_uplevel_middleware($first, $result);
  81   }
  82   elsif (ref($first) eq 'HASH' and $first->{+MAGIC_MIDDLEWARE_KEY}) {
  83     return $self->_redispatch_with_middleware($first, $match, $env);
  84   }
  85   elsif (
  86     blessed($first) &&
  87     not($first->can('to_app')) &&
  88     not($first->isa('Web::Dispatch::Matcher'))
  89   ) {
  90     return $first;
  91   }
  92   return;
  93 }
  94
  95 sub _uplevel_middleware {
  96   my ($self, $match, $results) = @_;
  97   die "Multiple results but first one is a middleware ($match)"
  98     if @{$results} > 1;
  99   # middleware needs to uplevel exactly once to wrap the rest of the
 100   # level it was created for - next elsif unwraps it
 101   return { MAGIC_MIDDLEWARE_KEY, $match };
 102 }
 103
 104 sub _redispatch_with_middleware {
 105   my ($self, $first, $match, $env) = @_;
 106
 107   my $mw = $first->{+MAGIC_MIDDLEWARE_KEY};
 108
 109   $mw->app(sub { $self->_dispatch($_[0], @{$match}) });
 110
 111   return $mw->to_app->($env);
 112 }
 113
 114 sub _to_try {
 115   my ($self, $try, $more) = @_;
 116
 117   # sub (<spec>) {}      becomes a dispatcher
 118   # sub {}               is a PSGI app and can be returned as is
 119   # '<spec>' => sub {}   becomes a dispatcher
 120   # $obj isa WD:Predicates::Matcher => sub { ... } -  become a dispatcher
 121   # $obj w/to_app method is a Plack::App-like thing - call it to get a PSGI app
 122   #
 123
 124   if (ref($try) eq 'CODE') {
 125     if (defined(my $proto = prototype($try))) {
 126       $self->_construct_node(match => $proto, run => $try);
 127     } else {
 128       $try
 129     }
 130   } elsif (!ref($try) and ref($more->[0]) eq 'CODE') {
 131     $self->_construct_node(match => $try, run => shift(@$more));
 132   } elsif (
 133     (blessed($try) && $try->isa('Web::Dispatch::Matcher'))
 134     and (ref($more->[0]) eq 'CODE')
 135   ) {
 136     $self->_construct_node(match => $try, run => shift(@$more));
 137   } elsif (blessed($try) && $try->can('to_app')) {
 138     $try->to_app;
 139   } else {
 140     die "No idea how we got here with $try";
 141   }
 142 }
 143
 144 sub _construct_node {
 145   my ($self, %args) = @_;
 146   $args{match} = $self->_parser->parse($args{match}) if !ref $args{match};
 147   $self->node_class->new({ %{$self->node_args}, %args })->to_app;
 148 }
 149
 150 1;