Mailing List Archive

The following patch *should* work. Suggestions welcome.

Best


*** Apache.pm.orig Fri Oct 13 18:43:39 2000
--- Apache.pm Fri Oct 13 18:43:35 2000
***************
*** 158,169 ****
}
*printf = \&PRINTF;

- sub WRITE {
- my($r, $buff, $length, $offset) = @_;
- my $send = substr($buff, $offset, $length);
- $r->print($send);
- }
-
sub send_cgi_header {
my($r, $headers) = @_;
my $dlm = "\015?\012"; #a bit borrowed from LWP::UserAgent
--- 158,163 ----


*** Apache.xs.orig Fri Oct 13 18:43:56 2000
--- Apache.xs Fri Oct 13 18:43:52 2000
***************
*** 1034,1039 ****
--- 1034,1091 ----
sv_setsv(ST(1), &sv_undef);
}

+
+ int
+ write(r, ...)
+ Apache r
+
+ ALIAS:
+ Apache::WRITE = 1
+
+ PREINIT:
+ STRLEN len;
+ char * buffer;
+ int sent = 0;
+
+ CODE:
+ ix = ix; /* avoid -Wall warning */
+
+ if(!mod_perl_sent_header(r, 0)) {
+ croak("HTTP headers missing. Please send HTTP headers first!");
+ XSRETURN_IV(0);
+ }
+ RETVAL = 0;
+ if (r->connection->aborted)
+ XSRETURN_UNDEF;
+
+ if(items > 2 ){
+ len = (int)SvIV(ST(2));
+ buffer = SvPV(ST(1), na);
+ if(items == 4)
+ buffer += (int)SvIV(ST(3));
+ }
+ else{
+ buffer = SvPV(ST(1), len);
+ }
+ while(len > 0){
+ sent = rwrite(buffer,
+ len < HUGE_STRING_LEN ? len : HUGE_STRING_LEN,
+ r);
+ if(sent < 0){
+ rwrite_neg_trace(r);
+ break;
+ }
+ buffer += sent;
+ len -= sent;
+ RETVAL += sent;
+ }
+
+ OUTPUT:
+ RETVAL
+
+
+
+
int
print(r, ...)
Apache r



*** http-get.t.org Fri Oct 13 18:44:05 2000
--- http-get.t Fri Oct 13 18:44:07 2000
***************
*** 7,15 ****
my(@test_scripts) = qw(test perl-status);
%get_only = map { $_,1 } qw(perl-status);

if($] > 5.003) {
! $num_tests += 3;
push @test_scripts, qw(io/perlio.pl);
}

print "1..$num_tests\n";
--- 7,18 ----
my(@test_scripts) = qw(test perl-status);
%get_only = map { $_,1 } qw(perl-status);

+ my(@sys_tests) = qw(syswrite_noheader syswrite_1 syswrite_2 syswrite_3);
+
if($] > 5.003) {
! $num_tests += 7;
push @test_scripts, qw(io/perlio.pl);
+
}

print "1..$num_tests\n";
***************
*** 42,48 ****
next if $get_only{$s};

test ++$i, ($str =~ /^REQUEST_METHOD=GET$/m);
! test ++$i, ($str =~ /^QUERY_STRING=query$/m);
}

my $mp_version;
--- 45,72 ----
next if $get_only{$s};

test ++$i, ($str =~ /^REQUEST_METHOD=GET$/m);
! test ++$i, ($str =~ /^QUERY_STRING=query$/m);
!
! if($s eq 'io/perlio.pl'){
! foreach my $h (@sys_tests){
! $url = new URI::URL("http://$netloc$script?$h");
!
! $request = new HTTP::Request('GET', $url);
!
! print "GET $url\n\n";
!
! $response = $ua->request($request, undef, undef);
!
! $str = $response->as_string;
! print "$str\n";
! if($h eq 'syswrite_noheader'){
! test ++$i, $str =~ /(Internal Server Error)/;
! }else{
! die "$1\n" if $str =~ /(Internal Server Error)/;
! test ++$i, ($response->is_success);
! }
! }
! }
}

my $mp_version;



*** perlio.pl.orig Fri Oct 13 18:44:23 2000
--- perlio.pl Fri Oct 13 18:44:20 2000
***************
*** 113,115 ****
--- 113,164 ----

}

+ sub test_syswrite_1{
+ test_syswrite();
+ }
+ sub test_syswrite_2{
+ test_syswrite(160);
+ }
+
+ sub test_syswrite_3{
+ test_syswrite(80, 2000);
+ }
+ sub test_syswrite{
+ my $len = shift;
+ my $offset = shift;
+ my $msg = "";
+
+ # my $m = "ENTERING test_syswrite ";
+ # $m .= "LEN = $len " if $len;
+ # $m .= "OFF = $offset" if $offset;
+ # print STDERR $m, "\n";
+
+ print "Status: 200 Bottles of beer on the wall\n",
+ "X-Perl-Version: $]\n";
+ print "X-Perl-Script: perlio.pl\n";
+ print "X-Message: hello\n";
+ print "Content-type: text/plain\n\n";
+
+ for ('A'..'Z') {
+ $msg .= $_ x 80;
+ }
+ my $bytes_sent =
+ defined($offset) ? syswrite STDOUT, $msg, $len, $offset :
+ defined($len) ? syswrite STDOUT, $msg, $len : syswrite STDOUT, $msg;
+
+ my $real_b = $r->bytes_sent;
+ print "REAL Bytes sent = $real_b\n";
+ die "Syswrite error. Bytes wrote=$bytes_sent. Real bytes sent = $real_b\n"
+ unless $bytes_sent == $real_b;
+ }
+
+ sub test_syswrite_noheader{
+ print STDERR "********* This is not a real error. Ignore. *********\n";
+ my $msg = "1234WRITEmethod";
+ syswrite STDOUT, $msg, 5, 4;
+ }
+
+
+
+
+