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.10.1;
  11
  12 use JSON;
  13 use DXDebug;
  14
  15 my $json;
  16
  17 our %spec = (
  18                          '0' => [
  19                                          ['type', 'int32'],
  20                                          ['id', 'utf'],
  21                                          ['schema', 'int32'],
  22                                          ['version', 'utf'],
  23                                          ['revision', 'utf'],
  24                                         ],
  25                          '1' => [
  26                                          ['type', 'int32'],
  27                                          ['id', 'utf'],
  28                                          ['qrg', 'int64', '_myqrg'],
  29                                          ['mode', 'utf'],
  30                                          ['dxcall', 'utf'],
  31                                          ['report', 'utf'],
  32                                          ['txmode', 'utf'],
  33                                          ['txenabled', 'bool'],
  34                                          ['txing', 'bool'],
  35                                          ['decoding', 'bool'],
  36                                          ['rxdf', 'int32'],
  37                                          ['txdf', 'int32'],
  38                                          ['mycall', 'utf', '_mycall'],
  39                                          ['mygrid', 'utf', '_mygrid'],
  40                                          ['dxgrid', 'utf'],
  41                                          ['txwd', 'bool'],
  42                                          ['submode', 'utf'],
  43                                          ['fastmode', 'bool'],
  44                                          ['som', 'int8', \&_som],
  45                                          ['qrgtol', 'int32'],
  46                                          ['trperiod', 'int32'],
  47                                          ['confname', 'utf'],
  48                                         ],
  49                          '2' => [
  50                                          ['type', 'int32'],
  51                                          ['id', 'utf'],
  52                                          ['new', 'bool'],
  53                                          ['tms', 'int32'],
  54                                          ['snr', 'int32'],
  55                                          ['deltat', 'float'],
  56                                          ['deltaqrg', 'int32'],
  57                                          ['mode', 'utf'],
  58                                          ['msg', 'utf'],
  59                                          ['lowconf', 'bool'],
  60                                          ['offair', 'bool'],
  61                                         ],
  62                          '3' => [
  63                                          ['type', 'int32'],
  64                                          ['id', 'utf'],
  65                                          ['window', 'int8'],
  66                                         ],
  67                          '4' => [
  68                                          ['type', 'int32'],
  69                                          ['id', 'utf'],
  70                                          ['tms', 'int32'],
  71                                          ['snr', 'int32'],
  72                                          ['deltat', 'float'],
  73                                          ['deltaqrg', 'int32'],
  74                                          ['mode', 'utf'],
  75                                          ['msg', 'utf'],
  76                                          ['lowconf', 'bool'],
  77                                          ['modifiers', 'int8'],
  78                                         ],
  79                          '5' => [
  80                                          ['type', 'int32'],
  81                                          ['id', 'utf'],
  82                                          ['toff', 'qdate'],
  83                                          ['dxcall', 'utf'],
  84                                          ['dxgrid', 'utf'],
  85                                          ['qrg', 'int64'],
  86                                          ['mode', 'utf'],
  87                                          ['repsent', 'utf'],
  88                                          ['reprcvd', 'utf'],
  89                                          ['txpower', 'utf'],
  90                                          ['comment', 'utf'],
  91                                          ['name', 'utf'],
  92                                          ['ton', 'qdate'],
  93                                          ['opcall', 'utf'],
  94                                          ['mycall', 'utf'],
  95                                          ['mysent', 'utf'],
  96                                          ['xchgsent', 'utf'],
  97                                          ['reprcvd', 'utf'],
  98                                         ],
  99                          '6' => [
 100                                          ['type', 'int32'],
 101                                          ['id', 'utf'],
 102                                         ],
 103                          '7' => [
 104                                          ['type', 'int32'],
 105                                          ['id', 'utf'],
 106                                         ],
 107                          '8' => [
 108                                          ['type', 'int32'],
 109                                          ['id', 'utf'],
 110                                          ['autotx', 'bool'],
 111                                         ],
 112                          '9' => [
 113                                          ['type', 'int32'],
 114                                          ['id', 'utf'],
 115                                          ['txt', 'utf'],
 116                                          ['send', 'bool'],
 117                                         ],
 118                          '10' => [
 119                                           ['type', 'int32'],
 120                                           ['id', 'utf'],
 121                                           ['new', 'bool'],
 122                                           ['tms', 'int32'],
 123                                           ['snr', 'int32'],
 124                                           ['deltat', 'float'],
 125                                           ['qrg', 'int64'],
 126                                           ['drift', 'int32'],
 127                                           ['call', 'utf'],
 128                                           ['grid', 'utf'],
 129                                           ['power', 'int32'],
 130                                           ['offair', 'bool'],
 131                                          ],
 132                          '11' => [
 133                                          ['type', 'int32'],
 134                                          ['id', 'utf'],
 135                                          ['grid', 'utf'],
 136                                         ],
 137                          '12' => [
 138                                          ['type', 'int32'],
 139                                          ['id', 'utf'],
 140                                          ['adif', 'utf'],
 141                                         ],
 142
 143                         );
 144
 145 sub new
 146 {
 147         my $name = shift;
 148         my $args =  ref $_[0] ? $_[0] : {@_};
 149
 150         $json = JSON->new->canonical unless $json;
 151
 152         my $self = bless {}, $name;
 153         if (exists $args->{handle}) {
 154                 my $v = $args->{handle};
 155                 for (split ',', $v) {
 156                         $self->{"h_$_"} = 1;
 157                 }
 158         }
 159         return $self;
 160
 161 }
 162
 163 sub handle
 164 {
 165         my ($self, $handle, $data, $origin) = @_;
 166
 167         my $lth = length $data;
 168         dbgdump('udp', "UDP IN lth: $lth", $data);
 169
 170         my ($magic, $schema, $type) = eval {unpack 'N N N', $data};
 171         return 0 unless $magic == 0xadbccbda && $schema >= 0 && $schema <= 3 && $spec{$type};
 172         my $out = $self->unpack($data, $spec{$type}, $origin);
 173         dbg($out) if $out && $type != 0;
 174
 175         return $out;
 176 }
 177
 178 use constant NAME => 0;
 179 use constant SORT => 1;
 180 use constant FUNC => 2;
 181 use constant LASTTIME => 0;
 182 use constant MYCALL => 1;
 183 use constant MYGRID => 2;
 184 use constant MYQRG => 3;
 185
 186 sub unpack
 187 {
 188         my $self = shift;
 189         my $data = shift;
 190         my $spec = shift;
 191         my $ip = shift;
 192
 193         my $now = time;
 194         my $mycall;
 195         my $mygrid;
 196         my $myqrg;
 197
 198         if ($ip) {
 199                 my $cr = $self->{CR}->{$ip};
 200                 if ($cr) {
 201                         $mycall = $cr->[MYCALL];
 202                         $mygrid = $cr->[MYGRID];
 203                         $myqrg = $cr->[MYQRG];
 204                         $cr->[LASTTIME] = $now;
 205                 }
 206                 $self->{ip} = $ip
 207         } else {
 208                 delete $self->{ip};
 209         }
 210
 211         my $pos = $self->{unpackpos} || 8;
 212         my $out = $pos ? '{' : '';
 213
 214         foreach my $r (@$spec) {
 215                 my $v = 'NULL';
 216                 my $l;
 217                 my $alpha;
 218
 219                 last if $pos >= length $data;
 220
 221                 if ($r->[SORT] eq 'int32') {
 222                         $l = 4;
 223                         ($v) = unpack 'l>', substr $data, $pos, $l;
 224                 } elsif ($r->[SORT] eq 'int64') {
 225                         $l = 8;
 226                         ($v) = unpack 'Q>', substr $data, $pos, $l;
 227                 } elsif ($r->[SORT] eq 'int8') {
 228                         $l = 1;
 229                         ($v) = unpack 'c', substr $data, $pos, $l;
 230
 231                 } elsif ($r->[SORT] eq 'bool') {
 232                         $l = 1;
 233                         ($v) = unpack 'c', substr $data, $pos, $l;
 234                         $v += 0;
 235                 } elsif ($r->[SORT] eq 'float') {
 236                         $l = 8;
 237                         ($v) = unpack 'd>', substr $data, $pos, $l;
 238                         $v = sprintf '%.3f', $v;
 239                         $v += 0;
 240                 } elsif ($r->[SORT] eq 'utf') {
 241                         $l = 4;
 242                         ($v) = unpack 'l>', substr $data, $pos, 4;
 243                         if ($v > 0) {
 244                                 ($v) = unpack "a$v", substr $data, $pos+4;
 245                                 $l += length $v;
 246                                 ++$alpha;
 247                         } else {
 248                                 $pos += 4;
 249                                 next;                   # null alpha field
 250                         }
 251                 }
 252
 253                 $out .= qq{"$r->[NAME]":};
 254                 if ($r->[FUNC]) {
 255                         no strict 'refs';
 256                         ($v, $alpha) = $r->[FUNC]($self, $v);
 257                 }
 258                 $out .= $alpha ? qq{"$v"} : $v;
 259                 $out .= ',';
 260                 $pos += $l;
 261         }
 262
 263         return undef unless $mycall;
 264
 265         $out .= qq{"ocall":"$mycall",} if $mycall;
 266         $out .= qq{"ogrid":"$mygrid",} if $mygrid;
 267         $out .= qq{"oqrg":"$myqrg",} if $myqrg;
 268 #       $out .= qq{"oip":"$ip",} if $ip;
 269
 270         $out =~ s/,$//;
 271         $out .= '}';
 272
 273         delete $self->{unpackpos};
 274
 275         return $out;
 276 }
 277
 278 sub finish
 279 {
 280
 281 }
 282
 283 sub per_sec
 284 {
 285
 286 }
 287
 288 sub per_minute
 289 {
 290
 291 }
 292
 293 sub _som
 294 {
 295         my $self = shift;
 296
 297         my @s = qw{NONE NA-VHF EU-VHF FIELD-DAY RTTY-RU WW-DIGI FOX HOUND};
 298         my $v = $s[shift];
 299         $v ||= 'UNKNOWN';
 300         return ($v, 1);
 301 }
 302
 303 sub _mycall
 304 {
 305         my $self = shift;
 306         my $v = shift;
 307         my $ip = $self->{ip};
 308         my $cr = $self->{CR}->{$ip} ||= [];
 309         $v = $cr->[MYCALL] //= $v;
 310         return ($v, 1);
 311 }
 312
 313 sub _mygrid
 314 {
 315         my $self = shift;
 316         my $v = shift;
 317         my $ip = $self->{ip};
 318         my $cr = $self->{CR}->{$ip} ||= [];
 319         $v = $cr->[MYGRID] //= $v;
 320         return ($v, 1);
 321 }
 322
 323 sub _myqrg
 324 {
 325         my $self = shift;
 326         my $v = shift;
 327         my $ip = $self->{ip};
 328         my $cr = $self->{CR}->{$ip} ||= [];
 329         $v = $cr->[MYQRG] = $v;
 330         return ($v, 1);
 331 }
 332
 333 1;