diff options
Diffstat (limited to 'debian/perl-framework/t/modules')
28 files changed, 1054 insertions, 620 deletions
diff --git a/debian/perl-framework/t/modules/actions.t b/debian/perl-framework/t/modules/actions.t new file mode 100644 index 0000000..337d4d8 --- /dev/null +++ b/debian/perl-framework/t/modules/actions.t @@ -0,0 +1,59 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestRequest; +use Apache::TestUtil; + +## +## mod_action tests +## +my @tests_action = ( + [ "mod_actions/", 200, "nada"], # Handler for this location + + [ "modules/actions/action/test.xyz", 404], # No handler for .xyz + [ "modules/actions/action/test.xyz1", 404], # Handler for .xyz1, but not virtual + [ "modules/actions/action/test.xyz22", 404], # No Handler for .xyz2x (but one for .xyz2) + + [ "modules/actions/action/test.xyz2", 200, "nada"], # Handler for .xyz2, and virtual +); + +my @tests_script = ( + [ "modules/actions/script/test.x", 404], + [ "modules/actions/script/test.x?foo=bar", 200, "foo=bar"], +); + +my $r; + +plan tests => scalar @tests_action*2 + scalar @tests_script*(2+2+1), need_module('mod_actions'); + +foreach my $test (@tests_action) { + $r = GET($test->[0]); + ok t_cmp($r->code, $test->[1]); + if ($test->[1] == 200) { + ok t_cmp($r->content, $test->[2]); + } + else { + skip "RC=404, no need to check content", 1; + } +} + +foreach my $test (@tests_script) { + $r = GET($test->[0]); + ok t_cmp($r->code, $test->[1]); + if ($test->[1] == 200) { + ok t_cmp($r->content, $test->[2]); + } + else { + skip "RC=404, no need to check content", 1; + } + + $r = POST($test->[0], content => "foo2=bar2"); + ok t_cmp($r->code, 200); + ok t_cmp($r->content, "POST\nfoo2: bar2\n"); + + # Method not allowed + $r = PUT($test->[0], content => "foo2=bar2"); + ok t_cmp($r->code, 405); +} + diff --git a/debian/perl-framework/t/modules/alias.t b/debian/perl-framework/t/modules/alias.t index a605966..957fccc 100644 --- a/debian/perl-framework/t/modules/alias.t +++ b/debian/perl-framework/t/modules/alias.t @@ -35,6 +35,14 @@ my %rm_rc = ( f => '403' ); + +my %relative_redirects = ( + "/redirect_relative/default" => "^http", # URL should be absolute + "/redirect_relative/on" => "^/out-on", # URL should be relative + "/redirect_relative/off" => "^http", # URL should be absolute + "/redirect_relative/off/fail" => undef, # 500 due to invalid URL +); + #XXX: find something that'll on other platforms (/bin/sh aint it) my $script_tests = WINFU ? 0 : 4 + have_min_apache_version("2.4.19"); @@ -44,6 +52,10 @@ my $tests = 12 + have_min_apache_version("2.4.19") * 10 + (keys %rm_rc) * (1 + have_min_apache_version("2.4.19")) * 10 + $script_tests; +if (have_min_apache_version("2.5.1")) { + $tests += (keys %relative_redirects)*2; +} + #LWP required to follow redirects plan tests => $tests, need need_module('alias'), need_lwp; @@ -207,3 +219,22 @@ ok t_cmp((GET_RC "/aliascgi-nada"), ## clean up ## t_rmtree("$vars->{t_logs}/mod_cgi.log"); + + +if (have_min_apache_version("2.5.1")) { + my ($path, $regex); + while (($path, $regex) = each (%relative_redirects)) { + local $Apache::TestRequest::RedirectOK = 0; + my $r; + $r = GET($path); + if (defined($regex)) { + ok t_cmp($r->code, "302"); + ok t_cmp($r->header("Location"), qr/$regex/, "failure on $path"); + } + else { + ok t_cmp($r->code, "500"); + ok t_cmp($r->header("Location"), undef, "failure on $path"); + } + } +} + diff --git a/debian/perl-framework/t/modules/allowmethods.t b/debian/perl-framework/t/modules/allowmethods.t index 6e2e815..d012554 100644 --- a/debian/perl-framework/t/modules/allowmethods.t +++ b/debian/perl-framework/t/modules/allowmethods.t @@ -9,6 +9,7 @@ my $r; my $get = "Get"; my $head = "Head"; my $post = "Post"; +my $options = "Options"; ## ## mod_allowmethods test @@ -25,11 +26,26 @@ my @test_cases = ( [ $post, $post, 200 ], ); +my @new_test_cases = ( + [ $get, $post . '/reset', 200 ], + [ $post, $get . '/post', 200 ], + [ $get, $get . '/post', 200 ], + [ $options, $get . '/post', 405 ], + [ $get, $get . '/none', 405 ], + [ $get, "NoPost", 200 ], + [ $post, "NoPost", 405 ], + [ $options, "NoPost" , 200 ], +); + +if (have_min_apache_version('2.5.1')) { + push(@test_cases, @new_test_cases); +} + plan tests => (scalar @test_cases), have_module 'allowmethods'; foreach my $case (@test_cases) { my ($fct, $allowed, $rc) = @{$case}; - + if ($fct eq $get) { $r = GET('/modules/allowmethods/' . $allowed . '/'); } @@ -39,7 +55,10 @@ foreach my $case (@test_cases) { elsif ($fct eq $post) { $r = POST('/modules/allowmethods/' . $allowed . '/foo.txt'); } + elsif ($fct eq $options) { + $r = OPTIONS('/modules/allowmethods/' . $allowed . '/'); + } - ok t_cmp($r->code, $rc, $fct . " - When " . $allowed . " is allowed."); + ok t_cmp($r->code, $rc, "$fct request to /$allowed responds $rc"); } - + diff --git a/debian/perl-framework/t/modules/autoindex.t b/debian/perl-framework/t/modules/autoindex.t index acd9656..76c9af4 100644 --- a/debian/perl-framework/t/modules/autoindex.t +++ b/debian/perl-framework/t/modules/autoindex.t @@ -122,8 +122,17 @@ foreach my $fancy (0,1) { sub ai_test ($$$$) { my ($htconf,$c,$o,$t_uri) = @_; - my $html_head = <<HEAD; -<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2 Final//EN"> + my $html_head; + + if (have_min_apache_version('2.5.1')) { + $html_head = '<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">'; + } + else { + $html_head = '<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2 Final//EN">'; + } + + $html_head .= <<HEAD; + <html> <head> <title>Index of $uri_prefix</title> diff --git a/debian/perl-framework/t/modules/brotli.t b/debian/perl-framework/t/modules/brotli.t index fcbed74..0f9dc13 100644 --- a/debian/perl-framework/t/modules/brotli.t +++ b/debian/perl-framework/t/modules/brotli.t @@ -5,49 +5,86 @@ use Apache::Test; use Apache::TestUtil; use Apache::TestRequest; -plan tests => 10, need_module 'brotli', need_module 'alias'; +my @qvalue = ( + [ '' , 1], + [ ' ' , 1], + [ ';' , 1], + [';q=' , 1], + [';q=0' , 0], + [';q=0.' , 0], + [';q=0.0' , 0], + [';q=0.00' , 0], + [';q=0.000' , 0], + [';q=0.0000' , 1], # invalid qvalue format +); + +plan tests => (6 * scalar @qvalue) + 4, need_module 'brotli', need_module 'alias'; my $r; -# GET request against the location with Brotli. -$r = GET("/only_brotli/index.html", "Accept-Encoding" => "br"); -ok t_cmp($r->code, 200); -ok t_cmp($r->header("Content-Encoding"), "br", "response Content-Encoding is OK"); -if (!defined($r->header("Content-Length"))) { - t_debug "Content-Length was expected"; - ok 0; -} -if (!defined($r->header("ETag"))) { - t_debug "ETag field was expected"; - ok 0; -} +foreach my $q (@qvalue) { + # GET request against the location with Brotli. + print "qvalue: " . $q->[0] . "\n"; + $r = GET("/only_brotli/index.html", "Accept-Encoding" => "br" . $q->[0]); + ok t_cmp($r->code, 200); + if ($q->[1] == 1) { + ok t_cmp($r->header("Content-Encoding"), "br", "response Content-Encoding is OK"); + } + else { + ok t_cmp($r->header("Content-Encoding"), undef, "response without Content-Encoding is OK"); + } + + if (!defined($r->header("Content-Length"))) { + t_debug "Content-Length was expected"; + ok 0; + } + if (!defined($r->header("ETag"))) { + t_debug "ETag field was expected"; + ok 0; + } -# GET request for a zero-length file. -$r = GET("/only_brotli/zero.txt", "Accept-Encoding" => "br"); -ok t_cmp($r->code, 200); -ok t_cmp($r->header("Content-Encoding"), "br", "response Content-Encoding is OK"); -if (!defined($r->header("Content-Length"))) { - t_debug "Content-Length was expected"; - ok 0; -} -if (!defined($r->header("ETag"))) { - t_debug "ETag field was expected"; - ok 0; -} + # GET request for a zero-length file. + print "qvalue: " . $q->[0] . "\n"; + $r = GET("/only_brotli/zero.txt", "Accept-Encoding" => "br" . $q->[0]); + ok t_cmp($r->code, 200); + if ($q->[1] == 1) { + ok t_cmp($r->header("Content-Encoding"), "br", "response Content-Encoding is OK"); + } + else { + ok t_cmp($r->header("Content-Encoding"), undef, "response without Content-Encoding is OK"); + } -# HEAD request against the location with Brotli. -$r = HEAD("/only_brotli/index.html", "Accept-Encoding" => "br"); -ok t_cmp($r->code, 200); -ok t_cmp($r->header("Content-Encoding"), "br", "response Content-Encoding is OK"); -if (!defined($r->header("Content-Length"))) { - t_debug "Content-Length was expected"; - ok 0; -} -if (!defined($r->header("ETag"))) { - t_debug "ETag field was expected"; - ok 0; + if (!defined($r->header("Content-Length"))) { + t_debug "Content-Length was expected"; + ok 0; + } + if (!defined($r->header("ETag"))) { + t_debug "ETag field was expected"; + ok 0; + } + + # HEAD request against the location with Brotli. + print "qvalue: " . $q->[0] . "\n"; + $r = HEAD("/only_brotli/index.html", "Accept-Encoding" => "br" . $q->[0]); + ok t_cmp($r->code, 200); + if ($q->[1] == 1) { + ok t_cmp($r->header("Content-Encoding"), "br", "response Content-Encoding is OK"); + } + else { + ok t_cmp($r->header("Content-Encoding"), undef, "response without Content-Encoding is OK"); + } + + if (!defined($r->header("Content-Length"))) { + t_debug "Content-Length was expected"; + ok 0; + } + if (!defined($r->header("ETag"))) { + t_debug "ETag field was expected"; + ok 0; + } } + if (have_module('deflate')) { # GET request against the location with fallback to deflate (test that # Brotli is chosen due to the order in SetOutputFilter). diff --git a/debian/perl-framework/t/modules/cgi.t b/debian/perl-framework/t/modules/cgi.t index d191d8d..9b6edc2 100644 --- a/debian/perl-framework/t/modules/cgi.t +++ b/debian/perl-framework/t/modules/cgi.t @@ -9,10 +9,7 @@ use File::stat; my $have_apache_2 = have_apache 2; my $have_apache_2050 = have_min_apache_version "2.0.50"; -my $script_log_length = 8192; -if (have_module 'mod_cgi') { - $script_log_length = 40960; -} +my $script_log_length = 40960; ## mod_cgi test ## @@ -21,12 +18,7 @@ if (have_module 'mod_cgi') { ## AddHandler cgi-script .sh ## AddHandler cgi-script .pl ## ScriptLog logs/mod_cgi.log -## <IfModule mod_cgi.c> -## ScriptLogLength 40960 -## </IfModule mod_cgi> -## <IfModule !mod_cgi.c> -## ScriptLogLength 8192 -## </IfModule mod_cgi> +## ScriptLogLength 40960 ## ScriptLogBuffer 256 ## <Directory @SERVERROOT@/htdocs/modules/cgi> ## Options +ExecCGI @@ -191,9 +183,8 @@ foreach my $length (@post_content) { $actual = POST_RC "$path/bogus-perl.pl", content => "$content"x$length; print "# posted content (length $length) to bogus-perl.pl\n"; - print "# got return code of: $actual, expecting: $expected\n"; ## should get rc 500 - ok ($actual eq $expected); + ok t_cmp($actual, $expected, "POST to $path/bogus-perl.pl [content: $content x $length]"); if (-e $cgi_log) { ## cgi log should be bigger. @@ -206,7 +197,7 @@ foreach my $length (@post_content) { ## should not fall in here at this point, ## but just in case... print "# verifying log did not increase in size...\n"; - ok ($$stat[7] eq $log_size); + ok t_cmp($$stat[7], $log_size, "log size should not have increased"); } $log_size = $$stat[7]; diff --git a/debian/perl-framework/t/modules/deflate.t b/debian/perl-framework/t/modules/deflate.t index c107b14..3b368ce 100644 --- a/debian/perl-framework/t/modules/deflate.t +++ b/debian/perl-framework/t/modules/deflate.t @@ -21,7 +21,7 @@ my @server_bucketeer_uri = ("/modules/deflate/bucketeer/P.txt", ); my $cgi_tests = 3; -my $tests_per_uri = 3; +my $tests_per_uri = 4; my $tests = $tests_per_uri * (@server_deflate_uris + @server_bucketeer_uri) + $cgi_tests; my $vars = Apache::Test::vars(); my $module = 'default'; @@ -33,6 +33,9 @@ print "testing $module\n"; my @deflate_headers; push @deflate_headers, "Accept-Encoding" => "gzip"; +my @deflate_headers_q0; +push @deflate_headers_q0, "Accept-Encoding" => "gzip;q=0"; + my @inflate_headers; push @inflate_headers, "Content-Encoding" => "gzip"; @@ -47,11 +50,13 @@ for my $server_deflate_uri (@server_deflate_uris) { my $original_str = GET_BODY($server_deflate_uri); my $deflated_str = GET_BODY($server_deflate_uri, @deflate_headers); + my $deflated_str_q0 = GET_BODY($server_deflate_uri, @deflate_headers_q0); my $inflated_str = POST_BODY($server_inflate_uri, @inflate_headers, content => $deflated_str); ok $original_str eq $inflated_str; + ok $original_str eq $deflated_str_q0; my $resp = POST($server_inflate_uri, @inflate_headers, content => "foo123456789012346"); if (have_min_apache_version("2.5")) { diff --git a/debian/perl-framework/t/modules/dir.t b/debian/perl-framework/t/modules/dir.t index 1b93423..51e632e 100644 --- a/debian/perl-framework/t/modules/dir.t +++ b/debian/perl-framework/t/modules/dir.t @@ -20,7 +20,7 @@ sub my_chomp { $actual =~ s/[\r\n]+$//s; } -plan tests => @bad_index * @index * 5 + @bad_index + 5, need_module 'dir'; +plan tests => @bad_index * @index * 5 + @bad_index + 5 + 3, need_module 'dir'; foreach my $bad_index (@bad_index) { @@ -91,6 +91,21 @@ $actual = GET_BODY $url; my_chomp(); ok ($actual eq $expected); +# DirectorySlash stuff +my $res = GET "/modules/dir", redirect_ok => 0; +ok ($res->code == 301); +$res = GET "/modules/dir/htaccess", redirect_ok => 0; +ok ($res->code == 403); + +if (!have_min_apache_version('2.5.1')) { + skip("missing DirectorySlash NotFound"); +} +else { + $res = GET "/modules/dir/htaccess/sub", redirect_ok => 0; + ok ($res->code == 404); +} + + sub write_htaccess { my $string = shift; diff --git a/debian/perl-framework/t/modules/headers.t b/debian/perl-framework/t/modules/headers.t index 3504a33..4892b95 100644 --- a/debian/perl-framework/t/modules/headers.t +++ b/debian/perl-framework/t/modules/headers.t @@ -2,6 +2,7 @@ use strict; use warnings FATAL => 'all'; use Apache::Test; +use Apache::TestUtil; use Apache::TestRequest; ## @@ -11,11 +12,138 @@ use Apache::TestRequest; my $htdocs = Apache::Test::vars('documentroot'); my $htaccess = "$htdocs/modules/headers/htaccess/.htaccess"; my @header_types = ('set', 'append', 'add', 'unset'); - + +my @testcases = ( + ## htaccess + ## Header to set in the request + ## Expected result + + # echo + [ + "Header echo Test-Header\nHeader echo ^Aaa\$\nHeader echo ^Aa\$", + [ 'Test-Header' => 'value', 'Aaa' => 'b' , 'Aa' => 'bb' ], + [ 'Test-Header' => 'value', 'Aaa' => 'b' , 'Aa' => 'bb' ], + ], + [ + "Header echo Test-Header\nHeader echo XXX\nHeader echo ^Aa\$", + [ 'Test-Header' => 'foo', 'aaa' => 'b', 'aa' => 'bb' ], + [ 'Test-Header' => 'foo', 'aa' => 'bb' ], + ], + [ + "Header echo Test-Header.*", # regex + [ 'Test-Header' => 'foo', 'Test-Header1' => 'value1', 'Test-Header2' => 'value2' ], + [ 'Test-Header' => 'foo', 'Test-Header1' => 'value1', 'Test-Header2' => 'value2' ], + ], + # edit + [ + "Header echo Test-Header\nHeader edit Test-Header foo bar", # sizeof(foo) = sizeof(bar) + [ 'Test-Header' => 'foofoo' ], + [ 'Test-Header' => 'barfoo' ], + ], + [ + "Header echo Test-Header\nHeader edit Test-Header foo2 bar", # sizeof(foo2) > sizeof(bar) + [ 'Test-Header' => 'foo2foo2' ], + [ 'Test-Header' => 'barfoo2' ], + ], + [ + "Header echo Test-Header\nHeader edit Test-Header foo bar2", # sizeof(foo) < sizeof(bar2) + [ 'Test-Header' => 'foofoo' ], + [ 'Test-Header' => 'bar2foo' ], + ], + # edit* + [ + "Header echo Test-Header\nHeader edit* Test-Header foo bar", # sizeof(foo) = sizeof(bar) + [ 'Test-Header' => 'foofoo' ], + [ 'Test-Header' => 'barbar' ], + ], + [ + "Header echo Test-Header\nHeader edit* Test-Header foo2 bar", # sizeof(foo2) > sizeof(bar) + [ 'Test-Header' => 'foo2foo2' ], + [ 'Test-Header' => 'barbar' ], + ], + [ + "Header echo Test-Header\nHeader edit* Test-Header foo bar2", # sizeof(foo) < sizeof(bar2) + [ 'Test-Header' => 'foofoo' ], + [ 'Test-Header' => 'bar2bar2' ], + ], + # merge + [ + "Header merge Test-Header foo", # missing header + [ ], + [ 'Test-Header' => 'foo' ], + ], + [ + "Header echo Test-Header\nHeader merge Test-Header foo", # already existing, same value + [ 'Test-Header' => 'foo' ], + [ 'Test-Header' => 'foo' ], + ], + [ + "Header echo Test-Header\nHeader merge Test-Header foo", # already existing, same value, but with "" + [ 'Test-Header' => '"foo"' ], + [ 'Test-Header' => '"foo", foo' ], + ], + [ + "Header echo Test-Header\nHeader merge Test-Header bar", # already existing, different value + [ 'Test-Header' => 'foo' ], + [ 'Test-Header' => 'foo, bar' ], + ], + # setifempty + [ + "Header echo Test-Header\nHeader setifempty Test-Header bar", # already existing + [ 'Test-Header' => 'foo' ], + [ 'Test-Header' => 'foo' ], + ], + [ + "Header echo Test-Header\nHeader setifempty Test-Header2 bar", # missing header + [ 'Test-Header' => 'foo' ], + [ 'Test-Header' => 'foo', 'Test-Header2' => 'bar' ], + ], + # env= + [ + "SetEnv MY_ENV\nHeader set Test-Header foo env=MY_ENV", # env defined + [ ], + [ 'Test-Header' => 'foo' ], + ], + [ + "Header set Test-Header foo env=!MY_ENV", # env NOT defined + [ ], + [ 'Test-Header' => 'foo' ], + ], + # expr= + [ + "Header set Test-Header foo \"expr=%{REQUEST_URI} =~ m#htaccess#\"", # expr + [ ], + [ 'Test-Header' => 'foo' ], + ], +); +if (have_min_apache_version('2.5.1')) { + push(@testcases, + ( + # edit* + [ + "Header echo Test-Header\nHeader edit* Test-Header (?<=a)(ba) cd", # lookbehind + [ 'Test-Header' => 'ababa' ], + [ 'Test-Header' => 'acdcd' ], + ], + [ + "Header echo Test-Header\nHeader edit* Test-Header ^ foo", # empty match (no infinite loop!) + [ 'Test-Header' => 'bar' ], + [ 'Test-Header' => 'foobar' ], + ], + [ + "Header echo Test-Header\nHeader edit* Test-Header ^(.*)\$ \$1;httpOnly;secure", # empty header/match (no infinite loop!) + [ 'Test-Header' => '' ], + [ 'Test-Header' => ';httpOnly;secure' ], + ], + ) + ); +} + plan tests => - @header_types**4 + @header_types**3 + @header_types**2 + @header_types**1, + @header_types**4 + @header_types**3 + @header_types**2 + @header_types**1 + scalar @testcases * 2, have_module 'headers'; +# Test various configurations foreach my $header1 (@header_types) { ok test_header($header1); @@ -37,6 +165,13 @@ foreach my $header1 (@header_types) { } +# Test some other Header directives, including regex +my $ua = LWP::UserAgent->new(); +my $hostport = Apache::TestRequest::hostport(); +foreach my $t (@testcases) { + test_header2($t); +} + ## clean up ## unlink $htaccess; @@ -157,3 +292,42 @@ sub test_header { } } + +sub test_header2 { + my @test = @_; + my $h = HTTP::Headers->new; + + print "\n\n\n"; + for (my $i = 0; $i < scalar @{$test[0][1]}; $i += 2) { + print "Header sent n°" . $i/2 . ":\n"; + print " header: " . $test[0][1][$i] . "\n"; + print " value: " . $test[0][1][$i+1] . "\n"; + $h->header($test[0][1][$i] => $test[0][1][$i+1]); + } + + open (HT, ">$htaccess"); + print HT $test[0][0]; + close(HT); + + ## + my $r = HTTP::Request->new('GET', "http://$hostport/modules/headers/htaccess/", $h); + my $res = $ua->request($r); + ok t_cmp($res->code, 200, "Checking return code is '200'"); + + my $isok = 1; + for (my $i = 0; $i < scalar @{$test[0][2]}; $i += 2) { + print "\n"; + print "Header received n°" . $i/2 . ":\n"; + print " header: " . $test[0][2][$i] . "\n"; + print " expected: " . $test[0][2][$i+1] . "\n"; + if ($res->header($test[0][2][$i])) { + print " received: " . $res->header($test[0][2][$i]) . "\n"; + } else { + print " received: <undefined>\n"; + } + $isok = $isok && $res->header($test[0][2][$i]) && $test[0][2][$i+1] eq $res->header($test[0][2][$i]); + } + print "\nResponse received is:\n" . $res->as_string; + + ok $isok; +} diff --git a/debian/perl-framework/t/modules/heartbeat.t b/debian/perl-framework/t/modules/heartbeat.t new file mode 100644 index 0000000..d9f6f18 --- /dev/null +++ b/debian/perl-framework/t/modules/heartbeat.t @@ -0,0 +1,30 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestRequest; +use Apache::TestUtil qw/t_start_error_log_watch t_finish_error_log_watch/; + +my $r; +my $line; +my $count = 0; +my $nb_seconds = 5; +# Because of timing, we may see less than what could be expected +my $nb_expected = $nb_seconds - 2; + +plan tests => 1, sub { need_module('mod_heartbeat', 'mod_heartmonitor') && !need_apache_mpm('prefork') }; + +# Give some time to the heart to beat a few times +t_start_error_log_watch(); +sleep($nb_seconds); +my @loglines = t_finish_error_log_watch(); + +# Heartbeat sent by mod_heartbeat and received by mod_heartmonitor are logged with DEBUG AH02086 message +foreach $line (@loglines) { + if ($line =~ "AH02086") { + $count++; + } +} + +print "Expecting at least " . $nb_expected . " heartbeat ; Seen: " . $count . "\n"; +ok($count >= $nb_expected); diff --git a/debian/perl-framework/t/modules/http2.t b/debian/perl-framework/t/modules/http2.t deleted file mode 100644 index d58f52f..0000000 --- a/debian/perl-framework/t/modules/http2.t +++ /dev/null @@ -1,528 +0,0 @@ -use strict; -use warnings FATAL => 'all'; - -use Net::SSLeay; -use Apache::Test; -use Apache::TestRequest; -use Apache::TestUtil; -use Apache::TestConfig (); - -my $tls_version_suite = 4; -my $num_suite = 24; -my $vhost_suite = 4; - -my $total_tests = 2 * $num_suite + $vhost_suite + $tls_version_suite; - -Net::SSLeay::initialize(); - -my $sni_available = Net::SSLeay::OPENSSL_VERSION_NUMBER() >= 0x01000000; -my $alpn_available = $sni_available && exists &Net::SSLeay::CTX_set_alpn_protos; - -plan tests => $total_tests, need 'Protocol::HTTP2::Client', - need_module 'http2', need_min_apache_version('2.4.17'); - -# Check support for TLSv1_2 and later - -my $tls_modern = 1; - -Apache::TestRequest::set_ca_cert(); -my $sock = Apache::TestRequest::vhost_socket('h2'); -ok ($sock && $sock->connected); - -my $req = "GET / HTTP/1.1\r\n". - "Host: " . Apache::TestRequest::hostport() . "\r\n". - "\r\n"; - -ok $sock->print($req); - -my $line = Apache::TestRequest::getline($sock) || ''; - -ok t_cmp($line, qr{^HTTP/1\.. 200}, "read first response-line"); - -my $tls_version = $sock->get_sslversion(); - -ok t_cmp($tls_version, qr{^(SSL|TLSv\d(_\d)?$)}, "TLS version in use"); - -if ($tls_version =~ /^(SSL|TLSv1(|_0|_1)$)/) { - print STDOUT "Disabling TLS tests due to TLS version $tls_version\n"; - $tls_modern = 0; -} - -Apache::TestRequest::module("http2"); - -my $config = Apache::Test::config(); -my $host = $config->{vhosts}->{h2c}->{servername}; -my $port = $config->{vhosts}->{h2c}->{port}; - -my $shost = $config->{vhosts}->{h2}->{servername}; -my $sport = $config->{vhosts}->{h2}->{port}; -my $serverdir = $config->{vars}->{t_dir}; -my $htdocs = $serverdir . "/htdocs"; - -require Protocol::HTTP2::Client; -use AnyEvent; -use AnyEvent::Socket; -use AnyEvent::Handle; -use Net::SSLeay; -use AnyEvent::TLS; -use Carp qw( croak ); - -no warnings 'redefine'; -no strict 'refs'; -{ - my $old_ref = \&{ 'AnyEvent::TLS::new' }; - *{ 'AnyEvent::TLS::new' } = sub { - my ( $class, %param ) = @_; - - my $self = $old_ref->( $class, %param ); - - $self->{host_name} = $param{host_name} - if exists $param{host_name}; - - $self; - }; -} - -{ - my $old_ref = \&{ 'AnyEvent::TLS::_get_session' }; - *{ 'AnyEvent::TLS::_get_session' } = sub($$;$$) { - my ($self, $mode, $ref, $cn) = @_; - - my $session = $old_ref->( @_ ); - - if ( $mode eq 'connect' ) { - if ( $self->{host_name} ) { - print 'setting host_name to ' . $self->{host_name}; - Net::SSLeay::set_tlsext_host_name( $session, $self->{host_name} ); - } - } - - $session; - }; -} - - -sub connect_and_do { - my %args = ( - @_ - ); - my $scheme = $args{ctx}->{scheme}; - my $host = $args{ctx}->{host}; - my $port = $args{ctx}->{port}; - my $client = $args{ctx}->{client}; - my $host_name = $args{ctx}->{host_name}; - my $w = AnyEvent->condvar; - - tcp_connect $host, $port, sub { - my ($fh) = @_ or do { - print "connection failed: $!\n"; - $w->send; - return; - }; - - my $tls; - my $tls_ctx; - if ($scheme eq 'https') { - $tls = "connect"; - eval { - # ALPN (Net-SSLeay > 1.55, openssl >= 1.0.1) - if ( $alpn_available ) { - $tls_ctx = AnyEvent::TLS->new( method => "TLSv1_2", - host_name => $host_name ); - Net::SSLeay::CTX_set_alpn_protos( $tls_ctx->ctx, ['h2'] ); - } - else { - $tls_ctx = AnyEvent::TLS->new( host_name => $host_name ); - } - }; - if ($@) { - print "Some problem with SSL CTX: $@\n"; - $w->send; - return; - } - } - - my $handle; - $handle = AnyEvent::Handle->new( - fh => $fh, - tls => $tls, - tls_ctx => $tls_ctx, - autocork => 1, - on_error => sub { - $_[0]->destroy; - print "connection error\n"; - $w->send; - }, - on_eof => sub { - $handle->destroy; - $w->send; - } - ); - - # First write preface to peer - while ( my $frame = $client->next_frame ) { - $handle->push_write($frame); - } - - $handle->on_read(sub { - my $handle = shift; - - $client->feed( $handle->{rbuf} ); - $handle->{rbuf} = undef; - - while ( my $frame = $client->next_frame ) { - $handle->push_write($frame); - } - - # Terminate connection if all done - $handle->push_shutdown if $client->shutdown; - }); - }; - $w->recv; - -} - -################################################################################ -# -# Add a request to the client, will be started whenever a STREAM to -# the server is available. -# -sub add_request { - my ($scheme, $client, $host, $port); - my %args = ( - method => 'GET', - headers => [], - rc => 200, - on_done => sub { - my %args = ( @_ ); - my $ctx = $args{ctx}; - my $req = $args{request}; - my $resp = $args{response}; - my $hr = $resp->{headers}; - my %headers = @$hr; - ok t_cmp($headers{':status'}, $req->{rc}, - "$req->{method} $ctx->{scheme}://$ctx->{host}:$ctx->{port}$req->{path}"); - }, - @_ - ); - $client = $args{ctx}->{client}; - $scheme = $args{ctx}->{scheme}; - $host = $args{ctx}->{host}; - $port = $args{ctx}->{port}; - - $client->request( - ':scheme' => $scheme, - ':authority' => $args{authority} || $host . ':' . $port, - ':path' => $args{path}, - ':method' => $args{method}, - headers => $args{headers}, - on_done => sub { - my ($headers, $data) = @_; - $args{on_done}( - ctx => $args{ctx}, - request => \%args, - response => { headers => \@$headers, data => $data } - ); - } - ); -} - -################################################################################ -# -# Add a list of request that will be processed in order. Only when the previous -# request is done, will a new one be started. -# -sub add_sequential { - my ($scheme, $client, $host, $port); - my %args = ( @_ ); - my $ctx = $args{ctx}; - my $requests = $args{requests}; - - $client = $args{ctx}->{client}; - $scheme = $args{ctx}->{scheme}; - $host = $args{ctx}->{host}; - $port = $args{ctx}->{port}; - - my $request = shift @$requests; - - if ($request) { - my %r = ( - method => 'GET', - headers => [], - rc => 200, - on_done => sub { - my %args = ( @_ ); - my $ctx = $args{ctx}; - my $req = $args{request}; - my $resp = $args{response}; - my $hr = $resp->{headers}; - my %headers = @$hr; - ok t_cmp($headers{':status'}, $req->{rc}, - "$req->{method} $ctx->{scheme}://$ctx->{host}:$ctx->{port}$req->{path}"); - }, - %$request - ); - - print "test case: $r{descr}: $r{method} $ctx->{scheme}://$ctx->{host}:$ctx->{port}$r{path}\n"; - $client->request( - ':scheme' => $scheme, - ':authority' => $r{authority} || $host . ':' . $port, - ':path' => $r{path}, - ':method' => $r{method}, - headers => $r{headers}, - on_done => sub { - my ($headers, $data) = @_; - $r{on_done}( - ctx => ${ctx}, - request => \%r, - response => { headers => \@$headers, data => $data } - ); - add_sequential( - ctx => $ctx, - requests => $requests - ); - } - ); - } -} - -sub cmp_content_length { - my %args = ( @_ ); - my $ctx = $args{ctx}; - my $req = $args{request}; - my $resp = $args{response}; - my $hr = $resp->{headers}; - my %headers = @$hr; - ok t_cmp($headers{':status'}, $req->{rc}, "response status"); - ok t_cmp(length $resp->{data}, $req->{content_length}, "content-length"); -} - -sub cmp_content { - my %args = ( @_ ); - my $ctx = $args{ctx}; - my $req = $args{request}; - my $resp = $args{response}; - my $hr = $resp->{headers}; - my %headers = @$hr; - ok t_cmp($headers{':status'}, $req->{rc}, "response status"); - ok t_cmp($resp->{data}, $req->{content}, "content comparision"); -} - -sub cmp_file_response { - my %args = ( @_ ); - my $ctx = $args{ctx}; - my $req = $args{request}; - my $resp = $args{response}; - my $hr = $resp->{headers}; - my %headers = @$hr; - ok t_cmp($headers{':status'}, $req->{rc}, "response status"); - open(FILE, "<$htdocs$req->{path}") or die "cannot open $req->{path}"; - undef $/; - my $content = <FILE>; - close(FILE); - ok t_is_equal($resp->{data}, $content); -} - -sub check_redir { - my %args = ( @_ ); - my $ctx = $args{ctx}; - my $req = $args{request}; - my $resp = $args{response}; - my $hr = $resp->{headers}; - my %headers = @$hr; - ok t_cmp($headers{':status'}, 302, "response status"); - ok t_cmp( - $headers{location}, - "$ctx->{scheme}://$ctx->{host}:$ctx->{port}$req->{redir_path}", - "location header" - ); -} - -################################################################################ -# -# Perform common tests to h2c + h2 hosts -# -sub do_common { - my %args = ( - scheme => 'http', - host => 'localhost', - port => 80, - @_ - ); - my $true_tls = ($args{scheme} eq 'https' and $sni_available); - - $args{client} = Protocol::HTTP2::Client->new( upgrade => 0 ); - - my $r = [ - { - descr => 'TC0001, expecting 200', - path => '/' - }, - { - descr => 'TC0002, expecting 404', - rc => 404, - path => '/not_here' - }, - { - descr => 'TC0005, cmp index.html file', - path => '/modules/h2/index.html', - on_done => \&cmp_file_response - }, - { - descr => 'TC0006, cmp image file', - path => '/modules/h2/003/003_img.jpg', - on_done => \&cmp_file_response - }, - ]; - - if (have_module 'mod_rewrite') { - push @$r, { - descr => 'TC0007, rewrite handling', - path => '/modules/h2/latest.tar.gz', - redir_path => "/modules/h2/xxx-1.0.2a.tar.gz", - on_done => \&check_redir - } - } - else { - skip "skipping test as mod_rewrite not available" foreach(1..2); - } - - if (have_cgi) { - # my $sni_host = $true_tls? 'localhost' : ''; - my $content = <<EOF; -<html><body> -<h2>Hello World!</h2> -</body></html> -EOF - - push @$r, { - descr => 'TC0008, hello.pl with ssl vars', - path => '/modules/h2/hello.pl', - content => $content, - on_done => \&cmp_content, - }; - - $content = <<EOF; -<html><body> -<p>No query was specified.</p> -</body></html> -EOF - push @$r, { - descr => 'TC0009, necho.pl without arguments', - path => '/modules/h2/necho.pl', - content => $content, - rc => 400, - on_done => \&cmp_content, - }; - push @$r, { - descr => 'TC0010, necho.pl 2x10', - path => '/modules/h2/necho.pl?count=2&text=0123456789', - content => "01234567890123456789", - on_done => \&cmp_content, - }; - push @$r, { - descr => 'TC0011, necho.pl 10x10', - path => '/modules/h2/necho.pl?count=10&text=0123456789', - content_length => 100, - on_done => \&cmp_content_length, - }; - push @$r, { - descr => 'TC0012, necho.pl 100x10', - path => '/modules/h2/necho.pl?count=100&text=0123456789', - content_length => 1000, - on_done => \&cmp_content_length, - }; - push @$r, { - descr => 'TC0013, necho.pl 1000x10', - path => '/modules/h2/necho.pl?count=1000&text=0123456789', - content_length => 10000, - on_done => \&cmp_content_length, - }; - push @$r, { - descr => 'TC0014, necho.pl 10000x10', - path => '/modules/h2/necho.pl?count=10000&text=0123456789', - content_length => 100000, - on_done => \&cmp_content_length, - }; - push @$r, { - descr => 'TC0015, necho.pl 100000x10', - path => '/modules/h2/necho.pl?count=100000&text=0123456789', - content_length => 1000000, - on_done => \&cmp_content_length, - }; - } - else { - skip "skipping test as mod_cgi not available" foreach(1..1); - } - - add_sequential( - ctx => \%args, - requests => $r - ); - connect_and_do( ctx => \%args ); -} - -################################################################################ -# -# Perform tests for virtual host setups, requires a client with SNI+ALPN -# -sub do_vhosts { - my %args = ( - scheme => 'http', - host => 'localhost', - port => 80, - @_ - ); - $args{client} = Protocol::HTTP2::Client->new( upgrade => 0 ); - - my $r = [ - { - descr => 'VHOST000, expecting 200', - path => '/' - }, - { - descr => 'VHOST001, expect 404 or 421 (using Host:)', - rc => 404, - path => '/misdirected', - header => [ 'host' => 'noh2.example.org' . $args{port} ] - }, - { - descr => 'VHOST002, expect 421 (using :authority)', - rc => 421, - path => '/misdirected', - authority => 'noh2.example.org:' . $args{port} - }, - { - descr => 'VHOST003, expect 421 ', - rc => (have_min_apache_version('2.4.18')? 404 : 421), - path => '/misdirected', - authority => 'test.example.org:' . $args{port} - }, - ]; - - add_sequential( - ctx => \%args, - requests => $r - ); - connect_and_do( ctx => \%args ); -} - -################################################################################ -# -# Bring it on -# -do_common( 'scheme' => 'http', 'host' => $host, 'port' => $port ); -if ($tls_modern) { - do_common( 'scheme' => 'https', 'host' => $shost, 'port' => $sport ); -} else { - skip "skipping test as TLS version '$tls_version' is not supported" foreach(1..$num_suite); -} -if ($sni_available) { - if ($tls_modern) { - do_vhosts( 'scheme' => 'https', 'host' => $shost, 'port' => $sport, host_name => "$shost:${sport}" ); - } else { - skip "skipping test as TLS version '$tls_version' is not supported" foreach(1..$vhost_suite); - } -} else { - skip "skipping test as SNI not available" foreach(1..$vhost_suite); -} diff --git a/debian/perl-framework/t/modules/include.t b/debian/perl-framework/t/modules/include.t index 64b2fdc..9ff2411 100644 --- a/debian/perl-framework/t/modules/include.t +++ b/debian/perl-framework/t/modules/include.t @@ -28,6 +28,7 @@ my $htdocs = Apache::Test::vars('documentroot'); my %test = ( "echo.shtml" => "echo.shtml", "set.shtml" => "set works", +"comment.shtml" => "No comment here", "include1.shtml" => "inc-two.shtml body include.shtml body", "include2.shtml" => "inc-two.shtml body include.shtml body", "include3.shtml" => "inc-two.shtml body inc-one.shtml body ". @@ -96,6 +97,10 @@ my %test = ( "virtualq.shtml?foo=bar" => "foo=bar pass inc-two.shtml body foo=bar", # PR#12655 "inc-nego.shtml" => "index.html.en", # requires mod_negotiation +"mod_request/echo.shtml"=> "echo.shtml", +"mod_request/post.shtml?foo=bar&foo2=bar2" + => "GET foo: bar foo2: bar2", +"mod_request/post.shtml"=> "POST foo: bar foo2: bar2", # will be twice, only the first one succeed ); my %ap_expr_test = ( @@ -227,15 +232,16 @@ unless ($have_apache_2) { push @todo, (scalar keys %tests) + 1; } -# in addition to %tests, there are 1 fsize and 1 flastmod test, +# in addition to %tests, there are 1 mod_request expected failure, +# 1 fsize and 1 flastmod test, # 1 GET test, 2 query string tests, 14 XBitHack tests and 14 # tests that use mod_bucketeer to construct brigades for mod_include -my $tests = (scalar keys %tests) + @patterns + 1 + 1 + 1 + 2 + 14 + 14; +my $tests = (scalar keys %tests) + 1 + @patterns + 1 + 1 + 1 + 2 + 14 + 14; plan tests => $tests, todo => \@todo, - need need_lwp, need_module 'include'; + need 'DateTime', need_lwp, need_module 'include'; foreach $doc (sort keys %tests) { # do as much from %test as we can @@ -267,6 +273,35 @@ foreach $doc (sort keys %tests) { skip "Skipping 'exec cgi' test; no cgi module.", 1; } } + elsif ($doc =~ m/mod_request.*\?/) { + # param in the url ==> use GET + if (have_cgi) { + ok t_cmp(super_chomp(GET_BODY "$dir$doc"), + $tests{$doc}, + "GET $dir$doc" + ); + } + else { + skip "Skipping 'exec cgi' test; no cgi module.", 1; + } + } + elsif ($doc =~ m/mod_request/) { + # no param in the url ==> use POST with a content + if (have_cgi) { + ok t_cmp(super_chomp(POST_BODY "$dir$doc", content => "foo=bar&foo2=bar2"), + $tests{$doc}, + "POST $dir$doc" + ); + if ($doc =~ m/mod_request.*post/) { + # KeptBodySize is 32 + my $r = POST("$dir$doc", content => "foo=bar&foo2=bar2&foo3=bar3&foo4=bar4"); + ok t_cmp($r->code, 413, "sizeof(body) > KeptBodySize"); + } + } + else { + skip "Skipping 'exec cgi' test; no cgi module.", 2; + } + } else { ok t_cmp(super_chomp(GET_BODY "$dir$doc"), $tests{$doc}, @@ -311,6 +346,10 @@ unless(eval "require POSIX") { else { # use DateTime and avoid the system locale messing things up use DateTime; + # Only for checking, whether system strftime supports %s + use POSIX; + my $strftime_gnu = (POSIX::strftime("%s", gmtime()) eq '%s' ? 0 : 1); + my $result = super_chomp(GET_BODY "${dir}file.shtml"); $result = single_space($result); @@ -325,8 +364,8 @@ else { my $expected = join ' ' => $dt->strftime("%A, %B %e, %G"), $dt->strftime("%A, %B %e, %G"), - $dt->strftime("%s"), - $dt->strftime("%s"); + $strftime_gnu ? $dt->strftime("%s") : '%s', + $strftime_gnu ? $dt->strftime("%s") : '%s'; # trim output $expected = single_space($expected); diff --git a/debian/perl-framework/t/modules/info.t b/debian/perl-framework/t/modules/info.t index cbc4d6e..21cee4e 100644 --- a/debian/perl-framework/t/modules/info.t +++ b/debian/perl-framework/t/modules/info.t @@ -31,7 +31,7 @@ foreach (split /\n/, $info) { foreach (sort keys %$mods) { ($mods->{$_} && !$config->should_skip_module($_)) or next; - if ($_ =~ /^mod_mpm_(eventopt|event|prefork|worker)\.c$/) { + if ($_ =~ /^mod_mpm_(eventopt|event|motorz|prefork|worker)\.c$/) { push(@expected,"$1.c"); } elsif ($_ eq 'mod_mpm_simple.c') { push(@expected,'simple_api.c'); diff --git a/debian/perl-framework/t/modules/ldap.t b/debian/perl-framework/t/modules/ldap.t new file mode 100644 index 0000000..d3bb8e9 --- /dev/null +++ b/debian/perl-framework/t/modules/ldap.t @@ -0,0 +1,52 @@ +use strict; +use warnings FATAL => 'all'; + +# +# To run tests for mod_authnz_ldap: +# +# a) run an LDAP server with root DN of dc=example,dc=com on localhost port 8389 +# b) populate the directory with the LDIF from scripts/httpd.ldif +# c) configure & run the test suite passing "--defines LDAP" to ./t/TEST +# + +use Apache::Test; +use Apache::TestRequest; +use Apache::TestUtil; +use Apache::TestConfig; + +my $defs = Apache::Test->vars('defines'); +my $ldap_defined = $defs =~ /LDAP/; + +# URL -> username, password, expected-status +my @cases = ( + ['/modules/ldap/simple/' => '', '', 401], + ['/modules/ldap/simple/' => 'alpha', 'badpass', 401], + ['/modules/ldap/simple/' => 'alpha', 'Alpha', 200], + ['/modules/ldap/simple/' => 'gamma', 'Gamma', 200], + ['/modules/ldap/group/' => 'gamma', 'Gamma', 401], + ['/modules/ldap/group/' => 'delta', 'Delta', 200], + ['/modules/ldap/refer/' => 'alpha', 'Alpha', 401], + ['/modules/ldap/refer/' => 'beta', 'Beta', 200], +); + +plan tests => scalar @cases, + need need_module('authnz_ldap'), { "LDAP testing not configured" => $ldap_defined }; + +foreach my $t (@cases) { + my $url = $t->[0]; + my $username = $t->[1]; + my $password = $t->[2]; + my $response; + my $creds; + + if ($username) { + $response = GET $url, username => $username, password => $password; + $creds = "$username/$password"; + } + else { + $response = GET $url; + $creds = "no credentials"; + } + + ok t_cmp($response->code, $t->[3], "test for $url with $creds"); +} diff --git a/debian/perl-framework/t/modules/lua.t b/debian/perl-framework/t/modules/lua.t index 9eb5b4f..9e6836d 100644 --- a/debian/perl-framework/t/modules/lua.t +++ b/debian/perl-framework/t/modules/lua.t @@ -41,6 +41,8 @@ my @ts = ( { url => "$pfx/setheaderfromparam.lua?HeaderName=foo&HeaderValue=bar", rcontent => "Header set", headers => { "foo" => "bar" } }, + { url => "$pfx/filtered/foobar.html", + rcontent => "prefix\nbucket:foobar\nsuffix\n" }, ); plan tests => 4 * scalar @ts, need 'lua'; diff --git a/debian/perl-framework/t/modules/negotiation.t b/debian/perl-framework/t/modules/negotiation.t index 0081ce0..9218aa1 100644 --- a/debian/perl-framework/t/modules/negotiation.t +++ b/debian/perl-framework/t/modules/negotiation.t @@ -7,8 +7,12 @@ use Apache::TestUtil; ## mod_negotiation test (see extra.conf.in) -my ($en, $fr, $de, $fu, $bu) = qw(en fr de fu bu); +my ($en, $fr, $de, $fu, $bu, $zh) = qw(en fr de fu bu zh-TW); + my @language = ($en, $fr, $de, $fu); +if (have_min_apache_version("2.4.38")) { + push @language, $zh; +} my @ct_tests = ( # [ Accept header, Expected response ] diff --git a/debian/perl-framework/t/modules/proxy.t b/debian/perl-framework/t/modules/proxy.t index af822cd..0a81f4f 100644 --- a/debian/perl-framework/t/modules/proxy.t +++ b/debian/perl-framework/t/modules/proxy.t @@ -7,16 +7,45 @@ use Apache::TestUtil; use Apache::TestConfig (); use Misc; -my $num_tests = 31; +my $num_tests = 46; plan tests => $num_tests, need need_module 'proxy', need_module 'setenvif'; Apache::TestRequest::module("proxy_http_reverse"); Apache::TestRequest::user_agent(requests_redirectable => 0); my $r = GET("/reverse/"); -ok t_cmp($r->code, 200, "reverse proxy to index.html"); +ok t_cmp($r->code, 200, "reverse proxy"); ok t_cmp($r->content, qr/^welcome to /, "reverse proxied body"); +$r = GET("/reverse/index.html"); +ok t_cmp($r->code, 200, "reverse proxy to index.html"); +ok t_cmp($r->content, qr/^welcome to /, "reverse proxied body to index.html"); + +if (have_min_apache_version('2.4.49')) { + $r = GET("/reverse-match/"); + ok t_cmp($r->code, 200, "reverse proxy match"); + ok t_cmp($r->content, qr/^welcome to /, "reverse proxied body match"); + + $r = GET("/reverse-match/index.html"); + ok t_cmp($r->code, 200, "reverse proxy match to index.html"); + ok t_cmp($r->content, qr/^welcome to /, "reverse proxied body match to index.html"); +} +else { + skip "skipping reverse-match test with httpd <2.5.1" foreach (1..4); +} + +$r = GET("/reverse-slash"); +ok t_cmp($r->code, 200, "reverse proxy match no slash"); +ok t_cmp($r->content, qr/^welcome to /, "reverse proxied body no slash"); + +$r = GET("/reverse-slash/"); +ok t_cmp($r->code, 200, "reverse proxy match w/ slash"); +ok t_cmp($r->content, qr/^welcome to /, "reverse proxied body w/ slash"); + +$r = GET("/reverse-slash/index.html"); +ok t_cmp($r->code, 200, "reverse proxy match w/ slash to index.html"); +ok t_cmp($r->content, qr/^welcome to /, "reverse proxied body w/ slash to index.html"); + if (have_min_apache_version('2.4.0')) { $r = GET("/reverse/locproxy/"); ok t_cmp($r->code, 200, "reverse Location-proxy to index.html"); @@ -188,3 +217,17 @@ else { skip "skipping UDS tests with httpd < 2.4.7" foreach (1..2); } +if (have_min_apache_version('2.4.49')) { + + $r = GET("/notexisting/../mapping/mapping.html"); + ok t_cmp($r->code, 200, "proxy mapping=servlet map it to /servlet/mapping.html"); + + $r = GET("/notexisting/..;/mapping/mapping.html"); + ok t_cmp($r->code, 200, "proxy mapping=servlet map it to /servlet/mapping.html"); + + $r = GET("/mapping/mapping.html"); + ok t_cmp($r->code, 200, "proxy to /servlet/mapping.html"); +} +else { + skip "skipping tests with mapping=servlet" foreach (1..3); +} diff --git a/debian/perl-framework/t/modules/proxy_balancer.t b/debian/perl-framework/t/modules/proxy_balancer.t index a16521b..ee31507 100644 --- a/debian/perl-framework/t/modules/proxy_balancer.t +++ b/debian/perl-framework/t/modules/proxy_balancer.t @@ -6,22 +6,120 @@ use Apache::TestRequest; use Apache::TestUtil; use Apache::TestConfig (); -plan tests => 3, need 'proxy_balancer', 'proxy_http'; +my @echos = ('A'x8, 'A'x64, 'A'x2048, 'A'x4096); + +my $skipbodyfailover = !need_min_apache_version("2.4.42"); +my $referertest = 0; + +if (have_min_apache_version("2.4.41")) { + $referertest = 2; +} + +plan tests => 6+(2*scalar @echos)+$referertest, need 'proxy_balancer', 'proxy_http'; Apache::TestRequest::module("proxy_http_balancer"); Apache::TestRequest::user_agent(requests_redirectable => 0); +# Extract the nonce from response to the URL +sub GetNonce { + my $url = shift; + my $balancer = shift; + my $r; + $r = GET($url); + my $NONCE; + foreach my $query ( split( /\?b=/, $r->content ) ){ + if ($query =~ m/$balancer/) { + foreach my $var ( split( /&/, $query ) ){ + if ($var =~ m/nonce=/) { + foreach my $nonce ( split( /nonce=/, $var ) ){ + my $ind = index ($nonce, "\""); + $nonce = substr($nonce, 0, ${ind}); + if ( $nonce =~ m/^[0-9a-fA-F-]+$/ ) { + $NONCE = $nonce; + last; + } + } + last; + } + } + last; + } + } + return $NONCE; +} + +my $r; + +if (have_module('lbmethod_byrequests')) { + $r = GET("/baltest1/index.html"); + ok t_cmp($r->code, 200, "Balancer did not die"); +} else { + skip "skipping tests without mod_lbmethod_byrequests" foreach (1..1); +} + +if (have_module('lbmethod_bytraffic')) { + $r = GET("/baltest2/index.html"); + ok t_cmp($r->code, 200, "Balancer did not die"); +} else { + skip "skipping tests without mod_lbmethod_bytraffic" foreach (1..1); +} + +if (have_module('lbmethod_bybusyness')) { + $r = GET("/baltest3/index.html"); + ok t_cmp($r->code, 200, "Balancer did not die"); +} else { + skip "skipping tests without mod_lbmethod_bybusyness" foreach (1..1); +} + +if (have_module('lbmethod_heartbeat')) { + #$r = GET("/baltest4/index.html"); + #ok t_cmp($r->code, 200, "Balancer did not die"); +} else { + #skip "skipping tests without mod_lbmethod_heartbeat" foreach (1..1); +} + -my $r = GET("/baltest1/index.html"); -ok t_cmp($r->code, 200, "Balancer did not die"); -$r = GET("/baltest2/index.html"); -ok t_cmp($r->code, 200, "Balancer did not die"); +# PR63891 +foreach my $t (@echos) { + $r = POST "/baltest_echo_post", content => $t; + skip $skipbodyfailover, t_cmp($r->code, 200, "failed over"); + skip $skipbodyfailover, t_cmp($r->content, $t, "response body echoed"); +} + +# test dynamic part +$r = GET("/balancer-manager"); +ok t_cmp($r->code, 200, "Can't find balancer-manager"); + +# get the nonce and add a worker +my $result = GetNonce("/balancer-manager", "dynproxy"); -$r = GET("/baltest3/index.html"); -ok t_cmp($r->code, 200, "Balancer did not die"); +my $query = "b_lbm=byrequests&b_tmo=0&b_max=0&b_sforce=0&b_ss=&b_nwrkr=ajp%3A%2F%2F%5B0%3A0%3A0%3A0%3A0%3A0%3A0%3A1%5D%3A8080&b_wyes=1&b=dynproxy&nonce=" . $result; +my @proxy_balancer_headers; +my $vars = Apache::Test::vars(); +push @proxy_balancer_headers, "Referer" => "http://" . $vars->{servername} . ":" . $vars->{port} . "/balancer-manager"; + +# First try without the referer it should fail. +if (have_min_apache_version("2.4.41")) { + $r = POST("/balancer-manager", content => $query); + ok t_cmp($r->code, 200, "request failed"); + ok !t_cmp($r->content, qr/ajp/, "AJP worker created"); +} -if (have_min_apache_version("2.3.0")) { - # $r = GET("/baltest4/index.html"); - # ok t_cmp($r->code, 200, "Balancer did not die"); +# Try with the referer and http (byrequests) +if (have_min_apache_version("2.4.49") && have_module('lbmethod_byrequests')) { + $r = GET("/dynproxy"); + ok t_cmp($r->code, 503, "request should fail for /dynproxy"); + # create it + $query = 'b_lbm=byrequests&b_tmo=0&b_max=0&b_sforce=0&b_ss=&b_nwrkr=http%3A%2F%2F' . $vars->{servername} . '%3A' . $vars->{port} . '&b_wyes=1&b=dynproxy&nonce=' . $result; + $r = POST("/balancer-manager", content => $query, @proxy_balancer_headers); + # enable it. + $query = 'w=http%3A%2F%2F' . $vars->{servername} . '%3A' . $vars->{port} . '&b=dynproxy&w_status_D=0&nonce=' . $result; + $r = POST("/balancer-manager", content => $query, @proxy_balancer_headers); + # make a query + $r = GET("/dynproxy"); + ok t_cmp($r->code, 200, "request failed to /dynproxy"); +} else { + skip "skipping tests without lbmethod_byrequests"; + skip "skipping tests without lbmethod_byrequests"; } diff --git a/debian/perl-framework/t/modules/proxy_fcgi.t b/debian/perl-framework/t/modules/proxy_fcgi.t index 1577497..2f62580 100644 --- a/debian/perl-framework/t/modules/proxy_fcgi.t +++ b/debian/perl-framework/t/modules/proxy_fcgi.t @@ -129,8 +129,16 @@ sub run_fcgi_envvar_request $envs{$components[0]} = $components[1]; } - # Rejoin the child FCGI process. - waitpid($child, 0) unless ($fcgi_port <= 0) ; + if ($fcgi_port > 0) { + if ($r->code eq '500') { + # Unknown failure, probably the request didn't hit the FCGI child + # process, so it will hang waiting for our request + kill 'TERM', $child; + } else { + # Rejoin the child FCGI process. + waitpid($child, 0); + } + } return \%envs; } diff --git a/debian/perl-framework/t/modules/proxy_websockets.t b/debian/perl-framework/t/modules/proxy_websockets.t new file mode 100644 index 0000000..f2d6558 --- /dev/null +++ b/debian/perl-framework/t/modules/proxy_websockets.t @@ -0,0 +1,81 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestRequest; +use Apache::TestUtil; +use Apache::TestConfig (); + +# not reliable, hangs for some people: +# my @test_cases = ( "ping0", "ping1" x 10, "ping2" x 100, "ping3" x 1024, "ping4" x 4096, "sendquit"); +my @test_cases = ( "ping0", "ping1" x 10, "ping2" x 100, "ping3" x 1024, "sendquit"); +my $total_tests = 2; + +plan tests => $total_tests, need 'AnyEvent::WebSocket::Client', + need_module('proxy_http', 'lua'), need_min_apache_version('2.4.47'); + +require AnyEvent; +require AnyEvent::WebSocket::Client; + +my $config = Apache::Test::config(); +my $hostport = Apache::TestRequest::hostport(); + +my $client = AnyEvent::WebSocket::Client->new(timeout => 5); + +my $quit_program = AnyEvent->condvar; + +my $responses = 0; +my $surprised = 0; + +$client->connect("ws://$hostport/proxy/wsoc")->cb(sub { + our $connection = eval { shift->recv }; + t_debug("wsoc connected"); + if($@) { + # handle error... + warn $@; + $quit_program->send(); + return; + } + + + # AnyEvent::WebSocket::Connection does not pass the PONG message down to the callback + # my $actualpingmsg = AnyEvent::WebSocket::Message->new(opcode => 0x09, body => "xxx"); + # $connection->send($actualpingmsg); + + foreach (@test_cases){ + $connection->send($_); + } + + $connection->on(finish => sub { + t_debug("finish"); + }); + + # recieve message from the websocket... + $connection->on(each_message => sub { + # $connection is the same connection object + # $message isa AnyEvent::WebSocket::Message + my($connection, $message) = @_; + $responses++; + t_debug("wsoc msg received: " . substr($message->body, 0, 5). " opcode " . $message->opcode); + if ("sendquit" eq $message->body) { + $connection->send('quit'); + t_debug("closing"); + $connection->close; # doesn't seem to close TCP. + $quit_program->send(); + } + elsif ($message->body =~ /^ping(\d)/) { + my $offset = $1; + if ($message->body ne $test_cases[$offset]) { + $surprised++; + } + } + else { + $surprised++; + } + }); + +}); + +$quit_program->recv; +ok t_cmp($surprised, 0); +ok t_cmp($responses, scalar(@test_cases) ); diff --git a/debian/perl-framework/t/modules/proxy_websockets_ssl.t b/debian/perl-framework/t/modules/proxy_websockets_ssl.t new file mode 100644 index 0000000..793ff48 --- /dev/null +++ b/debian/perl-framework/t/modules/proxy_websockets_ssl.t @@ -0,0 +1,86 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestRequest; +use Apache::TestUtil; +use Apache::TestConfig (); + +# my @test_cases = ( "ping0", "ping1" x 10, "ping2" x 100, "ping3" x 1024, "ping4" x 4000, "sendquit"); +my @test_cases = ( "ping0", "ping1" x 10, "ping2" x 100, "ping3" x 1024, "sendquit"); +my $total_tests = 2; + +plan tests => $total_tests, need 'AnyEvent::WebSocket::Client', + need_module('ssl', 'proxy_http', 'lua'), need_min_apache_version('2.4.47'); + +require AnyEvent; +require AnyEvent::WebSocket::Client; + +my $config = Apache::Test::config(); +#my $hostport = $config->{vhosts}->{proxy_https_https}->{hostport}; +my $hostport = $config->{vhosts}->{$config->{vars}->{ssl_module_name}}->{hostport}; +my $client = AnyEvent::WebSocket::Client->new(timeout => 5, ssl_ca_file => $config->{vars}->{sslca} . "/" . $config->{vars}->{sslcaorg} . "/certs/ca.crt"); + +my $quit_program = AnyEvent->condvar; + +my $responses = 0; +my $surprised = 0; + +t_debug("wss://$hostport/modules/lua/websockets.lua"); + +# $client->connect("wss://$hostport/proxy/wsoc")->cb(sub { +$client->connect("wss://$hostport/modules/lua/websockets.lua")->cb(sub { + our $connection = eval { shift->recv }; + t_debug("wsoc connected"); + if($@) { + # handle error... + warn $@; + $quit_program->send(); + return; + } + + + # AnyEvent::WebSocket::Connection does not pass the PONG message down to the callback + # my $actualpingmsg = AnyEvent::WebSocket::Message->new(opcode => 0x09, body => "xxx"); + # $connection->send($actualpingmsg); + + foreach (@test_cases){ + $connection->send($_); + } + + $connection->on(finish => sub { + t_debug("finish"); + $quit_program->send(); + }); + + # recieve message from the websocket... + $connection->on(each_message => sub { + # $connection is the same connection object + # $message isa AnyEvent::WebSocket::Message + my($connection, $message) = @_; + $responses++; + t_debug("wsoc msg received: " . substr($message->body, 0, 5). " opcode " . $message->opcode); + if ("sendquit" eq $message->body) { + $connection->send('quit'); + t_debug("closing"); + $connection->close; # doesn't seem to close TCP. + $quit_program->send(); + } + elsif ($message->body =~ /^ping(\d)/) { + my $offset = $1; + if ($message->body ne $test_cases[$offset]) { + t_debug("wrong data"); + $surprised++; + } + } + else { + $surprised++; + } + }); + +}); + +$quit_program->recv; +ok t_cmp($surprised, 0); +# We don't expect the 20k over SSL to work, and we won't read the "sendquit" echoed back either. +ok t_cmp($responses, scalar(@test_cases)); diff --git a/debian/perl-framework/t/modules/rewrite.t b/debian/perl-framework/t/modules/rewrite.t index f566535..4673431 100644 --- a/debian/perl-framework/t/modules/rewrite.t +++ b/debian/perl-framework/t/modules/rewrite.t @@ -15,6 +15,49 @@ my @url = qw(forbidden gone perm temp); my @todo; my $r; +my @redirects_all = ( + ["/modules/rewrite/escaping/qsd-like/foo", "/foo\$", have_min_apache_version('2.4.57')], # PR66547 + ["/modules/rewrite/escaping/qsd-like-plus-qsa/foo?preserve-me", "/foo\\?preserve-me\$", have_min_apache_version('2.5.1')], # PR66672 + ["/modules/rewrite/escaping/qsd-like-plus-qsa-qsl/foo/%3fbar/?preserve-me", "/foo/%3fbar/\\?preserve-me\$", have_min_apache_version('2.5.1')], # PR66672 + ); + +my @escapes = ( + # rewrite to local/PT is not escaped + [ "/modules/rewrite/escaping/local/foo%20bar" => 403], + # rewrite to redir escape opted out + [ "/modules/rewrite/escaping/redir_ne/foo%20bar" => 403], + # rewrite never escapes proxy targets, even though [NE] is kind or repurposed. + [ "/modules/rewrite/escaping/proxy/foo%20bar" => 403], + [ "/modules/rewrite/escaping/proxy_ne/foo%20bar" => 403], + + [ "/modules/rewrite/escaping/fixups/local/foo%20bar" => 403], + [ "/modules/rewrite/escaping/fixups/redir_ne/foo%20bar" => 403], + [ "/modules/rewrite/escaping/fixups/proxy/foo%20bar" => 403], + [ "/modules/rewrite/escaping/fixups/proxy_ne/foo%20bar" => 403], +); +if (have_min_apache_version('2.4.57')) { + push(@escapes, ( + # rewrite to redir escaped by default + [ "/modules/rewrite/escaping/redir/foo%20bar" => 302], + [ "/modules/rewrite/escaping/fixups/redir/foo%20bar" => 302], + )); +} + +my @bflags = ( + # t/conf/extra.conf.in + [ "/modules/rewrite/escaping/local_b/foo/bar/%20baz%0d" => "foo%2fbar%2f+baz%0d"], # this is why [B] sucks + [ "/modules/rewrite/escaping/local_b_justslash/foo/bar/%20baz/" => "foo%2fbar%2f baz%2f"], # test basic B=/ +); +if (have_min_apache_version('2.4.57')) { + # [BCTLS] / [BNE] + push(@bflags, ( + [ "/modules/rewrite/escaping/local_bctls/foo/bar/%20baz/%0d" => "foo/bar/+baz/%0d"], # spaces and ctls only + [ "/modules/rewrite/escaping/local_bctls_nospace/foo/bar/%20baz/%0d" => "foo/bar/ baz/%0d"], # ctls but keep space + [ "/modules/rewrite/escaping/local_bctls_andslash/foo/bar/%20baz/%0d" => "foo%2fbar%2f+baz%2f%0d"], # not realistic, but opt in to slashes + [ "/modules/rewrite/escaping/local_b_noslash/foo/bar/%20baz/%0d" => "foo/bar/+baz/%0d"], # negate something from [B] + )); +} + if (!have_min_apache_version('2.4.19')) { # PR 50447, server context push @todo, 26 @@ -26,8 +69,11 @@ if (!have_min_apache_version('2.4')) { # Specific tests for PR 58231 my $vary_header_tests = (have_min_apache_version("2.4.30") ? 9 : 0) + (have_min_apache_version("2.4.29") ? 4 : 0); +my $cookie_tests = have_min_apache_version("2.4.47") ? 6 : 0; +my @redirects = map {$_->[2] ? $_ : ()} @redirects_all; -plan tests => @map * @num + 16 + $vary_header_tests, todo => \@todo, need_module 'rewrite'; +plan tests => @map * @num + 16 + $vary_header_tests + $cookie_tests + scalar(@escapes) + scalar(@redirects) + scalar(@bflags), + todo => \@todo, need_module 'rewrite'; foreach (@map) { foreach my $n (@num) { @@ -128,6 +174,7 @@ if (have_min_apache_version('2.4')) { if (have_min_apache_version("2.4.29")) { # PR 58231: Vary:Host header (was) mistakenly added to the response + # XXX: If LWP uses http2, this can result in "Host: localhost, test1" $r = GET("/modules/rewrite/vary1.html", "Host" => "test1"); ok t_cmp($r->content, qr/VARY2/, "Correct internal redirect happened, OK"); ok t_cmp($r->header("Vary"), qr/(?!.*Host.*)/, "Vary:Host header not added, OK"); @@ -168,3 +215,46 @@ if (have_min_apache_version("2.4.30")) { ok t_cmp($r->content, qr/VARY4/, "Correct internal redirect happened, OK"); ok t_cmp($r->header("Vary"), qr/(?!.*Host.*)/, "Vary:Host header not added, OK"); } + +if (have_min_apache_version("2.4.47")) { + $r = GET("/modules/rewrite/cookie/"); + ok t_cmp($r->header("Set-Cookie"), qr/(?!.*SameSite=.*)/, "samesite not present with no arg"); + $r = GET("/modules/rewrite/cookie/0"); + ok t_cmp($r->header("Set-Cookie"), qr/(?!.*SameSite=.*)/, "samesite not present with 0"); + $r = GET("/modules/rewrite/cookie/false"); + ok t_cmp($r->header("Set-Cookie"), qr/(?!.*SameSite=.*)/, "samesite not present with false"); + $r = GET("/modules/rewrite/cookie/none"); + ok t_cmp($r->header("Set-Cookie"), qr/SameSite=none/, "samesite=none"); + $r = GET("/modules/rewrite/cookie/lax"); + ok t_cmp($r->header("Set-Cookie"), qr/SameSite=lax/, "samesite=lax"); + $r = GET("/modules/rewrite/cookie/foo"); + ok t_cmp($r->header("Set-Cookie"), qr/SameSite=foo/, "samesite=foo"); +} + + +foreach my $t (@escapes) { + my $url= $t->[0]; + my $expect = $t->[1]; + t_debug "Check $url for $expect\n"; + $r = GET($url, redirect_ok => 0); + ok t_cmp $r->code, $expect; +} +foreach my $t (@bflags) { + my $url= $t->[0]; + my $expect= $t->[1]; + t_debug "Check $url for $expect\n"; + $r = GET($url, redirect_ok => 0); + t_debug("rewritten query '" . $r->header("rewritten-query") . "'"); + ok t_cmp $r->header("rewritten-query"), $expect; +} + +foreach my $t (@redirects) { + my $url= $t->[0]; + my $expect= $t->[1]; + t_debug "Check $url for redir $expect\n"; + $r = GET($url, redirect_ok => 0); + my $loc = $r->header("location"); + t_debug " redirect is $loc"; + ok $loc =~ /$expect/; +} + diff --git a/debian/perl-framework/t/modules/sed.t b/debian/perl-framework/t/modules/sed.t new file mode 100644 index 0000000..6ab1ee1 --- /dev/null +++ b/debian/perl-framework/t/modules/sed.t @@ -0,0 +1,48 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestRequest; +use Apache::TestUtil; + +my @ts = ( + # see t/conf/extra.conf.in + { url => "/apache/sed/out-foo/foobar.html", content => 'barbar', msg => "sed output filter", code => '200' }, + # error after status sent + { url => "/apache/sed-echo/out-foo-grow/foobar.html", content => "", msg => "sed output filter too large", code => '200', body=>"foo" x (8192*1024), resplen=>0}, + { url => "/apache/sed-echo/input", content => 'barbar', msg => "sed input filter", code => '200', body=>"foobar" }, + { url => "/apache/sed-echo/input", content => undef, msg => "sed input filter", code => '200', body=>"foo" x (1024)}, + # fixme: returns 400 default error doc for some people instead + # { url => "/apache/sed-echo/input", content => '!!!ERROR!!!', msg => "sed input filter", code => '200', skippable=>true body=>"foo" x (1024*4096)} +); + +my $tests = 2*scalar @ts; + +plan tests => $tests, need 'LWP::Protocol::AnyEvent::http', need_module('sed'); + +# Hack to allow streaming of data in/out of mod_echo +require LWP::Protocol::AnyEvent::http; + +for my $t (@ts) { + my $req; + if (defined($t->{'body'})) { + t_debug "posting body of size ". length($t->{'body'}); + $req = POST $t->{'url'}, content => $t->{'body'}; + t_debug "... posted body of size ". length($t->{'body'}); + } + else { + $req = GET $t->{'url'}; + } + t_debug "Content Length " . length $req->content; + ok t_cmp($req->code, $t->{'code'}, "status code for " . $t->{'url'}); + if (defined($t->{content})) { + my $content = $req->content; + chomp($content); + ok t_cmp($content, $t->{content}, $t->{msg}); + } + else { + ok "no body check"; + } +} + + diff --git a/debian/perl-framework/t/modules/session.t b/debian/perl-framework/t/modules/session.t index 91428fe..617239c 100644 --- a/debian/perl-framework/t/modules/session.t +++ b/debian/perl-framework/t/modules/session.t @@ -24,7 +24,7 @@ my @todo = ( ); # Until the fix for PR 57300 is backported, sessions are always saved. -if (!have_min_apache_version('2.5')) { +if (!have_min_apache_version('2.4.41')) { my @todo_backport = ( 8, 18, 38, 43, 48, 58, 63, 133 ); push(@todo, @todo_backport); } @@ -172,8 +172,8 @@ check_get 'Keep non-expired session', check_post 'Session writable after expired', '/on/expire?expiry=1', $create_session, $session, 1, 1; -# SessionExpiryUpdateInterval directive - new in 2.5 -if (have_module('version') && have_min_apache_version('2.5')) { +# SessionExpiryUpdateInterval directive - new in 2.4.41 +if (have_module('version') && have_min_apache_version('2.4.41')) { my $max_expiry = expiry_from_seconds(time() + 100); my $threshold_expiry = expiry_from_seconds(time() + 40); diff --git a/debian/perl-framework/t/modules/setenvif.t b/debian/perl-framework/t/modules/setenvif.t index 82c4bf4..cb561c2 100644 --- a/debian/perl-framework/t/modules/setenvif.t +++ b/debian/perl-framework/t/modules/setenvif.t @@ -167,10 +167,16 @@ write_htaccess("SetEnvIfExpr \"%{REQUEST_URI} =~ /\.\(sh\)tmlXXX\$/\" VAR_ONE=\$ $body = GET_BODY $page; ok t_cmp($body, "1:(none)\n2:(none)\n3:(none)\n"); -## test SetEnvIfExpr with replacement when regex is REQUIRED to NOT match ## -write_htaccess("SetEnvIfExpr \"%{REQUEST_URI} !~ /\.\(sh\)tmlXXX\$/\" VAR_ONE=\$0 VAR_TWO=\$1"); -$body = GET_BODY $page; -ok t_cmp($body, "1:\$0\n2:\$1\n3:(none)\n"); +if (need_min_apache_version("2.4.38")) { + ## test SetEnvIfExpr with replacement when regex is REQUIRED to NOT match ## + write_htaccess("SetEnvIfExpr \"%{REQUEST_URI} !~ /\.\(sh\)tmlXXX\$/\" VAR_ONE=\$0 VAR_TWO=\$1"); + $body = GET_BODY $page; + ok t_cmp($body, "1:\$0\n2:\$1\n3:(none)\n"); +} +else { + # Skip for versions without r1786235 backported + skip "skipping inverted match test with version <2.4.38" +} ## i think this should work, but it doesnt. ## leaving it commented now pending investigation. diff --git a/debian/perl-framework/t/modules/speling.t b/debian/perl-framework/t/modules/speling.t index 25eb54e..85af159 100644 --- a/debian/perl-framework/t/modules/speling.t +++ b/debian/perl-framework/t/modules/speling.t @@ -2,8 +2,8 @@ use strict; use warnings FATAL => 'all'; use Apache::Test; -use Apache::TestUtil; use Apache::TestRequest; +use Apache::TestUtil; my @testcasespaths = ( ['/modules/speling/nocase/'], @@ -17,7 +17,6 @@ my @testcases = ( ['goood.html', "insertion", 301, 404], ['godo.html', "transposition", 301, 404], ['go_d.html', "wrong character", 301, 404], - ['GOOD.html', "case", 301, 301], ['good.wrong_ext', "wrong extension", 300, 300], ['GOOD.wrong_ext', "NC wrong extension", 300, 300], @@ -26,9 +25,15 @@ my @testcases = ( ['dogo.html', "double transposition", 404, 404], ['XooX.html', "double wrong character", 404, 404], - ['several0.html', "multiple choise", 300, 404], + ['several0.html', "multiple choice", 300, 404], ); +# macOS HFS is case-insensitive but case-preserving so the below tests +# would cause misleading failures +if ($^O ne "darwin") { + push (@testcases, ['GOOD.html', "case", 301, 301]); +} + plan tests => scalar @testcasespaths * scalar @testcases * 2, need 'mod_speling'; my $r; @@ -40,6 +45,7 @@ local $Apache::TestRequest::RedirectOK = 0; foreach my $p (@testcasespaths) { foreach my $t (@testcases) { ## + #local $Apache::TestRequest::RedirectOK = 0; $r = GET($p->[0] . $t->[0]); # Checking for return code diff --git a/debian/perl-framework/t/modules/substitute.t b/debian/perl-framework/t/modules/substitute.t index cc8c153..0f111c0 100644 --- a/debian/perl-framework/t/modules/substitute.t +++ b/debian/perl-framework/t/modules/substitute.t @@ -15,6 +15,8 @@ my $B = chr(0x02); my $F = chr(0x06); my $P = chr(0x10); +my @simple_cases = (); + my @test_cases = ( [ "f${B}o${P}ofoo" => 's/foo/bar/' ], [ "f${B}o${P}ofoo" => 's/fo/fa/', 's/fao/bar/' ], @@ -40,7 +42,10 @@ if (have_min_apache_version("2.3.5")) { [ "foobar" => 's/(oo)b/\d$1/' ]; } -plan tests => scalar @test_cases, +if (have_min_apache_version("2.4.42")) { + push @simple_cases, [ "foo\nbar" => 's/foo.*/XXX$0XXX', "XXXfooXXX\nbar" ], +} +plan tests => scalar @test_cases + scalar @simple_cases, need need_lwp, need_module('mod_substitute'), need_module('mod_bucketeer'); @@ -84,6 +89,18 @@ foreach my $t (@test_cases) { ok($ok); } +foreach my $t (@simple_cases) { + my ($content, $rule, $expect) = @{$t}; + write_testfile($content); + write_htaccess($rule); + my $response = GET('/modules/substitute/test.txt'); + my $rc = $response->code; + my $got = $response->content; + my $ok = ($rc == 200) && ($got eq $expect); + print "got $rc '$got'", ($ok ? ": OK\n" : ", expected '$expect'\n"); + + ok($ok); +} exit 0; ### sub routines diff --git a/debian/perl-framework/t/modules/usertrack.t b/debian/perl-framework/t/modules/usertrack.t index 449d5b5..d9f62da 100644 --- a/debian/perl-framework/t/modules/usertrack.t +++ b/debian/perl-framework/t/modules/usertrack.t @@ -15,7 +15,7 @@ my @testcases = ( my $iters = 100; my %cookiex = (); -plan tests => (scalar (@testcases) * 2 + 2) * $iters + 1, need 'mod_usertrack'; +plan tests => (scalar (@testcases) * 2 + 2) * $iters + 1 + 3, need 'mod_usertrack'; foreach (1..$iters) { my $nb_req = 1; @@ -60,3 +60,15 @@ foreach (1..$iters) { # Check the overall number of cookies generated ok ((scalar (keys %cookiex)) == ($iters * 2)); + +# Check that opt-in flags aren't set +my $r = GET("/modules/usertrack/foo.html"); +ok t_cmp($r->code, 200, "Checking return code is '200'"); +# Checking for content +my $setcookie = $r->header('Set-Cookie'); +t_debug("$setcookie"); +ok defined $setcookie; +$setcookie =~ m/(Secure|HTTPonly|SameSite)/i; +ok t_cmp($1, undef); + + |