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 sub peerhost
 138 {
 139         my $conn = shift;
 140         $conn->{peerhost} ||= 'ax25';
 141         return $conn->{peerhost};
 142 }
 143
 144
 145 sub connect
 146 {
 147
 148         return unless $Buffers;
 149
 150         my ($conn, $line) = @_;
 151         my ($port, $call) = split /\s+/, $line;
 152
 153
 154         dbg("BPQ Outgoing Connect  $conn $port $call") if isdbg('bpq');
 155
 156
 157         for (my $i = $BPQStreams; $i > 0; $i--) {
 158                 my $inuse = $circuit{$Stream[$i]};
 159
 160                 if (not $inuse) {               # Active connection?
 161
 162                         dbg("BPQ Outgoing Connect using stream $i") if isdbg('bpq');
 163
 164                         $conn->{bpqstream} = $Stream[$i];
 165                         $conn->{lineend} = "\cM";
 166                         $conn->{incoming} = 0;
 167                         $conn->{csort} = 'ax25';
 168                         $conn->{bpqcall} = uc $call;
 169                         $circuit{$Stream[$i]} = $conn;
 170
 171                         $SessionControl->Call($Stream[$i], 1, 0); # Connect
 172
 173                         $conn->{state} = 'WC';
 174
 175                         return 1;
 176
 177                 }
 178
 179         }
 180
 181         # No free streams
 182         dbg("BPQ Outgoing Connect - No streams available") if isdbg('bpq');
 183
 184         $conn->{bpqstream} = 0;         # So we can tidy up
 185         $circuit{0} = $conn;
 186         return 0;
 187 }
 188
 189 sub in_disconnect
 190 {
 191         my $conn = shift;
 192         dbg( "in_disconnect $conn $circuit{$conn->{bpqstream}}") if isdbg('bpq');
 193         delete $circuit{$conn->{bpqstream}};
 194         $conn->SUPER::disconnect;
 195 }
 196
 197 sub disconnect
 198 {
 199
 200         return unless $enable && $Buffers;
 201
 202         my $conn = shift;
 203
 204         delete $circuit{$conn->{bpqstream}};
 205
 206         $conn->SUPER::disconnect;
 207
 208         if ($conn->{bpqstream}) {       # not if stream = 0!
 209                 $SessionControl->Call($conn->{bpqstream}, 2, 0); # Disconnect
 210         }
 211 }
 212
 213 sub enqueue
 214 {
 215
 216         return unless $Buffers;
 217
 218         my ($conn, $msg) = @_;
 219
 220         if ($msg =~ /^D/) {
 221                 $msg =~ s/^[-\w]+\|//;
 222                 #               _sendf('Y', $main::mycall, $conn->{call}, $conn->{bpqstream}, $conn->{agwpid});
 223                 #               _sendf('D', $main::mycall, $conn->{bpqcall}, $conn->{bpqstream}, $conn->{agwpid}, $msg . $conn->{lineend});
 224
 225                 $msg = $msg . $conn->{lineend};
 226
 227                 my $len = length($msg);
 228                 $SendMsg->Call($conn->{bpqstream}, $msg, $len);
 229                 dbg("BPQ Data Out port: $conn->{bpqstream}   length: $len \"$msg\"") if isdbg('bpq');
 230         }
 231 }
 232
 233 sub process
 234 {
 235         return unless $enable && $Buffers;
 236
 237         my $state=0;
 238         my $change=0;
 239
 240         for (my $i = 1; $i <= $BPQStreams; $i++) {
 241                 $SessionState->Call($Stream[$i], $state, $change);
 242
 243                 if ($change) {
 244                         dbg("Stream $Stream[$i] newstate $state") if isdbg('bpq');
 245
 246                         if ($state == 0) {
 247                                 # Disconnected
 248
 249                                 my $conn = $circuit{$Stream[$i]};
 250
 251                                 if ($conn) {            # Active connection?
 252                                         &{$conn->{eproc}}() if $conn->{eproc};
 253                                         $conn->in_disconnect;
 254                                 }
 255
 256                         }
 257
 258                         if ($state) {
 259
 260                                 # Incoming call
 261
 262                                 my $call="            ";
 263
 264                                 $GetCallsign->Call($Stream[$i],$call);
 265
 266                                 for ($call) {   # trim whitespace in $variable, cheap
 267                                 s/^\s+//;
 268                                         s/\s+$//;
 269                                 }
 270
 271                                 dbg("BPQ Connect Stream $Stream[$i] $call") if isdbg('bpq');
 272
 273                                 my $conn =  $circuit{$Stream[$i]};;
 274
 275                                 if ($conn) {
 276
 277                                         # Connection already exists - if we are connecting out this is OK
 278
 279                                         if ($conn->{state} eq 'WC') {
 280                                                 $SendMsg->Call($Stream[$i], "?\r", 2); # Trigger response for chat script
 281                                         }
 282
 283                                         # Just ignore incomming connect if we think it is already connected
 284
 285                                 } else {
 286
 287                                         # New Incoming Connect
 288
 289                                         $conn = BPQMsg->new($rproc);
 290                                         $conn->{bpqstream} = $Stream[$i];
 291                                         $conn->{lineend} = "\cM";
 292                                         $conn->{incoming} = 1;
 293                                         $conn->{bpqcall} = $call;
 294                                         $circuit{$Stream[$i]} = $conn;
 295                                         if (my ($c, $s) = $call =~ /^(\w+)-(\d\d?)$/) {
 296                                                 $s = 15 - $s if $s > 8;
 297                                                 $call = $s > 0 ? "${c}-${s}" : $c;
 298                                         }
 299                                         $conn->to_connected($call, 'A', $conn->{csort} = 'ax25');
 300                                 }
 301
 302                         }
 303
 304                 }
 305
 306                 # See if data received
 307
 308                 my $cnt = $RXCount->Call($Stream[$i]);
 309
 310                 while ($cnt > 0) {
 311                         $cnt--;
 312
 313                         my $Buffer = " " x 340;
 314
 315                         my $len=0;
 316
 317                         $len=$GetMsg->Call($Stream[$i],$Buffer);
 318
 319                         $Buffer = substr($Buffer,0,$len);
 320
 321                         dbg ("BPQ RX: $Buffer") if isdbg('bpq');
 322
 323                         my $conn = $circuit{$Stream[$i]};
 324
 325                         if ($conn) {
 326
 327                                 dbg("BPQ State = $conn->{state}") if isdbg('bpq');
 328
 329                                 if ($conn->{state} eq 'WC') {
 330                                         if (exists $conn->{cmd}) {
 331                                                 if (@{$conn->{cmd}}) {
 332                                                         dbg($Buffer) if isdbg('connect');
 333                                                         $conn->_docmd($Buffer);
 334                                                 }
 335                                         }
 336                                         if ($conn->{state} eq 'WC' && exists $conn->{cmd} && @{$conn->{cmd}} == 0) {
 337                                                 $conn->to_connected($conn->{call}, 'O', $conn->{csort});
 338                                         }
 339                                 } else {
 340                                         my @lines = split /\cM\cJ?/, $Buffer;
 341                                         push @lines, $Buffer unless @lines;
 342                                         for (@lines) {
 343                                                 &{$conn->{rproc}}($conn, "I$conn->{call}|$_");
 344                                         }
 345                                 }
 346                         } else {
 347                                 dbg("BPQ error Unsolicited Data!");
 348                         }
 349                 }
 350         }
 351 }
 352
 353 1;
 354