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