home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / lan / g0bsx / smtpi.pas < prev    next >
Pascal/Delphi Source File  |  1989-08-28  |  12KB  |  420 lines
  1. program SMTPI ;
  2. { By Peter Meiring, G0BSX. All rights Reserved.                           }
  3. { Program to take input from a text file anmd convert it to SMTP messages }
  4. { according to instructions in a second file.                             }
  5. { usage syntax:                                                           }
  6. {   SMTP <import File> <List File> <mbox hostname> <mbox callsign>        }
  7. { Version 1.02: RFC822 compatible                                         }
  8.  
  9. const LineLength      = 255;
  10.       Version         = 'Version 1.02 (c) Peter Meiring, G0BSX, June 1988.';
  11.       CounterFilename = 'SEQUENCE.SEQ';
  12.       SMTPDir         = '\SPOOL\MQUEUE\';
  13.       IDText = '>> G0BSX  Mailbox->SMTP General Purpose Server.';
  14.       tab = #$09;
  15.       space = #$20;
  16.       maxconds = 50;
  17.  
  18. type WorkString = string[LineLength];
  19.      String40   = string[40];
  20.  
  21. var CurrentPath    : WorkString;
  22.     Counter        : integer;
  23.     TxtFilename, WrkFilename : String40 ;
  24.     CallsFP, InFP, LckFP, TxtFP, WrkFP    : text;
  25.  
  26.  
  27. function fopen(var fp : text; fname : WorkString; mode : char) : boolean;
  28.  
  29. begin
  30.   assign(fp,fname);
  31.   {$I-}
  32.   case mode of
  33.     'w', 'W' : rewrite(fp);
  34.     'r', 'R' : reset(fp);
  35.     'a', 'A' : append(fp)
  36.   end;
  37.   if IOResult <> 0 then begin
  38.     close(fp);
  39.     fopen := False;
  40.   end else
  41.     fopen := TRUE
  42.   {$I+}
  43. end;
  44.  
  45. function Now : String40;
  46.  
  47. type
  48.   regpack = record
  49.               ax,bx,cx,dx,bp,si,di,ds,es,flags: integer;
  50.             end;
  51.  
  52. var
  53.   recpack:          regpack;             {assign record}
  54.   ah,al,ch,cl,dh:   byte;
  55.   hour,min,sec,day:     string[2];
  56.   month, year:          string[4];
  57.   dx,cx,m :          integer;
  58.  
  59. begin
  60.   ah := $2c;                             {initialize correct registers}
  61.   with recpack do
  62.   begin
  63.     ax := ah shl 8 + al;
  64.   end;
  65.   intr($21,recpack);                     {call interrupt}
  66.   with recpack do
  67.   begin
  68.     str(cx shr 8,hour);                  {convert to string}
  69.     if length(hour) < 2 then hour := '0'+hour;
  70.     str(cx mod 256,min);                       { " }
  71.     if length(min) < 2 then min := '0'+min;
  72.     str(dx shr 8,sec);                         { " }
  73.     if length(sec) < 2 then sec := '0'+sec
  74.   end;
  75.   with recpack do
  76.   begin
  77.     ax := $2a shl 8;
  78.   end;
  79.   MsDos(recpack);                        { call function }
  80.   with recpack do
  81.   begin
  82.     str(cx,year);                        {convert to string}
  83.     str(dx mod 256,day);                     { " }
  84.     m := dx shr 8
  85.   end;
  86.   case m of
  87.     1 : month := 'Jan';
  88.     2 : month := 'Feb';
  89.     3 : month := 'Mar';
  90.     4 : month := 'Apr';
  91.     5 : month := 'May';
  92.     6 : Month := 'Jun';
  93.     7 : month := 'Jul';
  94.     8 : month := 'Aug';
  95.     9 : month := 'Sep';
  96.     10 : month := 'Oct';
  97.     11 : month := 'Nov';
  98.     12 : month := 'Dec'
  99.   end;
  100.   Now := day+' '+month+' '+copy(year, 3, 2)+'    '+hour+ ':'+min+':'+sec
  101. end;
  102.  
  103.  
  104. function word( n : integer; s : WorkString) : string40;
  105.  
  106. var c,p,q : integer;
  107.     t,a : WorkString;
  108.  
  109. begin
  110.   t := s;
  111.   for c := 1 to n do
  112.     if length(t) > 0 then begin
  113.       while (length(t) > 1) and ((t[1] = space)or(t[1] = Tab)) do
  114.         t := copy( t, 2, length(t)-1);
  115.       if (t = space) or (t = tab) then begin
  116.         t := '';
  117.         a := '';
  118.       end;
  119.       if t <> '' then
  120.         p := pos( space, t);
  121.         q := pos( tab, t);
  122.         if ((p > q) and (q > 0)) or ((q > p) and (p = 0)) then p := q;
  123.         if p <> 0 then begin
  124.           a := copy( t, 1, p-1);
  125.           t := copy( t, p+1, length(t) - p)
  126.         end else begin
  127.           a := t;
  128.           t := ''
  129.         end
  130.     end;
  131.   word := a
  132. end;
  133.  
  134. function words( s : workstring) : integer;
  135.  
  136. var n,c : integer;
  137.     white : boolean;
  138.  
  139. begin
  140.   white := true;
  141.   c := 0;
  142.   for n := 1 to length( s ) do begin
  143.     if (s[n] <> space) and (s[n] <> tab) and white then c := succ(c);
  144.     if (s[n] = space) or (s[n] = tab) then white := true else white := false
  145.   end;
  146.   words := c
  147. end;
  148.  
  149.  
  150. function NxtMsg : integer;
  151.  
  152. { Function to read the SMTP mailer sequence file, increment it amd return }
  153. { the number that can be used for the next SMTP mail file. }
  154.  
  155. var fp : text;
  156.     fname : WorkString;
  157.     n : integer;
  158.  
  159. begin
  160.   fname := SMTPDir + CounterFilename;
  161.   if fopen(fp, fname, 'r') then
  162.     read(fp,n)
  163.   else writeln( '*** Error accessing: ',fname);
  164.   n := Succ(n);
  165.   rewrite(fp);
  166.   writeln(fp,n);
  167.   close(fp);
  168.   Writeln('  SMTP msg: ',n);
  169.   NxtMsg := n
  170. end;
  171.  
  172. procedure Process;
  173.  
  174. var Line, fields : WorkString;
  175.     Dest, From, At, Title, hostname, SMTPAddress, Day : String40;
  176.     Home, ToLine, FromLine, MDate, MID : String40;
  177.     condition : array[1..maxconds] of string[80];
  178.     x,l,j,n,field : integer;
  179.     ok, yes, Private, PrivateOK : boolean;
  180.  
  181. function toUpper( str : WorkString ) : WorkString;
  182.  
  183. var i : integer;
  184.     t : Workstring;
  185.  
  186. begin
  187.   t := '';
  188.   for i := 1 to length(str) do
  189.     t := t + UpCase(str[i]);
  190.   ToUpper := t
  191. end;
  192.  
  193.  
  194. function match( s1, s2 : string40 ) : boolean;
  195.  
  196. var i, j : integer;
  197.     f, exclude : boolean;
  198.  
  199. begin
  200.   if s1[1] = '!' then i := 2 else i := 1;
  201.   f := true;
  202.   j := 1;
  203.   repeat
  204.     if (s1[i] <> '*') and (s1[i] <> s2[j]) then f := false;
  205.     i := succ(i);
  206.     j := succ(j)
  207.   until (j >= length(s2)) or (i >= length(s1));
  208.   if s1[1] = '!' then f := not f;
  209.   match := f
  210. end;
  211.  
  212. procedure Lock( var fp : text; n : integer );
  213.  
  214. var fname : WorkString;
  215.  
  216. begin
  217.   str(n,fname);
  218.   fname := SMTPDir + fname + '.LCK';
  219.   if not fopen(fp, fname, 'w') then begin
  220.      writeln( '*** Error writing :', fname);
  221.      close(fp);
  222.      halt
  223.   end;
  224.   close(fp)
  225. end;
  226.  
  227.  
  228. procedure TxtOpen( var fp : text; n : integer );
  229.  
  230. var fname : Workstring;
  231. begin
  232.   str(n,fname);
  233.   fname := SMTPDir + fname + '.TXT';
  234.   if not fopen(fp,fname,'w')then begin
  235.     writeln('*** Error accessing: ',fname);
  236.     halt
  237.   end
  238. end;
  239.  
  240. procedure WrkOpen( var fp : text; n : integer );
  241.  
  242. var fname : workstring;
  243.  
  244. begin
  245.   str( n, fname);
  246.   fname := SMTPDIR + fname + '.WRK';
  247.   if not fopen( fp, fname, 'w') then begin
  248.     writeln('*** Error accessing: ', fname);
  249.     halt
  250.   end
  251. end;
  252.  
  253. begin
  254.   writeln('> Reading File: ', ParamStr(2));
  255.   readln(CallsFP, Fields);
  256.   while not EOF(CallsFP) do begin
  257.     field := 1;
  258.     hostname := '';
  259.     SMTPAddress := '';
  260.     repeat
  261.       if Fields[1] <> ';' then begin
  262.         if word(1, Fields) = 'host' then hostname := word(2, Fields);
  263.         if word(1, Fields) = 'address' then SMTPAddress := word(2, Fields);
  264.         if (word(1,Fields) = 'P') or (word(1,Fields) = 'B') then begin
  265.            condition[field] := Fields;
  266.            field := succ(field);
  267.         end
  268.       end;
  269.       readln(CallsFP,Fields)
  270.     until (word(1, Fields) = '***') or eof(CallsFP) or (field > maxconds);
  271.     if field <= maxconds then condition[field] := '';
  272.  
  273.     reset(InFP);
  274.  
  275.     readln(InFP, Line);
  276.     while not eof(InFP) do begin
  277.       MDate := '';
  278.       MID := '';
  279.       From := '';
  280.       Dest := '';
  281.       Home := '';
  282.       At := '';
  283.       Title := '';
  284.       ToLine := '';
  285.       FromLine := '';
  286.       while Line <> '' do begin
  287.         if word(1, Line) = 'Date:' then MDate := Line;
  288.         if word(1, Line) = 'Message-ID:' then MID := Line;
  289.         if word(1, Line) = 'X-msgtype:' then
  290.           Private := pos('P',Line)>0;
  291.         if word(1, Line) = 'From:' then begin
  292.           FromLine := Line;
  293.             if pos('@', Line) > 0 then begin
  294.               Line[pos('@', Line)]:= chr(32);
  295.               Home := Word(3,Line)
  296.             end else Home := '';
  297.           From := Word(2, Line)
  298.         end ;
  299.         if Word(1, Line) = 'To:' then begin
  300.           ToLine := Line;
  301.           if pos('@', Line) > 0 then begin
  302.             Line[pos('@', Line)] := chr(32);
  303.             At := Word(3, Line)
  304.           end else At := '';
  305.           Dest := Word(2, Line)
  306.         end ;
  307.         if Word(1, Line) = 'Subject:' then
  308.           Title := Line;
  309.         readln(InFP,Line)
  310.       end;
  311.  
  312.       Writeln( '> To: ', Dest, ' @ ', At, '  From: ', From, ' @ ', Home);
  313.  
  314.       Field := 1 ;
  315.       ok := false;
  316.       while (condition[field] <> '') AND (field <= Maxconds) and (NOT ok) do begin
  317.         n := 2;
  318.         PrivateOK := (word(1,condition[field]) = 'P');
  319.         yes := ((Private = PrivateOK) or not Private);
  320.         writeln('Condition: ',condition[field]);
  321.         while yes and (n<words(condition[Field])) do begin
  322.           if word(n, condition[field]) = '>' then
  323.              yes := yes and match( word( n+1, condition[field] ), Dest);
  324.           if word(n, condition[field]) = '@' then
  325.              yes := yes and match( word( n+1, condition[field] ), At);
  326.           if word(n, condition[field]) = '<' then
  327.             yes := yes and match( word(n+1, condition[field]), From);
  328.           n := n+2
  329.         end;
  330.         ok := yes;
  331.         if ok then begin
  332.           write('> Writing: > ',hostname,' @ ',SMTPAddress);
  333.           n := NxtMsg;
  334.           Lock(LckFP, n);
  335.           TxtOpen( TxtFP, n );
  336.           Writeln( TxtFP, IDText);
  337.           If Mdate = '' then MDate := 'Date:' + Now ;
  338.           Writeln( TxtFP, Mdate );
  339.           If MID = '' then Writeln(TxtFP, 'Message-ID: <', n, '@', ParamStr(3), '>')
  340.           else Writeln( TxtFP, MID );
  341.           Writeln( TxtFP, FromLine);
  342.           Writeln( TxtFP, ToLine);
  343.           Line := 'Reply-to: ' + From;
  344.           if Home <> '' then Line := Line + '%' + Home;
  345.           Line := Line + '@' + ParamStr(3);
  346.           Writeln( TxtFP, Line);
  347.           If Title = '' then Title := 'Subject: Unknown' ;
  348.           Writeln( TxtFP, Title);
  349.           Readln(InFP,Line);
  350.           Writeln(TxtFP);
  351.           x := 6;
  352.           while (pos('R:', Line)>0) and (not EOF(InFP)) do begin
  353.             Day := '-'+copy(Line,3,11)+' ';
  354.             Line := copy( Line, pos('@', Line)+1, length(Line)-pos('@',Line)-1);
  355.             l := pos(' ',Line);
  356.             if line[1] = ':' then j := 2 else j := 1;
  357.             if x < 10 then Write(TxtFP,'Path: ') ;
  358.             At := copy(Line, j, l-j);
  359.             if At[1] = ':' then At := copy( At, 2, length(At)-1);
  360.             Write( TxtFP, At, day);
  361.             Readln(InFP,Line);
  362.             x := x + length(Day) + l-j + 1;
  363.             if x > 60 then begin
  364.               writeln(TxtFP);
  365.               x := 6
  366.             end
  367.           end;
  368.           if x > 6 then Writeln( TxtFP);
  369.           While (pos('/EX', Line)<>1) and (not EOF(InFP)) do begin
  370.             writeln(TxtFP,Line);
  371.             readln(InFP,Line)
  372.           end;
  373.           close(TxtFP);
  374.           WrkOpen( WrkFP, n);
  375.           Writeln( WRKFP, hostname );
  376.           Writeln( WRKFP, From,'%',Home,'@',ParamStr(3) );
  377.           writeln( WRKFP, SMTPAddress);
  378.           close(WRKFP);
  379.           erase(LckFP)
  380.         end;
  381.         field := succ(field);
  382.       end;
  383.       if not ok then
  384.         repeat
  385.           readln(InFP, Line)
  386.         until eof(InFP) or (pos('/EX', Line)>0);
  387.       readln(InFP,Line)
  388.     end
  389.   end
  390. end;
  391.  
  392. begin
  393.   writeln('G0BSX Mailbox -> SMTP General Purpose Server');
  394.   writeln(Version);
  395.   if ParamCount < 4 then begin
  396.     writeln( '**** Not enough Parameters' );
  397.     writeln( 'Usage: SMTPI ImportFile CallsFile hostID BBSCallsign');
  398.     halt
  399.   end;
  400.   writeln( '> Opening file: ',Paramstr(1));
  401.   if not fopen( InFP, ParamStr(1), 'r') then begin
  402.     writeln('*** File: ',ParamStr(1),' not found');
  403.     close(InFP);
  404.     Halt
  405.   end;
  406.   writeln( '> Opening file: ', Paramstr(2));
  407.   if not fopen( CallsFP, ParamStr(2), 'r') then begin
  408.     writeln('*** File: ', ParamStr(2), ' not found');
  409.     close(InFP);
  410.     close(CallsFP);
  411.     halt;
  412.   end;
  413.   writeln( 'G0BSX Mailbox > SMTP Import: ', Now );
  414.   Process;
  415.   close(InFP);
  416.   writeln( '*** Erasing: ', Paramstr(1));
  417.   erase(InFP);
  418.   close(CallsFP);
  419.   Writeln( '*** Done: ', Now )
  420. end.