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
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
{
--- /dev/null
+#!/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 <regexp>. a <regexp> preceeded by a '!' is
+# treated as NOT <regexp>. Each <regexp> is implcitly ANDed together.
+# All <regexp> 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);
projects / spider.git / commitdiff