[25410] | 1 | # @author Donnie Cameron (macnod)
|
---|
| 2 | # @url https://github.com/macnod/DcServer
|
---|
| 3 | # @readme http://donnieknows.com/blog/perl-sockets-swimming-thread-pool
|
---|
| 4 |
|
---|
| 5 | package SocketsSwimmingThreadPoolClient;
|
---|
| 6 |
|
---|
| 7 | use IO::Socket;
|
---|
| 8 | use Carp;
|
---|
| 9 | use strict;
|
---|
| 10 | use warnings;
|
---|
| 11 |
|
---|
| 12 | my $retry_time = 30;
|
---|
| 13 |
|
---|
| 14 | sub new
|
---|
| 15 | {
|
---|
| 16 | # Params: host, port
|
---|
| 17 | my ($proto, %param)= @_;
|
---|
| 18 | my $class= ref($proto) || $proto;
|
---|
| 19 | bless +{%param} => $class;
|
---|
| 20 | }
|
---|
| 21 |
|
---|
| 22 | sub stop_server
|
---|
| 23 | {
|
---|
| 24 | shift->query('$self->stop')
|
---|
| 25 | }
|
---|
| 26 |
|
---|
| 27 | sub open_socket
|
---|
| 28 | {
|
---|
| 29 | my $self = shift @_;
|
---|
| 30 | # There is, unfortunately, a complication when using TCP sockets - that being
|
---|
| 31 | # the amount of time sockets linger after being closed. This TIME_WAIT period
|
---|
| 32 | # is required to ensure the terminating ACKs (kernel level) are recieved (in
|
---|
| 33 | # a graceful disconnect) and to allow time for 'wandering duplicates' to
|
---|
| 34 | # finally arrive. While there are (platform/OS/hardware) methods for getting
|
---|
| 35 | # rid of / shortening this grace period they aren't recommended (for both
|
---|
| 36 | # stability and security reasons).
|
---|
| 37 | # Thus you have the issue that, very occasionally and somewhat based upon the
|
---|
| 38 | # current turnover rate of TCP connections, you may exhaust the available
|
---|
| 39 | # pool of TCP sockets (as the rest are stuck waiting on TIME_WAIT timeouts).
|
---|
| 40 | # While the 'reuse' flag might lead you to expect the ability to 'reuse' the
|
---|
| 41 | # socket - there is one glaring caveat: you can't reuse the port from the
|
---|
| 42 | # same origin address as this would be a major security flaw. So in reality
|
---|
| 43 | # the reuse flag does nothing for us (which is why I removed it).
|
---|
| 44 | # Instead I am forced to put the socket connection in a loop and, if the
|
---|
| 45 | # first attempt to create the socket fails, wait around for SO_LINGER time
|
---|
| 46 | # in the hope that the TCP socket pool will have finally purged a number of
|
---|
| 47 | # the stranded TIME_WAIT connections.
|
---|
| 48 | # One last kick in the daddy-bags - the *default* SO_LINGER is set to 2*MSL
|
---|
| 49 | # (Maximum Segment Lifetime - the 'Time To Live of TCP' packets). This means
|
---|
| 50 | # (according to RFC793) we may be waiting up to 4 minutes for TIME_WAITs to
|
---|
| 51 | # be reaped. Sigh. Still - ever an optimist - I'll retry the socket
|
---|
| 52 | # connection every 30 seconds.
|
---|
| 53 | # References:
|
---|
| 54 | # http://www.perlmonks.org/?node_id=771242
|
---|
| 55 | # http://hea-www.harvard.edu/~fine/Tech/addrinuse.html
|
---|
| 56 | # http://blog.port80software.com/2004/12/07/hurry-up-and-time_wait/
|
---|
| 57 | # http://www.isi.edu/touch/pubs/infocomm99/infocomm99-web/
|
---|
| 58 | # http://www.faqs.org/rfcs/rfc793.html
|
---|
| 59 | while(1)
|
---|
| 60 | {
|
---|
| 61 | my $socket= new IO::Socket::INET(PeerAddr => $self->{host} || 'localhost',
|
---|
| 62 | PeerPort => $self->{port} || 8190,
|
---|
| 63 | Proto => 'tcp');
|
---|
| 64 | if ($socket)
|
---|
| 65 | {
|
---|
| 66 | return $socket;
|
---|
| 67 | }
|
---|
| 68 | print "Failed to create client socket: $!\n";
|
---|
| 69 | print "=> Most likely cause - TCP ephemeral ports exhausted (stuck in TIME_WAITs)\n";
|
---|
| 70 | print "=> Retry in " . $retry_time . " seconds.\n";
|
---|
| 71 | }
|
---|
| 72 | }
|
---|
| 73 |
|
---|
| 74 | sub query
|
---|
| 75 | {
|
---|
| 76 | my ($self, $query)= @_;
|
---|
| 77 | my $socket = $self->open_socket();
|
---|
| 78 | croak "Fatal Error! $!\nDetails: " . $self->{'host'} . ":" . $self->{'port'} . "\n" unless $socket;
|
---|
| 79 | binmode($socket, ":utf8");
|
---|
| 80 | print $socket $query . "\n.\n";
|
---|
| 81 | my $buffer = '';
|
---|
| 82 | my $reply = '';
|
---|
| 83 | while($buffer = <$socket>)
|
---|
| 84 | {
|
---|
| 85 | $reply.= $buffer;
|
---|
| 86 | last if $reply =~ s/\n\.\n$//;
|
---|
| 87 | }
|
---|
| 88 | close($socket);
|
---|
| 89 | return $reply;
|
---|
| 90 | }
|
---|
| 91 |
|
---|
| 92 | 1;
|
---|