From 6b19958cbe351af8d5462f4e0e03b87875eec16a Mon Sep 17 00:00:00 2001
From: djk <djk>
Date: Sun, 14 Nov 1999 20:52:58 +0000
Subject: [PATCH] Added BBS.pm to start allowing BBSes to send mail into the
 cluster Made DXUser a bit more sanguine about corruption

---
 perl/BBS.pm       | 142 ++++++++++++++++++++++++++++++++++++++++++++++
 perl/DXChannel.pm |   7 +++
 perl/DXProt.pm    |   2 +-
 perl/DXUser.pm    |   5 +-
 perl/Messages     |   2 +-
 perl/Msg.pm       |   7 +++
 perl/cluster.pl   |   1 +
 7 files changed, 162 insertions(+), 4 deletions(-)
 create mode 100644 perl/BBS.pm

diff --git a/perl/BBS.pm b/perl/BBS.pm
new file mode 100644
index 00000000..e2920a47
--- /dev/null
+++ b/perl/BBS.pm
@@ -0,0 +1,142 @@
+#!/usr/bin/perl
+#
+# Sigh, I suppose it had to happen at some point...
+#
+# This is a simple BBS Forwarding module.
+#
+# Copyright (c) 1999 - Dirk Koopman G1TLH
+#
+# $Id$
+#
+
+package BBS;
+
+use strict;
+use DXUser;
+use DXChannel;
+use DB_File;
+use Carp;
+
+@ISA = qw(DXChannel);
+
+use vars qw (%bid $bidfn $lastbidclean $bidcleanint);
+
+%bid = ();						# the bid hash
+$bidfn = "$main::root/msg/bid";	# the bid file filename
+$lastbidclean = time;			# the last time the bid file was cleaned
+$bidcleanint = 86400;			# the time between bid cleaning intervals
+$maxbidage = 60;				# the maximum age of a stored bid
+
+sub init
+{
+	tie %hash, 'DB_File', $bidfn;
+}
+
+#
+# obtain a new connection this is derived from dxchannel
+#
+
+sub new 
+{
+	my $self = DXChannel::alloc(@_);
+	$self->{'sort'} = 'B';	
+	return $self;
+}
+
+#
+# start a new connection
+#
+sub start
+{
+	my ($self, $line, $sort) = @_;
+	my $call = $self->{call};
+	my $user = $self->{user};
+	
+	# remember type of connection
+	$self->{consort} = $line;
+	$self->{outbound} = $sort eq 'O';
+	$self->{priv} = $user->priv;
+	$self->{lang} = $user->lang;
+	$self->{isolate} = $user->{isolate};
+	$self->{consort} = $line;	# save the connection type
+	
+	# set unbuffered and no echo
+	$self->send_now('B',"0");
+	$self->send_now('E',"0");
+	
+	# send initialisation string
+    $self->send("[SDX-$main::version-H\$]");
+	$self->prompt;
+	$self->state('prompt');
+
+	Log('BBS', "$call", "connected");
+}
+
+#
+# send a prompt
+#
+
+sub prompt
+{
+	my $self = shift;
+	$self->send("$main::mycall>");
+}
+
+#
+# normal processing
+#
+
+sub normal
+{
+	my ($self, $line) = @_;
+
+    my ($com, $rest) = split /\s+/, $line, 2;
+	$com = uc $com;
+	if ($com =~ /^S/) {
+        my ($to, $at, $from) = $rest =~ /^(\w+)\s*\@\s*([\#\w\.]+)\s*<\s*(\w+)/;
+		my ($bid) = $rest =~ /\$(\S+)$/;
+		my ($justat, $haddr) = $at =~ /^(\w+)\.(.*)$/;
+		$justat = $at unless $justat;
+		unless ($to) {
+			$self->send('N - no "to" address');
+			return;
+		}
+		unless ($from) {
+			$self->send('N - no "from" address');
+			return;
+		}
+
+		# now handle the different types of send
+		if ($com eq 'SB') {
+			if ($to =~ /^ALL/) {
+				$self->send('N - "ALL" not allowed');
+				return;
+			}
+		} else {
+		}
+    } elsif ($com =~ /^F/) {
+		$self->disconnect;
+	} elsif ($com =~ /^(B|Q)) {
+		$self->disconnect;
+	}
+}
+
+#
+# end a connection (called by disconnect)
+#
+sub finish
+{
+	my $self = shift;
+	my $call = $self->call;
+	Log('BBS', "$call", "disconnected");
+}
+
+# 
+# process (periodic processing)
+#
+
+sub process
+{
+
+}
+
diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm
index 3ccadeaf..eafa76ad 100644
--- a/perl/DXChannel.pm
+++ b/perl/DXChannel.pm
@@ -165,6 +165,13 @@ sub del
 	delete $channels{$self->{call}};
 }
 
+# is it a bbs
+sub is_bbs
+{
+	my $self = shift;
+	return $self->{sort} eq 'B';
+}
+
 # is it an ak1a cluster ?
 sub is_ak1a
 {
diff --git a/perl/DXProt.pm b/perl/DXProt.pm
index d9b03a90..d467a5d5 100644
--- a/perl/DXProt.pm
+++ b/perl/DXProt.pm
@@ -516,7 +516,7 @@ sub normal
 				dbg('chan', "Dup WWV Spot ignored\n");
 				return;
 			}
-			if (($pcno == 23 && $d < $main::systime - $pc23_max_age) || $d > $main::systime + 900 || $field[2] < 0 || $field[2] > 23) {
+			if (($pcno == 23 && $d < $main::systime - $pc23_max_age) || $d > $main::systime + 1500 || $field[2] < 0 || $field[2] > 23) {
 				dbg('chan', "WWV Date ($field[1] $field[2]) out of range");
 				return;
 			}
diff --git a/perl/DXUser.pm b/perl/DXUser.pm
index a8fb7788..554a9930 100644
--- a/perl/DXUser.pm
+++ b/perl/DXUser.pm
@@ -216,8 +216,9 @@ sub decode
 	my $s = shift;
 	my $ref;
 	$s = '$ref = ' . $s;
-	eval $s;
-	confess $@ if $@;
+	eval { $s; };
+	Log('DXUser', $@) if $@;
+	$ref = undef if $@;
 	return $ref;
 }
 
diff --git a/perl/Messages b/perl/Messages
index 8e40b82c..0fa9f109 100644
--- a/perl/Messages
+++ b/perl/Messages
@@ -82,7 +82,7 @@ package DXM;
 				lockout => '$_[0] Locked out',
 				lockoutc => '$_[0] Created and Locked out',
 				lockoutun => '$_[0] Unlocked',
-				m1 => 'Enter Subject (30 characters) >',
+				m1 => 'Enter Subject (30 characters):',
 				m2 => 'Copy of msg $_[0] sent to $_[1]',
 				m3 => 'Sorry, $_[0] is an unacceptable TO address',
 				m4 => 'Sorry, can\'t access message $_[0]',
diff --git a/perl/Msg.pm b/perl/Msg.pm
index aaa38b53..e1ece5b9 100644
--- a/perl/Msg.pm
+++ b/perl/Msg.pm
@@ -278,6 +278,13 @@ sub _new_client {
     }
 }
 
+sub close_server
+{
+	set_event_handler ($main_socket, "read" => undef);
+	$main_socket->close;
+	$main_socket = 0;
+}
+
 #----------------------------------------------------
 # Event loop routines used by both client and server
 
diff --git a/perl/cluster.pl b/perl/cluster.pl
index 36c2f8bd..0ed98e55 100755
--- a/perl/cluster.pl
+++ b/perl/cluster.pl
@@ -148,6 +148,7 @@ sub rec
 		# create the channel
 		$dxchan = DXCommandmode->new($call, $conn, $user) if ($user->sort eq 'U');
 		$dxchan = DXProt->new($call, $conn, $user) if ($user->sort eq 'A');
+		$dxchan = BBS->new($call, $conn, $user) if ($user->sort eq 'B');
 		die "Invalid sort of user on $call = $sort" if !$dxchan;
 	}
 	
-- 
2.43.0