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