2019-09-11 08:38:26 +02:00
#!/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}";
2020-01-13 13:43:11 +01:00
my $leasere = "(?:L\\((?:[a-z]+ )?[0-9a-f:]+\\s+[0-9.]+\\)\\s*)+";
2019-09-11 08:38:26 +02:00
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;
2020-02-28 16:51:13 +01:00
my $proto_ip = "(?:(?:udp[46]?|tcp[46]?)\/)?(?:[0-9.]+|\[[0-9a-fA-F:]+\])";
2019-09-11 08:38:26 +02:00
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 ...
2020-01-13 13:43:11 +01:00
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)?/) {
2019-09-11 08:38:26 +02:00
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);
}
2020-01-13 13:43:11 +01:00
} elsif (/: HEARTBEAT\(F?L?#\d+:(\d+)\.\.(\d+)\s+(?:$leasere)?([0-9a-f]+(?::[0-9a-f]+){2}:[234]c2)/) {
2019-09-11 08:38:26 +02:00
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+)\)/) {
2020-02-28 16:51:13 +01:00
# Special handling of INFOTS for guessing at source time stamps (in particular also
# for guessing at start times of other nodes
2019-09-11 08:38:26 +02:00
$last_infots = ($1 - $t0sec) + ($2/1e3 - $t0usec) / 1e6;
2020-02-28 16:51:13 +01:00
} 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
2019-09-11 08:38:26 +02:00
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
2020-02-28 16:51:13 +01:00
if ($proxypp{$ppguid}->{disccompleteflag} && $ts > $proxypp{$ppguid}->{tasymdisc} + 5) {
2019-09-11 08:38:26 +02:00
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});
2020-02-28 16:51:13 +01:00
$proxypp{$ppguid}->{tasymdisc} = $ts;
2019-09-11 08:38:26 +02:00
}
}
2020-02-28 16:51:13 +01:00
} 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;
}
2019-09-11 08:38:26 +02:00
}
2020-02-28 16:51:13 +01:00
if (/: ownip: ($proto_ip)/o) {
2019-09-11 08:38:26 +02:00
$ownip = $1;
2020-02-28 16:51:13 +01:00
$ownip =~ s/^(udp|tcp)[46]?\///;
2019-09-11 08:38:26 +02:00
} elsif (/: PARTICIPANT ($guidre) QOS=\{/o) {
my $guid = hexify($1);
(my $gid = $guid) =~ s/:[^:]+$//;
my $userdata = $_;
if ($userdata =~ s/.*QOS=\{.*?user_data=//) {
$userdata =~ s/\}$//;
2020-02-28 16:51:13 +01:00
$userdata =~ s/,(?:prismtech_)?entity_factory=\d$//;
2019-09-11 08:38:26 +02:00
$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) {
2020-02-28 16:51:13 +01:00
(my $sysid = $guid) =~ s/:1c1$//;
2019-09-11 08:38:26 +02:00
$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;
2020-02-28 16:51:13 +01:00
# 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=\{([^}]*?)\}/) {
2020-01-08 12:26:21 +01:00
$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");
2019-09-11 08:38:26 +02:00
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 {
2020-02-28 16:51:13 +01:00
# all-zero GUID prefix or no topic, type: DDSI built-in reader/writer
2019-09-11 08:38:26 +02:00
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})) {
2020-02-28 16:51:13 +01:00
# 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};
2019-09-11 08:38:26 +02:00
}
2020-02-28 16:51:13 +01:00
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};
}
2019-09-11 08:38:26 +02:00
}
}
2020-02-28 16:51:13 +01:00
} 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) {
2019-09-11 08:38:26 +02:00
my $st = $1; my $ppguid = hexify($2); my $bes = hex $3; my $processguid = $4; my $ip = $5;
2020-02-28 16:51:13 +01:00
$ip =~ s/^(udp|tcp)[46]?\///;
2019-09-11 08:38:26 +02:00
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 {
2020-02-28 16:51:13 +01:00
# 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$//;
2019-09-11 08:38:26 +02:00
}
} 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,
2020-02-28 16:51:13 +01:00
tasymdisc => $ts,
2019-09-11 08:38:26 +02:00
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;
2020-02-28 16:51:13 +01:00
unless ($qos =~ /topic(?:_name)?="?([^,"]+?)"?,type(?:_name)?="?([^,"]+?)"?,(?:.+?,)?partition=\{([^}]*?)\}/) {
2019-09-11 08:38:26 +02:00
die unless $prwguid =~ /[4c][27]$/;
}
2020-01-08 12:26:21 +01:00
my $topic = $1; my $type = $2; my $partitions = $3;
2019-09-11 08:38:26 +02:00
(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]$/;
2020-02-28 16:51:13 +01:00
#die if defined $pwr{$pwrguid}->{tdel}; # the order reversal is possible, however unlikely
2019-09-11 08:38:26 +02:00
#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]$/;
2020-02-28 16:51:13 +01:00
#die if defined $prd{$prdguid}->{tdel}; # the order reversal is possible, however unlikely
2019-09-11 08:38:26 +02:00
#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};
}
2020-01-13 13:43:11 +01:00
} elsif (/ACKNACK\(F?#\d+:(\d+)\/\d+:([01]*) (?:$leasere)?($guidre) -> ($guidre)(\??)/o) {
2019-09-11 08:38:26 +02:00
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;
}
}
}
2020-01-13 13:43:11 +01:00
} elsif (/HEARTBEAT\(F?L?#\d+:(\d+)\.\.(\d+) ($guidre)/o) {
2019-09-11 08:38:26 +02:00
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;
2020-01-13 13:43:11 +01:00
return;
2019-09-11 08:38:26 +02:00
}
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;
}
