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