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 Carp;
  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         $self->{'sort'} = 'B';
  43         return $self;
  44 }
  45
  46 #
  47 # start a new connection
  48 #
  49 sub start
  50 {
  51         my ($self, $line, $sort) = @_;
  52         my $call = $self->{call};
  53         my $user = $self->{user};
  54
  55         # remember type of connection
  56         $self->{consort} = $line;
  57         $self->{outbound} = $sort eq 'O';
  58         $self->{priv} = $user->priv;
  59         $self->{lang} = $user->lang;
  60         $self->{isolate} = $user->{isolate};
  61         $self->{consort} = $line;       # save the connection type
  62
  63         # set unbuffered and no echo
  64         $self->send_now('B',"0");
  65         $self->send_now('E',"0");
  66
  67         # send initialisation string
  68     $self->send("[SDX-$main::version-H\$]");
  69         $self->prompt;
  70         $self->state('prompt');
  71
  72         Log('BBS', "$call", "connected");
  73 }
  74
  75 #
  76 # send a prompt
  77 #
  78
  79 sub prompt
  80 {
  81         my $self = shift;
  82         $self->send("$main::mycall>");
  83 }
  84
  85 #
  86 # normal processing
  87 #
  88
  89 sub normal
  90 {
  91         my ($self, $line) = @_;
  92
  93     my ($com, $rest) = split /\s+/, $line, 2;
  94         $com = uc $com;
  95         if ($com =~ /^S/) {
  96         my ($to, $at, $from) = $rest =~ /^(\w+)\s*\@\s*([\#\w\.]+)\s*<\s*(\w+)/;
  97                 my ($bid) = $rest =~ /\$(\S+)$/;
  98                 my ($justat, $haddr) = $at =~ /^(\w+)\.(.*)$/;
  99                 $justat = $at unless $justat;
 100                 unless ($to) {
 101                         $self->send('N - no "to" address');
 102                         return;
 103                 }
 104                 unless ($from) {
 105                         $self->send('N - no "from" address');
 106                         return;
 107                 }
 108
 109                 # now handle the different types of send
 110                 if ($com eq 'SB') {
 111                         if ($to =~ /^ALL/) {
 112                                 $self->send('N - "ALL" not allowed');
 113                                 return;
 114                         }
 115                 } else {
 116                 }
 117     } elsif ($com =~ /^F/) {
 118                 $self->disconnect;
 119         } elsif ($com =~ /^(B|Q)) {
 120                 $self->disconnect;
 121         }
 122 }
 123
 124 #
 125 # end a connection (called by disconnect)
 126 #
 127 sub finish
 128 {
 129         my $self = shift;
 130         my $call = $self->call;
 131         Log('BBS', "$call", "disconnected");
 132 }
 133
 134 #
 135 # process (periodic processing)
 136 #
 137
 138 sub process
 139 {
 140
 141 }
 142