]> dxcluster.org Git - spider.git/blob - perl/DXMsg.pm
04ef99cb8ecffccfb21d7215b590a886497d2a8d
[spider.git] / perl / DXMsg.pm
1 #!/usr/bin/perl
2 #
3 # This module impliments the message handling for a dx cluster
4 #
5 # Copyright (c) 1998 Dirk Koopman G1TLH
6 #
7 # $Id$
8 #
9 #
10 # Notes for implementors:-
11 #
12 # PC28 field 11 is the RR required flag
13 # PC28 field 12 is a VIA routing (ie it is a node call) 
14 #
15
16 package DXMsg;
17
18 use DXUtil;
19 use DXChannel;
20 use DXUser;
21 use DXM;
22 use DXProtVars;
23 use DXProtout;
24 use DXDebug;
25 use DXLog;
26 use IO::File;
27 use Fcntl;
28
29 eval {
30         require Net::SMTP;
31 };
32
33 use strict;
34
35 use vars qw($VERSION $BRANCH);
36 $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
37 $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/  || (0,0));
38 $main::build += $VERSION;
39 $main::branch += $BRANCH;
40
41 use vars qw(%work @msg $msgdir %valid %busy $maxage $last_clean $residencetime
42                         @badmsg @swop $swopfn $badmsgfn $forwardfn @forward $timeout $waittime
43                         $email_server $email_prog $email_from
44                     $queueinterval $lastq $importfn $minchunk $maxchunk $bulltopriv);
45
46 %work = ();                                             # outstanding jobs
47 @msg = ();                                              # messages we have
48 %busy = ();                                             # station interlocks
49 $msgdir = "$main::root/msg";    # directory contain the msgs
50 $maxage = 30 * 86400;                   # the maximum age that a message shall live for if not marked 
51 $last_clean = 0;                                # last time we did a clean
52 @forward = ();                  # msg forward table
53 @badmsg = ();                                   # bad message table
54 @swop = ();                                             # swop table
55 $timeout = 30*60;               # forwarding timeout
56 $waittime = 30*60;              # time an aborted outgoing message waits before trying again
57 $queueinterval = 1*60;          # run the queue every 1 minute
58 $lastq = 0;
59
60 $minchunk = 4800;               # minimum chunk size for a split message
61 $maxchunk = 6000;               # maximum chunk size
62 $bulltopriv = 1;                                # convert msgs with callsigns to private if they are bulls
63 $residencetime = 2*86400;       # keep deleted messages for this amount of time
64 $email_server = undef;                  # DNS address of smtp server if 'smtp'
65 $email_prog = undef;                    # program name + args for sending mail
66 $email_from = undef;                    # the from address the email will appear to be from
67
68 $badmsgfn = "$msgdir/badmsg.pl";    # list of TO address we wont store
69 $forwardfn = "$msgdir/forward.pl";  # the forwarding table
70 $swopfn = "$msgdir/swop.pl";        # the swopping table
71 $importfn = "$msgdir/import";       # import directory
72
73
74 %valid = (
75                   fromnode => '5,From Node',
76                   tonode => '5,To Node',
77                   to => '0,To',
78                   from => '0,From',
79                   t => '0,Msg Time,cldatetime',
80                   private => '5,Private,yesno',
81                   subject => '0,Subject',
82                   linesreq => '0,Lines per Gob',
83                   rrreq => '5,Read Confirm,yesno',
84                   origin => '0,Origin',
85                   lines => '5,Data',
86                   stream => '9,Stream No',
87                   count => '5,Gob Linecnt',
88                   file => '5,File?,yesno',
89                   gotit => '5,Got it Nodes,parray',
90                   lines => '5,Lines,parray',
91                   'read' => '5,Times read',
92                   size => '0,Size',
93                   msgno => '0,Msgno',
94                   keep => '0,Keep this?,yesno',
95                   lastt => '5,Last processed,cldatetime',
96                   waitt => '5,Wait until,cldatetime',
97                   delete => '5,Awaiting Delete,yesno',
98                   deletetime => '5,Deletion Time,cldatetime',
99                  );
100
101 # fix up the default sendmail if available
102 for (qw(/usr/sbin/sendmail /usr/lib/sendmail /usr/sbin/sendmail)) {
103         if (-e $_) {
104                 $email_prog = $_;
105                 last;
106         }
107 }
108
109 # allocate a new object
110 # called fromnode, tonode, from, to, datetime, private?, subject, nolinesper  
111 sub alloc                  
112 {
113         my $pkg = shift;
114         my $self = bless {}, $pkg;
115         $self->{msgno} = shift;
116         my $to = shift;
117         #  $to =~ s/-\d+$//o;
118         $self->{to} = ($to eq $main::mycall) ? $main::myalias : $to;
119         my $from = shift;
120         $self->{from} = uc $from;
121         $self->{t} = shift;
122         $self->{private} = shift;
123         $self->{subject} = shift;
124         $self->{origin} = shift;
125         $self->{'read'} = shift;
126         $self->{rrreq} = shift;
127         $self->{delete} = shift;
128         $self->{deletetime} = shift || ($self->{t} + $maxage);
129         $self->{keep} = shift;
130         $self->{gotit} = [];
131 #       $self->{lastt} = $main::systime;
132         $self->{lines} = [];
133         $self->{private} = 1 if $bulltopriv && DXUser->get_current($self->{to});
134     
135         return $self;
136 }
137
138
139 sub process
140 {
141         # this is periodic processing
142         if ($main::systime >= $lastq + $queueinterval) {
143
144                 # queue some message if the interval timer has gone off
145                 queue_msg(0);
146                 
147                 # import any messages in the import directory
148                 import_msgs();
149                 
150                 $lastq = $main::systime;
151         }
152
153         # clean the message queue
154         clean_old() if $main::systime - $last_clean > 3600 ;
155         
156         # actual remove all the 'deleted' messages in one hit.
157         # this has to be delayed until here otherwise it only does one at 
158         # a time because @msg is rewritten everytime del_msg is called.
159         my @del = grep {!$_->{tonode} && $_->{delete} && !$_->{keep} && $_->{deletetime} < $main::systime} @msg;
160         for (@del) {
161                 $_->del_msg;
162         }
163         
164         $last_clean = $main::systime;
165 }
166
167 # incoming message
168 sub handle_28
169 {
170         my $dxchan = shift;
171         my ($tonode, $fromnode) = @_[1..2];
172
173         # sort out various extant protocol errors that occur
174         my $origin = $_[13];
175         $origin = $dxchan->call unless $origin && $origin gt ' ';
176
177         # first look for any messages in the busy queue 
178         # and cancel them this should both resolve timed out incoming messages
179         # and crossing of message between nodes, incoming messages have priority
180
181         my $ref = get_busy($fromnode);
182         if ($ref) {
183                 my $otonode = $ref->{tonode} || "unknown";
184                 dbg("Busy, stopping msgno: $ref->{msgno} $fromnode->$otonode") if isdbg('msg');
185                 $ref->stop_msg($fromnode);
186         }
187
188         my $t = cltounix($_[5], $_[6]);
189         my $stream = next_transno($fromnode);
190         $ref = DXMsg->alloc($stream, uc $_[3], $_[4], $t, $_[7], $_[8], $origin, '0', $_[11]);
191                         
192         # fill in various forwarding state variables
193         $ref->{fromnode} = $fromnode;
194         $ref->{tonode} = $tonode;
195         $ref->{rrreq} = $_[11];
196         $ref->{linesreq} = $_[10];
197         $ref->{stream} = $stream;
198         $ref->{count} = 0;                      # no of lines between PC31s
199         dbg("new message from $_[4] to $_[3] '$_[8]' stream $fromnode/$stream\n") if isdbg('msg');
200         Log('msg', "Incoming message $_[4] to $_[3] '$_[8]' origin: $origin" );
201         set_fwq($fromnode, $stream, $ref); # store in work
202         set_busy($fromnode, $ref);      # set interlock
203         $dxchan->send(DXProt::pc30($fromnode, $tonode, $stream)); # send ack
204         $ref->{lastt} = $main::systime;
205
206         # look to see whether this is a non private message sent to a known callsign
207         my $uref = DXUser->get_current($ref->{to});
208         if (is_callsign($ref->{to}) && !$ref->{private} && $uref && $uref->homenode) {
209                 $ref->{private} = 1;
210                 dbg("set bull to $ref->{to} to private") if isdbg('msg');
211                 Log('msg', "set bull to $ref->{to} to private");
212         }
213 }
214                 
215 # incoming text
216 sub handle_29
217 {
218         my $dxchan = shift;
219         my ($tonode, $fromnode, $stream) = @_[1..3];
220         
221         my $ref = get_fwq($fromnode, $stream);
222         if ($ref) {
223                 $_[4] =~ s/\%5E/^/g;
224                 if (@{$ref->{lines}}) {
225                         push @{$ref->{lines}}, $_[4];
226                 } else {
227                         # temporarily store any R: lines so that we end up with 
228                         # only the first and last ones stored.
229                         if ($_[4] =~ m|^R:\d{6}/\d{4}|) {
230                                 push @{$ref->{tempr}}, $_[4];
231                         } else {
232                                 if (exists $ref->{tempr}) {
233                                         push @{$ref->{lines}}, shift @{$ref->{tempr}};
234                                         push @{$ref->{lines}}, pop @{$ref->{tempr}} if @{$ref->{tempr}};
235                                         delete $ref->{tempr};
236                                 }
237                                 push @{$ref->{lines}}, $_[4];
238                         } 
239                 }
240                 $ref->{count}++;
241                 if ($ref->{count} >= $ref->{linesreq}) {
242                         $dxchan->send(DXProt::pc31($fromnode, $tonode, $stream));
243                         dbg("stream $stream: $ref->{count} lines received\n") if isdbg('msg');
244                         $ref->{count} = 0;
245                 }
246                 $ref->{lastt} = $main::systime;
247         } else {
248                 dbg("PC29 from unknown stream $stream from $fromnode") if isdbg('msg');
249                 $dxchan->send(DXProt::pc42($fromnode, $tonode, $stream));       # unknown stream
250         }
251 }
252                 
253 # this is a incoming subject ack
254 sub handle_30
255 {
256         my $dxchan = shift;
257         my ($tonode, $fromnode, $stream) = @_[1..3];
258
259         my $ref = get_fwq($fromnode); # note no stream at this stage
260         if ($ref) {
261                 del_fwq($fromnode);
262                 $ref->{stream} = $stream;
263                 $ref->{count} = 0;
264                 $ref->{linesreq} = 5;
265                 set_fwq($fromnode, $stream, $ref); # new ref
266                 set_busy($fromnode, $ref); # interlock
267                 dbg("incoming subject ack stream $stream\n") if isdbg('msg');
268                 $ref->{lines} = [ $ref->read_msg_body ];
269                 $ref->send_tranche($dxchan);
270                 $ref->{lastt} = $main::systime;
271         } else {
272                 dbg("PC30 from unknown stream $stream from $fromnode") if isdbg('msg');
273                 $dxchan->send(DXProt::pc42($fromnode, $tonode, $stream));       # unknown stream
274         } 
275 }
276                 
277 # acknowledge a tranche of lines
278 sub handle_31
279 {
280         my $dxchan = shift;
281         my ($tonode, $fromnode, $stream) = @_[1..3];
282
283         my $ref = get_fwq($fromnode, $stream);
284         if ($ref) {
285                 dbg("tranche ack stream $stream\n") if isdbg('msg');
286                 $ref->send_tranche($dxchan);
287                 $ref->{lastt} = $main::systime;
288         } else {
289                 dbg("PC31 from unknown stream $stream from $fromnode") if isdbg('msg');
290                 $dxchan->send(DXProt::pc42($fromnode, $tonode, $stream));       # unknown stream
291         } 
292 }
293                 
294 # incoming EOM
295 sub handle_32
296 {
297         my $dxchan = shift;
298         my ($tonode, $fromnode, $stream) = @_[1..3];
299
300         dbg("stream $stream: EOM received\n") if isdbg('msg');
301         my $ref = get_fwq($fromnode, $stream);
302         if ($ref) {
303                 $dxchan->send(DXProt::pc33($fromnode, $tonode, $stream));       # acknowledge it
304                                 
305                 # get the next msg no - note that this has NOTHING to do with the stream number in PC protocol
306                 # store the file or message
307                 # remove extraneous rubbish from the hash
308                 # remove it from the work in progress vector
309                 # stuff it on the msg queue
310                 if ($ref->{lines}) {
311                         if ($ref->{file}) {
312                                 $ref->store($ref->{lines});
313                         } else {
314
315                                 # does an identical message already exist?
316                                 my $m;
317                                 for $m (@msg) {
318                                         if (substr($ref->{subject},0,28) eq substr($m->{subject},0,28) && $ref->{t} == $m->{t} && $ref->{from} eq $m->{from} && $ref->{to} eq $m->{to}) {
319                                                 $ref->stop_msg($fromnode);
320                                                 my $msgno = $m->{msgno};
321                                                 dbg("duplicate message from $ref->{from} -> $ref->{to} to msg: $msgno") if isdbg('msg');
322                                                 Log('msg', "duplicate message from $ref->{from} -> $ref->{to} to msg: $msgno");
323                                                 return;
324                                         }
325                                 }
326
327                                 # swop addresses
328                                 $ref->swop_it($dxchan->call);
329                                                 
330                                 # look for 'bad' to addresses 
331                                 if ($ref->dump_it($dxchan->call)) {
332                                         $ref->stop_msg($fromnode);
333                                         dbg("'Bad' message $ref->{to}") if isdbg('msg');
334                                         Log('msg', "'Bad' message $ref->{to}");
335                                         return;
336                                 }
337
338                                 # check the message for bad words 
339                                 my @words;
340                                 for (@{$ref->{lines}}) {
341                                         push @words, BadWords::check($_);
342                                 }
343                                 push @words, BadWords::check($ref->{subject});
344                                 if (@words) {
345                                         dbg("$ref->{from} swore: '@words' -> $ref->{to} '$ref->{subject}' origin: $ref->{origin} via " . $dxchan->call) if isdbg('msg');
346                                         Log('msg',"$ref->{from} swore: '@words' -> $ref->{to} origin: $ref->{origin} via " . $dxchan->call);
347                                         Log('msg',"subject: $ref->{subject}");
348                                         for (@{$ref->{lines}}) {
349                                                 Log('msg', "line: $_");
350                                         }
351                                         $ref->stop_msg($fromnode);
352                                         return;
353                                 }
354                                                         
355                                 $ref->{msgno} = next_transno("Msgno");
356                                 push @{$ref->{gotit}}, $fromnode; # mark this up as being received
357                                 $ref->store($ref->{lines});
358                                 $ref->notify;
359                                 add_dir($ref);
360                                 Log('msg', "Message $ref->{msgno} from $ref->{from} received from $fromnode for $ref->{to}");
361                         }
362                 }
363                 $ref->stop_msg($fromnode);
364         } else {
365                 dbg("PC32 from unknown stream $stream from $fromnode") if isdbg('msg');
366                 $dxchan->send(DXProt::pc42($fromnode, $tonode, $stream));       # unknown stream
367         }
368         # queue_msg(0);
369 }
370                 
371 # acknowledge the end of message
372 sub handle_33
373 {
374         my $dxchan = shift;
375         my ($tonode, $fromnode, $stream) = @_[1..3];
376         
377         my $ref = get_fwq($fromnode, $stream);
378         if ($ref) {
379                 if ($ref->{private}) {  # remove it if it private and gone off site#
380                         Log('msg', "Message $ref->{msgno} from $ref->{from} sent to $fromnode and deleted");
381                         $ref->mark_delete;
382                 } else {
383                         Log('msg', "Message $ref->{msgno} from $ref->{from} sent to $fromnode");
384                         push @{$ref->{gotit}}, $fromnode; # mark this up as being received
385                         $ref->store($ref->{lines});     # re- store the file
386                 }
387                 $ref->stop_msg($fromnode);
388         } else {
389                 dbg("PC33 from unknown stream $stream from $fromnode") if isdbg('msg');
390                 $dxchan->send(DXProt::pc42($fromnode, $tonode, $stream));       # unknown stream
391         } 
392
393         # send next one if present
394         queue_msg(0);
395 }
396                 
397 # this is a file request
398 sub handle_40
399 {
400         my $dxchan = shift;
401         my ($tonode, $fromnode) = @_[1..2];
402         
403         $_[3] =~ s/\\/\//og;            # change the slashes
404         $_[3] =~ s/\.//og;                      # remove dots
405         $_[3] =~ s/^\///o;                      # remove the leading /
406         $_[3] = lc $_[3];                       # to lower case;
407         dbg("incoming file $_[3]\n") if isdbg('msg');
408         $_[3] = 'packclus/' . $_[3] unless $_[3] =~ /^packclus\//o;
409                         
410         # create any directories
411         my @part = split /\//, $_[3];
412         my $part;
413         my $fn = "$main::root";
414         pop @part;                                      # remove last part
415         foreach $part (@part) {
416                 $fn .= "/$part";
417                 next if -e $fn;
418                 last SWITCH if !mkdir $fn, 0777;
419                 dbg("created directory $fn\n") if isdbg('msg');
420         }
421         my $stream = next_transno($fromnode);
422         my $ref = DXMsg->alloc($stream, "$main::root/$_[3]", $dxchan->call, time, !$_[4], $_[3], ' ', '0', '0');
423                         
424         # forwarding variables
425         $ref->{fromnode} = $tonode;
426         $ref->{tonode} = $fromnode;
427         $ref->{linesreq} = $_[5];
428         $ref->{stream} = $stream;
429         $ref->{count} = 0;                      # no of lines between PC31s
430         $ref->{file} = 1;
431         $ref->{lastt} = $main::systime;
432         set_fwq($fromnode, $stream, $ref); # store in work
433         $dxchan->send(DXProt::pc30($fromnode, $tonode, $stream)); # send ack 
434 }
435                 
436 # abort transfer
437 sub handle_42
438 {
439         my $dxchan = shift;
440         my ($tonode, $fromnode, $stream) = @_[1..3];
441         
442         dbg("stream $stream: abort received\n") if isdbg('msg');
443         my $ref = get_fwq($fromnode, $stream);
444         if ($ref) {
445                 $ref->stop_msg($fromnode);
446                 $ref = undef;
447         }
448 }
449
450 # global delete on subject
451 sub handle_49
452 {
453         my $dxchan = shift;
454         my $line = shift;
455         
456         for (@msg) {
457                 if ($_->{from} eq $_[1] && $_->{subject} eq $_[2]) {
458                         $_->mark_delete;
459                         Log('msg', "Message $_->{msgno} from $_->{from} ($_->{subject}) fully deleted");
460                         DXChannel::broadcast_nodes($line, $dxchan);
461                 }
462         }
463 }
464
465
466
467 sub notify
468 {
469         my $ref = shift;
470         my $to = $ref->{to};
471         my $uref = DXUser->get_current($to);
472         my $dxchan = DXChannel->get($to);
473         if (((*Net::SMTP && $email_server) || $email_prog) && $uref && $uref->wantemail) {
474                 my $email = $uref->email;
475                 if ($email) {
476                         my @rcpt = ref $email ? @{$email} : $email;
477                         my $fromaddr = $email_from || $main::myemail;
478                         my @headers = ("To: $ref->{to}", 
479                                                    "From: $fromaddr",
480                                                    "Subject: [DXSpider: $ref->{from}] $ref->{subject}", 
481                                                    "X-DXSpider-To: $ref->{to}",
482                                                    "X-DXSpider-From: $ref->{from}\@$ref->{origin}", 
483                                                    "X-DXSpider-Gateway: $main::mycall"
484                                                   );
485                         my @data = ("Msgno: $ref->{msgno} To: $to From: $ref->{from}\@$ref->{origin} Gateway: $main::mycall", 
486                                                 "", 
487                                                 $ref->read_msg_body
488                                            );
489                         my $msg;
490                         undef $!;
491                         if (*Net::SMTP && $email_server) {
492                                 $msg = Net::SMTP->new($email_server);
493                                 if ($msg) {
494                                         $msg->mail($fromaddr);
495                                         $msg->to(@rcpt);
496                                         $msg->data(map {"$_\n"} @headers, '', @data);
497                                         $msg->quit;
498                                 }
499                         } elsif ($email_prog) {
500                                 $msg = new IO::File "|$email_prog " . join(' ', @rcpt);
501                                 if ($msg) {
502                                         print $msg map {"$_\r\n"} @headers, '', @data, '.';
503                                         $msg->close;
504                                 }
505                         }
506                         dbg("email forwarding error $!") if isdbg('msg') && !$msg && defined $!; 
507                 }
508         }
509         $dxchan->send($dxchan->msg('m9')) if $dxchan && $dxchan->is_user;
510 }
511
512 # store a message away on disc or whatever
513 #
514 # NOTE the second arg is a REFERENCE not a list
515 sub store
516 {
517         my $ref = shift;
518         my $lines = shift;
519
520         if ($ref->{file}) {                     # a file
521                 dbg("To be stored in $ref->{to}\n") if isdbg('msg');
522                 
523                 my $fh = new IO::File "$ref->{to}", "w";
524                 if (defined $fh) {
525                         my $line;
526                         foreach $line (@{$lines}) {
527                                 print $fh "$line\n";
528                         }
529                         $fh->close;
530                         dbg("file $ref->{to} stored\n") if isdbg('msg');
531                         Log('msg', "file $ref->{to} from $ref->{from} stored" );
532                 } else {
533                         confess "can't open file $ref->{to} $!";  
534                 }
535         } else {                                        # a normal message
536
537                 # attempt to open the message file
538                 my $fn = filename($ref->{msgno});
539                 
540                 dbg("To be stored in $fn\n") if isdbg('msg');
541                 
542                 # now save the file, overwriting what's there, YES I KNOW OK! (I will change it if it's a problem)
543                 my $fh = new IO::File "$fn", "w";
544                 if (defined $fh) {
545                         my $rr = $ref->{rrreq} ? '1' : '0';
546                         my $priv = $ref->{private} ? '1': '0';
547                         my $del = $ref->{delete} ? '1' : '0';
548                         my $delt = $ref->{deletetime} || ($ref->{t} + $maxage);
549                         my $keep = $ref->{keep} || '0';
550                         print $fh "=== $ref->{msgno}^$ref->{to}^$ref->{from}^$ref->{t}^$priv^$ref->{subject}^$ref->{origin}^$ref->{'read'}^$rr^$del^$delt^$keep\n";
551                         print $fh "=== ", join('^', @{$ref->{gotit}}), "\n";
552                         my $line;
553                         $ref->{size} = 0;
554                         foreach $line (@{$lines}) {
555                                 $line =~ s/[\x00-\x08\x0a-\x1f\x80-\x9f]/./g;
556                                 $ref->{size} += (length $line) + 1;
557                                 print $fh "$line\n";
558                         }
559                         $fh->close;
560                         dbg("msg $ref->{msgno} stored\n") if isdbg('msg');
561                         Log('msg', "msg $ref->{msgno} from $ref->{from} to $ref->{to} stored" );
562                 } else {
563                         confess "can't open msg file $fn $!";  
564                 }
565         }
566
567 }
568
569 # delete a message
570 sub del_msg
571 {
572         my $self = shift;
573         my $dxchan = shift;
574         my $call = '';
575         $call = ' by ' . $dxchan->call if $dxchan;
576         
577         if ($self->{tonode}) {
578                 $self->{delete}++;
579                 $self->{deletetime} = 0;
580                 dbg("Msgno $self->{msgno} but marked as expunged$call") if isdbg('msg');
581         } else {
582                 # remove it from the active message list
583                 @msg = grep { $_ != $self } @msg;
584
585                 Log('msg', "Msgno $self->{msgno} expunged$call");
586                 dbg("Msgno $self->{msgno} expunged$call") if isdbg('msg');
587                 
588                 # remove the file
589                 unlink filename($self->{msgno});
590         }
591 }
592
593 sub mark_delete
594 {
595         my $ref = shift;
596         my $t = shift;
597
598         return if $ref->{keep};
599         
600         $t = $main::systime + $residencetime unless defined $t;
601         
602         $ref->{delete}++;
603         $ref->{deletetime} = $t;
604         $ref->store( [$ref->read_msg_body] );
605 }
606
607 sub unmark_delete
608 {
609         my $ref = shift;
610         my $t = shift;
611         $ref->{delete} = 0;
612         $ref->{deletetime} = 0;
613 }
614
615 # clean out old messages from the message queue
616 sub clean_old
617 {
618         my $ref;
619         
620         # mark old messages for deletion
621         foreach $ref (@msg) {
622                 if (ref($ref) && !$ref->{keep} && $ref->{deletetime} < $main::systime) {
623
624                         # this is for IMMEDIATE destruction
625                         $ref->{delete}++;
626                         $ref->{deletetime} = 0;
627                 }
628         }
629 }
630
631 # read in a message header
632 sub read_msg_header
633
634         my $fn = shift;
635         my $file;
636         my $line;
637         my $ref;
638         my @f;
639         my $size;
640         
641         $file = new IO::File "$fn";
642         if (!$file) {
643             dbg("Error reading $fn $!");
644             Log('err', "Error reading $fn $!");
645                 return undef;
646         }
647         $size = -s $fn;
648         $line = <$file>;                        # first line
649         if ($size == 0 || !$line) {
650             dbg("Empty $fn $!");
651             Log('err', "Empty $fn $!");
652                 return undef;
653         }
654         chomp $line;
655         $size -= length $line;
656         if (! $line =~ /^===/o) {
657                 dbg("corrupt first line in $fn ($line)");
658                 Log('err', "corrupt first line in $fn ($line)");
659                 return undef;
660         }
661         $line =~ s/^=== //o;
662         @f = split /\^/, $line;
663         $ref = DXMsg->alloc(@f);
664         
665         $line = <$file>;                        # second line
666         chomp $line;
667         $size -= length $line;
668         if (! $line =~ /^===/o) {
669             dbg("corrupt second line in $fn ($line)");
670             Log('err', "corrupt second line in $fn ($line)");
671                 return undef;
672         }
673         $line =~ s/^=== //o;
674         $ref->{gotit} = [];
675         @f = split /\^/, $line;
676         push @{$ref->{gotit}}, @f;
677         $ref->{size} = $size;
678         
679         close($file);
680         
681         return $ref;
682 }
683
684 # read in a message header
685 sub read_msg_body
686 {
687         my $self = shift;
688         my $msgno = $self->{msgno};
689         my $file;
690         my $line;
691         my $fn = filename($msgno);
692         my @out;
693         
694         $file = new IO::File;
695         if (!open($file, $fn)) {
696                 dbg("Error reading $fn $!");
697                 Log('err' ,"Error reading $fn $!");
698                 return ();
699         }
700         @out = map {chomp; $_} <$file>;
701         close($file);
702         
703         shift @out if $out[0] =~ /^=== /;
704         shift @out if $out[0] =~ /^=== /;
705         return @out;
706 }
707
708 # send a tranche of lines to the other end
709 sub send_tranche
710 {
711         my ($self, $dxchan) = @_;
712         my @out;
713         my $to = $self->{tonode};
714         my $from = $self->{fromnode};
715         my $stream = $self->{stream};
716         my $lines = $self->{lines};
717         my ($c, $i);
718         
719         for ($i = 0, $c = $self->{count}; $i < $self->{linesreq} && $c < @$lines; $i++, $c++) {
720                 push @out, DXProt::pc29($to, $from, $stream, $lines->[$c]);
721     }
722     $self->{count} = $c;
723
724     push @out, DXProt::pc32($to, $from, $stream) if $i < $self->{linesreq};
725         $dxchan->send(@out);
726 }
727
728         
729 # find a message to send out and start the ball rolling
730 sub queue_msg
731 {
732         my $sort = shift;
733         my $ref;
734         my $clref;
735         
736         # bat down the message list looking for one that needs to go off site and whose
737         # nearest node is not busy.
738
739         dbg("queue msg ($sort)\n") if isdbg('msg');
740         my @nodelist = DXChannel::get_all_nodes;
741         foreach $ref (@msg) {
742
743                 # ignore 'delayed' messages until their waiting time has expired
744                 if (exists $ref->{waitt}) {
745                         next if $ref->{waitt} > $main::systime;
746                         delete $ref->{waitt};
747                 } 
748
749                 # any time outs?
750                 if (exists $ref->{lastt} && $main::systime >= $ref->{lastt} + $timeout) {
751                         my $node = $ref->{tonode};
752                         dbg("Timeout, stopping msgno: $ref->{msgno} -> $node") if isdbg('msg');
753                         Log('msg', "Timeout, stopping msgno: $ref->{msgno} -> $node");
754                         $ref->stop_msg($node);
755                         
756                         # delay any outgoing messages that fail
757                         $ref->{waitt} = $main::systime + $waittime + int rand(120) if $node ne $main::mycall;
758                         delete $ref->{lastt};
759                         next;
760                 }
761
762                 # is it being sent anywhere currently?
763                 next if $ref->{tonode};           # ignore it if it already being processed
764                 
765                 # is it awaiting deletion?
766                 next if $ref->{delete};
767                 
768                 # firstly, is it private and unread? if so can I find the recipient
769                 # in my cluster node list offsite?
770
771                 # deal with routed private messages
772                 my $dxchan;
773                 if ($ref->{private}) {
774                         next if $ref->{'read'};           # if it is read, it is stuck here
775                         $clref = Route::get($ref->{to});
776                         if ($clref) {
777                                 $dxchan = $clref->dxchan;
778                                 if ($dxchan) {
779                                         if ($dxchan->is_node) {
780                                                 next if $clref->call eq $main::mycall;  # i.e. it lives here
781                                                 $ref->start_msg($dxchan) if !get_busy($dxchan->call)  && $dxchan->state eq 'normal';
782                                         }
783                                 } else {
784                                         dbg("Route: No dxchan for $ref->{to} " . ref($clref) ) if isdbg('msg');
785                                 }
786                         }
787                 } else {
788                         
789                         # otherwise we are dealing with a bulletin or forwarded private message
790                         # compare the gotit list with
791                         # the nodelist up above, if there are sites that haven't got it yet
792                         # then start sending it - what happens when we get loops is anyone's
793                         # guess, use (to, from, time, subject) tuple?
794                         foreach $dxchan (@nodelist) {
795                                 my $call = $dxchan->call;
796                                 next unless $call;
797                                 next if $call eq $main::mycall;
798                                 next if ref $ref->{gotit} && grep $_ eq $call, @{$ref->{gotit}};
799                                 next unless $ref->forward_it($call);           # check the forwarding file
800                                 next if $ref->{tonode};           # ignore it if it already being processed
801                                 
802                                 # if we are here we have a node that doesn't have this message
803                                 if (!get_busy($call)  && $dxchan->state eq 'normal') {
804                                         $ref->start_msg($dxchan);
805                                         last;
806                                 }
807                         }
808                 }
809
810                 # if all the available nodes are busy then stop
811                 last if @nodelist == scalar grep { get_busy($_->call) } @nodelist;
812         }
813
814         
815 }
816
817 # is there a message for me?
818 sub for_me
819 {
820         my $call = uc shift;
821         my $ref;
822         my $count;
823         
824         foreach $ref (@msg) {
825                 # is it for me, private and unread? 
826                 if ($ref->{to} eq $call && $ref->{private}) {
827                    $count++ unless $ref->{'read'} || $ref->{delete};
828                 }
829         }
830         return $count;
831 }
832
833 # start the message off on its travels with a PC28
834 sub start_msg
835 {
836         my ($self, $dxchan) = @_;
837         
838         confess("trying to start started msg $self->{msgno} nodes: $self->{fromnode} -> $self->{tonode}") if $self->{tonode};
839         dbg("start msg $self->{msgno}\n") if isdbg('msg');
840         $self->{linesreq} = 10;
841         $self->{count} = 0;
842         $self->{tonode} = $dxchan->call;
843         $self->{fromnode} = $main::mycall;
844         set_busy($self->{tonode}, $self);
845         set_fwq($self->{tonode}, undef, $self);
846         $self->{lastt} = $main::systime;
847         my ($fromnode, $origin);
848         $fromnode = $self->{fromnode};
849         $origin = $self->{origin};
850         $dxchan->send(DXProt::pc28($self->{tonode}, $fromnode, $self->{to}, $self->{from}, $self->{t}, $self->{private}, $self->{subject}, $origin, $self->{rrreq}));
851 }
852
853 # get the ref of a busy node
854 sub get_busy
855 {
856         my $call = shift;
857         return $busy{$call};
858 }
859
860 sub set_busy
861 {
862         my $call = shift;
863         return $busy{$call} = shift;
864 }
865
866 sub del_busy
867 {
868         my $call = shift;
869         return delete $busy{$call};
870 }
871
872 # get the whole busy queue
873 sub get_all_busy
874 {
875         return keys %busy;
876 }
877
878 # get a forwarding queue entry
879 sub get_fwq
880 {
881         my $call = shift;
882         my $stream = shift || '0';
883         return $work{"$call,$stream"};
884 }
885
886 # delete a forwarding queue entry
887 sub del_fwq
888 {
889         my $call = shift;
890         my $stream = shift || '0';
891         return delete $work{"$call,$stream"};
892 }
893
894 # set a fwq entry
895 sub set_fwq
896 {
897         my $call = shift;
898         my $stream = shift || '0';
899         return $work{"$call,$stream"} = shift;
900 }
901
902 # get the whole forwarding queue
903 sub get_all_fwq
904 {
905         return keys %work;
906 }
907
908 # stop a message from continuing, clean it out, unlock interlocks etc
909 sub stop_msg
910 {
911         my $self = shift;
912         my $node = shift;
913         my $stream = $self->{stream};
914         
915         
916         dbg("stop msg $self->{msgno} -> node $node\n") if isdbg('msg');
917         del_fwq($node, $stream);
918         $self->workclean;
919         del_busy($node);
920 }
921
922 sub workclean
923 {
924         my $ref = shift;
925         delete $ref->{lines};
926         delete $ref->{linesreq};
927         delete $ref->{tonode};
928         delete $ref->{fromnode};
929         delete $ref->{stream};
930         delete $ref->{file};
931         delete $ref->{count};
932         delete $ref->{tempr};
933         delete $ref->{lastt};
934         delete $ref->{waitt};
935 }
936
937 # get a new transaction number from the file specified
938 sub next_transno
939 {
940         my $name = shift;
941         $name =~ s/\W//og;                      # remove non-word characters
942         my $fn = "$msgdir/$name";
943         my $msgno;
944         
945         my $fh = new IO::File;
946         if (sysopen($fh, $fn, O_RDWR|O_CREAT, 0666)) {
947                 $fh->autoflush(1);
948                 $msgno = $fh->getline || '0';
949                 chomp $msgno;
950                 $msgno++;
951                 seek $fh, 0, 0;
952                 $fh->print("$msgno\n");
953                 dbg("msgno $msgno allocated for $name\n") if isdbg('msg');
954                 $fh->close;
955         } else {
956                 confess "can't open $fn $!";
957         }
958         return $msgno;
959 }
960
961 # initialise the message 'system', read in all the message headers
962 sub init
963 {
964         my $dir = new IO::File;
965         my @dir;
966         my $ref;
967                 
968         # load various control files
969         dbg("load badmsg: " . (load_badmsg() or "Ok"));
970         dbg("load forward: " . (load_forward() or "Ok"));
971         dbg("load swop: " . (load_swop() or "Ok"));
972
973         # read in the directory
974         opendir($dir, $msgdir) or confess "can't open $msgdir $!";
975         @dir = readdir($dir);
976         closedir($dir);
977
978         @msg = ();
979         for (sort @dir) {
980                 next unless /^m\d\d\d\d\d\d$/;
981                 
982                 $ref = read_msg_header("$msgdir/$_");
983                 unless ($ref) {
984                         dbg("Deleting $_");
985                         Log('err', "Deleting $_");
986                         unlink "$msgdir/$_";
987                         next;
988                 }
989                 
990                 # delete any messages to 'badmsg.pl' places
991                 if ($ref->dump_it('')) {
992                         dbg("'Bad' TO address $ref->{to}") if isdbg('msg');
993                         Log('msg', "'Bad' TO address $ref->{to}");
994                         $ref->del_msg;
995                         next;
996                 }
997
998                 # add the message to the available queue
999                 add_dir($ref); 
1000         }
1001 }
1002
1003 # add the message to the directory listing
1004 sub add_dir
1005 {
1006         my $ref = shift;
1007         confess "tried to add a non-ref to the msg directory" if !ref $ref;
1008         push @msg, $ref;
1009 }
1010
1011 # return all the current messages
1012 sub get_all
1013 {
1014         return @msg;
1015 }
1016
1017 # get a particular message
1018 sub get
1019 {
1020         my $msgno = shift;
1021         for (@msg) {
1022                 return $_ if $_->{msgno} == $msgno;
1023                 last if $_->{msgno} > $msgno;
1024         }
1025         return undef;
1026 }
1027
1028 # return the official filename for a message no
1029 sub filename
1030 {
1031         return sprintf "$msgdir/m%06d", shift;
1032 }
1033
1034 #
1035 # return a list of valid elements 
1036
1037
1038 sub fields
1039 {
1040         return keys(%valid);
1041 }
1042
1043 #
1044 # return a prompt for a field
1045 #
1046
1047 sub field_prompt
1048
1049         my ($self, $ele) = @_;
1050         return $valid{$ele};
1051 }
1052
1053 #
1054 # send a message state machine
1055 sub do_send_stuff
1056 {
1057         my $self = shift;
1058         my $line = shift;
1059         my @out;
1060         
1061         if ($self->state eq 'send1') {
1062                 #  $DB::single = 1;
1063                 confess "local var gone missing" if !ref $self->{loc};
1064                 my $loc = $self->{loc};
1065                 if (my @ans = BadWords::check($line)) {
1066                         $self->{badcount} += @ans;
1067                         Log('msg', $self->call . " used badwords: @ans to @{$loc->{to}} in msg");
1068                         $loc->{reject}++;
1069                 }
1070                 $loc->{subject} = $line;
1071                 $loc->{lines} = [];
1072                 $self->state('sendbody');
1073                 #push @out, $self->msg('sendbody');
1074                 push @out, $self->msg('m8');
1075         } elsif ($self->state eq 'sendbody') {
1076                 confess "local var gone missing" if !ref $self->{loc};
1077                 my $loc = $self->{loc};
1078                 if ($line eq "\032" || $line eq '%1A' || uc $line eq "/EX") {
1079                         my $to;
1080                         unless ($loc->{reject}) {
1081                                 foreach $to (@{$loc->{to}}) {
1082                                         my $ref;
1083                                         my $systime = $main::systime;
1084                                         my $mycall = $main::mycall;
1085                                         $ref = DXMsg->alloc(DXMsg::next_transno('Msgno'),
1086                                                                                 uc $to,
1087                                                                                 exists $loc->{from} ? $loc->{from} : $self->call, 
1088                                                                                 $systime,
1089                                                                                 $loc->{private}, 
1090                                                                                 $loc->{subject}, 
1091                                                                                 exists $loc->{origin} ? $loc->{origin} : $mycall,
1092                                                                                 '0',
1093                                                                                 $loc->{rrreq});
1094                                         $ref->swop_it($self->call);
1095                                         $ref->store($loc->{lines});
1096                                         $ref->add_dir();
1097                                         push @out, $self->msg('m11', $ref->{msgno}, $to);
1098                                         #push @out, "msgno $ref->{msgno} sent to $to";
1099                                         $ref->notify;
1100                                 }
1101                         } else {
1102                                 Log('msg', $self->call . " swore to @{$loc->{to}} subject: '$loc->{subject}' in msg, REJECTED");
1103                         }
1104                         
1105                         delete $loc->{lines};
1106                         delete $loc->{to};
1107                         delete $self->{loc};
1108                         $self->func(undef);
1109                         
1110                         $self->state('prompt');
1111                 } elsif ($line eq "\031" || uc $line eq "/ABORT" || uc $line eq "/QUIT") {
1112                         #push @out, $self->msg('sendabort');
1113                         push @out, $self->msg('m10');
1114                         delete $loc->{lines};
1115                         delete $loc->{to};
1116                         delete $self->{loc};
1117                         $self->func(undef);
1118                         $self->state('prompt');
1119                 } elsif ($line =~ m|^/+\w+|) {
1120                         # this is a command that you want display for your own reference
1121                         # or if it has TWO slashes is a command 
1122                         $line =~ s|^/||;
1123                         my $store = $line =~ s|^/+||;
1124                         my @in = $self->run_cmd($line);
1125                         push @out, @in;
1126                         if ($store) {
1127                                 foreach my $l (@in) {
1128                                         if (my @ans = BadWords::check($l)) {
1129                                                 $self->{badcount} += @ans;
1130                                                 Log('msg', $self->call . " used badwords: @ans to @{$loc->{to}} subject: '$loc->{subject}' in msg") unless $loc->{reject};
1131                                                 Log('msg', "line: $l");
1132                                                 $loc->{reject}++;
1133                                         } 
1134                                         push @{$loc->{lines}}, length($l) > 0 ? $l : " ";
1135                                 }
1136                         }
1137                 } else {
1138                         if (my @ans = BadWords::check($line)) {
1139                                 $self->{badcount} += @ans;
1140                                 Log('msg', $self->call . " used badwords: @ans to @{$loc->{to}} subject: '$loc->{subject}' in msg") unless $loc->{reject};
1141                                 Log('msg', "line: $line");
1142                                 $loc->{reject}++;
1143                         }
1144
1145                         if ($loc->{lines} && @{$loc->{lines}}) {
1146                                 push @{$loc->{lines}}, length($line) > 0 ? $line : " ";
1147                         } else {
1148                                 # temporarily store any R: lines so that we end up with 
1149                                 # only the first and last ones stored.
1150                                 if ($line =~ m|^R:\d{6}/\d{4}|) {
1151                                         push @{$loc->{tempr}}, $line;
1152                                 } else {
1153                                         if (exists $loc->{tempr}) {
1154                                                 push @{$loc->{lines}}, shift @{$loc->{tempr}};
1155                                                 push @{$loc->{lines}}, pop @{$loc->{tempr}} if @{$loc->{tempr}};
1156                                                 delete $loc->{tempr};
1157                                         }
1158                                         push @{$loc->{lines}}, length($line) > 0 ? $line : " ";
1159                                 } 
1160                         }
1161                         
1162                         # i.e. it ain't and end or abort, therefore store the line
1163                 }
1164         }
1165         return @out;
1166 }
1167
1168 # return the standard directory line for this ref 
1169 sub dir
1170 {
1171         my $ref = shift;
1172         my $flag = $ref->{private} && $ref->{read} ? '-' : ' ';
1173         if ($ref->{keep}) {
1174                 $flag = '!';
1175         } elsif ($ref->{delete}) {
1176                 $flag = $ref->{deletetime} > $main::systime ? 'D' : 'E'; 
1177         }
1178         return sprintf("%6d%s%s%5d %8.8s %8.8s %-6.6s %5.5s %-30.30s", 
1179                                    $ref->{msgno}, $flag, $ref->{private} ? 'p' : ' ', 
1180                                    $ref->{size}, $ref->{to}, $ref->{from}, cldate($ref->{t}), 
1181                                    ztime($ref->{t}), $ref->{subject});
1182 }
1183
1184 # load the forward table
1185 sub load_forward
1186 {
1187         my @out;
1188         my $s = readfilestr($forwardfn);
1189         if ($s) {
1190                 eval $s;
1191                 push @out, $@ if $@;
1192         }
1193         return @out;
1194 }
1195
1196 # load the bad message table
1197 sub load_badmsg
1198 {
1199         my @out;
1200         my $s = readfilestr($badmsgfn);
1201         if ($s) {
1202                 eval $s;
1203                 push @out, $@ if $@;
1204         }
1205         return @out;
1206 }
1207
1208 # load the swop message table
1209 sub load_swop
1210 {
1211         my @out;
1212         my $s = readfilestr($swopfn);
1213         if ($s) {
1214                 eval $s;
1215                 push @out, $@ if $@;
1216         }
1217         return @out;
1218 }
1219
1220 #
1221 # forward that message or not according to the forwarding table
1222 # returns 1 for forward, 0 - to ignore
1223 #
1224
1225 sub forward_it
1226 {
1227         my $ref = shift;
1228         my $call = shift;
1229         my $i;
1230         
1231         for ($i = 0; $i < @forward; $i += 5) {
1232                 my ($sort, $field, $pattern, $action, $bbs) = @forward[$i..($i+4)]; 
1233                 my $tested;
1234                 
1235                 # are we interested?
1236                 next if $ref->{private} && $sort ne 'P';
1237                 next if !$ref->{private} && $sort ne 'B';
1238                 
1239                 # select field
1240                 $tested = $ref->{to} if $field eq 'T';
1241                 $tested = $ref->{from} if $field eq 'F';
1242                 $tested = $ref->{origin} if $field eq 'O';
1243                 $tested = $ref->{subject} if $field eq 'S';
1244
1245                 if (!$pattern || $tested =~ m{$pattern}i) {
1246                         return 0 if $action eq 'I';
1247                         return 1 if !$bbs || grep $_ eq $call, @{$bbs};
1248                 }
1249         }
1250         return 0;
1251 }
1252
1253 #
1254 # look down the forward table to see whether this is a valid bull
1255 # or not (ie it will forward somewhere even if it is only here)
1256 #
1257 sub valid_bull_addr
1258 {
1259         my $call = shift;
1260         my $i;
1261         
1262         unless (@forward) {
1263                 return 1 if $call =~ /^ALL/;
1264                 return 1 if $call =~ /^DX/;
1265                 return 0;
1266         }
1267         
1268         for ($i = 0; $i < @forward; $i += 5) {
1269                 my ($sort, $field, $pattern, $action, $bbs) = @forward[$i..($i+4)]; 
1270                 if ($field eq 'T') {
1271                         if (!$pattern || $call =~ m{$pattern}i) {
1272                                 return 1;
1273                         }
1274                 }
1275         }
1276         return 0;
1277 }
1278
1279 sub dump_it
1280 {
1281         my $ref = shift;
1282         my $call = shift;
1283         my $i;
1284         
1285         for ($i = 0; $i < @badmsg; $i += 3) {
1286                 my ($sort, $field, $pattern) = @badmsg[$i..($i+2)]; 
1287                 my $tested;
1288                 
1289                 # are we interested?
1290                 next if $ref->{private} && $sort ne 'P';
1291                 next if !$ref->{private} && $sort ne 'B';
1292                 
1293                 # select field
1294                 $tested = $ref->{to} if $field eq 'T';
1295                 $tested = $ref->{from} if $field eq 'F';
1296                 $tested = $ref->{origin} if $field eq 'O';
1297                 $tested = $ref->{subject} if $field eq 'S';
1298                 $tested = $call if $field eq 'I';
1299
1300                 if (!$pattern || $tested =~ m{$pattern}i) {
1301                         return 1;
1302                 }
1303         }
1304         return 0;
1305 }
1306
1307 sub swop_it
1308 {
1309         my $ref = shift;
1310         my $call = shift;
1311         my $i;
1312         my $count = 0;
1313         
1314         for ($i = 0; $i < @swop; $i += 5) {
1315                 my ($sort, $field, $pattern, $tfield, $topattern) = @swop[$i..($i+4)]; 
1316                 my $tested;
1317                 my $swop;
1318                 my $old;
1319                 
1320                 # are we interested?
1321                 next if $ref->{private} && $sort ne 'P';
1322                 next if !$ref->{private} && $sort ne 'B';
1323                 
1324                 # select field
1325                 $tested = $ref->{to} if $field eq 'T';
1326                 $tested = $ref->{from} if $field eq 'F';
1327                 $tested = $ref->{origin} if $field eq 'O';
1328                 $tested = $ref->{subject} if $field eq 'S';
1329
1330                 # select swop field
1331                 $old = $swop = $ref->{to} if $tfield eq 'T';
1332                 $old = $swop = $ref->{from} if $tfield eq 'F';
1333                 $old = $swop = $ref->{origin} if $tfield eq 'O';
1334                 $old = $swop = $ref->{subject} if $tfield eq 'S';
1335
1336                 if ($tested =~ m{$pattern}i) {
1337                         if ($tested eq $swop) {
1338                                 $swop =~ s{$pattern}{$topattern}i;
1339                         } else {
1340                                 $swop = $topattern;
1341                         }
1342                         Log('msg', "Msg $ref->{msgno}: $tfield $old -> $swop");
1343                         Log('dbg', "Msg $ref->{msgno}: $tfield $old -> $swop");
1344                         $ref->{to} = $swop if $tfield eq 'T';
1345                         $ref->{from} = $swop if $tfield eq 'F';
1346                         $ref->{origin} = $swop if $tfield eq 'O';
1347                         $ref->{subject} = $swop if $tfield eq 'S';
1348                         ++$count;
1349                 }
1350         }
1351         return $count;
1352 }
1353
1354 # import any msgs in the import directory
1355 # the messages are in BBS format (but may have cluster extentions
1356 # so SB UK < GB7TLH is legal
1357 sub import_msgs
1358 {
1359         # are there any to do in this directory?
1360         return unless -d $importfn;
1361         unless (opendir(DIR, $importfn)) {
1362                 dbg("can\'t open $importfn $!") if isdbg('msg');
1363                 Log('msg', "can\'t open $importfn $!");
1364                 return;
1365         } 
1366
1367         my @names = readdir(DIR);
1368         closedir(DIR);
1369         my $name;
1370         foreach $name (@names) {
1371                 next if $name =~ /^\./;
1372                 my $splitit = $name =~ /^split/;
1373                 my $fn = "$importfn/$name";
1374                 next unless -f $fn;
1375                 unless (open(MSG, $fn)) {
1376                         dbg("can\'t open import file $fn $!") if isdbg('msg');
1377                         Log('msg', "can\'t open import file $fn $!");
1378                         unlink($fn);
1379                         next;
1380                 }
1381                 my @msg = map { chomp; $_ } <MSG>;
1382                 close(MSG);
1383                 unlink($fn);
1384                 my @out = import_one($main::me, \@msg, $splitit);
1385                 Log('msg', @out);
1386         }
1387 }
1388
1389 # import one message as a list in bbs (as extended) mode
1390 # takes a reference to an array containing the whole message
1391 sub import_one
1392 {
1393         my $dxchan = shift;
1394         my $ref = shift;
1395         my $splitit = shift;
1396         my $private = '1';
1397         my $rr = '0';
1398         my $notincalls = 1;
1399         my $from = $dxchan->call;
1400         my $origin = $main::mycall;
1401         my @to;
1402         my @out;
1403                                 
1404         # first line;
1405         my $line = shift @$ref;
1406         my @f = split /([\s\@\$])/, $line;
1407         @f = map {s/\s+//g; length $_ ? $_ : ()} @f;
1408
1409         unless (@f && $f[0] =~ /^(:?S|SP|SB|SEND)$/ ) {
1410                 my $m = "invalid first line in import '$line'";
1411                 dbg($m) if isdbg('msg');
1412                 return (1, $m);
1413         }
1414         while (@f) {
1415                 my $f = uc shift @f;
1416                 next if $f eq 'SEND';
1417
1418                 # private / noprivate / rr
1419                 if ($notincalls && ($f eq 'B' || $f eq 'SB' || $f =~ /^NOP/oi)) {
1420                         $private = '0';
1421                 } elsif ($notincalls && ($f eq 'P' || $f eq 'SP' || $f =~ /^PRI/oi)) {
1422                         ;
1423                 } elsif ($notincalls && ($f eq 'RR')) {
1424                         $rr = '1';
1425                 } elsif (($f =~ /^[\@\.\#\$]$/ || $f eq '.#') && @f) {       # this is bbs syntax, for AT
1426                         shift @f;
1427                 } elsif ($f eq '<' && @f) {     # this is bbs syntax  for from call
1428                         $from = uc shift @f;
1429                 } elsif ($f =~ /^\$/) {     # this is bbs syntax  for a bid
1430                         next;
1431                 } elsif ($f =~ /^<(\S+)/) {     # this is bbs syntax  for from call
1432                         $from = $1;
1433                 } elsif ($f =~ /^\$\S+/) {     # this is bbs syntax for bid
1434                         ;
1435                 } else {
1436
1437                         # callsign ?
1438                         $notincalls = 0;
1439
1440                         # is this callsign a distro?
1441                         my $fn = "$msgdir/distro/$f.pl";
1442                         if (-e $fn) {
1443                                 my $fh = new IO::File $fn;
1444                                 if ($fh) {
1445                                         local $/ = undef;
1446                                         my $s = <$fh>;
1447                                         $fh->close;
1448                                         my @call;
1449                                         @call = eval $s;
1450                                         return (1, "Error in Distro $f.pl:", $@) if $@;
1451                                         if (@call > 0) {
1452                                                 push @f, @call;
1453                                                 next;
1454                                         }
1455                                 }
1456                         }
1457                         
1458                         if (grep $_ eq $f, @DXMsg::badmsg) {
1459                                 push @out, $dxchan->msg('m3', $f);
1460                         } else {
1461                                 push @to, $f;
1462                         }
1463                 }
1464         }
1465         
1466         # subject is the next line
1467         my $subject = shift @$ref;
1468         
1469         # strip off trailing lines 
1470         pop @$ref while (@$ref && $$ref[-1] =~ /^\s*$/);
1471         
1472         # strip off /EX or /ABORT
1473         return ("aborted") if @$ref && $$ref[-1] =~ m{^/ABORT$}i; 
1474         pop @$ref if (@$ref && $$ref[-1] =~ m{^/EX$}i);                                                                  
1475
1476         # sort out any splitting that needs to be done
1477         my @chunk;
1478         if ($splitit) {
1479                 my $lth = 0;
1480                 my $lines = [];
1481                 for (@$ref) {
1482                         if ($lth >= $maxchunk || ($lth > $minchunk && /^\s*$/)) {
1483                                 push @chunk, $lines;
1484                                 $lines = [];
1485                                 $lth = 0;
1486                         } 
1487                         push @$lines, $_;
1488                         $lth += length; 
1489                 }
1490                 push @chunk, $lines if @$lines;
1491         } else {
1492                 push @chunk, $ref;
1493         }
1494
1495         # does an identical message already exist?
1496         my $m;
1497         for $m (@msg) {
1498                 if (substr($subject,0,28) eq substr($m->{subject},0,28) && $from eq $m->{from} && grep $m->{to} eq $_, @to) {
1499                         my $msgno = $m->{msgno};
1500                         dbg("duplicate message from $from -> $m->{to} to msg: $msgno") if isdbg('msg');
1501                         Log('msg', "duplicate message from $from -> $m->{to} to msg: $msgno");
1502                         return;
1503                 }
1504         }
1505
1506     # write all the messages away
1507         my $i;
1508         for ( $i = 0;  $i < @chunk; $i++) {
1509                 my $chunk = $chunk[$i];
1510                 my $ch_subject;
1511                 if (@chunk > 1) {
1512                         my $num = " [" . ($i+1) . "/" . scalar @chunk . "]";
1513                         $ch_subject = substr($subject, 0, 27 - length $num) .  $num;
1514                 } else {
1515                         $ch_subject = $subject;
1516                 }
1517                 my $to;
1518                 foreach $to (@to) {
1519                         my $systime = $main::systime;
1520                         my $mycall = $main::mycall;
1521                         my $mref = DXMsg->alloc(DXMsg::next_transno('Msgno'),
1522                                                                         $to,
1523                                                                         $from, 
1524                                                                         $systime,
1525                                                                         $private, 
1526                                                                         $ch_subject, 
1527                                                                         $origin,
1528                                                                         '0',
1529                                                                         $rr);
1530                         $mref->swop_it($main::mycall);
1531                         $mref->store($chunk);
1532                         $mref->add_dir();
1533                         push @out, $dxchan->msg('m11', $mref->{msgno}, $to);
1534                         #push @out, "msgno $ref->{msgno} sent to $to";
1535                         $mref->notify;
1536                 }
1537         }
1538         return @out;
1539 }
1540
1541 #no strict;
1542 sub AUTOLOAD
1543 {
1544         no strict;
1545         my $name = $AUTOLOAD;
1546         return if $name =~ /::DESTROY$/;
1547         $name =~ s/^.*:://o;
1548         
1549         confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
1550         # this clever line of code creates a subroutine which takes over from autoload
1551         # from OO Perl - Conway
1552         *$AUTOLOAD = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}};
1553        goto &$AUTOLOAD;
1554 }
1555
1556 1;
1557
1558 __END__