Send an OPTIONS ping to a SIP server - including peculiarities needed to make Asterisk happy.

sipping.pl

#!/usr/bin/perl
use strict;
use warnings;
use IO::Socket;
# use Time::HiRes qw/time sleep/;
# Since Time::HiRes is not always available, use the syscalls directly:
require 'syscall.ph';
use subs qw/time sleep/;
sub time {
    my $tv = pack('q2', 0, 0);
    syscall(SYS_gettimeofday(), $tv, undef);
    my($s, $u) = unpack('q2', $tv);
    return $s + ($u / 1e6);
}
sub sleep {
    my($u) = @_;
    my $ts = pack('q2', $u, ($u - int $u) * 1e9);
    return syscall(SYS_nanosleep(), $ts, undef);
}
# End missing Time::HiRes workaround

use constant DEBUG => 0;

my($interval, $peer) = @ARGV;
$interval ||= 5;
$peer ||= '127.0.0.1';
$peer =~ /:\d+$/ or $peer .= ':5060';
$peer =~ s/^(.*)\@//;
my $user = $1 || 'ping';
print "Interval: $interval\n";
print "Peer: $peer\n";
print "User: $user\n";

my $t = time;
while(1) {
    xlog("Sending SIP OPTIONS request to $peer\n");
    my($reply, $ph, $pp) = eval{ sipping($peer, $user, $interval) };
    if($reply) {
	my $statusline = (split(/\x0D?\x0A/, $reply))[0];
	xlog("REPLY_RECEIVED: from $ph:$pp - $statusline\n");
    } else {
	xlog("REPLY_NOT_RECEIVED: $@");
    }
    $t += $interval;
    my $n = time;
    if($t < $n) {
	$t = $n;
    } else {
	sleep($t - $n);
    }
}

sub xlog {
    my $t = time;
    sprintf('%.6f', $t - int $t) =~ /\.(\d+)/;
    my $f = $1;
    my $y = (localtime($t))[5] + 1900;
    my $m = (localtime($t))[4] + 1;
    printf '%04d-%02d-%02d %02d:%02d:%02d.%s: %s', $y, $m, (localtime($t))[3, 2, 1, 0], $f, "@_";
}

my $sock;
sub sipping {
    my($peer, $user, $timeout) = @_;
    if(not defined $sock) {
	my $newsock = IO::Socket::INET->new(
	    Proto    => 'udp',
	    PeerAddr => $peer,
	) or die "Could not create socket: $!\n";
	$newsock->setsockopt(
	    SOL_SOCKET,
	    SO_RCVTIMEO,
	    pack('l!l!', $timeout, 0),
	) or die "setsockopt: $!";
	$sock = $newsock;
    }
    my $localport = $sock->sockport();
    my $localhost = $sock->sockhost();
    my $peerport = $sock->peerport();
    my $peerhost = $sock->peerhost();
    my $id = join('', map{substr('0123456789ABCDEF', rand(16), 1)}(0..8));

    my $msg = <<END;
OPTIONS sip:$user\@$peerhost:$peerport SIP/2.0
Via: SIP/2.0/UDP $localhost:$localport;branch=$id
Contact: <sip:ping\@$localhost:$localport>
From: <sip:ping\@$localhost:$localport>;tag=$id
To: <sip:$user\@$peerhost:$peerport>
Call-ID: $id\@sipping.pl
CSeq: 1 OPTIONS
Accept: application/sdp
User-Agent: sipping.pl
Max-Forwards: 1
Content-Length: 0

END

    warn "sending msg:\n$msg" if DEBUG;
    $msg =~ s/\x0D?\x0A/\x0D\x0A/g;
    $sock->send($msg) or die "Send error: $!\n";
    xlog("Sent from $localhost:$localport - ID: $id - OPTIONS sip:$user\@$peerhost:$peerport SIP/2.0\n");
    $sock->recv(my $reply, 4096) or die "Recv error: $!\n";
    print "Reply:\n$reply\n" if DEBUG;
    return($reply, $peerhost, $peerport);
}