From 0527b7c5dc1f7e87eb6de0f7f6ce2f2ec27dd11e Mon Sep 17 00:00:00 2001 From: Dirk Koopman Date: Mon, 14 Sep 2020 17:17:34 +0200 Subject: [PATCH] wsjtl WIP --- perl/DXUDP.pm | 3 +- perl/WSJTX.pm | 227 +++++++++++++++++++++++++++++++++++++++++++++++- perl/watchwsjtl | 100 +++++++++++++++++++++ perl/wsjtl.pl | 11 +-- 4 files changed, 334 insertions(+), 7 deletions(-) create mode 100755 perl/watchwsjtl mode change 100644 => 100755 perl/wsjtl.pl diff --git a/perl/DXUDP.pm b/perl/DXUDP.pm index 28daf805..d9dda00c 100644 --- a/perl/DXUDP.pm +++ b/perl/DXUDP.pm @@ -39,6 +39,7 @@ A simple Mojo compatible UDP thingy use Mojo::Base 'Mojo::EventEmitter'; use Mojo::IOLoop; use Scalar::Util qw(weaken); +use IO::Socket::INET6; our $VERSION = '0.04'; @@ -107,7 +108,7 @@ sub start { my $host = $args->{LocalAddr} || $args->{host} || '0.0.0.0'; my $port = $args->{LocalPort} || $args->{port} || 1234; - $socket = IO::Socket::IP->new( + $socket = IO::Socket::INET6->new( LocalAddr => $host, LocalPort => $port, Proto => 'udp', diff --git a/perl/WSJTX.pm b/perl/WSJTX.pm index 16f7b64a..fac39c2f 100644 --- a/perl/WSJTX.pm +++ b/perl/WSJTX.pm @@ -14,9 +14,93 @@ use DXDebug; my $json; +our %specs = ( + 'head' => [ + ['magic', 'int32'], + ['proto', 'int32'], + ], + '0' => [ + ['type', 'int32'], + ['id', 'utf'], + ['schema', 'int32'], + ['version', 'utf'], + ['revision', 'utf'], + ], + '1' => [ + ['type', 'int32'], + ['id', 'utf'], + ['qrg', 'int64'], + ['mode', 'utf'], + ['dxcall', 'utf'], + ['report', 'utf'], + ['txmode', 'utf'], + ['txenabled', 'bool'], + ['txing', 'bool'], + ['decoding', 'bool'], + ['rxdf', 'int32'], + ['txdf', 'int32'], + ['mycall', 'utf'], + ['mygrid', 'utf'], + ['dxgrid', 'utf'], + ['txwd', 'bool'], + ['submode', 'utf'], + ['fastmode', 'bool'], + ['som', 'int8'], + ['qrgtol', 'int32'], + ['trperiod', 'int32'], + ['confname', 'utf'], + ], + '2' => [ + ['type', 'int32'], + ['id', 'utf'], + ['new', 'bool'], + ['t', 'int32'], + ['snr', 'int32'], + ['deltat', 'float'], + ['deltaqrg', 'int32'], + ['mode', 'utf'], + ['msg', 'utf'], + ['lowconf', 'bool'], + ['offair', 'bool'], + ], + '5' => [ + ['type', 'int32'], + ['id', 'utf'], + ['toff', 'qtime'], + ['dxcall', 'utf'], + ['dxgrid', 'utf'], + ['qrg', 'int64'], + ['mode', 'utf'], + ['repsent', 'utf'], + ['reprcvd', 'utf'], + ['txpower', 'utf'], + ['comment', 'utf'], + ['name', 'utf'], + ['ton', 'qtime'], + ['opcall', 'utf'], + ['mycall', 'utf'], + ['mysent', 'utf'], + ['xchgsent', 'utf'], + ['reprcvd', 'utf'], + ], + ); + sub new { - return bless {}, 'WSJTX'; + my $name = shift; + my $args = ref $_[0] ? $_[0] : {@_}; + + $json = JSON->new->canonical unless $json; + + my $self = bless {}, $name; + if (exists $args->{handle}) { + my $v = $args->{handle}; + for (split ',', $v) { + $self->{"h_$_"} = 1; + } + } + return $self; + } sub handle @@ -25,10 +109,151 @@ sub handle my $lth = length $data; dbgdump('udp', "UDP IN lth: $lth", $data); + + my ($magic, $schema, $type) = eval {unpack 'N N N', $data}; + return 0 unless $magic == 0xadbccbda && $schema >= 0 && $schema <= 3 && $type >= 0 && $type <= 32; # 32 to allow for expansion + + no strict 'refs'; + my $h = "decode$type"; + if ($self->can($h)) { + my $a = unpack "H*", $data; + $a =~ s/f{8}/00000000/g; + $data = pack 'H*', $a; + dbgdump('udp', "UDP process lth: $lth", $data); + $self->$h($type, substr($data, 12)) if $self->{"h_$type"}; + } else { + dbg("decode $type not implemented"); + } + + return 1; } +sub decode0 +{ + my ($self, $type, $data) = @_; + + my %r; + $r{type} = $type; + + ($r{id}, $r{schema}, $r{version}, $r{revision}) = eval {unpack 'l>/a N l>/a l>/a', $data}; + if ($@) { + dbg($@); + } else { + my $j = $json->encode(\%r); + dbg($j); + } + +} + +sub decode1 +{ + my ($self, $type, $data) = @_; + + my %r; + $r{type} = $type; + + ( + $r{id}, $r{qrg}, $r{mode}, $r{dxcall}, $r{report}, $r{txmode}, + $r{txenabled}, $r{txing}, $r{decoding}, $r{rxdf}, $r{txdf}, + $r{decall}, $r{degrid}, $r{dxgrid}, $r{txwatch}, $r{som}, + $r{fast}, $r{qrgtol}, $r{trperiod}, $r{confname} + + ) = eval {unpack 'l>/a Q> l>/a l>/a l>/a l>/a C C C l> l> l>/a l>/a l>/a C l>/a c l> l> l>/a', $data}; + if ($@) { + dbg($@); + } else { + my $j = $json->encode(\%r); + dbg($j); + } +} + +sub decode2 +{ + my ($self, $type, $data) = @_; + + my %r; + $r{type} = $type; + + ( + $r{id}, $r{new}, $r{tms}, $r{snr}, $r{deltat}, $r{deltaqrg}, $r{mode}, $r{msg}, $r{lowconf}, $r{offair} + ) = eval {unpack 'l>/a C N l> d> N l>/a l>/a C C ', $data}; + if ($@) { + dbg($@); + } else { + my $j = $json->encode(\%r); + dbg($j); + } +} + +use constant NAME => 0; +use constant SORT => 1; +use constant FUNCTION => 3; + +sub unpack +{ + my $self = shift; + my $data = shift; + my $spec = shift; + my $end = shift; + + my $pos = $self->{unpackpos} || 0; + my $out = $pos ? '{' : ''; + + foreach my $r (@$spec) { + my $v = 'NULL'; + my $l; + my $alpha; + + last if $pos >= length $data; + + if ($r->[SORT] eq 'int32') { + $l = 4; + ($v) = unpack 'l>', substr $data, $pos, $l; + } elsif ($r->[SORT] eq 'int64') { + $l = 8; + ($v) = unpack 'Q>', substr $data, $pos, $l; + } elsif ($r->[SORT] eq 'int8') { + $l = 1; + ($v) = unpack 'c', substr $data, $pos, $l; + } elsif ($r->[SORT] eq 'bool') { + $l = 1; + ($v) = unpack 'c', substr $data, $pos, $l; + $v += 0; + } elsif ($r->[SORT] eq 'float') { + $l = 8; + ($v) = unpack 'd>', substr $data, $pos, $l; + $v = sprintf '%.3f', $v; + $v += 0; + } elsif ($r->[SORT] eq 'utf') { + $l = 4; + ($v) = unpack 'l>', substr $data, $pos, 4; + if ($v > 0) { + ($v) = unpack "a$v", substr $data, $pos; + $l += length $v; + ++$alpha; + } else { + next; # null alpha field + } + } + + $out .= qq{"$r->[NAME]":}; + $out .= $alpha ? qq{"$v"} : $v; + $out .= ','; + $pos += $l; + } + + if ($end) { + $out =~ s/,$//; + $out .= '}'; + delete $self->{unpackpos}; + } else { + $self->{unpackpos} = $pos; + } + return $out; +} + sub finish { diff --git a/perl/watchwsjtl b/perl/watchwsjtl new file mode 100755 index 00000000..2c175f74 --- /dev/null +++ b/perl/watchwsjtl @@ -0,0 +1,100 @@ +#!/usr/bin/perl +# +# watch the end of the current debug file (like tail -f) applying +# any regexes supplied on the command line. +# +# There can be more than one . a preceeded by a '!' is +# treated as NOT . Each is implcitly ANDed together. +# All are caseless. +# +# examples:- +# +# watchwsjtl g1tlh # watch everything g1tlh does +# watchwsjtl -2 PCPROT # watch all PCPROT messages + up to 2 lines before +# watchwsjtl gb7baa gb7djk # watch the conversation between BAA and DJK +# + +require 5.004; + +# search local then perl directories +BEGIN { + # root of directory tree for this system + $root = "/spider"; + $root = $ENV{'DXSPIDER_ROOT'} if $ENV{'DXSPIDER_ROOT'}; + + unshift @INC, "$root/perl"; # this IS the right way round! + unshift @INC, "$root/local"; +} + +use IO::File; +use SysVar; +use DXUtil; +use DXLog; + +use strict; + +my $fp = DXLog::new('wsjtl', 'dat', 'd'); +my $today = $fp->unixtoj(time()); +my $fh = $fp->open($today) or die $!; +my $nolines = 1; +$nolines = shift if $ARGV[0] =~ /^-?\d+$/; +$nolines = abs $nolines if $nolines < 0; +my @patt = @ARGV; +my @prev; + +# seek to end of file +$fh->seek(0, 2); +for (;;) { + my $line = $fh->getline; + if ($line) { + if (@patt) { + push @prev, $line; + shift @prev while @prev > $nolines; + my $flag = 0; + foreach my $p (@patt) { + if ($p =~ /^!/) { + my $r = substr $p, 1; + last if $line =~ m{$r}i; + } else { + last unless $line =~ m{$p}i; + } + ++$flag; + } + if ($flag == @patt) { + printit(@prev); + @prev = (); + } + } else { + printit($line); + } + } else { + sleep(1); + + # check that the debug hasn't rolled over to next day + # open it if it has + my $now = $fp->unixtoj(time()); + if ($today->cmp($now)) { + $fp->close; + my $i; + for ($i = 0; $i < 20; $i++) { + last if $fh = $fp->open($now); + sleep 5; + } + die $! if $i >= 20; + $today = $now; + } + } +} + +sub printit +{ + while (@_) { + my $line = shift; + chomp $line; + $line =~ s/([\x00-\x1f\x7f-\xff])/sprintf("\\x%02X", ord($1))/eg; + my ($t, $l) = split /\^/, $line, 2; + $t = time unless defined $t; + printf "%02d:%02d:%02d %s\n", (gmtime($t))[2,1,0], $l; + } +} +exit(0); diff --git a/perl/wsjtl.pl b/perl/wsjtl.pl old mode 100644 new mode 100755 index e6f1c048..8915a2c8 --- a/perl/wsjtl.pl +++ b/perl/wsjtl.pl @@ -1,4 +1,4 @@ -#!/usr/binenv perl +#!/usr/bin/env perl # # A basic listener and decoder of wsjtx packets # @@ -70,8 +70,8 @@ use DXUDP; use WSJTX; -our $udp_host = '0.0.0.0'; -our $udp_port = 59387; # 2237; +our $udp_host = '::'; +our $udp_port = 2237; our $tcp_host = '::'; our $tcp_port = 2238; @@ -84,12 +84,13 @@ our %slot; # where the connected TCP client structures live dbginit('wsjtl'); -dbgadd('udp'); + + $uh = DXUDP->new; $uh->start(host => $udp_host, port => $udp_port) or die "Cannot listen on $udp_host:$udp_port $!\n"; -$wsjtx = WSJTX->new; +$wsjtx = WSJTX->new(handle=>'2,5'); $uh->on(read => \&_read); Mojo::IOLoop->start() unless Mojo::IOLoop->is_running; -- 2.43.0