From a90885c5c10b837b05ef1ebf718fd88e428a3c91 Mon Sep 17 00:00:00 2001 From: Dirk Koopman Date: Tue, 5 Feb 2008 00:28:54 +0000 Subject: [PATCH] added Windows only BPQ interface from John G8BPQ --- cmd/show/connect.pl | 4 +- perl/BPQConnect.pm | 27 ++++ perl/BPQMsg.pm | 347 ++++++++++++++++++++++++++++++++++++++++++++ perl/ExtMsg.pm | 11 +- perl/Version.pm | 2 +- perl/cluster.pl | 6 + 6 files changed, 393 insertions(+), 4 deletions(-) create mode 100644 perl/BPQConnect.pm create mode 100644 perl/BPQMsg.pm diff --git a/cmd/show/connect.pl b/cmd/show/connect.pl index 77598be4..4644d5c9 100644 --- a/cmd/show/connect.pl +++ b/cmd/show/connect.pl @@ -3,7 +3,7 @@ # # Copyright (c) 2001 Dirk Koopman G1TLH # -# +# $Id$ # my $self = shift; @@ -23,6 +23,8 @@ foreach my $call (sort keys %Msg::conns) { $c = "Server"; } else { $addr = "AGW Port ($r->{agwport})" if exists $r->{agwport}; + $addr = "BPQ Stream ($r->{bpqstream})" if exists $r->{bpqstream}; + $addr ||= "$r->{peerhost}/$r->{peerport}"; $addr ||= "Unknown"; } diff --git a/perl/BPQConnect.pm b/perl/BPQConnect.pm new file mode 100644 index 00000000..86dd46b0 --- /dev/null +++ b/perl/BPQConnect.pm @@ -0,0 +1,27 @@ +# +# Copy this file to /spider/local and modify it to your requirements +# +# +# This file specifies whether you want to connect to a BPQ32 Switch +# You are only likely to want to do this in a Microsoft Windows +# environment +# + +package BPQMsg; + +use strict; +use vars qw($enable $ApplMask $BPQStreams); + +# set this to 1 to enable BPQ handling + +$enable = 0; + +# Applmask is normally 1, unless you are already running another BPQ app such as a BBS + +$ApplMask = 1; + +# Streams to allocate - used both for incomming and outgoing connects + +$BPQStreams = 10; + +1; diff --git a/perl/BPQMsg.pm b/perl/BPQMsg.pm new file mode 100644 index 00000000..e5ca7077 --- /dev/null +++ b/perl/BPQMsg.pm @@ -0,0 +1,347 @@ +# +# This class is the internal subclass that deals with the G8BPQ switch connections +# +# Written by John Wiseman G8BPQ Jan 2006 +# +# Based on AGWMsg.pm Copyright (c) 2001 - Dirk Koopman G1TLH +# + +package BPQMsg; + +use strict; +use Msg; +use BPQConnect; +use DXDebug; + +use vars qw(@ISA @outqueue $send_offset $inmsg $rproc $noports + %circuit $total_in $total_out); + +@ISA = qw(Msg ExtMsg); +@outqueue = (); +$send_offset = 0; +$inmsg = ''; +$rproc = undef; +$noports = 0; +%circuit = (); +$total_in = $total_out = 0; + +my $GetFreeBuffs; +my $FindFreeStream; +my $SetAppl; +my $SessionState; +my $GetCallsign; +my $SendMsg; +my $GetMsg; +my $RXCount; +my $DeallocateStream; +my $SessionControl; + +my @Stream; + +my $Buffers; + +sub init +{ + return unless $enable; + + eval { + require Win32::API; + }; + if ($@) { + $enable = 0; + dbg("BPQWin disabled because Win32::API cannot be loaded"); + return; + } else { + Win32::API->import; + } + + $rproc = shift; + + dbg("BPQ initialising..."); + + $GetFreeBuffs = Win32::API->new("bpq32", "int _GetFreeBuffs\@0()"); + $FindFreeStream = Win32::API->new("bpq32", "int _FindFreeStream\@0()"); + $SetAppl = Win32::API->new("bpq32", "int _SetAppl\@12(int a, int b, int c)"); + $SessionState = Win32::API->new("bpq32", "DWORD _SessionState\@12(DWORD stream, LPDWORD state, LPDWORD change)"); + $GetCallsign = new Win32::API("bpq32", "_GetCallsign\@8",'NP','N'); + $SendMsg = new Win32::API("bpq32","_SendMsg\@12",'NPN','N'); + $RXCount = new Win32::API("bpq32","_RXCount\@4",'N','N'); + $GetMsg = Win32::API->new("bpq32","_GetMsgPerl\@8",'NP','N'); + + $DeallocateStream = Win32::API->new("bpq32","_DeallocateStream\@4",'N','N'); + $SessionControl = Win32::API->new("bpq32", "int _SessionControl\@12(int a, int b, int c)"); + + if (!defined $GetMsg) { + $GetMsg = Win32::API->new("bpqperl","_GetMsgPerl\@8",'NP','N'); + } + + if (!defined $GetMsg) { + dbg ("Can't find routine 'GetMsgPerl' - is bpqperl.dll available?"); + } + + $Buffers = 0; + + if (defined $GetFreeBuffs && defined $GetMsg) { + my $s; + + $Buffers = $GetFreeBuffs->Call(); + + dbg("G8BPQ Free Buffers = $Buffers") if isdbg('bpq'); + + $s = "BPQ Streams:"; + + for (my $i = 1; $i <= $BPQStreams; $i++) { + + $Stream[$i] = $FindFreeStream->Call(); + + $s .= " $Stream[$i]"; + + $SetAppl->Call($Stream[$i], 0, $ApplMask); + + } + + dbg($s) if isdbg('bpq'); + } else { + + dbg("Couldn't initialise BPQ32 switch, BPQ disabled"); + $enable = 0; + } +} + +sub finish +{ + return unless $enable; + + dbg("BPQ Closing..") if isdbg('bpq'); + + return unless $Buffers; + + for (my $i = 1; $i <= $BPQStreams; $i++) { + $SetAppl->Call($Stream[$i], 0, 0); + $SessionControl->Call($Stream[$i], 2, 0); # Disconnect + $DeallocateStream->Call($Stream[$i]); + } +} + +sub login +{ + goto &main::login; # save some writing, this was the default +} + +sub active +{ + dbg("BPQ is active called") if isdbg('bpq'); + return $Buffers; +} + + +sub connect +{ + + return unless $Buffers; + + my ($conn, $line) = @_; + my ($port, $call) = split /\s+/, $line; + + + dbg("BPQ Outgoing Connect $conn $port $call") if isdbg('bpq'); + + + for (my $i = $BPQStreams; $i > 0; $i--) { + my $inuse = $circuit{$Stream[$i]}; + + if (not $inuse) { # Active connection? + + dbg("BPQ Outgoing Connect using stream $i") if isdbg('bpq'); + + $conn->{bpqstream} = $Stream[$i]; + $conn->{lineend} = "\cM"; + $conn->{incoming} = 0; + $conn->{csort} = 'ax25'; + $conn->{bpqcall} = uc $call; + $circuit{$Stream[$i]} = $conn; + + $SessionControl->Call($Stream[$i], 1, 0); # Connect + + $conn->{state} = 'WC'; + + return 1; + + } + + } + + # No free streams + dbg("BPQ Outgoing Connect - No streams available") if isdbg('bpq'); + + $conn->{bpqstream} = 0; # So we can tidy up + $circuit{0} = $conn; + return 0; +} + +sub in_disconnect +{ + my $conn = shift; + dbg( "in_disconnect $conn $circuit{$conn->{bpqstream}}") if isdbg('bpq'); + delete $circuit{$conn->{bpqstream}}; + $conn->SUPER::disconnect; +} + +sub disconnect +{ + + return unless $enable && $Buffers; + + my $conn = shift; + + delete $circuit{$conn->{bpqstream}}; + + $conn->SUPER::disconnect; + + if ($conn->{bpqstream}) { # not if stream = 0! + $SessionControl->Call($conn->{bpqstream}, 2, 0); # Disconnect + } +} + +sub enqueue +{ + + return unless $Buffers; + + my ($conn, $msg) = @_; + + if ($msg =~ /^D/) { + $msg =~ s/^[-\w]+\|//; + # _sendf('Y', $main::mycall, $conn->{call}, $conn->{bpqstream}, $conn->{agwpid}); + # _sendf('D', $main::mycall, $conn->{bpqcall}, $conn->{bpqstream}, $conn->{agwpid}, $msg . $conn->{lineend}); + + $msg = $msg . $conn->{lineend}; + + my $len = length($msg); + $SendMsg->Call($conn->{bpqstream}, $msg, $len); + dbg("BPQ Data Out port: $conn->{bpqstream} length: $len \"$msg\"") if isdbg('bpq'); + } +} + +sub process +{ + return unless $enable && $Buffers; + + my $state=0; + my $change=0; + + for (my $i = 1; $i <= $BPQStreams; $i++) { + $SessionState->Call($Stream[$i], $state, $change); + + if ($change) { + dbg("Stream $Stream[$i] newstate $state") if isdbg('bpq'); + + if ($state == 0) { + # Disconnected + + my $conn = $circuit{$Stream[$i]}; + + if ($conn) { # Active connection? + &{$conn->{eproc}}() if $conn->{eproc}; + $conn->in_disconnect; + } + + } + + if ($state) { + + # Incoming call + + my $call=" "; + + $GetCallsign->Call($Stream[$i],$call); + + for ($call) { # trim whitespace in $variable, cheap + s/^\s+//; + s/\s+$//; + } + + dbg("BPQ Connect Stream $Stream[$i] $call") if isdbg('bpq'); + + my $conn = $circuit{$Stream[$i]};; + + if ($conn) { + + # Connection already exists - if we are connecting out this is OK + + if ($conn->{state} eq 'WC') { + $SendMsg->Call($Stream[$i], "?\r", 2); # Trigger response for chat script + } + + # Just ignore incomming connect if we think it is already connected + + } else { + + # New Incoming Connect + + $conn = BPQMsg->new($rproc); + $conn->{bpqstream} = $Stream[$i]; + $conn->{lineend} = "\cM"; + $conn->{incoming} = 1; + $conn->{bpqcall} = $call; + $circuit{$Stream[$i]} = $conn; + if (my ($c, $s) = $call =~ /^(\w+)-(\d\d?)$/) { + $s = 15 - $s if $s > 8; + $call = $s > 0 ? "${c}-${s}" : $c; + } + $conn->to_connected($call, 'A', $conn->{csort} = 'ax25'); + } + + } + + } + + # See if data received + + my $cnt = $RXCount->Call($Stream[$i]); + + while ($cnt > 0) { + $cnt--; + + my $Buffer = " " x 340; + + my $len=0; + + $len=$GetMsg->Call($Stream[$i],$Buffer); + + $Buffer = substr($Buffer,0,$len); + + dbg ("BPQ RX: $Buffer") if isdbg('bpq'); + + my $conn = $circuit{$Stream[$i]}; + + if ($conn) { + + dbg("BPQ State = $conn->{state}") if isdbg('bpq'); + + if ($conn->{state} eq 'WC') { + if (exists $conn->{cmd}) { + if (@{$conn->{cmd}}) { + dbg($Buffer) if isdbg('connect'); + $conn->_docmd($Buffer); + } + } + if ($conn->{state} eq 'WC' && exists $conn->{cmd} && @{$conn->{cmd}} == 0) { + $conn->to_connected($conn->{call}, 'O', $conn->{csort}); + } + } else { + my @lines = split /\cM\cJ?/, $Buffer; + push @lines, $Buffer unless @lines; + for (@lines) { + &{$conn->{rproc}}($conn, "I$conn->{call}|$_"); + } + } + } else { + dbg("BPQ error Unsolicited Data!"); + } + } + } +} + +1; + diff --git a/perl/ExtMsg.pm b/perl/ExtMsg.pm index 1f543fc0..15f875a7 100644 --- a/perl/ExtMsg.pm +++ b/perl/ExtMsg.pm @@ -5,10 +5,13 @@ # This is where the cluster handles direct connections coming both in # and out # -# +# $Id$ # # Copyright (c) 2001 - Dirk Koopman G1TLH # +# Modified Jan 2006 by John Wiseman G8BPQ to support connections to BPQ32 node, +# and fix pattern matching on 'chat' abort handling +# package ExtMsg; @@ -270,6 +273,10 @@ sub _doconnect # turn it into an AGW object bless $conn, 'AGWMsg'; $r = $conn->connect($line); + } elsif ($sort eq 'bpq') { + # turn it into an BPQ object + bless $conn, 'BPQMsg'; + $r = $conn->connect($line); } elsif ($sort eq 'ax25' || $sort eq 'prog') { $r = $conn->start_program($line, $sort); } else { @@ -318,7 +325,7 @@ sub _dochat if ($line) { if ($expect) { dbg("connect $conn->{cnum}: expecting: \"$expect\" received: \"$line\"") if isdbg('connect'); - if ($conn->{abort} && $line =~ /\Q$conn->{abort}/i) { + if ($conn->{abort} && $line =~ /$conn->{abort}/i) { dbg("connect $conn->{cnum}: aborted on /$conn->{abort}/") if isdbg('connect'); $conn->disconnect; delete $conn->{cmd}; diff --git a/perl/Version.pm b/perl/Version.pm index 03598dd4..fc713ecf 100644 --- a/perl/Version.pm +++ b/perl/Version.pm @@ -11,6 +11,6 @@ use vars qw($version $subversion $build); $version = '1.54'; $subversion = '0'; -$build = '199'; +$build = '200'; 1; diff --git a/perl/cluster.pl b/perl/cluster.pl index 620c7e77..0fe3b575 100755 --- a/perl/cluster.pl +++ b/perl/cluster.pl @@ -102,6 +102,7 @@ use RouteDB; use DXXml; use DXSql; use IsoTime; +use BPQMsg; use Data::Dumper; use IO::File; @@ -260,6 +261,7 @@ sub cease # disconnect AGW AGWMsg::finish(); + BPQMsg::finish(); # disconnect UDP customers UDPMsg::finish(); @@ -411,6 +413,9 @@ foreach my $l (@main::listen) { dbg("AGW Listener") if $AGWMsg::enable; AGWrestart(); +dbg("BPQ Listener") if $BPQMsg::enable; +BPQMsg::init(\&new_channel); + dbg("UDP Listener") if $UDPMsg::enable; UDPMsg::init(\&new_channel); @@ -538,6 +543,7 @@ for (;;) { DXUser::process(); DXDupe::process(); AGWMsg::process(); + BPQMsg::process(); if (defined &Local::process) { eval { -- 2.34.1