perl/BBS.pm

   1 #!/usr/bin/perl
   2 #
   3 # Sigh, I suppose it had to happen at some point...
   4 #
   5 # This is a simple BBS Forwarding module.
   6 #
   7 # Copyright (c) 1999 - Dirk Koopman G1TLH
   8 #
   9 # $Id$
  10 #
  11
  12 package BBS;
  13
  14 use strict;
  15 use DXUser;
  16 use DXChannel;
  17 use DB_File;
  18 use DXDebug;
  19
  20 @ISA = qw(DXChannel);
  21
  22 use vars qw (%bid $bidfn $lastbidclean $bidcleanint);
  23
  24 %bid = ();                                              # the bid hash
  25 $bidfn = "$main::root/msg/bid"; # the bid file filename
  26 $lastbidclean = time;                   # the last time the bid file was cleaned
  27 $bidcleanint = 86400;                   # the time between bid cleaning intervals
  28 $maxbidage = 60;                                # the maximum age of a stored bid
  29
  30 sub init
  31 {
  32         tie %hash, 'DB_File', $bidfn;
  33 }
  34
  35 #
  36 # obtain a new connection this is derived from dxchannel
  37 #
  38
  39 sub new
  40 {
  41         my $self = DXChannel::alloc(@_);
  42         return $self;
  43 }
  44
  45 #
  46 # start a new connection
  47 #
  48 sub start
  49 {
  50         my ($self, $line, $sort) = @_;
  51         my $call = $self->{call};
  52         my $user = $self->{user};
  53
  54         # remember type of connection
  55         $self->{consort} = $line;
  56         $self->{outbound} = $sort eq 'O';
  57         $self->{priv} = $user->priv;
  58         $self->{lang} = $user->lang;
  59         $self->{isolate} = $user->{isolate};
  60         $self->{consort} = $line;       # save the connection type
  61
  62         # set unbuffered and no echo
  63         $self->send_now('B',"0");
  64         $self->send_now('E',"0");
  65
  66         # send initialisation string
  67     $self->send("[SDX-$main::version-H\$]");
  68         $self->prompt;
  69         $self->state('prompt');
  70
  71         Log('BBS', "$call", "connected");
  72 }
  73
  74 #
  75 # send a prompt
  76 #
  77
  78 sub prompt
  79 {
  80         my $self = shift;
  81         $self->send("$main::mycall>");
  82 }
  83
  84 #
  85 # normal processing
  86 #
  87
  88 sub normal
  89 {
  90         my ($self, $line) = @_;
  91
  92     my ($com, $rest) = split /\s+/, $line, 2;
  93         $com = uc $com;
  94         if ($com =~ /^S/) {
  95         my ($to, $at, $from) = $rest =~ /^(\w+)\s*\@\s*([\#\w\.]+)\s*<\s*(\w+)/;
  96                 my ($bid) = $rest =~ /\$(\S+)$/;
  97                 my ($justat, $haddr) = $at =~ /^(\w+)\.(.*)$/;
  98                 $justat = $at unless $justat;
  99                 unless ($to) {
 100                         $self->send('N - no "to" address');
 101                         return;
 102                 }
 103                 unless ($from) {
 104                         $self->send('N - no "from" address');
 105                         return;
 106                 }
 107
 108                 # now handle the different types of send
 109                 if ($com eq 'SB') {
 110                         if ($to =~ /^ALL/) {
 111                                 $self->send('N - "ALL" not allowed');
 112                                 return;
 113                         }
 114                 } else {
 115                 }
 116     } elsif ($com =~ /^F/) {
 117                 $self->disconnect;
 118         } elsif ($com =~ /^(B|Q)) {
 119                 $self->disconnect;
 120         }
 121 }
 122
 123 #
 124 # end a connection (called by disconnect)
 125 #
 126 sub disconnect
 127 {
 128         my $self = shift;
 129         my $call = $self->call;
 130         Log('BBS', "$call", "disconnected");
 131         $self->SUPER::disconnect;
 132 }
 133
 134 #
 135 # process (periodic processing)
 136 #
 137
 138 sub process
 139 {
 140
 141 }
 142