cvs commit: modperl-2.0/t/filter/TestFilter in_bbs_inject_header.pm
stas2003/10/03 15:41:39
Added: t/filter in_bbs_inject_header.t
t/filter/TestFilter in_bbs_inject_header.pm
Log:
this filter demonstrates two things:
1. how to write a filter that will work only on HTTP headers
2. how to inject extra HTTP headers
- it still needs a bit of work
Revision ChangesPath
1.1 modperl-2.0/t/filter/in_bbs_inject_header.t
Index: in_bbs_inject_header.t
===
use strict;
use warnings FATAL => 'all';
use Apache::Test ();
use Apache::TestUtil;
use Apache::TestRequest;
my $module = 'TestFilter::in_bbs_inject_header';
my $location = "/" . Apache::TestRequest::module2path($module);
Apache::TestRequest::scheme('http'); #force http for t/TEST -ssl
Apache::TestRequest::module($module);
my $config = Apache::Test::config();
my $hostport = Apache::TestRequest::hostport($config);
t_debug("connecting to $hostport");
print POST_BODY_ASSERT $location, content => "whatever";
1.1 modperl-2.0/t/filter/TestFilter/in_bbs_inject_header.pm
Index: in_bbs_inject_header.pm
===
package TestFilter::in_bbs_inject_header;
# this filter demonstrates two things:
# 1. how to write a filter that will work only on HTTP headers
# 2. how to inject extra HTTP headers
#
# the first task is simple -- as soon as a bucket which matches
# /^[\r\n]+$/ is read we can store that event in the filter context and
# simply 'return Apache::DECLINED on the future invocation, so not to
# slow things.
#
#
# the second task is a bit trickier, as the headers_in core httpd
# filter is picky and it wants each header to arrive in a separate
# bucket, and moreover this bucket needs to be in its own brigade.
# so this test arranges for this to happen.
#
# the test shows how to push headers at the end of all headers
# and in the middle, whichever way you prefer.
use strict;
use warnings;# FATAL => 'all';
use base qw(Apache::Filter);
use Apache::RequestRec ();
use Apache::RequestIO ();
use APR::Brigade ();
use APR::Bucket ();
use Apache::Test;
use Apache::TestUtil;
use Apache::TestTrace;
use Apache::Const -compile => qw(OK DECLINED);
use APR::Const-compile => ':common';
my $header1_key = 'X-My-Protocol';
my $header1_val = 'POST-IT';
my %headers = (
'X-Extra-Header2' => 'Value 2',
'X-Extra-Header3' => 'Value 3',
);
# returns 1 if a bucket with a header was inserted to the $bb's tail,
# otherwise returns 0 (i.e. if there are no buckets to insert)
sub inject_header_bucket {
my ($bb, $ctx) = @_;
return 0 unless @{ $ctx->{buckets} };
my $bucket = shift @{ $ctx->{buckets} };
$bb->insert_tail($bucket);
if (1) {
# extra debug, wasting cycles
my $data;
$bucket->read($data);
debug "injected header: [$data]";
}
else {
debug "injected header";
}
# next filter invocations will bring the request body if any
if ($ctx->{seen_body_separator} && [EMAIL PROTECTED] $ctx->{buckets} }) {
$ctx->{done_with_headers} = 1;
$ctx->{seen_body_separator} = 0;
}
return 1;
}
sub handler : FilterConnectionHandler {
my($filter, $bb, $mode, $block, $readbytes) = @_;
debug join '', "-" x 20 , " filter called ", "-" x 20;
use Data::Dumper;
warn Dumper $filter->ctx;
my $ctx;
unless ($ctx = $filter->ctx) {
debug "filter context init";
$ctx = {
buckets => [],
done_with_headers => 0,
seen_body_separator => 0,
};
# since we are going to manipulate the reference stored in
# ctx, it's enough to store it only once, we will get the same
# reference in the following invocations of that filter
$filter->ctx($ctx);
}
# handling the HTTP request body
if ($ctx->{done_with_headers}) {
# XXX: when the bug in httpd filter will be fixed all the
# code in this branch will be replaced with $filter->remove;
# at the moment (2.0.48) it doesn't work
# so meanwhile tell the mod_perl filter core to pass-through
# the brigade unmodified
debug "passing the body through unmodified";
return Apache::DECLINED;
#my $rv = $filter->next->get_brigade($bb, $mode, $block, $readbytes);
#return $rv unless $rv == APR::SUCCESS;
#return Apache::OK;
}
# any custom HTTP header buckets to inject?
return Apache::OK if inject_header_bucket($bb, $ctx);
# normal HTTP headers processing
my $c = $filter->c;
my $ctx_bb = APR::Brigade->new($c->pool, $c->b
cvs commit: modperl-2.0/src/modules/perl modperl_io.c
stas2003/10/03 10:45:23
Modified:src/modules/perl modperl_io.c
Log:
STDOUT is O_WRONLY, not O_RDONLY (though since it's a dup op, it doesn't
really matter)
Submitted by: Steve Hay
Revision ChangesPath
1.14 +3 -3 modperl-2.0/src/modules/perl/modperl_io.c
Index: modperl_io.c
===
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_io.c,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -u -r1.13 -r1.14
--- modperl_io.c 2 Oct 2003 23:01:56 - 1.13
+++ modperl_io.c 3 Oct 2003 17:45:23 - 1.14
@@ -133,7 +133,7 @@
sv_setref_pv(sv, "Apache::RequestRec", (void*)r);
/* open my $oldout, ">&STDOUT" or die "Can't dup STDOUT: $!"; */
-status = Perl_do_open(aTHX_ handle_save, ">&STDOUT", 8, FALSE, O_RDONLY,
+status = Perl_do_open(aTHX_ handle_save, ">&STDOUT", 8, FALSE, O_WRONLY,
0, Nullfp);
if (status == 0) {
Perl_croak(aTHX_ "Failed to dup STDOUT: %_", get_sv("!", TRUE));
@@ -143,7 +143,7 @@
* have file descriptors, so STDOUT must be closed before it can
* be reopened */
Perl_do_close(aTHX_ handle, TRUE);
-status = Perl_do_open9(aTHX_ handle, ">:Apache", 8, FALSE, O_RDONLY,
+status = Perl_do_open9(aTHX_ handle, ">:Apache", 8, FALSE, O_WRONLY,
0, Nullfp, sv, 1);
if (status == 0) {
Perl_croak(aTHX_ "Failed to open STDOUT: %_", get_sv("!", TRUE));
@@ -188,7 +188,7 @@
/* Perl_do_close(aTHX_ handle_orig, FALSE); */
/* open STDOUT, ">&STDOUT_SAVED" or die "Can't dup STDOUT_SAVED: $!"; */
-status = Perl_do_open9(aTHX_ handle_orig, ">&", 2, FALSE, O_RDONLY,
+status = Perl_do_open9(aTHX_ handle_orig, ">&", 2, FALSE, O_WRONLY,
0, Nullfp, (SV*)handle, 1);
if (status == 0) {
Perl_croak(aTHX_ "Failed to restore STDOUT: %_", get_sv("!", TRUE));
cvs commit: modperl-2.0/t/htdocs/perlio - New directory
randyk 2003/10/03 19:10:07 modperl-2.0/t/htdocs/perlio - New directory
cvs commit: modperl-2.0/t/htdocs/perlio .cvsignore MoonRise.jpeg redrum.txt
randyk 2003/10/03 19:12:13 Added: t/htdocs/perlio .cvsignore MoonRise.jpeg redrum.txt Log: added some files for perlio tests. Revision ChangesPath 1.1 modperl-2.0/t/htdocs/perlio/.cvsignore Index: .cvsignore === test 1.1 modperl-2.0/t/htdocs/perlio/MoonRise.jpeg <> 1.1 modperl-2.0/t/htdocs/perlio/redrum.txt Index: redrum.txt === ALL wORk and NO play mAKes Jack A dull BoY. ALl WORK and no plAy makEs JaCk a dULl boY. All wORk AND no PLAy mAkes JACk A DULL boy. AlL WORK and nO play MAKES JacK a dUlL bOy. ALL wOrK ANd no PLAY makes JACk A dULl Boy. All woRk and NO play mAKes Jack a Dull BOY. alL work and no pLaY makeS JaCk a dull boy. aLL wORK aND nO pLAY mAKES Jack A dULL bOY.
cvs commit: modperl-2.0/t/htdocs/perlio MoonRise.jpeg
randyk 2003/10/03 19:40:16 Modified:t/htdocs/perlio MoonRise.jpeg Log: use a smaller image Revision ChangesPath 1.2 +20 -100 modperl-2.0/t/htdocs/perlio/MoonRise.jpeg <>
cvs commit: modperl-2.0/t/response/TestAPR perlio.pm
randyk 2003/10/03 20:10:48
Modified:t/response/TestAPR perlio.pm
Log:
Reviewed by: stas
add some tests within TestAPR/perlio to test reading/writing binary
and text files and also to test some CRLF and urf-8 issues.
Revision ChangesPath
1.26 +118 -2modperl-2.0/t/response/TestAPR/perlio.pm
Index: perlio.pm
===
RCS file: /home/cvs/modperl-2.0/t/response/TestAPR/perlio.pm,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -r1.25 -r1.26
--- perlio.pm 19 Sep 2003 19:54:37 - 1.25
+++ perlio.pm 4 Oct 2003 03:10:48 - 1.26
@@ -13,7 +13,7 @@
use Fcntl ();
use File::Spec::Functions qw(catfile);
-use Apache::Const -compile => 'OK';
+use Apache::Const -compile => qw(OK CRLF);
#XXX: APR::LARGE_FILES_CONFLICT constant?
#XXX: you can set to zero if largefile support is not enabled in Perl
@@ -28,7 +28,7 @@
sub handler {
my $r = shift;
-my $tests = 11;
+my $tests = 22;
$tests += 3 unless LARGE_FILES_CONFLICT;
$tests += 1 unless APR_WIN32_FILE_DUP_BUG;
@@ -221,6 +221,115 @@
}
+# tests reading and writing text and binary files
+{
+for my $file ('MoonRise.jpeg', 'redrum.txt') {
+my $in = catfile $dir, $file;
+my $out = catfile $dir, "$file.out";
+my ($apr_content, $perl_content);
+open my $rfh, "<:APR", $in, $r->pool
+or die "Cannot open $in for reading: $!";
+{
+local $/;
+$apr_content = <$rfh>;
+}
+close $rfh;
+open my $pfh, "<", $in
+or die "Cannot open $in for reading: $!";
+binmode($pfh);
+{
+local $/;
+$perl_content = <$pfh>;
+}
+close $pfh;
+ok t_cmp(length $perl_content,
+ length $apr_content,
+ "testing data size of $file");
+
+open my $wfh, ">:APR", $out, $r->pool
+or die "Cannot open $out for writing: $!";
+print $wfh $apr_content;
+close $wfh;
+ok t_cmp(-s $in,
+ -s $out,
+ "testing file size of $file");
+unlink $out;
+}
+}
+
+# tests for various CRLF and utf-8 issues
+{
+my $scratch = catfile $dir, 'scratch.dat';
+my $text;
+my $count = 2000;
+open my $wfh, ">:crlf", $scratch
+or die "Cannot open $scratch for writing: $!";
+print $wfh 'a' . ((('a' x 14) . "\n") x $count);
+close $wfh;
+open my $rfh, "<:APR", $scratch, $r->pool
+or die "Cannot open $scratch for reading: $!";
+{
+local $/;
+$text = <$rfh>;
+}
+close $rfh;
+ok t_cmp($count,
+ count_chars($text, Apache::CRLF),
+ 'testing for presence of \015\012');
+ok t_cmp($count,
+ count_chars($text, "\n"),
+ 'testing for presence of \n');
+
+open $wfh, ">:APR", $scratch, $r->pool
+or die "Cannot open $scratch for writing: $!";
+print $wfh 'a' . ((('a' x 14) . Apache::CRLF) x $count);
+close $wfh;
+open $rfh, "<:APR", $scratch, $r->pool
+or die "Cannot open $scratch for reading: $!";
+{
+local $/;
+$text = <$rfh>;
+}
+close $rfh;
+ok t_cmp($count,
+ count_chars($text, Apache::CRLF),
+ 'testing for presence of \015\012');
+ok t_cmp($count,
+ count_chars($text, "\n"),
+ 'testing for presence of \n');
+open $rfh, "<:crlf", $scratch
+or die "Cannot open $scratch for reading: $!";
+{
+local $/;
+$text = <$rfh>;
+}
+close $rfh;
+ok t_cmp(0,
+ count_chars($text, Apache::CRLF),
+ 'testing for presence of \015\012');
+ok t_cmp($count,
+ count_chars($text, "\n"),
+ 'testing for presence of \n');
+
+my $utf8 = "\x{042F} \x{0432}\x{0430}\x{0441} \x{043B}\x{044E}";
+open $wfh, ">:APR", $scratch, $r->pool
+or die "Cannot open $scratch for writing: $!";
+binmode($wfh, ':utf8');
+print $wfh $utf8;
+close $wfh;
+open $rfh, "<:APR", $scratch, $r->pool
+or die "Cannot open $scratch for reading: $!";
+binmode($rfh, ':utf8');
+{
+local $/;
+$text = <$rfh>;
+
