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->bestdxchan;
 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__