perl/BPQMsg.pm

   1 #
   2 # This class is the internal subclass that deals with the G8BPQ switch connections
   3 #
   4 # Written by John Wiseman G8BPQ Jan 2006
   5 #
   6 # Based on AGWMsg.pm Copyright (c) 2001 - Dirk Koopman G1TLH
   7 #
   8
   9 package BPQMsg;
  10
  11 use strict;
  12 use Msg;
  13 use BPQConnect;
  14 use DXDebug;
  15
  16 use vars qw(@ISA @outqueue $send_offset $inmsg $rproc $noports
  17                         %circuit $total_in $total_out);
  18
  19 @ISA = qw(Msg ExtMsg);
  20 @outqueue = ();
  21 $send_offset = 0;
  22 $inmsg = '';
  23 $rproc = undef;
  24 $noports = 0;
  25 %circuit = ();
  26 $total_in = $total_out = 0;
  27
  28 my $GetFreeBuffs;
  29 my $FindFreeStream;
  30 my $SetAppl;
  31 my $SessionState;
  32 my $GetCallsign;
  33 my $SendMsg;
  34 my $GetMsg;
  35 my $RXCount;
  36 my $DeallocateStream;
  37 my $SessionControl;
  38
  39 my @Stream;
  40
  41 my $Buffers;
  42
  43 sub init
  44 {
  45         return unless $enable;
  46
  47         eval {
  48                 require Win32::API;
  49         };
  50         if ($@) {
  51                 $enable = 0;
  52                 dbg("BPQWin disabled because Win32::API cannot be loaded");
  53                 return;
  54         } else {
  55                 Win32::API->import;
  56         }
  57
  58         $rproc = shift;
  59
  60         dbg("BPQ initialising...");
  61
  62         $GetFreeBuffs = Win32::API->new("bpq32", "int _GetFreeBuffs\@0()");
  63     $FindFreeStream = Win32::API->new("bpq32", "int _FindFreeStream\@0()");
  64     $SetAppl = Win32::API->new("bpq32", "int _SetAppl\@12(int a, int b, int c)");
  65     $SessionState = Win32::API->new("bpq32", "DWORD _SessionState\@12(DWORD stream, LPDWORD state, LPDWORD change)");
  66         $GetCallsign = new Win32::API("bpq32", "_GetCallsign\@8",'NP','N');
  67         $SendMsg = new Win32::API("bpq32","_SendMsg\@12",'NPN','N');
  68         $RXCount = new Win32::API("bpq32","_RXCount\@4",'N','N');
  69         $GetMsg = Win32::API->new("bpq32","_GetMsgPerl\@8",'NP','N');
  70
  71         $DeallocateStream = Win32::API->new("bpq32","_DeallocateStream\@4",'N','N');
  72     $SessionControl = Win32::API->new("bpq32", "int _SessionControl\@12(int a, int b, int c)");
  73
  74         if (!defined $GetMsg) {
  75                 $GetMsg = Win32::API->new("bpqperl","_GetMsgPerl\@8",'NP','N');
  76         }
  77
  78         if (!defined $GetMsg) {
  79                 dbg ("Can't find routine 'GetMsgPerl' - is bpqperl.dll available?");
  80         }
  81
  82         $Buffers = 0;
  83
  84         if (defined $GetFreeBuffs && defined $GetMsg) {
  85                 my $s;
  86
  87                 $Buffers = $GetFreeBuffs->Call();
  88
  89                 dbg("G8BPQ Free Buffers = $Buffers") if isdbg('bpq');
  90
  91                 $s = "BPQ Streams:";
  92
  93                 for (my $i = 1; $i <= $BPQStreams; $i++) {
  94
  95                         $Stream[$i] = $FindFreeStream->Call();
  96
  97                         $s .= " $Stream[$i]";
  98
  99                         $SetAppl->Call($Stream[$i], 0, $ApplMask);
 100
 101                 }
 102
 103                 dbg($s) if isdbg('bpq');
 104         } else {
 105
 106                 dbg("Couldn't initialise BPQ32 switch, BPQ disabled");
 107                 $enable = 0;
 108         }
 109 }
 110
 111 sub finish
 112 {
 113         return unless $enable;
 114
 115         dbg("BPQ Closing..") if isdbg('bpq');
 116
 117         return unless $Buffers;
 118
 119         for (my $i = 1; $i <= $BPQStreams; $i++) {
 120                 $SetAppl->Call($Stream[$i], 0, 0);
 121                 $SessionControl->Call($Stream[$i], 2, 0); # Disconnect
 122                 $DeallocateStream->Call($Stream[$i]);
 123         }
 124 }
 125
 126 sub login
 127 {
 128         goto &main::login;                      # save some writing, this was the default
 129 }
 130
 131 sub active
 132 {
 133         dbg("BPQ is active called") if isdbg('bpq');
 134         return $Buffers;
 135 }
 136
 137
 138 sub connect
 139 {
 140
 141         return unless $Buffers;
 142
 143         my ($conn, $line) = @_;
 144         my ($port, $call) = split /\s+/, $line;
 145
 146
 147         dbg("BPQ Outgoing Connect  $conn $port $call") if isdbg('bpq');
 148
 149
 150         for (my $i = $BPQStreams; $i > 0; $i--) {
 151                 my $inuse = $circuit{$Stream[$i]};
 152
 153                 if (not $inuse) {               # Active connection?
 154
 155                         dbg("BPQ Outgoing Connect using stream $i") if isdbg('bpq');
 156
 157                         $conn->{bpqstream} = $Stream[$i];
 158                         $conn->{lineend} = "\cM";
 159                         $conn->{incoming} = 0;
 160                         $conn->{csort} = 'ax25';
 161                         $conn->{bpqcall} = uc $call;
 162                         $circuit{$Stream[$i]} = $conn;
 163
 164                         $SessionControl->Call($Stream[$i], 1, 0); # Connect
 165
 166                         $conn->{state} = 'WC';
 167
 168                         return 1;
 169
 170                 }
 171
 172         }
 173
 174         # No free streams
 175         dbg("BPQ Outgoing Connect - No streams available") if isdbg('bpq');
 176
 177         $conn->{bpqstream} = 0;         # So we can tidy up
 178         $circuit{0} = $conn;
 179         return 0;
 180 }
 181
 182 sub in_disconnect
 183 {
 184         my $conn = shift;
 185         dbg( "in_disconnect $conn $circuit{$conn->{bpqstream}}") if isdbg('bpq');
 186         delete $circuit{$conn->{bpqstream}};
 187         $conn->SUPER::disconnect;
 188 }
 189
 190 sub disconnect
 191 {
 192
 193         return unless $enable && $Buffers;
 194
 195         my $conn = shift;
 196
 197         delete $circuit{$conn->{bpqstream}};
 198
 199         $conn->SUPER::disconnect;
 200
 201         if ($conn->{bpqstream}) {       # not if stream = 0!
 202                 $SessionControl->Call($conn->{bpqstream}, 2, 0); # Disconnect
 203         }
 204 }
 205
 206 sub enqueue
 207 {
 208
 209         return unless $Buffers;
 210
 211         my ($conn, $msg) = @_;
 212
 213         if ($msg =~ /^D/) {
 214                 $msg =~ s/^[-\w]+\|//;
 215                 #               _sendf('Y', $main::mycall, $conn->{call}, $conn->{bpqstream}, $conn->{agwpid});
 216                 #               _sendf('D', $main::mycall, $conn->{bpqcall}, $conn->{bpqstream}, $conn->{agwpid}, $msg . $conn->{lineend});
 217
 218                 $msg = $msg . $conn->{lineend};
 219
 220                 my $len = length($msg);
 221                 $SendMsg->Call($conn->{bpqstream}, $msg, $len);
 222                 dbg("BPQ Data Out port: $conn->{bpqstream}   length: $len \"$msg\"") if isdbg('bpq');
 223         }
 224 }
 225
 226 sub process
 227 {
 228         return unless $enable && $Buffers;
 229
 230         my $state=0;
 231         my $change=0;
 232
 233         for (my $i = 1; $i <= $BPQStreams; $i++) {
 234                 $SessionState->Call($Stream[$i], $state, $change);
 235
 236                 if ($change) {
 237                         dbg("Stream $Stream[$i] newstate $state") if isdbg('bpq');
 238
 239                         if ($state == 0) {
 240                                 # Disconnected
 241
 242                                 my $conn = $circuit{$Stream[$i]};
 243
 244                                 if ($conn) {            # Active connection?
 245                                         &{$conn->{eproc}}() if $conn->{eproc};
 246                                         $conn->in_disconnect;
 247                                 }
 248
 249                         }
 250
 251                         if ($state) {
 252
 253                                 # Incoming call
 254
 255                                 my $call="            ";
 256
 257                                 $GetCallsign->Call($Stream[$i],$call);
 258
 259                                 for ($call) {   # trim whitespace in $variable, cheap
 260                                 s/^\s+//;
 261                                         s/\s+$//;
 262                                 }
 263
 264                                 dbg("BPQ Connect Stream $Stream[$i] $call") if isdbg('bpq');
 265
 266                                 my $conn =  $circuit{$Stream[$i]};;
 267
 268                                 if ($conn) {
 269
 270                                         # Connection already exists - if we are connecting out this is OK
 271
 272                                         if ($conn->{state} eq 'WC') {
 273                                                 $SendMsg->Call($Stream[$i], "?\r", 2); # Trigger response for chat script
 274                                         }
 275
 276                                         # Just ignore incomming connect if we think it is already connected
 277
 278                                 } else {
 279
 280                                         # New Incoming Connect
 281
 282                                         $conn = BPQMsg->new($rproc);
 283                                         $conn->{bpqstream} = $Stream[$i];
 284                                         $conn->{lineend} = "\cM";
 285                                         $conn->{incoming} = 1;
 286                                         $conn->{bpqcall} = $call;
 287                                         $circuit{$Stream[$i]} = $conn;
 288                                         if (my ($c, $s) = $call =~ /^(\w+)-(\d\d?)$/) {
 289                                                 $s = 15 - $s if $s > 8;
 290                                                 $call = $s > 0 ? "${c}-${s}" : $c;
 291                                         }
 292                                         $conn->to_connected($call, 'A', $conn->{csort} = 'ax25');
 293                                 }
 294
 295                         }
 296
 297                 }
 298
 299                 # See if data received
 300
 301                 my $cnt = $RXCount->Call($Stream[$i]);
 302
 303                 while ($cnt > 0) {
 304                         $cnt--;
 305
 306                         my $Buffer = " " x 340;
 307
 308                         my $len=0;
 309
 310                         $len=$GetMsg->Call($Stream[$i],$Buffer);
 311
 312                         $Buffer = substr($Buffer,0,$len);
 313
 314                         dbg ("BPQ RX: $Buffer") if isdbg('bpq');
 315
 316                         my $conn = $circuit{$Stream[$i]};
 317
 318                         if ($conn) {
 319
 320                                 dbg("BPQ State = $conn->{state}") if isdbg('bpq');
 321
 322                                 if ($conn->{state} eq 'WC') {
 323                                         if (exists $conn->{cmd}) {
 324                                                 if (@{$conn->{cmd}}) {
 325                                                         dbg($Buffer) if isdbg('connect');
 326                                                         $conn->_docmd($Buffer);
 327                                                 }
 328                                         }
 329                                         if ($conn->{state} eq 'WC' && exists $conn->{cmd} && @{$conn->{cmd}} == 0) {
 330                                                 $conn->to_connected($conn->{call}, 'O', $conn->{csort});
 331                                         }
 332                                 } else {
 333                                         my @lines = split /\cM\cJ?/, $Buffer;
 334                                         push @lines, $Buffer unless @lines;
 335                                         for (@lines) {
 336                                                 &{$conn->{rproc}}($conn, "I$conn->{call}|$_");
 337                                         }
 338                                 }
 339                         } else {
 340                                 dbg("BPQ error Unsolicited Data!");
 341                         }
 342                 }
 343         }
 344 }
 345
 346 1;
 347