PROGRAM WtrBina;

{ Dit programma kan binaries uit de news flow halen. Sluit een aantal }
{ newsgroups aan voor een 'dummy' user en geef bij dit programma op   }
{ waar die staan, hij scant de hele bende en eventueel met wat hulp   }
{ bouwt hij de originele archives weer.                               }

USES Ramon,
     Dos,     { SearchRec }
     Logs,    { DataStamp, TimeStamp }
     FBuffer,
     Msgs;

TYPE BinaConfigType = RECORD
                            InPath   : STRING[79];
                            MsgsPath : STRING[79];
                            OutPath  : STRING[79];
                            Expected : BYTE;
                      END;

VAR BinaConfig : BinaConfigType;
    Number     : LONGINT;


{--------------------------------------------------------------------------}
{ LogWriteMessage                                                          }
{                                                                          }
{ Deze routine schrijft een melding weg naar de logfile. Deze wordt        }
{ geopent, de melding geschreven en meteen weer gesloten om er zeker van   }
{ te zijn dat de tekst erin staat.                                         }
{                                                                          }
PROCEDURE LogWriteMessage (Tekst : STRING);

VAR LogFile : TEXT;
    IORes   : BYTE;

BEGIN
     Assign (LogFile,'WTRBINA.LOG');
     {$I-} Append (LogFile); {$I+} IORes:=IOResult;
     PeekFiles;
     IF (IORes = 2) THEN
     BEGIN
          {$I-} ReWrite (LogFile); {$I+} IORes:=IOResult;
          PeekFiles;
     END;

     IF (IORes = 4) THEN
        Error ('[LogMessage] Too many open files! Cannot write to log');

     IF (IORes = 0) THEN
     BEGIN
          WriteLn (LogFile,Tekst);
          Close (LogFile);
          PeekFiles;
     END;
END;


{--------------------------------------------------------------------------}
{ LogMessage                                                               }
{                                                                          }
{ Deze routine logt de opgegeven regel, met een DateTimeStamp ervoor.      }
{                                                                          }
PROCEDURE LogMessage (Tekst : STRING);
BEGIN
     LogWriteMessage (TimeStamp+' '+Tekst);
END;


{--------------------------------------------------------------------------}
{ LogExtraMessage                                                          }
{                                                                          }
{ Zelfde routine als LogMessage, alleen worden er nu spaties ter lengte    }
{ van de DateTimeStamp aan vooraf gezet.                                   }
{                                                                          }
PROCEDURE LogExtraMessage (Tekst : STRING);
BEGIN
     LogWriteMessage (Spaces (9)+Tekst);
END;


{--------------------------------------------------------------------------}
{ LogDiskIOError                                                           }
{                                                                          }
{ Met deze routine kan een melding van een disk I/O fout gemeld worden op  }
{ het scherm en in de log file. Het is geen critical error en de routine   }
{ zal dus gewoon terug keren.                                              }
{                                                                          }
PROCEDURE LogDiskIOError (IORes : BYTE; Tekst : STRING);

VAR Desc : STRING;

BEGIN
     CASE IORes OF
          2 : Desc:='File not found';
          ELSE Desc:='Unknown';
     END; { case }

     LogMessage (Tekst+' (dos='+Byte2String (IORes)+')');
END;


{--------------------------------------------------------------------------}
{ ReadBinaConfig                                                           }
{                                                                          }
{ Deze routine leest de config file voor WtrBina in (nu nog ascii) en      }
{ stopt de juiste gegevens in de juiste variabelen in het config record.   }
{                                                                          }
FUNCTION ReadBinaConfig : BOOLEAN;

VAR CfgFile : TEXT;
    IORes   : BYTE;
    Regel   : STRING[100];
    ID      : STRING[30];
    Nop     : INTEGER;

BEGIN
     WITH BinaConfig DO
     BEGIN
          InPath:='';
          OutPath:='';
     END; { with }

     Assign (CfgFile,'WTRBINA.CFG');
     {$I-} Reset (CfgFile); {$I+} IORes:=IOResult;
     PeekFiles;
     IF (IORes <> 0) THEN
     BEGIN
          Error ('Cannot open WTRBINA.CFG (dos='+Byte2String (IORes)+')');
          ReadBinaConfig:=FALSE; { error }
          Exit;
     END;

     WHILE (NOT Eof (CfgFile)) DO
     BEGIN
          ReadLn (CfgFile,Regel);

          IF (Regel <> '') AND (Regel[1] <> ';') THEN
          BEGIN
               IF (Pos ('=',Regel) = 0) THEN
                  Error ('"Identifier=" missing in line "'+Regel+'"')
               ELSE BEGIN
                    ID:=UpCaseString (Copy (Regel,1,Pos ('=',Regel)));
                    Delete (Regel,1,Pos ('=',Regel));

                    IF (ID = 'INPATH=') THEN
                    BEGIN
                         IF (Regel[Length (Regel)] <> '\') THEN
                            Regel:=Regel+'\';
                         BinaConfig.InPath:=UpCaseString (Regel);
                         ID:='';
                    END;

                    IF (ID = 'OUTPATH=') THEN
                    BEGIN
                         IF (Regel[Length (Regel)] <> '\') THEN
                            Regel:=Regel+'\';
                         BinaConfig.OutPath:=UpCaseString (Regel);
                         ID:='';
                    END;

                    IF (ID = 'MSGSPATH=') THEN
                    BEGIN
                         IF (Regel[Length (Regel)] <> '\') THEN
                            Regel:=Regel+'\';
                         BinaConfig.MsgsPath:=UpCaseString (Regel);
                         ID:='';
                    END;

                    IF (ID = 'EXPECTED=') THEN
                    BEGIN
                         Val (Regel,BinaConfig.Expected,Nop);
                         IF (Nop > 0) THEN
                         BEGIN
                              LogMessage ('Cannot evaluate EXPECTED value');
                              LogExtraMessage ('Set to default value 5');
                              BinaConfig.Expected:=5;
                         END;
                         ID:='';
                    END;

                    IF (ID <> '') THEN
                       Error ('Unknown identifier "'+ID+'"');
               END; { niet leeg; geen commentaar regel }
          END;
     END; { while }

     Close (CfgFile);
     PeekFiles;
     ReadBinaConfig:=TRUE; { geen error }
END;


{--------------------------------------------------------------------------}
{ ProcessDatFile                                                           }
{                                                                          }
PROCEDURE ProcessDatFile (Filename : STRING);

VAR Invoer     : FBufferType;
    Regel      : STRING;
    Newsgroups : STRING;
    Subject    : STRING;
    Expects    : WORD;
    InBody     : BOOLEAN;

PROCEDURE WriteMsg;

VAR MsgFile  : TEXT;
    EenRegel : EenRegelRecordPtr;
    Path     : STRING[91];
    IORes    : BYTE;

BEGIN
     Inc (Number);
     Path:=BinaConfig.MsgsPath+Longint2String (Number)+'.MSG';
     Assign (MsgFile,Path);
     {$I-} ReWrite (MsgFile); {$I+} IORes:=IOResult;
     PeekFiles;
     IF (IORes <> 0) THEN
     BEGIN
          LogDiskIOError (IORes,'Cannot create file '+Path);
          Exit;
     END;

     IF (Msg.HeaderTop_U <> NIL) THEN
     BEGIN
          EenRegel:=Msg.HeaderTop_U^.FirstRegelRecordPtr;
          WHILE (EenRegel <> NIL) DO
          BEGIN
               WriteLn (MsgFile,EenRegel^.RegelPtr^);
               EenRegel:=EenRegel^.NextRegelRecordPtr;
          END;
     END;

     IF (Msg.BodyTop <> NIL) THEN
     BEGIN
          EenRegel:=Msg.BodyTop^.FirstRegelRecordPtr;
          WHILE (EenRegel <> NIL) DO
          BEGIN
               WriteLn (MsgFile,EenRegel^.RegelPtr^);
               EenRegel:=EenRegel^.NextRegelRecordPtr;
          END;
     END;

     LogMessage ('Created '+Path);
     LogExtraMessage (Newsgroups);
     LogExtraMessage (Subject);

     Close (MsgFile);
     PeekFiles;
END;

{ProcessDatFile}
BEGIN
     FBufferOpen (Invoer,Filename,10*1024); { 10Kb cache buffer }

     MsgsEmpty;
     Expects:=0;

     WHILE (FBReadLn (Invoer,Regel) >= 0) DO
     BEGIN
          IF (Copy (Regel,1,8) = '#! rnews') THEN
          BEGIN
               IF (Expects >= BinaConfig.Expected) THEN
                  WriteMsg;

               MsgsEmpty;
               Newsgroups:='';
               Subject:='';
               InBody:=FALSE;
               Expects:=0;
          END ELSE
          BEGIN
               IF (NOT InBody) THEN
               BEGIN
                    MsgsAddLineTo (Header_U,Regel);

                    IF (UpCaseString (Copy (Regel,1,12)) = 'NEWSGROUPS: ') THEN
                       NewsGroups:=Regel;

                    IF (UpCaseString (Copy (Regel,1,9)) = 'SUBJECT: ') THEN
                       Subject:=Regel;

                    IF (Regel = '') THEN InBody:=TRUE;
               END ELSE
               BEGIN
                    MsgsAddLineTo (Body,Regel);
                    IF (Length (Regel) = 61) AND (Regel[1] = 'M') THEN
                       Inc (Expects);
               END;
          END;
     END; { while }

     FBufferClose (Invoer);

     IF (Expects >= BinaConfig.Expected) THEN
        WriteMsg;

     MsgsEmpty; { laatste bericht weggooien }
END;


{--------------------------------------------------------------------------}
{ ScanNewsFiles                                                            }
{                                                                          }
{ Deze routine 'leest' de niet gecunbatchte en ongecompresste .DAT files   }
{ in en gooit alle .XQT en .CMD files weg.                                 }
{                                                                          }
PROCEDURE ScanNewsFiles;

VAR Search : SearchRec;
    Ext    : STRING[3];
    AFile  : FILE;
    IORes  : BYTE;

BEGIN
     Message ('Scanning for binaires');

     FindFirst (BinaConfig.InPath+'*.*',Archive,Search);
     WHILE (DosError = 0) DO
     BEGIN
          Ext:=Copy (Search.Name,Pos ('.',Search.Name)+1,3);

          IF (Ext = 'DAT') THEN
             ProcessDatFile (BinaConfig.InPath+Search.Name);

          IF (Ext = 'XQT') OR (Ext = 'CMD') {OR (Ext = 'DAT')} THEN
          BEGIN
               Assign (AFile,BinaConfig.InPath+Search.Name);
               {$I-} Erase (AFile); {$I+} IORes:=IOResult;
               IF (IORes <> 0) THEN
                  LogDiskIOError (IORes,'Cannot delete file '+BinaConfig.InPath+Search.Name);
          END;

          FindNext (Search);
     END; { while }

     WindowPop; { message }
END;


{--------------------------------------------------------------------------}
{ FindHighestNumber                                                        }
{                                                                          }
{ Deze routine doorloopt de MsgsPath directory op zoek naar alle .MSG      }
{ files en kijkt daarna naar de filename. Het hoogste nummer hiervan wordt }
{ in de globale longint Number gezet. Deze wordt verhoogd en gebruikt voor }
{ de volgende file die moet worden geschreven.                             }
{                                                                          }
PROCEDURE FindHighestNumber;

VAR Search : SearchRec;
    Nr     : LONGINT;
    Nop    : INTEGER;

BEGIN
     Number:=0; { highest number }

     FindFirst (BinaConfig.MsgsPath+'*.MSG',Archive,Search);
     WHILE (DosError = 0) DO
     BEGIN
          Val (Copy (Search.Name,1,Pos ('.',Search.Name)-1),Nr,Nop);
          IF (Nop > 0) THEN
             Error ('Cannot convert '+Search.Name);

          IF (Nop = 0) AND (Nr > Number) THEN
             Number:=Nr;

          FindNext (Search);
     END;

     LogMessage ('Highest found .MSG file is '+Longint2String (Number));
END;


{--------------------------------------------------------------------------}
{ main                                                                     }
{                                                                          }

VAR Quit     : BOOLEAN;
    MenuAuto : KeyType;
    Param    : STRING[20];

    DelFile : FILE;
    IORes   : BYTE;
    Search  : SearchRec;

BEGIN
     OpenDesktop ('WtrBina','1.0 beta');

     MenuAuto:=kUnknown;
     IF (ParamCount = 1) THEN
     BEGIN
          Param:=UpCaseString (ParamStr (1));

          IF (Param = 'SCANNEWSFILES') THEN MenuAuto:=mOpt01;
     END;

     IF ReadBinaConfig THEN
     BEGIN
          LogExtraMessage ('');
          LogMessage ('WtrBina v1.0 beta started on '+DateStamp);

          FindHighestNumber;

          IF (MenuAuto = kUnknown) THEN
          BEGIN
               MenuDefine (30,7,'Main menu');
               MenuAddItem ('Scan news files');
               MenuAddItem ('Delete log etc');
               MenuAddItem ('Quit');
               MenuShow;
          END;

          Quit:=FALSE;
          REPEAT
                IF (MenuAuto <> kUnknown) THEN
                BEGIN
                     Key:=MenuAuto;
                     Quit:=TRUE;
                END ELSE
                    MenuSelect;

                CASE Key OF
                     mOpt01 : ScanNewsFiles;

                     mOpt02 : BEGIN
                                   Assign (DelFile,'WTRBINA.LOG');
                                   {$I-} Erase (DelFile); {$I+} IORes:=IOResult;

                                   FindFirst (BinaConfig.MsgsPath+'*.MSG',Archive,Search);
                                   WHILE (DosError = 0) DO
                                   BEGIN
                                        Assign (DelFile,BinaConfig.MsgsPath+Search.Name);
                                        {$I-} Erase (DelFile); {$I+} IORes:=IOResult;

                                        FindNext (Search);
                                   END;
                              END;

                     mOpt03,
                     kEsc   : Quit:=TRUE;
                END; { case }
          UNTIL Quit;

          IF (MenuAuto = kUnknown) THEN
             MenuErase;

          LogMessage ('End of run');
     END;

     CloseDesktop;
END.
