I am making a program that interfaces with Teamspeak, and I have an issue where the responses received will not match the commands sent. I run the program multiple times and each time, I will get different results when they should be the same, due to responses being out of sync.
my $buf = '';
use IO::Socket;
my $sock = new IO::Socket::INET (
PeerAddr => 'localhost'
,PeerPort => '10011'
,Proto => 'tcp'
,Autoflush => 1
,Blocking => 1
,Timeout => 10
);
sub ExecuteCommand{
print $sock $_[0]."\n";$sock->sysread($buf,1024*10);
return $buf;
};
ExecuteCommand("login ${username} ${password}");
ExecuteCommand("use sid=1");
ExecuteCommand("clientupdate client_nickname=Idle\\sTimer");
my $client_list = ExecuteCommand("clientlist");
Each command is executed properly, however the server likes to return extra lines, so a single sysread will not be enough and I will have to execute another. The size of responses are at most 512, so they aren't being cut off. If I try to run the sysread multiple times in an attempt to flush it, when there is nothing to read it will just make the program hang.
The end of the executions are followed with "error id=0 msg=ok"
How would I be able to read all the data that comes out, even if it's multiple lines? Or just be able to flush it all out so I can move onto the next command without having to worry about old data?
So you want to read until you find a line starting with error. In addition to doing that, the following buffers anything extra read since it's part of the next response.
sub read_response {
my ($conn) = #_;
my $fh = $conn->{fh};
our $buf; local *buf = \($conn->{buf}); # alias
our $eof; local *eof = \($conn->{eof}); # alias
$buf = '' if !defined($buf);
return undef if $eof;
while (1) {
if ($buf =~ s/\A(.*?^error[^\n]*\n)//ms) {
return $1;
}
my $rv = sysread($fh, $buf, 64*1024, length($buf));
if (!$rv) {
if (defined($rv)) {
$eof = 1;
return undef;
} else {
die "Can't read response: $!\n";
}
}
}
}
my $conn = { fh => $sock };
... send command ...
my $response = read_response($conn);
...
... send command ...
my $response = read_response($conn);
...
I changed my ExecuteCommand subroutine to include a check for "error code=[0-9]{1,}", which is what is always at the end of a response for Teamspeak 3 servers.
sub ExecuteCommand{
print $sock $_[0]."\n";
my $response = "";
while (1){
$sock->sysread($buf,1024*10);
last if($buf =~ /error id=([0-9]{1,})/);
$response .= $buf;
};
return $response;
};
Related
For some reason I am implementing some specific network protocol similar to STOMP in plain pure Perl.
The connection can be either a direct network socket, or an SSL tunnel provided by openssl s_client created by a call to open3 (no IO::Socket::SSL available on the host).
Depending on the dialog a request to the server may or may not have a response, or may have multiple responses. How can I test the file descriptors for the existence of data? Currently when no data is available, it waits until the defined timeout.
EDIT: I have probably a vocabulary issue between file handle vs. file descriptor to perform my research. I just found that eof() may help but cannot use it correctly yet.
While it is a bit complicated to provide an SCCCE, here is the interesting parts of the code:
# creation of a direct socket connection
sub connect_direct_socket {
my ($host, $port) = #_;
my $sock = new IO::Socket::INET(PeerAddr => $host,
PeerPort => $port,
Proto => 'tcp') or die "Can't connect to $host:$port\n";
$sock->autoflush(1);
say STDERR "* connected to $host port $port" if $args{verbose} || $args{debug};
return $sock, $sock, undef;
}
# for HTTPS, we are "cheating" by creating a tunnel with OpenSSL in s_client mode
my $tunnel_pid;
sub connect_ssl_tunnel {
my ($dest) = #_;
my ($host, $port);
$host = $dest->{host};
$port = $dest->{port};
my $cmd = "openssl s_client -connect ${host}:${port} -servername ${host} -quiet";# -quiet -verify_quiet -partial_chain';
$tunnel_pid = open3(*CMD_IN, *CMD_OUT, *CMD_ERR, $cmd);
say STDERR "* connected via OpenSSL to $host:$port" if $args{verbose} || $args{debug};
say STDERR "* command = $cmd" if $args{debug};
$SIG{CHLD} = sub {
print STDERR "* REAPER: status $? on ${tunnel_pid}\n" if waitpid($tunnel_pid, 0) > 0 && $args{debug};
};
return *CMD_IN, *CMD_OUT, *CMD_ERR;
}
# later
($OUT, $IN, $ERR) = connect_direct_socket($url->{host}, $url->{port});
# or
($OUT, $IN, $ERR) = connect_ssl_tunnel($url);
# then I am sending with a
print $OUT $request;
# and read the response with
my $selector = IO::Select->new();
$selector->add($IN);
FRAME:
while (my #ready = $selector->can_read($args{'max-wait'} || $def_max_wait)) {
last unless #ready;
foreach my $fh (#ready) {
if (fileno($fh) == fileno($IN)) {
my $buf_size = 1024 * 1024;
my $block = $fh->sysread(my $buf, $buf_size);
if($block){
if ($buf =~ s/^\n*([^\n].*?)\n\n//s){
# process data here
}
if ($buf =~ s/^(.*?)\000\n*//s ){
goto EOR;
# next FRAME;
} }
$selector->remove($fh) if eof($fh);
}
}
}
EOR:
EDIT 2 and epilogue
As a summary, depending in the protocol dialog
a request can have an expected response (for instance a CONNECT must return a CONNECTED)
a request to get the pending messages can return a single response, multiple responses at once (without intermediate request), or no response (and in this case the can_read() with no parameter of Ikegami is blocking, what I want to avoid).
Thanks to Ikegami I have changed my code as the following:
the timeout argument to can_read() is passed as an argument to the sub that is processing the responses
for initial connections I am passing a timeout of several seconds
when I expect instant responses I am passing a timeout of 1 second
in the process loop, after any correct response I replace the initial timeout by a 0.1 to not block if no more data is waiting in the filehandle
Here is my updated code:
sub process_stomp_response {
my $IN = shift;
my $timeout = shift;
my $resp = [];
my $buf; # allocate the buffer once and not in loop - thanks Ikegami!
my $buf_size = 1024 * 1024;
my $selector = IO::Select->new();
$selector->add($IN);
FRAME:
while (1){
my #ready = $selector->can_read($timeout);
last FRAME unless #ready; # empty array = timed-out
foreach my $fh (#ready) {
if (fileno($fh) == fileno($IN)) {
my $bytes = $fh->sysread($buf, $buf_size);
# if bytes undef -> error, if 0 -> eof, else number of read bytes
my %frame;
if (defined $bytes){
if($bytes){
if ($buf =~ s/^\n*([^\n].*?)\n\n//s){
# process frame headers here
# [...]
}
if ($buf =~ s/^(.*?)\000\n*//s ){
# process frame body here
# [...]
push #$resp, \%frame;
$timeout = 0.1; # for next read short timeout
next FRAME;
}
} else {
# EOF
$selector->remove($fh);
last FRAME;
}
} else {
# something is wrong
say STDERR "Error reading STOMP response: $!";
}
} else {
# what? not the given fh
}
}
}
return $resp;
}
Do not use eof in conjunction with select (which can_read wraps). It performs a buffered read, which breaks select.
select will mark a handle as ready for reading when it reaches EOF, and sysread returns zero on EOF. So all you need to do to detect EOF is to check for sysread returning zero.
Note that using a new buffer for every pass was a mistake sysread can easily return only part of a message. The following fixes this, and shows how to handle errors and EOF from sysread.
Globals:
my %clients_by_fd;
When you get a new connection:
$selector->add( $fh );
$clients_by_fd{ fileno( $fh ) } = {
buf => "",
# Any other info you want here.
};
Event loop:
while ( 1 ) {
my #ready = $selector->can_read();
for my $fh ( #ready ) {
my $client = $clients_by_fd{ fileno( $fh ) };
my $buf_ref = \$client->{ buf };
my $rv = sysread( $fh, $$buf_ref, 1024*1024, length( $$buf_ref ) );
if ( !$rv ) {
if ( defined( $rv ) ) {
# EOF
if ( length( $$buf_ref ) ) {
warn( "Error reading: Incomplete message\n" );
}
} else {
# Error
warn( "Error reading: $!\n" );
}
delete $clients_by_fd{ fileno( $fh ) };
$select->remove( $fh );
}
while ( $$buf_ref =~ s/^.*?\n\n//s ) {
process_message( $client, $& );
}
}
}
First of all I would thank you guys not offering a work around as a solution (although it would be cool to know other ways to do it). I was setting up tg-master project (telegram for cli) to be used by check_mk alert plugin. I found out that telegram runs on a stdin/stdout proccess so I tought it would be cool to "glue" it, so i wrote with a lot of building blocks from blogs and cpan the next 2 pieces of code. They already work (i need to handle broken pipes sometimes) but I was wondering if sharing this could come from some experts new ideas.
As you could see my code relies on a eval with a die reading from spawned process, and I know is not the best way to do it. Any suggestions? :D
Thank you guys
Server
use strict;
use IO::Socket::INET;
use IPC::Open2;
use POSIX;
our $pid;
use sigtrap qw/handler signal_handler normal-signals/;
sub signal_handler {
print "what a signal $!\nlets kill $pid\n";
kill 'SIGKILL', $pid;
#die "Caught a signal $!";
}
# auto-flush on socket
$| = 1;
# creating a listening socket
my $socket = new IO::Socket::INET(
LocalHost => '0.0.0.0',
LocalPort => '7777',
Proto => 'tcp',
Listen => 5,
Reuse => 1
);
die "cannot create socket $!\n" unless $socket;
print "server waiting for client connection on port 7777\n";
my ( $read_proc, $write_proc );
my ( $uid, $gid ) = ( getpwnam "nagios" )[ 2, 3 ];
POSIX::setgid($gid); # GID must be set before UID!
POSIX::setuid($uid);
$pid = open2( $read_proc, $write_proc, '/usr/bin/telegram' );
#flush first messages;
eval {
local $SIG{ALRM} = sub { die "Timeout" }; # alarm handler
alarm(1);
while (<$read_proc>) { }
};
while (1) {
my $client_socket = $socket->accept();
my $client_address = $client_socket->peerhost();
my $client_port = $client_socket->peerport();
print "connection from $client_address:$client_port\n";
# read until \n
my $data = "";
$data = $client_socket->getline();
# write to spawned process stdin the line we got on $data
print $write_proc $data;
$data = "";
eval {
local $SIG{ALRM} = sub { die "Timeout" }; # alarm handler
alarm(1);
while (<$read_proc>) {
$client_socket->send($_);
}
};
# notify client that response has been sent
shutdown( $client_socket, 1 );
}
$socket->close();
Client
echo "contact_list" | nc localhost 7777
or
echo "msg user#12345 NAGIOS ALERT ... etc" | nc localhost 7777
or
some other perl script =)
If you are going to implement a script that performs both reads and writes from/to different handles, consider using select (the one defined as select RBITS,WBITS,EBITS,TIMEOUT in the documentation). In this case you will totally avoid using alarm with a signal handler in eval to handle a timeout, and will only have one loop with all of the work happening inside it.
Here is an example of a program that reads from both a process opened with open2 and a network socket, not using alarm at all:
use strict;
use warnings;
use IO::Socket;
use IPC::Open2;
use constant MAXLENGTH => 1024;
my $socket = IO::Socket::INET->new(
Listen => SOMAXCONN,
LocalHost => '0.0.0.0',
LocalPort => 7777,
Reuse => 1,
);
# accepting just one connection
print "waiting for connection...\n";
my $remote = $socket->accept();
print "remote client connected\n";
# simple example of the program writing something
my $pid = open2(my $localread, my $localwrite, "sh -c 'while : ; do echo boom; sleep 1 ; done'");
for ( ; ; ) {
# cleanup vectors for select
my $rin = '';
my $win = '';
my $ein = '';
# will wait for a possibility to read from these two descriptors
vec($rin, fileno($localread), 1) = 1;
vec($rin, fileno($remote), 1) = 1;
# now wait
select($rin, $win, $ein, undef);
# check which one is ready. read with sysread, not <>, as select doc warns
if (vec($rin, fileno($localread), 1)) {
print "read from local process: ";
sysread($localread, my $data, MAXLENGTH);
print $data;
}
if (vec($rin, fileno($remote), 1)) {
print "read from remote client: ";
sysread($remote, my $data, MAXLENGTH);
print $data;
}
}
In the real production code you will need to carefully check for errors returned by various function (socket creation, open2, accept, and select).
I have a simple script that should bind to an SMSC and listen for incoming messages. The problem I'm having is that it will time out if it doesn't receive any messages.
Here is the script:
#!/usr/bin/perl
use Net::SMPP;
use Data::Dumper;
$Net::SMPP::trace = 1;
$smpp = Net::SMPP->new_receiver('--removed--',
port => '--removed--',
system_id => '--removed--',
password => '--removed--',
) or die;
while (1)
{
$pdu = $smpp->read_pdu() or die;
print "Received #$pdu->{seq} $pdu->{cmd}:". Net::SMPP::pdu_tab->{$pdu->{cmd}}{cmd} ."\n";
print "From: $pdu->{source_addr}\nTo: $pdu->{destination_addr}\nData: $pdu->{data}\n";
print "Messsage: $pdu->{short_message}\n\n";
}
Here's the error I'm getting:
premature eof reading from socket at /usr/lib/perl5/site_perl/5.8.8/Net/SMPP.pm line 2424.
$VAR1 = undef;
And here's the relevant sub from SMPP.pm:
sub read_hard {
my ($me, $len, $dr, $offset) = #_;
while (length($$dr) < $len+$offset) {
my $n = length($$dr) - $offset;
eval {
local $SIG{ALRM} = sub { die "alarm\n" }; # NB: \n required
alarm ${*$me}{enquire_interval} if ${*$me}{enquire_interval};
warn "read $n/$len enqint(${*$me}{enquire_interval})" if $trace>1;
while (1) {
$n = $me->sysread($$dr, $len-$n, $n+$offset);
next if $! =~ /^Interrupted/;
last;
}
alarm 0;
};
if ($#) {
warn "ENQUIRE $#" if $trace;
die unless $# eq "alarm\n"; # propagate unexpected errors
$me->enquire_link(); # Send a periodic ping
} else {
if (!defined($n)) {
warn "error reading header from socket: $!";
${*$me}{smpperror} = "read_hard I/O error: $!";
${*$me}{smpperrorcode} = 1;
return undef;
}
#if ($n == 0) { last; }
if (!$n) {
warn "premature eof reading from socket";
${*$me}{smpperror} = "read_hard premature eof";
${*$me}{smpperrorcode} = 2;
return undef;
#return 0;
}
}
}
#warn "read complete";
return 1;
}
In the sub, the if statement it's hitting is the one where $n is 0 or undef.
My guess is that the socket is timing out and disconnecting. How can I keep the listener up indefinitely?
In addition, this listener blocks while waiting for a pdu. Is there a way to listen without blocking?
I'm a Telecom Engineer who does programming on the side, and I've gone through all the material I could find but couldn't find an answer.
It looks as if the sysread() call simply returns 0. It can do that only, if the connection status is known to be disconnected. Since your side did not disconnect or timeout, i would deduce that the remote side disconnected. If a timeout would have occured on your side, you should not have been able to see the premature eof... message.
So, you are already 'keeping the listener up indefinitely', since you do not set the enquire_interval option.
Regarding 'Is there a way to listen without blocking?' the description section describes asynchronous mode at the end: Module can also be used asynchronously by specifying async=>1 to the constructor. You have to implement the data polling then yourself.
Have you tried to set a parameter for the enquire link (SMPP ping) timeout?
On your new_receiver, verify if "enquire_interval" parameter exists and set it to 15 seconds, for example...
I have tried with new_transceiver() method, and it works.
my $smpp = Net::SMPP->new_transceiver(
$self->host,
port => $self->port,
system_id => $self->user,
password => $self->password,
smpp_version => $self->version,
interface_version => $self->interface_version,
enquire_interval => $self->timeout,
addr_ton => $self->addr_ton,
addr_npi => $self->addr_npi,
source_addr => $self->source_addr,
source_addr_ton => $self->source_addr_ton,
source_addr_npi => $self->source_addr_npi,
dest_addr_ton => $self->dest_addr_ton,
dest_addr_npi => $self->dest_addr_npi,
system_type => $self->system_type,
facilities_mask => $self->facilities_mask
) or die "Could not connect to $self->host: $!";
It (Net::SMPP) handles enquire link automaticallly.
I am also receiving the same error of premature termination.
For blocking, you can fork or thread another process and both can run parallel. There is no way around the blocking.
Assuming a handle created with the following code:
use IO::File;
my $fh = IO::File->new;
my $pid = $fh->open('some_long_running_proc |') or die $!;
$fh->autoflush(1);
$fh->blocking(0);
and then read with a loop like this:
while (some_condition_here) {
my #lines = $fh->getlines;
...
sleep 1;
}
What do I put as some_condition_here that will return false if the process on the other end of the pipe has terminated?
Testing for $fh->eof will not work since the process could still be running without printing any new lines. Testing for $fh->opened doesn't seem to do anything useful.
Currently I am using $pid =! waitpid($pid, WNOHANG) which seems to work in POSIX compliant environments. Is this the best way? What about on Windows?
On using select,
use strict;
use warnings;
use IO::Select qw( );
sub process_msg {
my ($client, $msg) = #_;
chomp $msg;
print "$client->{id} said '$msg'\n";
return 1; # Return false to close the handle.
}
my $select = IO::Select->new();
my %clients;
for (...) {
my $fh = ...;
$clients{fileno($fh)} = {
id => '...'
buf => '',
# ...
};
$select->add($fh);
}
while (my #ready = $select->can_read) {
for my $fh (#ready) {
my $client = $clients{ fileno($fh) };
our $buf; local *buf = \( $client->{buf} );
my $rv = sysread($fh, $buf, 64*1024, length($buf));
if (!$rv) {
if (defined($rv)) {
print "[$client->{id} ended]\n";
} else {
print "[Error reading from $client->{id}: $!]\n";
}
print "[Incomplete message received from $client->{id}]\n"
if length($buf);
delete $clients{ fileno($fh) };
$select->remove($fh);
next;
}
while ($buf =~ s/^(.*\n)//) {
if (!process_msg($client, "$1")) {
print "[Dropping $client->{id}]\n";
delete $clients{ fileno($fh) };
$select->remove($fh);
last;
}
}
}
}
What's wrong with waiting for an actual EOF?
while (<$fh>) {
...
sleep 1;
}
You've set the handle for non-blocking reads, so it should just do the right thing. Indeed, given your example, you don't even need to set non-blocking and can get rid of the sleep.
Are there other things that you want to do while waiting on some_long_running_proc? If so, select is probably in your future.
There a number of options.
readline aka <$fh> will return false on eof (or error).
eof will return true on eof.
read (with block size > 0) will return defined and zero on eof.
sysread (with block size > 0) will return defined and zero on eof.
You can use select or make the handle non-blocking before any of the above to check without blocking.
You use select() to ascertain whether there is any data, or an exceptional condition such as a close.
Personally I prefer to use IO::Multiplex, especially where you're multiplexing input from several different descriptors, but that may not apply in this case.
I am trying to implement a request to an unreliable server. The request is a nice to have, but not 100% required for my perl script to successfully complete. The problem is that the server will occasionally deadlock (we're trying to figure out why) and the request will never succeed. Since the server thinks it is live, it keeps the socket connection open thus LWP::UserAgent's timeout value does us no good what-so-ever. What is the best way to enforce an absolute timeout on a request?
FYI, this is not an DNS problem. The deadlock has something to do with a massive number of updates hitting our Postgres database at the same time. For testing purposes, we've essentially put a while(1) {} line in the servers response handler.
Currently, the code looks like so:
my $ua = LWP::UserAgent->new;
ua->timeout(5); $ua->cookie_jar({});
my $req = HTTP::Request->new(POST => "http://$host:$port/auth/login");
$req->content_type('application/x-www-form-urlencoded');
$req->content("login[user]=$username&login[password]=$password");
# This line never returns
$res = $ua->request($req);
I've tried using signals to trigger a timeout, but that does not seem to work.
eval {
local $SIG{ALRM} = sub { die "alarm\n" };
alarm(1);
$res = $ua->request($req);
alarm(0);
};
# This never runs
print "here\n";
The final answer I'm going to use was proposed by someone offline, but I'll mention it here. For some reason, SigAction works while $SIG(ALRM) does not. Still not sure why, but this has been tested to work. Here are two working versions:
# Takes a LWP::UserAgent, and a HTTP::Request, returns a HTTP::Request
sub ua_request_with_timeout {
my $ua = $_[0];
my $req = $_[1];
# Get whatever timeout is set for LWP and use that to
# enforce a maximum timeout per request in case of server
# deadlock. (This has happened.)
use Sys::SigAction qw( timeout_call );
our $res = undef;
if( timeout_call( 5, sub {$res = $ua->request($req);}) ) {
return HTTP::Response->new( 408 ); #408 is the HTTP timeout
} else {
return $res;
}
}
sub ua_request_with_timeout2 {
print "ua_request_with_timeout\n";
my $ua = $_[0];
my $req = $_[1];
# Get whatever timeout is set for LWP and use that to
# enforce a maximum timeout per request in case of server
# deadlock. (This has happened.)
my $timeout_for_client = $ua->timeout() - 2;
our $socket_has_timedout = 0;
use POSIX;
sigaction SIGALRM, new POSIX::SigAction(
sub {
$socket_has_timedout = 1;
die "alarm timeout";
}
) or die "Error setting SIGALRM handler: $!\n";
my $res = undef;
eval {
alarm ($timeout_for_client);
$res = $ua->request($req);
alarm(0);
};
if ( $socket_has_timedout ) {
return HTTP::Response->new( 408 ); #408 is the HTTP timeout
} else {
return $res;
}
}
You might try LWPx::ParanoidAgent, a subclass of LWP::UserAgent which is more cautious about how it interacts with remote webservers.
Among other things, it allows you to specify a global timeout. It was developed by Brad Fitzpatrick as part of the LiveJournal project.
You can make your own timeout like this:
use LWP::UserAgent;
use IO::Pipe;
my $agent = new LWP::UserAgent;
my $finished = 0;
my $timeout = 5;
$SIG{CHLD} = sub { wait, $finished = 1 };
my $pipe = new IO::Pipe;
my $pid = fork;
if($pid == 0) {
$pipe->writer;
my $response = $agent->get("http://stackoverflow.com/");
$pipe->print($response->content);
exit;
}
$pipe->reader;
sleep($timeout);
if($finished) {
print "Finished!\n";
my $content = join('', $pipe->getlines);
}
else {
kill(9, $pid);
print "Timed out.\n";
}
From what I understand, the timeout property doesn't take into account DNS timeouts. It's possible that you could make a DNS lookup separately, then make the request to the server if that works, with the correct timeout value set for the useragent.
Is this a DNS problem with the server, or something else?
EDIT: It could also be a problem with IO::Socket. Try updating your IO::Socket module, and see if that helps. I'm pretty sure there was a bug in there that was preventing LWP::UserAgent timeouts from working.
Alex
The following generalization of one of the original answers also restores the alarm signal handler to the previous handler and adds a second call to alarm(0) in case the call in the eval clock throws a non alarm exception and we want to cancel the alarm. Further $# inspection and handling can be added:
sub ua_request_with_timeout {
my $ua = $_[0];
my $request = $_[1];
# Get whatever timeout is set for LWP and use that to
# enforce a maximum timeout per request in case of server
# deadlock. (This has happened.)`enter code here`
my $timeout_for_client_sec = $ua->timeout();
our $res_has_timedout = 0;
use POSIX ':signal_h';
my $newaction = POSIX::SigAction->new(
sub { $res_has_timedout = 1; die "web request timeout"; },# the handler code ref
POSIX::SigSet->new(SIGALRM),
# not using (perl 5.8.2 and later) 'safe' switch or sa_flags
);
my $oldaction = POSIX::SigAction->new();
if(!sigaction(SIGALRM, $newaction, $oldaction)) {
log('warn',"Error setting SIGALRM handler: $!");
return $ua->request($request);
}
my $response = undef;
eval {
alarm ($timeout_for_client_sec);
$response = $ua->request($request);
alarm(0);
};
alarm(0);# cancel alarm (if eval failed because of non alarm cause)
if(!sigaction(SIGALRM, $oldaction )) {
log('warn', "Error resetting SIGALRM handler: $!");
};
if ( $res_has_timedout ) {
log('warn', "Timeout($timeout_for_client_sec sec) while waiting for a response from cred central");
return HTTP::Response->new(408); #408 is the HTTP timeout
} else {
return $response;
}
}