Added BBS.pm to start allowing BBSes to send mail into the cluster

Made DXUser a bit more sanguine about corruption

diff --git a/perl/BBS.pm b/perl/BBS.pm
new file mode 100644 (file)
index 0000000..e2920a4
--- /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 3ccadeaf426e0864d355a76d095faa36d8ad54f8..eafa76ad527083212ee0d8a31c12485e23f01dc4 100644 (file)
--- 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 d9b03a907d1768420574dcb9ffb51e19266cc983..d467a5d5b7866880ce5886a4449ea3d33f36d46a 100644 (file)
--- 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 a8fb7788c2e5406081f190c600970479c0a0b68b..554a9930cdfc35ee6174c18a9893774fdd827cd7 100644 (file)
--- 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 8e40b82ceeda1a7d82bd6ac418b8e502443ca549..0fa9f109c28608908bed33f500794f2d8d680d4b 100644 (file)
--- 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 aaa38b533b47397ac40193c82fe771872e52d7d7..e1ece5b93c35e932e118308785b6d8d7ca3e478f 100644 (file)
--- 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 36c2f8bd027005b8ae6a16db4cfba6fe5d1e2477..0ed98e55b39ddd33926ec6dbcd8e3aa670b080f2 100755 (executable)
--- 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;
        }