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