dougm 00/12/20 00:07:37
Modified: . Changes
Apache Apache.pm
src/modules/perl Apache.xs
t/internal http-get.t
t/net/perl/io perlio.pl
Log:
rewrite of Apache::WRITE() in c/xs
Revision Changes Path
1.556 +3 -0 modperl/Changes
Index: Changes
===================================================================
RCS file: /home/cvs/modperl/Changes,v
retrieving revision 1.555
retrieving revision 1.556
diff -u -r1.555 -r1.556
--- Changes 2000/12/20 07:24:42 1.555
+++ Changes 2000/12/20 08:07:32 1.556
@@ -10,6 +10,9 @@
=item 1.24_02-dev
+rewrite of Apache::WRITE() in c/xs
+[Soheil Seyfaie <[EMAIL PROTECTED]>]
+
prevent $PerlRequire in a <Perl> section from triggering an endless loop
[Salvador Ortiz Garcia <[EMAIL PROTECTED]>]
1.60 +0 -6 modperl/Apache/Apache.pm
Index: Apache.pm
===================================================================
RCS file: /home/cvs/modperl/Apache/Apache.pm,v
retrieving revision 1.59
retrieving revision 1.60
diff -u -r1.59 -r1.60
--- Apache.pm 2000/11/25 15:39:24 1.59
+++ Apache.pm 2000/12/20 08:07:34 1.60
@@ -158,12 +158,6 @@
}
*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
1.117 +48 -0 modperl/src/modules/perl/Apache.xs
Index: Apache.xs
===================================================================
RCS file: /home/cvs/modperl/src/modules/perl/Apache.xs,v
retrieving revision 1.116
retrieving revision 1.117
diff -u -r1.116 -r1.117
--- Apache.xs 2000/12/20 07:02:49 1.116
+++ Apache.xs 2000/12/20 08:07:35 1.117
@@ -1035,6 +1035,54 @@
}
int
+write(r, sv_buffer, sv_length=-1, offset=0)
+ Apache r
+ SV *sv_buffer
+ int sv_length
+ int offset
+
+ ALIAS:
+ Apache::WRITE = 1
+
+ PREINIT:
+ STRLEN len;
+ char *buffer;
+ int sent = 0;
+
+ CODE:
+ ix = ix; /* avoid -Wall warning */
+ RETVAL = 0;
+
+ if (r->connection->aborted) {
+ XSRETURN_UNDEF;
+ }
+
+ buffer = SvPV(sv_buffer, len);
+ if (sv_length != -1) {
+ len = sv_length;
+ }
+
+ if (offset) {
+ buffer += offset;
+ }
+
+ 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
1.7 +25 -2 modperl/t/internal/http-get.t
Index: http-get.t
===================================================================
RCS file: /home/cvs/modperl/t/internal/http-get.t,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- http-get.t 2000/10/10 16:33:59 1.6
+++ http-get.t 2000/12/20 08:07:36 1.7
@@ -7,8 +7,10 @@
my(@test_scripts) = qw(test perl-status);
%get_only = map { $_,1 } qw(perl-status);
+my(@sys_tests) = qw(syswrite_1 syswrite_2 syswrite_3);
+
if($] > 5.003) {
- $num_tests += 3;
+ $num_tests += (3 + @sys_tests);
push @test_scripts, qw(io/perlio.pl);
}
@@ -42,7 +44,28 @@
next if $get_only{$s};
test ++$i, ($str =~ /^REQUEST_METHOD=GET$/m);
- test ++$i, ($str =~ /^QUERY_STRING=query$/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;
1.6 +51 -0 modperl/t/net/perl/io/perlio.pl
Index: perlio.pl
===================================================================
RCS file: /home/cvs/modperl/t/net/perl/io/perlio.pl,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- perlio.pl 1999/05/18 02:08:33 1.5
+++ perlio.pl 2000/12/20 08:07:37 1.6
@@ -113,3 +113,54 @@
}
+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;
+}
+
+
+
+
+
