program SMTPX ;
{ By Peter Meiring, G0BSX. All rights Reserved.                              }
{ Version 1.02: RFC822 compatible                                            }
{ This is a program will scan the SMTP Queue directory and extract files     }
{ Therein for importation into the mailbox.  It will search for a "callsign" }
{ in the TO field and, if found, will make that message PRIVATE, else it     }
{ will make it a public bulletin                                             }
{ The program requires 2 parameters, namely the Mailbox IMPORT filename and  }
{ the callsign of the Host Mailbox.                                          }

{ file format: RQUEUE .TXT file. }
{ Received: from <hostid> by <hostid> with SMTP }
{ 	id AA7750 ; <day>, <date> <time> GMT         }
{ Date: <day>, <date> <time> GMT                }
{ Message-Id: <<number>@<hostid>>               }
{ From: <user>@<hostid> <name>                  }
{ To: <user>@<bbs>@<hostid>                     }
{ Subject: Message Title                        }
{                                               }
{ Message TEXT                                  }

const LineLength = 80;
      Version    = 'Version 1.02 (c) Peter Meiring, G0BSX, June 1988.';

type WorkString = string[255];
     String40   = string[40];

var CurrentPath : WorkString;
    OutFP : text;
    Line : WorkString;

function toUpper( str : WorkString ) : WorkString;

var i : integer;
    t : Workstring;

begin
  t := '';
  for i := 1 to length(str) do
    t := t + UpCase(str[i]);
  ToUpper := t
end;

procedure ProcessDirectory;

type
  Char12arr            = array [ 1..12 ] of Char;
  RegRec =
    record
      AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags : Integer;
    end;

var
  Regs                 : RegRec;
  DTA                  : array [ 1..43 ] of Byte;
  Mask                 : Char12arr;
  NamR                 : String40;
  Error, I             : Integer;
  msgFP                : text;


procedure Process( fname : String40 );

var ToCall, AtCall, TextFilename, LockFilename : String40;
    ToLine, Xmsgtype : String40 ;
    RXLine, DateLine, Subject : string[80];
    InFP : text;
    Bull : boolean;
    Lines : array[1..7] of WorkString;
    l, T1, T2, T3 : integer;

function IsCall( name : String40 ) : boolean;

var n : integer;
    f,f1,f2,f3,f4 : boolean;

function IsAlpha( c : char ) : boolean;
begin
  if ((c <= 'Z') and (c >= 'A')) or ((c <= 'z') and (c >= 'a')) then
    IsAlpha := TRUE
  else
    IsAlpha := FALSE
end;

function IsNumber( c : char ) : boolean;
begin
  if (c >= '0') and (c <= '9') then
    IsNumber := TRUE
  else
    IsNumber := FALSE
end;

begin
  f := (length(name) > 2);
  f1 := IsAlpha(name[1]) and IsNumber(name[2]) and IsAlpha(name[3]);
  f2 := IsAlpha(name[1]) and IsNumber(name[2]) and IsNumber(name[3])
        and IsAlpha(name[4]);
  f3 := IsAlpha(name[1])  and IsAlpha(name[2]) and IsNumber(name[3])
        and IsAlpha(name[4]);
  f4 := IsNumber(name[1]) and IsAlpha(name[2]) and IsNumber(name[3])
        and IsAlpha(name[4]);
  IsCall := f and (f1 or f2 or f3 or f4)
end;

begin
  LockFilename := copy( fname, 1, pos('.', fname)) + 'LCK';
  TextFilename := copy( fname, 1, pos('.', fname)) + 'TXT';
  Write( ' : ', fname);
  assign( InFP, LockFilename);
  {$I-}
  reset(InFP);
  if IOResult = 0 then begin
    writeln( ' locked by SMTP');
    close(InFP)
  {$I+}
  end else begin
    assign(InFP, Textfilename);
    reset(InFP);
    repeat
      readln(InFP,Line);
      if pos('Received:', Line) = 1 then RXLine := Line;
      if pos('Date:', Line) = 1 then DateLine := Line;
      if pos('To:', Line)=1 then begin
        Line := ToUpper(Line);
        T1 := 5;
        T2 := pos('%',Line);
        T3 := pos('@',Line);
        If T2 = 0 then begin
          ToCall := copy(Line,T1,T3-T1);
          AtCall := ParamStr(2)
        end
        else begin
          AtCall := Copy(Line, T2+1, T3-T2-1);
          ToCall := Copy(Line, T1, T2-T1)
        end;
        Writeln(OutFP, 'To: ', ToCall, '@', AtCall);
        Xmsgtype := 'X-msgtype: ';
        if IsCall( ToCall ) then
          Xmsgtype := Xmsgtype + 'P'
        else
          Xmsgtype := Xmsgtype + 'B';
        writeln(OutFP, Xmsgtype)
      end
      else
        writeln(outFP, Line)
    until Line = '' ;
    Writeln(OutFP, '>> G0BSX General Purpose SMTP -> Mailbox Server.');
    Writeln(OutFP, RXLine);
    Writeln(OutFP, DateLine);
    while not EOF(InFP) do begin
      readln(InFP,Line);
      writeln(OutFP,Line)
    end;
    Writeln(OutFP);
    Writeln(OutFP,'/EX');
    close(InFP);
    erase(InFP);
    assign(InFP,fname);
    erase(InFP);
  end
end;


begin
  write('Processing');

  FillChar(DTA,SizeOf(DTA),0);        { Initialize the DTA buffer }
  FillChar(Mask,SizeOf(Mask),0);      { Initialize the mask }
  FillChar(NamR,SizeOf(NamR),0);      { Initialize the file name }

  Regs.AX := $1A00;         { Function used to set the DTA }
  Regs.DS := Seg(DTA);      { store the parameter segment in DS }
  Regs.DX := Ofs(DTA);      {   "    "      "     offset in DX }
  MSDos(Regs);              { Set DTA location }
  Error := 0;
  Mask := '????????.???';    { Use message ONLY search }
  Regs.AX := $4E00;          { Get first directory entry }
  Regs.DS := Seg(Mask);      { Point to the file Mask }
  Regs.DX := Ofs(Mask);
  Regs.CX := 22;             { Store the option }
  MSDos(Regs);               { Execute MSDos call }
  Error := Regs.AX and $FF;  { Get Error return }
  I := 1;                    { initialize 'I' to the first element }
  if (Error = 0) then
    repeat
      NamR[I] := Chr(Mem[Seg(DTA):Ofs(DTA)+29+I]);
      I := I + 1;
    until not (NamR[I-1] in [' '..'~']) or (I>20);

  NamR[0] := Chr(I-1);          { set string length because assigning }
                                { by element does not set length }
  while (Error = 0) do begin
    Error := 0;
    Regs.AX := $4F00;           { Function used to get the next }
                                { directory entry }
    Regs.CX := 22;              { Set the file option }
    MSDos( Regs );              { Call MSDos }
    Error := Regs.AX and $FF;   { get the Error return }
    I := 1;
    repeat
      NamR[I] := Chr(Mem[Seg(DTA):Ofs(DTA)+29+I]);
      I := I + 1;
    until not (NamR[I-1] in [' '..'~'] ) or (I > 20);
    NamR[0] := Chr(I-1);
    if (error = 0) and (pos('.WRK', NamR)>0) then
      Process(NamR)
  end;
  close(OutFP);
  writeln;
  writeln('*** Done.')
end;

begin
  writeln('G0BSX  SMTP -> Mailbox General Purpose Server.');
  writeln(Version);
  if ParamCount < 2 then begin
    Writeln( '*** Not enough Parameters');
    Writeln( 'SMTPX usage: SMTPX mbxfilename mbxCallsign');
    halt
  end;
  GetDIR(0,CurrentPath);
  {$I-}
  assign(OutFP,ParamStr(1));
  append(OutFP);
  if IOResult <> 0 then begin
     rewrite(OutFP);
     if IOResult <> 0 then begin
       writeln('*** Error in opening ', ParamStr(1));
       close(OutFP);
       halt
     end
  end;
  {$I+}
  writeln( 'Output file open :', ParamStr(1));
  ChDIR('\SPOOL\RQUEUE');
  writeln( 'Current Directory : \SPOOL\RQUEUE');
  ProcessDirectory;
  ChDIR(CurrentPath);
  writeln('Current Directory : ',CurrentPath);
  close( OutFP )
end.