]> scm.dxcluster.org Git - spider.git/blob - perl/BBS.pm
68bf4314b0af022a6f554ea26b03a05d8121b1ab
[spider.git] / 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         $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