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