From: Dirk Koopman <djk@tobit.co.uk>
Date: Mon, 14 Sep 2020 23:19:13 +0000 (+0200)
Subject: nominally working wsjtl with tcp listener
X-Git-Url: http://scm.dxcluster.org/gitweb/gitweb.cgi?a=commitdiff_plain;h=7b01da28872dd9fb93e9dc29683869a851efd6cc;p=spider.git

nominally working wsjtl with tcp listener
---

diff --git a/perl/DXUDP.pm b/perl/DXUDP.pm
index d9dda00c..01c3b3b0 100644
--- a/perl/DXUDP.pm
+++ b/perl/DXUDP.pm
@@ -140,6 +140,8 @@ sub _incoming {
 	$self->emit(read => $datagram);
 }	
 
+has peerhost => sub { return $_[0]->{socket}->peerhost };
+has peerport => sub { return $_[0]->{socket}->peerport };
 
 sub DEMOLISH {
     my $self = shift;
diff --git a/perl/WSJTX.pm b/perl/WSJTX.pm
index fac39c2f..b421620b 100644
--- a/perl/WSJTX.pm
+++ b/perl/WSJTX.pm
@@ -7,83 +7,140 @@ package WSJTX;
 
 use strict;
 use warnings;
-use 5.22.1;
+use 5.10.1;
 
 use JSON;
 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' => [
+our %spec = (
+			 '0' => [
+					 ['type', 'int32'],
+					 ['id', 'utf'],
+					 ['schema', 'int32'],
+					 ['version', 'utf'],
+					 ['revision', 'utf'],
+					],
+			 '1' => [
+					 ['type', 'int32'],
+					 ['id', 'utf'],
+					 ['qrg', 'int64', '_myqrg'],
+					 ['mode', 'utf'],
+					 ['dxcall', 'utf'],
+					 ['report', 'utf'],
+					 ['txmode', 'utf'],
+					 ['txenabled', 'bool'],
+					 ['txing', 'bool'],
+					 ['decoding', 'bool'],
+					 ['rxdf', 'int32'],
+					 ['txdf', 'int32'],
+					 ['mycall', 'utf', '_mycall'],
+					 ['mygrid', 'utf', '_mygrid'],
+					 ['dxgrid', 'utf'],
+					 ['txwd', 'bool'],
+					 ['submode', 'utf'],
+					 ['fastmode', 'bool'],
+					 ['som', 'int8', \&_som],
+					 ['qrgtol', 'int32'],
+					 ['trperiod', 'int32'],
+					 ['confname', 'utf'],
+					],
+			 '2' => [
+					 ['type', 'int32'],
+					 ['id', 'utf'],
+					 ['new', 'bool'],
+					 ['tms', 'int32'],
+					 ['snr', 'int32'],
+					 ['deltat', 'float'],
+					 ['deltaqrg', 'int32'],
+					 ['mode', 'utf'],
+					 ['msg', 'utf'],
+					 ['lowconf', 'bool'],
+					 ['offair', 'bool'],
+					],
+			 '3' => [
+					 ['type', 'int32'],
+					 ['id', 'utf'],
+					 ['window', 'int8'],
+					],
+			 '4' => [
+					 ['type', 'int32'],
+					 ['id', 'utf'],
+					 ['tms', 'int32'],
+					 ['snr', 'int32'],
+					 ['deltat', 'float'],
+					 ['deltaqrg', 'int32'],
+					 ['mode', 'utf'],
+					 ['msg', 'utf'],
+					 ['lowconf', 'bool'],
+					 ['modifiers', 'int8'],
+					],
+			 '5' => [
+					 ['type', 'int32'],
+					 ['id', 'utf'],
+					 ['toff', 'qdate'],
+					 ['dxcall', 'utf'],
+					 ['dxgrid', 'utf'],
+					 ['qrg', 'int64'],
+					 ['mode', 'utf'],
+					 ['repsent', 'utf'],
+					 ['reprcvd', 'utf'],
+					 ['txpower', 'utf'],
+					 ['comment', 'utf'],
+					 ['name', 'utf'],
+					 ['ton', 'qdate'],
+					 ['opcall', 'utf'],
+					 ['mycall', 'utf'],
+					 ['mysent', 'utf'],
+					 ['xchgsent', 'utf'],
+					 ['reprcvd', 'utf'],
+					],
+			 '6' => [
+					 ['type', 'int32'],
+					 ['id', 'utf'],
+					],
+			 '7' => [
+					 ['type', 'int32'],
+					 ['id', 'utf'],
+					],
+			 '8' => [
+					 ['type', 'int32'],
+					 ['id', 'utf'],
+					 ['autotx', 'bool'],
+					],
+			 '9' => [
+					 ['type', 'int32'],
+					 ['id', 'utf'],
+					 ['txt', 'utf'],
+					 ['send', 'bool'],
+					],
+			 '10' => [
 					  ['type', 'int32'],
 					  ['id', 'utf'],
 					  ['new', 'bool'],
-					  ['t', 'int32'],
+					  ['tms', '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'],
+					  ['drift', 'int32'],
+					  ['call', 'utf'],
+					  ['grid', 'utf'],
+					  ['power', 'int32'],
+					  ['offair', 'bool'],
 					 ],
-			 );
+			 '11' => [
+					 ['type', 'int32'],
+					 ['id', 'utf'],
+					 ['grid', 'utf'],
+					],
+			 '12' => [
+					 ['type', 'int32'],
+					 ['id', 'utf'],
+					 ['adif', 'utf'],
+					],
+			 
+			);
 
 sub new
 {
@@ -105,102 +162,55 @@ sub new
 
 sub handle
 {
-	my ($self, $handle, $data) = @_;
+	my ($self, $handle, $data, $origin) = @_;
 
 	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;
+	return 0 unless $magic == 0xadbccbda && $schema >= 0 && $schema <= 3 && $spec{$type};
+	my $out = $self->unpack($data, $spec{$type}, $origin);
+	dbg($out) if $out && $type != 0;
 	
-	(
-	 $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);
-	}
+	return $out;
 }
 
 use constant NAME => 0;
 use constant SORT => 1;
-use constant FUNCTION => 3;
+use constant FUNC => 2;
+use constant LASTTIME => 0;
+use constant MYCALL => 1;
+use constant MYGRID => 2;
+use constant MYQRG => 3;
 
 sub unpack
 {
 	my $self = shift;
 	my $data = shift;
 	my $spec = shift;
-	my $end = shift;
+	my $ip = shift;
 
-	my $pos = $self->{unpackpos} || 0;
-	my $out = $pos ? '{' : '';
+	my $now = time;
+	my $mycall;
+	my $mygrid;
+	my $myqrg;
+		
+	if ($ip) {
+		my $cr = $self->{CR}->{$ip};
+		if ($cr) {
+			$mycall = $cr->[MYCALL];
+			$mygrid = $cr->[MYGRID];
+			$myqrg = $cr->[MYQRG];
+			$cr->[LASTTIME] = $now;
+		}
+		$self->{ip} = $ip
+	} else {
+		delete $self->{ip};
+	}
 	
+	my $pos = $self->{unpackpos} || 8;
+	my $out = $pos ? '{' : '';
+
 	foreach my $r (@$spec) {
 		my $v = 'NULL';
 		my $l;
@@ -217,6 +227,7 @@ sub unpack
 		} 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;
@@ -230,27 +241,37 @@ sub unpack
 			$l = 4;
 			($v) = unpack 'l>', substr $data, $pos, 4;
 			if ($v > 0) {
-				($v) = unpack "a$v", substr $data, $pos;
+				($v) = unpack "a$v", substr $data, $pos+4;
 				$l += length $v;
 				++$alpha;
 			} else {
+				$pos += 4;
 				next;			# null alpha field
 			} 
 		}
 
 		$out .= qq{"$r->[NAME]":};
+		if ($r->[FUNC]) {
+			no strict 'refs';
+			($v, $alpha) = $r->[FUNC]($self, $v);
+		}
 		$out .= $alpha ? qq{"$v"} : $v;
 		$out .= ',';
 		$pos += $l;
 	}
 
-	if ($end) {
-		$out =~ s/,$//;
-		$out .= '}';
-		delete $self->{unpackpos};
-	} else {
-		$self->{unpackpos} = $pos;
-	}
+	return undef unless $mycall;
+	
+	$out .= qq{"ocall":"$mycall",} if $mycall;
+	$out .= qq{"ogrid":"$mygrid",} if $mygrid;
+	$out .= qq{"oqrg":"$myqrg",} if $myqrg;
+#	$out .= qq{"oip":"$ip",} if $ip;
+
+	$out =~ s/,$//;
+	$out .= '}';
+	
+	delete $self->{unpackpos};
+
 	return $out;
 }
 
@@ -261,7 +282,7 @@ sub finish
 
 sub per_sec
 {
-
+	
 }
 
 sub per_minute
@@ -269,5 +290,44 @@ sub per_minute
 
 }
 
+sub _som
+{
+	my $self = shift;
+	
+	my @s = qw{NONE NA-VHF EU-VHF FIELD-DAY RTTY-RU WW-DIGI FOX HOUND};
+	my $v = $s[shift];
+	$v ||= 'UNKNOWN';
+	return ($v, 1);
+}
+
+sub _mycall
+{
+	my $self = shift;
+	my $v = shift;
+	my $ip = $self->{ip};
+	my $cr = $self->{CR}->{$ip} ||= [];
+	$v = $cr->[MYCALL] //= $v;
+	return ($v, 1); 
+}
+
+sub _mygrid
+{
+	my $self = shift;
+	my $v = shift;
+	my $ip = $self->{ip};
+	my $cr = $self->{CR}->{$ip} ||= [];
+	$v = $cr->[MYGRID] //= $v;
+	return ($v, 1); 
+}
+
+sub _myqrg
+{
+	my $self = shift;
+	my $v = shift;
+	my $ip = $self->{ip};
+	my $cr = $self->{CR}->{$ip} ||= [];
+	$v = $cr->[MYQRG] = $v;
+	return ($v, 1); 
+}
 
 1;
diff --git a/perl/grepwsjtl b/perl/grepwsjtl
new file mode 100755
index 00000000..364f9360
--- /dev/null
+++ b/perl/grepwsjtl
@@ -0,0 +1,134 @@
+#!/usr/bin/perl
+#
+# Program to do a grep with dates and times on the debug
+# files
+#
+# grepwsjtl [nn] [-mm] <regular expression>
+#
+# nn - is the day you what to look at: 1 is yesterday, 0 is today
+# and is optional if there is only one argument
+#
+# -mmm - print the mmm lines before the match. So -10 will print
+# ten lines including the line matching the regular expression. 
+#
+# <regexp> is the regular expression you are searching for, 
+# a caseless search is done. There can be more than one <regexp>
+# a <regexp> preceeded by a '!' is treated as NOT <regexp>. Each
+# <regexp> is implcitly ANDed together. 
+#
+# If you specify something that likes a filename and that filename
+# has a .pm on the end of it and it exists then rather than doing
+# the regex match it executes the "main::handle()" function passing
+# it one line at a time.
+#
+#
+
+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 SysVar;
+use DXUtil;
+use DXLog;
+use Julian;
+
+use strict;
+
+use vars qw(@list $fp $today $string);
+
+
+$fp = DXLog::new('wsjtl', 'dat', 'd');
+$today = $fp->unixtoj(time()); 
+my $nolines = 1;
+my @prev;
+my @patt;
+
+foreach my $arg (@ARGV) {
+	if ($arg =~ /^-/) {
+		$arg =~ s/^-//o;
+		if ($arg =~ /^\s*\-+(?:[h\?]e?l?p?)/) {
+			usage();
+			exit(0);
+		}
+		push @list, $arg;
+	} elsif ($arg =~ /^\d+$/) {
+		$nolines = $arg;
+	} elsif ($arg =~ /\.pm$/) {
+		if (-e $arg) {
+			my $fn = $arg;
+			$fn =~ s/\.pm$//;
+			eval { require $arg};
+			die "requiring $fn failed $@" if $@;
+		} else {
+			die "$arg not found";
+		}
+	} else {
+		push @patt, $arg;
+	}
+}
+
+push @patt, '.*' unless @patt;
+
+push @list, "0" unless @list;
+for my $entry (@list) {
+	my $now = $today->sub($entry); 
+	my $fh = $fp->open($now); 
+	my $line;
+	my $do;
+
+	if (main->can('handle')) {
+		$do = \&handle;
+	} else {
+		$do = \&process;
+	}
+
+	begin() if main->can('begin');
+	if ($fh) {
+		while (<$fh>) {
+			&$do($_);
+		}
+		$fp->close();
+	}
+	end() if main->can('end');
+}
+
+sub process
+{
+	my $line = shift;
+	chomp $line;
+	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) {
+		for (@prev) {
+			s/([\x00-\x1f\x7f-\xff])/sprintf("\\x%02X", ord($1))/eg; 
+			my ($t, $l) =  split /\^/, $_, 2;
+			print atime($t), ' ', $l, "\n";
+			print '----------------' if $nolines > 1;
+		}
+		@prev = ();
+	}
+}
+	
+sub usage
+{
+	die "usage: grepwsjtl [nn days before] [-nnn lines before] [<perl file name>] [<regexp>|!<regexp>]...\n";
+}
+exit(0);
diff --git a/perl/wsjtl.pl b/perl/wsjtl.pl
index 8915a2c8..f991366e 100755
--- a/perl/wsjtl.pl
+++ b/perl/wsjtl.pl
@@ -78,37 +78,73 @@ our $tcp_port = 2238;
 my $uh;							# the mojo handle for the UDP listener
 my $th;							#  ditto TCP
 my $wsjtx;						# the wsjtx decoder
-
+my $cease;
 
 our %slot;			  # where the connected TCP client structures live
 
 
 dbginit('wsjtl');
 
-
+my @queue;
 
 $uh = DXUDP->new;
 $uh->start(host => $udp_host, port => $udp_port) or die "Cannot listen on $udp_host:$udp_port $!\n";
 
-$wsjtx = WSJTX->new(handle=>'2,5');
-$uh->on(read => \&_read);
+$wsjtx = WSJTX->new();
+$uh->on(read => \&_udpread);
+
+$th = Mojo::IOLoop::Server->new;
+$th->on(accept => \&_accept);
+$th->listen(address => $tcp_host, port => $tcp_port);
+$th->start;
 
 Mojo::IOLoop->start() unless Mojo::IOLoop->is_running;
 
-sub _read
+exit;
+
+sub _udpread
 {
 	my ($handle, $data) = @_;
 
-#	say "before handle";
+	my $host = $handle->peerhost;
+	my $port = $handle->peerport;
+   
+	my $in = $wsjtx->handle($handle, $data, "$host:$port");
+
+	distribute($in);
+}
+
+sub _accept
+{
+	my ($id, $handle) = @_;
+	my $host = $handle->peerhost;
+	my $port = $handle->peerport;
+
 	
-	$wsjtx->handle($handle, $data);
+	my $s = $slot{"$host:$port"} = { addr => "$host:$port"};
+	my $stream = $s->{stream} = Mojo::IOLoop::Stream->new($handle);
+	$stream->on(error => sub { $stream->close; delete $s->{addr}});
+	$stream->on(close => sub { delete $s->{addr}});
+	$stream->on(read => sub {_tcpread($s, $_[1])});
+	$stream->timeout(0);
+	$stream->start;
+}
 
-#	say "after handle";
+sub _tcpread
+{
+	my $s = shift;
+	my $data = shift;
 	
-#	my $lth = length $data;
-#	dbgdump('udp', "UDP IN lth: $lth", $data);	
+	dbg("incoming: $data");
+}
+
+sub distribute
+{
+	my $in = shift;
+	foreach my $c (values %slot) {
+		$c->{stream}->write("$in\r\n");
+	}
 }
 
-exit;