t/sub-dispatch-args.t

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