t/cgi_maypole.t

   1 #!/usr/bin/perl -w
   2 use strict;
   3 use Test::More tests => 30;
   4 use Test::MockModule;
   5
   6 require_ok('CGI::Maypole');
   7 ok($CGI::Maypole::VERSION, 'defines $VERSION');
   8 ok($INC{'CGI/Simple.pm'}, 'requires CGI::Simple');
   9 ok($INC{'Maypole/Headers.pm'}, 'requires Maypole::Headers');
  10 ok(CGI::Maypole->isa('Maypole'), '@ISA = Maypole');
  11
  12 my %calls;
  13 my $mock_maypole = new Test::MockModule('CGI::Maypole');
  14 my $mock_cgi = new Test::MockModule('CGI::Simple');
  15 $mock_cgi->mock(path_info => sub {
  16     delete $_[0]->{'.path_info'};
  17     my $orig_path_info = $mock_cgi->original('path_info');
  18     goto $orig_path_info;
  19 });
  20
  21 # run()
  22 can_ok('CGI::Maypole' => 'run');
  23 $mock_maypole->mock(handler => sub {$calls{handler} = \@_; 'X'});
  24 my $status = CGI::Maypole->run('TEST');
  25 ok($calls{handler}, '... calls handler()');
  26 is_deeply($calls{handler}, ['CGI::Maypole'],
  27           '... as a method, passing 0 arguments');
  28 is($status, 'X', '... and returns its status');
  29
  30 my $r = bless {}, 'CGI::Maypole';
  31 $r->headers_out(Maypole::Headers->new);
  32 $ENV{HTTP_HOST}      = 'localhost';
  33 $ENV{SCRIPT_NAME}    = '/maypole/index.cgi';
  34 $ENV{PATH_INFO}      = '/';
  35 $ENV{REQUEST_METHOD} = 'GET';
  36 $ENV{QUERY_STRING}   = 'beer=1;beer=2;pub=red+lion;handpump';
  37 $ENV{DOCUMENT_ROOT}  = '/var/tmp/maypole';
  38 for (keys %ENV) {
  39     delete $ENV{$_} if /^HTTPS?/;
  40 }
  41
  42 # get_request()
  43 can_ok($r => 'get_request');
  44 my $cgi = $r->get_request;
  45 isa_ok($cgi, 'CGI::Simple', '... returns a CGI::Simple object');
  46 is($cgi, $r->{cgi}, '... and stores it in the "cgi" slot');
  47
  48 # parse_location()
  49 can_ok($r => 'parse_location');
  50 $ENV{HTTP_REFERER} = 'http://maypole.perl.org/';
  51 $ENV{HTTP_USER_AGENT} = 'tty';
  52 $r->parse_location;
  53 is($r->headers_in->get('Referer'), 'http://maypole.perl.org/',
  54    '... sets headers_in() from HTTP variables');
  55 is_deeply([$r->headers_in->field_names], [qw(Referer User-Agent)],
  56    '... loads only those HTTP variables');
  57 is($r->path, 'frontpage', '... sets "path" to frontpage if undefined');
  58
  59 #delete $r->{cgi}{'.path_info'};
  60 $ENV{PATH_INFO} = '/brewery/view/1/2/3';
  61 $r->parse_location;
  62 is($r->path, 'brewery/view/1/2/3', '... path is PATH_INFO without leading /');
  63 is($r->table, 'brewery', '... sets "table" to first part of PATH_INFO');
  64 is($r->action, 'view', '... sets "action" to second part of PATH_INFO');
  65 is_deeply($r->args, [1,2,3],
  66           '... sets "args" to a list of remaining path segments');
  67
  68 $mock_maypole->mock(
  69     parse_path => sub {$calls{parse_path} = \@_},
  70     parse_args => sub {$calls{parse_args} = \@_},
  71 );
  72 $r->parse_location;
  73 is_deeply($calls{parse_path}, [$r], '... calls parse_path');
  74 is_deeply($calls{parse_args}, [$r], '... calls parse_args');
  75
  76
  77 # parse_args()
  78 $mock_maypole->unmock('parse_args');
  79 can_ok($r => 'parse_args');
  80 $cgi->parse_query_string;
  81 $r->parse_args;
  82 is_deeply($r->params, { beer => [1,2], pub => 'red lion', handpump => undef },
  83           '... parsed params');
  84 is_deeply($r->params, $r->query, '... query and params are identical');
  85
  86 # send_output()
  87 can_ok($r => 'send_output');
  88 SKIP: {
  89     eval "require IO::CaptureOutput";
  90     skip "IO::CaptureOutput not installed", 2 if $@;
  91     $r->content_type('text/plain');
  92     $r->document_encoding('iso8859-1');
  93     $r->output('Hello World!');
  94
  95     my $stdout;
  96     eval {
  97         IO::CaptureOutput::capture(sub {$r->send_output}, \$stdout);
  98     };
  99     diag $@ if $@;
 100     my $compare = join "\cM\cJ", 'Content-length: 12',
 101         'Content-Type: text/plain; charset=iso8859-1', '', 'Hello World!';
 102     is($stdout, $compare, '... prints output, including content-type header');
 103
 104     # test custom output headers
 105     $r->headers_out->set(X_Bender => 'kiss my shiny metal ass');
 106     eval {
 107         IO::CaptureOutput::capture(sub {$r->send_output}, \$stdout);
 108     };
 109     diag $@ if $@;
 110
 111     my $CL = 'Content-length: 12';
 112     my $XB = 'X-bender: kiss my shiny metal ass';
 113     my $nl = "\cM\cJ";
 114     my $re = join $nl, "($CL$nl$XB)|($XB$nl$CL)",
 115         'Content-Type: text/plain; charset=iso8859-1',
 116         '', 'Hello World!';
 117     like($stdout, qr/$re/, '... prints output, including custom headers');
 118 }
 119
 120 # get_template_root()
 121 can_ok($r => 'get_template_root');
 122 is($r->get_template_root(), '/var/tmp/maypole/index.cgi',
 123    '... catdir(document_root, [relative_url])');