From 6b19958cbe351af8d5462f4e0e03b87875eec16a Mon Sep 17 00:00:00 2001 From: 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