1521 lines
66 KiB
Perl
Executable file
1521 lines
66 KiB
Perl
Executable file
#!/usr/bin/perl -w
|
|
#
|
|
# Copyright(c) 2019 ADLINK Technology Limited and others
|
|
#
|
|
# This program and the accompanying materials are made available under the
|
|
# terms of the Eclipse Public License v. 2.0 which is available at
|
|
# http://www.eclipse.org/legal/epl-2.0, or the Eclipse Distribution License
|
|
# v. 1.0 which is available at
|
|
# http://www.eclipse.org/org/documents/edl-v10.php.
|
|
#
|
|
# SPDX-License-Identifier: EPL-2.0 OR BSD-3-Clause
|
|
#
|
|
|
|
use strict;
|
|
use Getopt::Long;
|
|
|
|
my @showopts = ();
|
|
my %shows = ("topic" => 0, "localdisc" => 0, "remotedisc" => 0, "user" => 1, "ack" => 0, "throttle" => 0, "block" => 0, "rematch" => 0, "in" => 1, "out" => 1, "partition" => 0, "builtin" => 0, "mtreader" => 0, "limit" => 1, "warn" => 1, "tstamp" => 0, "topic-filter" => 0, "compact" => 0, "qos" => 0);
|
|
my $topic_filter = '.';
|
|
my $topic_xfilter = '$^';
|
|
my $data_filter = '.?';
|
|
my $t0opt = undef;
|
|
my $rawip2name = undef;
|
|
my $helpflag = 0;
|
|
my $topcolwidth = 30;
|
|
my $statintv = undef;
|
|
GetOptions ("help" => \$helpflag, "show=s" => \@showopts, "topic-filter=s" => \$topic_filter, "topic-xfilter=s" => \$topic_xfilter, "data-filter=s" => \$data_filter, "t0=s" => \$t0opt, "hn=s" => \$rawip2name, "topic-width=i", \$topcolwidth, "stat=i", \$statintv)
|
|
or die "Error in command line arguments\n";
|
|
usage() if $helpflag;
|
|
for (@showopts) {
|
|
$_ =~ /^((no-?)?)(.*)/;
|
|
die "--show $_: not a known category\n" unless exists $shows{$3};
|
|
$shows{$3} = ($1 eq '') ? 1 : 0;
|
|
}
|
|
|
|
my $topfmt = "%${topcolwidth}.${topcolwidth}s";
|
|
my $guidre = "[0-9a-f]+(?::[0-9a-f]+){3}";
|
|
my $gidre = "[0-9a-f]+(?::[0-9a-f]+){2}";
|
|
my $leasere = "(?:L\\((?:[a-z]+ )?[0-9a-f:]+\\s+[0-9.]+\\)\\s*)+";
|
|
my %opstr = ("00" => "R ", "01" => "W ", # index by $stinfo.$dflag
|
|
"10" => " D ", "11" => "WD ",
|
|
"20" => " U", "21" => "W U",
|
|
"30" => " DU", "31" => "WDU");
|
|
my $self_fullversion;
|
|
my @self_version;
|
|
my %pp = ();
|
|
my %rd = ();
|
|
my %wr = ();
|
|
my %rdgid = ();
|
|
my %wrgid = ();
|
|
my %sysid = ();
|
|
my %proxypp = ();
|
|
my %pwr = ();
|
|
my %prd = ();
|
|
my %pub = ();
|
|
my %sub = ();
|
|
my %ftrflag = ();
|
|
my @ackcheck;
|
|
my ($t0sec, $t0usec);
|
|
my $prevtjump = -1e9;
|
|
my %prevts = ();
|
|
my %tlastpkt = ();
|
|
my $self_seen = 0;
|
|
my $ownip;
|
|
my %txblock = (); # indexed by xmit thread
|
|
my %txblockwr = ();
|
|
my %txblocktp = ();
|
|
my %tlast_txblock = ();
|
|
my $tlast_non_spdp_check = 0;
|
|
my $curpktvendor;
|
|
my $last_infots;
|
|
my %spdp_info;
|
|
my $hexmode = 1;
|
|
my $sysid_hex;
|
|
my $proto_ip = "(?:(?:udp[46]?|tcp[46]?)\/)?(?:[0-9.]+|\[[0-9a-fA-F:]+\])";
|
|
my %tstamps;
|
|
my %topic_qos;
|
|
my $recv_packet = 0;
|
|
my $recv_bytes = 0;
|
|
my $recv_appdata = 0;
|
|
my $xmit_packet = 0;
|
|
my $xmit_bytes = 0;
|
|
my $xmit_appdata = 0;
|
|
my $rexmit_count_req = 0;
|
|
my $rexmit_frags = 0;
|
|
my @stat_deltas;
|
|
my $next_stat_print;
|
|
my $skiplines = 0;
|
|
my $last_nonresponsive_details = "";
|
|
|
|
# Readers, writers for DDSI discovery data have entity ids, minus the
|
|
# source and kind of 2, 3, &c., with the following interpretation
|
|
# (actually, there are more ... but these are the ones I am most
|
|
# interested in)
|
|
my %discentitystr = ("2" => "TOPIC", "3" => "WRITER", "4" => "READER");
|
|
|
|
$rawip2name = do $rawip2name if defined $rawip2name;
|
|
sub ip2name {
|
|
my ($ip, $ppguid) = @_;
|
|
if (defined $rawip2name) {
|
|
return &$rawip2name(@_);
|
|
} else {
|
|
return $ip;
|
|
}
|
|
}
|
|
|
|
if (defined $t0opt) {
|
|
$t0sec = int($t0opt);
|
|
$t0usec = int(1e6 * ($t0opt - $t0sec));
|
|
}
|
|
|
|
if ($shows{"topic-filter"}) {
|
|
print "TOPIC-FILTER:\n$topic_filter\n";
|
|
}
|
|
|
|
$| = 1; # let output not be fully buffered
|
|
my $ts;
|
|
my (%psgid, %psguid, %rwgid, %rwguid);
|
|
my %isbuiltin_entitykind = (0xc2 => 1, 0xc3 => 1, 0xc4 => 1, 0xc7 => 1, 0x42 => 1, 0x43 => 1, 0x44 => 1, 0x47 => 1);
|
|
my $prevline = "";
|
|
while(<>) {
|
|
#printf $_;
|
|
s/[\r\n]+$//; # chomp;
|
|
|
|
if (defined $t0sec && /\(anon\): config: DDSI2EService\/General\/NetworkInterfaceAddress/) {
|
|
restart();
|
|
}
|
|
|
|
# Skip raw data lines, possibly inserted by DDS Security configuration, until end is reached.
|
|
if ($skiplines) {
|
|
if (/-----END CERTIFICATE-----|-----END RSA PRIVATE KEY-----/) {
|
|
$skiplines = 0;
|
|
}
|
|
next;
|
|
}
|
|
|
|
# Some cases observed where the log had a newline immediately following the time stamp, domain,
|
|
# thread prefix; so hack around those by merging a line not matching the pattern with a preceding
|
|
# line consisting of nothing but that prefix.
|
|
if (! /^(?:\d+-\d+-\d+T\d+:\d+:\d+[+-]\d+\s+)?(\d+)\.(\d+)(\/| \[(\d+)\]) *([^:]+)/ &&
|
|
$prevline =~ /^(?:\d+-\d+-\d+T\d+:\d+:\d+[+-]\d+\s+)?(\d+)\.(\d+)(\/| \[(\d+)\]) *([^:]+):\s*$/) {
|
|
$_ = $prevline . $_;
|
|
}
|
|
$prevline = $_;
|
|
|
|
last unless /^(?:\d+-\d+-\d+T\d+:\d+:\d+[+-]\d+\s+)?(\d+)\.(\d+)(\/| \[(\d+)\]) *([^:]+)/;
|
|
unless (defined $t0sec) {
|
|
($t0sec, $t0usec) = ($1, $2);
|
|
printf "T0 = %d.%06d\n", $t0sec, $t0usec;
|
|
}
|
|
$ts = ($1 - $t0sec) + ($2 - $t0usec) / 1e6;
|
|
my $dom = $4;
|
|
my $tid = $5;
|
|
$prevts{$tid} = $ts unless exists $prevts{$tid};
|
|
if ($ts < $prevts{$tid}) {
|
|
printf "%9.3f %35s $topfmt TJMP time jumped %.3fs (thread %s line $.)\n", $ts, "", "", $ts - $prevts{$tid}, $tid if $ts - $prevtjump > 1;
|
|
$prevtjump = $ts;
|
|
} elsif ($tid eq "lease" && $ts > $prevts{$tid} + 3) {
|
|
printf "%9.3f %35s $topfmt TJMP possible time jump %.3fs (thread %s line $.)\n", $ts, "", "", $ts - $prevts{$tid}, $tid if $ts - $prevtjump > 1;
|
|
}
|
|
$prevts{$tid} = $ts;
|
|
|
|
if (defined $statintv) {
|
|
if (!defined $next_stat_print) {
|
|
$next_stat_print = $ts + abs($statintv);
|
|
@stat_deltas = (0,0, 0,0, 0,0, 0, 0);
|
|
}
|
|
my @stat = ($recv_packet, $xmit_packet, $recv_bytes, $xmit_bytes, $recv_appdata, $xmit_appdata, $rexmit_count_req, $rexmit_frags);
|
|
if ($ts >= $next_stat_print) {
|
|
if ($statintv > 0) {
|
|
printf "%9.3f %35s $topfmt STAT recv/xmit: pkt %u %u bytes %u %u app %u %u rexmit: req %u frags %u\n", $ts, "", "", @stat;
|
|
} else {
|
|
my $dt = $ts - ($next_stat_print + $statintv);
|
|
for (my $i = 0; $i < @stat; $i++) {
|
|
my $x = $stat[$i];
|
|
$stat[$i] = ($x - $stat_deltas[$i]) / $dt;
|
|
$stat_deltas[$i] = $x;
|
|
}
|
|
printf "%9.3f %35s $topfmt STAT recv/xmit: pkt %f %f bytes %f %f app %f %f rexmit: req %f frags %f\n", $ts, "", "", @stat;
|
|
}
|
|
$next_stat_print = $ts + abs($statintv);
|
|
}
|
|
}
|
|
|
|
while (@ackcheck && $ackcheck[0]->{ts} < $ts) {
|
|
my $x = shift @ackcheck;
|
|
my $nsamp = scalar(acklate($ts, $x->{wrguid}, $x->{seq}));
|
|
if ($nsamp > 0) {
|
|
# note: sample count is against check reqt, not current position
|
|
# of the writer
|
|
printf "%9.3f %35s $topfmt ACK lagging by %d samples (last seq from writer: %d)\n",
|
|
$x->{ts}, fmtguid($x->{wrguid}), $wr{$x->{wrguid}}->{stopic}, $nsamp, $wr{$x->{wrguid}}->{seq}
|
|
unless $wr{$x->{wrguid}}->{acklate} || !$shows{ack} || !show_topic($wr{$x->{wrguid}}->{topic});
|
|
$wr{$x->{wrguid}}->{acklate} = $x->{tswrite};
|
|
}
|
|
}
|
|
|
|
# Check whether something other than an SPDP reasonably recently
|
|
# arrived (to guard against only SPDP keeping things alive, which is
|
|
# known to happen when network routing is configured incorrectly)
|
|
if ($ts - $tlast_non_spdp_check >= 1.0) {
|
|
while (my ($k, $v) = each %proxypp) {
|
|
if (!defined $v->{tdel} && $ts - $v->{tcreate} > 5.0 && $v->{non_spdp_seen} == 0) {
|
|
printf "%9.3f %35s $topfmt CONN nothing other than SPDP received for %3.fs, possible connectivity issue\n", $ts, fmtguid($k), "", $ts - $v->{tcreate};
|
|
$v->{non_spdp_seen} = -1; # flagging it so we don't keep repeating it
|
|
}
|
|
}
|
|
|
|
# Also check whether discovery completes within reason for all proxypp's (only in hexmode, cos it doesn't work yet in decimal mode)
|
|
if ($hexmode) {
|
|
while (my ($k, $v) = each %proxypp) {
|
|
if (!defined $v->{tdel} && $ts - $v->{tcreate} > 5.0 && !$v->{disccompleteflag} && !$v->{disccompletewarned}) {
|
|
printf "%9.3f %35s $topfmt DISC discovery not complete yet after %.3fs (%s)\n", $ts, fmtguid($k), "", $ts - $v->{tcreate}, disccomplete_diagstr ($v);
|
|
$v->{disccompletewarned} = 1;
|
|
}
|
|
}
|
|
}
|
|
$tlast_non_spdp_check = $ts;
|
|
}
|
|
|
|
for my $t (keys %txblock) {
|
|
if ($shows{block} && defined $txblock{$t} && $ts > $txblock{$t} + 1.0 && $txblock{$t} > $tlast_txblock{$t}) {
|
|
my $stopic = (exists $wr{$txblockwr{$t}}) ? $wr{$txblockwr{$t}}->{stopic} : "";
|
|
printf "%9.3f %35s $topfmt BLCK already blocked for %.3fs\n", $ts, fmtguid($txblockwr{$t}), $stopic, $ts - $txblock{$t};
|
|
if (exists $wr{$txblockwr{$t}}) {
|
|
my @lates = acklate(1e100, $txblockwr{$t});
|
|
for (@lates) {
|
|
my $cause = ($_->{haveack} ? sprintf "%d behind", $_->{nsamp} : "no ack yet");
|
|
printf "%9.3f %35s $topfmt BLCK %s (%s)\n", $ts, fmtguid($txblockwr{$t}), $stopic, fmtguid($_->{guid}), $cause;
|
|
}
|
|
}
|
|
$tlast_txblock{$t} = $txblock{$t};
|
|
}
|
|
}
|
|
|
|
if (/HDR\(([0-9a-f]+:[0-9a-f]+:[0-9a-f]+) vendor (\d+\.\d+)\).*len (\d+)/) {
|
|
my $guidpre = $1;
|
|
my $ppguid = hexify("$1:1c1");
|
|
$recv_packet++;
|
|
$recv_bytes += $3;
|
|
$curpktvendor = $2;
|
|
$last_infots = undef;
|
|
$hexmode = 1 if !(defined $hexmode) && "$guidpre" =~ /[a-f]/;
|
|
if (exists $proxypp{$ppguid}) {
|
|
my $sysid = $proxypp{$ppguid}->{sysid};
|
|
die unless exists $sysid{$sysid};
|
|
$tlastpkt{$sysid} = $ts;
|
|
undef $last_infots;
|
|
if (exists $sysid{$sysid}->{tlastpkt} && !exists $sysid{$sysid}->{tresumepkt}) {
|
|
$sysid{$sysid}->{tresumepkt} = $ts;
|
|
}
|
|
}
|
|
}
|
|
|
|
# Special handling of ACKNACK of built-in reader/writer pairs:
|
|
# generally the script completely ignores the built-in ones (maybe I
|
|
# should change that?) but it is interesting to know when all
|
|
# discovery for a participant has completed. The "happy-now" is a
|
|
# decent proxy for that.
|
|
#
|
|
# FIXME: find a way of dealing with decimal representation ...
|
|
if (/: ACKNACK\(F?#\d+:(\d+)\/(\d+):[01]* (?:$leasere)?([0-9a-f]+(?::[0-9a-f]+){2}:[234]c7) -\> ([0-9a-f]+(?::[0-9a-f]+){2}:[234]c2) .*?(happy-now)?/) {
|
|
if (defined $5 || ($1 > 1 && $2 == 0 && version_at_least(6,6,4))) {
|
|
# happy-now should be enough, but historically DDSI2 advertised only data present in the WHC,
|
|
# which caused happy-now to not show up if the historical data ended on an unregister, because
|
|
# the remote side wouldn't acknowledge the sequence numbers between the last available and the
|
|
# last one written (that is, unregistered) (fixed in 6.6.4)
|
|
check_disccomplete("A", $3);
|
|
}
|
|
} elsif (/: HEARTBEAT\(F?L?#\d+:(\d+)\.\.(\d+)\s+(?:$leasere)?([0-9a-f]+(?::[0-9a-f]+){2}:[234]c2)/) {
|
|
check_disccomplete("H", $3);
|
|
# if there is no data and final is set there might be no ACK
|
|
check_disccomplete("B", $3) if $2 < $1;
|
|
} elsif (/tev: acknack (?:$guidre) -\> ([0-9a-f]+(?::[0-9a-f]+){2}:[234]c2): #\d+:(\d+)\/0:$/o && $2 > 1) {
|
|
check_disccomplete("B", $1);
|
|
}
|
|
|
|
if (/recv(?:UC|MC)?: INFOTS\((\d+)\.(\d+)\)/) {
|
|
# Special handling of INFOTS for guessing at source time stamps (in particular also
|
|
# for guessing at start times of other nodes
|
|
$last_infots = ($1 - $t0sec) + ($2/1e3 - $t0usec) / 1e6;
|
|
} elsif ($hexmode ? m/recv(?:UC|MC)?: DATA\(((?:[0-9a-f]+:){3}100c2) -> ($guidre)/ : m/recv(?:UC|MC)?: DATA\(((?:[0-9a-f]+:){3}65730) -> ($guidre)/) {
|
|
# SPDP for extracting start times of remote nodes and making an informed guess as to
|
|
# whether the remote node learned of our existence because we sent a multicast or a
|
|
# unicast
|
|
my $src = $1; my $dst = $2;
|
|
(my $ppguid = hexify($src)) =~ s/:(100c2|65730)$/:1c1/;
|
|
my $directed = ($dst !~ /^0:0:0:/);
|
|
$spdp_info{$ppguid} = { ts => $last_infots, vendor => $curpktvendor };
|
|
if ($directed && exists $proxypp{$ppguid} && not defined $proxypp{$ppguid}->{tdel}) {
|
|
# Other discovered us because of a multicast: perfectly normal unless it happens
|
|
# relatively long after discovery. "Relatively long" being a pretty difficult
|
|
# concept to work with, we use the "discovery complete" flag to see if it is a
|
|
# likely asymmetrical disconnect
|
|
if ($proxypp{$ppguid}->{disccompleteflag} && $ts > $proxypp{$ppguid}->{tasymdisc} + 5) {
|
|
my $sysid = $proxypp{$ppguid}->{sysid};
|
|
my $sx = decimal_sysid($sysid);
|
|
printf "%9.3f %35s $topfmt ASYM %s (%s; %s; %s) likely asymmetrical disconnect\n", $ts, $sysid, "", $sysid{$sysid}->{ip}, $sx, $sysid{$sysid}->{name}, vendorstr($spdp_info{$ppguid}->{vendor});
|
|
$proxypp{$ppguid}->{tasymdisc} = $ts;
|
|
}
|
|
}
|
|
} elsif (/: ACKNACK\(#\d+:1\/0:\s+(?:$leasere)?([0-9a-f]+(?::[0-9a-f]+){2}:([34])c7) -\>/) {
|
|
# An ACKNACK that acks nothing, nacks nothing and requests a response (no "F" flag
|
|
# present) is a tell-tale sign of a pre-emptive ACKNACK. Receipt of one of those
|
|
# after having received a normal one is indicative of an asymmetrical disconnect.
|
|
# Detecting when all is well again is too hard. Being lazy, we simply gate it with
|
|
# the "discovery complete" flag and suppress it within a window of 1s.
|
|
my $src = $1; my $src_id = $2;
|
|
(my $ppguid = hexify($src)) =~ s/:[0-9a-f]+$/:1c1/;
|
|
if (exists $proxypp{$ppguid} && $proxypp{$ppguid}->{disccompleteflag} && $ts > $proxypp{$ppguid}->{tasymdisc} + 1) {
|
|
my $sysid = $proxypp{$ppguid}->{sysid};
|
|
my $sx = decimal_sysid($sysid);
|
|
printf "%9.3f %35s $topfmt ASYM %s (%s; %s; %s) likely asymmetrical disconnect\n", $ts, $sysid, "", $sysid{$sysid}->{ip}, $sx, $sysid{$sysid}->{name}, vendorstr($spdp_info{$ppguid}->{vendor});
|
|
$proxypp{$ppguid}->{tasymdisc} = $ts;
|
|
}
|
|
}
|
|
|
|
if (/: ownip: ($proto_ip)/o) {
|
|
$ownip = $1;
|
|
$ownip =~ s/^(udp|tcp)[46]?\///;
|
|
} elsif (/: PARTICIPANT ($guidre) QOS=\{/o) {
|
|
my $guid = hexify($1);
|
|
(my $gid = $guid) =~ s/:[^:]+$//;
|
|
my $userdata = $_;
|
|
if ($userdata =~ s/.*QOS=\{.*?user_data=//) {
|
|
$userdata =~ s/\}$//;
|
|
$userdata =~ s/,(?:(?:prismtech|adlink)_)?entity_factory=\d$//;
|
|
$userdata = " userdata:$userdata";
|
|
} else {
|
|
$userdata = "";
|
|
}
|
|
my ($name, $sname);
|
|
if ($userdata =~ /^ userdata:\d+<"name=(.*);namespace=(.*);">$/) {
|
|
$name = $sname = $1;
|
|
$sname = "...".substr $sname, -25 if length $sname > 25;
|
|
} else {
|
|
$name = $sname = ip2name($ownip, $guid);
|
|
}
|
|
$pp{$guid} = { gid => $gid, guid => $guid, name => $name, sname => $sname, sub => {}, pub => {} };
|
|
if (! $self_seen) {
|
|
(my $sysid = $guid) =~ s/:1c1$//;
|
|
$self_seen = 1;
|
|
$sysid{$sysid} = { self => 1, ip => $ownip, name => $name, sname => $sname };
|
|
my $sx = decimal_sysid($sysid);
|
|
printf "%9.3f %35s $topfmt SELF node %s (%s; %s) alive\n", $ts, $sysid, "", $ownip, $sx, $sysid{$sysid}->{name};
|
|
}
|
|
printf "%9.3f LOCAL PARTICIPANT %s (%s)\n", $ts, fmtguid($guid), $gid if $shows{localdisc};
|
|
} elsif (/: unref_participant\(($guidre) .*user 0 builtin 0/o) {
|
|
my $guid = hexify($1);
|
|
(my $gid = $guid) =~ s/:[^:]+$//;
|
|
printf "%9.3f DELETE LOCAL PARTICIPANT %s (%s)\n", $ts, fmtguid($guid), $gid if $shows{localdisc};
|
|
} elsif (/: map group ($gidre) -> ($guidre)/o) {
|
|
$psgid{$tid} = hexify($1);
|
|
$psguid{$tid} = hexify($2);
|
|
} elsif (/: new_(reader|writer)\(gid ($gidre)\)$/o) {
|
|
$rwgid{$tid} = hexify($2);
|
|
} elsif (/: new_(reader|writer)\(guid ($guidre)/o) {
|
|
$rwguid{$tid} = hexify($2);
|
|
} elsif (/new_fictitious_transient_reader/) {
|
|
$ftrflag{$tid} = 1; # no GID or subscriber
|
|
} elsif (/: (READER|WRITER) ($guidre) QOS=\{(.*)/o) {
|
|
my $kind = $1;
|
|
my $guid = hexify($2);
|
|
my $g = ($1 eq "READER") ? \%sub : \%pub;
|
|
my $h = ($1 eq "READER") ? \%rd : \%wr;
|
|
my $hgid = ($1 eq "READER") ? \%rdgid : \%wrgid;
|
|
my $gk = ($1 eq "READER") ? "sub" : "pub";
|
|
my $hk = ($1 eq "READER") ? "rd" : "wr";
|
|
my $qos = $3;
|
|
$rwguid{$tid} = $guid; # if $is_cyclone;
|
|
die "$guid $rwguid{$tid}" unless $guid eq $rwguid{$tid};
|
|
my $topic; my $type; my $groupcoh; my $partitions; my $keepall;
|
|
# GUID prefix of 0:0:0: local built-in writer
|
|
my $local_builtin = ($guid =~ /^0:0:0:/);
|
|
if (! $local_builtin && $qos =~ /topic(?:_name)?="?([^,"]+?)"?,type(?:_name)="?([^,"]+?)"?.*?,partition=\{([^}]*?)\}/) {
|
|
$topic = $1; $type = $2; $partitions = $3;
|
|
die unless $qos =~ /,history=([01]):/; $keepall = $1;
|
|
die unless $qos =~ /,presentation=(\d:\d):\d/; $groupcoh = ($1 eq "2:1");
|
|
unless (defined $rwguid{$tid} && ($ftrflag{$tid} || (defined $psgid{$tid} && defined $psguid{$tid} && defined $rwgid{$tid})) || 1) { # $is_cyclone
|
|
die;
|
|
}
|
|
$rwgid{$tid} = $psguid{$tid} = $psgid{$tid} = "" if 1; # $is_cyclone;
|
|
} else {
|
|
# all-zero GUID prefix or no topic, type: DDSI built-in reader/writer
|
|
if (defined $rwgid{$tid} || $ftrflag{$tid}) {
|
|
die;
|
|
}
|
|
if (defined $psgid{$tid} || defined $psguid{$tid}) {
|
|
# in some cases, we have a pub/sub gid+guid set for an
|
|
# internal reader (depends on the order of discovery)
|
|
die unless $rwguid{$tid} =~ /[4c][27]$/;
|
|
}
|
|
$psgid{$tid} = $psguid{$tid} = $rwgid{$tid} = "";
|
|
$rwguid{$tid} = $guid;
|
|
$topic = ""; $type = ""; $partitions = ""; $keepall = 0; $groupcoh = 0;
|
|
}
|
|
#if (defined $rwgid{$tid} && $rwgid{$tid} =~ /:([0-9a-f]+):/ && hex($1) >= 0x400000 && !(defined $psgid{$tid} && defined $psguid{$tid})) {
|
|
# # R&R reader, which also means no group GID => fake one by reusing the rw gid/guid
|
|
# $psgid{$tid} = $rwgid{$tid};
|
|
# $psguid{$tid} = $rwguid{$tid};
|
|
#}
|
|
my @ps = split ',', $partitions;
|
|
$psgid{$tid} = $psguid{$tid} = $rwgid{$tid} = "" if $ftrflag{$tid};
|
|
(my $ppguid = $rwguid{$tid}) =~ s/:[^:]+$/:1c1/;
|
|
if (! exists $pp{$ppguid}->{$gk}->{$psguid{$tid}}) {
|
|
$pp{$ppguid}->{$gk}->{$psguid{$tid}} =
|
|
{ gid => $psgid{$tid}, guid => $psguid{$tid}, ppguid => $ppguid, $hk => {} };
|
|
}
|
|
my $stopic = make_stopic($partitions, $topic);
|
|
#print "FTR $topic\n" if $ftrflag;
|
|
my $rw = { gid => $rwgid{$tid}, guid => $rwguid{$tid}, psguid => $psguid{$tid}, ppguid => $ppguid,
|
|
topic => $topic, stopic => $stopic, type => $type, partition => \@ps,
|
|
matches => {}, nhappy => 0, seq => 0, acklate => 0, cs => undef, keepall => $keepall,
|
|
groupcoh => $groupcoh };
|
|
$pp{$ppguid}->{$gk}->{$psguid{$tid}}->{$rwguid{$tid}} = $rw;
|
|
$h->{$rwguid{$tid}} = $rw;
|
|
$hgid->{$rwgid{$tid}} = $rw;
|
|
$g->{$psguid{$tid}} = { gid => $psgid{$tid}, guid => $psguid{$tid}, es => {}, txn => 0, durqos => undef } unless exists $g->{$psguid{$tid}};
|
|
$g->{$psguid{$tid}}->{es}->{$rwguid{$tid}} = 1;
|
|
my $gidstr;
|
|
if ($rwgid{$tid} eq '') {
|
|
$gidstr = "no gid";
|
|
} else {
|
|
$gidstr = sprintf "gid %s ${gk}gid %s", $rwgid{$tid}, $psgid{$tid};
|
|
}
|
|
printf "%9.3f LOCAL $kind %s %s {%s} (%s)\n", $ts, fmtguid($rwguid{$tid}), $topic, $partitions, $gidstr if $shows{localdisc} && $topic =~ /$topic_filter/o && $topic !~ /$topic_xfilter/o;
|
|
check_qos($ts, $kind, fmtguid($rwguid{$tid}), $topic, $partitions, $qos, $g->{$psguid{$tid}});
|
|
$psgid{$tid} = $psguid{$tid} = $rwgid{$tid} = $rwguid{$tid} = undef;
|
|
$ftrflag{$tid} = 0;
|
|
} elsif (/rtps_write\(gid ($gidre)\) - seq (\d+) txn id (\d+) (begin|end)s/o) {
|
|
my $wrgid = hexify($1); my $kseq = $2; my $ktxnid = $3; my $op = uc $4;
|
|
die unless defined $wrgid{$wrgid};
|
|
my $wrguid = $wrgid{$wrgid}->{guid};
|
|
my $wr = $wr{$wrguid};
|
|
die unless defined $wr;
|
|
my $pub = $pub{$wr->{psguid}};
|
|
die unless defined $pub;
|
|
if ($op eq "BEGIN") {
|
|
die if defined $wr->{cs};
|
|
if ($pub->{txn} == 0) {
|
|
$pub->{txn} = keys %{$pub->{es}};
|
|
printf "%9.3f %35s $topfmt %16s XMT BEGIN [%d writers]\n", $ts, fmtguid($pub->{guid}), "", "", $pub->{txn}
|
|
if $shows{out};
|
|
}
|
|
$wr->{cs} = { seq => undef, ktxn => $ktxnid, kseq => $kseq }; # seq will be filled in with the first sample
|
|
} elsif ($op eq "END") {
|
|
if (defined $wr->{cs}) {
|
|
my $nk = $kseq - $wr->{cs}->{kseq};
|
|
my $nd = defined $wr->{cs}->{seq} ? $wr->{seq} - $wr->{cs}->{seq} + 1 : 0;
|
|
if ($nk != $nd) {
|
|
my $keeplastmsg = $wr->{keepall} ? " (weird)" : " - change writer to use a keep-all history";
|
|
printf "%9.3f %35s $topfmt %s #%-4d %-6s EOTX kernel has %d but DDSI %d samples in txn%s\n", $ts, fmtguid($wrguid), $wr->{stopic}, "", $wr->{seq}, "", $nk, $nd, $keeplastmsg;
|
|
}
|
|
} else {
|
|
# assume empty transaction
|
|
$wr->{cs} = { seq => $wr->{seq}+1, ktxn => $ktxnid, kseq => $kseq } unless defined $wr->{cs};
|
|
}
|
|
# not clearing: doing that when seeing the EoT
|
|
} else {
|
|
die;
|
|
}
|
|
} elsif (/: (?:tk=(?:0x)?[0-9A-Fa-f]+ iid=[0-9a-f]+)?write_sample ($guidre) #(\d+)((?: C#(?:\d+))?): ST(\d+) [^\{]+?(\{.*(?:\}|\(trunc\))|:k:\{.*\}|:e:\(blob\)|$)/o) {
|
|
# tk=... iid=... and absence of data is typical for Lite/Cyclone
|
|
my $wrguid = hexify($1); my $seq = $2; my $cseq = $3; my $st = $4; my $data = defined $5 ? $5 : '';
|
|
my $dflag = ($data =~ /^:[ek]:/ ? 0 : 1);
|
|
$cseq =~ s/^ C#//;
|
|
# all but built-in writers must have been found in the log
|
|
if (!defined $wr{$wrguid} && $wrguid !~ /[4c][23]$/) {
|
|
die;
|
|
}
|
|
if (!defined ($wr{$wrguid}->{topic})) {
|
|
# PMD looks like regular data but is built-in without a topic name
|
|
die unless $wrguid =~ /[4c][23]$/;
|
|
} else {
|
|
my $wr = $wr{$wrguid};
|
|
$cseq = "C#$cseq" if $cseq ne "";
|
|
my $dest = getdest($wrguid);
|
|
$wr->{seq} = $seq;
|
|
if (defined $wr->{cs}) {
|
|
$wr->{cs}->{seq} = $seq unless defined $wr->{cs}->{seq};
|
|
}
|
|
if (scalar (keys %{$wr->{matches}}) > 0) {
|
|
push @ackcheck, { ts => $ts + 1, tswrite => $ts, wrguid => $wrguid, seq => $seq };
|
|
}
|
|
my $op = ($data =~ /^:e:/) ? "W " : $opstr{$st.$dflag};
|
|
my $print = 0;
|
|
my $printlim = $shows{limit};
|
|
$xmit_appdata++;
|
|
$print = show_topic($wr->{topic}) && $shows{out};
|
|
$print = 0 unless $data =~ /$data_filter/o;
|
|
my $sdata = $printlim ? (sprintf "%-100.100s", $data) : (sprintf "%-100s", $data);
|
|
printf "%9.3f %35s $topfmt %s #%-4d %-6s XMT %s -> %s\n", $ts, fmtguid($wrguid), $wr->{stopic}, $op, $seq, $cseq, $sdata, $dest if $print;
|
|
if ($data =~ /^:e:/ && defined $wr->{cs}) {
|
|
# assume empty transaction if no $wr->{cs}
|
|
my $pub = $pub{$wr->{psguid}};
|
|
die unless defined $pub;
|
|
$wr->{cs} = undef;
|
|
if ($pub->{txn} == 0) {
|
|
# presumably an empty transaction
|
|
$pub->{txn} = keys %{$pub->{es}};
|
|
printf "%9.3f %35s $topfmt %16s XMT BEGIN [empty, %d writers]\n", $ts, fmtguid($pub->{guid}), "", "", $pub->{txn} if $shows{out};
|
|
}
|
|
if (--$pub->{txn} == 0) {
|
|
printf "%9.3f %35s $topfmt %16s XMT COMMIT\n", $ts, fmtguid($pub->{guid}), "", ""
|
|
if $shows{out};
|
|
}
|
|
}
|
|
}
|
|
} elsif (/: (?:SPDP ST\d+)?SPDP ST(\d) ($guidre)\s+bes\s+([0-9a-f]+)\s+.*NEW(?: processguid ($guidre) )?.*?meta(?: ${proto_ip}:\d+)*? (${proto_ip}:\d+)\)/o) {
|
|
my $st = $1; my $ppguid = hexify($2); my $bes = hex $3; my $processguid = $4; my $ip = $5;
|
|
$ip =~ s/^(udp|tcp)[46]?\///;
|
|
my $hostname = $ip;
|
|
my $sysid;
|
|
if (defined $processguid) {
|
|
($sysid = $processguid) =~ s/:1c1$//;
|
|
} elsif (/(?:0x[0-9a-f]+-){4}0x[0-9a-f]+ ([^\/]*)\//) {
|
|
# Cyclone or OpenSplice; Cyclone GUIDs are crazy numbers, OpenSplice has smallish ones for
|
|
# the 2nd and 3rd word
|
|
$hostname = $1;
|
|
$ppguid =~ /:([0-9a-f]+):([0-9a-f]+)/ or die;
|
|
if (hex $1 < 2**20 && hex $2 < 10**4) {
|
|
# presumably OSPL: first word is system id
|
|
($sysid = $ppguid) =~ s/:.*//;
|
|
} else {
|
|
# presumably Cyclone, old format: 2nd word is process id; new format: altogether
|
|
# crazy -- so don't bother with the old one
|
|
($sysid = $ppguid) =~ s/:1c1$//;
|
|
}
|
|
} else {
|
|
($sysid = $ppguid) =~ s/:1c1$//;
|
|
}
|
|
my $userdata = $_;
|
|
if ($userdata =~ s/.*QOS=\{.*?user_data=//) {
|
|
$userdata =~ s/\}$//;
|
|
$userdata =~ s/,entity_factory=\d$//;
|
|
$userdata = " userdata:$userdata";
|
|
} else {
|
|
$userdata = "";
|
|
}
|
|
my ($name, $sname);
|
|
if ($userdata =~ /^ userdata:\d+<"name=(.*);namespace=(.*);">$/) {
|
|
$name = $sname = $1;
|
|
$sname = "...".substr $sname, -25 if length $sname > 25;
|
|
} else {
|
|
$name = $sname = ip2name($ip, $ppguid);
|
|
}
|
|
my $note = "";
|
|
if (exists $sysid{$sysid} && defined $sysid{$sysid}->{tcrash}) {
|
|
printf "%9.3f %35s $topfmt DISC node %s apparently not disconnected as assumed before\n",
|
|
$ts, $sysid, "", $ip;
|
|
$sysid{$sysid}->{tcrash} = undef;
|
|
}
|
|
if ($st != 0) {
|
|
# should know it, but I guess it might not if one were to receive a dispose followed by an unregister
|
|
# actually deleting is deferred
|
|
#printf "%9.3f LEAVE %s\n", $ts, $ppguid;
|
|
} else {
|
|
$sysid{$sysid} = { npp => 0, ip => $ip, name => $name, sname => $sname, tdel => undef, tcrash => undef } unless defined $sysid{$sysid};
|
|
if ($sysid{$sysid}->{npp}++ > 0) {
|
|
die if defined $sysid{$sysid}->{tdel};
|
|
} elsif (! defined $sysid{$sysid}->{tdel}) {
|
|
my $x = defined $spdp_info{$ppguid}->{ts} ? sprintf " (started at %.3fs)", $spdp_info{$ppguid}->{ts} : "";
|
|
my $sx = decimal_sysid($sysid);
|
|
printf "%9.3f %35s $topfmt DISC node %s (%s; %s; %s) alive%s%s\n", $ts, $sysid, "", $ip, $sx, $sysid{$sysid}->{name}, vendorstr($spdp_info{$ppguid}->{vendor}), $x, $userdata;
|
|
} else {
|
|
my $dt = $ts - $sysid{$sysid}->{tdel};
|
|
my $dtgapstr;
|
|
if (defined $sysid{$sysid}->{tresumepkt} && defined $sysid{$sysid}->{tlastpkt}) {
|
|
$dtgapstr = sprintf "%.3fs", $sysid{$sysid}->{tresumepkt} - $sysid{$sysid}->{tlastpkt} if defined $sysid{$sysid}->{tresumepkt} && defined $sysid{$sysid}->{tlastpkt};
|
|
} else {
|
|
$dtgapstr = "unavailable";
|
|
}
|
|
my $sx = decimal_sysid($sysid);
|
|
$sysid{$sysid}->{tdel} = undef;
|
|
delete $sysid{$sysid}->{tlastpkt};
|
|
delete $sysid{$sysid}->{tresumepkt};
|
|
printf "%9.3f %35s $topfmt DISC node %s (%s; %s; %s) alive again after %.3fs (disconnect estimate %s)\n", $ts, $sysid, "", $ip, $sx, $sysid{$sysid}->{name}, vendorstr($spdp_info{$ppguid}->{vendor}), $dt, $dtgapstr;
|
|
}
|
|
if (! exists $proxypp{$ppguid}) {
|
|
$proxypp{$ppguid} =
|
|
{ guid => $ppguid,
|
|
sysid => $sysid,
|
|
vendor => $spdp_info{$ppguid}->{vendor},
|
|
ip => $ip,
|
|
name => $name,
|
|
sname => $sname,
|
|
infots => $spdp_info{$ppguid}->{ts},
|
|
tcreate => $ts,
|
|
tasymdisc => $ts,
|
|
non_spdp_seen => 0,
|
|
disccomplete => init_proxypp_disccomplete($bes),
|
|
disccompleteflag => 0,
|
|
disccompletewarned => 0 };
|
|
#printf "%9.3f DISCOVER %s @ %s\n", $ts, $ppguid, $ip;
|
|
} else {
|
|
die unless defined $proxypp{$ppguid}->{tdel};
|
|
my $dt = $ts - $proxypp{$ppguid}->{tdel};
|
|
$proxypp{$ppguid}->{tdel} = undef;
|
|
$proxypp{$ppguid}->{tcreate} = $ts;
|
|
$proxypp{$ppguid}->{non_spdp_seen} = 0;
|
|
$proxypp{$ppguid}->{disccomplete} = {};
|
|
$proxypp{$ppguid}->{disccompleteflag} = 0;
|
|
$proxypp{$ppguid}->{disccompletewarned} = 0;
|
|
#printf "%9.3f REDISCOVER %s @ %s - gone for %.3fs\n", $ts, $ppguid, $ip, $dt;
|
|
}
|
|
}
|
|
} elsif (/lease expired:.*? guid ($guidre)/o) {
|
|
# actually deleting is deferred
|
|
my $ppguid = hexify($1);
|
|
die unless exists $proxypp{$ppguid};
|
|
my $sysid = $proxypp{$ppguid}->{sysid};
|
|
my $sx = decimal_sysid($sysid);
|
|
# participant lease expiry doesn't necessarily mean a
|
|
# disconnection, but let's assume it does
|
|
die unless defined $sysid{$sysid};
|
|
if (!defined $sysid{$sysid}->{tcrash}) {
|
|
my $lastpacketmsg = exists $tlastpkt{$sysid} ? sprintf " last packet %.3fs ago", $ts - $tlastpkt{$sysid} : "";
|
|
printf "%9.3f %35s $topfmt DIED assuming disconnect of node %s (%s; %s)%s\n",
|
|
$ts, fmtguid($ppguid), "", $sysid{$sysid}->{ip}, $sx, $sysid{$sysid}->{name}, $lastpacketmsg;
|
|
$sysid{$sysid}->{tcrash} = $ts;
|
|
$sysid{$sysid}->{tlastpkt} = exists $tlastpkt{$sysid} ? $tlastpkt{$sysid} : $ts;
|
|
}
|
|
} elsif (/unref_proxy_participant\(($guidre)\).*freeing/o) {
|
|
my $ppguid = hexify($1);
|
|
die unless exists $proxypp{$ppguid} && ! defined $proxypp{$ppguid}->{tdel};
|
|
delete_proxypp($ts, $ppguid);
|
|
} elsif (/: SEDP ST0.*unknown-proxypp.*from-DS.*new-proxypp ($guidre)/o) {
|
|
my $ppguid = hexify($1); my $ip = "from-DS"; my $sysid = sysid_from_guid ($ppguid);
|
|
my $sx = decimal_sysid($sysid);
|
|
my $name = ip2guid($ip, $ppguid);
|
|
my $sname = $name;
|
|
$sysid{$sysid} = { npp => 0, ip => $ip, name => $name, sname => $sname, tdel => undef, tcrash => undef } unless defined $sysid{$sysid};
|
|
$sysid{$sysid}->{npp}++;
|
|
printf "%9.3f %35s $topfmt DISC %s (%s; %s; %s)\n", $ts, $sysid, "", $ip, $sx, $sysid{$sysid}->{name}, vendorstr($spdp_info{$ppguid}->{vendor});
|
|
$proxypp{$ppguid} =
|
|
{ guid => $ppguid,
|
|
sysid => $sysid,
|
|
vendor => $spdp_info{$ppguid}->{vendor},
|
|
ip => $ip,
|
|
name => $name,
|
|
sname => $sname,
|
|
infots => $spdp_info{$ppguid}->{ts},
|
|
tcreate => $ts,
|
|
non_spdp_seen => 0,
|
|
disccomplete => 1,
|
|
disccompleteflag => 1,
|
|
disccompletewarned => 0 };
|
|
} elsif (/: SEDP ST0 ($guidre)(?: \(cont\))? [a-z_ -]*(reader|writer): .*QOS=\{(.*)/o) {
|
|
my $prwguid = hexify($1); my $kind = uc $2;
|
|
my $h = ($kind eq "READER") ? \%prd : \%pwr;
|
|
my $hk = ($kind eq "READER") ? "prd" : "pwr";
|
|
my $qos = $3;
|
|
unless ($qos =~ /topic(?:_name)?="?([^,"]+?)"?,type(?:_name)?="?([^,"]+?)"?,(?:.+?,)?partition=\{([^}]*?)\}/) {
|
|
die unless $prwguid =~ /[4c][27]$/;
|
|
}
|
|
my $topic = $1; my $type = $2; my $partitions = $3;
|
|
(my $ppguid = $prwguid) =~ s/:[0-9a-f]+$/:1c1/;
|
|
die unless exists $proxypp{$ppguid} && !defined $proxypp{$ppguid}->{tdel};
|
|
my @ps = split ',', $partitions;
|
|
my $stopic = make_stopic($partitions, $topic);
|
|
my $prw = { guid => $prwguid, ppguid => $ppguid,
|
|
topic => $topic, stopic => $stopic, type => $type, partition => \@ps,
|
|
matches => {}, checklost => 0, suppressbegin => 0, tcreate => $ts, tstamps => {} };
|
|
if (! exists $h->{$prwguid}) {
|
|
$proxypp{$ppguid}->{$hk}->{$prwguid} = $prw;
|
|
$h->{$prwguid} = $prw;
|
|
printf "%9.3f DISCOVER $kind %s %s {%s}\n", $ts, fmtguid($prwguid), $topic, $partitions
|
|
if $shows{remotedisc} && $topic =~ /$topic_filter/o && $topic !~ /$topic_xfilter/o;
|
|
} else {
|
|
my $x = $h->{$prwguid};
|
|
die unless defined $x->{tdel};
|
|
die unless $x->{topic} eq $prw->{topic};
|
|
my $dt = $ts - $x->{tdel};
|
|
$x->{tdel} = undef;
|
|
if ($x->{explicitdel}) {
|
|
printf "%9.3f REDISCOVER ZOMBIE $kind %s %s - gone for %.3fs\n", $ts, fmtguid($prwguid), $stopic, $dt;
|
|
} else {
|
|
printf "%9.3f REDISCOVER $kind %s %s - gone for %.3fs\n", $ts, fmtguid($prwguid), $stopic, $dt
|
|
if $shows{remotedisc} && $topic =~ /$topic_filter/o && $topic !~ /$topic_xfilter/o;
|
|
}
|
|
}
|
|
check_qos($ts, $kind, fmtguid($prwguid), $topic, $partitions, $qos, undef);
|
|
} elsif (/(?:match_proxy_writer_with_readers|match_proxy_reader_with_writers)\((prd|pwr) ($gidre):([0-9a-f]+)(?{ $hexmode ? hex($3)%256 : $3%256 })/ && $isbuiltin_entitykind{$^R}) {
|
|
# this depends on GUIDs in hex ...
|
|
my $kind = $1; my $prwguid = hexify("$2:$3");
|
|
my $h = ($kind eq "prd") ? \%prd : \%pwr;
|
|
my $hk = $kind;
|
|
(my $ppguid = $prwguid) =~ s/:[0-9a-f]+$/:1c1/;
|
|
do{print "$_\n";die} unless exists $proxypp{$ppguid} && !defined $proxypp{$ppguid}->{tdel};
|
|
my $prw = { guid => $prwguid, ppguid => $ppguid,
|
|
topic => "", stopic => "", type => "", partition => [""],
|
|
matches => {}, checklost => 0, suppressbegin => 0, tcreate => $ts };
|
|
# the rest is copy-paste from the application reader/writer case
|
|
if (! exists $h->{$prwguid}) {
|
|
$proxypp{$ppguid}->{$hk}->{$prwguid} = $prw;
|
|
$h->{$prwguid} = $prw;
|
|
printf "%9.3f DISCOVER $kind %s %s {%s}\n", $ts, fmtguid($prwguid), $prw->{topic}, $prw->{partitions}
|
|
if $shows{remotedisc} && $prw->{topic} =~ /$topic_filter/o && $prw->{topic} !~ /$topic_xfilter/o;
|
|
} else {
|
|
my $x = $h->{$prwguid};
|
|
if (defined $x->{tdel}) {
|
|
die unless $x->{topic} eq $prw->{topic};
|
|
my $dt = $ts - $x->{tdel};
|
|
$x->{tdel} = undef;
|
|
if ($x->{explicitdel}) {
|
|
printf "%9.3f REDISCOVER ZOMBIE $kind %s %s - gone for %.3fs\n", $ts, fmtguid($prwguid), $prw->{stopic}, $dt;
|
|
} else {
|
|
printf "%9.3f REDISCOVER $kind %s %s - gone for %.3fs\n", $ts, fmtguid($prwguid), $prw->{stopic}, $dt
|
|
if $shows{remotedisc} && $prw->{topic} =~ /$topic_filter/o && $prw->{topic} !~ /$topic_xfilter/o;
|
|
}
|
|
} else {
|
|
printf "%9.3f RECHECK $kind %s %s {%s}\n", $ts, fmtguid($prwguid), $prw->{stopic}, $prw->{partitions}
|
|
if $shows{remotedisc} && $prw->{topic} =~ /$topic_filter/o && $prw->{topic} !~ /$topic_xfilter/o;
|
|
}
|
|
}
|
|
} elsif (/((?:SEDP ST3 (?:$guidre))?)delete_proxy_(reader|writer) \(($guidre)/o) {
|
|
my $guid = hexify($3);
|
|
if ($2 eq "reader") {
|
|
delete_prd($ts, $guid, ($1 eq "") ? 1 : 0);
|
|
} else {
|
|
delete_pwr($ts, $guid, ($1 eq "") ? 1 : 0);
|
|
}
|
|
} elsif (/gc_delete_(reader|writer)\((?:0[xX])?[0-9a-f]+, ($guidre)/o) {
|
|
# somewhat imprecise, as deleting a writer may take a significant amount of time
|
|
my $kind = uc $1; my $guid = hexify($2);
|
|
my $g = ($kind eq "READER") ? \%sub : \%pub;
|
|
my $h = ($kind eq "READER") ? \%rd : \%wr;
|
|
next unless exists $h->{$guid};
|
|
my $x = $h->{$guid};
|
|
die
|
|
if exists $x->{tdel};
|
|
my $topic = $x->{topic};
|
|
my $gk = ($kind eq "READER") ? "sub" : "pub";
|
|
printf "%9.3f DELETE LOCAL $kind %s %s%s\n", $ts, fmtguid($guid), $topic, ($kind eq "WRITER" && $x->{nhappy} < scalar (keys %{$x->{matches}})) ? " (while unhappy)" : "" if $shows{localdisc} && $topic =~ /$topic_filter/o && $topic !~ /$topic_xfilter/o;
|
|
$x->{tdel} = $ts;
|
|
} elsif (/proxy_writer_add_connection\(pwr ($guidre) rd ($guidre)\)/o) {
|
|
next if /already connected/;
|
|
my $pwrguid = hexify($1); my $rdguid = hexify($2);
|
|
die unless exists $pwr{$pwrguid} || $pwrguid =~ /[4c][23]$/;
|
|
die unless exists $rd{$rdguid} || $rdguid =~ /[4c][74]$/;
|
|
#die if defined $pwr{$pwrguid}->{tdel}; # the order reversal is possible, however unlikely
|
|
#next if $pwrguid =~ /[4c]2$/;
|
|
$pwr{$pwrguid}->{matches}->{$rdguid} = {};
|
|
$rd{$rdguid}->{matches}->{$pwrguid} = {};
|
|
} elsif (/writer_add_connection\(wr ($guidre) prd ($guidre)\)((?: - ack seq 9223372036854775807)?)/o) {
|
|
next if /already connected/;
|
|
my $wrguid = hexify($1); my $prdguid = hexify($2); my $bereader = $3 ne '';
|
|
die unless exists $wr{$wrguid} || $wrguid =~ /[4c][23]$/;
|
|
die unless exists $prd{$prdguid} || $prdguid =~ /[4c][74]$/;
|
|
#die if defined $prd{$prdguid}->{tdel}; # the order reversal is possible, however unlikely
|
|
#next if $wrguid =~ /[4c]2$/;
|
|
my $wr = $wr{$wrguid};
|
|
my $prd = $prd{$prdguid};
|
|
$wr->{matches}->{$prdguid} = { seqp1 => 0, happy => ($bereader ? 1 : 0), thappy => ($bereader ? $ts : 1e100), tmatch => $ts };
|
|
$wr->{nhappy}++ if $bereader;
|
|
if (! exists $prd->{matches}->{$wrguid}) {
|
|
$prd->{matches}->{$wrguid} = {};
|
|
} else {
|
|
die unless defined $prd->{matches}->{$wrguid}->{seqp1del};
|
|
# nlost can become -1 if $wr->{seq} is still 0, which can happen
|
|
# if we sent a GAP for seq 1 to get a valid HEARTBEAT out in
|
|
# response to an ACKNACK; seqp1del can be 0, too ...
|
|
my $nlost;
|
|
if ($wr->{seq} == 0) {
|
|
warn
|
|
if $prd->{matches}->{$wrguid}->{seqp1del} > 2;
|
|
$nlost = 0;
|
|
} else {
|
|
$nlost = $wr->{seq} - $prd->{matches}->{$wrguid}->{seqp1del} + 1;
|
|
}
|
|
printf "%9.3f %35s $topfmt MTCH %s rematch %d lost\n", $ts, fmtguid($wrguid), $wr->{stopic}, $prdguid, $nlost
|
|
if $nlost > 0 && $shows{rematch};
|
|
delete $prd->{matches}->{$wrguid}->{seqp1del};
|
|
}
|
|
} elsif (/ACKNACK\(F?#\d+:(\d+)\/\d+:([01]*) (?:$leasere)?($guidre) -> ($guidre)(\??)/o) {
|
|
my $seqp1 = $1; my $nackset = $2; my $prdguid = hexify($3); my $wrguid = hexify($4); my $wrknown = ($5 eq "");
|
|
my $wr = $wr{$wrguid};
|
|
my $cnt = ($nackset =~ y/1//);
|
|
my $op = ($cnt == 0) ? " ACK" : "NACK";
|
|
next unless defined $wr;
|
|
(my $ppguid = $prdguid) =~ s/:[0-9a-f]+$/:1c1/;
|
|
if (exists $proxypp{$ppguid} && exists $wr->{tdel} && $ts - $wr->{tdel} > 0.5) {
|
|
my $sysid = $proxypp{$prdguid}->{sysid};
|
|
if (!$wr->{zombiewarn}->{$sysid} && exists $proxypp{$ppguid}->{non_spdp_seen}) {
|
|
# shouldn't be getting ACKs this late
|
|
# but if no proper connection established yet, can be false positive
|
|
# (could take time of discovery of proxy participant into account as well)
|
|
$wr->{zombiewarn}->{$sysid} = 1;
|
|
if ($seqp1 <= 1) {
|
|
printf "%9.3f %35s $topfmt $op %s pre-emptive but writer deleted %.3fs ago, likely zombie\n",
|
|
$ts, fmtguid($wrguid), $wr->{stopic}, $prdguid, $ts - $wr->{tdel};
|
|
} else {
|
|
printf "%9.3f %35s $topfmt $op %s writer deleted %.3fs ago, seemingly no progress\n",
|
|
$ts, fmtguid($wrguid), $wr->{stopic}, $prdguid, $ts - $wr->{tdel};
|
|
}
|
|
}
|
|
}
|
|
next unless exists $prd{$prdguid};
|
|
next unless exists $wr->{matches}->{$prdguid};
|
|
if (defined $prd{$prdguid}->{tdel}) {
|
|
my $dt = $ts - $prd{$prdguid}->{tdel};
|
|
printf "%9.3f %35s $topfmt $op %s undiscovered %.3fs ago\n", $ts, fmtguid($wrguid), $wr->{stopic}, $prdguid, $dt;
|
|
next;
|
|
}
|
|
$proxypp{$ppguid}->{non_spdp_seen} = 1;
|
|
$wr->{matches}->{$prdguid}->{seqp1} = $seqp1;
|
|
if ($cnt == 0) {
|
|
# $seqp1 <= 1 => pre-emptive ACKNACK < which is not proof of a happy reader
|
|
if ($seqp1 > 1 && !$wr->{matches}->{$prdguid}->{happy}) {
|
|
$wr->{matches}->{$prdguid}->{happy} = 1;
|
|
$wr->{matches}->{$prdguid}->{thappy} = $ts;
|
|
$wr->{nhappy}++;
|
|
}
|
|
if (defined $wr->{matches}->{$prdguid}->{tnack}) {
|
|
my $dt = $ts - $wr->{matches}->{$prdguid}->{tnack};
|
|
printf "%9.3f %35s $topfmt $op %s caught up after %.3fs\n", $ts, fmtguid($wrguid), $wr->{stopic}, fmtguid($prdguid), $dt if $shows{ack} && show_topic($wr->{topic});
|
|
$wr->{matches}->{$prdguid}->{tnack} = undef;
|
|
}
|
|
} elsif ($wr->{matches}->{$prdguid}->{happy}) {
|
|
# initial rexmit requests are not that interesting, so we
|
|
# suppress tracking/printing them until the reader has sent a
|
|
# pure ACK (the same reasoning as the "happy" flag of DDSI2,
|
|
# which uses it to classify requests as historical data or
|
|
# recovery from packet loss)
|
|
$wr->{matches}->{$prdguid}->{tnack} = $ts unless defined $wr->{matches}->{$prdguid}->{tnack};
|
|
printf "%9.3f %35s $topfmt $op %s rexmit request for %d samples starting from %d\n",
|
|
$ts, fmtguid($wrguid), $wr->{stopic}, fmtguid($prdguid), $cnt, $seqp1 if $shows{ack} && show_topic($wr->{topic});
|
|
# retransmit count is inexact because it counts requests for retransmission, not actual
|
|
# retransmits -- the latter is possible, but currently doesn't allow distinguishing between a
|
|
# request for historical data and a request for a retransmit of a lost packet
|
|
$rexmit_count_req += $cnt;
|
|
}
|
|
if ($wr->{acklate} && acklate($ts, $wrguid) == 0) {
|
|
my $dt = $ts - $wr->{acklate};
|
|
printf "%9.3f %35s $topfmt ACK caught up after %.3fs since triggering write\n",
|
|
$ts, fmtguid($wrguid), $wr->{stopic}, $dt if $shows{ack} && show_topic($wr->{topic});
|
|
$wr->{acklate} = 0;
|
|
}
|
|
} elsif (/\(begin ($guidre) txn (\d+)\)/o) {
|
|
my $wrguid = hexify($1);
|
|
my $pwr = $pwr{$wrguid};
|
|
die unless defined $pwr;
|
|
die if ! $pwr->{suppressbegin};
|
|
$pwr->{suppressbegin} = 0;
|
|
#printf "%9.3f %35s $topfmt %16s RCV BEGIN txn %d\n", $ts, $1, $pwr->{stopic}, "", $2 if $shows{in};
|
|
} elsif (/\(commit ($guidre) txn (\d+) (\d+) seq_offset (\d+)/o) {
|
|
my $pwrguid = hexify($1); my $txn = $2; my $ktxn = $2;
|
|
my $pwr = $pwr{$pwrguid};
|
|
die unless defined $pwr;
|
|
die if $pwr->{suppressbegin};
|
|
my $n = (defined $pwr->{cseq} && defined $pwr->{seq}) ? $pwr->{seq} - $pwr->{cseq} + 1 : 0;
|
|
my $nr = keys %{$pwr->{matches}};
|
|
printf "%9.3f %35s $topfmt %16s RCV COMMIT txn %d %d [%d samples %d readers]\n", $ts, fmtguid($pwrguid), $pwr->{stopic}, "", $txn, $ktxn, $n, $nr
|
|
if $shows{in} && $pwr->{topic} =~ /$topic_filter/o && $pwr->{topic} !~ /$topic_xfilter/o;
|
|
$pwr->{cseq} = undef;
|
|
} elsif (/data\(application, vendor \d+\.\d+\): ($guidre) #(\d+)((?: C#\d+)?): ST(\d+) [^\{]+?(\{.*|:k:\{.*|:e:\(blob\))/o) {
|
|
my $pwrguid = hexify($1); my $seq = $2;
|
|
my $cseq = $3; my $st = $4; my $data = $5;
|
|
$data =~ s/( =>(?: EVERYONE| *(?:$guidre(?: $guidre)*)))$//;
|
|
(my $readers = $1) =~ s/^ => *//;
|
|
my $pwr = $pwr{$pwrguid};
|
|
my $dflag = ($data =~ /^:[ek]:/ ? 0 : 1);
|
|
next unless defined $pwr;
|
|
die if $pwr->{suppressbegin};
|
|
my $oldcseq = $pwr->{cseq};
|
|
my $readers_str;
|
|
if ($readers eq "EVERYONE") {
|
|
$readers_str = sprintf "%d readers", (scalar keys %{$pwr->{matches}});
|
|
} else {
|
|
$readers_str = $readers;
|
|
}
|
|
$pwr->{seq} = $seq;
|
|
if ($cseq =~ /C#(\d+)/) {
|
|
$pwr->{cseq} = $1;
|
|
} else {
|
|
$pwr->{cseq} = undef;
|
|
}
|
|
if (defined $pwr->{cseq}) {
|
|
if (! defined $oldcseq) {
|
|
printf "%9.3f %35s $topfmt %16s RCV BEGIN\n", $ts, fmtguid($pwrguid), $pwr->{stopic}, ""
|
|
if $shows{in} && $pwr->{topic} =~ /$topic_filter/o && $pwr->{topic} !~ /$topic_xfilter/o;
|
|
$pwr->{suppressbegin} = 1;
|
|
} elsif ($oldcseq != $pwr->{cseq}) {
|
|
printf "%9.3f %35s $topfmt %16s RCV IMPLICIT COMMIT + BEGIN\n", $ts, fmtguid($pwrguid), $pwr->{stopic}, ""
|
|
if $shows{in} && $pwr->{topic} =~ /$topic_filter/o && $pwr->{topic} !~ /$topic_xfilter/o;
|
|
}
|
|
} elsif (defined $oldcseq) {
|
|
printf "%9.3f %35s $topfmt %16s RCV IMPLICIT COMMIT\n", $ts, fmtguid($pwrguid), $pwr->{stopic}, ""
|
|
if $shows{in} && $pwr->{topic} =~ /$topic_filter/o && $pwr->{topic} !~ /$topic_xfilter/o;
|
|
}
|
|
my $op = ($data =~ /^:e:/) ? "W " : $opstr{$st.$dflag};
|
|
my $print = 0;
|
|
my $printlim = $shows{limit};
|
|
$recv_appdata++;
|
|
$print = show_topic($pwr->{topic}) && $shows{in};
|
|
$print = 0 unless $data =~ /$data_filter/o;
|
|
my $sdata = $printlim ? (sprintf "%-100.100s", $data) : (sprintf "%-100s", $data);
|
|
my $tstamp = "";
|
|
if ($shows{tstamp} && (exists $tstamps{$pwrguid} || defined $last_infots)) {
|
|
my $t;
|
|
if (exists $tstamps{$pwrguid}) {
|
|
shift @{$tstamps{$pwrguid}} while @{$tstamps{$pwrguid}} && $tstamps{$pwrguid}->[0]->[0] < $seq;
|
|
$t = shift @{$tstamps{$pwrguid}} if @{$tstamps{$pwrguid}} && $tstamps{$pwrguid}->[0]->[0] == $seq;
|
|
}
|
|
if (defined $t) {
|
|
$tstamp = sprintf " (@%.3f) ", $t->[1];
|
|
} elsif (defined $last_infots) {
|
|
$tstamp = sprintf " (@%.3f?) ", $last_infots;
|
|
}
|
|
}
|
|
printf "%9.3f %35s $topfmt %s #%-4d %-6s RCV %s%s [%s]\n", $ts, fmtguid($pwrguid), $pwr->{stopic}, $op, $seq, $cseq, $tstamp, $sdata, $readers_str if $print;
|
|
} elsif (/DATA\(($guidre)\s*->\s*$guidre\s+#(\d+)/o) {
|
|
my $pwrguid = hexify($1); my $seq = $2;
|
|
(my $ppguid = $pwrguid) =~ s/:[0-9a-f]+$/:1c1/;
|
|
# 100c2 is entity id of SPDP writer
|
|
$proxypp{$ppguid}->{non_spdp_seen} = 1
|
|
if exists $proxypp{$ppguid} && !defined $proxypp{$ppguid}->{tdel} && $pwrguid !~ /:100c2$/;
|
|
if (defined $last_infots && $shows{tstamp}) {
|
|
my $t = [ $seq, $last_infots ];
|
|
if (not defined $tstamps{$pwrguid}) {
|
|
$tstamps{$pwrguid} = [ $t ];
|
|
} else {
|
|
my $i;
|
|
for ($i = @{$tstamps{$pwrguid}}; $i > 0; $i--) {
|
|
last if $seq > $tstamps{$pwrguid}->[$i-1]->[0];
|
|
}
|
|
if ($i == @{$tstamps{$pwrguid}}) {
|
|
push @{$tstamps{$pwrguid}}, $t;
|
|
} elsif ($seq != $tstamps{$pwrguid}->[$i]->[0]) {
|
|
splice @{$tstamps{$pwrguid}}, $i, 0, $t;
|
|
}
|
|
}
|
|
}
|
|
} elsif (/HEARTBEAT\(F?L?#\d+:(\d+)\.\.(\d+) ($guidre)/o) {
|
|
my $prdguid = hexify($3);
|
|
(my $ppguid = $prdguid) =~ s/:[0-9a-f]+$/:1c1/;
|
|
$proxypp{$ppguid}->{non_spdp_seen} = 1 if exists $proxypp{$ppguid} && !defined $proxypp{$ppguid}->{tdel};
|
|
} elsif (/: SEDP_TOPIC ST\d+ ([^\/]+)\/([^ ]+) QOS=(.*)/) {
|
|
my $topic = $1; my $type = $2; my $qos = $3;
|
|
my $sysid = "0";
|
|
$topic_qos{$topic} = $qos;
|
|
printf "%9.3f %35s $topfmt %16s RCV %s (%s)\n", $ts, $sysid, "TOPIC", "", $topic, $type if $shows{topic} && $shows{in};
|
|
} elsif (/: sedp: write topic ([^ ]+)/) {
|
|
my $topic = $1;
|
|
printf "%9.3f %35s $topfmt %16s XMT %s\n", $ts, "0", "TOPIC", "", $topic if $shows{topic} && $shows{out};
|
|
} elsif (/writer ($guidre)(?: topic ([^ ]+))? waiting for whc/o) {
|
|
my $wrguid = hexify($1);
|
|
$tlast_txblock{$tid} = 0 unless exists $tlast_txblock{$tid};
|
|
$txblock{$tid} = $ts;
|
|
$txblockwr{$tid} = $wrguid;
|
|
$txblocktp{$tid} = defined $2 ? $2 : exists $wr{$wrguid} && exists $wr{$wrguid}->{topic} ? $wr{$wrguid}->{topic} : 'unknown';
|
|
printf "%9.3f %35s $topfmt BLCK\n", $ts, fmtguid($wrguid), $txblocktp{$tid} if $shows{throttle};
|
|
} elsif (/writer ($guidre) done waiting/o) {
|
|
my $wrguid = hexify($1);
|
|
my $dt = $ts - $txblock{$tid};
|
|
my $mustprint = ($tlast_txblock{$tid} == $txblock{$tid});
|
|
delete $txblock{$tid};
|
|
delete $txblockwr{$tid};
|
|
delete $txblocktp{$tid};
|
|
if ($shows{throttle} || $mustprint) {
|
|
if (!exists $wr{$wrguid}) {
|
|
printf "%9.3f %35s $topfmt UNBK after %.3fs\n", $ts, fmtguid($wrguid), "", $dt;
|
|
} else {
|
|
my $wr = $wr{$wrguid};
|
|
printf "%9.3f %35s $topfmt UNBK after %.3fs\n", $ts, fmtguid($wrguid), $wr->{stopic}, $dt;
|
|
}
|
|
}
|
|
} elsif (/message dropped because sender ($gidre) is unknown/o) {
|
|
my $gid = hexify($1);
|
|
$gid =~ /^([0-9a-f]+):([0-9a-f]+):([0-9a-f]+)/;
|
|
my $decgid = sprintf "{%d,%d,%d}", hex $1, hex $2, hex $3;
|
|
printf "%9.3f %55s DROP unknown writer %s (a.k.a. %s) \n", $ts, "", $gid, $decgid;
|
|
} elsif (/writer ($guidre) topic .* considering reader ($guidre) non-responsive/o) {
|
|
my $wrguid = hexify($1); my $prdguid = hexify($2);
|
|
if (! exists $wr{$wrguid}) {
|
|
printf "%9.3f %35s $topfmt UNRP unknown writer declaring reader %s non-responsive\n", $ts, fmtguid($wrguid), "", fmtguid($prdguid);
|
|
} else {
|
|
my $wr = $wr{$wrguid};
|
|
printf "%9.3f %35s $topfmt UNRP writer declaring reader %s non-responsive\n", $ts, fmtguid($wrguid), $wr->{stopic}, fmtguid($prdguid);
|
|
my @lates = acklate(1e100, $wrguid);
|
|
my @details = ();
|
|
for (@lates) {
|
|
my $cause = ($_->{haveack} ? sprintf "%d behind", $_->{nsamp} : "no ack yet");
|
|
push @details, sprintf "%35s $topfmt UNRP %s (%s)", fmtguid($wrguid), $wr->{stopic}, fmtguid($_->{guid}), $cause;
|
|
}
|
|
my $details = join '\n', @details;
|
|
if ($details ne $last_nonresponsive_details) {
|
|
printf "%9.3f %s\n", $ts, $_ for @details;
|
|
$last_nonresponsive_details = $details;
|
|
}
|
|
}
|
|
} elsif (/: update_mtreader: (.*)/) {
|
|
printf "%9.3f %55s UMTR %s\n", $ts, "", $1 if $shows{mtreader};
|
|
} elsif (!defined($self_fullversion) && /: spdp_write\($guidre\) - internals: [^\/]*\/([^\/]+)\//o) {
|
|
$self_fullversion = $1;
|
|
@self_version = ($self_fullversion =~ /^(\d+)\.(\d+)\.(\d+)(?:p(\d+))?/);
|
|
} elsif (/-----BEGIN CERTIFICATE-----|-----BEGIN RSA PRIVATE KEY-----/) {
|
|
# The following few lines in the log will not have the 'normal' ddsi log syntax: skip them.
|
|
$skiplines = 1;
|
|
} elsif (/traffic-xmit\s*\((\d+)\)\s*(\d+)/) {
|
|
$xmit_packet += $1;
|
|
$xmit_bytes += $1 * $2;
|
|
} elsif (/xpack_addmsg.*rexmit/) {
|
|
$rexmit_frags++;
|
|
}
|
|
}
|
|
# blocking on whc is generally very bad if it is not resolved by the time the log ends
|
|
for my $t (keys %txblock) {
|
|
if (defined $txblock{$t} && $shows{block}) {
|
|
my $dt = $ts - $txblock{$t};
|
|
my $wrguid = $txblockwr{$t};
|
|
printf "%9.3f %35s $topfmt BLCK still blocked at end of log after %.3fs\n", $ts, fmtguid($wrguid), $txblocktp{$t}, $dt;
|
|
if (exists $wr{$txblockwr{$t}}) {
|
|
my @lates = acklate(1e100, $txblockwr{$t});
|
|
for (@lates) {
|
|
my $cause = ($_->{haveack} ? sprintf "%d behind", $_->{nsamp} : "no ack yet");
|
|
printf "%9.3f %35s $topfmt BLCK %s (%s)\n", $ts, fmtguid($txblockwr{$t}), $txblocktp{$t}, fmtguid($_->{guid}), $cause;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
sub version_at_least {
|
|
my ($major, $minor, $maint, $patch) = @_;
|
|
return 0 unless defined $self_version[0];
|
|
return 1 if $major > $self_version[0];
|
|
return 0 if $major < $self_version[0];
|
|
return 1 if $minor > $self_version[1];
|
|
return 0 if $minor < $self_version[1];
|
|
return 1 if $maint > $self_version[2];
|
|
return 0 if $maint < $self_version[2];
|
|
return 1 if defined $patch && !defined($self_version[3]);
|
|
return 0 if !defined($patch) && defined($self_version[3]);
|
|
return $patch >= $self_version[3];
|
|
}
|
|
|
|
sub make_stopic {
|
|
my ($partitions, $topic) = @_;
|
|
my $stopic;
|
|
if ($shows{partition}) {
|
|
$stopic = "$partitions/$topic";
|
|
if (length $stopic < $topcolwidth) {
|
|
# nop
|
|
} elsif (length $partitions < 15) {
|
|
my $max = ($topcolwidth - 4) - length $partitions;
|
|
$stopic =~ s/\/.*?(.{1,$max})$/\/...$1/;
|
|
} elsif (length $topic < 15) {
|
|
my $max = ($topcolwidth - 4) - length $topic;
|
|
$stopic =~ s/.*?(.{1,$max})\//...$1\//;
|
|
} else {
|
|
$stopic =~ s/.*?(.{1,11})\/.*?(.{1,11})$/...$1\/...$2/;
|
|
}
|
|
} else {
|
|
if (length $topic < $topcolwidth) {
|
|
$stopic = $topic;
|
|
} else {
|
|
$topic =~ /(.{1,27})$/;
|
|
$stopic = "...$1";
|
|
}
|
|
}
|
|
return $stopic;
|
|
}
|
|
|
|
sub hexify {
|
|
my $in = $_[0];
|
|
if (!defined $hexmode) {
|
|
# guess, and hope we're right (chances are that a GUID contains a hex digit in hex mode)
|
|
$hexmode = ($in =~ /[a-f]/);
|
|
}
|
|
return $in if $hexmode;
|
|
my @z = split ':', $in;
|
|
return (join ':', map { sprintf "%x", $_ } @z);
|
|
}
|
|
|
|
sub vendorstr {
|
|
my %vendor = ('1.0' => 'unknown',
|
|
'1.1' => 'Connext',
|
|
'1.2' => 'OSPL',
|
|
'1.3' => 'OCI',
|
|
'1.4' => 'Milsoft',
|
|
'1.5' => 'Kongsberg',
|
|
'1.6' => 'CoreDX',
|
|
'1.7' => 'Lakota',
|
|
'1.8' => 'ICOUP',
|
|
'1.9' => 'ETRI',
|
|
'1.10' => 'ConnextMicro',
|
|
'1.11' => 'PTCafe',
|
|
'1.12' => 'PTGateway',
|
|
'1.13' => 'Lite',
|
|
'1.14' => 'Technicolor',
|
|
'1.15' => 'FastRTPS',
|
|
'1.16' => 'Cyclone',
|
|
'1.32' => 'PTLink');
|
|
return 'undef' unless defined $_[0];
|
|
return $vendor{$_[0]} if exists $vendor{$_[0]};
|
|
return 'unknown';
|
|
}
|
|
|
|
sub fmtguid {
|
|
my ($guid) = @_;
|
|
(my $ppguid = $guid) =~ s/:[^:]+$/:1c1/;
|
|
(my $entityid = $guid) =~ s/.*://;
|
|
if (exists $proxypp{$ppguid}) {
|
|
return "$proxypp{$ppguid}->{sname}:$entityid";
|
|
} elsif ($ppguid ne "0:0:0:1c1" && exists $pp{$ppguid}) {
|
|
return "$pp{$ppguid}->{sname}:$entityid";
|
|
} else {
|
|
return $guid;
|
|
}
|
|
}
|
|
|
|
sub acklate { # returns ({ "guid" => guid, "nsamp" => nr of samples not acked})
|
|
my ($ts, $wrguid, $seq) = @_;
|
|
if ($wr{$wrguid}->{seq} == 0) {
|
|
return ();
|
|
} else {
|
|
#my $x;
|
|
#for (values %{$wr{$wrguid}->{matches}}) {
|
|
# next if $_->{seqp1} == 0; # nothing from reader yet, so not really lagging yet
|
|
# $x = $_->{seqp1} if !(defined $x) || $_->{seqp1} < $x;
|
|
#}
|
|
#return 0 unless defined $x;
|
|
#$seq = $wr{$wrguid}->{seq} unless defined $seq;
|
|
#return ($x > $seq) ? 0 : ($seq - $x + 1);
|
|
my @r;
|
|
$seq = $wr{$wrguid}->{seq} unless defined $seq;
|
|
while (my ($k,$v) = each %{$wr{$wrguid}->{matches}}) {
|
|
# nothing from reader yet, and less than 2s passed since
|
|
# matching, so not really lagging yet
|
|
next if $v->{seqp1} == 0 && $ts < $v->{tmatch} + 2;
|
|
push @r, { "guid" => $k, "nsamp" => $seq - $v->{seqp1} + 1, "haveack" => ($v->{seqp1} > 0) } if $v->{seqp1} <= $seq;
|
|
}
|
|
return @r;
|
|
}
|
|
}
|
|
|
|
sub init_proxypp_disccomplete {
|
|
my ($bes) = @_;
|
|
# keys are TOPIC, WRITER, READER
|
|
# A = ACK received, i.e., remote reader exists
|
|
# H = HB received, i.e., remote writer exists
|
|
# B = pure ack sent, i.e., remote writer exists
|
|
# first element in arrays is bit in $bes indicating existence of the "announcer", i.e., the writer
|
|
# second is the bit indicating existence of the "detector", i.e., the reader
|
|
my %tab = ("WRITER" => [ 2, 3 ], "READER" => [ 4, 5 ], "TOPIC" => [ 12, 13 ]);
|
|
my $res = {};
|
|
while (my ($k, $v) = each %tab) {
|
|
# need both an announcer & a detector for a meaningful discovery
|
|
my $reqflags = ((1 << $v->[0]) | (1 << $v->[1]));
|
|
$res->{"H$k"} = $res->{"B$k"} = $res->{"A$k"} = 1
|
|
unless ($bes & $reqflags) == $reqflags;
|
|
}
|
|
return $res;
|
|
}
|
|
|
|
sub disccomplete_diagstr {
|
|
my ($proxypp) = @_;
|
|
my (@noack, @nohb, @norecv);
|
|
for my $type (qw(WRITER READER TOPIC)) {
|
|
push @noack, $type unless exists $proxypp->{disccomplete}->{"A$type"};
|
|
push @nohb, $type unless exists $proxypp->{disccomplete}->{"H$type"};
|
|
push @norecv, $type unless exists $proxypp->{disccomplete}->{"B$type"};
|
|
}
|
|
my $res = "";
|
|
$res .= "; noack: " . join(',', map { lc } @noack) if @noack;
|
|
$res .= "; nohb: " . join(',', map { lc } @nohb) if @nohb;
|
|
$res .= "; norecv: " . join(',', map { lc } @norecv) if @norecv;
|
|
$res =~ s/^; //;
|
|
return $res;
|
|
}
|
|
|
|
sub check_disccomplete {
|
|
my ($which, $guid) = @_;
|
|
(my $kind = $guid) =~ s/^[0-9a-f:]+:([234])c[27]$/$1/;
|
|
(my $ppguid = $guid) =~ s/:[^:]+$/:1c1/;
|
|
return if not exists $proxypp{$ppguid};
|
|
my $sysid = $proxypp{$ppguid}->{sysid};
|
|
if (exists $proxypp{$ppguid} && exists $proxypp{$ppguid}->{tcreate}) {
|
|
$proxypp{$ppguid}->{disccomplete}->{"$which$discentitystr{$kind}"} = 1;
|
|
if (! $proxypp{$ppguid}->{disccompleteflag} && keys %{$proxypp{$ppguid}->{disccomplete}} == 3 * keys %discentitystr) {
|
|
$proxypp{$ppguid}->{disccompleteflag} = 1;
|
|
my $dt = $ts - $proxypp{$ppguid}->{tcreate};
|
|
(my $ppguidpre = $ppguid) =~ s/:1c1$//;
|
|
my $sx = decimal_sysid($sysid);
|
|
printf "%9.3f %35s $topfmt DISC node %s (%s; %s) discovery complete after %.3fs\n", $ts, $ppguidpre, "", $sysid{$sysid}->{ip}, $sx, $sysid{$sysid}->{name}, $dt;
|
|
}
|
|
}
|
|
}
|
|
|
|
sub delete_pwr {
|
|
my ($ts, $pwrguid, $isimplicit) = @_;
|
|
(my $ppguid = $pwrguid) =~ s/:[0-9a-f]+$/:1c1/;
|
|
#proxy endpoint doesn't necessarily exist, so shouldn't die
|
|
#die unless exists $pwr{$pwrguid} || $pwrguid =~ /[4c]2$/;
|
|
return unless exists $pwr{$pwrguid};
|
|
my $pwr = $pwr{$pwrguid};
|
|
my $proxypp = $proxypp{$ppguid};
|
|
die unless defined $proxypp;
|
|
for (keys %{$pwr->{matches}}) {
|
|
die unless $rd{$_}->{matches}->{$pwrguid};
|
|
delete $rd{$_}->{matches}->{$pwrguid};
|
|
}
|
|
# removal from GUID hash and actual deletion are separate events, so
|
|
# this is imprecise; built-ins get rougher treatmeant as they are
|
|
# not explicitly discovered
|
|
if ($pwrguid !~ /[4c][23]$/) {
|
|
$pwr->{matches} = {};
|
|
$pwr{$pwrguid}->{tdel} = $ts;
|
|
$pwr{$pwrguid}->{explicitdel} = 1 unless $isimplicit;
|
|
$pwr{$pwrguid}->{cseq} = undef;
|
|
delete $tstamps{$pwrguid};
|
|
if ($shows{remotedisc} && $pwr{$pwrguid}->{topic} =~ /$topic_filter/o && $pwr{$pwrguid}->{topic} !~ /$topic_xfilter/o) {
|
|
printf "%9.3f %35s $topfmt UNDISCOVER %s\n", $ts, $pwrguid, $pwr{$pwrguid}->{stopic}, $isimplicit ? " (implicit)" : "";
|
|
}
|
|
} else {
|
|
delete $proxypp->{pwr}->{$pwrguid};
|
|
delete $pwr{$pwrguid};
|
|
}
|
|
}
|
|
|
|
sub delete_prd {
|
|
my ($ts, $prdguid, $isimplicit) = @_;
|
|
(my $ppguid = $prdguid) =~ s/:[0-9a-f]+$/:1c1/;
|
|
#proxy endpoint doesn't necessarily exist, so shouldn't die
|
|
#die unless exists $prd{$prdguid} || $prdguid =~ /[4c]7$/;
|
|
return unless exists $prd{$prdguid};
|
|
my $prd = $prd{$prdguid};
|
|
my $proxypp = $proxypp{$ppguid};
|
|
die unless defined $proxypp;
|
|
for (keys %{$prd->{matches}}) {
|
|
next if defined $prd->{matches}->{$_}->{seqp1del};
|
|
unless( $wr{$_}->{matches}->{$prdguid} ){
|
|
die;
|
|
}
|
|
my $x = $wr{$_}->{matches}->{$prdguid};
|
|
$wr{$_}->{nhappy}-- if $x->{happy};
|
|
my $dtmatch = $ts - $x->{tmatch};
|
|
if ($x->{seqp1} == 0) {
|
|
# also happens when a writer with an empty WHC has written
|
|
# nothing since the match, hence disabling it for now
|
|
printf "%9.3f %35s $topfmt DEL %s no ACKs received, reader matched for %.3fs\n", $ts, $_, $wr{$_}->{stopic}, $prdguid, $dtmatch
|
|
if $shows{ack} && 0;
|
|
} elsif ($wr{$_}->{seq} >= $x->{seqp1}) {
|
|
printf "%9.3f %35s $topfmt DEL %s %d samples behind, reader matched for %.3fs\n", $ts, $_, $wr{$_}->{stopic}, $prdguid, $wr{$_}->{seq} - $x->{seqp1} + 1, $dtmatch
|
|
if $shows{ack} && show_topic($wr{$_}->{topic});
|
|
}
|
|
$prd->{matches}->{$_}->{seqp1del} = $x->{seqp1};
|
|
delete $wr{$_}->{matches}->{$prdguid};
|
|
if ($wr{$_}->{acklate} && acklate($ts, $_) == 0) {
|
|
printf "%9.3f %35s $topfmt ACK caught up because of unmatch\n", $ts, fmtguid($_), $wr{$_}->{stopic} if $shows{ack} && show_topic($wr{$_}->{topic});
|
|
$wr{$_}->{acklate} = 0;
|
|
}
|
|
}
|
|
if ($prdguid !~ /[4c][47]$/) {
|
|
#$prd->{matches} = {};
|
|
$prd{$prdguid}->{tdel} = $ts;
|
|
$prd{$prdguid}->{explicitdel} = 1 unless $isimplicit;
|
|
if ($shows{remotedisc} && $prd{$prdguid}->{topic} =~ /$topic_filter/o && $prd{$prdguid}->{topic} !~ /$topic_xfilter/o) {
|
|
printf "%9.3f %35s $topfmt UNDISCOVER %s\n", $ts, $prdguid, $prd{$prdguid}->{stopic}, $isimplicit ? " (implicit)" : "";
|
|
}
|
|
} else {
|
|
delete $proxypp->{prd}->{$prdguid};
|
|
delete $prd{$prdguid};
|
|
}
|
|
}
|
|
|
|
sub delete_proxypp {
|
|
my ($ts, $ppguid) = @_;
|
|
my $proxypp = $proxypp{$ppguid};
|
|
die unless defined $proxypp;
|
|
my $sysid = $proxypp{$ppguid}->{sysid};
|
|
#my @pwrguids = keys %{$proxypp->{pwr}};
|
|
#die unless @pwrguids == 0;
|
|
#my @prdguids = keys %{$proxypp->{prd}};
|
|
#die unless @prdguids == 0;
|
|
$proxypp{$ppguid}->{tdel} = $ts;
|
|
#delete $proxypp{$ppguid};
|
|
die unless $sysid{$sysid}->{npp} > 0;
|
|
if (--$sysid{$sysid}->{npp} == 0) {
|
|
my $dt = (defined $sysid{$sysid}->{tcrash}) ? $ts - $sysid{$sysid}->{tcrash} : undef;
|
|
my $dtmsg = (defined $dt) ? sprintf " (cleanup took %.3fs)", $dt : "";
|
|
my $sx = decimal_sysid($sysid);
|
|
printf "%9.3f %35s $topfmt DISC node %s (%s; %s) no proxy participants left%s\n",
|
|
$ts, $sysid, "", $sysid{$sysid}->{ip}, $sx, $sysid{$sysid}->{name}, $dtmsg;
|
|
$sysid{$sysid}->{tdel} = $ts;
|
|
$sysid{$sysid}->{tcrash} = undef;
|
|
}
|
|
}
|
|
|
|
sub getdest {
|
|
my ($wrguid) = @_;
|
|
my $wr = $wr{$wrguid};
|
|
die unless defined $wr;
|
|
my @xs = sort { $a cmp $b } (keys %{$wr->{matches}});
|
|
my $d = "";
|
|
my $l = "";
|
|
my $n = 0;
|
|
for (@xs, "0") {
|
|
my $pp = $proxypp{"$1:1c1"} if /^(.*):[0-9a-f]+$/;
|
|
die unless defined $pp || $_ eq "0";
|
|
/^([0-9a-f]+)/;
|
|
if ($l eq $1) {
|
|
$n++;
|
|
} else {
|
|
$d .= "*$n" if $n > 1;
|
|
$n = 0;
|
|
$l = $1;
|
|
$d .= " $pp->{ip}" if defined $pp;
|
|
}
|
|
}
|
|
$d =~ s/^ +//;
|
|
return ($d eq "") ? "(no prd)" : $d;
|
|
}
|
|
|
|
sub show_topic {
|
|
my ($topic) = @_;
|
|
return $shows{topic} if $topic =~ /^DCPSTopic/;
|
|
return $shows{builtin} if $topic =~ /^(CM|DCPS|q_)/;
|
|
return $shows{user} && $topic =~ /$topic_filter/o && $topic !~ /$topic_xfilter/o;
|
|
}
|
|
|
|
sub check_qos {
|
|
my ($ts, $kind, $guid, $topic, $partitions, $qos, $pubsub_opt) = @_;
|
|
if ($kind eq 'WRITER' && $qos =~ /,presentation=2:1:/ && $qos =~ /,history=0:/) {
|
|
printf "%9.3f $kind %s %s {%s} is keep-last and group coherent\n", $ts, $guid, $topic, $partitions if $shows{warn};
|
|
}
|
|
#if ($kind eq 'WRITER' && $qos =~ /,durability=3/) {
|
|
# if (exists $topic_qos{$topic} && $topic_qos{$topic} =~ /,durability=[0-2]/) {
|
|
# printf "%9.3f $kind %s %s {%s} is persistent but topic is not\n", $ts, $guid, $topic, $partitions if $shows{warn};
|
|
# } else {
|
|
# printf "%9.3f $kind %s %s {%s} is persistent but topic QoS is not yet known\n", $ts, $guid, $topic, $partitions if $shows{warn};
|
|
# }
|
|
#}
|
|
if ($qos =~ /,presentation=2:1:/ && defined $pubsub_opt) {
|
|
my ($durqos) = ($qos =~ /,durability=(\d),/);
|
|
$pubsub_opt->{durqos} = $durqos unless defined $pubsub_opt->{durqos};
|
|
if ($durqos != $pubsub_opt->{durqos}) {
|
|
my @durstr = qw(volatile transient-local transient persistent);
|
|
printf "%9.3f $kind %s %s {%s} is group coherent with durability %s where group is %s\n", $ts, $guid, $topic, $partitions, $durstr[$durqos], $durstr[$pubsub_opt->{durqos}] if $shows{warn};
|
|
}
|
|
}
|
|
#if ($qos =~ /,presentation=2:1:/ && $qos =~ /,history=0:/) {
|
|
# printf "%9.3f $kind %s %s {%s} is keep-last and group coherent\n", $ts, $guid, $topic, $partitions;
|
|
#}
|
|
#if ($kind eq 'WRITER' && $qos =~ /,durability=[23]/ && $qos =~ /,writer_data_lifecycle=\{1/) {
|
|
# printf "%9.3f $kind %s %s {%s} is transient/persistent and auto-dispose\n", $ts, $guid, $topic, $partitions;
|
|
#}
|
|
}
|
|
|
|
sub xformP { # . allowed in a partition name
|
|
my $x = $_[0];
|
|
$x =~ s/\./\\./g;
|
|
$x =~ s/\*/.*/g;
|
|
$x =~ s/\?/./g;
|
|
return $x;
|
|
}
|
|
|
|
sub xformT { # no . in a topic name
|
|
my $x = $_[0];
|
|
$x =~ s/\./\\./g;
|
|
$x =~ s/\*/[^.]*/g;
|
|
$x =~ s/\?/[^.]/g;
|
|
return $x;
|
|
}
|
|
|
|
sub sysid_from_guid {
|
|
$_[0] =~ /^([0-9a-f]+:[0-9a-f]+)/;
|
|
return $1;
|
|
}
|
|
|
|
sub decimal_sysid {
|
|
my @f = split /:/, $_[0];
|
|
return (join ':', map { hex } @f);
|
|
}
|
|
|
|
sub restart {
|
|
print "================ RESTART ================\n";
|
|
undef %psgid;
|
|
undef %psguid;
|
|
undef %rwgid;
|
|
undef %rwguid;
|
|
undef $self_fullversion;
|
|
undef @self_version;
|
|
undef %pp;
|
|
undef %rd;
|
|
undef %wr;
|
|
undef %rdgid;
|
|
undef %wrgid;
|
|
undef %sysid;
|
|
undef %proxypp;
|
|
undef %pwr;
|
|
undef %prd;
|
|
undef %pub;
|
|
undef %sub;
|
|
undef %ftrflag;
|
|
undef @ackcheck;
|
|
undef %prevts;
|
|
undef %tlastpkt;
|
|
$self_seen = 0;
|
|
undef $ownip;
|
|
%txblock = ();
|
|
%txblockwr = ();
|
|
%txblocktp = ();
|
|
%tlast_txblock = ();
|
|
$tlast_non_spdp_check = 0;
|
|
undef $curpktvendor;
|
|
undef $last_infots;
|
|
undef %spdp_info;
|
|
undef $sysid_hex;
|
|
undef %topic_qos;
|
|
$recv_packet = 0;
|
|
$recv_bytes = 0;
|
|
$recv_appdata = 0;
|
|
$xmit_packet = 0;
|
|
$xmit_bytes = 0;
|
|
$xmit_appdata = 0;
|
|
$rexmit_count_req = 0;
|
|
$rexmit_frags = 0;
|
|
$skiplines = 0;
|
|
undef @stat_deltas;
|
|
undef $next_stat_print;
|
|
$last_nonresponsive_details = "";
|
|
}
|
|
|
|
sub usage {
|
|
print << "EOT"
|
|
Usage: $0 [OPTIONS] INPUT
|
|
|
|
--show KEYWORD enable/disable showing of certain categories of
|
|
events (see below)
|
|
--topic-filter REGEX limit output to topics matching REGEX
|
|
--topic-xfilter REGEX do not show anything related to topics matching REGEX
|
|
(even when it matches the topic-filter)
|
|
--data-filter REGEX limit data output to those cases where the shown
|
|
content matches REGEX
|
|
--t0 TIMESTAMP set timestamp reference to TIMESTAMP, timestamps
|
|
printed are relative to this; defaults to the first
|
|
timestamp in the input
|
|
--hn PERLFILE IP-address to name translator, included using perl's
|
|
"do" statement, it should return a code reference
|
|
that takes the IP-address and the name as strings and
|
|
returns the name to use (which can be just the IP
|
|
address, the default)
|
|
--stat INTV show transmit/receive statistics every INTV seconds
|
|
|
|
The --show option gives some control over the kinds of events that are
|
|
shown in the output. Below is a list of keywords with the defaults.
|
|
Enabling is the default, disabling is done by prefixing the keyword with
|
|
"no" (i.e., --show noin means no input is shown).
|
|
|
|
KEYWORD DEF DESCRIPTION
|
|
EOT
|
|
;
|
|
my %blurbs = ("topic" => "show data related to topic discovery",
|
|
"localdisc" => "show discovery events for local readers and writers",
|
|
"remotedisc" => "show discovery events for remote readers and writers",
|
|
"user" => "show user traffic",
|
|
"ack" => "show some ACK-related events (retransmit requests, long delays until an ACK is received, catching up after there has been an issue)",
|
|
"throttle" => "show all blocking (and unblocking) events in transmit path",
|
|
"block" => "show blocking (and unblocking) events in transmit path if it is blocked for some time",
|
|
"rematch" => "show matching events for local writers and remote readers",
|
|
"in" => "show incoming traffic",
|
|
"out" => "show outgoing traffic",
|
|
"partition" => "include partition names in output",
|
|
"builtin" => "show writes for OpenSplice built-in topics",
|
|
"mtreader" => "show events on multi-topic reader for local discovery",
|
|
"limit" => "limit data dumps to first 100 characters",
|
|
"warn" => "warnings of various kinds",
|
|
"tstamp" => "show source-timestamp as well as we can",
|
|
"topic-filter" => "show topic filter in use",
|
|
"compact" => "use a more compact representation in some places (currently only d_sampleChain)",
|
|
"qos" => "show QoS in some places (currently only d_sampleChain)");
|
|
for (sort (keys %shows)) {
|
|
printf "* %-14s %-5s %s\n", $_, $shows{$_} ? "yes" : "no", fmtblurb ($blurbs{$_});
|
|
}
|
|
print << 'EOT'
|
|
Keywords in the output (in the 4th column, after the topic name, though
|
|
not necessarily the 4th field in, say, AWK):
|
|
|
|
SELF informational message giving the node's own ids, IP
|
|
address, etc., like DISC
|
|
DISC discovery events: the first appearance of a node, the
|
|
completion of cleaning up after its disappearance, long
|
|
time needed to get SEDP to complete
|
|
DIED lease expiry of a node
|
|
TJMP possible time jump (detected by largish jumps forward in
|
|
the time stamp of two successive lines, or a single thread
|
|
going backwards in time)
|
|
STAT some traffic statistics calculated by the script (if
|
|
--stat)
|
|
ACK warning that the specified readers haven't acknowledged
|
|
a sample within a "reasonable" amount of time, here taken
|
|
to be 0.5s; also when it recovers (only if --show ack)
|
|
DEL when a remote reader disappears without having
|
|
acknowledged all data that was sent to it (if --show ack)
|
|
CONN connectivity warning: if nothing but SPDP packets are
|
|
received for 5s, that's strongly suggestive of a problem
|
|
BLCK / UNBK transmit path blocked (shown only for blocking events
|
|
taking longer than 1s if --show block, all if --show throttle)
|
|
or no longer blocked
|
|
BEGIN / COMMIT start/end of a coherent set
|
|
EOT
|
|
;
|
|
exit 1;
|
|
return;
|
|
}
|
|
|
|
sub fmtblurb {
|
|
my ($blurb) = @_;
|
|
my @words = split ' ', $blurb;
|
|
my @lines = ();
|
|
while (@words > 0) {
|
|
my $x = shift @words;
|
|
while (@words > 0 && (length $x) + 1 + (length $words[0]) < 50) {
|
|
$x .= " " . shift @words;
|
|
}
|
|
push @lines, "$x";
|
|
}
|
|
my $sep = "\n" . (" "x23);
|
|
return join $sep, @lines;
|
|
}
|