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