3 use Test::More tests => 30;
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');
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')
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');
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';
38 delete $ENV{$_} if /^HTTPS?/;
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');
48 can_ok($r => 'parse_location');
49 $ENV{HTTP_REFERER} = 'http://maypole.perl.org/';
50 $ENV{HTTP_USER_AGENT} = 'tty';
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');
58 #delete $r->{cgi}{'.path_info'};
59 $ENV{PATH_INFO} = '/brewery/view/1/2/3';
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');
68 parse_path => sub {$calls{parse_path} = \@_},
69 parse_args => sub {$calls{parse_args} = \@_},
72 is_deeply($calls{parse_path}, [$r], '... calls parse_path');
73 is_deeply($calls{parse_args}, [$r], '... calls parse_args');
77 $mock_maypole->unmock('parse_args');
78 can_ok($r => 'parse_args');
79 $cgi->parse_query_string;
81 is_deeply($r->params, { beer => [1,2], pub => 'red lion', handpump => undef },
83 is_deeply($r->params, $r->query, '... query and params are identical');
86 can_ok($r => 'send_output');
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!');
96 IO::CaptureOutput::capture(sub {$r->send_output}, \$stdout);
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');
103 # test custom output headers
104 $r->headers_out->set(X_Bender => 'kiss my shiny metal ass');
106 IO::CaptureOutput::capture(sub {$r->send_output}, \$stdout);
110 $compare = join "\cM\cJ", 'Content-length: 12',
111 'X-bender: kiss my shiny metal ass',
112 'Content-Type: text/plain; charset=iso8859-1',
114 is($stdout, $compare, '... prints output, including custom headers');
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])');