program SMTPI ;
{ By Peter Meiring, G0BSX. All rights Reserved.                           }
{ Program to take input from a text file anmd convert it to SMTP messages }
{ according to instructions in a second file.                             }
{ usage syntax:                                                           }
{   SMTP <import File> <List File> <mbox hostname> <mbox callsign>        }
{ Version 1.02: RFC822 compatible                                         }

const LineLength      = 255;
      Version         = 'Version 1.02 (c) Peter Meiring, G0BSX, June 1988.';
      CounterFilename = 'SEQUENCE.SEQ';
      SMTPDir         = '\SPOOL\MQUEUE\';
      IDText = '>> G0BSX  Mailbox->SMTP General Purpose Server.';
      tab = #$09;
      space = #$20;
      maxconds = 50;

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

var CurrentPath    : WorkString;
    Counter        : integer;
    TxtFilename, WrkFilename : String40 ;
    CallsFP, InFP, LckFP, TxtFP, WrkFP    : text;


function fopen(var fp : text; fname : WorkString; mode : char) : boolean;

begin
  assign(fp,fname);
  {$I-}
  case mode of
    'w', 'W' : rewrite(fp);
    'r', 'R' : reset(fp);
    'a', 'A' : append(fp)
  end;
  if IOResult <> 0 then begin
    close(fp);
    fopen := False;
  end else
    fopen := TRUE
  {$I+}
end;

function Now : String40;

type
  regpack = record
              ax,bx,cx,dx,bp,si,di,ds,es,flags: integer;
            end;

var
  recpack:          regpack;             {assign record}
  ah,al,ch,cl,dh:   byte;
  hour,min,sec,day:     string[2];
  month, year:          string[4];
  dx,cx,m :          integer;

begin
  ah := $2c;                             {initialize correct registers}
  with recpack do
  begin
    ax := ah shl 8 + al;
  end;
  intr($21,recpack);                     {call interrupt}
  with recpack do
  begin
    str(cx shr 8,hour);                  {convert to string}
    if length(hour) < 2 then hour := '0'+hour;
    str(cx mod 256,min);                       { " }
    if length(min) < 2 then min := '0'+min;
    str(dx shr 8,sec);                         { " }
    if length(sec) < 2 then sec := '0'+sec
  end;
  with recpack do
  begin
    ax := $2a shl 8;
  end;
  MsDos(recpack);                        { call function }
  with recpack do
  begin
    str(cx,year);                        {convert to string}
    str(dx mod 256,day);                     { " }
    m := dx shr 8
  end;
  case m of
    1 : month := 'Jan';
    2 : month := 'Feb';
    3 : month := 'Mar';
    4 : month := 'Apr';
    5 : month := 'May';
    6 : Month := 'Jun';
    7 : month := 'Jul';
    8 : month := 'Aug';
    9 : month := 'Sep';
    10 : month := 'Oct';
    11 : month := 'Nov';
    12 : month := 'Dec'
  end;
  Now := day+' '+month+' '+copy(year, 3, 2)+'    '+hour+ ':'+min+':'+sec
end;


function word( n : integer; s : WorkString) : string40;

var c,p,q : integer;
    t,a : WorkString;

begin
  t := s;
  for c := 1 to n do
    if length(t) > 0 then begin
      while (length(t) > 1) and ((t[1] = space)or(t[1] = Tab)) do
        t := copy( t, 2, length(t)-1);
      if (t = space) or (t = tab) then begin
        t := '';
        a := '';
      end;
      if t <> '' then
        p := pos( space, t);
        q := pos( tab, t);
        if ((p > q) and (q > 0)) or ((q > p) and (p = 0)) then p := q;
        if p <> 0 then begin
          a := copy( t, 1, p-1);
          t := copy( t, p+1, length(t) - p)
        end else begin
          a := t;
          t := ''
        end
    end;
  word := a
end;

function words( s : workstring) : integer;

var n,c : integer;
    white : boolean;

begin
  white := true;
  c := 0;
  for n := 1 to length( s ) do begin
    if (s[n] <> space) and (s[n] <> tab) and white then c := succ(c);
    if (s[n] = space) or (s[n] = tab) then white := true else white := false
  end;
  words := c
end;


function NxtMsg : integer;

{ Function to read the SMTP mailer sequence file, increment it amd return }
{ the number that can be used for the next SMTP mail file. }

var fp : text;
    fname : WorkString;
    n : integer;

begin
  fname := SMTPDir + CounterFilename;
  if fopen(fp, fname, 'r') then
    read(fp,n)
  else writeln( '*** Error accessing: ',fname);
  n := Succ(n);
  rewrite(fp);
  writeln(fp,n);
  close(fp);
  Writeln('  SMTP msg: ',n);
  NxtMsg := n
end;

procedure Process;

var Line, fields : WorkString;
    Dest, From, At, Title, hostname, SMTPAddress, Day : String40;
    Home, ToLine, FromLine, MDate, MID : String40;
    condition : array[1..maxconds] of string[80];
    x,l,j,n,field : integer;
    ok, yes, Private, PrivateOK : boolean;

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;


function match( s1, s2 : string40 ) : boolean;

var i, j : integer;
    f, exclude : boolean;

begin
  if s1[1] = '!' then i := 2 else i := 1;
  f := true;
  j := 1;
  repeat
    if (s1[i] <> '*') and (s1[i] <> s2[j]) then f := false;
    i := succ(i);
    j := succ(j)
  until (j >= length(s2)) or (i >= length(s1));
  if s1[1] = '!' then f := not f;
  match := f
end;

procedure Lock( var fp : text; n : integer );

var fname : WorkString;

begin
  str(n,fname);
  fname := SMTPDir + fname + '.LCK';
  if not fopen(fp, fname, 'w') then begin
     writeln( '*** Error writing :', fname);
     close(fp);
     halt
  end;
  close(fp)
end;


procedure TxtOpen( var fp : text; n : integer );

var fname : Workstring;
begin
  str(n,fname);
  fname := SMTPDir + fname + '.TXT';
  if not fopen(fp,fname,'w')then begin
    writeln('*** Error accessing: ',fname);
    halt
  end
end;

procedure WrkOpen( var fp : text; n : integer );

var fname : workstring;

begin
  str( n, fname);
  fname := SMTPDIR + fname + '.WRK';
  if not fopen( fp, fname, 'w') then begin
    writeln('*** Error accessing: ', fname);
    halt
  end
end;

begin
  writeln('> Reading File: ', ParamStr(2));
  readln(CallsFP, Fields);
  while not EOF(CallsFP) do begin
    field := 1;
    hostname := '';
    SMTPAddress := '';
    repeat
      if Fields[1] <> ';' then begin
        if word(1, Fields) = 'host' then hostname := word(2, Fields);
        if word(1, Fields) = 'address' then SMTPAddress := word(2, Fields);
        if (word(1,Fields) = 'P') or (word(1,Fields) = 'B') then begin
           condition[field] := Fields;
           field := succ(field);
        end
      end;
      readln(CallsFP,Fields)
    until (word(1, Fields) = '***') or eof(CallsFP) or (field > maxconds);
    if field <= maxconds then condition[field] := '';

    reset(InFP);

    readln(InFP, Line);
    while not eof(InFP) do begin
      MDate := '';
      MID := '';
      From := '';
      Dest := '';
      Home := '';
      At := '';
      Title := '';
      ToLine := '';
      FromLine := '';
      while Line <> '' do begin
        if word(1, Line) = 'Date:' then MDate := Line;
        if word(1, Line) = 'Message-ID:' then MID := Line;
        if word(1, Line) = 'X-msgtype:' then
          Private := pos('P',Line)>0;
        if word(1, Line) = 'From:' then begin
          FromLine := Line;
            if pos('@', Line) > 0 then begin
              Line[pos('@', Line)]:= chr(32);
              Home := Word(3,Line)
            end else Home := '';
          From := Word(2, Line)
        end ;
        if Word(1, Line) = 'To:' then begin
          ToLine := Line;
          if pos('@', Line) > 0 then begin
            Line[pos('@', Line)] := chr(32);
            At := Word(3, Line)
          end else At := '';
          Dest := Word(2, Line)
        end ;
        if Word(1, Line) = 'Subject:' then
          Title := Line;
        readln(InFP,Line)
      end;

      Writeln( '> To: ', Dest, ' @ ', At, '  From: ', From, ' @ ', Home);

      Field := 1 ;
      ok := false;
      while (condition[field] <> '') AND (field <= Maxconds) and (NOT ok) do begin
        n := 2;
        PrivateOK := (word(1,condition[field]) = 'P');
        yes := ((Private = PrivateOK) or not Private);
        writeln('Condition: ',condition[field]);
        while yes and (n<words(condition[Field])) do begin
          if word(n, condition[field]) = '>' then
             yes := yes and match( word( n+1, condition[field] ), Dest);
          if word(n, condition[field]) = '@' then
             yes := yes and match( word( n+1, condition[field] ), At);
          if word(n, condition[field]) = '<' then
            yes := yes and match( word(n+1, condition[field]), From);
          n := n+2
        end;
        ok := yes;
        if ok then begin
          write('> Writing: > ',hostname,' @ ',SMTPAddress);
          n := NxtMsg;
          Lock(LckFP, n);
          TxtOpen( TxtFP, n );
          Writeln( TxtFP, IDText);
          If Mdate = '' then MDate := 'Date:' + Now ;
          Writeln( TxtFP, Mdate );
          If MID = '' then Writeln(TxtFP, 'Message-ID: <', n, '@', ParamStr(3), '>')
          else Writeln( TxtFP, MID );
          Writeln( TxtFP, FromLine);
          Writeln( TxtFP, ToLine);
          Line := 'Reply-to: ' + From;
          if Home <> '' then Line := Line + '%' + Home;
          Line := Line + '@' + ParamStr(3);
          Writeln( TxtFP, Line);
          If Title = '' then Title := 'Subject: Unknown' ;
          Writeln( TxtFP, Title);
          Readln(InFP,Line);
          Writeln(TxtFP);
          x := 6;
          while (pos('R:', Line)>0) and (not EOF(InFP)) do begin
            Day := '-'+copy(Line,3,11)+' ';
            Line := copy( Line, pos('@', Line)+1, length(Line)-pos('@',Line)-1);
            l := pos(' ',Line);
            if line[1] = ':' then j := 2 else j := 1;
            if x < 10 then Write(TxtFP,'Path: ') ;
            At := copy(Line, j, l-j);
            if At[1] = ':' then At := copy( At, 2, length(At)-1);
            Write( TxtFP, At, day);
            Readln(InFP,Line);
            x := x + length(Day) + l-j + 1;
            if x > 60 then begin
              writeln(TxtFP);
              x := 6
            end
          end;
          if x > 6 then Writeln( TxtFP);
          While (pos('/EX', Line)<>1) and (not EOF(InFP)) do begin
            writeln(TxtFP,Line);
            readln(InFP,Line)
          end;
          close(TxtFP);
          WrkOpen( WrkFP, n);
          Writeln( WRKFP, hostname );
          Writeln( WRKFP, From,'%',Home,'@',ParamStr(3) );
          writeln( WRKFP, SMTPAddress);
          close(WRKFP);
          erase(LckFP)
        end;
        field := succ(field);
      end;
      if not ok then
        repeat
          readln(InFP, Line)
        until eof(InFP) or (pos('/EX', Line)>0);
      readln(InFP,Line)
    end
  end
end;

begin
  writeln('G0BSX Mailbox -> SMTP General Purpose Server');
  writeln(Version);
  if ParamCount < 4 then begin
    writeln( '**** Not enough Parameters' );
    writeln( 'Usage: SMTPI ImportFile CallsFile hostID BBSCallsign');
    halt
  end;
  writeln( '> Opening file: ',Paramstr(1));
  if not fopen( InFP, ParamStr(1), 'r') then begin
    writeln('*** File: ',ParamStr(1),' not found');
    close(InFP);
    Halt
  end;
  writeln( '> Opening file: ', Paramstr(2));
  if not fopen( CallsFP, ParamStr(2), 'r') then begin
    writeln('*** File: ', ParamStr(2), ' not found');
    close(InFP);
    close(CallsFP);
    halt;
  end;
  writeln( 'G0BSX Mailbox > SMTP Import: ', Now );
  Process;
  close(InFP);
  writeln( '*** Erasing: ', Paramstr(1));
  erase(InFP);
  close(CallsFP);
  Writeln( '*** Done: ', Now )
end.