t/predicate_objects.t

   1 use strict;
   2 use warnings FATAL => 'all';
   3
   4 use Data::Dumper::Concise;
   5 use Test::More 'no_plan';
   6 use Plack::Test;
   7
   8 {
   9     use Web::Simple 't::Web::Simple::SubDispatchArgs';
  10     package t::Web::Simple::SubDispatchArgs;
  11     use Web::Dispatch::Predicates;
  12
  13     has 'attr' => (is=>'ro');
  14
  15     sub dispatch_request {
  16         my $self = shift;
  17         ## sub(/) {
  18         match_path(qr/(?-xism:^(\/)$)/), sub {
  19             $self->show_landing(@_);
  20         },
  21         ## sub(/...) {
  22         match_path_strip(qr/(?-xism:^()(\/.*)$)/) => sub {
  23             match_and
  24             (
  25                 match_method('GET'),
  26                 match_path(qr/(?-xism:^(\/user(?:\.\w+)?)$)/)
  27             )  => sub {
  28                 $self->show_users(@_);
  29             },
  30             match_path(qr/(?-xism:^(\/user\/([^\/]+?)(?:\.\w+)?)$)/), sub {
  31                 match_method('GET') => sub {
  32                     $self->show_user(@_);
  33                 },
  34                 match_and
  35                 (
  36                   match_method('POST'),
  37                   match_body
  38                   ({
  39                     named => [
  40                       {
  41                         multi => "",
  42                         name => "id"
  43                       },
  44                       {
  45                         multi => 1,
  46                         name => "roles"
  47                       }
  48                     ],
  49                     required => ["id"]
  50                   })
  51                 ) => sub {
  52                   $self->process_post(@_);
  53                 }
  54             },
  55         }
  56     };
  57
  58     sub show_landing {
  59         my ($self, @args) = @_;
  60         local $self->{_dispatcher};
  61         local $args[-1]->{'Web::Dispatch.original_env'};
  62         return [
  63             200, ['Content-Type' => 'application/perl' ],
  64             [::Dumper \@args],
  65         ];
  66     }
  67     sub show_users {
  68         my ($self, @args) = @_;
  69         local $self->{_dispatcher};
  70         local $args[-1]->{'Web::Dispatch.original_env'};
  71         return [
  72             200, ['Content-Type' => 'application/perl' ],
  73             [::Dumper \@args],
  74         ];
  75     }
  76     sub show_user {
  77         my ($self, @args) = @_;
  78         local $self->{_dispatcher};
  79         local $args[-1]->{'Web::Dispatch.original_env'};
  80         return [
  81             200, ['Content-Type' => 'application/perl' ],
  82             [::Dumper \@args],
  83         ];
  84     }
  85     sub process_post {
  86         my ($self, @args) = @_;
  87         local $self->{_dispatcher};
  88         local $args[-1]->{'Web::Dispatch.original_env'};
  89         return [
  90             200, ['Content-Type' => 'application/perl' ],
  91             [::Dumper \@args],
  92         ];
  93     }
  94 }
  95
  96 ok my $app = t::Web::Simple::SubDispatchArgs->new,
  97   'made app';
  98
  99 sub run_request { $app->run_test_request(@_); }
 100
 101 ok my $get_landing = run_request(GET => 'http://localhost/' ),
 102   'got landing';
 103
 104 cmp_ok $get_landing->code, '==', 200,
 105   '200 on GET';
 106
 107 no strict 'refs';
 108
 109 {
 110     my ($self, $env, @noextra) = @{eval($get_landing->content)||[]};
 111     die $@ if $@;
 112     is scalar(@noextra), 0, 'No extra stuff';
 113     is ref($self), 't::Web::Simple::SubDispatchArgs', 'got object';
 114     is ref($env), 'HASH', 'Got hashref';
 115 }
 116
 117 ok my $get_users = run_request(GET => 'http://localhost/user'),
 118   'got user';
 119
 120 cmp_ok $get_users->code, '==', 200,
 121   '200 on GET';
 122
 123 {
 124     my ($self, $env, @noextra) = @{eval $get_users->content};
 125     is scalar(@noextra), 0, 'No extra stuff';
 126     is ref($self), 't::Web::Simple::SubDispatchArgs', 'got object';
 127     is ref($env), 'HASH', 'Got hashref';
 128 }
 129
 130 ok my $get_user = run_request(GET => 'http://localhost/user/42'),
 131   'got user';
 132
 133 cmp_ok $get_user->code, '==', 200,
 134   '200 on GET';
 135
 136 {
 137     my ($self, $env, @noextra) = @{eval $get_user->content};
 138     is scalar(@noextra), 0, 'No extra stuff';
 139     is ref($self), 't::Web::Simple::SubDispatchArgs', 'got object';
 140     is ref($env), 'HASH', 'Got hashref';
 141 }
 142
 143 ok my $post_user = run_request(POST => 'http://localhost/user/42', id => '99' ),
 144   'post user';
 145
 146 cmp_ok $post_user->code, '==', 200,
 147   '200 on POST';
 148
 149 {
 150     my ($self, $params, $env, @noextra) = @{eval $post_user->content or die $@};
 151     is scalar(@noextra), 0, 'No extra stuff';
 152     is ref($self), 't::Web::Simple::SubDispatchArgs', 'got object';
 153     is ref($params), 'HASH', 'Got POST hashref';
 154     is $params->{id}, 99, 'got expected value for id';
 155     is ref($env), 'HASH', 'Got hashref';
 156 }