home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
HAM Radio 1
/
HamRadio.cdr
/
packet
/
g0bsx
/
smtpi.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1989-08-28
|
12KB
|
420 lines
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.