Contributor: GAYLE DAVIS
{NEWSQWK.PAS}
{
Converts USENET files to QWK format ..
You'll need PKZIP to use this.
I use NXpress for my Newsgroup reader, in it saves it files with an
extension of .MBX. If you newsreader saves in someother format, then
change the extension default at the front of the program.
Perhaps you newsreader has a SAVEAS feature that allows you to download
all of the material and save it as a text file. If so, you could use it.
Just save the files as SOMEFILE.MBX in the same DIR as this program,
and it'll create the QWK file for you.
Gayle Davis 05/28/96
}
{$V-,S-,I-}
{$M 16384,0,655360} { no need to leave memory for PKZIP !!!
see the EXECUTE procedure below and find out how !!}
USES
Dos, Crt, Upper, RLine;
{ NOTE : Upper is in STRINGS.SWG
RLINE is in TEXTFILE.SWG }
CONST
ControlHdr : ARRAY [1..11] OF STRING [30] = (
{1} 'SOURCEWARE ARCHIVAL GROUP', { change this to whatever you want ! }
{2} 'Goshen', { ditto }
{3} '875-8133', { ditto }
{4} 'Gayle Davis', { ditto }
{5} '99999,SWAG', { ditto }
{6} '11-03-1993,04:41:37', { this will get updated automatically }
{7} 'SWAG Genius', { whatever pleases you ! }
{8} '', { QMAIL Menu name ??? }
{9} '0', { allways ZERO ??? }
{10} '0', { total number of messages in package }
{11} '0'); { number of conferences-1 here }
{ next is 0 , then first conference }
TYPE
BlockArray = ARRAY [1..128] OF CHAR;
CharArray = ARRAY [1..6] OF CHAR; { to read in chunks }
ControlArray = ARRAY [1..100] OF STRING [40]; { set to 100 conferences !!}
bsingle = array [0..4] of byte;
MSGDATHdr = RECORD
Status : CHAR;
MSGNum : ARRAY [1..7] OF CHAR;
Date : ARRAY [1..8] OF CHAR;
Time : ARRAY [1..5] OF CHAR;
UpTO : ARRAY [1..25] OF CHAR;
UpFROM : ARRAY [1..25] OF CHAR;
Subject : ARRAY [1..25] OF CHAR;
PassWord : ARRAY [1..12] OF CHAR;
ReferNum : ARRAY [1..8] OF CHAR;
NumChunk : CharArray;
Alive : BYTE;
LeastSig : BYTE;
MostSig : BYTE;
Reserved : ARRAY [1..3] OF CHAR;
END;
MBXHeader = RECORD
Xref : STRING[70];
Path : STRING;
From : STRING[70];
Subject : STRING[70];
Date : STRING[40];
Lines : WORD;
Status : CHAR;
END;
CONST
PKZIP : PathStr = 'PKZIP.EXE';
QWKFile : PathStr = 'NEWS.QWK';
VAR
MBXF : TEXT;
QWKF : FILE;
ControlF : TEXT;
FOL : FileOfLinesPtr;
FOLPos : LONGINT;
SavePath,
SwagPath,
MBXFn,
MsgFName : PATHSTR;
TR : SearchRec;
ConfNum,
Number : WORD; { message number, conference number }
MSGHdr : MSGDatHdr;
ch : CHAR;
count : INTEGER;
chunks : INTEGER;
ControlVal : ControlArray;
ControlIdx : BYTE;
ConfName,
WStr : STRING;
FUNCTION TrimL (InpStr : STRING) : STRING; ASSEMBLER;
ASM
PUSH DS
LDS SI, InpStr
XOR AX, AX
LODSB
XCHG AX, CX
LES DI, @Result
INC DI
JCXZ @@2
MOV BL, ' '
CLD
@@1 : LODSB
CMP AL, BL
LOOPE @@1
DEC SI
INC CX
REP MOVSB
@@2 : XCHG AX, DI
MOV DI, WORD PTR @Result
SUB AX, DI
DEC AX
STOSB
POP DS
END;
FUNCTION TrimR (InpStr : STRING) : STRING;
VAR i : INTEGER;
BEGIN
i := LENGTH (InpStr);
WHILE (i>= 1) AND (InpStr [i] = ' ') DO
i := i - 1;
TrimR := COPY (InpStr, 1, i)
END;
FUNCTION TrimB (InpStr : STRING) : STRING;
BEGIN
TrimB := TrimL (TrimR (InpStr) );
END;
FUNCTION PadR (InpStr : STRING; FieldLen : BYTE) : STRING;
{-Return a string right-padded to length len with ch}
VAR
o : STRING;
SLen : BYTE ABSOLUTE InpStr;
BEGIN
IF LENGTH (InpStr)>= FieldLen THEN
PadR := COPY (InpStr, 1, FieldLen)
ELSE BEGIN
o [0] := CHR (FieldLen);
MOVE (InpStr [1], o [1], SLen);
IF SLen < 255 THEN FILLCHAR (o [SUCC (SLen) ], FieldLen - SLen, #32); PadR := o; END; END; FUNCTION GoodNumber (S : STRING) : BOOLEAN; VAR Num : LONGINT; Code : WORD; BEGIN Num := 0; VAL (S, Num, Code); GoodNumber := ( (Code = 0) AND (Num> 0) AND (S> '') );
END;
FUNCTION IntStr (Num : LONGINT; Width : BYTE; Zeros : BOOLEAN) : STRING;
{ Return a string value (width 'w')for the input integer ('n') }
VAR
Stg : STRING;
BEGIN
STR (Num : Width, Stg);
IF Zeros THEN BEGIN
FOR Num := 1 TO Width DO IF Stg [Num] = #32 THEN Stg [Num] := '0';
END ELSE Stg := TrimL (Stg);
IntStr := Stg;
END;
FUNCTION GetStr (VAR InpStr : STRING; Delim : CHAR) : STRING;
VAR i : INTEGER;
BEGIN
i := POS (Delim, InpStr);
IF i = 0 THEN
BEGIN
GetStr := InpStr;
InpStr := ''
END ELSE
BEGIN
GetStr := COPY (InpStr, 1, i - 1);
DELETE (InpStr, 1, i)
END
END;
FUNCTION Str2LongInt (S : STRING; VAR I : LONGINT) : BOOLEAN;
{-Convert a string to an integer, returning true if successful}
VAR
code : WORD;
BEGIN
VAL (S, I, code);
IF code 0 THEN BEGIN
i := 0;
Str2LongInt := FALSE;
END ELSE
Str2LongInt := TRUE;
END;
FUNCTION GetNumber (VAR InpStr : STRING; Delim : CHAR) : LONGINT;
VAR S, S1 : STRING;
I : LONGINT;
BEGIN
I := 0;
S1 := InpStr;
S := GetStr (InpStr, Delim);
IF NOT GoodNumber (S) THEN InpStr := S1 ELSE
Str2LongInt (S, I);
GetNumber := I;
END;
FUNCTION NameOnly (FileName : PathStr) : PathStr;
{ Strip any path information from a file specification }
VAR
Dir : DirStr;
Name : NameStr;
Ext : ExtStr;
BEGIN
FSplit (FileName, Dir, Name, Ext);
NameOnly := Name;
END {NameOnly};
FUNCTION SlashDate(AddCentury : BOOLEAN) : STRING; {10/08/88}
VAR
MonthName, dayname, yearname, dayofweekname : WORD;
BEGIN
GETDATE (yearname, MonthName, dayname, dayofweekname);
IF AddCentury THEN
SlashDate := IntStr (MonthName, 2, TRUE) + '/' +
IntStr (dayname, 2, TRUE) + '/' +
IntStr (yearname, 4, TRUE) ELSE
SlashDate := IntStr (MonthName, 2, TRUE) + '/' +
IntStr (dayname, 2, TRUE) + '/' +
COPY (IntStr (yearname, 4, TRUE), 3, 2);
END;
FUNCTION PlainTime : STRING; {09:10:01}
VAR
Hr, Min, Sec, sec100 : WORD;
BEGIN
GETTIME (Hr, Min, Sec, sec100);
PlainTime := IntStr (Hr, 2, TRUE) + ':' +
IntStr (Min, 2, TRUE) + ':' +
IntStr (Sec, 2, TRUE);
END;
FUNCTION EraseFile ( S : PathStr ) : BOOLEAN ;
VAR F : FILE;
BEGIN
EraseFile := FALSE;
ASSIGN (F, S);
RESET (F);
IF IORESULT 0 THEN EXIT;
CLOSE (F);
ERASE (F);
EraseFile := (IORESULT = 0);
END;
PROCEDURE ReallocateMemory(P : POINTER); ASSEMBLER;
ASM
MOV AX, PrefixSeg
MOV ES, AX
MOV BX, WORD PTR P+2
CMP WORD PTR P,0
JE @OK
INC BX
@OK:
SUB BX, AX
MOV AH, 4Ah
INT 21h
JC @X
LES DI, P
MOV WORD PTR HeapEnd,DI
MOV WORD PTR HeapEnd+2,ES
@X:
END;
FUNCTION EXECUTE(Name : PathStr ; Tail : STRING) : WORD; ASSEMBLER;
ASM
{$IFDEF CPU386}
DB 66h
PUSH WORD PTR HeapEnd
DB 66h
PUSH WORD PTR Name
DB 66h
PUSH WORD PTR Tail
DB 66h
PUSH WORD PTR HeapPtr
{$ELSE}
PUSH WORD PTR HeapEnd+2
PUSH WORD PTR HeapEnd
PUSH WORD PTR Name+2
PUSH WORD PTR Name
PUSH WORD PTR Tail+2
PUSH WORD PTR Tail
PUSH WORD PTR HeapPtr+2
PUSH WORD PTR HeapPtr
{$ENDIF}
CALL ReallocateMemory
CALL SwapVectors
CALL DOS.EXEC
CALL SwapVectors
CALL ReallocateMemory
MOV AX, DosError
OR AX, AX
JNZ @OUT
MOV AH, 4Dh
INT 21h
@OUT:
END;
PROCEDURE FindPKZip;
VAR
S : PathStr;
BEGIN
S := FSearch ('PKZIP.EXE', GetEnv ('PATH') );
IF S = '' THEN
BEGIN
WriteLn(#7,'You GOTTA have PKZIP somewhere on your PATH to do this !!');
HALT(1);
END;
PKZIP := FExpand (S);
END;
PROCEDURE CleanUp;
{ clean up after ourselves }
BEGIN
FINDFIRST ('*.NDX', 21,ドル TR);
WHILE DosError = 0 DO
BEGIN
EraseFile(TR.NAME);
FINDNEXT (TR);
END;
EraseFile('MESSAGES.DAT');
EraseFile('CONTROL.DAT');
END;
PROCEDURE CreateControlDat;
VAR
I : BYTE;
BEGIN
ControlHdr [ 6] := SlashDate(TRUE)+','+PlainTime;
ControlHdr [10] := IntStr (Count, 5, FALSE);
ControlHdr [11] := IntStr (PRED (ConfNum), 3, FALSE);
ASSIGN (ControlF, 'CONTROL.DAT');
REWRITE (ControlF);
FOR I := 1 TO 11 DO
WRITELN (ControlF, ControlHdr [i]);
FOR I := 1 TO ControlIdx DO
WRITELN (ControlF, ControlVal [i]);
CLOSE (ControlF);
END;
PROCEDURE CreateMessageDat;
VAR
I : BYTE;
Buff : BlockArray;
BEGIN
FILLCHAR (ControlVal, SIZEOF (ControlVal), #0);
FILLCHAR (Buff, SIZEOF (Buff), #32);
FILLCHAR (MsgHdr, SIZEOF (MsgHdr), #32);
ConfNum := 0;
ControlIdx := 0;
Number := 0;
ASSIGN (QWKF, 'MESSAGES.DAT');
REWRITE (QWKF, SIZEOF (MsgHdr) );
WStr := 'NEWS TO QWK (c) 1996 GDSOFT';
FOR I := 1 TO LENGTH (WStr) DO Buff [i] := WSTR [i];
BLOCKWRITE (QwkF, Buff, 1);
END;
FUNCTION ArrayTOInteger (B : CharArray; Len : BYTE) : LONGINT;
VAR I : BYTE;
S : STRING;
E : INTEGER;
T : INTEGER;
BEGIN
S := '';
FOR I := 1 TO PRED (Len) DO IF B [i] #32 THEN S := S + B [i];
VAL (S, T, E);
IF E = 0 THEN ArrayToInteger := T;
END;
PROCEDURE GetNewsGroupHeader(VAR NGH : MBXHeader);
VAR
Junk : STRING;
BEGIN
WHILE POS('STATUS:',UpCaseStr(FOL^.LastLine)) = 0 DO
BEGIN
FOL^.SeekLine(FOLPos);
INC(FOLPos);
IF POS('XREF:',UpCaseStr(FOL^.LastLine))> 0 THEN
NGH.XRef := TrimB(COPY(FOL^.LastLine,6,$FF));
IF POS('PATH:',UpCaseStr(FOL^.Lastline))> 0 THEN
NGH.Path := TrimB(COPY(FOL^.LastLine,6,$FF));
IF POS('FROM:',UpCaseStr(FOL^.Lastline))> 0 THEN
NGH.From := TrimB(COPY(FOL^.LastLine,6,$FF));
IF POS('SUBJECT:',UpCaseStr(FOL^.Lastline))> 0 THEN
NGH.Subject := Trimb(COPY(FOL^.LastLine,9,$FF));
IF POS('DATE:',UpCaseStr(FOL^.Lastline))> 0 THEN
NGH.Date := Trimb(COPY(FOL^.LastLine,6,$FF));
IF POS('LINES:',UpCaseStr(FOL^.Lastline))> 0 THEN
BEGIN
Junk := GetStr(FOL^.LastLine,#32);
NGH.Lines := GetNumber(FOL^.LastLine,#32);
END;
IF POS('STATUS:',UpCaseStr(FOL^.Lastline))> 0 THEN
NGH.STATUS := 'S';
END;
END;
PROCEDURE ReadMessage(HdrPos : LONGINT);
VAR
HDR : MsgDatHdr;
Block : BlockArray;
EndPos : LONGINT;
Chunks : LONGINT;
J,K : INTEGER;
I,SFOL : LONGINT;
NS : STRING;
NGH : MBXHeader;
PROCEDURE MoveDataToBlock (Start, Len : BYTE; S : STRING; VAR Block : BlockArray);
VAR I, K : BYTE;
BEGIN
K := 0;
FOR I := Start TO PRED (Start + Len) DO
BEGIN
INC (k);
Block [i] := S [k];
END;
END;
PROCEDURE WriteHeader;
BEGIN
{ write the header out }
Seek(QwkF,HdrPos);
FillChar(Block,SizeOf(Block),#32);
MoveDataToBlock( 2, 7,PadR(IntStr(Number,7,FALSE),7),Block); { number }
MoveDataToBlock( 9, 8,SlashDate(FALSE),Block); { date }
MoveDataToBlock( 17, 5,PlainTime,Block); { Time }
MoveDataToBlock( 22,25,PadR(ControlHdr[4],25),Block); { To }
MoveDataToBlock( 47,25,PadR(NGH.FROM,25),Block); { From }
MoveDataToBlock( 72,25,PadR(NGH.Subject,25),Block); { Subj }
MoveDataToBlock( 97,20,PadR('IMPORT',20),Block); { Confname }
MoveDataToBlock(117, 6,PadR(IntStr(Chunks,6,FALSE),6),Block); { Numpacs }
MoveDataToBlock(124, 1,Chr(64),Block);
BlockWrite(QwkF,Block,1);
END;
PROCEDURE WriteBlock;
BEGIN
BLOCKWRITE (QwkF, Block, 1);
FILLCHAR (Block, SIZEOF (Block), #32);
INC (chunks); { increment block count }
k := 0;
END;
PROCEDURE ProcessLine;
VAR
c : BYTE;
BEGIN
FOR c := 1 TO LENGTH(FOL^.LastLine) DO
BEGIN
INC (k);
{
IF FOL^.LastLine [c] = #13 THEN
BEGIN
Block [k] := #227;
INC (c);
END ELSE Block [k] := FOL^.LastLine [c];
}
Block[k] := FOL^.Lastline[c];
IF k = 128 THEN WriteBlock;
END; { for }
{ write end of line }
INC(k);
Block[k] := #227;
IF k=128 THEN WriteBlock;
END;
BEGIN
SFOL := SUCC(FOLPos);
{ read the header block }
GetNewsGroupHeader(NGH);
{ fill QWK Header with info }
FILLCHAR (Block, SIZEOF (Block), #32);
FILLCHAR(Hdr,SizeOF(Hdr),#0);
{ write the header out }
chunks := 1; { number packs }
INC(Number); { update message number }
{ write the header to our QWK file }
WriteHeader;
{ write the blocks out }
K := 0;
FILLCHAR (Block, SIZEOF (Block), #32);
FOR I := FOLPos TO FOLPos + NGH.Lines DO
BEGIN
FOL^.SeekLine(i);
ProcessLine;
END;
J := I; { save the FOLPos for later }
{ write the original header out }
FOL^.LastLine := ' ';
ProcessLine;
FOL^.LastLine := 'Original Header:';
ProcessLine;
FOL^.LastLine := ' ';
ProcessLine;
FOR I := SFOL TO FOLPos DO
BEGIN
FOL^.Seekline(i);
ProcessLine;
END;
IF k> 0 THEN WriteBlock;
FOLPos := j; { update the position in the file }
EndPos := FilePos(QwkF);
{ update the header }
WriteHeader;
SEEK(QwkF, EndPos);
END;
PROCEDURE ProcessUseNetFile (FN : PathStr);
{ this is the heart !! Read messages from MBX file and save in QWK file }
VAR
ndxF : File;
b : bSingle;
r : REAL;
n : LONGINT;
{ converts TP real to Microsoft 4 bytes single .. GOOFY !!!! }
procedure real_to_msb (preal : real; var b : bsingle);
var
r : array [0 .. 5] of byte absolute preal;
begin
b [3] := r [0];
move (r [3], b [0], 3);
end; { procedure real_to_msb }
BEGIN
WriteLn('Process .. ',FN);
{ create the NDX file }
ASSIGN (ndxF,IntStr(ConfNum,3,TRUE)+'.NDX');
REWRITE (ndxF,1);
WHILE (FOLPos < FOL^.Totallines) DO BEGIN n := SUCC(FilePos(QwkF)); { ndx wants the RELATIVE position } r := N; { make a REAL } REAL_TO_MSB(r,b); { convert to MSB format } BLOCKWRITE(ndxF,B,SizeOf(B)); { store it } WriteLn('Process message .. ',IntStr(Number+1,5,FALSE)); ReadMessage(PRED(n)); INC(Count); END; CLOSE (NdxF); { update the CONTROL file array } INC (ControlIdx); ControlVal [ControlIdx] := IntStr (ConfNum, 3, TRUE); INC (ControlIdx); ControlVal [ControlIdx] := ConfName; INC (ConfNum); END; PROCEDURE GetConferenceName; VAR Junk : STRING; BEGIN WHILE POS('NEWSGROUPS:',UpCaseStr(FOL^.LastLine)) = 0 DO BEGIN FOL^.SeekLine(FOLPos); INC(FOLPos); END; Junk := GetStr(FOL^.LastLine,' '); ConfName := TrimB(FOL^.Lastline); FOLPos := 1; END; BEGIN ClrScr; IF ParamCount> 0 THEN MBXfn := FExpand(ParamStr(1)) ELSE MBXfn := '*.MBX';
EraseFile(QWKFile); { make sure we don't have one yet }
FindPkZip;
CreateMessageDat;
Count := 0; { total messages in package }
{ process all the files that we find with the extension }
FINDFIRST (MBXFn, 21,ドル TR);
WHILE DosError = 0 DO
BEGIN
NEW(FOL, Init(TR.Name, 1024));
FOLPos := 1; { current position in RLINE array }
GetConferenceName;
ProcessUseNetFile (TR.Name);
DISPOSE (FOL, Done);
FindNext(TR);
END;
CLOSE (QwkF);
CreateControlDat;
Execute(PKZIP,' -ex '+QWKFile+' *.NDX MESSAGES.DAT CONTROL.DAT');
CleanUp;
END.