Commit | Line | Data |
481da1e2 |
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 | } |