t/sub-dispatch-args.t

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