perl/WSJTX.pm

   1 #
   2 # WSJTX logging and control protocol decoder etc
   3 #
   4 #
   5
   6 package WSJTX;
   7
   8 use strict;
   9 use warnings;
  10 use 5.22.1;
  11
  12 use JSON;
  13 use DXDebug;
  14
  15 my $json;
  16
  17 our %specs = (
  18                           'head' => [
  19                                                  ['magic', 'int32'],
  20                                                  ['proto', 'int32'],
  21                                                 ],
  22                           '0' => [
  23                                           ['type', 'int32'],
  24                                           ['id', 'utf'],
  25                                           ['schema', 'int32'],
  26                                           ['version', 'utf'],
  27                                           ['revision', 'utf'],
  28                                          ],
  29                           '1' => [
  30                                           ['type', 'int32'],
  31                                           ['id', 'utf'],
  32                                           ['qrg', 'int64'],
  33                                           ['mode', 'utf'],
  34                                           ['dxcall', 'utf'],
  35                                           ['report', 'utf'],
  36                                           ['txmode', 'utf'],
  37                                           ['txenabled', 'bool'],
  38                                           ['txing', 'bool'],
  39                                           ['decoding', 'bool'],
  40                                           ['rxdf', 'int32'],
  41                                           ['txdf', 'int32'],
  42                                           ['mycall', 'utf'],
  43                                           ['mygrid', 'utf'],
  44                                           ['dxgrid', 'utf'],
  45                                           ['txwd', 'bool'],
  46                                           ['submode', 'utf'],
  47                                           ['fastmode', 'bool'],
  48                                           ['som', 'int8'],
  49                                           ['qrgtol', 'int32'],
  50                                           ['trperiod', 'int32'],
  51                                           ['confname', 'utf'],
  52                                          ],
  53                           '2' => [
  54                                           ['type', 'int32'],
  55                                           ['id', 'utf'],
  56                                           ['new', 'bool'],
  57                                           ['t', 'int32'],
  58                                           ['snr', 'int32'],
  59                                           ['deltat', 'float'],
  60                                           ['deltaqrg', 'int32'],
  61                                           ['mode', 'utf'],
  62                                           ['msg', 'utf'],
  63                                           ['lowconf', 'bool'],
  64                                           ['offair', 'bool'],
  65                                          ],
  66                           '5' => [
  67                                           ['type', 'int32'],
  68                                           ['id', 'utf'],
  69                                           ['toff', 'qtime'],
  70                                           ['dxcall', 'utf'],
  71                                           ['dxgrid', 'utf'],
  72                                           ['qrg', 'int64'],
  73                                           ['mode', 'utf'],
  74                                           ['repsent', 'utf'],
  75                                           ['reprcvd', 'utf'],
  76                                           ['txpower', 'utf'],
  77                                           ['comment', 'utf'],
  78                                           ['name', 'utf'],
  79                                           ['ton', 'qtime'],
  80                                           ['opcall', 'utf'],
  81                                           ['mycall', 'utf'],
  82                                           ['mysent', 'utf'],
  83                                           ['xchgsent', 'utf'],
  84                                           ['reprcvd', 'utf'],
  85                                          ],
  86                          );
  87
  88 sub new
  89 {
  90         my $name = shift;
  91         my $args =  ref $_[0] ? $_[0] : {@_};
  92
  93         $json = JSON->new->canonical unless $json;
  94
  95         my $self = bless {}, $name;
  96         if (exists $args->{handle}) {
  97                 my $v = $args->{handle};
  98                 for (split ',', $v) {
  99                         $self->{"h_$_"} = 1;
 100                 }
 101         }
 102         return $self;
 103
 104 }
 105
 106 sub handle
 107 {
 108         my ($self, $handle, $data) = @_;
 109
 110         my $lth = length $data;
 111         dbgdump('udp', "UDP IN lth: $lth", $data);
 112
 113         my ($magic, $schema, $type) = eval {unpack 'N N N', $data};
 114         return 0 unless $magic == 0xadbccbda && $schema >= 0 && $schema <= 3 && $type >= 0  && $type <= 32; # 32 to allow for expansion
 115
 116         no strict 'refs';
 117         my $h = "decode$type";
 118         if ($self->can($h)) {
 119                 my $a = unpack "H*", $data;
 120                 $a =~ s/f{8}/00000000/g;
 121                 $data = pack 'H*', $a;
 122                 dbgdump('udp', "UDP process lth: $lth", $data);
 123                 $self->$h($type, substr($data, 12)) if $self->{"h_$type"};
 124         } else {
 125                 dbg("decode $type not implemented");
 126         }
 127
 128
 129         return 1;
 130
 131 }
 132
 133 sub decode0
 134 {
 135         my ($self, $type, $data) = @_;
 136
 137         my %r;
 138         $r{type} = $type;
 139
 140         ($r{id}, $r{schema}, $r{version}, $r{revision}) = eval {unpack 'l>/a N l>/a l>/a', $data};
 141         if ($@) {
 142                 dbg($@);
 143         } else {
 144                 my $j = $json->encode(\%r);
 145                 dbg($j);
 146         }
 147
 148 }
 149
 150 sub decode1
 151 {
 152         my ($self, $type, $data) = @_;
 153
 154         my %r;
 155         $r{type} = $type;
 156
 157         (
 158          $r{id}, $r{qrg}, $r{mode}, $r{dxcall}, $r{report}, $r{txmode},
 159          $r{txenabled}, $r{txing}, $r{decoding}, $r{rxdf}, $r{txdf},
 160          $r{decall}, $r{degrid}, $r{dxgrid}, $r{txwatch}, $r{som},
 161          $r{fast}, $r{qrgtol}, $r{trperiod}, $r{confname}
 162
 163         ) = 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};
 164         if ($@) {
 165                 dbg($@);
 166         } else {
 167                 my $j = $json->encode(\%r);
 168                 dbg($j);
 169         }
 170 }
 171
 172 sub decode2
 173 {
 174         my ($self, $type, $data) = @_;
 175
 176         my %r;
 177         $r{type} = $type;
 178
 179         (
 180          $r{id}, $r{new}, $r{tms}, $r{snr}, $r{deltat}, $r{deltaqrg}, $r{mode}, $r{msg}, $r{lowconf}, $r{offair}
 181         )  = eval {unpack 'l>/a C N l> d> N l>/a l>/a C C ', $data};
 182         if ($@) {
 183                 dbg($@);
 184         } else {
 185                 my $j = $json->encode(\%r);
 186                 dbg($j);
 187         }
 188 }
 189
 190 use constant NAME => 0;
 191 use constant SORT => 1;
 192 use constant FUNCTION => 3;
 193
 194 sub unpack
 195 {
 196         my $self = shift;
 197         my $data = shift;
 198         my $spec = shift;
 199         my $end = shift;
 200
 201         my $pos = $self->{unpackpos} || 0;
 202         my $out = $pos ? '{' : '';
 203
 204         foreach my $r (@$spec) {
 205                 my $v = 'NULL';
 206                 my $l;
 207                 my $alpha;
 208
 209                 last if $pos >= length $data;
 210
 211                 if ($r->[SORT] eq 'int32') {
 212                         $l = 4;
 213                         ($v) = unpack 'l>', substr $data, $pos, $l;
 214                 } elsif ($r->[SORT] eq 'int64') {
 215                         $l = 8;
 216                         ($v) = unpack 'Q>', substr $data, $pos, $l;
 217                 } elsif ($r->[SORT] eq 'int8') {
 218                         $l = 1;
 219                         ($v) = unpack 'c', substr $data, $pos, $l;
 220                 } elsif ($r->[SORT] eq 'bool') {
 221                         $l = 1;
 222                         ($v) = unpack 'c', substr $data, $pos, $l;
 223                         $v += 0;
 224                 } elsif ($r->[SORT] eq 'float') {
 225                         $l = 8;
 226                         ($v) = unpack 'd>', substr $data, $pos, $l;
 227                         $v = sprintf '%.3f', $v;
 228                         $v += 0;
 229                 } elsif ($r->[SORT] eq 'utf') {
 230                         $l = 4;
 231                         ($v) = unpack 'l>', substr $data, $pos, 4;
 232                         if ($v > 0) {
 233                                 ($v) = unpack "a$v", substr $data, $pos;
 234                                 $l += length $v;
 235                                 ++$alpha;
 236                         } else {
 237                                 next;                   # null alpha field
 238                         }
 239                 }
 240
 241                 $out .= qq{"$r->[NAME]":};
 242                 $out .= $alpha ? qq{"$v"} : $v;
 243                 $out .= ',';
 244                 $pos += $l;
 245         }
 246
 247         if ($end) {
 248                 $out =~ s/,$//;
 249                 $out .= '}';
 250                 delete $self->{unpackpos};
 251         } else {
 252                 $self->{unpackpos} = $pos;
 253         }
 254         return $out;
 255 }
 256
 257 sub finish
 258 {
 259
 260 }
 261
 262 sub per_sec
 263 {
 264
 265 }
 266
 267 sub per_minute
 268 {
 269
 270 }
 271
 272
 273 1;