{$I DIRECT.INC}
{$M $DDDD,1200,8000}
Uses Dos,
Crt,
DosMem,
FileLock,
GenSubs,
ConfigRt,
GenTypes,
skashit;
Type FidoRec = Record
FromUserName : array[1..36] of char;
ToUsername : array[1..36] of char;
subject : array[1..72] of char;
DateTime : array[1..20] of char;
TimesRead,
DestNode,
OrigNode,
cost,
OrigNet,
DestNet : integer;
fill : array[1..4] of integer;
ReplyTo : integer;
Attrib : word;
NextReply : integer;
End;
Const Status : Array[1..12] Of String[3] = ('Jan','Feb','Mar','Apr','May',
'Jun','Jul','Aug','Sep','Oct','Nov','Dec');
{$I ANSIS.SKA}
Const FilesOpen : Boolean = FALSE;
Type BufArray = Array[1..$3000] Of Char;
Var FidoMail : File of FidoRec;
Header : Fidorec;
FHeader : Fidorec;
Infile : String[79];
Bul : Bulrec;
Board : Boardrec;
M : Message;
Mess : Text;
BDFile : File Of Boardrec;
BFile : File Of Bulrec;
Conf : Integer;
TFile : SStr;
MFile : SStr;
Filter : Boolean;
FilterA : Boolean;
ForceLF : Boolean;
Suppress : Boolean;
x1 : Integer;
Var LastTextFile,
LastMailFile : Lstr;
MailFile : File Of MailPtrRec;
TextFile : File Of Lstr;
Buf : ^BufArray;
Procedure Show(S : String);
Begin
gotoxy(3,wherey);
skawrite('|07.,:$½%'' |07'+S);
End;
Procedure ShowStats;
Begin
TextAttr:=7;show('processing area : '+board.boardName+'|CR');
If Suppress Then Exit;
show('tossing - current : ');
End;
Procedure AssignName(Txt,MailName : Sstr);
Var CurTextFile,
CurMailFile : Lstr;
Begin
CurTextFile := Cfg.TextDir + Txt;
CurMailFile := Cfg.Textdir + MailName;
If (CurTextFile <> LastTextFile) Or (CurMailFile <> LastMailFile)
Then Begin
If FilesOPEN THEN BEGIN
Close(TextFile);
Close(MailFile);
END;
Assign(TextFile,CurTextFile);
If Not Exist(CurTextFile)
Then Rewrite(TextFile)
Else Reset(TextFile);
Assign(MailFile,CurMailFile);
If Not Exist(CurMailFile)
Then Rewrite(MailFile)
Else Reset(MailFile);
FilesOPEN := TRUE;
End;
LastTextFile := CurTextFile;
LastMailFile := CurMailFile;
End;
Procedure Fidoin;
Var Mess : File;
Function NumBuls : Integer;
Begin
Numbuls := Filesize(BFile)
End;
Procedure SeekBFile (n:integer);
Var I : Integer;
Begin
Seek (BFile,N - 1);
I := IoRESULT;
End;
Procedure Addbul (var b:bulrec);
Var b2 : Bulrec;
Begin
If Numbuls = 0
Then b.id := 1
Else Begin
Seekbfile (NumBuls);
nRead (BFile,b2);
If b2.id = 65535
Then b.id := 1
Else B.id := b2.id+1
End;
B.SCANNED := TRUE;
SeekBFile (Numbuls + 1);
nWrite (bfile,b);
end;
Procedure Fix(VAR Str:String);
Begin
While (Str[ Length(Str) ] = #0) And (Length(Str) > 1)
Do Str[0] := Pred( Str[0] );
While (Str[ Length(Str) ] = #1) And (Length(Str) > 1)
Do Str[0] := Pred( Str[0] );
End;
Var BaseName,
Marker,
CurMsg,
Nt,
Cnt : Integer;
W,Z : String[255];
L : Lstr;
Total : Word;
CurrentChar : Longint;
BufPos,
EndBuf : Word;
Procedure CheckBuf;
Begin
If BufPos > EndBuf Then Begin
BufPos := 1;
NBlockRead(Mess,Buf^,$3000,EndBuf);
If Buf^[EndBuf] = #26
Then Begin
Buf^[EndBuf] := #0;
Dec(EndBuf);
End
End
End;
Function Get_Next_Line : String;
Var S,s1 : String;
Done : Boolean;
K : Char;
Begin
S[0] := #0;
Done := False;
Repeat
Done := EndBuf = 0;
If Done
Then K := #10
Else K := Buf^[BufPos];
Inc(BufPos);
CheckBuf;
Case K Of
#13 : Done := True;
#10 :;
Else S := S + K;
End;
Done := Done Or (EndBuf = 0);
Until (Done);
Get_Next_Line := S;
End;
Var X : Byte;
K : Char;
Mail : MailPtrRec;
Size : LongInt;
Begin
Dos_GetMem(Buf,$3000);
show('importing mail...|CR');
BaseName:=0;
Total:=0;
Assign(BdFile,Cfg.BoardDir + 'BOARDDIR.' + Strr(Conf));
Reset(BdFile);
Repeat
Seek(BdFile,BaseName);
NRead(BdFile,Board);
TextColor(9);
If (Board.EchoType = 2) AND (Length(Board.Fido_Dir) > 0) Then
Begin
ShowStats;
TFile := Board.ShortName + '.T' + Strr(Conf);
MFile := Board.ShortName + '.M' + Strr(Conf);
AssignName(TFile,MFile);
If Board.Fido_Dir[ Length(Board.Fido_Dir) ] <> '\'
Then Board.Fido_Dir := Board.Fido_Dir + '\';
Assign(Bfile,Cfg.BoardDir + Board.ShortName + '.' + Strr(Conf));
Reset(BFile);
CurMsg := 1;
While Exist(Board.Fido_Dir + Strr(CurMsg + 1) + '.MSG') Do
Begin
FillChar(Mail,SizeOf(Mail),0);
Size := FileSize(TextFile);
Mail.TextPtr := Size;
Seek(TextFile,Size);
Nt := 0;
CurrentChar := 1;
If Not Suppress Then Begin
GotoXy(23,11);
TextAttr:=7;
show(Strr(CurMsg+1)+'.msg has been imported..|CR');
End;
Inc(Total);
Assign(Mess,Board.Fido_Dir+Strr(CurMsg+1)+'.MSG');
Reset(Mess,1);
EndBuf := 0;
BufPos := 1;
CheckBuf;
Z := '';
For X := 1 to 36 Do Begin
Z := Z + Buf^[BufPos];
Inc(BufPos);
CheckBuf;
End;
Bul.Leftby := Z;
Fix(Bul.LeftBy);
Z := '';
For X := 1 to 36 Do Begin
Z := Z + Buf^[BufPos];
Inc(BufPos);
CheckBuf;
End;
Bul.SenTto := Z;
Fix(Bul.SentTo);
Z := '';
For X := 1 to 30 Do Begin
Z := Z + Buf^[BufPos];
Inc(BufPos);
CheckBuf;
End;
Bul.Title := Z;
Fix(Bul.Title);
While Buf^[BufPos] <> #13 Do Begin
Inc(BufPos);
CheckBuf;
End;
Inc(BufPos);
CheckBuf;
If Buf^[BufPos] <> #10
Then Begin
If BufPos > 1
Then Dec(BufPos);
End;
Bul.Status := 'Unknown';
Bul.When := Now;
Bul.Origin1 := '';
Bul.Origin2 := '';
Bul.Anon := False;
Bul.Recieved := False;
Bul.SCANNED := TRUE;
While (EndBuf > 0) Do
Begin
W := Get_Next_Line;
If Not (Copy(W,1,1) = #1) And
Not (Copy(W,1,7) = 'SEEN-BY') And
Not (Copy(W,1,4) = '--- ') And
Not (Copy(W,2,9) = '* Origin:') AND
Not (Pos(^A+'PID',W)>0) AND
Not (Pos(^A+'EPID',W)>0) AND
Not (Pos(^A+'EID',W)>0) AND
Not (Pos(^A+'MSGID',W)>0)
Then Begin
While (Length(W) > 79) Do
Begin
Marker := 69;
Repeat
Inc(Marker);
Until (Marker>78) or (W[Marker]=' ') or (W[Marker]=#27);
If (W[Marker]=#27)
Then Dec(Marker);
Inc(NT);
Delete( W, 1, Marker );
End;
L := W;
If (Mail.TotalLines > 0) Then Begin
Inc(Mail.TotalLines);
NWrite(TextFile,L);
End Else If L > '' Then Begin
Inc(Mail.TotalLines);
NWrite(TextFile,L);
End;
End Else
Begin
If (Copy(W,1,4)='--- ') Then Bul.Origin1 := W Else
If (Copy(W,1,9)=' * Origin') then Bul.Origin2 := W Else
If (Copy(W,2,8)='USERNOTE') then Begin
Bul.Status := (Copy(W,11,30));
Fix(Bul.Status);
End
End
End;
If Mail.TotalLines > 0 Then
Begin
If (Length(Bul.Origin1) < 1) Then Bul.Origin1 := '';
Size := FileSize(MailFile);
Seek(MailFile,Size);
NWrite(MailFile,Mail);
Bul.Line := Size;
Bul.PLevel := 0;
Bul.INF_Net := False;
Bul.Fidonet := True;
Bul.RealName := Bul.LeftBy;
AddBul(Bul);
End;
Inc(CurMsg);
Close(Mess);
Erase(Mess);
End;
Close(BFile);
WriteLn;
End;
Board.LastScan := Now;
Seek(BDFile,basename);
NWrite(BDFile,Board);
Inc(BaseName);
Until EOF(BDFile);
Close(BDFile);
TextAttr:=7;
Dos_FreeMem(Buf);
show('a total of '+strr(total)+' messages were imported..|CR');
End;
Procedure FidoOut;
Var Node,Net,Zone:Integer;
NodeA,NetA,ZoneA:String[10];
EndOL : String[2];
Procedure SplitUp;
Var INA,INB : Integer;
Begin
Ina := Pos(':',Board.Address);
inb := Pos('/',Board.Address);
ZoneA := Copy(Board.Address,1,ina-1);
Zone := Valu(ZoneA);
NetA := Copy(Board.Address,Ina+1,(Inb-Ina-1));
Net := Valu(NetA);
NodeA := Copy(Board.Address,(Inb+1),(Length(Board.Address)-Inb));
Node := Valu(NodeA);
End;
Function PadRight(Str:string;Size:byte;Pad:char):string;
var
temp : string;
L : integer;
begin
Fillchar(Temp[1],Size,Pad);
Temp[0] := chr(Size);
L := length(Str);
If L <= Size then
Move(Str[1],Temp[succ(Size - L)],L)
else
Move(Str[1],Temp[1],size);
PadRight := Temp;
End;
Function Last(N:byte;Str:string):string;
var Temp : string;
begin
If N > length(Str) then
Temp := Str
else
Temp := copy(Str,succ(length(Str) - N),N);
Last := Temp;
end; {Func Last}
Function MsgDateStamp : String; { Creates Fido standard- 01 Jan 89 21:05:18 }
Var h,m,s,hs : Word; { Standard message header time/date stamp }
y,mo,d,dow : Word;
Tmp,
o1,o2,o3 : String;
Begin
o1 := '';
o2 := '';
o3 := '';
tmp := '';
GetDate(y,mo,d,dow);
GetTime(h,m,s,hs);
o1 := PadRight(Strr(d),2,'0');
o2 := Status[mo];
o3 := Last(2,Strr(y));
Tmp := Concat( o1,' ',o2,' ',o3,' ');
o1 := PadRight(Strr(h),2,'0');
o2 := PadRight(Strr(m),2,'0');
o3 := PadRight(Strr(s),2,'0');
Tmp := Tmp + Concat(o1,':',o2,':',o3);
MsgDateStamp := Tmp;
End;
Function PadLeft(Str:string;Size:byte;Pad:char):string;
var temp : string;
begin
Fillchar(Temp[1],Size,Pad);
Temp[0] := chr(Size);
If Length(Str) <= Size then
Move(Str[1],Temp[1],length(Str))
else
Move(Str[1],Temp[1],size);
PadLeft := Temp;
end;
function netmessage : string;
Var Hdr:string;
Attr:Word;
Name:Mstr;
Begin
{If Board. Then Name:=Bul.RealName
Else}
Name:=Bul.LeftBy;
Attr:=($0100);
Hdr := '';
Hdr := PadLeft(Name,36,#0);
Hdr := Hdr + PadLeft(Bul.Sentto,36,#0)
+ PadLeft(Bul.Title,72,#0)
+ PadRight(msgdatestamp,19,' ')+ #0
+ Chr(Lo(0))+Chr(Hi(0)) {TimesRead}
+ Chr(Lo(1))+Chr(Hi(1)) {DestNode }
+ Chr(Lo(Node))+Chr(Hi(Node)) {OrigNode }
+ Chr(Lo(0))+Chr(Hi(0)) {Cost }
+ Chr(Lo(Net))+Chr(Hi(Net)) {OrigNet }
+ Chr(Lo(1))+Chr(Hi(1)) {DestNet }
+ #0#0#0#0#0#0#0#0
+ Chr(Lo(0))+Chr(Hi(0)) {ReplyTo }
+ Chr(Lo(Attr))+Chr(Hi(Attr)) {Attr }
+ Chr(Lo(0))+Chr(Hi(0)); {NextReply}
NetMessage := Hdr;
End;
Function IsOpen (Var FF) : Boolean;
Var FI : Fib Absolute FF;
Begin
IsOpen := Fi.Handle <> 0
End;
Procedure Textclose (Var F:Text);
Var N : Integer;
FI : Fib Absolute F;
begin
If IsOpen(f)
Then System.Close (f);
FI.Handle := 0;
N := IoResult
end;
Procedure PrintText (Sector : Longint);
Var N, MM : Integer;
P, B : Byte;
S, s1,A, CS, SB : String;
WorkStr : Lstr;
Mail : MailPtrRec;
Begin
AssignName(TFile,MFile);
Seek(MailFile,Sector);
NRead(MailFile,Mail);
Seek(TextFile,Mail.TextPtr);
Write(Mess,EndOL);
N := 1;
Repeat
nRead(TextFile,WorkStr);
MM := 0;
Repeat
If Length(WorkStr) > 0
Then Begin
P := 0;
Inc(MM);
S := Copy(WorkStr,MM,1);
If (S = '|') and (filter=true) then begin
delete(WorkStr,MM,3);
S:=Copy(WorkStr,MM,1);
end;
Write(Mess,S);
End;
Until MM >= Length(WorkStr);
Write(Mess,EndOL);
Inc(N);
Until (N > Mail.TotalLines);
End;
Var BaseName : Integer;
BDFile : File of BoardRec;
BFile : File Of BulRec;
CurMsg,
CNT,
NT : Integer;
Total : Word;
begin
show('beginning netmail exportation sequence..|CR');
basename:=0;
total:=0;
Assign(bdfile,Cfg.BoardDir + 'BOARDDIR.'+strr(conf));
Reset(bdfile);
EndOL := #13;
If ForceLF
Then EndOL := #13 + #10;
Repeat
Seek(bdfile,basename);
NRead(bdfile,board);
Curmsg := 0;
if (board.echotype > 1)
and (length(board.Fido_Dir) > 0) then begin
ShowStats;
TFile := Board.ShortName + '.T' + Strr(Conf);
MFile := Board.ShortName + '.M' + Strr(Conf);
If Board.Fido_Dir[ Length(Board.Fido_Dir) ] <> '\'
Then Board.Fido_Dir := Board.Fido_Dir + '\';
Assign(Bfile,Cfg.BoardDir+board.shortname+'.'+strr(conf));
Reset(Bfile);
Cnt := 0;
Nt := 0;
For CNT := 0 TO (FileSize(BFile) - 1)
Do BEGIN
Seek(Bfile,CNT);
NRead(Bfile,Bul);
IF NOT BUL.SCANNED THEN
BEGIN
Bul.Scanned := TRUE;
Seek(BFile,CNT);
NWrite(BFile,Bul);
Inc(NT);
If Not Suppress Then Begin
GotoXy(23,12);
TextAttr := 7;
show(Strr(Nt)+' exported to '+Strr(nt+1)+'.msg|CR');
End;
Inc(Total);
Assign(Mess,Board.Fido_Dir + Strr(NT + 1) + '.MSG');
Rewrite(Mess);
Write(mess,netmessage);
Write(mess,'MSGID: '+board.address+'.0');
Write(mess,'PID: iNFUSiON '+Versionnum);
Write(mess,EndOL);
Write(mess,'USERNOTE:'+Bul.Status+'');
Write(mess,#13);
PrintTEXT(bul.line);
Writeln(Mess,'');
Writeln(mess,'--- iNFUSiON BBS Software - MailTosser v1.0a');
If Board.OriginLine <> '' THEN
Writeln(mess,' * Origin: '+board.originline+' ('+Board.Address+')');
TextClose(Mess);
END;
END;
Writeln('');
Close(bfile);
END;
Board.LastScan := NOW;
Seek(BDFile,BaseName);
NWrite(BDFile,board);
Inc(basename);
Until EOF (Bdfile);
Close(Bdfile);
TextAttr := 7;
gotoxy(23,12);Write(#13#10);
TextAttr := 7;
Write(Total);
TextAttr := 7;
Writeln(' messages exported.');
END;
Procedure FidoPur;
var basename:integer;
bdfile:File of Boardrec;
cnt:integer;
found:boolean;
F : File;
Procedure DeleteRange(S_Dir : String);
VAR Index:SearchRec;
Str:Lstr;
F:File;
Begin
Str:=S_Dir + '*.MSG';
FindFirst(Str,Anyfile,Index);
If DosError <> 0 Then Exit;
While DosError = 0 Do Begin
{ If Index.Name <> '1.MSG' Then BEGIN }
Assign(F,S_Dir + Index.Name);
Erase(F);
{ END; }
FindNext(Index);
End;
End;
begin
show('removing all netmail files..|CR');
basename:=0;
Assign(bdfile,Cfg.BoardDir+'BOARDDIR.' + Strr(Conf));
Reset (bdfile);
repeat
seek(bdfile,basename);
NRead(bdfile,board);
if (board.echotype > 1) and (length(board.fido_dir) > 0) then begin
show('currently scanning '+Board.BoardName+'..|CR');
DeleteRange(Board.Fido_Dir);
end;
inc(basename);
until EOF(Bdfile);
close(Bdfile);
end;
Procedure HelpScreen;
Begin
show('valid infutoss parameters are as follows - ');
gotoxy(11,12);TextAttr:=7; Write('- ');
TextAttr:=7; Writeln('INFUTOSS [option] [conference(s) (default = 1)] ');
gotoxy(11,13);TextAttr:=7; Write('- ');
TextAttr:=7; Writeln('options - ');
Writeln;
gotoxy(11,15);TextAttr:=7; Write('IM - ');
TextAttr:=7; Writeln('import messages from fido dirs');
gotoxy(11,16);TextAttr:=7; Write('EX - ');
TextAttr:=7; Writeln('export new messages from fido bases into fido dirs');
gotoxy(11,17);TextAttr:=7; Write('DEL - ');
TextAttr:=7; Writeln('delete message files in the fido directories');
gotoxy(11,18);TextAttr:=7; Write('/F - ');
TextAttr:=7; Writeln('turns bar color filter on');
gotoxy(11,19);TextAttr:=7; Write('/A - ');
TextAttr:=7; Writeln('force linefeeds in outgoing messages');
gotoxy(11,20);TextAttr:=7; Write('/D - ');
TextAttr:=7; Writeln('dont display status');
Writeln;
End;
Var Total : Array[1..99] Of Byte;
Var X,By,TotalConf : Byte;
W : Word;
Which : Byte;
begin
FileMode:=66;
ClrScr;
LastTextFile[0] := #0;
LastMailFile := 'BLAH!';
FillChar(Total,SizeOf(Total),0);
TextAttr:=8;
move(header12,mem[$b800:0000],sizeof(header12));
Filter := False;
ForceLF := False;
Suppress:= False;
Textattr:=7;
gotoxy(8,9);writeln('infusion bbs software, netmail tosser (c)copyright skaboy101 1998');
If not ShareInstalled then begin
writeln;
show('error, share.exe must be installed for this program..|CR');
writeln;
halt;
end;
TextAttr:=8;
Writeln;
Readcfg(False);
If Conf < 1
Then Conf := 1;
Conf := 2;
TotalConf := 0;
By := 1;
Which := 0;
While ParamStr(By) <> '' Do Begin
If UpString(ParamStr(By)) = '/F'
Then Filter := True
Else If UpString(ParamStr(By)) = '/D'
Then Suppress := True
Else If UpSTring(ParamStr(By)) = '/L'
Then ForceLF := True
Else If UpString(ParamStr(By)) = 'IM'
Then Which := 1
Else If UpString(ParamStr(By)) = 'EX'
Then Which := 2
Else If UpString(ParamStr(By)) = 'DEL'
Then Which := 3
Else If Valu(ParamStr(By)) > 0
Then Begin
Total[Conf - 1] := Valu(ParamStr(By));
Inc(Conf);
Inc(TotalConf);
End;
Inc(By);
End;
If TotalConf <= 0 Then Begin
Total[1] := 1;
TotalConf := 1;
End;
Case Which Of
1 : Begin
For X := 1 to TotalConf
Do Begin
Conf := Total[X];
FidoIN;
End
End;
2 : Begin
For X := 1 to TotalConf
Do Begin
Conf := Total[X];
FidoOut;
End
End;
3 : Begin
For X := 1 to TotalConf
Do Begin
Conf := Total[X];
FidoPur;
End
End;
Else Begin
HelpScreen;
Halt(1);
End;
End;
Writeln;
Halt(0);
End.