perl-modperl-cvs mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From do...@locus.apache.org
Subject cvs commit: modperl/t/net/perl/io perlio.pl
Date Wed, 20 Dec 2000 08:07:38 GMT
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 <sseyfaie@cryptologic.com>]
  +
   prevent $PerlRequire in a <Perl> section from triggering an endless loop
   [Salvador Ortiz Garcia <sog@msg.com.mx>]
   
  
  
  
  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;
  +}
  +
  +
  +
  +
  +
  
  
  

Mime
View raw message