fastcgi-ping.pl

fastcgi-ping.pl

#!/usr/bin/perl
use strict;
use warnings;

use IO::Socket             qw[];
use Net::FastCGI::Constant qw[ :type FCGI_NULL_REQUEST_ID FCGI_HEADER_LEN ];
use Net::FastCGI::Protocol qw[ build_record parse_header get_type_name ];

sub fatal ($;$);
sub timeout (&$$);

(@ARGV == 1)
  || fatal(qq/usage: <host:port>/);

my $remote = shift @ARGV;
my $socket = timeout {
    (-S $remote ? 'IO::Socket::UNIX' : 'IO::Socket::INET')->new($remote)
      or fatal(qq<Could not connect to '$remote': '$!'>);
} 5, q<Timeout while attempting to connect to the specified address>;

timeout {
    print {$socket} build_record(FCGI_GET_VALUES, FCGI_NULL_REQUEST_ID, "\x00\x00")
      or fatal(qq<Could not write record: '$!'>);
} 5, q<Timeout while attempting to write FCGI_Record>;

my $header = timeout {
    my $r = read($socket, my $buf, FCGI_HEADER_LEN);
    (defined $r && $r == FCGI_HEADER_LEN)
      || fatal(qq<Could not read FCGI_Header: '$!'>);
    parse_header($buf);
} 5, q<Timeout while attempting to read FCGI_Header>;

if ($header->{type} == FCGI_GET_VALUES_RESULT) {
    print "$remote: OK\n";
}
else {
    printf "$remote: NOT OK (Application responed with an unexpected record type %s)\n",
      get_type_name($header->{type});
}

sub fatal ($;$) {
    my ($message, $status) = @_;
    warn $0, ': ', $message, "\n";
    exit ($status || 1);
}

sub awaken::DESTROY () { alarm(0) }

sub timeout (&$$) {
    my ($code, $timeout, $message) = @_;
    $SIG{ALRM} = sub {
        fatal($message);
    };
    alarm($timeout);
    my $awaken = bless \(my $x), 'awaken';
    &$code;
}