/usr/share/perl5/Smokeping/probes/SipSak.pm is in smokeping 2.6.11-2.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 | package Smokeping::probes::SipSak;
=head1 301 Moved Permanently
This is a Smokeping probe module. Please use the command
C<smokeping -man Smokeping::probes::SipSak>
to view the documentation or the command
C<smokeping -makepod Smokeping::probes::SipSak>
to generate the POD document.
=cut
use strict;
use base qw(Smokeping::probes::basefork);
use Carp;
sub pod_hash {
return {
name => <<DOC,
Smokeping::probes::SipSak - tests sip server
DOC
overview => <<DOC,
This probe sends OPTIONS messages to a sip server testing the latency.
DOC
description => <<DOC,
The probe uses the L<sipsak|http://sipsak.org/> tool to measure sip server latency by sending an OPTIONS message.
The sipsak command supports a large number of additional parameters to fine-tune its operation. Use the
params variable to configure them.
DOC
authors => <<'DOC',
Tobias Oetiker <tobi@oetiker.ch> sponsored by ANI Networks
DOC
}
}
sub ProbeDesc ($) {
my $self = shift;
return sprintf("SIP OPTIONS messages");
}
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my $self = $class->SUPER::new(@_);
return $self;
}
sub pingone {
my $self = shift;
my $target = shift;
my $host = $target->{addr};
my $vars = $target->{vars};
my @times;
my $elapsed;
my $pingcount = $self->pings($target);
my $keep = $vars->{keep_second};
$host = $vars->{user}.'@'.$host if $vars->{user};
$host = $host . ':' . $vars->{port} if $vars->{port};
my @extra_opts = ();
@extra_opts = split /\s/, $vars->{params} if $vars->{params};
open (my $sak,'-|',$self->{properties}{binary},'-vv','-A',$pingcount,'-s','sip:'.$host,@extra_opts)
or die("ERROR: $target->{binary}: $!\n");
my $reply = join ("",<$sak>);
close $sak;
my @reply = split /\*\*\sreply/, $reply;
# don't need the stuff before the first replyx
shift @reply;
my $filter = '.*';
$self->do_debug("SipSak: got ".(scalar @reply)." replies, expected $pingcount");
if (scalar @reply > $pingcount){
$filter = $keep eq 'yes' ? 'final received' : 'provisional received';
}
for my $item (@reply){
$self->do_debug("SipSak: looking at '$item'");
if (not $item =~ /$filter/){
$self->do_debug("SipSak: skipping as there was not match for $filter");
next;
}
if ($item =~ /(?:\sand|\sreceived\safter)\s(\d+(?:\.\d+)?)\sms\s/){
$self->do_debug("SipSak: match");
push @times,$1/1000;
}
else {
$self->do_debug("SipSak: no match");
}
}
return sort { $a <=> $b } @times;
}
sub probevars {
my $class = shift;
my $h = $class->SUPER::probevars;
return $class->_makevars($h, {
binary => {
_doc => "The location of your echoping binary.",
_default => '/usr/bin/sipsak',
_sub => sub {
my $val = shift;
-x $val or return "ERROR: binary '$val' is not executable";
return undef;
},
},
});
}
sub targetvars {
my $class = shift;
return $class->_makevars($class->SUPER::targetvars, {
user => {
_doc => "User to use for sip connection.",
_example => 'nobody',
},
port => {
_doc => "usa non-default port for the sip connection.",
_example => 5061,
},
params => {
_doc => "additional sipsak options. The options will get split on space.",
_example => '--numeric --password=mysecret'
},
keep_second => {
_doc => "If OPTIONS is actually implemented by the server, SipSak will receive two responses. If this option is set, the timeing from the second, final response will be counter",
_example => 'yes',
_re => 'yes|no'
}
});
}
1;
|