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         my $self = shift;
1522         no strict;
1523         my $name = $AUTOLOAD;
1524         return if $name =~ /::DESTROY$/;
1525         $name =~ s/^.*:://o;
1526
1527         confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
1528         # this clever line of code creates a subroutine which takes over from autoload
1529         # from OO Perl - Conway
1530         *$AUTOLOAD = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}};
1531         &$AUTOLOAD($self, @_);
1532 #       *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ;
1533 #       @_ ? $self->{$name} = shift : $self->{$name} ;
1534 }
1535
1536 1;
1537
1538 __END__