Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 152 lines (133 sloc) 3.657 kb
f61f188 @spiritloose Initial commit
authored
1 package t::TestModPSGI;
2 use strict;
3 use warnings;
4 use Test::Base -Base;
5
46afe51 @spiritloose use t::Config
authored
6 use t::Config;
f61f188 @spiritloose Initial commit
authored
7 use URI::Escape;
8 use List::Util qw(sum);
b8e8623 @spiritloose Refactored tests
authored
9 use Test::TCP;
10 use File::Temp;
f61f188 @spiritloose Initial commit
authored
11
12 our @EXPORT = qw(
13 running_in_mod_psgi eval_body_app eval_response_app
b8e8623 @spiritloose Refactored tests
authored
14 run_server_tests
f61f188 @spiritloose Initial commit
authored
15 );
16
0e90b5f @spiritloose use G_KEEPERR and CLEAR_ERRSV() to catch errors
authored
17 BEGIN {
18 no warnings 'redefine';
19 *Test::Base::run_compare = sub {}; # XXX
20 }
21
f61f188 @spiritloose Initial commit
authored
22 sub running_in_mod_psgi() {
23 exists $ENV{MOD_PSGI};
24 }
25
26 sub eval_body_app() {
27 sub {
28 my $env = shift;
29 my $code = uri_unescape($env->{QUERY_STRING});
30 my $body = eval $code;
31 [ 200, [ 'Content-Type' => 'text/plain' ], [ $body ] ];
32 };
33 }
34
35 sub eval_response_app() {
36 sub {
37 my $env = shift;
38 my $code = uri_unescape($env->{QUERY_STRING});
39 eval $code;
40 };
41 }
42
43 our $UA;
44
45 sub ua() {
46 require LWP::UserAgent;
47 $UA ||= LWP::UserAgent->new;
48 }
49
50 sub eval_request($$$;@) {
b8e8623 @spiritloose Refactored tests
authored
51 my ($port, $method, $code, @args) = @_;
f61f188 @spiritloose Initial commit
authored
52 if (ref $code eq 'CODE') {
53 no warnings 'prototype';
b8e8623 @spiritloose Refactored tests
authored
54 return eval_request($port, $method, $code->(), @args);
f61f188 @spiritloose Initial commit
authored
55 }
b8e8623 @spiritloose Refactored tests
authored
56 my $uri = sprintf 'http://localhost:%d/?%s', $port, uri_escape($code);
f61f188 @spiritloose Initial commit
authored
57 $method = lc $method;
58 ua->$method($uri, @args);
59 }
60
61 sub setup_filters() {
62 filters {
63 request => 'yaml',
64 response => 'yaml',
65 };
66 }
67
68 sub setup_plan() {
69 plan tests => sum map { scalar keys %{$_->response} } blocks;
70 }
71
72 sub setup_tests() {
73 setup_filters;
74 setup_plan;
75 }
76
48bb65f @spiritloose Display test name
authored
77 sub compare($$$$;@) {
78 my ($res, $input, $expected, $name, @args) = @_;
f61f188 @spiritloose Initial commit
authored
79 my $ref = ref $expected;
80 if ($ref eq 'CODE') {
81 no warnings 'prototype';
48bb65f @spiritloose Display test name
authored
82 compare($res, $input, $expected->(), $name);
f61f188 @spiritloose Initial commit
authored
83 } elsif ($ref eq 'Regexp') {
48bb65f @spiritloose Display test name
authored
84 like $res->$input(@args), $expected, $name;
f61f188 @spiritloose Initial commit
authored
85 } elsif ($ref eq 'HASH') {
86 while (my ($key, $val) = each %$expected) {
87 no warnings 'prototype';
48bb65f @spiritloose Display test name
authored
88 compare($res, $input, $val, $name, $key);
f61f188 @spiritloose Initial commit
authored
89 }
90 } elsif ($ref) {
48bb65f @spiritloose Display test name
authored
91 is_deeply $res->$input(@args), $expected, $name;
f61f188 @spiritloose Initial commit
authored
92 } elsif ($expected eq 'ok') {
48bb65f @spiritloose Display test name
authored
93 ok $res->$input(@args), $name;
f61f188 @spiritloose Initial commit
authored
94 } elsif ($expected eq 'not ok') {
48bb65f @spiritloose Display test name
authored
95 ok !$res->$input(@args), $name;
f61f188 @spiritloose Initial commit
authored
96 } else {
48bb65f @spiritloose Display test name
authored
97 is $res->$input(@args), $expected, $name;
f61f188 @spiritloose Initial commit
authored
98 }
99 }
100
b8e8623 @spiritloose Refactored tests
authored
101 our $TestFile;
102
103 sub run_httpd($) {
104 my $port = shift;
c5d70ca @spiritloose Now we can test before 'make install'
authored
105 my $tmpdir = $ENV{MOD_PSGI_TMP_DIR} || File::Temp::tempdir(CLEANUP => 1);
46afe51 @spiritloose use t::Config
authored
106 my $apxs = $t::Config::APXS;
107 chomp(my $libexecdir = `$apxs -q libexecdir`);
108 chomp(my $sbindir = `$apxs -q sbindir`);
109 chomp(my $progname = `$apxs -q progname`);
b8e8623 @spiritloose Refactored tests
authored
110 my $httpd = "$sbindir/$progname";
ad1548e @spiritloose use abs_top_builddir
authored
111 my $topdir = $t::Config::ABS_TOP_BUILDDIR;
b8e8623 @spiritloose Refactored tests
authored
112 my $conf = <<"END_CONF";
ef0a120 @spiritloose Add ServerName to suppress warnings
authored
113 ServerName mod-psgi.test
ad1548e @spiritloose use abs_top_builddir
authored
114 LoadModule psgi_module $topdir/.libs/mod_psgi.so
b8e8623 @spiritloose Refactored tests
authored
115 PidFile $tmpdir/httpd.pid
116 LockFile $tmpdir/httpd.lock
117 ErrorLog $tmpdir/error_log
118 Listen $port
119 <Location />
120 SetHandler psgi
ad1548e @spiritloose use abs_top_builddir
authored
121 PSGIApp $topdir/$TestFile
b8e8623 @spiritloose Refactored tests
authored
122 </Location>
123 END_CONF
124 open my $fh, '>', "$tmpdir/httpd.conf" or die $!;
125 print $fh $conf;
126 close $fh;
127 exec "$httpd -X -D FOREGROUND -f $tmpdir/httpd.conf";
128 }
129
48bb65f @spiritloose Display test name
authored
130 sub run_requests($) {
131 my $port = shift;
132 setup_tests;
133 run {
134 my $block = shift;
135 my $req = $block->request;
136 my $res = eval_request($port, $req->{method}, $req->{code}, @{$req->{args}});
137 my $response = $block->response;
138 local $Test::Builder::Level = $Test::Builder::Level + 5;
139 while (my ($input, $expected) = each %$response) {
140 compare($res, $input, $expected, $block->name);
141 }
142 };
143 }
144
b8e8623 @spiritloose Refactored tests
authored
145 sub run_server_tests() {
f61f188 @spiritloose Initial commit
authored
146 my ($pkg, $file) = caller;
b8e8623 @spiritloose Refactored tests
authored
147 $TestFile = $file;
48bb65f @spiritloose Display test name
authored
148 test_tcp(client => \&run_requests, server => \&run_httpd);
f61f188 @spiritloose Initial commit
authored
149 }
150
151 1;
Something went wrong with that request. Please try again.