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