t/lib/Mason/ApacheTest.pm

package Mason::ApacheTest;

use strict;
use warnings;

use Apache::test qw( have_httpd have_module );
use File::Basename qw( dirname );
use File::Path qw( mkpath rmtree );
use File::Spec;
use Module::Build;
use Test::More;

use lib 'inc';

use base 'Exporter';
our @EXPORT_OK = qw( require_libapreq require_cgi require_apache_filter chmod_data_dir );


my $TestConfig;

INIT
{
    $TestConfig = Module::Build->current()->notes()->{apache_test_conf};

    unless ( $TestConfig
             && defined $TestConfig->{apache_dir}
             && -d $TestConfig->{apache_dir} )
    {
        plan skip_all =>
            '$TestConfig->{is_maintainer} is not true or '
            . '$TestConfig->{apache_dir} is not a directory';
    }

    unless ( have_httpd() )
    {
        plan skip_all => 'Apache::test::have_httpd() returned a false value';
    }
}

sub require_libapreq
{
    my $version = _apache_version();

    my $module = $version == 1 ? 'Apache::Request' : 'Apache2::Request';

    unless ( eval "use $module; 1" )
    {
        plan skip_all => "These tests require the $module module.";
    }
}

sub require_cgi
{
    unless ( eval 'use CGI 3.08; 1' )
    {
        plan skip_all => 'These tests required CGI.pm 3.08 or greater.';
    }
}

sub require_apache_filter
{
    my $version = _apache_version();

    unless ( eval 'use Apache::Filter; 1' && $version == 1 )
    {
        plan skip_all => 'These tests required Apache::Filter and mod_perl 1.';
    }
}

sub _apache_version
{
    my $apache_bin = _apache_bin();

    my ($version) = `$apache_bin -v` =~ m{version: Apache/(\d)};

    die "Could not determine Apache version"
        unless $version;

    return $version;
}

sub _apache_bin
{
    return File::Spec->catfile( $TestConfig->{apache_dir}, 'httpd' );
}

sub chmod_data_dir
{
    # This is a hack but otherwise the multi-conf tests fail if the
    # Apache server runs as any user other than root.  In real life, a
    # user using the multi-config option with httpd.conf must handle
    # the file permissions manually.
    if ( $> == 0 || $< == 0 )
    {
        chmod 0777, File::Spec->catdir( $TestConfig->{apache_dir}, 'data' );
    }
}

sub run_tests
{
    my $class = shift;
    my %p     = @_;

    # Needed for Apache::test->fetch() to work
    local $ENV{PORT} = $TestConfig->{port};

    _write_test_comps();

    my @tests = $class->_tests(%p);

    my $count = 0;
    $count++ for grep { $_->{expect} || $_->{regex} } @tests;
    $count++ for map { $_->{extra} ? @{ $_->{extra} } : () } @tests;

    plan tests => $count;

    _kill_httpd();

    _start_httpd( $p{apache_define} );

    _cleanup_data_dir();

    _run_test( \%p, $_ ) for @tests;

    _kill_httpd();
}

sub _write_test_comps
{
    _write_comp( 'basic', <<'EOF',
Basic test.
2 + 2 = <% 2 + 2 %>.
uri = <% $r->uri =~ /basic$/ ? '/basic' : $r->uri %>.
method = <% $r->method %>.


EOF
              );

    _write_comp( 'headers', <<'EOF',


% $r->headers_out->{'X-Mason-Test'} = 'New value 2';
Blah blah
blah
% $r->headers_out->{'X-Mason-Test'} = 'New value 3';
<%init>
$r->headers_out->{'X-Mason-Test'} = 'New value 1';
$m->abort if $blank;
</%init>
<%args>
$blank=>0
</%args>
EOF
              );

    _write_comp( 'cgi_object', <<'EOF',
<% UNIVERSAL::isa(eval { $m->cgi_object } || undef, 'CGI') ? 'CGI' : 'NO CGI' %><% $@ || '' %>
EOF
              );

    _write_comp( 'params', <<'EOF',
% foreach (sort keys %ARGS) {
<% $_ %>: <% ref $ARGS{$_} ? join ', ', sort @{ $ARGS{$_} }, 'array' : $ARGS{$_} %>
% }
EOF
              );

    _write_comp( '_underscore', <<'EOF',
I am underscore.
EOF
              );

    _write_comp( 'die', <<'EOF',
% die 'Mine heart is pierced';
EOF
              );

    _write_comp( 'apache_request', <<'EOF',
% if ($r->isa('Apache::Request') || $r->isa('Apache2::Request')) {
Apache::Request
% }
EOF
                  );

    _write_comp( 'multiconf1/foo', <<'EOF',
I am foo in multiconf1
comp root is <% $m->interp->comp_root =~ m,/comps/multiconf1$, ? 'multiconf1' : $m->interp->comp_root %>
EOF
              );

    _write_comp( 'multiconf1/autohandler', <<'EOF'
<& $m->fetch_next, autohandler => 'present' &>
EOF
              );

    _write_comp( 'multiconf1/autohandler_test', <<'EOF'
<%args>
$autohandler => 'misnamed'
</%args>
autohandler is <% $autohandler %>
EOF
              );


    _write_comp( 'multiconf2/foo', <<'EOF',
I am foo in multiconf2
comp root is <% $m->interp->comp_root =~ m,/comps/multiconf2$, ? 'multiconf2' : $m->interp->comp_root %>
EOF
              );

    _write_comp( 'multiconf2/dhandler', <<'EOF',
This should not work
EOF
              );

    _write_comp( 'allow_globals', <<'EOF',
% $foo = 1;
% @bar = ( qw( a b c ) );
$foo is <% $foo %>
@bar is <% @bar %>
EOF
              );

    _write_comp( 'decline_dirs', <<'EOF',
decline_dirs is <% $m->ah->decline_dirs %>
EOF
              );

    _write_comp( 'with_dhandler/dhandler', <<'EOF',
% $r->content_type('text/html');
with a dhandler
EOF
              );

    _write_comp( 'with_dhandler_no_ct/dhandler', <<'EOF',
with a dhandler, no content type
EOF
              );

    _write_comp( 'print', <<'EOF',
This is first.
% print "This is second.\n";
This is third.
EOF
              );

    _write_comp( 'r_print', <<'EOF',
This is first.
% $r->print("This is second.\n");
This is third.
EOF
              );

    _write_comp( 'flush_buffer', <<'EOF',
% $m->print("foo\n");
% $m->flush_buffer;
bar
EOF
              );

    _write_comp( 'head_request', <<'EOF',
<%init>
my $x = 1;
foreach (sort keys %ARGS) {
  $r->headers_out->{'X-Mason-HEAD-Test' . $x++} = "$_: " . (ref $ARGS{$_} ? 'is a ref' : 'not a ref' );
}
</%init>
We should never see this.
EOF
              );

    _write_comp( 'redirect', <<'EOF',
% $m->print("\n");  # leading whitespace

<%perl>
$m->scomp('foo');
$m->redirect('/comps/basic');
</%perl>
<%def foo>
fum
</%def>
EOF
              );

    _write_comp( 'internal_redirect', <<'EOF',
<%init>
if ($mod_perl2::VERSION >= 1.99) { require Apache2::SubRequest; }
$r->internal_redirect('/comps/internal_redirect_target?foo=17');
$m->auto_send_headers(0);
$m->clear_buffer;
$m->abort;
</%init>
EOF
              );

    _write_comp( 'subrequest', <<'EOF',
<%init>
# tests can run under various comp_root settings
my $comp_root = $m->interp->comp_root;
$comp_root = $$comp_root[0][1] if ref $comp_root;
my $comp = $comp_root =~ m/comps/ ? '/internal_redirect_target' : '/comps/internal_redirect_target';

$m->clear_buffer;
my $sub = $m->make_subrequest(comp => $comp, args=> [ foo => 17 ]);
$sub->exec;
$m->flush_buffer;
$m->abort(200);
</%init>
EOF
              );

    _write_comp( 'internal_redirect_target', <<'EOF',
The number is <% $foo %>.
<%args>
$foo
</%args>
EOF
              );

    _write_comp( 'error_as_html', <<'EOF',
% my $x = 
EOF
              );

    _write_comp( 'interp_class', <<'EOF',
Interp class: <% ref $m->interp %>
EOF
              );

    _write_comp( 'old_html_escape', <<'EOF',
<% '<>' | old_h %>
EOF
              );

    _write_comp( 'old_html_escape2', <<'EOF',
<% '<>' | old_h2 %>
EOF
              );

    _write_comp( 'uc_escape', <<'EOF',
<% 'upper case' | uc %>
EOF
              );

    _write_comp( 'data_cache_defaults', <<'EOF',
is memory: <% $m->cache->isa('Cache::MemoryCache') ? 1 : 0 %>
namespace: <% $m->cache->get_namespace %>
EOF
              );

    _write_comp( 'test_code_param', <<'EOF',
preprocess changes lc fooquux to FOOQUUX
EOF
              );

    _write_comp( 'explicitly_send_header', <<'EOF',
Sending headers in this comp.
<%perl>
$r->send_http_header() if $r->can('send_http_header');
</%perl>
EOF
              );

    _write_comp( 'cgi_foo_param', <<'EOF',
CGI foo param is <% $r->query->param('foo') %>
EOF
              );

    _write_comp( 'abort_with_ok', <<'EOF',
All is well
% $m->abort(200);
Will not be seen
EOF
              );

    _write_comp( 'abort_with_not_ok', <<'EOF',
All is well
% $m->abort(500);
Will not be seen
EOF
              );

    _write_comp( 'cgi_dh/dhandler', <<'EOF' );
dhandler
dhandler_arg = <% $m->dhandler_arg %>
EOF

    _write_comp( 'cgi_dh/file', <<'EOF' );
file
dhandler_arg = <% $m->dhandler_arg %>
path_info = <% $ENV{PATH_INFO} %>
EOF

    _write_comp( 'cgi_dh/dir/file', '' );
}

sub _write_comp
{
    my $name = shift;
    my $comp = shift;

    my $file = File::Spec->catfile( $TestConfig->{apache_dir}, 'comps', $name );
    my $dir = dirname($file);
    mkpath( $dir, 0, 0755 ) unless -d $dir;

    open my $fh, '>',$file
        or die "Can't write to '$file': $!";

    print $fh $comp;

    close $fh;
}

sub _start_httpd
{
    my $def = shift;
    $def = "-D$def" if $def;

    my $httpd = _apache_bin();
    my $conf_file = File::Spec->catfile( $TestConfig->{apache_dir}, 'conf', 'httpd.conf' );
    my $pid_file = File::Spec->catfile( $TestConfig->{apache_dir}, 'logs', 'httpd.pid' );

    my $cmd ="$httpd $def -f $conf_file";

    diag( "Executing $cmd" );

    system ($cmd)
        and die "Can't start httpd server as '$cmd': $!";

    diag( "Waiting 10 seconds for httpd to start." );

    my $x = 0;
    until ( -e $pid_file )
    {
        sleep (1);
        $x++;
        if ( $x > 10 )
        {
            die "No $pid_file file has appeared after 10 seconds.  ",
                "There is probably a problem with the configuration file that was generated for these tests.";
        }
    }
}

sub _kill_httpd
{
    my $pid_file = File::Spec->catfile( $TestConfig->{apache_dir}, 'logs', 'httpd.pid' );

    return unless -e $pid_file;
    my $pid = _get_pid();

    diag( "Killing httpd process ($pid)" );

    my $result = kill 'TERM', $pid;
    if ( ! $result and $! =~ /no such (?:file|proc)/i )
    {
        # Looks like apache wasn't running, so we're done
        unlink $pid_file
            or warn "Couldn't remove $pid_file: $!";
        return;
    }

    die "Can't kill process $pid: $!" unless $result;

    diag( "Waiting up to 10 seconds for httpd to shut down" );

    my $x = 0;
    while ( -e $pid_file )
    {
        sleep (1);

        $x++;
        if ( $x > 1 )
        {
            $result = kill 'TERM', $pid;
            if ( ! $result and $! =~ /no such (?:file|proc)/i )
            {
                # Looks like apache wasn't running, so we're done
                if ( -e $pid_file )
                {
                    unlink $pid_file
                        or warn "Couldn't remove $pid_file: $!";
                }
                return;
            }
        }

        die "$pid_file file still exists after 10 seconds.  Exiting."
            if $x > 10;
    }
}

sub _get_pid
{
    my $pid_file = File::Spec->catfile( $TestConfig->{apache_dir}, 'logs', 'httpd.pid' );

    open my $fh, '<', $pid_file
        or die "Can't open $pid_file: $!";

    my $pid = <$fh>;
    close $fh;

    chomp $pid;

    return $pid;
}

# by wiping out the subdirectories here we can catch permissions
# issues if some of the tests can't write to the data dir.
sub _cleanup_data_dir
{
    return if $ENV{MASON_NO_CLEANUP};

    my $dir = File::Spec->catdir( $TestConfig->{apache_dir}, 'data' );

    opendir my $dh, $dir
        or die "Can't open $dir dir: $!";

    foreach ( grep { -d File::Spec->catdir( $dir, $_ ) && $_ !~ /^\./ } readdir $dh )
    {
        rmtree( File::Spec->catdir( $TestConfig->{apache_dir}, 'data', $_ ) );
    }

    closedir $dh;
}

sub _tests
{
    my $class = shift;
    my %p     = @_;

    my @sets = @{ $p{test_sets} };

    my @tests;
    for my $set (@sets)
    {
        my $meth = q{_} . $set . '_tests';
        push @tests, $class->$meth(%p);

        my $addl_meth =
              $p{with_handler}
            ? q{_} . $set . '_with_handler_tests'
            : q{_} . $set . '_no_handler_tests';

        push @tests, $class->$addl_meth(%p)
            if $class->can($addl_meth);
    }

    return @tests;
}

sub _standard_tests
{
    shift;
    my %p = @_;

    my @tests =
        ( { path => '/comps/basic',
            expect => <<'EOF',
X-Mason-Test: Initial value
Basic test.
2 + 2 = 4.
uri = /basic.
method = GET.


Status code: 0
EOF
            extra =>
            [ sub { my $response = shift;
                    unlike( $response->content, qr{HTTP/1\.1},
                            'the response for a good component should not contain headers in the body' ); },
            ],
          },
          { path => '/comps/headers',
            expect => <<'EOF',
X-Mason-Test: New value 3


Blah blah
blah
Status code: 0
EOF
          },
          { path => '/comps/headers?blank=1',
            expect => <<'EOF',
X-Mason-Test: New value 1
Status code: 0
EOF
          },
          { path => '/comps/_underscore',
            expect => <<'EOF',
X-Mason-Test: Initial value
I am underscore.
Status code: 0
EOF
          },
          { path  => '/comps/die',
            regex => qr{error.*Mine heart is pierced}s,
          },
          { path => '/comps/params?qs1=foo&qs2=bar&foo=A&foo=B',
            expect => <<'EOF',
X-Mason-Test: Initial value
foo: A, B, array
qs1: foo
qs2: bar
Status code: 0
EOF
          },
          { path => '/comps/params',
            post => { post1 => 'foo',
                      post2 => 'bar',
                      foo   => [ 'A', 'B' ],
                    },
            expect => <<'EOF',
X-Mason-Test: Initial value
foo: A, B, array
post1: foo
post2: bar
Status code: 0
EOF
          },

          { path => '/comps/params?qs1=foo&qs2=bar&mixed=A',
            post => { post1 => 'a',
                      post2 => 'b',
                      mixed => 'B',
                    },
            expect => <<'EOF',
X-Mason-Test: Initial value
mixed: A, B, array
post1: a
post2: b
qs1: foo
qs2: bar
Status code: 0
EOF
          },
          { path => '/comps/print',
            expect => <<'EOF',
X-Mason-Test: Initial value
This is first.
This is second.
This is third.
Status code: 0
EOF
          },
          { path => '/comps/r_print',
            expect => <<'EOF',
X-Mason-Test: Initial value
This is first.
This is second.
This is third.
Status code: 0
EOF
          },
          { path => '/comps/flush_buffer',
            expect => <<'EOF',
X-Mason-Test: Initial value
foo
bar
Status code: 0
EOF
          },
          { path => '/comps/redirect',
            expect => <<'EOF',
X-Mason-Test: Initial value
Basic test.
2 + 2 = 4.
uri = /basic.
method = GET.


Status code: 0
EOF
          },
          { path => '/comps/internal_redirect',
            expect => <<'EOF',
X-Mason-Test: Initial value
The number is 17.
Status code: 0
EOF
          },
          { path => '/comps/subrequest',
            expect => <<'EOF',
X-Mason-Test: Initial value
The number is 17.
Status code: 0
EOF
          },
          { path => '/comps/error_as_html',
            regex => qr{<b>error:</b>.*Error during compilation}s,
            extra =>
            [ sub { my $response = shift;
                    unlike( $response->content, qr{HTTP/1\.1},
                            'the response for a compilation error should not contain headers in the body' ); },
            ],
          },
          { path => '/comps/explicitly_send_header',
            expect => <<'EOF',
X-Mason-Test: Initial value
Sending headers in this comp.
Status code: 0
EOF
          },
        );

    my $expected_class = $p{with_handler} ? 'My::Interp' : 'HTML::Mason::Interp';

    push @tests, { path => '/comps/interp_class',
                   expect => <<"EOF",
X-Mason-Test: Initial value
Interp class: $expected_class
Status code: 0
EOF
                 };

    return @tests;
}

sub _standard_with_handler_tests
{
    shift;
    my %p = @_;

    return ( { path => '/ah=1/comps/headers',
               expect => <<'EOF',
X-Mason-Test: New value 1


Blah blah
blah
Status code: 0
EOF
             },
             { path => '/ah=1/comps/headers?blank=1',
               expect => <<'EOF',
X-Mason-Test: New value 1
Status code: 0
EOF
             },
             { path => '/ah=3/comps/die',
               # error_mode is fatal so we just get a 500
               regex => qr{500 Internal Server Error},
             },
             { path => '/ah=1/comps/print',
               expect => <<'EOF',
X-Mason-Test: Initial value
This is first.
This is second.
This is third.
Status code: 0
EOF
             },
             { path => '/ah=1/comps/r_print',
               expect => <<'EOF',
X-Mason-Test: Initial value
This is first.
This is second.
This is third.
Status code: 0
EOF
             },
             { path => '/ah=1/comps/flush_buffer',
               expect => <<'EOF',
X-Mason-Test: Initial value
foo
bar
Status code: 0
EOF
             },
           );
}

sub _apache_request_tests
{
    shift;
    my %p = @_;

    return ( { path => '/comps/apache_request',
               expect => <<'EOF',
X-Mason-Test: Initial value
Apache::Request
Status code: 0
EOF
             },
           );
}

sub _apache_request_with_handler_tests
{
    shift;
    my %p = @_;

    return ( { path => '/ah=4/comps/apache_request',
               expect => <<'EOF',
X-Mason-Test: Initial value
Status code: 0
EOF
             },
           );
}

sub _apache_request_no_handler_tests
{
    shift;
    my %p = @_;

    return ( { path => '/comps/decline_dirs',
               expect => <<'EOF',
X-Mason-Test: Initial value
decline_dirs is 0
Status code: 0
EOF
             },
             { path => '/comps/old_html_escape',
               expect => <<'EOF',
X-Mason-Test: Initial value
&lt;&gt;
Status code: 0
EOF
             },
             { path => '/comps/old_html_escape2',
               expect => <<'EOF',
X-Mason-Test: Initial value
&lt;&gt;
Status code: 0
EOF
             },
             { path => '/comps/uc_escape',
               expect => <<'EOF',
X-Mason-Test: Initial value
UPPER CASE
Status code: 0
EOF
             },
             { path => '/comps/data_cache_defaults',
               expect => <<'EOF',
X-Mason-Test: Initial value
is memory: 1
namespace: foo
Status code: 0
EOF
             },
             { path => '/comps/test_code_param',
               expect => <<"EOF",
X-Mason-Test: Initial value
preprocess changes lc FOOQUUX to FOOQUUX
Status code: 0
EOF
             },
             { path => '/comps/with_dhandler/',
               expect => <<"EOF",
X-Mason-Test: Initial value
with a dhandler
Status code: 0
EOF
             },
           );
}

sub _cgi_tests
{
    shift;
    my %p = @_;

    return ( { path => '/comps/cgi_object',
               expect => <<'EOF',
X-Mason-Test: Initial value
CGI
Status code: 0
EOF
             },
             { path   => '/comps/head_request?foo=1&bar=1&bar=2',
               method => 'HEAD',
               expect => <<'EOF',
X-Mason-Test: Initial value
X-Mason-HEAD-Test1: bar: is a ref
X-Mason-HEAD-Test2: foo: not a ref
Status code: 0
EOF
             },
           );
}

sub _cgi_no_handler_tests
{
    shift;
    my %p = @_;

    # tests that MasonAllowGlobals works with a list of params
    # (testing a list parameter from httpd.conf)
    return ( { path => '/comps/allow_globals',
               expect => <<'EOF',
X-Mason-Test: Initial value
$foo is 1
@bar is abc
Status code: 0
EOF
             },
           );
}

sub _filter_tests
{
    shift;
    my %p = @_;

    return ( { path => '/comps/basic',
               expect => <<'EOF',
X-Mason-Test: Initial value
BASIC TEST.
2 + 2 = 4.
URI = /BASIC.
METHOD = GET.


Status code: 0
EOF
             },
           );
}

sub _set_content_type_tests
{
    shift;
    my %p = @_;

    return ( { path  => '/comps/basic',
               extra =>
               [ sub { my $response = shift;
                       is( $response->headers()->header('Content-Type'),
                           'text/html; charset=i-made-this-up',
                           'Content type set by handler is preserved by Mason' ); },
                 sub { my $response = shift;
                       unlike( $response->content(), qr/Content-Type:/i,
                               'response body does not contain a content-type header' ); },
               ],
             },
             { path => '/comps/with_dhandler_no_ct/',
               extra =>
               [ sub { my $response = shift;
                       is( $response->headers()->header('Content-Type'),
                           'text/html; charset=i-made-this-up',
                           'Content type set by handler is preserved by Mason with directory request' ); },
                 sub { my $response = shift;
                       unlike( $response->content(), qr/Content-Type:/i,
                               'response body does not contain a content-type header with directory request' ); },
               ],
             },
           );
}

sub _multi_config_tests
{
    shift;
    my %p = @_;

    return ( { path => '/comps/multiconf1/foo',
               expect => <<'EOF',
X-Mason-Test: Initial value
I am foo in multiconf1
comp root is multiconf1
Status code: 0
EOF
             },
             { path => '/comps/multiconf1/autohandler_test',
               expect => <<'EOF',
X-Mason-Test: Initial value
autohandler is misnamed
Status code: 0
EOF
             },
             { path => '/comps/multiconf2/foo',
               expect => <<'EOF',
X-Mason-Test: Initial value
I am foo in multiconf2
comp root is multiconf2
Status code: 0
EOF
             },
             { path => '/comps/multiconf2/dhandler_test',
               regex => qr{404 not found}i,
             },
             { path => '/perl-status',
               regex => qr{<a href="/perl-status\?mason0001">HTML::Mason status</a>},
             },
           );
}

sub _cgi_handler_tests
{
    shift;
    my %p = @_;

    return ( { path => '/comps/basic',
               unfiltered_response => 1,
               expect => <<'EOF',
Basic test.
2 + 2 = 4.
uri = /basic.
method = GET.
EOF
             },
             { path => '/comps/print',
               unfiltered_response => 1,
               expect => <<'EOF',
This is first.
This is second.
This is third.
EOF
             },
             { path => '/comps/print/autoflush',
               unfiltered_response => 1,
               expect => <<'EOF',
This is first.
This is second.
This is third.
EOF
             },
             { path => '/comps/print/handle_comp',
               unfiltered_response => 1,
               expect => <<'EOF',
This is first.
This is second.
This is third.
EOF
             },
             { path => '/comps/print/handle_cgi_object',
               unfiltered_response => 1,
               expect => <<'EOF',
This is first.
This is second.
This is third.
EOF
             },
             { path => '/comps/cgi_foo_param/handle_cgi_object',
               unfiltered_response => 1,
               expect => <<'EOF',
CGI foo param is bar
EOF
             },
             { path => '/comps/redirect',
               unfiltered_response => 1,
               expect => <<'EOF',
Basic test.
2 + 2 = 4.
uri = /basic.
method = GET.
EOF
             },
             { path => '/comps/params?qs1=foo&qs2=bar&mixed=A',
               post => { post1 => 'a',
                         post2 => 'b',
                         mixed => 'B',
                       },
               unfiltered_response => 1,
               expect => <<'EOF',
mixed: A, B, array
post1: a
post2: b
qs1: foo
qs2: bar
EOF
             },
             { path => '/comps/error_as_html',
               regex => qr{<b>error:</b>.*Error during compilation}s,
             },
             { path => '/comps/abort_with_ok',
               unfiltered_response => 1,
               expect => <<'EOF',
All is well
EOF
             },
             # XXX - does this test make any sense?
             { path => '/comps/abort_with_not_ok',
               unfiltered_response => 1,
               expect => <<'EOF',
All is well
EOF
             },
             { path => '/comps/foo/will_decline',
               # Having decline generate an error like this is bad,
               # but there's not much else we can do without rewriting
               # more of CGIHandler, which isn't a good idea for
               # stable, methinks.
               regex => qr{could not find component for initial path}is,
             },
             { path => '/comps/cgi_dh/dir/extra/stuff',
               unfiltered_response => 1,
               expect => <<'EOF',
dhandler
dhandler_arg = dir/extra/stuff
EOF
             },
             { path => '/comps/explicitly_send_header',
               unfiltered_response => 1,
               expect => <<'EOF',
Sending headers in this comp.
EOF
             },
           );

    ## CGIHandler.pm does not do this the same as ApacheHandler.pm
    ## but we do not want to rewrite CGIHandler in stable
    #
    #       my $path = '/comps/cgi_dh/file/extra/stuff';
    #        my $response = Apache::test->fetch($path);
    #        expect => <<'EOF',
    #file
    #dhandler_arg = 
    #path_info = /extra/stuff
    #EOF
}

sub _run_test
{
    my $p    = shift;
    my $test = shift;

    my $path = $test->{path}
        or die "Test with no path!";

    if ( $p->{with_handler} && $path !~ m{^/ah=\d/} )
    {
        $path = '/ah=0' . $path;
    }

    my %fetch_p = ( uri => $path );
    if ( $test->{post} )
    {
        $fetch_p{method} = 'POST';

        my $uri = URI->new();
        $uri->query_form( $test->{post} );

        $fetch_p{content} = $uri->query();
    }
    elsif ( $test->{method} )
    {
        $fetch_p{method} = $test->{method};
    }

    my $response = Apache::test->fetch( \%fetch_p );

    my $output =
          $test->{unfiltered_response}
        ? $response->content()
        : _filter_response( $response, $p, $test );

    _check_output( $output, $test );

    if ( $test->{extra} )
    {
        $_->($response) for @{ $test->{extra} };
    }
}

# We're not interested in headers that are always going to be
# different (like date or server type).
sub _filter_response
{
    my $response = shift;
    my $p        = shift;
    my $test     = shift;

    my $actual;
    {
        $actual = 'X-Mason-Test: ';

        my $val;

        # This is a nasty hack because some tests using a handler()
        # sub are expected to always return this header, and others
        # are not.
        if ( $p->{with_handler} )
        {
            $val = $response->headers->header('X-Mason-Test');
        }
        else
        {
            $val = ( defined $response->headers->header('X-Mason-Test') ?
                     $response->headers->header('X-Mason-Test') :
                     'Initial value' );
        }

        $actual .= defined $val ? $val : '';
    }

    $actual .= "\n";

    # Any headers starting with X-Mason are added, excluding
    # X-Mason-Test, which is handled above
    my @headers;
    $response->headers->scan( sub { return if $_[0] eq 'X-Mason-Test' || $_[0] !~ /^X-Mason/;
                                    push @headers, [ $_[0], $_[1] ] } );

    foreach my $h ( sort { $a->[0] cmp $b->[0] } @headers )
    {
        $actual .= "$h->[0]: ";
        $actual .= defined $h->[1] ? $h->[1] : '';
        $actual .= "\n";
    }

    my $content = $response->content();
    $actual .= $content if defined $content;

    if ( ( $test->{method} && $test->{method} eq 'HEAD' ) || ! $p->{with_handler} )
    {
        my $code = $response->code() == 200 ? 0 : $response->code();
        $actual .= "Status code: $code";
    }

    return $actual;
}

sub _check_output
{
    my $output = shift;
    my $test   = shift;

    my $desc = $test->{path};
    $desc .= ' (post)' if $test->{post};

    if ( $test->{expect} )
    {
        my $expect = $test->{expect};

        for ( $output, $expect )
        {
            s/\s+$//s;
        }

        is( $output, $expect, $desc );
    }
    elsif ( $test->{regex} )
    {
        like( $output, $test->{regex},
              "Regex test for $desc" );
    }
    elsif ( ! $test->{extra} )
    {
        die "No error, expect, or extra key provided for test ($test->{path})";
    }
}


1;
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)