diff options
Diffstat (limited to 'debian/perl-framework/t/apache')
41 files changed, 3248 insertions, 0 deletions
diff --git a/debian/perl-framework/t/apache/404.t b/debian/perl-framework/t/apache/404.t new file mode 100644 index 0000000..83e9c06 --- /dev/null +++ b/debian/perl-framework/t/apache/404.t @@ -0,0 +1,16 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestRequest; + +plan tests => 2; + +my $four_oh_four = GET_STR "/404/not/found/test"; + +print "# GET_STR Response:\n# ", + join("\n# ", split(/\n/, $four_oh_four)), "\n"; + +ok (($four_oh_four =~ /HTTP\/1\.[01] 404 Not Found/) + || ($four_oh_four =~ /RC:\s+404.*Message:\s+Not Found/s)); +ok ($four_oh_four =~ /Content-Type: text\/html/); diff --git a/debian/perl-framework/t/apache/acceptpathinfo.t b/debian/perl-framework/t/apache/acceptpathinfo.t new file mode 100644 index 0000000..b42093c --- /dev/null +++ b/debian/perl-framework/t/apache/acceptpathinfo.t @@ -0,0 +1,86 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestRequest; +use Apache::TestUtil; + +my $havecgi = have_cgi(); + +my $pathinfo = "/foo/bar"; + +## +## mode path, filerc, filebody, cgirc, cgibody +## +my %tests = ( + default => [ "", "404","Not Found", "200","_${pathinfo}_" ], + on => [ "/on", "200","_${pathinfo}_","200","_${pathinfo}_" ], + off => [ "/off","404","Not Found", "404","Not Found" ] + ); + + +my @files = ("", "/index.shtml"); +push @files, "/test.sh" if ($havecgi); + +my $numtests = ((scalar keys %tests) * (scalar @files) * 4); +plan tests => $numtests, need need_apache(2), need_module('include'), need_lwp; + +my $loc = "/apache/acceptpathinfo"; + +foreach my $mode (keys %tests) { + foreach my $file (@files) { + + foreach my $pinf ("","$pathinfo") { + + my ($expectedrc, $expectedbody); + + if ($pinf eq "") { + $expectedrc = "200"; + $expectedbody = "_\\(none\\)_"; + } + else { + if ($file eq "") { + $expectedrc = "404"; + $expectedbody = "Not Found"; + } + elsif ($file eq "/index.shtml") { + $expectedrc = $tests{$mode}[1]; + $expectedbody = $tests{$mode}[2]; + } + else { + $expectedrc = $tests{$mode}[3]; + $expectedbody = $tests{$mode}[4]; + } + } + + + my $req = $loc.$tests{$mode}[0].$file.$pinf; + + my $resp = GET $req; + + ok t_cmp($resp->code, + $expectedrc, + "AcceptPathInfo $mode return code for $req" + ); + + my $actual = super_chomp($resp->content); + ok t_cmp($actual, + qr/$expectedbody/, + "AcceptPathInfo $mode body for $req" + ); + } + } +} + +sub super_chomp { + my ($body) = shift; + + ## super chomp - all leading and trailing \n (and \r for win32) + $body =~ s/^[\n\r]*//; + $body =~ s/[\n\r]*$//; + ## and all the rest change to spaces + $body =~ s/\n/ /g; + $body =~ s/\r//g; #rip out all remaining \r's + + $body; +} diff --git a/debian/perl-framework/t/apache/byterange.t b/debian/perl-framework/t/apache/byterange.t new file mode 100644 index 0000000..e439d1d --- /dev/null +++ b/debian/perl-framework/t/apache/byterange.t @@ -0,0 +1,57 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestRequest (); +use Apache::TestCommon (); + +Apache::TestCommon::run_files_test(\&verify, 1); + +sub verify { + my($ua, $url, $file) = @_; + my $debug = $Apache::TestRequest::DebugLWP; + + $url = Apache::TestRequest::resolve_url($url); + my $req = HTTP::Request->new(GET => $url); + + my $total = 0; + my $chunk_size = 8192; + + my $wanted = -s $file; + + while ($total < $wanted) { + my $end = $total + $chunk_size; + if ($end > $wanted) { + $end = $wanted; + } + + my $range = "bytes=$total-$end"; + $req->header(Range => $range); + + print $req->as_string if $debug; + + my $res = $ua->request($req); + my $content_range = $res->header('Content-Range') || 'NONE'; + + $res->content("") if $debug and $debug == 1; + print $res->as_string if $debug; + + if ($content_range =~ m:^bytes\s+(\d+)-(\d+)/(\d+):) { + my($start, $end, $total_bytes) = ($1, $2, $3); + $total += ($end - $start) + 1; + } + elsif ($total == 0 && $end == $wanted && + $content_range eq 'NONE' && $res->code == 200) { + $total += $wanted; + } + else { + print "Range: $range\n"; + print "Content-Range: $content_range\n"; + last; + } + } + + print "downloaded $total bytes, file is $wanted bytes\n"; + + ok $total == $wanted; +} diff --git a/debian/perl-framework/t/apache/byterange2.t b/debian/perl-framework/t/apache/byterange2.t new file mode 100644 index 0000000..f0dcc1e --- /dev/null +++ b/debian/perl-framework/t/apache/byterange2.t @@ -0,0 +1,15 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestUtil; +use Apache::TestRequest; + +plan tests => 1, need need_min_apache_version('2.0.51'), need_cgi; + +my $resp; + +$resp = GET_BODY "/modules/cgi/ranged.pl", + Range => 'bytes=5-10/10'; + +ok t_cmp($resp, "hello\n", "return correct content"); diff --git a/debian/perl-framework/t/apache/byterange3.t b/debian/perl-framework/t/apache/byterange3.t new file mode 100644 index 0000000..56932f1 --- /dev/null +++ b/debian/perl-framework/t/apache/byterange3.t @@ -0,0 +1,73 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestRequest (); +use Apache::TestCommon (); + +# test merging of byte ranges + +if (Apache::Test::need_min_apache_version("2.3.15")) { + Apache::TestCommon::run_files_test(\&verify, 1); +} +else { + plan tests => 0; +} + +sub verify { + my($ua, $url, $file) = @_; + my $debug = $Apache::TestRequest::DebugLWP; + + $url = Apache::TestRequest::resolve_url($url); + my $req = HTTP::Request->new(GET => $url); + + my $total = 0; + my $chunk_size = 8192; + + my $wanted = -s $file; + + while ($total < $wanted) { + my $end = $total + $chunk_size; + if ($end > $wanted) { + $end = $wanted; + } + + my $t1 = $total+1; + my $t10 = $total+5; + my $e1 = $end-1; + my $e20 = $end-10; + #my $range = "bytes=$total-$end"; + my $range = "bytes=$t10-$end,$total-$e1,$t10-$e20,$total-$e1"; + if ($end - $total < 15) { + # make sure to not send invalid ranges with start > end + $range = "bytes=$total-$end"; + } + $req->header(Range => $range); + + print $req->as_string if $debug; + + my $res = $ua->request($req); + my $content_range = $res->header('Content-Range') || 'NONE'; + + $res->content("") if $debug and $debug == 1; + print $res->as_string if $debug; + + if ($content_range =~ m:^bytes\s+(\d+)-(\d+)/(\d+):) { + my($start, $end, $total_bytes) = ($1, $2, $3); + $total += ($end - $start) + 1; + } + elsif ($total == 0 && $end == $wanted && + $content_range eq 'NONE' && $res->code == 200) { + $total += $wanted; + } + else { + print "Range: $range\n"; + print "Content-Range: $content_range\n"; + last; + } + } + + print "downloaded $total bytes, file is $wanted bytes\n"; + + ok $total == $wanted; +} diff --git a/debian/perl-framework/t/apache/byterange4.t b/debian/perl-framework/t/apache/byterange4.t new file mode 100644 index 0000000..73572d7 --- /dev/null +++ b/debian/perl-framework/t/apache/byterange4.t @@ -0,0 +1,52 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestRequest; +use Apache::TestUtil qw(t_write_file); + +# test byteranges if range boundaries are near bucket boundaries + +my $url = "/apache/chunked/byteranges.txt"; +my $file = Apache::Test::vars('serverroot') . "/htdocs$url"; + +my $content = ""; +$content .= sprintf("%04d", $_) for (1 .. 2000); +my $clen = length($content); + +# make mod_bucketeer create buckets of size 200 from our 4000 bytes +my $blen = 200; +my $B = chr(0x02); +my @buckets = ($content =~ /(.{1,$blen})/g); +my $file_content = join($B, @buckets); +t_write_file($file, $file_content); + + +my @range_boundaries = ( + 0, 1, 2, + $blen-2, $blen-1, $blen, $blen+1, + 3*$blen-2, 3*$blen-1, 3*$blen, 3*$blen+1, + $clen-$blen-2, $clen-$blen-1, $clen-$blen, $clen-$blen+1, + $clen-2, $clen-1, +); +my @test_cases; +for my $start (@range_boundaries) { + for my $end (@range_boundaries) { + push @test_cases, [$start, $end] unless ($end < $start); + } +} + +plan tests => scalar(@test_cases), need need_lwp, + need_module('mod_bucketeer'); + +foreach my $test (@test_cases) { + my ($start, $end) = @$test; + my $r = "$start-$end"; + print "range: $r\n"; + my $result = GET $url, "Range" => "bytes=$r"; + my $expect = substr($content, $start, $end - $start + 1); + my $got = $result->content; + print("rc " . $result->code . "\n"); + print("expect: '$expect'\ngot: '$got'\n"); + ok ($got eq $expect); +} diff --git a/debian/perl-framework/t/apache/byterange5.t b/debian/perl-framework/t/apache/byterange5.t new file mode 100644 index 0000000..d069946 --- /dev/null +++ b/debian/perl-framework/t/apache/byterange5.t @@ -0,0 +1,104 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestRequest; +use Apache::TestUtil qw(t_write_file); + +# test multi-byterange-requests while allowing re-ordering + +my $url = "/apache/chunked/byteranges.txt"; +my $file = Apache::Test::vars('serverroot') . "/htdocs$url"; + +my $content = ""; +$content .= sprintf("%04d", $_) for (1 .. 2000); +t_write_file($file, $content); +my $clen = length($content); + + +my @test_cases = ( + "0-1,1000-1001", + "1000-1100,100-200", + "1000-1100,100-200,2000-2200", + "1000-1100,100-200,2000-", + "3000-,100-200,2000-2200", +); +plan tests => scalar(@test_cases), need need_lwp; + +foreach my $test (@test_cases) { + my $result = GET $url, "Range" => "bytes=$test"; + my $boundary; + my $ctype = $result->header("Content-Type"); + if ($ctype =~ m{multipart/byteranges; boundary=(.*)}) { + $boundary = $1; + } + else { + print "Wrong Content-Type: $ctype\n"; + ok(0); + next; + } + + my @want = split(",", $test); + foreach my $w (@want) { + $w =~ /(\d*)-(\d*)/ or die; + if (defined $1 eq "") { + $w = [ $clen - $2, $clen - 1 ]; + } + elsif ($2 eq "") { + $w = [ $1, $clen - 1 ]; + } + else { + $w = [ $1, $2 ]; + } + } + + my @got; + my $rcontent = $result->content; + my $error; + while ($rcontent =~ s{^[\n\s]*--$boundary\s*?\n(.+?)\r\n\r\n}{}s ) { + my $headers = $1; + my ($from, $to); + if ($headers =~ m{^Content-range: bytes (\d+)-(\d+)/\d*$}mi ) { + $from = $1; + $to = $2; + } + else { + print "Can't parse Content-range in '$headers'\n"; + $error = 1; + } + push @got, [$from, $to]; + my $chunk = substr($rcontent, 0, $to - $from + 1, ""); + my $expect = substr($content, $from, $to - $from + 1); + if ($chunk ne $expect) { + print "Wrong content in range. Got: \n", + $headers, $content, + "Expected:\n$expect\n"; + $error = 1; + } + } + if ($error) { + ok(0); + next; + } + if ($rcontent !~ /^[\s\n]*--${boundary}--[\s\n]*$/) { + print "error parsing final boundary: '$rcontent'\n"; + ok(0); + next; + } + foreach my $w (@want) { + my $found; + foreach my $g (@got) { + $found = 1 if ($g->[0] <= $w->[0] && $g->[1] >= $w->[1]); + } + if (!$found) { + print "Data for '$w->[0]-$w->[1]' not found in response\n"; + $error = 1; + } + } + if ($error) { + ok(0); + next; + } + + ok (1); +} diff --git a/debian/perl-framework/t/apache/byterange6.t b/debian/perl-framework/t/apache/byterange6.t new file mode 100644 index 0000000..5fae418 --- /dev/null +++ b/debian/perl-framework/t/apache/byterange6.t @@ -0,0 +1,162 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestRequest; +use Apache::TestUtil qw(t_write_file t_debug); + +# test multi-byterange-requests with overlaps (merges) + +my $url = "/apache/chunked/byteranges.txt"; +my $file = Apache::Test::vars('serverroot') . "/htdocs$url"; + +my $content = ""; +$content .= sprintf("%04d", $_) for (1 .. 2000); +t_write_file($file, $content); +my $clen = length($content); + + +my @test_cases = ( + { h => "0-100,70-100,1000-1001", actlike => "0-100,1000-1001"}, + { h => "0-90,70-100,1000-1001", actlike => "0-100,1000-1001"}, + { h => "0-70,70-100,1000-1001", actlike => "0-100,1000-1001"}, + { h => "1-100,70-100,1000-1001", actlike => "1-100,1000-1001"}, + { h => "1-90,70-100,1000-1001", actlike => "1-100,1000-1001"}, + { h => "1-90,70-100,1000-1001", actlike => "1-100,1000-1001"}, + { h => "0-100,70-100,1000-1001,5-6", actlike => "0-100,1000-1001,5-6"}, + { h => "0-90,70-100,1000-1001,5-6", actlike => "0-100,1000-1001,5-6"}, + { h => "0-70,70-100,1000-1001,5-6", actlike => "0-100,1000-1001,5-6"}, + { h => "1-100,70-100,1000-1001,5-6", actlike => "1-100,1000-1001,5-6"}, + + { h => "1-90,70-100,1000-1001,5-6", actlike => "1-100,1000-1001,5-6"}, + { h => "1-90,70-100,1000-1001,5-6", actlike => "1-100,1000-1001,5-6"}, + { h => "1-70,70-100,1000-1001", actlike => "1-100,1000-1001"}, + { h => "1-70,71-100,1000-1001", actlike => "1-100,1000-1001"}, + { h => "1-70,69-100,1000-1001", actlike => "1-100,1000-1001"}, + { h => "1-70,0-100,1000-1001", actlike => "1-100,1000-1001"}, + { h => "0-70,72-100,1000-1001", actlike => "0-70,72-100,1000-1001"}, + { h => "1-70,0-100,1000-1001", actlike => "0-100,1000-1001"}, + { h => "1-70,1-100,1000-1001", actlike => "1-100,1000-1001"}, + { h => "1-70,2-100,1000-1001", actlike => "1-100,1000-1001"}, + + { h => "0-100,0-99,1000-1001", actlike => "0-100,1000-1001"}, + { h => "0-100,0-100,1000-1001", actlike => "0-100,1000-1001"}, + { h => "0-100,0-101,1000-1001", actlike => "0-101,1000-1001"}, + { h => "0-100,1-99,1000-1001", actlike => "0-100,1000-1001"}, + { h => "0-100,1-100,1000-1001", actlike => "0-100,1000-1001"}, + { h => "0-100,1-101,1000-1001", actlike => "0-101,1000-1001"}, + { h => "0-100,50-99,1000-1001", actlike => "0-100,1000-1001"}, + { h => "0-100,50-100,1000-1001", actlike => "0-100,1000-1001"}, + { h => "0-100,50-101,1000-1001", actlike => "0-101,1000-1001"}, + { h => "1-10,1-9,99-99", actlike => "1-10,99-99"}, + + { h => "1-10,1-10,99-99", actlike => "1-10,99-99"}, + { h => "1-10,1-11,99-99", actlike => "1-11,99-99"}, + { h => "1-10,0-9,99-99", actlike => "0-10,99-99"}, + { h => "1-10,0-10,99-99", actlike => "0-10,99-99"}, + { h => "1-10,0-11,99-99", actlike => "0-11,99-99"}, + { h => "1-10,0-12,99-99", actlike => "0-12,99-99"}, + { h => "1-10,0-13,99-99", actlike => "0-13,99-99"}, + { h => "1-10,2-11,99-99", actlike => "1-11,99-99"}, + { h => "1-10,2-12,99-99", actlike => "1-12,99-99"}, + { h => "1-10,2-13,99-99", actlike => "1-13,99-99"}, + + { h => "1-10,1-9,99-99", actlike => "1-10,99-99"}, + { h => "1-11,1-10,99-99", actlike => "1-11,99-99"}, + { h => "1-9,1-10,99-99", actlike => "1-10,99-99"}, + { h => "0-11,1-10,99-99", actlike => "0-11,99-99"}, + { h => "1-9,1-10,99-99", actlike => "1-10,99-99"}, + { h => "10-20,1-9,99-99", actlike => "1-20,99-99"}, + { h => "10-20,1-10,99-99", actlike => "1-20,99-99"}, + { h => "10-20,1-11,99-99", actlike => "1-20,99-99"}, + { h => "10-20,1-21,99-99", actlike => "1-21,99-99"}, + + { h => "5-10,11-12,99-99", actlike => "5-12,99-99"}, + { h => "5-10,1-4,99-99", actlike => "1-10,99-99"}, + { h => "5-10,1-3,99-99", actlike => "5-10,1-3,99-99"}, + + { h => "0-1,-1", actlike => "0-1,-1"}, # PR 51748 + +); +plan tests => scalar(@test_cases), need need_lwp, + need_min_apache_version('2.3.15'); + + +foreach my $test (@test_cases) { + my $result = GET $url, "Range" => "bytes=" . $test->{"h"} ; + my $boundary; + my $ctype = $result->header("Content-Type"); + if ($ctype =~ m{multipart/byteranges; boundary=(.*)}) { + $boundary = $1; + } + else { + print "Wrong Content-Type: $ctype, for ".$test->{"h"}."\n"; + ok(0); + next; + } + + my @want = split(",", $test->{"actlike"}); + foreach my $w (@want) { + $w =~ /(\d*)-(\d*)/ or die; + if ($1 eq "") { + $w = [ $clen - $2, $clen - 1 ]; + } + elsif ($2 eq "") { + $w = [ $1, $clen - 1 ]; + } + else { + $w = [ $1, $2 ]; + } + t_debug("expecting range ". $w->[0]. "-". $w->[1]); + } + + my @got; + my $rcontent = $result->content; + my $error; + while ($rcontent =~ s{^[\n\s]*--$boundary\s*?\n(.+?)\r\n\r\n}{}s ) { + my $headers = $1; + my ($from, $to); + if ($headers =~ m{^Content-range: bytes (\d+)-(\d+)/\d*$}mi ) { + $from = $1; + $to = $2; + } + else { + print "Can't parse Content-range in '$headers'\n"; + $error = 1; + } + push @got, [$from, $to]; + my $chunk = substr($rcontent, 0, $to - $from + 1, ""); + my $expect = substr($content, $from, $to - $from + 1); + if ($chunk ne $expect) { + print "Wrong content in range. Got: \n", + $headers, $content, + "Expected:\n$expect\n"; + $error = 1; + } + } + if ($error) { + ok(0); + next; + } + if ($rcontent !~ /^[\s\n]*--${boundary}--[\s\n]*$/) { + print "error parsing final boundary: '$rcontent'\n"; + ok(0); + next; + } + foreach my $w (@want) { + my $found; + foreach my $g (@got) { + $found = 1 if ($g->[0] <= $w->[0] && $g->[1] >= $w->[1]); + } + if (!$found) { + print "Data for '$w->[0]-$w->[1]' not found in response\n" . $result->content. "\n"; + $error = 1; + } + } + if ($error) { + ok(0); + next; + } + + ok (1); +} diff --git a/debian/perl-framework/t/apache/byterange7.t b/debian/perl-framework/t/apache/byterange7.t new file mode 100644 index 0000000..513dfa9 --- /dev/null +++ b/debian/perl-framework/t/apache/byterange7.t @@ -0,0 +1,119 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestRequest; +use Apache::TestUtil qw(t_write_file); + +# test content-length header in byterange-requests +# test invalid range headers + +my $url = "/apache/chunked/byteranges.txt"; +my $file = Apache::Test::vars('serverroot') . "/htdocs$url"; + +my $content = ""; +$content .= sprintf("%04d", $_) for (1 .. 10000); +t_write_file($file, $content); +my $real_clen = length($content); + + +# +# test cases +# + +# check content-length for (multi-)range responses +my @tc_ranges_cl = ( 1, 2, 10, 50, 100); +# send 200 response if range invalid +my @tc_invalid = ("", ",", "7-1", "foo", "1-4,x", "1-4,5-2", + "100000-110000,5-2"); +# send 416 if no range satisfiable +my %tc_416 = ( + "100000-110000" => 416, + "100000-110000,200000-" => 416, + "1000-200000" => 206, # should be truncated until end + "100000-110000,1000-2000" => 206, # should ignore unsatifiable range + "100000-110000,2000-1000" => 200, # invalid, should ignore whole header + ); + +plan tests => scalar(@tc_ranges_cl) + + 2 * scalar(@tc_invalid) + + scalar(keys %tc_416), + need need_lwp; + +foreach my $num (@tc_ranges_cl) { + my @ranges; + foreach my $i (0 .. ($num-1)) { + push @ranges, sprintf("%d-%d", $i * 100, $i * 100 + 1); + } + my $range = join(",", @ranges); + my $result = GET $url, "Range" => "bytes=$range"; + print_result($result); + if ($result->code != 206) { + print "did not get 206\n"; + ok(0); + next; + } + my $clen = $result->header("Content-Length"); + my $body = $result->content; + my $blen = length($body); + if ($blen == $real_clen) { + print "Did get full content, should have gotten only parts\n"; + ok(0); + next; + } + print "body length $blen\n"; + if (defined $clen) { + print "Content-Length: $clen\n"; + if ($blen != $clen) { + print "Content-Length does not match body\n"; + ok(0); + next; + } + } + ok(1); +} + +# test invalid range headers, with and without "bytes=" +my @tc_invalid2 = map { "bytes=" . $_ } @tc_invalid; +foreach my $range (@tc_invalid, @tc_invalid2) { + my $result = GET $url, "Range" => "$range"; + print_result($result); + my $code = $result->code; + if ($code == 206) { + print "got partial content response with invalid range header '$range'\n"; + ok(0); + } + elsif ($code == 200) { + my $body = $result->content; + if ($body != $content) { + print "Body did not match expected content\n"; + ok(0); + } + ok(1); + } + else { + print "Huh?\n"; + ok(0); + } +} + +# test unsatisfiable ranges headers +foreach my $range (sort keys %tc_416) { + print "Sending '$range', expecting $tc_416{$range}\n"; + my $result = GET $url, "Range" => "bytes=$range"; + print_result($result); + ok($result->code == $tc_416{$range}); +} + +sub print_result +{ + my $result = shift; + my $code = $result->code; + my $cr = $result->header("Content-Range"); + my $ct = $result->header("Content-Type"); + my $msg = "Got $code"; + $msg .= " multipart/byteranges" + if (defined $ct && $ct =~ m{^multipart/byteranges}); + $msg .= " Range: '$cr'" if defined $cr; + print "$msg\n"; +} diff --git a/debian/perl-framework/t/apache/cfg_getline.t b/debian/perl-framework/t/apache/cfg_getline.t new file mode 100644 index 0000000..08f0231 --- /dev/null +++ b/debian/perl-framework/t/apache/cfg_getline.t @@ -0,0 +1,46 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestRequest; +use Apache::TestUtil qw(t_write_file); + +use File::Spec; + +# test ap_cfg_getline / ap_varbuf_cfg_getline + +Apache::TestRequest::user_agent(keep_alive => 1); + +my $dir_foo = Apache::Test::vars('serverroot') . '/htdocs/cfg_getline'; + +# XXX: htaccess is limited to 8190 chars, would need different test +# XXX: method to test longer lines +my @test_cases = (100, 196 .. 202, 396 .. 402 , 596 .. 602 , 1016 .. 1030, + 8170 .. 8190); +plan tests => 2 * scalar(@test_cases), need need_lwp, + need_module('mod_include'), + need_module('mod_setenvif'); + +foreach my $len (@test_cases) { + my $prefix = 'SetEnvIf User-Agent ^ testvar='; + my $expect = 'a' x ($len - length($prefix)); + my $file = File::Spec->catfile(Apache::Test::vars('serverroot'), 'htdocs', + 'apache', 'cfg_getline', '.htaccess'); + t_write_file($file, "$prefix$expect\n"); + + my $response = GET('/apache/cfg_getline/index.shtml'); + my $rc = $response->code; + print "Got rc $rc for length $len\n"; + ok($rc == 200); + + my $got = $response->content; + my $match; + if ($got =~ /^'$expect'/) { + $match = 1; + } + else { + print "Got $got\n", + "expected '$expect'\n"; + } + ok($match); +} diff --git a/debian/perl-framework/t/apache/chunkinput.t b/debian/perl-framework/t/apache/chunkinput.t new file mode 100644 index 0000000..2538585 --- /dev/null +++ b/debian/perl-framework/t/apache/chunkinput.t @@ -0,0 +1,93 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestUtil; +use Apache::TestRequest (); + +my @test_strings = ("0", + "A\r\n1234567890\r\n0", + "A; ext=val\r\n1234567890\r\n0", + "A \r\n1234567890\r\n0", # <10 BWS + "A :: :: :: \r\n1234567890\r\n0", # <10 BWS multiple send + "A \r\n1234567890\r\n0", # >10 BWS + "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA\r\n", + "A; ext=\x7Fval\r\n1234567890\r\n0", + " A", + ); +my @req_strings = ("/echo_post_chunk", + "/i_do_not_exist_in_your_wildest_imagination"); + +# This is expanded out as these results... +my @resp_strings = ("HTTP/1.1 200 OK", # "0" + "HTTP/1.1 404 Not Found", + "HTTP/1.1 200 OK", # "A" + "HTTP/1.1 404 Not Found", + "HTTP/1.1 200 OK", # "A; ext=val" + "HTTP/1.1 404 Not Found", + "HTTP/1.1 200 OK", # "A " + "HTTP/1.1 404 Not Found", + "HTTP/1.1 200 OK", # "A " + " " + " " + " " pkts + "HTTP/1.1 404 Not Found", + "HTTP/1.1 400 Bad Request", # >10 BWS + "HTTP/1.1 400 Bad Request", + "HTTP/1.1 413 Request Entity Too Large", # Overflow size + "HTTP/1.1 413 Request Entity Too Large", + "HTTP/1.1 400 Bad Request", # Ctrl in data + "HTTP/1.1 400 Bad Request", + "HTTP/1.1 400 Bad Request", # Invalid LWS + "HTTP/1.1 400 Bad Request", + ); + +my $tests = 4 * @test_strings + 1; +my $vars = Apache::Test::vars(); +my $module = 'default'; +my $cycle = 0; + +plan tests => $tests, ['echo_post_chunk']; + +print "testing $module\n"; + +for my $data (@test_strings) { + for my $request_uri (@req_strings) { + my $sock = Apache::TestRequest::vhost_socket($module); + ok $sock; + + Apache::TestRequest::socket_trace($sock); + + my @elts = split("::", $data); + + $sock->print("POST $request_uri HTTP/1.0\r\n"); + $sock->print("Transfer-Encoding: chunked\r\n"); + $sock->print("\r\n"); + if (@elts > 1) { + for my $elt (@elts) { + $sock->print("$elt"); + sleep 0.5; + } + $sock->print("\r\n"); + } + else { + $sock->print("$data\r\n"); + } + $sock->print("X-Chunk-Trailer: $$\r\n"); + $sock->print("\r\n"); + + #Read the status line + chomp(my $response = Apache::TestRequest::getline($sock)); + $response =~ s/\s$//; + ok t_cmp($response, $resp_strings[$cycle++], "response codes"); + + do { + chomp($response = Apache::TestRequest::getline($sock)); + $response =~ s/\s$//; + } + while ($response ne ""); + + if ($cycle == 1) { + $response = Apache::TestRequest::getline($sock); + chomp($response) if (defined($response)); + ok t_cmp($response, "$$", "trailer (pid)"); + } + } +} diff --git a/debian/perl-framework/t/apache/contentlength.t b/debian/perl-framework/t/apache/contentlength.t new file mode 100644 index 0000000..f141990 --- /dev/null +++ b/debian/perl-framework/t/apache/contentlength.t @@ -0,0 +1,83 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestUtil; +use Apache::TestRequest (); + +my @test_strings = ("", + "0", + "0000000000000000000000000000000000", + "1000000000000000000000000000000000", + "-1", + "123abc", + ); +my @req_strings = ("/echo_post", + "/i_do_not_exist_in_your_wildest_imagination"); + +my $resp_failure; +if (have_min_apache_version('2.2.30') + && (!have_min_apache_version('2.3.0') + || have_min_apache_version('2.4.14'))) { + $resp_failure = "HTTP/1.1 400 Bad Request"; +} +else { + $resp_failure = "HTTP/1.1 413 Request Entity Too Large"; +} +# This is expanded out. +my @resp_strings = ($resp_failure, + $resp_failure, + "HTTP/1.1 200 OK", + "HTTP/1.1 404 Not Found", + "HTTP/1.1 200 OK", + "HTTP/1.1 404 Not Found", + $resp_failure, + $resp_failure, + $resp_failure, + $resp_failure, + $resp_failure, + $resp_failure, + ); + +my $tests = 4 * @test_strings; +my $vars = Apache::Test::vars(); +my $module = 'default'; +my $cycle = 0; + +plan tests => $tests, ['eat_post']; + +print "testing $module\n"; + +for my $data (@test_strings) { + for my $request_uri (@req_strings) { + my $sock = Apache::TestRequest::vhost_socket($module); + ok $sock; + + Apache::TestRequest::socket_trace($sock); + + $sock->print("POST $request_uri HTTP/1.0\r\n"); + $sock->print("Content-Length: $data\r\n"); + $sock->print("\r\n"); + $sock->print("\r\n"); + + # Read the status line + chomp(my $response = Apache::TestRequest::getline($sock) || ''); + $response =~ s/\s$//; + + # Tests with empty content-length have platform-specific behaviour + # until 2.1.0. + skip + $data eq "" && !have_min_apache_version('2.1.0') ? + "skipping tests with empty C-L for httpd < 2.1.0" : 0, + t_cmp($response, $resp_strings[$cycle], + "response codes POST for $request_uri with Content-Length: $data"); + + $cycle++; + + do { + chomp($response = Apache::TestRequest::getline($sock) || ''); + $response =~ s/\s$//; + } + while ($response ne ""); + } +} diff --git a/debian/perl-framework/t/apache/errordoc.t b/debian/perl-framework/t/apache/errordoc.t new file mode 100644 index 0000000..405924b --- /dev/null +++ b/debian/perl-framework/t/apache/errordoc.t @@ -0,0 +1,108 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestRequest; +use Apache::TestUtil; + +Apache::TestRequest::module('error_document'); + +plan tests => 14, need_lwp; + +# basic ErrorDocument tests + +{ + my $response = GET '/notfound.html'; + chomp(my $content = $response->content); + + ok t_cmp($response->code, + 404, + 'notfound.html code'); + + ok t_cmp($content, + qr'per-server 404', + 'notfound.html content'); +} + +{ + my $response = GET '/inherit/notfound.html'; + chomp(my $content = $response->content); + + ok t_cmp($response->code, + 404, + '/inherit/notfound.html code'); + + ok t_cmp($content, + qr'per-server 404', + '/inherit/notfound.html content'); +} + +{ + my $response = GET '/redefine/notfound.html'; + chomp(my $content = $response->content); + + ok t_cmp($response->code, + 404, + '/redefine/notfound.html code'); + + ok t_cmp($content, + 'per-dir 404', + '/redefine/notfound.html content'); +} + +{ + my $response = GET '/restore/notfound.html'; + chomp(my $content = $response->content); + + ok t_cmp($response->code, + 404, + '/redefine/notfound.html code'); + + # 1.3 requires quotes for hard-coded messages + my $expected = have_min_apache_version('2.0.51') ? qr/Not Found/ : + have_apache(2) ? 'default' : + qr/Additionally, a 500/; + + ok t_cmp($content, + $expected, + '/redefine/notfound.html content'); +} + +{ + my $response = GET '/apache/notfound.html'; + chomp(my $content = $response->content); + + ok t_cmp($response->code, + 404, + '/merge/notfound.html code'); + + ok t_cmp($content, + 'testing merge', + '/merge/notfound.html content'); +} + +{ + my $response = GET '/apache/etag/notfound.html'; + chomp(my $content = $response->content); + + ok t_cmp($response->code, + 404, + '/merge/merge2/notfound.html code'); + + ok t_cmp($content, + 'testing merge', + '/merge/merge2/notfound.html content'); +} + +{ + my $response = GET '/bounce/notfound.html'; + chomp(my $content = $response->content); + + ok t_cmp($response->code, + 404, + '/bounce/notfound.html code'); + + ok t_cmp($content, + qr!expire test!, + '/bounce/notfound.html content'); +} diff --git a/debian/perl-framework/t/apache/etags.t b/debian/perl-framework/t/apache/etags.t new file mode 100644 index 0000000..6618a88 --- /dev/null +++ b/debian/perl-framework/t/apache/etags.t @@ -0,0 +1,170 @@ +# +# Test the FileETag directive. +# +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestRequest; +use Apache::TestUtil; + +t_debug "Checking for existence of FileETag directive\n"; +my $resp = GET('/apache/etags/test.txt'); +my $rc = $resp->code; +t_debug "Returned $rc:"; +if ($rc == 500) { + t_debug "Feature not supported, skipping..", + " Message was:", $resp->as_string; + if (defined($resp->content)) { + t_debug $resp->content; + } + plan tests => 1..0; + exit; +} + +# +# The tests verify the inclusion of the different fields, and +# inheritance, according to the directories involved. All are +# subdirectories under /apache/etags/. The key is the path, the value +# is the pattern the ETag response header field needs to match, +# and the comment is the keywords on the FileETag directive in +# the directory's .htaccess file. A pattern of "" means the header +# field is expected to be absent. +# +# The things we want to test are: +# +# 1. That the 'All' and 'None' keywords work. +# 2. That the 'MTime', 'INode', and 'Size' keywords work, +# alone and in combination. +# 3. That '+MTime', '+INode', and '+Size' work, alone and +# in combination. +# 4. That '-MTime', '-INode', and '-Size' work, alone and +# in combination. +# 5. That relative keywords work in combination with non-relative +# ones. +# 6. That inheritance works properly. +# +my $x = '[0-9a-fA-F]+'; +my $tokens_1 = "^\"$x\"\$"; +my $tokens_2 = "^\"$x-$x\"\$"; +my $tokens_3 = "^\"$x-$x-$x\"\$"; +my %expect = ($tokens_1 => "one component in ETag field", + $tokens_2 => "two components in ETag field", + $tokens_3 => "three components in ETag field", + "" => "field to be absent" + ); +my $tokens_default = have_min_apache_version("2.3.15") ? $tokens_2 : $tokens_3; +my %tests = ( + '/default/' => $tokens_default, + # + # First, the absolute settings in various combinations, + # disregarding inheritance. + # + '/m/' => $tokens_1, # MTime + '/i/' => $tokens_1, # INode + '/s/' => $tokens_1, # Size + '/mi/' => $tokens_2, # MTime INode + '/ms/' => $tokens_2, # MTime Size + '/is/' => $tokens_2, # INode Size + '/mis/' => $tokens_3, # MTime INode Size + '/all/' => $tokens_3, # All + '/none/' => "", # None + '/all/m/' => $tokens_1, # MTime + '/all/i/' => $tokens_1, # INode + '/all/s/' => $tokens_1, # Size + '/all/mi/' => $tokens_2, # MTime INode + '/all/ms/' => $tokens_2, # MTime Size + '/all/is/' => $tokens_2, # INode Size + '/all/mis/' => $tokens_3, # MTime INode Size + '/all/inherit/' => $tokens_3, # no directive + '/none/m/' => $tokens_1, # MTime + '/none/i/' => $tokens_1, # INode + '/none/s/' => $tokens_1, # Size + '/none/mi/' => $tokens_2, # MTime INode + '/none/ms/' => $tokens_2, # MTime Size + '/none/is/' => $tokens_2, # INode Size + '/none/mis/' => $tokens_3, # MTime INode Size + '/none/inherit/' => "", # no directive + # + # Now for the relative keywords. First, subtract fields + # in a place where they all should have been inherited. + # + '/all/minus-m/' => $tokens_2, # -MTime + '/all/minus-i/' => $tokens_2, # -INode + '/all/minus-s/' => $tokens_2, # -Size + '/all/minus-mi/' => $tokens_1, # -MTime -INode + '/all/minus-ms/' => $tokens_1, # -MTime -Size + '/all/minus-is/' => $tokens_1, # -INode -Size + '/all/minus-mis/' => "", # -MTime -INode -Size + # + # Now add them in a location where they should all be absent. + # + '/none/plus-m/' => $tokens_1, # +MTime + '/none/plus-i/' => $tokens_1, # +INode + '/none/plus-s/' => $tokens_1, # +Size + '/none/plus-mi/' => $tokens_2, # +MTime +INode + '/none/plus-ms/' => $tokens_2, # +MTime +Size + '/none/plus-is/' => $tokens_2, # +INode +Size + '/none/plus-mis/' => $tokens_3, # +MTime +INode +Size + # + # Try subtracting them below where they were added. + # + '/none/plus-mis/minus-m/' => $tokens_2, # -MTime + '/none/plus-mis/minus-i/' => $tokens_2, # -INode + '/none/plus-mis/minus-s/' => $tokens_2, # -Size + '/none/plus-mis/minus-mi/' => $tokens_1, # -MTime -INode + '/none/plus-mis/minus-ms/' => $tokens_1, # -MTime -Size + '/none/plus-mis/minus-is/' => $tokens_1, # -INode -Size + '/none/plus-mis/minus-mis/' => "", # -MTime -INode -Size + # + # Now relative settings under a non-All non-None absolute + # setting location. + # + '/m/plus-m/' => $tokens_1, # +MTime + '/m/plus-i/' => $tokens_2, # +INode + '/m/plus-s/' => $tokens_2, # +Size + '/m/plus-mi/' => $tokens_2, # +MTime +INode + '/m/plus-ms/' => $tokens_2, # +MTime +Size + '/m/plus-is/' => $tokens_3, # +INode +Size + '/m/plus-mis/' => $tokens_3, # +MTime +INode +Size + '/m/minus-m/' => "", # -MTime + '/m/minus-i/' => "", # -INode + '/m/minus-s/' => "", # -Size + '/m/minus-mi/' => "", # -MTime -INode + '/m/minus-ms/' => "", # -MTime -Size + '/m/minus-is/' => "", # -INode -Size + '/m/minus-mis/' => "" # -MTime -INode -Size + ); + +my $testcount = scalar(keys(%tests)); +plan tests => $testcount; + +for my $key (keys(%tests)) { + my $uri = "/apache/etags" . $key . "test.txt"; + my $pattern = $tests{$key}; + t_debug "---", "HEAD $uri", + "Expecting " . $expect{$pattern}; + $resp = HEAD($uri); + my $etag = $resp->header("ETag"); + if (defined($etag)) { + t_debug "Received $etag"; + ok ($etag =~ /$pattern/); + } + else { + t_debug "ETag field is missing"; + if ($tests{$key} eq "") { + ok 1; + } + else { + t_debug "ETag field was expected"; + ok 0; + } + } +} + +# +# Local Variables: +# mode: perl +# indent-tabs-mode: nil +# End: +# diff --git a/debian/perl-framework/t/apache/expr.t b/debian/perl-framework/t/apache/expr.t new file mode 100644 index 0000000..7d62bc0 --- /dev/null +++ b/debian/perl-framework/t/apache/expr.t @@ -0,0 +1,327 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestRequest; +use Apache::TestUtil qw(t_write_file t_start_error_log_watch t_finish_error_log_watch); + +use File::Spec; + +# test ap_expr + +Apache::TestRequest::user_agent(keep_alive => 1); + +my $file_foo = Apache::Test::vars('serverroot') . '/htdocs/expr/index.html'; +my $dir_foo = Apache::Test::vars('serverroot') . '/htdocs/expr'; +my $file_notexist = Apache::Test::vars('serverroot') . '/htdocs/expr/none'; +my $file_zero = Apache::Test::vars('serverroot') . '/htdocs/expr/zero'; +my $url_foo = '/apache/'; +my $url_notexist = '/apache/expr/none'; +my @test_cases = ( + [ 'true' => 1 ], + [ 'false' => 0 ], + [ 'foo' => undef ], + # integer comparison + [ '1 -eq 01' => 1 ], + [ '1 -eq 2' => 0 ], + [ '1 -ne 2' => 1 ], + [ '1 -ne 1' => 0 ], + [ '1 -lt 02' => 1 ], + [ '1 -lt 1' => 0 ], + [ '1 -le 2' => 1 ], + [ '1 -le 1' => 1 ], + [ '2 -gt 1' => 1 ], + [ '1 -gt 1' => 0 ], + [ '2 -ge 1' => 1 ], + [ '1 -ge 1' => 1 ], + [ '1 -gt -1' => 1 ], + # string comparison + [ q{'aa' == 'aa'} => 1 ], + [ q{'aa' == 'b'} => 0 ], + [ q{'aa' = 'aa'} => 1 ], + [ q{'aa' = 'b'} => 0 ], + [ q{'aa' != 'b'} => 1 ], + [ q{'aa' != 'aa'} => 0 ], + [ q{'aa' < 'b'} => 1 ], + [ q{'aa' < 'aa'} => 0 ], + [ q{'aa' <= 'b'} => 1 ], + [ q{'aa' <= 'aa'} => 1 ], + [ q{'b' > 'aa'} => 1 ], + [ q{'aa' > 'aa'} => 0 ], + [ q{'b' >= 'aa'} => 1 ], + [ q{'aa' >= 'aa'} => 1 ], + # string operations/whitespace handling + [ q{'a' . 'b' . 'c' = 'abc'} => 1 ], + [ q{'a' .'b'. 'c' = 'abc'} => 1 ], + [ q{ 'a' .'b'. 'c'='abc' } => 1 ], + [ q{'a1c' = 'a'. 1. 'c'} => 1 ], + [ q{req('foo') . 'bar' = 'bar'} => 1 ], + [ q[%{req:foo} . 'bar' = 'bar'] => 1 ], + [ q['x'.%{req:foo} . 'bar' = 'xbar'] => 1 ], + [ q[%{req:User-Agent} . 'bar' != 'bar'] => 1 ], + [ q['%{req:User-Agent}' . 'bar' != 'bar'] => 1 ], + [ q['%{TIME}' . 'bar' != 'bar'] => 1 ], + [ q[%{TIME} != ''] => 1 ], + # string lists + [ q{'a' -in { 'b', 'a' } } => 1 ], + [ q{'a' -in { 'b', 'c' } } => 0 ], + # regexps + [ q[ 'abc' =~ /bc/ ] => 1 ], + [ q[ 'abc' =~ /BC/i ] => 1 ], + [ q[ 'abc' !~ m!bc! ] => 0 ], + [ q[ 'abc' !~ m!BC!i ] => 0 ], + [ q[ $0 == '' ] => 1 ], + [ q[ $1 == '' ] => 1 ], + [ q[ $9 == '' ] => 1 ], + [ q[ '$0' == '' ] => 1 ], + [ q[ 'abc' =~ /(bc)/ && $0 == 'bc' ] => 1 ], + [ q[ 'abc' =~ /(bc)/ && $1 == 'bc' ] => 1 ], + [ q[ 'abc' =~ /b(.)/ && $1 == 'c' ] => 1 ], + # $0 .. $9 are only populated if there are capturing parens + [ q[ 'abc' =~ /bc/ && $0 == '' ] => 1 ], + [ q[ 'abc' =~ /(bc)/ && 'xy' =~ /x/ && $0 == 'bc' ] => 1 ], + # Attempt to blow up when more matches are present than 'typical' $0 .. $9 + [ q[ 'abcdefghijklm' =~ /(b)(c)(d)(e)(f)(g)(h)(i)(j)(k)(l)/ && $2 == 'c' ] => 1 ], + # variables + [ q[%{TIME_YEAR} =~ /^\d{4}$/] => 1 ], + [ q[%{TIME_YEAR} =~ /^\d{3}$/] => 0 ], + [ q[%{TIME_MON} -gt 0 && %{TIME_MON} -le 12 ] => 1 ], + [ q[%{TIME_DAY} -gt 0 && %{TIME_DAY} -le 31 ] => 1 ], + [ q[%{TIME_HOUR} -ge 0 && %{TIME_HOUR} -lt 24 ] => 1 ], + [ q[%{TIME_MIN} -ge 0 && %{TIME_MIN} -lt 60 ] => 1 ], + [ q[%{TIME_SEC} -ge 0 && %{TIME_SEC} -lt 60 ] => 1 ], + [ q[%{TIME} =~ /^\d{14}$/] => 1 ], + [ q[%{API_VERSION} -gt 20101001 ] => 1 ], + [ q[%{REQUEST_METHOD} == 'GET' ] => 1 ], + [ q['x%{REQUEST_METHOD}' == 'xGET' ] => 1 ], + [ q['x%{REQUEST_METHOD}y' == 'xGETy' ] => 1 ], + [ q[%{REQUEST_SCHEME} == 'http' ] => 1 ], + [ q[%{HTTPS} == 'off' ] => 1 ], + [ q[%{REQUEST_URI} == '/apache/expr/index.html' ] => 1 ], + # request headers + [ q[%{req:referer} = 'SomeReferer' ] => 1 ], + [ q[req('Referer') = 'SomeReferer' ] => 1 ], + [ q[http('Referer') = 'SomeReferer' ] => 1 ], + [ q[%{HTTP_REFERER} = 'SomeReferer' ] => 1 ], + [ q[req('User-Agent') = 'SomeAgent' ] => 1 ], + [ q[%{HTTP_USER_AGENT} = 'SomeAgent' ] => 1 ], + [ q[req('SomeHeader') = 'SomeValue' ] => 1 ], + [ q[req('SomeHeader2') = 'SomeValue' ] => 0 ], + # functions + [ q[toupper('abC12d') = 'ABC12D' ] => 1 ], + [ q[tolower('abC12d') = 'abc12d' ] => 1 ], + [ q[escape('?') = '%3f' ] => 1 ], + [ q[unescape('%3f') = '?' ] => 1 ], + [ q[toupper(escape('?')) = '%3F' ] => 1 ], + [ q[tolower(toupper(escape('?'))) = '%3f' ] => 1 ], + [ q[%{toupper:%{escape:?}} = '%3F' ] => 1 ], + [ q[file('] . $file_foo . q[') = 'foo\n' ] => 1 ], + # unary operators + [ q[-n ''] => 0 ], + [ q[-z ''] => 1 ], + [ q[-n '1'] => 1 ], + [ q[-z '1'] => 0 ], + # IP match + [ q[-R 'abc'] => undef ], + [ q[-R %{REMOTE_ADDR}] => undef ], + [ q[-R '240.0.0.0'] => 0 ], + [ q[-R '240.0.0.0/8'] => 0 ], + [ q[-R 'ff::/8'] => 0 ], + [ q[-R '127.0.0.1' || -R '::1'] => 1 ], + [ q['127.0.0.1' -ipmatch 'abc'] => undef ], + [ q['127.0.0.1' -ipmatch %{REMOTE_ADDR}] => undef ], + [ q['127.0.0.1' -ipmatch '240.0.0.0'] => 0 ], + [ q['127.0.0.1' -ipmatch '240.0.0.0/8'] => 0 ], + [ q['127.0.0.1' -ipmatch 'ff::/8'] => 0 ], + [ q['127.0.0.1' -ipmatch '127.0.0.0/8'] => 1 ], + # fn/strmatch + [ q['foo' -strmatch '*o'] => 1 ], + [ q['fo/o' -strmatch 'f*'] => 1 ], + [ q['foo' -strmatch 'F*'] => 0 ], + [ q['foo' -strcmatch 'F*'] => 1 ], + [ q['foo' -strmatch 'g*'] => 0 ], + [ q['foo' -strcmatch 'g*'] => 0 ], + [ q['a/b' -fnmatch 'a*'] => 0 ], + [ q['a/b' -fnmatch 'a/*'] => 1 ], + # error handling + [ q['%{foo:User-Agent}' != 'bar'] => undef ], + [ q[%{foo:User-Agent} != 'bar'] => undef ], + [ q[foo('bar') = 'bar'] => undef ], + [ q[%{FOO} != 'bar'] => undef ], + [ q['bar' = bar] => undef ], +); + +# +# Bool logic: +# Test all combinations with 0 to 2 '||' or '&&' operators +# +my @bool_base = ( + [ q[true] => 1 ], +); +push @bool_base, ( + [ q[-z ''] => 1 ], + [ q[-n 'x'] => 1 ], + [ q[false] => 0 ], + [ q[-n ''] => 0 ], + [ q[-z 'x'] => 0 ], +) if 0; # This produces an exessive number of tests for normal operation + +# negation function: perl's "!" returns undef for false, but we need 0 +sub neg +{ + return (shift) ? 0 : 1; +} +# also test combinations with '!' operator before each operand +@bool_base = (@bool_base, map { ["!$_->[0]" => neg($_->[1]) ] } @bool_base); +# now create the test cases +my @bool_test_cases; +foreach my $ex1 (@bool_base) { + my ($e1, $r1) = @$ex1; + push @bool_test_cases, [ $e1 => $r1 ]; + foreach my $ex2 (@bool_base) { + my ($e2, $r2) = @$ex2; + push @bool_test_cases, [ "$e1 && $e2" => ($r1 && $r2) ]; + push @bool_test_cases, [ "$e1 || $e2" => ($r1 || $r2) ]; + foreach my $ex3 (@bool_base) { + my ($e3, $r3) = @$ex3; + foreach my $op1 ("||", "&&") { + foreach my $op2 ("||", "&&") { + my $r = eval "$r1 $op1 $r2 $op2 $r3"; + push @bool_test_cases, [ "$e1 $op1 $e2 $op2 $e3" => $r]; + } + } + } + } +} +push @test_cases, @bool_test_cases; +# also test combinations with '!' operator before the whole expression +push @test_cases, map { ["!($_->[0])" => neg($_->[1]) ] } @bool_test_cases; + +if (have_min_apache_version("2.3.13")) { + push(@test_cases, ( + # functions + [ q[filesize('] . $file_foo . q[') = 4 ] => 1 ], + [ q[filesize('] . $file_notexist . q[') = 0 ] => 1 ], + [ q[filesize('] . $file_zero . q[') = 0 ] => 1 ], + # unary operators + [ qq[-d '$file_foo' ] => 0 ], + [ qq[-e '$file_foo' ] => 1 ], + [ qq[-f '$file_foo' ] => 1 ], + [ qq[-s '$file_foo' ] => 1 ], + [ qq[-d '$file_zero' ] => 0 ], + [ qq[-e '$file_zero' ] => 1 ], + [ qq[-f '$file_zero' ] => 1 ], + [ qq[-s '$file_zero' ] => 0 ], + [ qq[-d '$dir_foo' ] => 1 ], + [ qq[-e '$dir_foo' ] => 1 ], + [ qq[-f '$dir_foo' ] => 0 ], + [ qq[-s '$dir_foo' ] => 0 ], + [ qq[-d '$file_notexist' ] => 0 ], + [ qq[-e '$file_notexist' ] => 0 ], + [ qq[-f '$file_notexist' ] => 0 ], + [ qq[-s '$file_notexist' ] => 0 ], + [ qq[-F '$file_foo' ] => 1 ], + [ qq[-F '$file_notexist' ] => 0 ], + [ qq[-U '$url_foo' ] => 1 ], + [ qq[-U '$url_notexist' ] => 0 ], + )); +} + +if (have_min_apache_version("2.4.5")) { + push(@test_cases, ( + [ qq[sha1('foo') = '0beec7b5ea3f0fdbc95d0dd47f3c5bc275da8a33' ] => 1 ], + [ qq[md5('foo') = 'acbd18db4cc2f85cedef654fccc4a4d8' ] => 1 ], + [ qq[base64('foo') = 'Zm9v' ] => 1 ], + [ qq[unbase64('Zm9vMg==') = 'foo2' ] => 1 ], + )); +} + +if (have_min_apache_version("2.5")) { + my $SAN_one = "email:<redacted1>, email:<redacted2>, " . + "IP Address:127.0.0.1, IP Address:0:0:0:0:0:0:0:1, " . + "IP Address:192.168.169.170"; + my $SAN_tuple = "'email:<redacted1>', 'email:<redacted2>', " . + "'IP Address:127.0.0.1', 'IP Address:0:0:0:0:0:0:0:1', " . + "'IP Address:192.168.169.170'"; + my $SAN_list_one = "{ '$SAN_one' }"; + my $SAN_list_tuple = "{ $SAN_tuple }"; + + my $SAN_split = '.*?IP Address:([^,]+)'; + + push(@test_cases, ( + [ "join {'a', 'b', 'c'} == 'abc'" => 1 ], + [ "join($SAN_list_tuple, ', ') == " . + "'email:<redacted1>, email:<redacted2>, " . + "IP Address:127.0.0.1, IP Address:0:0:0:0:0:0:0:1, " . + "IP Address:192.168.169.170'" => 1 ], + [ "join($SAN_list_tuple, ', ') == join $SAN_list_one" => 1 ], + [ "join(split(s/$SAN_split/\$1/, $SAN_list_tuple), ', ') == " . + "'email:<redacted1>, email:<redacted2>, " . + "127.0.0.1, 0:0:0:0:0:0:0:1, 192.168.169.170'" => 1 ], + [ "join(split(s/$SAN_split/\$1/, $SAN_list_one), ', ') == " . + "'127.0.0.1, 0:0:0:0:0:0:0:1, 192.168.169.170'" => 1 ], + [ "'IP Address:192.168.169.170' -in $SAN_list_tuple" => 1 ], + [ "'192.168.169.170' -in split s/$SAN_split/\$1/, $SAN_list_tuple" => 1 ], + [ "'0:0:0:0:0:0:0:1' -in split s/$SAN_split/\$1/, $SAN_list_one" => 1 ], + [ "%{REMOTE_ADDR} -in split s/$SAN_split/\$1/, $SAN_list_one" => 1 ], + [ "'email:<redacted1>' -in split s/$SAN_split/\$1/, $SAN_list_tuple" => 1 ], + [ "'email:<redacted2>' -in split s/$SAN_split/\$1/, $SAN_list_one" => 0 ], + [ "'IP Address:%{REMOTE_ADDR}' -in split/, /, join $SAN_list_one" + => 1 ], + [ "replace(%{REQUEST_METHOD}, 'E', 'O') == 'GOT'" => 1], + [ "replace(%{REQUEST_METHOD}, 'E', 'O') == 'GET'" => 0], + )); +} + +plan tests => scalar(@test_cases) + 1, + need need_lwp, + need_module('mod_authz_core'), + need_min_apache_version('2.3.9'); + +t_start_error_log_watch(); + +my %rc_map = ( 500 => 'parse error', 403 => 'true', 200 => 'false'); +foreach my $t (@test_cases) { + my ($expr, $expect) = @{$t}; + + write_htaccess($expr); + + my $response = GET('/apache/expr/index.html', + 'SomeHeader' => 'SomeValue', + 'User-Agent' => 'SomeAgent', + 'Referer' => 'SomeReferer'); + my $rc = $response->code; + if (!defined $expect) { + print qq{Should get parse error for "$expr", got $rc_map{$rc}\n}; + ok($rc == 500); + } + elsif ($expect) { + print qq{"$expr" should evaluate to true, got $rc_map{$rc}\n}; + ok($rc == 403); + } + else { + print qq{"$expr" should evaluate to false, got $rc_map{$rc}\n}; + ok($rc == 200); + } +} + +my @loglines = t_finish_error_log_watch(); +my @evalerrors = grep { /internal evaluation error/i } @loglines; +my $num_errors = scalar @evalerrors; +print "Error log should not have 'Internal evaluation error' entries, found $num_errors\n"; +ok($num_errors == 0); + +exit 0; + +### sub routines +sub write_htaccess +{ + my $expr = shift; + my $file = File::Spec->catfile(Apache::Test::vars('serverroot'), 'htdocs', 'apache', 'expr', '.htaccess'); + t_write_file($file, << "EOF" ); +<If "$expr"> + Require all denied +</If> +EOF +} + diff --git a/debian/perl-framework/t/apache/expr_string.t b/debian/perl-framework/t/apache/expr_string.t new file mode 100644 index 0000000..4682d4a --- /dev/null +++ b/debian/perl-framework/t/apache/expr_string.t @@ -0,0 +1,123 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestRequest; +use Apache::TestUtil qw(t_write_file t_start_error_log_watch t_finish_error_log_watch t_cmp); + +use File::Spec; + +use Time::HiRes qw(usleep); + +# test ap_expr + +Apache::TestRequest::user_agent(keep_alive => 1); + +# The left-hand values are written into the config file as-is, i.e. +# necessary quoting for the config file parser needs to be included +# explicitly. +my @test_cases = ( + [ 'foo' => 'foo' ], + [ '%{req:SomeHeader}' => 'SomeValue' ], + [ '%{' => undef ], + [ '%' => '%' ], + [ '}' => '}' ], + [ q{\"} => q{"} ], + [ q{\'} => q{'} ], + [ q{"\%{req:SomeHeader}"} => '%{req:SomeHeader}' ], + [ '%{tolower:IDENT}' => 'ident' ], + [ '%{tolower:%{REQUEST_METHOD}}' => 'get' ], +); + +if (have_min_apache_version("2.5")) { + my $SAN_one = "email:<redacted1>, email:<redacted2>, " . + "IP Address:127.0.0.1, IP Address:0:0:0:0:0:0:0:1, " . + "IP Address:192.168.169.170"; + my $SAN_tuple = "'email:<redacted1>', 'email:<redacted2>', " . + "'IP Address:127.0.0.1', 'IP Address:0:0:0:0:0:0:0:1', " . + "'IP Address:192.168.169.170'"; + my $SAN_list_one = "{ '$SAN_one' }"; + my $SAN_list_tuple = "{ $SAN_tuple }"; + + push(@test_cases, ( + [ qq["%{tolower:%{:toupper(%{REQUEST_METHOD}):}}"] => "get" ], + [ qq["%{: join $SAN_list_one :}"] => "$SAN_one" ], + [ qq["%{: join($SAN_list_tuple, ', ') :}"] => "$SAN_one" ], + [ qq['%{tolower:"IDENT"}'] => '"ident"' ], + [ qq["%{: 'IP Address:%{REMOTE_ADDR}' -in split/, /, join $SAN_list_one :}"] + => "true" ], + )); +} + +my $successful_expected = scalar(grep { defined $_->[1] } @test_cases); + +plan tests => scalar(@test_cases) * 2 + $successful_expected, + need need_lwp, + need_module('mod_log_debug'); +foreach my $t (@test_cases) { + my ($expr, $expect) = @{$t}; + + write_htaccess($expr); + + t_start_error_log_watch(); + my $response = GET('/apache/expr/index.html', + 'SomeHeader' => 'SomeValue', + 'User-Agent' => 'SomeAgent', + 'Referer' => 'SomeReferer'); + ### Sleep here, attempt to avoid intermittent failures. + usleep(250000); + my @loglines = t_finish_error_log_watch(); + + my @evalerrors = grep {/(?:internal evaluation error|flex scanner jammed)/i + } @loglines; + my $num_errors = scalar @evalerrors; + print "Error log should not have 'Internal evaluation error' or " . + "'flex scanner jammed' entries, found $num_errors:\n@evalerrors\n" + if $num_errors; + ok($num_errors == 0); + + my $rc = $response->code; + + if (!defined $expect) { + print qq{Should get parse error (500) for "$expr", got $rc\n}; + ok($rc == 500); + } + else { + print qq{Expected return code 200, got $rc for '$expr'\n}; + ok($rc == 200); + my @msg = grep { /log_debug:info/ } @loglines; + if (scalar @msg != 1) { + print "expected 1 message, got " . scalar @msg . ":\n@msg\n"; + ok(0); + } + elsif ($msg[0] =~ m{^(?:\[ # opening '[' + [^\]]+ # anything but a ']' + \] # closing ']' + [ ] # trailing space + ){4} # repeat 4 times (timestamp, level, pid, client IP) + (.*?) # The actual message logged by LogMessage + (,[ ]referer # either trailing referer (LogLevel info) + | # or + [ ]\(log_transaction) # trailing hook info (LogLevel debug and higher) + }x ) { + my $result = $1; + ok t_cmp($result, $expect, "log message @msg didn't match"); + } + else { + print "Can't extract expr result from log message:\n@msg\n"; + ok(0); + } + } +} + +exit 0; + +### sub routines +sub write_htaccess +{ + my $expr = shift; + my $file = File::Spec->catfile(Apache::Test::vars('serverroot'), 'htdocs', 'apache', 'expr', '.htaccess'); + t_write_file($file, << "EOF" ); +LogMessage $expr +EOF +} diff --git a/debian/perl-framework/t/apache/getfile.t b/debian/perl-framework/t/apache/getfile.t new file mode 100644 index 0000000..3df2faf --- /dev/null +++ b/debian/perl-framework/t/apache/getfile.t @@ -0,0 +1,24 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestUtil; +use Apache::TestRequest (); +use Apache::TestCommon (); + +Apache::TestCommon::run_files_test(\&verify); + +sub verify { + my($ua, $url, $file) = @_; + + my $flen = -s $file; + my $received = 0; + + $ua->do_request(GET => $url, + sub { + my($chunk, $res) = @_; + $received += length $chunk; + }); + + ok t_cmp($received, $flen, "download of $url"); +} diff --git a/debian/perl-framework/t/apache/headers.t b/debian/perl-framework/t/apache/headers.t new file mode 100644 index 0000000..2412eff --- /dev/null +++ b/debian/perl-framework/t/apache/headers.t @@ -0,0 +1,96 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestUtil; +use Apache::TestRequest; + +my %headers; + +my $hasfix = 0; +if (have_min_apache_version("2.4.0")) { + if (have_min_apache_version("2.4.24")) { + $hasfix = 1; + } +} +elsif (have_min_apache_version("2.2.32")) { + $hasfix = 1; +} +if ($hasfix) { + %headers = ( + "Hello:World\r\n" => ["Hello", "World"], + "Hello: World\r\n" => ["Hello", "World"], + "Hello: World \r\n" => ["Hello", "World"], + "Hello: World \t \r\n" => ["Hello", "World"], + "Hello: Foo\r\n Bar\r\n" => ["Hello", "Foo Bar"], + "Hello: Foo\r\n\tBar\r\n" => ["Hello", "Foo Bar"], + "Hello: Foo\r\n Bar\r\n" => ["Hello", "Foo Bar"], + "Hello: Foo \t \r\n Bar\r\n" => ["Hello", "Foo Bar"], + "Hello: Foo\r\n \t Bar\r\n" => ["Hello", "Foo Bar"], + ); +} +else { + %headers = ( + "Hello:World\n" => ["Hello", "World"], + "Hello : World\n" => ["Hello", "World"], + "Hello : World \n" => ["Hello", "World"], + "Hello \t : World \n" => ["Hello", "World"], + "Hello: Foo\n Bar\n" => ["Hello", "Foo Bar"], + "Hello: Foo\n\tBar\n" => ["Hello", "Foo\tBar"], + "Hello: Foo\n Bar\n" => ["Hello", qr/Foo +Bar/], + "Hello: Foo \n Bar\n" => ["Hello", qr/Foo +Bar/], + ); +} + +my $uri = "/modules/cgi/env.pl"; + +plan tests => (scalar keys %headers) * 3, need_cgi; + +foreach my $key (sort keys %headers) { + + print "testing: $key"; + + my $sock = Apache::TestRequest::vhost_socket('default'); + ok $sock; + + Apache::TestRequest::socket_trace($sock); + + $sock->print("GET $uri HTTP/1.0\r\n"); + $sock->print($key); + $sock->print("\r\n"); + + # Read the status line + chomp(my $response = Apache::TestRequest::getline($sock) || ''); + $response =~ s/\s$//; + + ok t_cmp($response, qr{HTTP/1\.. 200 OK}, "response success"); + + my $line; + + do { + chomp($line = Apache::TestRequest::getline($sock) || ''); + $line =~ s/\s$//; + } + while ($line ne ""); + + my $found = 0; + + my ($name, $value) = ($headers{$key}[0], $headers{$key}[1]); + + do { + chomp($line = Apache::TestRequest::getline($sock) || ''); + $line =~ s/\r?\n?$//; + if ($line ne "" && !$found) { + my @part = split(/ = /, $line); + if (@part && $part[0] eq "HTTP_" . uc($name)) { + print "header: [".$part[1]."] vs [".$value."]\n"; + ok t_cmp $part[1], $value, "compare header $name value"; + $found = 1; + } + } + } + while ($line ne ""); + + ok 0 unless $found; +} + diff --git a/debian/perl-framework/t/apache/hostcheck.t b/debian/perl-framework/t/apache/hostcheck.t new file mode 100644 index 0000000..b9e11aa --- /dev/null +++ b/debian/perl-framework/t/apache/hostcheck.t @@ -0,0 +1,113 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestRequest; +use Apache::TestUtil; +use MIME::Base64; +use Data::Dumper; +use HTTP::Response; +use Socket; + +# undef: HTTPD should drop connection without error message + +my @test_cases = ( + # request, status code global, status code strict VH, msg + [ "GET / HTTP/1.1\r\nHost: localhost\r\n\r\n" => 200, 400, "ok"], + [ "GET / HTTP/1.1\r\nHost: localhost:1\r\n\r\n" => 200, 400, "port ignored"], + [ "GET / HTTP/1.1\r\nHost: notlisted\r\n\r\n" => 200, 400, "name not listed"], + [ "GET / HTTP/1.1\r\nHost: 127.0.0.1\r\n\r\n" => 200, 400, "IP not in serveralias/servername"], + [ "GET / HTTP/1.1\r\nHost: default-strict\r\n\r\n" => 200, 200, "NVH matches in default server"], + [ "GET / HTTP/1.1\r\nHost: nvh-strict\r\n\r\n" => 200, 200, "NVH matches"], + [ "GET / HTTP/1.1\r\nHost: nvh-strict:1\r\n\r\n" => 200, 200, "NVH matches port ignored"], +); +plan tests => scalar(@test_cases) * 2, need_min_apache_version('2.5.1'); + + +foreach my $vhosts ((["default" => 1], ["core" => 2])) { + my $vhost = $vhosts->[0]; + my $expect_column = $vhosts->[1]; + + foreach my $t (@test_cases) { + my $req = $t->[0]; + my $expect = $t->[$expect_column]; + my $desc = $t->[3]; + my $decoded; + + my $sock = Apache::TestRequest::vhost_socket($vhost); + if (!$sock) { + print "# failed to connect\n"; + ok(0); + next; + } + + print "# SENDING to " . peer($sock) . "\n# $req\n"; + $sock->print($req); + $sock->shutdown(1); + $req = escape($req); + + my $response_data = ""; + my $buf; + while ($sock->read($buf, 10000) > 0) { + $response_data .= $buf; + } + my $response = HTTP::Response->parse($response_data); + if ($decoded) { + $response_data =~ s/<title>.*/.../s; + my $out = escape($response_data); + $out =~ s{\\n}{\\n\n# }g; + print "# RESPONSE:\n# $out\n"; + } + if (! defined $response) { + die "HTTP::Response->parse failed"; + } + my $rc = $response->code; + if (! defined $rc) { + if (! defined $expect) { + print "# expecting dropped connection and HTTPD dropped connection\n"; + ok(1); + } + else { + print "# expecting $expect, but HTTPD dropped the connection\n"; + ok(0); + } + } + elsif ($expect > 100) { + print "# expected $expect, got " . $response->code . " for $desc\n"; + ok ($response->code, $expect, $desc ); + } + elsif ($expect == 90) { + print "# expecting headerless HTTP/0.9 body, got response\n"; + ok (1); + } + elsif ($expect) { + print "# expecting success, got ", $rc, ": $desc\n"; + ok ($rc >= 200 && $rc < 400); + } + else { + print "# expecting error, got ", $rc, ": $desc\n"; + ok ($rc >= 400); + } + } +} + +sub escape +{ + my $in = shift; + $in =~ s{\\}{\\\\}g; + $in =~ s{\r}{\\r}g; + $in =~ s{\n}{\\n}g; + $in =~ s{\t}{\\t}g; + $in =~ s{([\x00-\x1f])}{sprintf("\\x%02x", ord($1))}ge; + return $in; +} + +sub peer +{ + my $sock = shift; + my $hersockaddr = getpeername($sock); + my ($port, $iaddr) = sockaddr_in($hersockaddr); + my $herhostname = gethostbyaddr($iaddr, AF_INET); + my $herstraddr = inet_ntoa($iaddr); + return "$herstraddr:$port"; +} diff --git a/debian/perl-framework/t/apache/http_strict.t b/debian/perl-framework/t/apache/http_strict.t new file mode 100644 index 0000000..2434fc3 --- /dev/null +++ b/debian/perl-framework/t/apache/http_strict.t @@ -0,0 +1,243 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestRequest; +use MIME::Base64; +use Data::Dumper; +use HTTP::Response; + + +my $test_underscore = defined(&need_min_apache_fix) ? + need_min_apache_fix("2.4.34", "2.5.1") : + need_min_apache_version('2.4.34'); + +# possible expected results: +# 0: any HTTP error +# 1: any HTTP success +# 200-500: specific HTTP status code +# undef: HTTPD should drop connection without error message + +my @test_cases = ( + [ "GET / HTTP/1.0\r\n\r\n" => 1], + [ "GET / HTTP/1.0\n\n" => 1, 400], + [ "get / HTTP/1.0\r\n\r\n" => 501], + [ "G ET / HTTP/1.0\r\n\r\n" => 400], + [ "G\0ET / HTTP/1.0\r\n\r\n" => 400], + [ "G/T / HTTP/1.0\r\n\r\n" => 501, 400], + [ "GET /\0 HTTP/1.0\r\n\r\n" => 400], + [ "GET / HTTP/1.0\0\r\n\r\n" => 400], + [ "GET\f/ HTTP/1.0\r\n\r\n" => 400], + [ "GET\r/ HTTP/1.0\r\n\r\n" => 400], + [ "GET\t/ HTTP/1.0\r\n\r\n" => 400], + [ "GET / HTT/1.0\r\n\r\n" => 0], + [ "GET / HTTP/1.0\r\nHost: localhost\r\n\r\n" => 1], + [ "GET / HTTP/2.0\r\nHost: localhost\r\n\r\n" => 1], + [ "GET / HTTP/1.2\r\nHost: localhost\r\n\r\n" => 1], + [ "GET / HTTP/1.11\r\nHost: localhost\r\n\r\n" => 400], + [ "GET / HTTP/10.0\r\nHost: localhost\r\n\r\n" => 400], + [ "GET / HTTP/1.0 \r\nHost: localhost\r\n\r\n" => 200, 400], + [ "GET / HTTP/1.0 x\r\nHost: localhost\r\n\r\n" => 400], + [ "GET / HTTP/\r\nHost: localhost\r\n\r\n" => 0], + [ "GET / HTTP/0.9\r\n\r\n" => 0], + [ "GET / HTTP/0.8\r\n\r\n" => 0], + [ "GET /\x01 HTTP/1.0\r\n\r\n" => 400], + [ "GET / HTTP/1.0\r\nFoo: bar\r\n\r\n" => 200], + [ "GET / HTTP/1.0\r\nFoo:bar\r\n\r\n" => 200], + [ "GET / HTTP/1.0\r\nFoo: b\0ar\r\n\r\n" => 400], + [ "GET / HTTP/1.0\r\nFoo: b\x01ar\r\n\r\n" => 200, 400], + [ "GET / HTTP/1.0\r\nFoo\r\n\r\n" => 400], + [ "GET / HTTP/1.0\r\nFoo bar\r\n\r\n" => 400], + [ "GET / HTTP/1.0\r\n: bar\r\n\r\n" => 400], + [ "GET / HTTP/1.0\r\nX: bar\r\n\r\n" => 200], + [ "GET / HTTP/1.0\r\nFoo bar:bash\r\n\r\n" => 400], + [ "GET / HTTP/1.0\r\nFoo :bar\r\n\r\n" => 400], + [ "GET / HTTP/1.0\r\n Foo:bar\r\n\r\n" => 400], + [ "GET / HTTP/1.0\r\nF\x01o: bar\r\n\r\n" => 200, 400], + [ "GET / HTTP/1.0\r\nF\ro: bar\r\n\r\n" => 400], + [ "GET / HTTP/1.0\r\nF\to: bar\r\n\r\n" => 400], + [ "GET / HTTP/1.0\r\nFo: b\tar\r\n\r\n" => 200], + [ "GET / HTTP/1.0\r\nFo: bar\r\r\n\r\n" => 400], + [ "GET / HTTP/1.0\r\r" => undef, undef], + [ "GET /\r\n" => 90, undef], + [ "GET /#frag HTTP/1.0\r\n" => 400], + [ "GET / HTTP/1.0\r\nHost: localhost\r\n" . + "Host: localhost\r\n\r\n" => 200, 400], + [ "GET http://017700000001/ HTTP/1.0\r\n\r\n" => 200, 400], + [ "GET http://0x7f.1/ HTTP/1.0\r\n\r\n" => 200, 400], + [ "GET http://127.0.0.1/ HTTP/1.0\r\n\r\n" => 200], + [ "GET http://127.01.0.1/ HTTP/1.0\r\n\r\n" => 200, 400], + [ "GET http://%3127.0.0.1/ HTTP/1.0\r\n\r\n" => 200, 400], + [ "GET / HTTP/1.0\r\nHost: localhost:80\r\n" . + "Host: localhost:80\r\n\r\n" => 200, 400], + [ "GET / HTTP/1.0\r\nHost: localhost:80 x\r\n\r" => 400], + [ "GET http://localhost:80/ HTTP/1.0\r\n\r\n" => 200], + [ "GET http://localhost:80x/ HTTP/1.0\r\n\r\n" => 400], + [ "GET http://localhost:80:80/ HTTP/1.0\r\n\r\n" => 400], + [ "GET http://localhost::80/ HTTP/1.0\r\n\r\n" => 400], + [ "GET http://foo\@localhost:80/ HTTP/1.0\r\n\r\n" => 200, 400], + [ "GET http://[::1]/ HTTP/1.0\r\n\r\n" => 1], + [ "GET http://[::1:2]/ HTTP/1.0\r\n\r\n" => 1], + [ "GET http://[4712::abcd]/ HTTP/1.0\r\n\r\n" => 1], + [ "GET http://[4712::abcd:1]/ HTTP/1.0\r\n\r\n" => 1], + [ "GET http://[4712::abcd::]/ HTTP/1.0\r\n\r\n" => 400], + [ "GET http://[4712:abcd::]/ HTTP/1.0\r\n\r\n" => 1], + [ "GET http://[4712::abcd]:8000/ HTTP/1.0\r\n\r\n" => 1], + [ "GET http://4713::abcd:8001/ HTTP/1.0\r\n\r\n" => 400], + [ "GET / HTTP/1.0\r\nHost: [::1]\r\n\r\n" => 1], + [ "GET / HTTP/1.0\r\nHost: [::1:2]\r\n\r\n" => 1], + [ "GET / HTTP/1.0\r\nHost: [4711::abcd]\r\n\r\n" => 1], + [ "GET / HTTP/1.0\r\nHost: [4711::abcd:1]\r\n\r\n" => 1], + [ "GET / HTTP/1.0\r\nHost: [4711:abcd::]\r\n\r\n" => 1], + [ "GET / HTTP/1.0\r\nHost: [4711::abcd]:8000\r\n\r\n" => 1], + [ "GET / HTTP/1.0\r\nHost: 4714::abcd:8001\r\n\r\n" => 200, 400], + [ "GET / HTTP/1.0\r\nHost: abc\xa0\r\n\r\n" => 200, 400], + [ "GET / HTTP/1.0\r\nHost: abc\\foo\r\n\r\n" => 400], + [ "GET http://foo/ HTTP/1.0\r\nHost: bar\r\n\r\n" => 200], + [ "GET http://foo:81/ HTTP/1.0\r\nHost: bar\r\n\r\n" => 200], + [ "GET http://[::1]:81/ HTTP/1.0\r\nHost: bar\r\n\r\n" => 200], + [ "GET http://10.0.0.1:81/ HTTP/1.0\r\nHost: bar\r\n\r\n" => 200], + [ "GET / HTTP/1.0\r\nHost: foo-bar.example.com\r\n\r\n" => 200], + [ "GET / HTTP/1.0\r\nHost: foo_bar.example.com\r\n\r\n" => 200, 200, $test_underscore], + [ "GET http://foo_bar/ HTTP/1.0\r\n\r\n" => 200, 200, $test_underscore], + + # + # tests for response headers + # + # Everything after the leading "R" will be sent encoded + # to .../send_hdr.pl which will decode it and include it + # in the response headers. + [ "R" . "Foo: bar" => 200 ], + [ "R" . "Foo:" => 200 ], + [ "R" . ": bar" => 500 ], + [ "R" . "F\0oo: bar" => 500 ], + [ "R" . "F\x01oo: bar" => 500 ], + [ "R" . "F\noo: bar" => 500 ], + [ "R" . "Foo: b\tar" => 200 ], + [ "R" . "Foo: b\x01ar" => 500 ], + # XXX ap_scan_script_header() eats the \r + #[ "R" . "F\roo: bar" => 500 ], + #[ "R" . "Foo: bar\rBaz: h" => 500 ], + + # + # implementation regression tests + # + # `Header always set <bad value>` followed by a <bad field name> + # should not cause a recursion loop + [ "GET /regression-header HTTP/1.1\r\nHost:localhost\r\n\r\n" => 500, 500, + have_module qw(mod_headers) ], +); + +my $test_fold = defined(&need_min_apache_fix) ? + need_min_apache_fix("2.2.33", "2.4.26", "2.5.0") : + need_min_apache_version('2.4.26'); + +plan tests => scalar(@test_cases) * 2 + $test_fold * 2, + need_min_apache_version('2.2.32'); + +foreach my $vhosts ((["http_unsafe" => 1], ["http_strict" => 2])) { + my $vhost = $vhosts->[0]; + my $expect_column = $vhosts->[1]; + + foreach my $t (@test_cases) { + my $req = $t->[0]; + my $expect = $t->[$expect_column]; + $expect = $t->[1] if (! defined $expect); + my $cond = $t->[3]; + my $decoded; + + if ($req =~ s/^R//) { + if (!have_cgi) { + skip "Skipping test without CGI module"; + next; + } + $decoded = $req; + my $q = encode_base64($decoded); + chomp $q; + $req = "GET /apache/http_strict/send_hdr.pl?$q HTTP/1.0\r\n\r\n"; + } + + if (defined $cond && not $cond) { + $req = escape($req); + print "# SKIPPING:\n# $req\n"; + skip "Test prerequisites are not met"; + next; + } + + my $sock = Apache::TestRequest::vhost_socket($vhost); + if (!$sock) { + print "# failed to connect\n"; + ok(0); + next; + } + $sock->print($req); + $sock->shutdown(1); + sleep(0.1); + $req = escape($req); + print "# SENDING:\n# $req\n"; + print "# DECODED: " . escape($decoded) . "\n" if $decoded; + + my $response_data = ""; + my $buf; + while ($sock->read($buf, 10000) > 0) { + $response_data .= $buf; + } + my $response = HTTP::Response->parse($response_data); + if ($decoded) { + $response_data =~ s/<title>.*/.../s; + my $out = escape($response_data); + $out =~ s{\\n}{\\n\n# }g; + print "# RESPONSE:\n# $out\n"; + } + if (! defined $response) { + die "HTTP::Response->parse failed"; + } + my $rc = $response->code; + if (! defined $rc) { + if (! defined $expect) { + print "# expecting dropped connection and HTTPD dropped connection\n"; + ok(1); + } + else { + print "# expecting $expect, but HTTPD dropped the connection\n"; + ok(0); + } + } + elsif ($expect > 100) { + print "# expecting $expect, got ", $rc, "\n"; + ok ($response->code == $expect); + } + elsif ($expect == 90) { + print "# expecting headerless HTTP/0.9 body, got response\n"; + ok (1); + } + elsif ($expect) { + print "# expecting success, got ", $rc, "\n"; + ok ($rc >= 200 && $rc < 400); + } + else { + print "# expecting error, got ", $rc, "\n"; + ok ($rc >= 400); + } + } +} + +if ($test_fold) { + my $resp; + my $foo; + $resp = GET("/fold"); + $foo = $resp->header("Foo"); + ok ($resp->code == 200); + ok (defined($foo) && $foo =~ /Bar Baz/); +} + +sub escape +{ + my $in = shift; + $in =~ s{\\}{\\\\}g; + $in =~ s{\r}{\\r}g; + $in =~ s{\n}{\\n}g; + $in =~ s{\t}{\\t}g; + $in =~ s{([\x00-\x1f])}{sprintf("\\x%02x", ord($1))}ge; + return $in; +} diff --git a/debian/perl-framework/t/apache/if_sections.t b/debian/perl-framework/t/apache/if_sections.t new file mode 100644 index 0000000..12d591a --- /dev/null +++ b/debian/perl-framework/t/apache/if_sections.t @@ -0,0 +1,76 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestRequest; +use Apache::TestUtil; + +# +# Test <If > section merging +# + +plan tests => (have_min_apache_version('2.4.26') ? 23 : 11) * 2, + need need_lwp, + need_module('mod_headers'), + need_module('mod_proxy'), + need_module('mod_proxy_http'), + need_min_apache_version('2.3.8'); + + +sub do_test +{ + my $url = shift; + my $set = shift; + my $expect = shift; + + $url = "/if_sec$url"; + + my @headers_to_set = split(/\s+/, $set); + my @headers = map { ("In-If$_" => 1) } @headers_to_set; + + my $response = GET($url, @headers); + print "# $url with '$set':\n"; + ok t_cmp($response->code, 200); + ok t_cmp($response->header("Out-Trace"), $expect); +} + +do_test('/', '', undef); +do_test('/foo.if_test', '', undef); +do_test('/foo.if_test', '1', 'global1'); + +if (have_min_apache_version('2.4.26')) { + do_test('/foo.if_test', '1 11', 'global1, nested11, nested113'); + do_test('/foo.if_test', '1 11 111', 'global1, nested11, nested111'); + do_test('/foo.if_test', '1 11 112', 'global1, nested11, nested112'); +} + +do_test('/foo.if_test', '1 2', 'global1, files2'); +do_test('/dir/foo.txt', '1 2', 'global1, dir1, dir2, dir_files1'); +do_test('/dir/', '1 2', 'global1, dir1, dir2'); + +if (have_min_apache_version('2.4.26')) { + do_test('/dir/', '1 11', 'global1, dir1, nested11, nested113'); + do_test('/dir/', '1 11 111', 'global1, dir1, nested11, nested111'); + do_test('/dir/', '1 11 112', 'global1, dir1, nested11, nested112'); +} + +do_test('/loc/', '1 2', 'global1, loc1, loc2'); +do_test('/loc/foo.txt', '1 2', 'global1, loc1, loc2'); + +if (have_min_apache_version('2.4.26')) { + do_test('/loc/', '1 11', 'global1, loc1, nested11, nested113'); + do_test('/loc/', '1 11 111', 'global1, loc1, nested11, nested111'); + do_test('/loc/', '1 11 112', 'global1, loc1, nested11, nested112'); +} + +do_test('/loc/foo.if_test', '1 2', 'global1, files2, loc1, loc2'); + +if (have_min_apache_version('2.4.26')) { + do_test('/loc/foo.if_test', '1 2 11', 'global1, files2, loc1, loc2, nested11, nested113'); + do_test('/loc/foo.if_test', '1 2 11 111', 'global1, files2, loc1, loc2, nested11, nested111'); + do_test('/loc/foo.if_test', '1 2 11 112', 'global1, files2, loc1, loc2, nested11, nested112'); +} + +do_test('/proxy/', '1 2', 'global1, locp1, locp2'); +do_test('/proxy/', '2', 'locp2'); + diff --git a/debian/perl-framework/t/apache/iffile.t b/debian/perl-framework/t/apache/iffile.t new file mode 100644 index 0000000..fab15a1 --- /dev/null +++ b/debian/perl-framework/t/apache/iffile.t @@ -0,0 +1,17 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestRequest; +use Apache::TestUtil; + +# Available since 2.4.34, but quoted paths in <IfFile> fixed in 2.4.35 +plan tests => 2, + need( + need_module('mod_headers'), + need_min_apache_version('2.4.35') + ); + +my $resp = GET('/apache/iffile/document'); +ok t_cmp($resp->code, 200); +ok t_cmp($resp->header('X-Out'), "success1, success2, success3, success4, success5"); diff --git a/debian/perl-framework/t/apache/leaks.t b/debian/perl-framework/t/apache/leaks.t new file mode 100644 index 0000000..bb7b329 --- /dev/null +++ b/debian/perl-framework/t/apache/leaks.t @@ -0,0 +1,63 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestRequest; +use Apache::TestUtil; + +my $url = "/memory_track"; +my $init_iters = 2000; +my $iters = 500; + +my $active = GET_RC($url) == 200; + +my $num_tests = $init_iters + $iters * 2; +plan tests => $num_tests, + need { "mod_memory_track not activated" => $active }; + +### this doesn't seem sufficient to force all requests over a single +### persistent connection any more, is there a better trick? +Apache::TestRequest::user_agent(keep_alive => 1); +Apache::TestRequest::scheme('http'); + +my $cid = -1; +my $mem; + +# initial iterations should get workers to steady-state memory use. +foreach (1..$init_iters) { + ok t_cmp(GET_RC($url), 200, "200 response"); +} + +# now test whether c->pool memory is increasing for further +# requests on a given conn_rec (matched by id)... could track them +# all with a bit more effort. +foreach (1..$iters) { + my $r = GET $url; + + print "# iter $_\n"; + + ok t_cmp($r->code, 200, "got response"); + + my $content = $r->content; + chomp $content; + my ($key, $id, $bytes) = split ',', $content; + + print "# $key, $id, $bytes\n"; + + if ($cid == -1) { + $cid = $id; + $mem = $bytes; + ok 1; + } + elsif ($cid != $id) { + skip "using wrong connection"; + } + elsif ($bytes > $mem) { + print "# error: pool memory increased from $mem to $bytes!\n"; + ok 0; + } + else { + ok 1; + } +} + diff --git a/debian/perl-framework/t/apache/limits.t b/debian/perl-framework/t/apache/limits.t new file mode 100644 index 0000000..a475f82 --- /dev/null +++ b/debian/perl-framework/t/apache/limits.t @@ -0,0 +1,217 @@ +# +# Test the LimitRequestLine, LimitRequestFieldSize, LimitRequestFields, +# and LimitRequestBody directives. +# +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestRequest; +use Apache::TestUtil; + +# +# These values are chosen to exceed the limits in extra.conf, namely: +# +# LimitRequestLine @limitrequestline@ +# LimitRequestFieldSize 1024 +# LimitRequestFields 32 +# <Directory @SERVERROOT@/htdocs/apache/limits> +# LimitRequestBody 65536 +# </Directory> +# + +my $limitrequestlinex2 = Apache::Test::config()->{vars}->{limitrequestlinex2}; + +my @conditions = qw(requestline fieldsize fieldcount bodysize merged_fieldsize); + +my %params = ('requestline-succeed' => "/apache/limits/", + 'requestline-fail' => ("/apache/limits/" . ('a' x $limitrequestlinex2)), + 'fieldsize-succeed' => 'short value', + 'fieldsize-fail' => ('a' x 2048), + 'fieldcount-succeed' => 1, + 'fieldcount-fail' => 64, + 'bodysize-succeed' => ('a' x 1024), + 'bodysize-fail' => ('a' x 131072), + 'merged_fieldsize-succeed' => ('a' x 500), + 'merged_fieldsize-fail' => ('a' x 600), + ); +my %xrcs = ('requestline-succeed' => 200, + 'requestline-fail' => 414, + 'fieldsize-succeed' => 200, + 'fieldsize-fail' => 400, + 'fieldcount-succeed' => 200, + 'fieldcount-fail' => 400, + 'bodysize-succeed' => 200, + 'bodysize-fail' => 413, + 'merged_fieldsize-succeed' => 200, + 'merged_fieldsize-fail' => 400, + ); + +my $res; + +if (!have_min_apache_version("2.2.32")) { + $xrcs{"merged_fieldsize-fail"} = 200; +} + +# +# Two tests for each of the conditions, plus two more for the +# chunked version of the body-too-large test IFF we have the +# appropriate level of LWP support. +# + +my $no_chunking = defined($LWP::VERSION) && $LWP::VERSION < 5.60; +if ($no_chunking) { + print "# Chunked upload tests will NOT be performed;\n", + "# LWP 5.60 or later is required and you only have ", + "$LWP::VERSION installed.\n"; +} + +my $subtests = (@conditions * 2) + 2; +plan tests => $subtests, \&need_lwp; + +use vars qw($expected_rc); + +my $testnum = 1; +foreach my $cond (@conditions) { + foreach my $goodbad (qw(succeed fail)) { + my $param = $params{"$cond-$goodbad"}; + $expected_rc = $xrcs{"$cond-$goodbad"}; + my $resp; + if ($cond eq 'fieldcount') { + my %fields; + for (my $i = 1; $i <= $param; $i++) { + $fields{"X-Field-$i"} = "Testing field $i"; + } + print "# Testing LimitRequestFields; should $goodbad\n"; + $resp = GET('/apache/limits/', %fields, 'X-Subtest' => $testnum); + ok t_cmp($resp->code, + $expected_rc, + "Test #$testnum"); + if ($resp->code != $expected_rc) { + print_response($resp); + } + $testnum++; + } + elsif ($cond eq 'bodysize') { + # + # Make sure the last situation is keepalives off.. + # + foreach my $chunked (qw(1 0)) { + print "# Testing LimitRequestBody; should $goodbad\n"; + set_chunking($chunked); + # + # Note that this tests different things depending upon + # the chunking state. The content-body will not even + # be counted if the Content-Length of an unchunked + # request exceeds the server's limit; it'll just be + # drained and discarded. + # + if ($chunked) { + if ($no_chunking) { + my $msg = 'Chunked upload not tested; ' + . 'not supported by this version of LWP'; + print "# $msg\n"; + skip $msg, 1; + } + else { + my ($req, $resp, $url); + $url = Apache::TestRequest::resolve_url('/apache/limits/'); + $req = HTTP::Request->new(GET => $url); + $req->content_type('text/plain'); + $req->header('X-Subtest' => $testnum); + $req->content(chunk_it($param)); + $resp = Apache::TestRequest::user_agent->request($req); + + # limit errors with chunked request bodies get + # 400 with 1.3, not 413 - see special chunked + # request handling in ap_get_client_block in 1.3 + + local $expected_rc = 400 if $goodbad eq 'fail' && + have_apache(1); + + ok t_cmp($resp->code, + $expected_rc, + "Test #$testnum"); + if ($resp->code != $expected_rc) { + print_response($resp); + } + } + } + else { + $resp = GET('/apache/limits/', content_type => 'text/plain', + content => $param, 'X-Subtest' => $testnum); + ok t_cmp($resp->code, + $expected_rc, + "Test #$testnum"); + if ($resp->code != $expected_rc) { + print_response($resp); + } + } + $testnum++; + } + } + elsif ($cond eq 'merged_fieldsize') { + print "# Testing LimitRequestFieldSize; should $goodbad\n"; + $resp = GET('/apache/limits/', 'X-Subtest' => $testnum, + 'X-overflow-field' => $param, + 'X-overflow-field' => $param); + ok t_cmp($resp->code, + $expected_rc, + "Test #$testnum"); + if ($resp->code != $expected_rc) { + print_response($resp); + } + $testnum++; + } + elsif ($cond eq 'fieldsize') { + print "# Testing LimitRequestFieldSize; should $goodbad\n"; + $resp = GET('/apache/limits/', 'X-Subtest' => $testnum, + 'X-overflow-field' => $param); + ok t_cmp($resp->code, + $expected_rc, + "Test #$testnum"); + if ($resp->code != $expected_rc) { + print_response($resp); + } + $testnum++; + } + elsif ($cond eq 'requestline') { + print "# Testing LimitRequestLine; should $goodbad\n"; + $resp = GET($param, 'X-Subtest' => $testnum); + ok t_cmp($resp->code, + $expected_rc, + "Test #$testnum"); + if ($resp->code != $expected_rc) { + print_response($resp); + } + $testnum++; + } + } +} + +sub chunk_it { + my $str = shift; + my $delay = shift; + + $delay = 1 unless defined $delay; + return sub { + select(undef, undef, undef, $delay) if $delay; + my $l = length($str); + return substr($str, 0, ($l > 102400 ? 102400 : $l), ""); + } +} + +sub set_chunking { + my ($setting) = @_; + $setting = $setting ? 1 : 0; + print "# Chunked transfer-encoding ", + ($setting ? "enabled" : "disabled"), "\n"; + Apache::TestRequest::user_agent(keep_alive => ($setting ? 1 : 0)); +} + +sub print_response { + my ($resp) = @_; + my $str = $resp->as_string; + $str =~ s:\n:\n# :gs; + print "# Server response:\n# $str\n"; +} diff --git a/debian/perl-framework/t/apache/loglevel.t b/debian/perl-framework/t/apache/loglevel.t new file mode 100644 index 0000000..cb542d1 --- /dev/null +++ b/debian/perl-framework/t/apache/loglevel.t @@ -0,0 +1,43 @@ +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/; + +plan tests => 8, need_min_apache_version('2.3.6'); + +my $base = "/apache/loglevel"; + +t_start_error_log_watch(); + +my @error_expected =qw{ + core_info + info + crit/core_info + info/core_crit/info +}; +my @error_not_expected =qw{ + core_crit + crit + info/core_crit + crit/core_info/crit +}; + +my $dir; +foreach $dir (@error_expected) { + GET "$base/$dir/not_found_error_expected"; +} +foreach $dir (@error_not_expected) { + GET "$base/$dir/not_found_error_NOT_expected"; +} + +my @loglines = t_finish_error_log_watch(); +my $log = join("\n", @loglines); + +foreach $dir (@error_expected) { + ok($log =~ m{does not exist.*?$base/$dir/not_found_error_expected}); +} +foreach $dir (@error_not_expected) { + ok($log !~ m{does not exist.*?$base/$dir/not_found_error_NOT_expected}); +} diff --git a/debian/perl-framework/t/apache/maxranges.t b/debian/perl-framework/t/apache/maxranges.t new file mode 100644 index 0000000..015a474 --- /dev/null +++ b/debian/perl-framework/t/apache/maxranges.t @@ -0,0 +1,70 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestRequest; +use Apache::TestUtil qw(t_write_file); + +# test multi-byterange-requests with overlaps (merges) + +my $url = "/apache/chunked/byteranges.txt"; +my $file = Apache::Test::vars('serverroot') . "/htdocs$url"; + +my $content = ""; +$content .= sprintf("%04d", $_) for (1 .. 2000); +t_write_file($file, $content); +my $clen = length($content); + + +my $medrange = ""; +my $longrange = ""; +my $i; + +for (0 .. 50) { + $longrange .= "0-1,3-4,0-1,3-4,"; + if ($_ % 2) { + $medrange .= "0-1,3-4,0-1,3-4,"; + } +} + +my @test_cases = ( + { url => "/maxranges/default/byteranges.txt" , h => "0-100", status => "206"}, + { url => "/maxranges/default/byteranges.txt" , h => $medrange, status => "206"}, + { url => "/maxranges/default/byteranges.txt" , h => $longrange, status => "200"}, + + { url => "/maxranges/default-explicit/byteranges.txt" , h => "0-100", status => "206"}, + { url => "/maxranges/default-explicit/byteranges.txt" , h => $medrange, status => "206"}, + { url => "/maxranges/default-explicit/byteranges.txt" , h => $longrange, status => "200"}, + + { url => "/maxranges/none/byteranges.txt" , h => "0-100", status => "200"}, + { url => "/maxranges/none/byteranges.txt" , h => "$medrange", status => "200"}, + { url => "/maxranges/none/byteranges.txt" , h => "$longrange", status => "200"}, + + { url => "/maxranges/1/merge/none/byteranges.txt" , h => "0-100", status => "200"}, + { url => "/maxranges/1/merge/none/byteranges.txt" , h => "$medrange", status => "200"}, + { url => "/maxranges/1/merge/none/byteranges.txt" , h => "$longrange", status => "200"}, + + { url => "/maxranges/1/byteranges.txt" , h => "0-100", status => "206"}, + { url => "/maxranges/1/byteranges.txt" , h => "0-100,200-300", status => "200"}, + { url => "/maxranges/2/byteranges.txt" , h => "0-100,200-300", status => "206"}, + { url => "/maxranges/2/byteranges.txt" , h => "0-100,200-300,400-500", status => "200"}, + { url => "/maxranges/unlimited/byteranges.txt" , h => "0-100", status => "206"}, + { url => "/maxranges/unlimited/byteranges.txt" , h => "$medrange", status => "206"}, + { url => "/maxranges/unlimited/byteranges.txt" , h => "$longrange", status => "206"}, + +); +plan tests => scalar(@test_cases), need need_lwp, need_min_apache_version('2.3.15') || need_min_apache_version('2.2.21'), + need_module('mod_alias'); + + +foreach my $test (@test_cases) { + my $result = GET $test->{"url"}, "Range" => "bytes=" . $test->{"h"} ; + my $boundary; + my $ctype = $result->header("Content-Type"); + if ($test->{"status"} ne $result->code()) { + print "Wrong status code: " . $result->code() ."\n"; + ok(0); + next; + } + ok (1); +} diff --git a/debian/perl-framework/t/apache/mergeslashes.t b/debian/perl-framework/t/apache/mergeslashes.t new file mode 100644 index 0000000..850fc93 --- /dev/null +++ b/debian/perl-framework/t/apache/mergeslashes.t @@ -0,0 +1,117 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestRequest; +use Apache::TestUtil; +use MIME::Base64; +use Data::Dumper; +use HTTP::Response; +use Socket; + +# undef: HTTPD should drop connection without error message + +my @test_cases = ( + # request, status code global, status code 'mergeslashes off' VH, msg + [ "GET /authz_core/a/b/c/index.html HTTP/1.1\r\nHost: merge-default\r\nConnection: close\r\n\r\n" => 403, "exact match"], + [ "GET //authz_core/a/b/c/index.html HTTP/1.1\r\nHost: merge-default\r\nConnection: close\r\n\r\n" => 403, "merged even at front"], + [ "GET ///authz_core/a/b/c/index.html HTTP/1.1\r\nHost: merge-default\r\nConnection: close\r\n\r\n" => 403, "merged even at front"], + [ "GET /authz_core/a/b/c//index.html HTTP/1.1\r\nHost: merge-default\r\nConnection: close\r\n\r\n" => 403, "c// should be merged"], + [ "GET /authz_core/a//b/c/index.html HTTP/1.1\r\nHost: merge-default\r\nConnection: close\r\n\r\n" => 403, "a// should be merged"], + [ "GET /authz_core/a//b/c/index.html HTTP/1.1\r\nHost: merge-disabled\r\nConnection: close\r\n\r\n" => 403, "a// matches locationmatch"], + [ "GET /authz_core/a/b/c//index.html HTTP/1.1\r\nHost: merge-disabled\r\nConnection: close\r\n\r\n" => 200, "c// doesn't match locationmatch"], + [ "GET /authz_core/a/b/d/index.html HTTP/1.1\r\nHost: merge-disabled\r\nConnection: close\r\n\r\n" => 403, "baseline failed", need_min_apache_version('2.4.47')], + [ "GET /authz_core/a/b//d/index.html HTTP/1.1\r\nHost: merge-disabled\r\nConnection: close\r\n\r\n" => 403, "b//d not merged for Location with OFF",need_min_apache_version('2.4.47')], +); + +plan tests => scalar(@test_cases), need_min_apache_version('2.4.39'); + + + foreach my $t (@test_cases) { + my $req = $t->[0]; + my $expect = $t->[1]; + my $desc = $t->[2]; + my $cond = $t->[3]; + my $decoded; + + if (defined($cond) && !$cond) { + skip("n/a"); + } + + my $sock = Apache::TestRequest::vhost_socket("core"); + if (!$sock) { + print "# failed to connect\n"; + ok(0); + next; + } + + $sock->print($req); + sleep(0.1); + $req = escape($req); + print "# SENDING to " . peer($sock) . "\n# $req\n"; + + my $response_data = ""; + my $buf; + while ($sock->read($buf, 10000) > 0) { + $response_data .= $buf; + } + my $response = HTTP::Response->parse($response_data); + if ($decoded) { + $response_data =~ s/<title>.*/.../s; + my $out = escape($response_data); + $out =~ s{\\n}{\\n\n# }g; + print "# RESPONSE:\n# $out\n"; + } + if (! defined $response) { + die "HTTP::Response->parse failed"; + } + my $rc = $response->code; + if (! defined $rc) { + if (! defined $expect) { + print "# expecting dropped connection and HTTPD dropped connection\n"; + ok(1); + } + else { + print "# expecting $expect, but HTTPD dropped the connection\n"; + ok(0); + } + } + elsif ($expect > 100) { + print "# expected $expect, got " . $response->code . " for $desc\n"; + ok ($response->code, $expect, $desc ); + } + elsif ($expect == 90) { + print "# expecting headerless HTTP/0.9 body, got response\n"; + ok (1); + } + elsif ($expect) { + print "# expecting success, got ", $rc, ": $desc\n"; + ok ($rc >= 200 && $rc < 400); + } + else { + print "# expecting error, got ", $rc, ": $desc\n"; + ok ($rc >= 400); + } + } + +sub escape +{ + my $in = shift; + $in =~ s{\\}{\\\\}g; + $in =~ s{\r}{\\r}g; + $in =~ s{\n}{\\n}g; + $in =~ s{\t}{\\t}g; + $in =~ s{([\x00-\x1f])}{sprintf("\\x%02x", ord($1))}ge; + return $in; +} + +sub peer +{ + my $sock = shift; + my $hersockaddr = getpeername($sock); + return "<disconnected>" if !$hersockaddr; + my ($port, $iaddr) = sockaddr_in($hersockaddr); + my $herhostname = gethostbyaddr($iaddr, AF_INET); + my $herstraddr = inet_ntoa($iaddr); + return "$herstraddr:$port"; +} diff --git a/debian/perl-framework/t/apache/mmn.t b/debian/perl-framework/t/apache/mmn.t new file mode 100644 index 0000000..985a8e6 --- /dev/null +++ b/debian/perl-framework/t/apache/mmn.t @@ -0,0 +1,42 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; + +# +# check that the comment and the #define in ap_mmn.h are equal +# + +plan tests => 2, need_apache 2; + +my $config = Apache::TestConfig->thaw(); +my $filename = $config->apxs('INCLUDEDIR') . '/ap_mmn.h'; + +my $cmajor; +my $cminor; +my $major; +my $minor; +my $skip; +if (open(my $fh, "<", $filename)) { + while (defined (my $line = <$fh>)) { + if ($line =~ m/^\s+[*]\s+(\d{8})[.](\d+)\s+\([\d.]+(?:-dev)?\)\s/ ) { + $cmajor = $1; + $cminor = $2; + } + elsif ($line =~ m{^#define\s+MODULE_MAGIC_NUMBER_MAJOR\s+(\d+)(?:\s|$)}) + { + $major = $1; + } + elsif ($line =~ m{^#define\s+MODULE_MAGIC_NUMBER_MINOR\s+(\d+)(?:\s|$)}) + { + $minor = $1; + } + } + close($fh); +} +else { + $skip = "Skip if can't read $filename"; +} + +skip($skip, $major, $cmajor); +skip($skip, $minor, $cminor); diff --git a/debian/perl-framework/t/apache/options.t b/debian/perl-framework/t/apache/options.t new file mode 100644 index 0000000..93809b7 --- /dev/null +++ b/debian/perl-framework/t/apache/options.t @@ -0,0 +1,17 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestUtil; +use Apache::TestRequest; + +my @urls = qw(/); + +plan tests => @urls * 2, \&need_lwp; + +for my $url (@urls) { + my $res = OPTIONS $url; + ok t_cmp $res->code, 200, "code"; + my $allow = $res->header('Allow') || ''; + ok t_cmp $allow, qr/OPTIONS/, "OPTIONS"; +} diff --git a/debian/perl-framework/t/apache/passbrigade.t b/debian/perl-framework/t/apache/passbrigade.t new file mode 100644 index 0000000..a31f29f --- /dev/null +++ b/debian/perl-framework/t/apache/passbrigade.t @@ -0,0 +1,7 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::TestCommon (); + +Apache::TestCommon::run_write_test('test_pass_brigade'); + diff --git a/debian/perl-framework/t/apache/post.t b/debian/perl-framework/t/apache/post.t new file mode 100644 index 0000000..8c58847 --- /dev/null +++ b/debian/perl-framework/t/apache/post.t @@ -0,0 +1,12 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestCommon (); + +my $module = 'eat_post'; +my $num = Apache::TestCommon::run_post_test_sizes(); + +plan tests => $num, need need_lwp, need_module($module); + +Apache::TestCommon::run_post_test($module); diff --git a/debian/perl-framework/t/apache/pr17629.t b/debian/perl-framework/t/apache/pr17629.t new file mode 100644 index 0000000..a089e98 --- /dev/null +++ b/debian/perl-framework/t/apache/pr17629.t @@ -0,0 +1,51 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestUtil; +use Apache::TestRequest; + +plan tests => 4, need [need_cgi, qw(include deflate case_filter)]; +my $inflator = "/modules/deflate/echo_post"; + +my @deflate_headers; +push @deflate_headers, "Accept-Encoding" => "gzip"; + +my @inflate_headers; +push @inflate_headers, "Content-Encoding" => "gzip"; + +# The SSI script has the DEFLATE filter applied. +# The SSI includes a CGI script. +# The CGI script has the CASE filter applied. +# The CGI script returns a redirect to /foobar.html. +# The flat file does not have the DEFLATE filter applied. + +# The test is that the internal redirect when applied to the +# subrequest must retain the DEFLATE filter in the filter chain, but +# must lose the CASE filter. + +my $uri = "/modules/deflate/ssi/ssi.shtml"; + +my $content = GET_BODY($uri); + +my $expected = "begin-foobar-end\n"; + +ok t_cmp($content, $expected); + +my $r = GET($uri, @deflate_headers); + +ok t_cmp($r->code, 200); + +my $renc = $r->header("Content-Encoding") || ""; + +ok t_cmp($renc, "gzip", "response was gzipped"); + +if ($renc eq "gzip") { + my $deflated = POST_BODY($inflator, @inflate_headers, + content => $r->content); + + ok t_cmp($deflated, $expected); +} +else { + skip "response not gzipped"; +} diff --git a/debian/perl-framework/t/apache/pr18757.t b/debian/perl-framework/t/apache/pr18757.t new file mode 100644 index 0000000..d53262f --- /dev/null +++ b/debian/perl-framework/t/apache/pr18757.t @@ -0,0 +1,58 @@ +# +# Regression test for PR 18757. +# +# Annoyingly awkward to write because LWP is a poor excuse for an HTTP +# interface and will lie about what response headers are sent, so this +# must be yet another test which speaks TCP directly. +# + +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestUtil; +use Apache::TestRequest; + +plan tests => 3, need 'proxy', need_min_apache_version('2.2.1'), need_cgi; + +Apache::TestRequest::module("mod_proxy"); + +my $path = "/index.html"; + +my $r = GET($path); + +ok t_cmp($r->code, 200, "200 response from GET"); + +my $clength = $r->content_length; + +t_debug("expected C-L is $clength"); + +my $url = Apache::TestRequest::resolve_url($path); +my $hostport = Apache::TestRequest::hostport(); +my $sock = Apache::TestRequest::vhost_socket("mod_proxy"); + +t_debug "URL via proxy is $url"; + +ok $sock; + +$sock->print("HEAD $url HTTP/1.1\r\n"); +$sock->print("Host: $hostport\r\n"); +$sock->print("\r\n"); + +my $ok = 0; +my $response; + +do { + chomp($response = Apache::TestRequest::getline($sock) || ''); + $response =~ s/\s$//; + + t_debug("line: $response"); + + if ($response =~ /Content-Length: $clength/) { + $ok = 1; + } + +} +while ($response ne ""); + +ok t_cmp($ok, 1, "whether proxy strips Content-Length header"); diff --git a/debian/perl-framework/t/apache/pr35292.t b/debian/perl-framework/t/apache/pr35292.t new file mode 100644 index 0000000..9a6243e --- /dev/null +++ b/debian/perl-framework/t/apache/pr35292.t @@ -0,0 +1,33 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestUtil; +use Apache::TestRequest; + +$SIG{PIPE} = 'IGNORE'; + +plan tests => 3, need_min_apache_version('2.1.8'); + +my $sock = Apache::TestRequest::vhost_socket('default'); +ok $sock; + +Apache::TestRequest::socket_trace($sock); + +$sock->print("POST /apache/limits/ HTTP/1.1\r\n"); +$sock->print("Host: localhost\r\n"); +$sock->print("Content-Length: 1048576\r\n"); +$sock->print("\r\n"); + +foreach (1..128) { + $sock->print('x'x8192) if $sock->connected; +} + +# Before the PR 35292 fix, the socket would already have been reset by +# this point and most clients will have stopped sending and gone away. + +ok $sock->connected; + +my $line = Apache::TestRequest::getline($sock) || ''; + +ok t_cmp($line, qr{^HTTP/1\.. 413}, "read response-line"); diff --git a/debian/perl-framework/t/apache/pr35330.t b/debian/perl-framework/t/apache/pr35330.t new file mode 100644 index 0000000..e5fe01f --- /dev/null +++ b/debian/perl-framework/t/apache/pr35330.t @@ -0,0 +1,16 @@ +# +# Regression test for PR 35330 +# +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestRequest; +use Apache::TestUtil; + +plan tests => 2, need 'include'; + +my $r = GET '/apache/htaccess/override/hello.shtml'; + +ok t_cmp($r->code, 200, "SSI was allowed for location"); +ok t_cmp($r->content, "hello", "file was served with correct content"); diff --git a/debian/perl-framework/t/apache/pr37166.t b/debian/perl-framework/t/apache/pr37166.t new file mode 100644 index 0000000..919cda2 --- /dev/null +++ b/debian/perl-framework/t/apache/pr37166.t @@ -0,0 +1,29 @@ +# +# Regression test for PR 37166 +# +# r370692 determined that a CGI script which outputs an explicit +# "Status: 200" will not be subject to conditional request processing. +# Previous behaviour was the opposite, but fell foul of the r->status +# vs r->status_line issue fixed in r385581. +# +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestRequest; +use Apache::TestUtil; + +plan tests => 4, \&need_cgi; + +my $uri = '/modules/cgi/pr37166.pl'; + +my $r = GET $uri; + +ok t_cmp($r->code, 200, "SSI was allowed for location"); +ok t_cmp($r->content, "Hello world\n", "file was served with correct content"); + +$r = GET $uri, "If-Modified-Since" => "Tue, 15 Feb 2005 15:00:00 GMT"; + +ok t_cmp($r->code, 200, "explicit 200 response"); +ok t_cmp($r->content, "Hello world\n", + "file was again served with correct content"); diff --git a/debian/perl-framework/t/apache/pr43939.t b/debian/perl-framework/t/apache/pr43939.t new file mode 100644 index 0000000..5e35f9e --- /dev/null +++ b/debian/perl-framework/t/apache/pr43939.t @@ -0,0 +1,47 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestUtil; +use Apache::TestRequest; + +plan tests => 4, need [need_cgi, qw(include deflate case_filter)]; +my $inflator = "/modules/deflate/echo_post"; + +my @deflate_headers; +push @deflate_headers, "Accept-Encoding" => "gzip"; + +my @inflate_headers; +push @inflate_headers, "Content-Encoding" => "gzip"; + +# The SSI script has the DEFLATE filter applied. +# The SSI includes directory index page. +# The directory index page is processed with a fast internal redirect. + +# The test is that filter chain survives across the redirect. + +my $uri = "/modules/deflate/ssi/ssi2.shtml"; + +my $content = GET_BODY($uri); + +my $expected = "begin-default-end\n"; + +ok t_cmp($content, $expected); + +my $r = GET($uri, @deflate_headers); + +ok t_cmp($r->code, 200); + +my $renc = $r->header("Content-Encoding") || ""; + +ok t_cmp($renc, "gzip", "response was gzipped"); + +if ($renc eq "gzip") { + my $deflated = POST_BODY($inflator, @inflate_headers, + content => $r->content); + + ok t_cmp($deflated, $expected); +} +else { + skip "response not gzipped"; +} diff --git a/debian/perl-framework/t/apache/pr49328.t b/debian/perl-framework/t/apache/pr49328.t new file mode 100644 index 0000000..5b37032 --- /dev/null +++ b/debian/perl-framework/t/apache/pr49328.t @@ -0,0 +1,25 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestUtil; +use Apache::TestRequest; + +plan tests => 1, need [qw(filter include deflate)]; + +my $inflator = "/modules/deflate/echo_post"; + +my @deflate_headers; +push @deflate_headers, "Accept-Encoding" => "gzip"; + +my @inflate_headers; +push @inflate_headers, "Content-Encoding" => "gzip"; + +my $uri = "/modules/filter/pr49328/pr49328.shtml"; + +my $content = GET_BODY($uri, @deflate_headers); + +my $deflated = POST_BODY($inflator, @inflate_headers, + content => $content); + +ok t_cmp($deflated, "before\nincluded\nafter\n"); diff --git a/debian/perl-framework/t/apache/rwrite.t b/debian/perl-framework/t/apache/rwrite.t new file mode 100644 index 0000000..e27808c --- /dev/null +++ b/debian/perl-framework/t/apache/rwrite.t @@ -0,0 +1,6 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::TestCommon (); + +Apache::TestCommon::run_write_test('test_rwrite'); diff --git a/debian/perl-framework/t/apache/server_name_port.t b/debian/perl-framework/t/apache/server_name_port.t new file mode 100644 index 0000000..2597d7c --- /dev/null +++ b/debian/perl-framework/t/apache/server_name_port.t @@ -0,0 +1,135 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestRequest; +use Socket; + +# send +# arg #1: url prefix +# arg #2: Host header (none if undef) +# expected results: +# arg #3: response code +# arg #4: SERVER_NAME +# arg #5: SERVER_PORT (canonical port if 'REMOTE') +# undef == don't care + +my $url_suffix = 'modules/cgi/env.pl'; + +my @test_cases = ( + [ "/", "righthost" => 200, 'righthost', 'REMOTE' ], + [ "/", "righthost:123" => 200, 'righthost', '123' ], + [ "/", "Righthost" => 200, 'righthost', 'REMOTE' ], + [ "/", "Righthost:123" => 200, 'righthost', '123' ], + [ "/", "128.0.0.1" => 200, '128.0.0.1', 'REMOTE' ], + [ "/", "128.0.0.1:123" => 200, '128.0.0.1', '123' ], + [ "/", "[::1]" => 200, '[::1]', 'REMOTE' ], + [ "/", "[::1]:123" => 200, '[::1]', '123' ], + [ "/", "[a::1]" => 200, '[a::1]', 'REMOTE' ], + [ "/", "[a::1]:123" => 200, '[a::1]', '123' ], + [ "/", "[A::1]" => 200, '[a::1]', 'REMOTE' ], + [ "/", "[A::1]:123" => 200, '[a::1]', '123' ], + [ "http://righthost/", undef => 200, 'righthost', 'REMOTE' ], + [ "http://righthost:123/", undef => 200, 'righthost', '123' ], + [ "http://Righthost/", undef => 200, 'righthost', 'REMOTE' ], + [ "http://Righthost:123/", undef => 200, 'righthost', '123' ], + [ "http://128.0.0.1/", undef => 200, '128.0.0.1', 'REMOTE' ], + [ "http://128.0.0.1:123/", undef => 200, '128.0.0.1', '123' ], + [ "http://[::1]/", undef => 200, '[::1]', 'REMOTE' ], + [ "http://[::1]:123/", undef => 200, '[::1]', '123' ], + [ "http://righthost/", "wronghost" => 200, 'righthost', 'REMOTE' ], + [ "http://righthost:123/", "wronghost:321" => 200, 'righthost', '123' ], + [ "http://Righthost/", "wronghost" => 200, 'righthost', 'REMOTE' ], + [ "http://Righthost:123/", "wronghost:321" => 200, 'righthost', '123' ], + [ "http://128.0.0.1/", "126.0.0.1" => 200, '128.0.0.1', 'REMOTE' ], + [ "http://128.0.0.1:123/", "126.0.0.1:321" => 200, '128.0.0.1', '123' ], + [ "http://[::1]/", "[::2]" => 200, '[::1]', 'REMOTE' ], + [ "http://[::1]:123/", "[::2]:321" => 200, '[::1]', '123' ], +); + +my @todo; +if (!have_min_apache_version('2.4.24')) { + # r1426827 + push @todo, 32, 35, 56, 59, 80, 83; +} +if (!have_min_apache_version('2.4')) { + # r1147614, PR 26005 + push @todo, 20, 23, 26, 29; +} + +plan tests => 3 * scalar(@test_cases), todo => \@todo, need need_min_apache_version('2.2'), need_cgi; + +foreach my $t (@test_cases) { + my $req = "GET $t->[0]$url_suffix HTTP/1.1\r\nConnection: close\r\n"; + $req .= "Host: $t->[1]\r\n" if defined $t->[1]; + $req .= "\r\n"; + + my %ex = ( + rc => $t->[2], + SERVER_NAME => $t->[3], + SERVER_PORT => $t->[4], + ); + + my $sock = Apache::TestRequest::vhost_socket(); + if (!$sock) { + print "# failed to connect\n"; + ok(0); + next; + } + if (defined $ex{SERVER_PORT} && $ex{SERVER_PORT} eq 'REMOTE') { + my $peername = getpeername($sock); + my ($port) = sockaddr_in($peername); + $ex{SERVER_PORT} = "$port"; + } + + $sock->print($req); + $sock->shutdown(1); + sleep(0.1); + print "# SENDING:\n# ", escape($req), "\n"; + + my $response_data = ""; + my $buf; + while ($sock->read($buf, 10000) > 0) { + $response_data .= $buf; + } + my $response = HTTP::Response->parse($response_data); + if (! defined $response) { + die "HTTP::Response->parse failed"; + } + my $rc = $response->code; + if (! defined $rc) { + print "# HTTPD dropped the connection\n"; + ok(0); + } + else { + print "# expecting $ex{rc}, got ", $rc, "\n"; + ok ($rc == $ex{rc}); + } + + foreach my $var (qw/SERVER_NAME SERVER_PORT/) { + if (! defined $ex{$var}) { + print "# don't care about $var\n"; + ok(1); + } + elsif ($response_data =~ /^$var = (.*)$/m) { + my $val = $1; + print "# got $var='$val', expected '$ex{$var}'\n"; + ok($val eq $ex{$var}); + } + else { + print "# no $var in response, expected '$ex{$var}'\n"; + ok(0); + } + } +} + +sub escape +{ + my $in = shift; + $in =~ s{\\}{\\\\}g; + $in =~ s{\r}{\\r}g; + $in =~ s{\n}{\\n}g; + $in =~ s{\t}{\\t}g; + $in =~ s{([\x00-\x1f])}{sprintf("\\x%02x", ord($1))}ge; + return $in; +} diff --git a/debian/perl-framework/t/apache/teclchunk.t b/debian/perl-framework/t/apache/teclchunk.t new file mode 100644 index 0000000..b804368 --- /dev/null +++ b/debian/perl-framework/t/apache/teclchunk.t @@ -0,0 +1,57 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestUtil; +use Apache::TestCommon (); +use Apache::TestRequest (); + +my $module = 'default'; + +if (!have_min_apache_version('2.5.0')) { + print "1..0 # skip: Not supported yet"; + exit 0; +} + +plan tests => 4, ['echo_post_chunk']; + +my $sock = Apache::TestRequest::vhost_socket($module); +ok $sock; + +Apache::TestRequest::socket_trace($sock); +$sock->print("POST /echo_post_chunk HTTP/1.1\r\n"); +$sock->print("Host: localhost\r\n"); +$sock->print("Content-Length: 77\r\n"); +$sock->print("Transfer-Encoding: chunked\r\n"); +$sock->print("\r\n"); +$sock->print("0\r\n"); +$sock->print("X-Chunk-Trailer: $$\r\n"); +$sock->print("\r\n"); +$sock->print("GET /i_do_not_exist_in_your_wildest_imagination HTTP/1.1\r\n"); +$sock->print("Host: localhost\r\n"); + +# Read the status line +chomp(my $response = Apache::TestRequest::getline($sock) || ''); +$response =~ s/\s$//; +ok t_cmp($response, "HTTP/1.1 200 OK", "response codes"); + +# Read the rest +do { + chomp($response = Apache::TestRequest::getline($sock)); + $response =~ s/\s$//; +} +while ($response ne ""); + +# Do the next request... that MUST fail. +$sock->print("\r\n"); +$sock->print("\r\n"); + +# read the trailer (pid) +$response = Apache::TestRequest::getline($sock); +chomp($response) if (defined($response)); +ok t_cmp($response, "$$", "trailer (pid)"); + +# Make sure we have not received a 404. +chomp($response = Apache::TestRequest::getline($sock) || 'NO'); +$response =~ s/\s$//; +ok t_cmp($response, "NO", "no response"); |