← Back to branch summary

~ubuntu-branches/ubuntu/edgy/libapache2-mod-perl2/edgy

« back to all changes in this revision

Viewing changes to t/protocol/TestProtocol/echo_timeout.pm

  • Committer: Bazaar Package Importer
  • Author(s): Andres Salomon
  • Date: 2005-08-12 01:40:38 UTC
  • mfrom: (1.1.2 upstream) (2.1.1 sarge)
  • Revision ID: james.westby@ubuntu.com-20050812014038-gjigefs55pqx4qc8
Tags: 2.0.1-3
Grr.  Really include perl.conf file; it got lost due to diff not
wanting to add an empty file.

Show diffs side-by-side

added added

removed removed

Lines of Context:
t/protocol/TestProtocol/echo_timeout.pm
8
8
use strict;
9
9
use warnings FATAL => 'all';
10
10
 
11
 
use Apache::Connection ();
 
11
use Apache2::Connection ();
12
12
use APR::Socket ();
13
13
 
14
 
use Apache::Const -compile => 'OK';
15
 
use APR::Const    -compile => qw(TIMEUP);
 
14
use Apache2::Const -compile => 'OK';
 
15
use APR::Const     -compile => qw(SO_NONBLOCK);
 
16
use APR::Status ();
16
17
 
17
18
use constant BUFF_LEN => 1024;
18
19
 
19
20
sub handler {
20
 
    my Apache::Connection $c = shift;
 
21
    my Apache2::Connection $c = shift;
21
22
    my APR::Socket $socket = $c->client_socket;
22
23
 
23
 
    # XXX: workaround to a problem on some platforms (solaris, bsd,
24
 
    # etc), where Apache 2.0.49+ forgets to set the blocking mode on
25
 
    # the socket
26
 
    BEGIN { use APR::Const -compile => qw(SO_NONBLOCK) }
27
 
    $c->client_socket->opt_set(APR::SO_NONBLOCK => 0);
 
24
    # starting from Apache 2.0.49 several platforms require you to set
 
25
    # the socket to a blocking IO mode
 
26
    $c->client_socket->opt_set(APR::Const::SO_NONBLOCK, 0);
28
27
 
29
28
    # set timeout (20 sec) so later we can do error checking on
30
29
    # read/write timeouts
31
30
    $socket->timeout_set(20_000_000);
32
31
 
33
32
    while (1) {
34
 
        my $buff = eval { $socket->recv(BUFF_LEN) };
 
33
        my $buff;
 
34
        my $rlen = eval { $socket->recv($buff, BUFF_LEN) };
35
35
        if ($@) {
36
 
            die "timed out, giving up: $@" if $@ == APR::TIMEUP;
 
36
            die "timed out, giving up: $@" if APR::Status::is_TIMEUP($@);
37
37
            die $@;
38
38
        }
39
39
 
40
 
        last unless length $buff; # EOF
 
40
        last unless $rlen; # EOF
41
41
 
42
42
        my $wlen = eval { $socket->send($buff) };
43
43
        if ($@) {
44
 
            die "timed out, giving up: $@" if $@ == APR::TIMEUP;
 
44
            die "timed out, giving up: $@" if APR::Status::is_TIMEUP($@);
45
45
            die $@;
46
46
        }
47
 
        last if $wlen != length $buff; # write failure?
48
47
    }
49
48
 
50
 
    Apache::OK;
 
49
    Apache2::Const::OK;
51
50
}
52
51
 
53
52
1;