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