home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / lan / g0bsx / smtpx.pas < prev    next >
Pascal/Delphi Source File  |  1989-08-28  |  7KB  |  241 lines
  1. program SMTPX ;
  2. { By Peter Meiring, G0BSX. All rights Reserved.                              }
  3. { Version 1.02: RFC822 compatible                                            }
  4. { This is a program will scan the SMTP Queue directory and extract files     }
  5. { Therein for importation into the mailbox.  It will search for a "callsign" }
  6. { in the TO field and, if found, will make that message PRIVATE, else it     }
  7. { will make it a public bulletin                                             }
  8. { The program requires 2 parameters, namely the Mailbox IMPORT filename and  }
  9. { the callsign of the Host Mailbox.                                          }
  10.  
  11. { file format: RQUEUE .TXT file. }
  12. { Received: from <hostid> by <hostid> with SMTP }
  13. {     id AA7750 ; <day>, <date> <time> GMT         }
  14. { Date: <day>, <date> <time> GMT                }
  15. { Message-Id: <<number>@<hostid>>               }
  16. { From: <user>@<hostid> <name>                  }
  17. { To: <user>@<bbs>@<hostid>                     }
  18. { Subject: Message Title                        }
  19. {                                               }
  20. { Message TEXT                                  }
  21.  
  22. const LineLength = 80;
  23.       Version    = 'Version 1.02 (c) Peter Meiring, G0BSX, June 1988.';
  24.  
  25. type WorkString = string[255];
  26.      String40   = string[40];
  27.  
  28. var CurrentPath : WorkString;
  29.     OutFP : text;
  30.     Line : WorkString;
  31.  
  32. function toUpper( str : WorkString ) : WorkString;
  33.  
  34. var i : integer;
  35.     t : Workstring;
  36.  
  37. begin
  38.   t := '';
  39.   for i := 1 to length(str) do
  40.     t := t + UpCase(str[i]);
  41.   ToUpper := t
  42. end;
  43.  
  44. procedure ProcessDirectory;
  45.  
  46. type
  47.   Char12arr            = array [ 1..12 ] of Char;
  48.   RegRec =
  49.     record
  50.       AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags : Integer;
  51.     end;
  52.  
  53. var
  54.   Regs                 : RegRec;
  55.   DTA                  : array [ 1..43 ] of Byte;
  56.   Mask                 : Char12arr;
  57.   NamR                 : String40;
  58.   Error, I             : Integer;
  59.   msgFP                : text;
  60.  
  61.  
  62. procedure Process( fname : String40 );
  63.  
  64. var ToCall, AtCall, TextFilename, LockFilename : String40;
  65.     ToLine, Xmsgtype : String40 ;
  66.     RXLine, DateLine, Subject : string[80];
  67.     InFP : text;
  68.     Bull : boolean;
  69.     Lines : array[1..7] of WorkString;
  70.     l, T1, T2, T3 : integer;
  71.  
  72. function IsCall( name : String40 ) : boolean;
  73.  
  74. var n : integer;
  75.     f,f1,f2,f3,f4 : boolean;
  76.  
  77. function IsAlpha( c : char ) : boolean;
  78. begin
  79.   if ((c <= 'Z') and (c >= 'A')) or ((c <= 'z') and (c >= 'a')) then
  80.     IsAlpha := TRUE
  81.   else
  82.     IsAlpha := FALSE
  83. end;
  84.  
  85. function IsNumber( c : char ) : boolean;
  86. begin
  87.   if (c >= '0') and (c <= '9') then
  88.     IsNumber := TRUE
  89.   else
  90.     IsNumber := FALSE
  91. end;
  92.  
  93. begin
  94.   f := (length(name) > 2);
  95.   f1 := IsAlpha(name[1]) and IsNumber(name[2]) and IsAlpha(name[3]);
  96.   f2 := IsAlpha(name[1]) and IsNumber(name[2]) and IsNumber(name[3])
  97.         and IsAlpha(name[4]);
  98.   f3 := IsAlpha(name[1])  and IsAlpha(name[2]) and IsNumber(name[3])
  99.         and IsAlpha(name[4]);
  100.   f4 := IsNumber(name[1]) and IsAlpha(name[2]) and IsNumber(name[3])
  101.         and IsAlpha(name[4]);
  102.   IsCall := f and (f1 or f2 or f3 or f4)
  103. end;
  104.  
  105. begin
  106.   LockFilename := copy( fname, 1, pos('.', fname)) + 'LCK';
  107.   TextFilename := copy( fname, 1, pos('.', fname)) + 'TXT';
  108.   Write( ' : ', fname);
  109.   assign( InFP, LockFilename);
  110.   {$I-}
  111.   reset(InFP);
  112.   if IOResult = 0 then begin
  113.     writeln( ' locked by SMTP');
  114.     close(InFP)
  115.   {$I+}
  116.   end else begin
  117.     assign(InFP, Textfilename);
  118.     reset(InFP);
  119.     repeat
  120.       readln(InFP,Line);
  121.       if pos('Received:', Line) = 1 then RXLine := Line;
  122.       if pos('Date:', Line) = 1 then DateLine := Line;
  123.       if pos('To:', Line)=1 then begin
  124.         Line := ToUpper(Line);
  125.         T1 := 5;
  126.         T2 := pos('%',Line);
  127.         T3 := pos('@',Line);
  128.         If T2 = 0 then begin
  129.           ToCall := copy(Line,T1,T3-T1);
  130.           AtCall := ParamStr(2)
  131.         end
  132.         else begin
  133.           AtCall := Copy(Line, T2+1, T3-T2-1);
  134.           ToCall := Copy(Line, T1, T2-T1)
  135.         end;
  136.         Writeln(OutFP, 'To: ', ToCall, '@', AtCall);
  137.         Xmsgtype := 'X-msgtype: ';
  138.         if IsCall( ToCall ) then
  139.           Xmsgtype := Xmsgtype + 'P'
  140.         else
  141.           Xmsgtype := Xmsgtype + 'B';
  142.         writeln(OutFP, Xmsgtype)
  143.       end
  144.       else
  145.         writeln(outFP, Line)
  146.     until Line = '' ;
  147.     Writeln(OutFP, '>> G0BSX General Purpose SMTP -> Mailbox Server.');
  148.     Writeln(OutFP, RXLine);
  149.     Writeln(OutFP, DateLine);
  150.     while not EOF(InFP) do begin
  151.       readln(InFP,Line);
  152.       writeln(OutFP,Line)
  153.     end;
  154.     Writeln(OutFP);
  155.     Writeln(OutFP,'/EX');
  156.     close(InFP);
  157.     erase(InFP);
  158.     assign(InFP,fname);
  159.     erase(InFP);
  160.   end
  161. end;
  162.  
  163.  
  164. begin
  165.   write('Processing');
  166.  
  167.   FillChar(DTA,SizeOf(DTA),0);        { Initialize the DTA buffer }
  168.   FillChar(Mask,SizeOf(Mask),0);      { Initialize the mask }
  169.   FillChar(NamR,SizeOf(NamR),0);      { Initialize the file name }
  170.  
  171.   Regs.AX := $1A00;         { Function used to set the DTA }
  172.   Regs.DS := Seg(DTA);      { store the parameter segment in DS }
  173.   Regs.DX := Ofs(DTA);      {   "    "      "     offset in DX }
  174.   MSDos(Regs);              { Set DTA location }
  175.   Error := 0;
  176.   Mask := '????????.???';    { Use message ONLY search }
  177.   Regs.AX := $4E00;          { Get first directory entry }
  178.   Regs.DS := Seg(Mask);      { Point to the file Mask }
  179.   Regs.DX := Ofs(Mask);
  180.   Regs.CX := 22;             { Store the option }
  181.   MSDos(Regs);               { Execute MSDos call }
  182.   Error := Regs.AX and $FF;  { Get Error return }
  183.   I := 1;                    { initialize 'I' to the first element }
  184.   if (Error = 0) then
  185.     repeat
  186.       NamR[I] := Chr(Mem[Seg(DTA):Ofs(DTA)+29+I]);
  187.       I := I + 1;
  188.     until not (NamR[I-1] in [' '..'~']) or (I>20);
  189.  
  190.   NamR[0] := Chr(I-1);          { set string length because assigning }
  191.                                 { by element does not set length }
  192.   while (Error = 0) do begin
  193.     Error := 0;
  194.     Regs.AX := $4F00;           { Function used to get the next }
  195.                                 { directory entry }
  196.     Regs.CX := 22;              { Set the file option }
  197.     MSDos( Regs );              { Call MSDos }
  198.     Error := Regs.AX and $FF;   { get the Error return }
  199.     I := 1;
  200.     repeat
  201.       NamR[I] := Chr(Mem[Seg(DTA):Ofs(DTA)+29+I]);
  202.       I := I + 1;
  203.     until not (NamR[I-1] in [' '..'~'] ) or (I > 20);
  204.     NamR[0] := Chr(I-1);
  205.     if (error = 0) and (pos('.WRK', NamR)>0) then
  206.       Process(NamR)
  207.   end;
  208.   close(OutFP);
  209.   writeln;
  210.   writeln('*** Done.')
  211. end;
  212.  
  213. begin
  214.   writeln('G0BSX  SMTP -> Mailbox General Purpose Server.');
  215.   writeln(Version);
  216.   if ParamCount < 2 then begin
  217.     Writeln( '*** Not enough Parameters');
  218.     Writeln( 'SMTPX usage: SMTPX mbxfilename mbxCallsign');
  219.     halt
  220.   end;
  221.   GetDIR(0,CurrentPath);
  222.   {$I-}
  223.   assign(OutFP,ParamStr(1));
  224.   append(OutFP);
  225.   if IOResult <> 0 then begin
  226.      rewrite(OutFP);
  227.      if IOResult <> 0 then begin
  228.        writeln('*** Error in opening ', ParamStr(1));
  229.        close(OutFP);
  230.        halt
  231.      end
  232.   end;
  233.   {$I+}
  234.   writeln( 'Output file open :', ParamStr(1));
  235.   ChDIR('\SPOOL\RQUEUE');
  236.   writeln( 'Current Directory : \SPOOL\RQUEUE');
  237.   ProcessDirectory;
  238.   ChDIR(CurrentPath);
  239.   writeln('Current Directory : ',CurrentPath);
  240.   close( OutFP )
  241. end.