Skip to content
Newer
Older
100644 151 lines (132 sloc) 3.55 KB
f61f188 @spiritloose Initial commit
authored Sep 18, 2009
1 package t::TestModPSGI;
2 use strict;
3 use warnings;
4 use Test::Base -Base;
5
46afe51 @spiritloose use t::Config
authored Oct 11, 2009
6 use t::Config;
f61f188 @spiritloose Initial commit
authored Sep 18, 2009
7 use URI::Escape;
8 use List::Util qw(sum);
b8e8623 @spiritloose Refactored tests
authored Oct 10, 2009
9 use Test::TCP;
10 use File::Temp;
f61f188 @spiritloose Initial commit
authored Sep 18, 2009
11
12 our @EXPORT = qw(
13 running_in_mod_psgi eval_body_app eval_response_app
b8e8623 @spiritloose Refactored tests
authored Oct 10, 2009
14 run_server_tests
f61f188 @spiritloose Initial commit
authored Sep 18, 2009
15 );
16
0e90b5f @spiritloose use G_KEEPERR and CLEAR_ERRSV() to catch errors
authored Oct 16, 2009
17 BEGIN {
18 no warnings 'redefine';
19 *Test::Base::run_compare = sub {}; # XXX
20 }
21
f61f188 @spiritloose Initial commit
authored Sep 18, 2009
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 Oct 10, 2009
51 my ($port, $method, $code, @args) = @_;
f61f188 @spiritloose Initial commit
authored Sep 18, 2009
52 if (ref $code eq 'CODE') {
53 no warnings 'prototype';
b8e8623 @spiritloose Refactored tests
authored Oct 10, 2009
54 return eval_request($port, $method, $code->(), @args);
f61f188 @spiritloose Initial commit
authored Sep 18, 2009
55 }
b8e8623 @spiritloose Refactored tests
authored Oct 10, 2009
56 my $uri = sprintf 'http://localhost:%d/?%s', $port, uri_escape($code);
f61f188 @spiritloose Initial commit
authored Sep 18, 2009
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 Oct 11, 2009
77 sub compare($$$$;@) {
78 my ($res, $input, $expected, $name, @args) = @_;
f61f188 @spiritloose Initial commit
authored Sep 18, 2009
79 my $ref = ref $expected;
80 if ($ref eq 'CODE') {
81 no warnings 'prototype';
48bb65f @spiritloose Display test name
authored Oct 10, 2009
82 compare($res, $input, $expected->(), $name);
f61f188 @spiritloose Initial commit
authored Sep 18, 2009
83 } elsif ($ref eq 'Regexp') {
48bb65f @spiritloose Display test name
authored Oct 10, 2009
84 like $res->$input(@args), $expected, $name;
f61f188 @spiritloose Initial commit
authored Sep 18, 2009
85 } elsif ($ref eq 'HASH') {
86 while (my ($key, $val) = each %$expected) {
87 no warnings 'prototype';
48bb65f @spiritloose Display test name
authored Oct 10, 2009
88 compare($res, $input, $val, $name, $key);
f61f188 @spiritloose Initial commit
authored Sep 18, 2009
89 }
90 } elsif ($ref) {
48bb65f @spiritloose Display test name
authored Oct 10, 2009
91 is_deeply $res->$input(@args), $expected, $name;
f61f188 @spiritloose Initial commit
authored Sep 18, 2009
92 } elsif ($expected eq 'ok') {
48bb65f @spiritloose Display test name
authored Oct 10, 2009
93 ok $res->$input(@args), $name;
f61f188 @spiritloose Initial commit
authored Sep 18, 2009
94 } elsif ($expected eq 'not ok') {
48bb65f @spiritloose Display test name
authored Oct 10, 2009
95 ok !$res->$input(@args), $name;
f61f188 @spiritloose Initial commit
authored Sep 18, 2009
96 } else {
48bb65f @spiritloose Display test name
authored Oct 10, 2009
97 is $res->$input(@args), $expected, $name;
f61f188 @spiritloose Initial commit
authored Sep 18, 2009
98 }
99 }
100
b8e8623 @spiritloose Refactored tests
authored Oct 10, 2009
101 our $TestFile;
102
103 sub run_httpd($) {
104 my $port = shift;
c5d70ca @spiritloose Now we can test before 'make install'
authored Oct 11, 2009
105 my $tmpdir = $ENV{MOD_PSGI_TMP_DIR} || File::Temp::tempdir(CLEANUP => 1);
46afe51 @spiritloose use t::Config
authored Oct 10, 2009
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 Oct 10, 2009
110 my $httpd = "$sbindir/$progname";
ad1548e @spiritloose use abs_top_builddir
authored Oct 12, 2009
111 my $topdir = $t::Config::ABS_TOP_BUILDDIR;
b8e8623 @spiritloose Refactored tests
authored Oct 10, 2009
112 my $conf = <<"END_CONF";
ad1548e @spiritloose use abs_top_builddir
authored Oct 12, 2009
113 LoadModule psgi_module $topdir/.libs/mod_psgi.so
b8e8623 @spiritloose Refactored tests
authored Oct 10, 2009
114 PidFile $tmpdir/httpd.pid
115 LockFile $tmpdir/httpd.lock
116 ErrorLog $tmpdir/error_log
117 Listen $port
118 <Location />
119 SetHandler psgi
ad1548e @spiritloose use abs_top_builddir
authored Oct 12, 2009
120 PSGIApp $topdir/$TestFile
b8e8623 @spiritloose Refactored tests
authored Oct 10, 2009
121 </Location>
122 END_CONF
123 open my $fh, '>', "$tmpdir/httpd.conf" or die $!;
124 print $fh $conf;
125 close $fh;
126 exec "$httpd -X -D FOREGROUND -f $tmpdir/httpd.conf";
127 }
128
48bb65f @spiritloose Display test name
authored Oct 10, 2009
129 sub run_requests($) {
130 my $port = shift;
131 setup_tests;
132 run {
133 my $block = shift;
134 my $req = $block->request;
135 my $res = eval_request($port, $req->{method}, $req->{code}, @{$req->{args}});
136 my $response = $block->response;
137 local $Test::Builder::Level = $Test::Builder::Level + 5;
138 while (my ($input, $expected) = each %$response) {
139 compare($res, $input, $expected, $block->name);
140 }
141 };
142 }
143
b8e8623 @spiritloose Refactored tests
authored Oct 10, 2009
144 sub run_server_tests() {
f61f188 @spiritloose Initial commit
authored Sep 18, 2009
145 my ($pkg, $file) = caller;
b8e8623 @spiritloose Refactored tests
authored Oct 10, 2009
146 $TestFile = $file;
48bb65f @spiritloose Display test name
authored Oct 10, 2009
147 test_tcp(client => \&run_requests, server => \&run_httpd);
f61f188 @spiritloose Initial commit
authored Sep 18, 2009
148 }
149
150 1;
Something went wrong with that request. Please try again.