home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
lan
/
g0bsx
/
smtpx.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1989-08-28
|
7KB
|
241 lines
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.