jlpoole/microReticulumTbeam
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions
microReticulumTbeam/tools/analyze_tbeam_bilateral_transfer_20260520_0412.pl

805 lines
30 KiB
Perl
Executable file
Raw Blame History

#!/usr/bin/env perl
# ./analyze_tbeam_bilateral_transfer_20260520_0412.pl BLE_CY_DAN_20260519_2051.zip
# ./analyze_tbeam_bilateral_transfer_20260520_0412.pl --detail BLE_CY_DAN_20260519_2051.zip
# ./analyze_tbeam_bilateral_transfer_20260520_0412.pl --csv tbeam_chunks_$(date +%Y%m%d_%H%M).csv BLE_CY_DAN_20260519_2051.zip
# ./analyze_tbeam_bilateral_transfer_20260520_0412.pl --report tbeam_report_$(date +%Y%m%d_%H%M).txt BLE_CY_DAN_20260519_2051.zip
#
# 20260520 ChatGPT
# $Header$
# $HeadURL$
#
=pod
Purpose:
Analyze two or more ESP32/T-Beam serial monitor logs from a bilateral
microReticulum + Reticulum BLE file transfer.
The script is intentionally parallel in spirit to
analyze_reticulum_file_transfer_20260518_1930.pl, but the T-Beam logs have a
different shape:
[1779249101.7991] TX FILE BEGIN: round=3 file=US_Constitution.txt ...
[1779249101.9005] TX FILE DATA: round=3 seq=1/148 bytes=300 ...
[1779249105.8511] RX FILE END: from=Node-... received=0/44225 chunks=0/148 ... status=VERIFY_FAIL
[1779249090.6498] 00:21:47.653 [ERR] Decryption failed ... Token token HMAC was invalid
It accepts either log files directly or a .zip archive containing log files.
Zip extraction uses the system unzip command because that is usually already
present on Gentoo/Debian systems and avoids a non-core Perl dependency.
Interpretation note:
HMAC failures mean the receiver rejected encrypted Reticulum traffic before it
became valid application payload. Therefore, a transfer can show many Reticulum
decrypt errors while showing zero RX FILE DATA records.
=cut
use strict;
use warnings;
use Getopt::Long qw(GetOptions);
use POSIX qw(strftime);
use List::Util qw(min max sum);
use File::Basename qw(basename dirname);
use File::Temp qw(tempdir);
use Cwd qw(abs_path getcwd);
my $detail = 0;
my $csv_file = '';
my $report_file = '';
my $keep_extract = 0;
GetOptions(
'detail!' => \$detail,
'csv=s' => \$csv_file,
'report=s' => \$report_file,
'keep-extract' => \$keep_extract,
'help' => \my $help,
) or die usage();
if ($help || !@ARGV) {
print usage();
exit($help ? 0 : 1);
}
my @input_files = expand_inputs(@ARGV);
@input_files or die "No readable log files found.\n";
my @reports;
for my $file (@input_files) {
push @reports, parse_tbeam_log($file);
}
my %node_to_board = infer_node_to_board(@reports);
annotate_remote_boards(\@reports, \%node_to_board);
annotate_errors(\@reports);
my $text = build_report(\@reports, \%node_to_board, $detail);
if ($report_file ne '') {
open my $rfh, '>', $report_file or die "Cannot write $report_file: $!\n";
print {$rfh} $text;
close $rfh;
print "Report written: $report_file\n";
}
else {
print $text;
}
write_csv($csv_file, \@reports) if $csv_file ne '';
exit 0;
sub expand_inputs {
my (@args) = @_;
my @files;
for my $arg (@args) {
if (-d $arg) {
push @files, grep { -f $_ && -r $_ } glob("$arg/*");
next;
}
if ($arg =~ /\.zip\z/i) {
push @files, extract_zip_logs($arg);
next;
}
push @files, $arg if -f $arg && -r $arg;
}
@files = grep { /(?:\.log|\.txt)\z/i || file_looks_like_tbeam_log($_) } @files;
return sort @files;
}
sub extract_zip_logs {
my ($zip) = @_;
-r $zip or die "Cannot read zip archive $zip\n";
my $tdir = tempdir('tbeam_ble_logs_XXXXXX', TMPDIR => 1, CLEANUP => !$keep_extract);
my $cmd = sprintf('unzip -q %s -d %s', shellq($zip), shellq($tdir));
system($cmd) == 0 or die "unzip failed for $zip\n";
my @found;
open my $find, '-|', 'find', $tdir, '-type', 'f' or die "Cannot run find: $!\n";
while (my $path = <$find>) {
chomp $path;
push @found, $path if $path =~ /(?:\.log|\.txt)\z/i || file_looks_like_tbeam_log($path);
}
close $find;
warn "Extracted zip under $tdir\n" if $keep_extract;
return @found;
}
sub file_looks_like_tbeam_log {
my ($file) = @_;
open my $fh, '<', $file or return 0;
my $n = 0;
while (my $line = <$fh>) {
++$n;
if ($line =~ /^#\s+Board:/ || $line =~ /^\[\d+\.\d+\]\s+(?:TX|RX) FILE / || $line =~ /Decryption failed on link/) {
close $fh;
return 1;
}
last if $n > 40;
}
close $fh;
return 0;
}
sub parse_tbeam_log {
my ($file) = @_;
open my $fh, '<', $file or die "Cannot open $file: $!\n";
my %r = (
file => $file,
base => basename($file),
header => {},
tx_rounds => {},
rx_sessions => [],
errors => [],
events => [],
line_count => 0,
);
my %active_rx_by_node;
while (my $line = <$fh>) {
++$r{line_count};
chomp $line;
if ($line =~ /^#\s*([^:]+):\s*(.*)$/) {
my ($k, $v) = (trim($1), trim($2));
$r{header}{$k} = $v;
next;
}
next unless $line =~ /^\[([0-9]+(?:\.[0-9]+)?)\]\s+(.*)$/;
my ($epoch, $msg) = ($1 + 0.0, $2);
$r{first_epoch} = $epoch if !defined $r{first_epoch};
$r{last_epoch} = $epoch;
if ($msg =~ /^TX FILE BEGIN:\s+round=(\d+)\s+file=(\S+)\s+bytes=(\d+)\s+chunks=(\d+)\s+crc=([0-9A-Fa-f]+)/) {
my ($round, $file_name, $bytes, $chunks, $crc) = ($1+0, $2, $3+0, $4+0, uc($5));
my $tx = ($r{tx_rounds}{$round} ||= new_tx_round($round));
@{$tx}{qw(begin_epoch file bytes_expected chunks_expected crc_expected)} = ($epoch, $file_name, $bytes, $chunks, $crc);
push @{$r{events}}, { type => 'tx_begin', epoch => $epoch, round => $round, line => $r{line_count} };
next;
}
if ($msg =~ /^TX FILE DATA:\s+round=(\d+)\s+seq=(\d+)\/(\d+)\s+bytes=(\d+)/) {
my ($round, $seq, $total, $bytes) = ($1+0, $2+0, $3+0, $4+0);
my $tx = ($r{tx_rounds}{$round} ||= new_tx_round($round));
push @{$tx->{data}}, { epoch => $epoch, seq => $seq, total => $total, bytes => $bytes, line => $r{line_count} };
$tx->{chunks_expected} ||= $total;
push @{$r{events}}, { type => 'tx_data', epoch => $epoch, round => $round, seq => $seq, line => $r{line_count} };
next;
}
if ($msg =~ /^TX FILE END:\s+round=(\d+)\s+file=(\S+)\s+bytes=(\d+)\s+chunks=(\d+)\s+crc=([0-9A-Fa-f]+)(?:\s+next_round_in_ms=(\d+))?/) {
my ($round, $file_name, $bytes, $chunks, $crc, $next_ms) = ($1+0, $2, $3+0, $4+0, uc($5), $6);
my $tx = ($r{tx_rounds}{$round} ||= new_tx_round($round));
@{$tx}{qw(end_epoch file bytes_expected chunks_expected crc_expected)} = ($epoch, $file_name, $bytes, $chunks, $crc);
$tx->{next_round_in_ms} = $next_ms + 0 if defined $next_ms;
push @{$r{events}}, { type => 'tx_end', epoch => $epoch, round => $round, line => $r{line_count} };
next;
}
if ($msg =~ /^RX FILE BEGIN:\s+from=(\S+)\s+file=(\S+)\s+bytes=(\d+)\s+chunks=(\d+)\s+crc=([0-9A-Fa-f]+)/) {
my ($from, $file_name, $bytes, $chunks, $crc) = ($1, $2, $3+0, $4+0, uc($5));
my $sess = {
idx => scalar(@{$r{rx_sessions}}) + 1,
from_node => $from,
file => $file_name,
begin_epoch => $epoch,
bytes_expected => $bytes,
chunks_expected => $chunks,
crc_expected => $crc,
data => [],
errors => [],
begin_line => $r{line_count},
};
push @{$r{rx_sessions}}, $sess;
$active_rx_by_node{$from} = $sess;
push @{$r{events}}, { type => 'rx_begin', epoch => $epoch, rx_idx => $sess->{idx}, from_node => $from, line => $r{line_count} };
next;
}
if ($msg =~ /^RX FILE DATA:\s+from=(\S+)\s+seq=(\d+)\/(\d+)\s+bytes=(\d+)/) {
my ($from, $seq, $total, $bytes) = ($1, $2+0, $3+0, $4+0);
my $sess = $active_rx_by_node{$from};
if (!$sess) {
$sess = {
idx => scalar(@{$r{rx_sessions}}) + 1,
from_node => $from,
file => 'UNKNOWN',
begin_epoch => undef,
bytes_expected => undef,
chunks_expected => $total,
crc_expected => undef,
data => [],
errors => [],
synthetic => 1,
};
push @{$r{rx_sessions}}, $sess;
$active_rx_by_node{$from} = $sess;
}
push @{$sess->{data}}, { epoch => $epoch, seq => $seq, total => $total, bytes => $bytes, line => $r{line_count} };
$sess->{chunks_expected} ||= $total;
push @{$r{events}}, { type => 'rx_data', epoch => $epoch, rx_idx => $sess->{idx}, from_node => $from, seq => $seq, line => $r{line_count} };
next;
}
if ($msg =~ /^RX FILE END:\s+from=(\S+)\s+file=(\S+)\s+received=(\d+)\/(\d+)\s+chunks=(\d+)\/(\d+)\s+crc=([0-9A-Fa-f]+)\s+status=(\S+)/) {
my ($from, $file_name, $rx_bytes, $expect_bytes, $rx_chunks, $expect_chunks, $crc, $status) = ($1, $2, $3+0, $4+0, $5+0, $6+0, uc($7), $8);
my $sess = $active_rx_by_node{$from};
if (!$sess) {
$sess = {
idx => scalar(@{$r{rx_sessions}}) + 1,
from_node => $from,
file => $file_name,
begin_epoch => undef,
bytes_expected => $expect_bytes,
chunks_expected => $expect_chunks,
crc_expected => undef,
data => [],
errors => [],
synthetic => 1,
};
push @{$r{rx_sessions}}, $sess;
}
@{$sess}{qw(end_epoch file bytes_received bytes_expected chunks_received chunks_expected crc_seen status end_line)} =
($epoch, $file_name, $rx_bytes, $expect_bytes, $rx_chunks, $expect_chunks, $crc, $status, $r{line_count});
delete $active_rx_by_node{$from};
push @{$r{events}}, { type => 'rx_end', epoch => $epoch, rx_idx => $sess->{idx}, from_node => $from, line => $r{line_count} };
next;
}
if ($msg =~ /\[ERR\]\s+Decryption failed on link\s+\{Link:([^}]+)\}\.\s+The contained exception was:\s+(.+)$/) {
my ($link, $exception) = ($1, $2);
my $class = classify_error($exception);
my $err = {
epoch => $epoch,
link => $link,
exception => $exception,
class => $class,
line => $r{line_count},
raw => $msg,
};
push @{$r{errors}}, $err;
push @{$r{events}}, { type => 'error', epoch => $epoch, error => $err, line => $r{line_count} };
next;
}
}
close $fh;
$r{board} = $r{header}{Board} || board_from_filename($file);
summarize_tx_round($_) for values %{$r{tx_rounds}};
summarize_rx_session($_) for @{$r{rx_sessions}};
return \%r;
}
sub new_tx_round {
my ($round) = @_;
return {
round => $round,
data => [],
};
}
sub classify_error {
my ($e) = @_;
return 'HMAC_INVALID' if $e =~ /HMAC/i;
return 'PADDING_INVALID' if $e =~ /pad|padding/i;
return 'TOKEN_INVALID' if $e =~ /token/i;
return 'OTHER';
}
sub summarize_tx_round {
my ($tx) = @_;
my @d = sort { $a->{seq} <=> $b->{seq} || $a->{epoch} <=> $b->{epoch} } @{$tx->{data}};
$tx->{data} = \@d;
$tx->{data_count} = scalar @d;
$tx->{bytes_sent_logged} = sum0(map { $_->{bytes} } @d);
$tx->{first_data_epoch} = @d ? $d[0]{epoch} : undef;
$tx->{last_data_epoch} = @d ? $d[-1]{epoch} : undef;
$tx->{first_seq} = @d ? min(map { $_->{seq} } @d) : undef;
$tx->{last_seq} = @d ? max(map { $_->{seq} } @d) : undef;
$tx->{chunk_total_seen} = @d ? max(map { $_->{total} } @d) : ($tx->{chunks_expected} || 0);
$tx->{missing} = missing_ranges([ map { $_->{seq} } @d ], $tx->{chunk_total_seen});
$tx->{duplicates} = duplicate_list(map { $_->{seq} } @d);
$tx->{data_span} = defined($tx->{first_data_epoch}) && defined($tx->{last_data_epoch}) ? $tx->{last_data_epoch} - $tx->{first_data_epoch} : undef;
$tx->{round_span} = defined($tx->{begin_epoch}) && defined($tx->{end_epoch}) ? $tx->{end_epoch} - $tx->{begin_epoch} : undef;
$tx->{gaps} = [ consecutive_deltas(map { $_->{epoch} } @d) ];
}
sub summarize_rx_session {
my ($s) = @_;
my @d = sort { $a->{seq} <=> $b->{seq} || $a->{epoch} <=> $b->{epoch} } @{$s->{data}};
$s->{data} = \@d;
$s->{data_count} = scalar @d;
$s->{bytes_data_logged} = sum0(map { $_->{bytes} } @d);
$s->{first_data_epoch} = @d ? $d[0]{epoch} : undef;
$s->{last_data_epoch} = @d ? $d[-1]{epoch} : undef;
$s->{first_seq} = @d ? min(map { $_->{seq} } @d) : undef;
$s->{last_seq} = @d ? max(map { $_->{seq} } @d) : undef;
$s->{missing} = missing_ranges([ map { $_->{seq} } @d ], $s->{chunks_expected} || 0);
$s->{duplicates} = duplicate_list(map { $_->{seq} } @d);
$s->{data_span} = defined($s->{first_data_epoch}) && defined($s->{last_data_epoch}) ? $s->{last_data_epoch} - $s->{first_data_epoch} : undef;
$s->{session_span} = defined($s->{begin_epoch}) && defined($s->{end_epoch}) ? $s->{end_epoch} - $s->{begin_epoch} : undef;
$s->{gaps} = [ consecutive_deltas(map { $_->{epoch} } @d) ];
}
sub infer_node_to_board {
my (@reports) = @_;
my %received_from;
for my $r (@reports) {
my $board = $r->{board};
for my $s (@{$r->{rx_sessions}}) {
next unless defined $s->{from_node};
$received_from{$board}{$s->{from_node}}++;
}
}
my %node_to_board;
if (@reports == 2) {
my ($a, $b) = @reports;
my ($board_a, $board_b) = ($a->{board}, $b->{board});
for my $node (keys %{$received_from{$board_a} || {}}) {
$node_to_board{$node} = $board_b;
}
for my $node (keys %{$received_from{$board_b} || {}}) {
$node_to_board{$node} = $board_a;
}
}
return %node_to_board;
}
sub annotate_remote_boards {
my ($reports, $node_to_board) = @_;
for my $r (@$reports) {
for my $s (@{$r->{rx_sessions}}) {
$s->{from_board} = $node_to_board->{$s->{from_node}} if defined $s->{from_node} && exists $node_to_board->{$s->{from_node}};
}
}
}
sub annotate_errors {
my ($reports) = @_;
for my $r (@$reports) {
my @tx = values %{$r->{tx_rounds}};
my @rx = @{$r->{rx_sessions}};
for my $e (@{$r->{errors}}) {
for my $tx (@tx) {
next unless defined $tx->{begin_epoch} && defined $tx->{end_epoch};
if ($e->{epoch} >= $tx->{begin_epoch} && $e->{epoch} <= $tx->{end_epoch}) {
$e->{tx_round} = $tx->{round};
$tx->{error_count}++;
}
}
for my $s (@rx) {
next unless defined $s->{begin_epoch} && defined $s->{end_epoch};
if ($e->{epoch} >= $s->{begin_epoch} && $e->{epoch} <= $s->{end_epoch}) {
$e->{rx_idx} = $s->{idx};
push @{$s->{errors}}, $e;
}
}
}
}
}
sub build_report {
my ($reports, $node_to_board, $detail) = @_;
my $out = '';
my $emit = sub { $out .= join('', @_) };
$emit->("Reticulum BLE T-Beam bilateral transfer analysis\n");
$emit->("Generated: ", strftime('%Y-%m-%d %H:%M:%S %Z', localtime), "\n");
$emit->("Input files:\n");
for my $r (@$reports) {
$emit->(" $r->{file}\n");
}
$emit->("\n");
$emit->("Capture summary:\n");
for my $r (@$reports) {
my $duration = defined($r->{first_epoch}) && defined($r->{last_epoch}) ? $r->{last_epoch} - $r->{first_epoch} : 0;
$emit->(sprintf " %-36s board=%-6s port=%-12s exercise=%-6s lines=%6d duration=%8.3f s\n",
$r->{base}, $r->{board} || 'UNKNOWN', $r->{header}{Port} || 'UNKNOWN', $r->{header}{Exercise} || 'n/a', $r->{line_count}, $duration);
$emit->(sprintf " started : %s\n", $r->{header}{Started} || 'not seen');
$emit->(sprintf " command : %s\n", $r->{header}{Command} || 'not seen');
}
$emit->("\n");
$emit->("Inferred Reticulum node identity map:\n");
if (%$node_to_board) {
for my $node (sort keys %$node_to_board) {
$emit->(sprintf " %-22s => %s\n", $node, $node_to_board->{$node});
}
}
else {
$emit->(" not enough information to infer node-to-board mapping\n");
}
$emit->("\n");
$emit->("Per-board high-level totals:\n");
for my $r (@$reports) {
my @tx_rounds = values %{$r->{tx_rounds}};
my @rx_sessions = @{$r->{rx_sessions}};
my $tx_data = sum0(map { $_->{data_count} } @tx_rounds);
my $rx_data = sum0(map { $_->{data_count} } @rx_sessions);
my $rx_ok = scalar grep { ($_->{status} || '') eq 'OK' } @rx_sessions;
my $rx_fail = scalar grep { ($_->{status} || '') ne '' && ($_->{status} || '') ne 'OK' } @rx_sessions;
my %err_class;
$err_class{$_->{class}}++ for @{$r->{errors}};
$emit->(sprintf " %-6s tx_rounds=%3d tx_data=%4d rx_sessions=%3d rx_data=%4d rx_ok=%3d rx_fail=%3d decrypt_errors=%5d",
$r->{board}, scalar(@tx_rounds), $tx_data, scalar(@rx_sessions), $rx_data, $rx_ok, $rx_fail, scalar(@{$r->{errors}}));
if (%err_class) {
$emit->(" ", join(' ', map { "$err_class{$_} $_" } sort keys %err_class));
}
$emit->("\n");
}
$emit->("\n");
$emit->("TX round summary:\n");
for my $r (@$reports) {
$emit->(" Board $r->{board}\n");
for my $round (sort { $a <=> $b } keys %{$r->{tx_rounds}}) {
my $tx = $r->{tx_rounds}{$round};
my $expected = $tx->{chunks_expected} || $tx->{chunk_total_seen} || 0;
my $complete = $expected ? 100.0 * $tx->{data_count} / $expected : 0;
$emit->(sprintf " round=%-3d file=%-22s chunks=%3d/%-3d completeness=%6.2f%% bytes_logged=%6d span=%8s data_span=%8s errors_during_tx=%4d missing=%s dupes=%s\n",
$round,
$tx->{file} || 'UNKNOWN',
$tx->{data_count} || 0,
$expected,
$complete,
$tx->{bytes_sent_logged} || 0,
fmt_s($tx->{round_span}),
fmt_s($tx->{data_span}),
$tx->{error_count} || 0,
@{$tx->{missing}} ? join(',', @{$tx->{missing}}) : 'none',
@{$tx->{duplicates}} ? join(',', @{$tx->{duplicates}}) : 'none');
emit_gap_stats_to_string(\$out, " tx inter-data gap", $tx->{gaps});
}
}
$emit->("\n");
$emit->("RX session summary:\n");
for my $r (@$reports) {
$emit->(" Board $r->{board}\n");
for my $s (sort { ($a->{begin_epoch} || 0) <=> ($b->{begin_epoch} || 0) } @{$r->{rx_sessions}}) {
my $expected = $s->{chunks_expected} || 0;
my $rx_chunks = defined($s->{chunks_received}) ? $s->{chunks_received} : $s->{data_count};
my $complete = $expected ? 100.0 * $rx_chunks / $expected : 0;
$emit->(sprintf " rx#=%-2d from=%-6s node=%-22s file=%-22s status=%-11s chunks=%3d/%-3d completeness=%6.2f%% bytes=%6s/%-6s crc=%-8s expect=%-8s session_span=%8s data_span=%8s errors=%4d missing=%s dupes=%s\n",
$s->{idx},
$s->{from_board} || '?',
$s->{from_node} || 'UNKNOWN',
$s->{file} || 'UNKNOWN',
$s->{status} || 'OPEN/UNKNOWN',
$rx_chunks,
$expected,
$complete,
defined($s->{bytes_received}) ? $s->{bytes_received} : $s->{bytes_data_logged} || 0,
defined($s->{bytes_expected}) ? $s->{bytes_expected} : '?',
$s->{crc_seen} || '?',
$s->{crc_expected} || '?',
fmt_s($s->{session_span}),
fmt_s($s->{data_span}),
scalar(@{$s->{errors} || []}),
@{$s->{missing}} ? join(',', @{$s->{missing}}) : 'none',
@{$s->{duplicates}} ? join(',', @{$s->{duplicates}}) : 'none');
emit_gap_stats_to_string(\$out, " rx inter-data gap", $s->{gaps});
}
}
$emit->("\n");
$emit->("Decrypt error summary:\n");
for my $r (@$reports) {
my @e = @{$r->{errors}};
$emit->(" Board $r->{board}\n");
if (!@e) {
$emit->(" none\n");
next;
}
my %by_class; $by_class{$_->{class}}++ for @e;
my %by_link; $by_link{$_->{link}}++ for @e;
my $span = $e[-1]{epoch} - $e[0]{epoch};
my $rate = $span > 0 ? @e / $span : 0;
$emit->(sprintf " total=%d first=%s last=%s span=%.3f s rate=%.2f errors/s\n",
scalar(@e), fmt_epoch($e[0]{epoch}), fmt_epoch($e[-1]{epoch}), $span, $rate);
$emit->(" by class: ", join(', ', map { "$by_class{$_} $_" } sort keys %by_class), "\n");
$emit->(" by link : ", join(', ', map { "$by_link{$_} $_" } sort keys %by_link), "\n");
my %by_tx;
my %by_rx;
for my $err (@e) {
$by_tx{defined($err->{tx_round}) ? $err->{tx_round} : 'no-active-tx'}++;
$by_rx{defined($err->{rx_idx}) ? $err->{rx_idx} : 'no-active-rx'}++;
}
$emit->(" during TX rounds: ", join(', ', map { "$_=$by_tx{$_}" } sort by_mixed keys %by_tx), "\n");
$emit->(" during RX sessions: ", join(', ', map { "$_=$by_rx{$_}" } sort by_mixed keys %by_rx), "\n");
emit_error_bursts(\$out, \@e);
}
$emit->("\n");
$emit->("Bilateral asymmetry notes:\n");
$emit->(build_asymmetry_notes($reports));
$emit->("\n");
if ($detail) {
$emit->("Detailed RX DATA rows:\n");
for my $r (@$reports) {
$emit->(" Board $r->{board}\n");
for my $s (@{$r->{rx_sessions}}) {
for my $d (@{$s->{data}}) {
$emit->(sprintf " rx#=%-2d t=%s from=%-6s seq=%3d/%-3d bytes=%3d line=%d\n",
$s->{idx}, fmt_epoch($d->{epoch}), $s->{from_board} || '?', $d->{seq}, $d->{total}, $d->{bytes}, $d->{line});
}
}
}
$emit->("\n");
}
$emit->("Caution:\n");
$emit->(" This report uses the host-side epoch prefix from the serial monitor. That is excellent for ordering and gap analysis,\n");
$emit->(" but it is not the same as an on-device timestamp captured before BLE queueing and Reticulum decrypt work.\n");
return $out;
}
sub build_asymmetry_notes {
my ($reports) = @_;
my $s = '';
for my $r (@$reports) {
my $board = $r->{board};
my $err_count = scalar @{$r->{errors}};
my $rx_ok = scalar grep { ($_->{status} || '') eq 'OK' } @{$r->{rx_sessions}};
my $rx_fail = scalar grep { ($_->{status} || '') ne '' && ($_->{status} || '') ne 'OK' } @{$r->{rx_sessions}};
my $zero_chunk_fail = scalar grep { (($_->{status} || '') ne '' && ($_->{status} || '') ne 'OK') && (($_->{chunks_received} || 0) == 0) } @{$r->{rx_sessions}};
$s .= sprintf(" %-6s rx_ok=%d rx_fail=%d zero_chunk_fail=%d decrypt_errors=%d\n", $board, $rx_ok, $rx_fail, $zero_chunk_fail, $err_count);
}
my @bad = grep { @{$_->{errors}} > 0 } @$reports;
my @good = grep { @{$_->{errors}} == 0 } @$reports;
if (@bad && @good) {
$s .= " Observation: decrypt failures are asymmetric. At least one board receives complete files while another reports Reticulum HMAC failures.\n";
$s .= " Working hypothesis: investigate the receiver/server side before blaming the Constitution payload or the sender text chunker.\n";
}
return $s;
}
sub emit_error_bursts {
my ($out_ref, $errors) = @_;
my %bin;
for my $e (@$errors) {
$bin{int($e->{epoch})}++;
}
my @top = sort { $bin{$b} <=> $bin{$a} || $a <=> $b } keys %bin;
@top = @top[0 .. min(4, $#top)] if @top > 5;
$$out_ref .= " busiest seconds: ";
$$out_ref .= @top ? join(', ', map { fmt_epoch($_) . "=$bin{$_}" } @top) : 'none';
$$out_ref .= "\n";
}
sub write_csv {
my ($csv, $reports) = @_;
open my $out, '>', $csv or die "Cannot write $csv: $!\n";
print {$out} join(',', qw(board event direction peer file round rx_idx seq total bytes epoch time status crc expected_crc error_class link line source_log)), "\n";
for my $r (@$reports) {
for my $round (sort { $a <=> $b } keys %{$r->{tx_rounds}}) {
my $tx = $r->{tx_rounds}{$round};
for my $d (@{$tx->{data}}) {
print {$out} join(',', map { csvq($_) } (
$r->{board}, 'TX_FILE_DATA', 'tx', '', $tx->{file} || '', $round, '',
$d->{seq}, $d->{total}, $d->{bytes}, sprintf('%.4f', $d->{epoch}), fmt_epoch($d->{epoch}), '', '', '', '', '', $d->{line}, $r->{base}
)), "\n";
}
}
for my $s (@{$r->{rx_sessions}}) {
for my $d (@{$s->{data}}) {
print {$out} join(',', map { csvq($_) } (
$r->{board}, 'RX_FILE_DATA', 'rx', $s->{from_board} || $s->{from_node} || '', $s->{file} || '', '', $s->{idx},
$d->{seq}, $d->{total}, $d->{bytes}, sprintf('%.4f', $d->{epoch}), fmt_epoch($d->{epoch}), $s->{status} || '', $s->{crc_seen} || '', $s->{crc_expected} || '', '', '', $d->{line}, $r->{base}
)), "\n";
}
}
for my $e (@{$r->{errors}}) {
print {$out} join(',', map { csvq($_) } (
$r->{board}, 'DECRYPT_ERROR', 'rx', '', '', $e->{tx_round} || '', $e->{rx_idx} || '',
'', '', '', sprintf('%.4f', $e->{epoch}), fmt_epoch($e->{epoch}), '', '', '', $e->{class}, $e->{link}, $e->{line}, $r->{base}
)), "\n";
}
}
close $out;
print "CSV written: $csv\n";
}
# Build-report-local gap appender. Kept separate from emit_gap_stats to avoid passing closures everywhere.
sub emit_gap_stats_to_string {
my ($out_ref, $label, $values) = @_;
return if !$values || !@$values;
$$out_ref .= sprintf "%s min/median/mean/p95/max/stddev: %.3f / %.3f / %.3f / %.3f / %.3f / %.3f ms\n",
$label,
min(@$values) * 1000.0,
percentile(50, @$values) * 1000.0,
mean(@$values) * 1000.0,
percentile(95, @$values) * 1000.0,
max(@$values) * 1000.0,
stddev(@$values) * 1000.0;
}
# Monkey-patch wrapper used by build_report's lexical $out. This is clearer than a global in usage.
# Perl has no closures by name, so build_report calls this helper via explicit code below.
sub fmt_s {
my ($v) = @_;
return 'n/a' unless defined $v;
return sprintf('%.3f s', $v);
}
sub fmt_epoch {
my ($epoch) = @_;
return 'n/a' unless defined $epoch;
my $whole = int($epoch);
my $ms = int(($epoch - $whole) * 1000.0 + 0.5);
if ($ms >= 1000) { ++$whole; $ms -= 1000; }
return strftime('%H:%M:%S', localtime($whole)) . sprintf('.%03d', $ms);
}
sub consecutive_deltas {
my (@v) = @_;
my @d;
for (my $i = 1; $i < @v; ++$i) {
push @d, $v[$i] - $v[$i - 1];
}
return @d;
}
sub missing_ranges {
my ($seen_ref, $expected) = @_;
return [] if !$expected;
my %seen = map { $_ => 1 } @$seen_ref;
my @missing = grep { !$seen{$_} } 1 .. $expected;
return [] unless @missing;
my @ranges;
my ($start, $prev) = ($missing[0], $missing[0]);
for my $m (@missing[1 .. $#missing]) {
if ($m == $prev + 1) {
$prev = $m;
}
else {
push @ranges, $start == $prev ? $start : "$start-$prev";
($start, $prev) = ($m, $m);
}
}
push @ranges, $start == $prev ? $start : "$start-$prev";
return \@ranges;
}
sub duplicate_list {
my (@v) = @_;
my %count;
++$count{$_} for @v;
return [ sort { $a <=> $b } grep { $count{$_} > 1 } keys %count ];
}
sub percentile {
my ($p, @values) = @_;
@values = sort { $a <=> $b } @values;
return 0 unless @values;
return $values[0] if @values == 1;
my $rank = ($p / 100.0) * (@values - 1);
my $lo = int($rank);
my $hi = $lo + 1;
return $values[$lo] if $hi > $#values;
my $frac = $rank - $lo;
return $values[$lo] + (($values[$hi] - $values[$lo]) * $frac);
}
sub mean {
my (@values) = @_;
return 0 unless @values;
return sum0(@values) / @values;
}
sub stddev {
my (@values) = @_;
return 0 if @values < 2;
my $mean = mean(@values);
my $ss = 0;
$ss += ($_ - $mean) ** 2 for @values;
return sqrt($ss / @values);
}
sub sum0 {
return 0 unless @_;
my $s = sum(@_);
return defined($s) ? $s : 0;
}
sub by_mixed {
my $aa = $a;
my $bb = $b;
return $aa <=> $bb if $aa =~ /^\d+\z/ && $bb =~ /^\d+\z/;
return $aa cmp $bb;
}
sub board_from_filename {
my ($file) = @_;
my $base = basename($file);
return $1 if $base =~ /_(AMY|BOB|CY|DAN|ED|FLO|GUY)_/i;
return $1 if $base =~ /\b(AMY|BOB|CY|DAN|ED|FLO|GUY)\b/i;
return $base;
}
sub trim {
my ($v) = @_;
$v = '' unless defined $v;
$v =~ s/^\s+//;
$v =~ s/\s+\z//;
return $v;
}
sub shellq {
my ($s) = @_;
$s =~ s/'/'"'"'/g;
return "'$s'";
}
sub csvq {
my ($v) = @_;
$v = '' unless defined $v;
$v =~ s/"/""/g;
return '"' . $v . '"';
}
sub usage {
return <<'USAGE';
Usage:
analyze_tbeam_bilateral_transfer_20260520_0412.pl [options] log1.log log2.log
analyze_tbeam_bilateral_transfer_20260520_0412.pl [options] BLE_CY_DAN_20260519_2051.zip
Options:
--detail Print detailed RX DATA rows.
--csv FILE Write normalized TX/RX/error rows to CSV.
--report FILE Write the report to FILE instead of STDOUT.
--keep-extract Keep temporary extraction directory when reading .zip input.
--help Show this help.
Examples:
chmod 755 analyze_tbeam_bilateral_transfer_20260520_0412.pl
./analyze_tbeam_bilateral_transfer_20260520_0412.pl \
BLE_CY_DAN_20260519_2051.zip
./analyze_tbeam_bilateral_transfer_20260520_0412.pl \
--detail \
--csv tbeam_chunks_$(date +%Y%m%d_%H%M).csv \
--report tbeam_report_$(date +%Y%m%d_%H%M).txt \
BLE_CY_DAN_20260519_2051.zip
USAGE
}
Reference in a new issue View git blame Copy permalink