]> scm.dxcluster.org Git - spider.git/blob - perl/BBS.pm
move ::process things back into persec
[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 #
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