UNIT PackBase;

{$i platform.inc}

{ deze unit bevat alle code om de databases te packen. Ze worden nu met }
{ z'n drieen tegelijk aangemaakt en onderweg nog even gesorteerd.       }

INTERFACE

PROCEDURE UtilPackBases (Automatic : BOOLEAN);

VAR ForceNoSort : BOOLEAN;


IMPLEMENTATION

USES Tdb,
     Database,
     Logs,
     Ramon,
     Cfg,
     Fido,
     Slice,
     FlexTdb,
     DupeChk;

CONST Xb  = 5;
      Yb  = 2;
      Xl  = 70;
      Yl  = 14;
      Xb2 = 45;
      Xl2 = 29;

      AreaYb = Yb+1;
      UserYb = Yb+6;
      ListYb = Yb+10;
      CfgYb  = Yb+11;
      DupeYb = Yb+12;

CONST MapRecordsPerArray = 4096; { veelvoud van twee, optimaliseert DIV en MOD }
      MapArrays          = 65536 DIV MapRecordsPerArray;

TYPE NamesBlock    = ARRAY[1..61440] OF CHAR;
     NamesBlockPtr = ^NamesBlock;

     MapRecord    = RECORD
                          RecNr   : WORD; { NILRecordNr = Deleted }
                          NamePtr : ^STRING;
                    END;

     MapRecordPtr = ^MapRecord;

     MapArray     = ARRAY[0..MapRecordsPerArray-1] OF MapRecord;
     MapArrayPtr  = ^MapArray;

VAR NewAreaBaseTdbNr,
    NewUserBaseTdbNr,
    NewSubscrBaseTdbNr : TdbNrType;

    OldAreaRecCount    : WORD;
    NewAreaRecCount    : WORD;
    PartNameLen        : BYTE;
    AreaDataTable      : ARRAY[0..MapArrays-1] OF MapArrayPtr;

    NameCount          : BYTE;
    NameLengths        : ARRAY[1..10] OF WORD;
    NamePtrs           : ARRAY[1..10] OF NamesBlockPtr;


{--------------------------------------------------------------------------}
{ RecoverFromOversizedAreaBase                                             }
{                                                                          }
{ Deze routine zorgt ervoor dat het juiste aantal records voor een area    }
{ base hersteld wordt.                                                     }
{                                                                          }
PROCEDURE RecoverFromOversizedAreaBase;

VAR Lp       : WORD;
    NewAreas : WORD;
    NulCount : BYTE;
    AreaRec  : AreaBaseRecord;

BEGIN
     IF (AreaBaseRecCount <> 65535) THEN
        Exit;

     Message ('Oversized AreaBase; searching real record count');

     { NILRecordNr aantal records; dat kan niet!  }
     { zoek uit hoeveel records er eigenlijk zijn }
     NewAreas:=0;
     NulCount:=0; { misbruik: kappen bij 10 }

     { alles alle records in totdat er een NUL record volgt }
     FOR Lp:=1 TO 65534 DO
     BEGIN
          ReadAreaBaseRecord (Lp,AreaRec);

          IF (Byte (AreaRec.Deleted) < 2) AND
             (Byte (AreaRec.Passive) < 2) AND
             (Byte (AreaRec.AllowPassive) < 2) AND
             (Length (AreaRec.AreaName_U) <= MaxLenAreaName) AND
             (Length (AreaRec.AreaName_F) <= MaxLenAreaName) AND
             (Length (AreaRec.Comment) <= MaxLenComment) THEN
          BEGIN
               Inc (NewAreas);
               NulCount:=0;
          END ELSE
          BEGIN
               Inc (NulCount);
               IF (NulCount = 10) THEN
                  Break; { 10 achter elkaar niet goed; kappen }
          END;
     END; { for }

     { areabase afkappen op NewAreas aantal records }
     TdbCut (AreaBaseTdbNr,NewAreas);

     WindowPop;
END;


{---------------------------------------------------------------------------}
{ InitAreaDataTable                                                         }
{                                                                           }
{ Deze routine vraagt het geheugen aan voor de mapping table waarmee de     }
{ oude area base record nummers straks naar de nieuwe nummers omgezet       }
{ kunnen worden. Als de user afbreekt met Escape, dan wordt TRUE terug      }
{ gegeven.                                                                  }
{                                                                           }
FUNCTION InitAreaDataTable : BOOLEAN;

VAR BigBlocks : BYTE;
    LeftOver  : WORD;
    Lp        : WORD;
    AreaRec   : AreaBaseRecord;
    MaxHelp   : LONGINT;
    ToCopy    : WORD;
    MaxCopy   : WORD;  { maximum aantal tekens van de AreaRec.AreaName }
                       { die gekopieerd kunnen worden. Wordt continue  }
                       { bijgesteld.                                   }
    StorePos  : WORD;
    PercDone  : BYTE;

BEGIN
     OldAreaRecCount:=AreaBaseRecCount;

     { bereken hoeveel volle blokken van 4096 er nodig zijn }
     { het resultaat van beide berekeningen is 0-based! }
     BigBlocks:=OldAreaRecCount DIV MapRecordsPerArray;
     LeftOver:=OldAreaRecCount MOD MapRecordsPerArray;

     { vraag deze nu allemaal aan }
     IF (BigBlocks > 0) THEN
        FOR Lp:=0 TO BigBlocks-1 DO
            GetMem (AreaDataTable[Lp],SizeOf (MapArray));

     IF (LeftOver <> 0) THEN
        GetMem (AreaDataTable[BigBlocks],SizeOf (MapRecord)*(LeftOver+1));

     NameCount:=1;
     NameLengths[NameCount]:=61440;
     IF ((_MaxAvail-5000) < NameLengths[NameCount]) THEN
        NameLengths[NameCount]:=_MaxAvail-5000;

     GetMem (NamePtrs[NameCount],NameLengths[NameCount]);

     StorePos:=1;

     { lees nu alle benodigde gegevens van de areas in }
     FOR Lp:=1 TO OldAreaRecCount DO
     BEGIN
          { reken uit hoeveel tekens van de area naam van de nog te  }
          { verwerken records er maximaal opgeslagen kunnen worden,  }
          { inclusief de lengte byte. Dit wordt continue bijgesteld, }
          { zodat lange namen dit aantal omlaag brengen en korte     }
          { namen dit aantal omhoog halen.                           }

          { de berekening is als volgt: het geheugen dat nog vrij is, }
          { plus het geheugen dat we nog vrij hebben maar al wel      }
          { aangevraag hebben en dat gedeeld door het aantal records  }
          { dat we nog moeten verwerken.                              }

          IF ((NameLengths[NameCount]-StorePos) > 256) THEN
             MaxCopy:=256
          ELSE BEGIN
               MaxHelp:=((_MemAvail-5000)+(NameLengths[NameCount]-StorePos)) DIV (OldAreaRecCount-Lp+1);
               IF (MaxHelp > 256) THEN
                  MaxCopy:=256
               ELSE
                   MaxCopy:=MaxHelp;
          END;

          ReadAreaBaseRecord (Lp,AreaRec);

          IF ((Lp MOD 25) = 1) THEN
          BEGIN
               PercDone:=Round ((Lp/OldAreaRecCount)*100);
               WriteXYC (Xb2,AreaYb+1,cBoxData,Word2String (Lp)+'/'+Word2String (OldAreaRecCount)+
                                               ' ('+Byte2String (PercDone)+'%)');
               Slice_Now;
          END;

          IF KeyPressed AND (ReadKey = kEsc) THEN
          BEGIN
               InitAreaDataTable:=TRUE;
               Exit;
          END;

          WITH AreaDataTable[Lp DIV MapRecordsPerArray]^[Lp MOD MapRecordsPerArray] DO
          BEGIN
               IF (AreaRec.Deleted) THEN
               BEGIN
                    RecNr:=NILRecordNr;
                    NamePtr:=NIL;
               END ELSE
               BEGIN
                    RecNr:=Lp;

                    ToCopy:=Length (AreaRec.AreaName_F)+1{lengte byte};
                    IF (ToCopy > MaxCopy) THEN
                       ToCopy:=MaxCopy;

                    { kijk of er nog ruimte genoeg voor is }
                    IF ((NameLengths[NameCount]-StorePos) < ToCopy) THEN
                    BEGIN
                         { naam, vraag een nieuw geheugen blok aan, }
                         { zo groot mogelijk.                       }
                         Inc (NameCount);

                         NameLengths[NameCount]:=61440;
                         IF ((_MaxAvail-5000) < NameLengths[NameCount]) THEN
                            NameLengths[NameCount]:=_MaxAvail-5000;

                         GetMem (NamePtrs[NameCount],NameLengths[NameCount]);

                         StorePos:=1;
                    END;

                    NamePtr:=Addr (NamePtrs[NameCount]^[StorePos]);

                    Move (AreaRec.AreaName_F,NamePtr^,ToCopy);

                    Inc (StorePos,ToCopy);
               END; { not deleted }
          END; { with }
     END; { for }

     WriteXYC (Xb2,AreaYb+1,cBoxData,Word2String (OldAreaRecCount)+' records, '+
                                     Longint2String (_MemAvail DIV 1024)+'Kb free');

     InitAreaDataTable:=FALSE; { niet afgebroken door de user }
END;


{--------------------------------------------------------------------------}
{ DestroyAreaDataTable                                                     }
{                                                                          }
{ Deze routine ruimt de AreaDataTable en NameBlocks weer op door al het    }
{ geheugen weer vrij te gegeven.                                           }
{                                                                          }
PROCEDURE DestroyAreaDataTable;

VAR Lp,
    BigBlocks : BYTE;
    LeftOver  : WORD;  { RAWI 970621: was BYTE }

BEGIN
     { het resultaat van beide berekeningen is 0-based! }
     BigBlocks:=OldAreaRecCount DIV MapRecordsPerArray;
     LeftOver:=OldAreaRecCount MOD MapRecordsPerArray;

     IF (BigBlocks > 0) THEN
        FOR Lp:=0 TO BigBlocks-1 DO
            FreeMem (AreaDataTable[Lp],SizeOf (MapArray));

     IF (LeftOver <> 0) THEN
        FreeMem (AreaDataTable[BigBlocks],SizeOf (MapRecord)*(LeftOver+1));

     { geef nu de geheugen blokken vrij waarin de namen opgeslagen }
     { staan. Dit doen we nadat de pointers naar deze blokken      }
     { verwijderd zijn.                                            }
     FOR Lp:=1 TO NameCount DO
         FreeMem (NamePtrs[Lp],NameLengths[Lp]);

     NameCount:=0;
END;


{--------------------------------------------------------------------------}
{ CheckForDuplicateAreas                                                   }
{                                                                          }
{ This routine checks for duplicate area definitions. If found, it tries   }
{ to decide which is the active one and which is not and deletes the right }
{ one. The decision is based on attached message base and subscribed       }
{ users. All activity is logged. If it cannot decide, it logs this and the }
{ sysop will have to go in and decide.                                     }
{ Returns TRUE when aborted by the user, otherwise FALSE (even when there  }
{ was not enough memory to perform the dupe check).                        }
{                                                                          }
FUNCTION CheckForDuplicateAreas : BOOLEAN;

TYPE IndexArray    = ARRAY[1..16383] OF LONGINT;
     IndexArrayPtr = ^IndexArray;

VAR AreaCount : WORD;

    {----------------------------------------------------------------------}
    { SearchIndex                                                          }
    {                                                                      }
    { This routine searches through the AreaCount entries in the given     }
    { index for the given CRC value. If found, the index is returned.      }
    { By changing the index value of the area itself before calling, a hit }
    { on that entry is avoided and the dupe is returned. NILRecordNr is    }
    { returned when nothing is found.                                      }
    {                                                                      }
    FUNCTION SearchIndex (IndexPtr : IndexArrayPtr; Value : LONGINT) : WORD;

    VAR RecNr : WORD;
        Lp    : WORD;

    BEGIN
         RecNr:=NILRecordNr; { = Not Found }

         FOR Lp:=1 TO AreaCount DO
             IF (IndexPtr^[Lp] = Value) THEN
             BEGIN
                  RecNr:=Lp;
                  Break;
             END; { for }
         (*
         {$ELSE}
         ASM
            LES DI,IndexPtr           { adres van het buffer ophalen }
            MOV CX,AreaCount          { aantal te doorzoeken }
            SHL CX,1                  { *2 omdat we in words zoeken }

            LEA SI,Value              { hierop controleren }
            SEGSS MOV AX,[SI]         { bx:ax laden met de CRC }
            SEGSS MOV BX,[SI+2]

            CLD                       { vooruit zoeken }
          @Cont:
            REPNE SCASW               { zoek naar AX }
            JCXZ @NotFound            { einde tabel, niet gevonden dus }

            PUSH AX               { wel gevonden, kijk of we aan het begin van }
            MOV AX,DI             { een longint staan, dan is het verkeerd. }
            AND AL,3              { Omdat SCASW altijd verhoogd controleren we }
            POP AX                { dus of we NU WEL aan het begin staan, dan }
                                  { stonden we het bij de controle niet. }
            JE @Cont              { niet aan het begin, zoek verder }

            CMP BX,ES:[DI]            { kijk of het tweede deel ook klopt }
            JNE @Cont                 { nee, zoek verder }

          @Found:
            SHR CX,1                  { terug van words naar longints }
            MOV AX,AreaCount          { bereken de offset in de tabel }
            SUB AX,CX
            MOV RecNr,AX              { geef het record nummer terug }

          @NotFound:
         END;
         {$ENDIF}
         *)

         SearchIndex:=RecNr;
    END;

    {----------------------------------------------------------------------}
    { ResolveDupe                                                          }
    {                                                                      }
    { This routine tries to solve the duplicate situation by working out   }
    { which one must be deleted. It looks at the existance of a message    }
    { base and the subscribed users.                                       }
    {                                                                      }
    { Decision table:                                                      }
    {                                                                      }
    { Case                                          Action                 }
    {      UserList1   UserList2   MsgBase1   MsgBase2                     }
    { ---- ----------- ----------- ---------- ---------- --------          }
    { 1    NILRecordNr NILRecordNr =MsgBase2  x          Delete 2          }
    { 2    NILRecordNr NILRecordNr Used       NONE       Delete 2          }
    { 3    NILRecordNr NILRecordNr NONE       Used       Delete 1          }
    { 4    Used        NILRecordNr =MsgBase2  x          Delete 2          }
    { 5    NILRecordNr Used        =MsgBase2  x          Delete 1          }
    { 6    Used        Used        =MsgBase2  x          Merge Users; Del2 }
    {                                                                      }
    { The RecNr of the area to delete is returned. NILRecordNr is returned }
    { when the dupe case could not be resolved.                            }
    {                                                                      }
    FUNCTION ResolveDupe (RecNr1,RecNr2 : AreaBaseRecordNrType) : AreaBaseRecordNrType;

    VAR Rec1,
        Rec2   : AreaBaseRecord;
        FDupe,
        RDupe  : BOOLEAN;
        Desc   : STRING[20];
        Search : SubscrSearchRecord;

    BEGIN
         {LogMessage ('Resolve: '+Word2String (RecNr1)+' and '+Word2String (RecNr2));}

         ReadAreaBaseRecord (RecNr1,Rec1);
         ReadAreaBaseRecord (RecNr2,Rec2);

         IF (Rec1.UserList = NILRecordNr) AND (Rec2.UserList = NILRecordNr) THEN
         BEGIN
              { case 1 }
              IF (Rec1.FidoMsgStyle = Rec2.FidoMsgStyle) THEN
              BEGIN
                   ResolveDupe:=RecNr2;
                   Exit;
              END;

              { case 2 }
              IF (Rec2.FidoMsgStyle = NoneType) THEN
              BEGIN
                   ResolveDupe:=RecNr2;
                   Exit;
              END;

              { case 3 }
              IF (Rec1.FidoMsgStyle = NoneType) THEN
              BEGIN
                   ResolveDupe:=RecNr1;
                   Exit;
              END;
         END;

         IF (Rec1.FidoMsgStyle = Rec2.FidoMsgStyle) THEN
         BEGIN
              { case 4 }
              IF (Rec2.UserList = NILRecordNr) THEN
              BEGIN
                   ResolveDupe:=RecNr2;
                   Exit;
              END;

              { case 5 }
              IF (Rec1.UserList = NILRecordNr) THEN
              BEGIN
                   ResolveDupe:=RecNr1;
                   Exit;
              END;

              {LogMessage ('Merging user lists for '+Rec1.AreaName_U);}

              { case 6: merge Rec2 lists of subscribers with Rec1 and }
              {         delete Rec2.                                  }
              GetFirstUserSubscribedToThisArea (Rec2.UserList,Search);
              WHILE (Search.Found) DO
              BEGIN
                   IF (NOT TestIfUserIsInAreaRec_UserList (Rec1.UserList,Search.UserBaseRecordNr)) THEN
                   BEGIN
                        {LogExtraMessage ('Rec2: '+Word2String (Search.UserBaseRecordNr)+' -> Adding to Rec1');}
                        AddUserToAreaSubscrList (Rec1,Search.UserBaseRecordNr);
                   END ELSE
                   BEGIN
                        {LogExtraMessage ('Rec2: '+Word2String (Search.UserBaseRecordNr)+' -> Present');}
                   END;

                   GetNextUserSubscribedToThisArea (Search);
              END; { while }

              ResolveDupe:=RecNr2;
              Exit;
         END;

         { failed to resolve dupe; return NILRecordNr }
         ResolveDupe:=NILRecordNr;   { assume we couldn't resolve the situation }

         FDupe:=(UpCaseString (Rec1.AreaName_F) = UpCaseString (Rec2.AreaName_F));
         RDupe:=(UpCaseString (Rec1.AreaName_U) = UpCaseString (Rec2.AreaName_U));

         IF (FDupe AND RDupe) THEN
            Desc:=' (FTN and RFC)'
         ELSE
             IF RDupe THEN
                Desc:=' (RFC)'
             ELSE
                 Desc:=' (FTN)';

         LogMessage (liConfig,'Duplicate area: '+Rec1.AreaName_F+Desc);
    END;

VAR FTNIndexPtr,
    RFCIndexPtr : IndexArrayPtr;
    DupesSolved : WORD;

    {----------------------------------------------------------------------}
    { DeleteDupeArea                                                       }
    {                                                                      }
    { This routine deletes the area that is detected to be the dupe.       }
    {
    {                                                                      }
    PROCEDURE DeleteDupeArea (RecNr : AreaBaseRecordNrType);

    VAR AreaRec : AreaBaseRecord;

    BEGIN
         { checked here for simplified code }
         IF (RecNr = NILRecordNr) THEN
            Exit;

         Inc (DupesSolved);

         { remove from indexes so it doesn't trigger again }
         FTNIndexPtr^[RecNr]:=0;
         RFCIndexPtr^[RecNr]:=0;

         { set Deleted flag in area }
         ReadAreaBaseRecord (RecNr,AreaRec);
         AreaRec.Deleted:=TRUE;
         WriteAreaBaseRecord (RecNr,AreaRec);

         LogMessage (liGeneral,'Deleted duplicate area '+AreaRec.AreaName_F+' (record '+Word2String (RecNr)+')');
    END;

{CheckForDuplicateAreas}

VAR Lp          : WORD;
    ArraySize   : WORD;
    AreaRec     : AreaBaseRecord;
    Name        : STRING[MaxLenAreaName];
    PercDone    : BYTE;
    FoundRecNr  : WORD;
    Value       : LONGINT;
    SolvedRecNr : AreaBaseRecordNrType;
    DupesFound  : WORD;

LABEL Abort;

BEGIN
     CheckForDuplicateAreas:=FALSE; { assume success }

     { 1 - build CRC name based index }
     AreaCount:=AreaBaseRecCount;

     IF (AreaCount > 16383) THEN
     BEGIN
          LogMessage (liConfig,'Too many areas ('+Word2String (AreaCount)+'); will only check first 16383 areas');
          AreaCount:=16383;
     END;

     ArraySize:=AreaCount*4;

     IF (_MaxAvail < ArraySize) THEN
     BEGIN
          LogMessage (liFatal,'Not enough memory to perform dupe check');
          Exit;
     END;

     GetMem (FTNIndexPtr,ArraySize);

     IF (_MaxAvail < ArraySize) THEN
     BEGIN
          LogMessage (liFatal,'Not enough memory to perform dupe check');
          FreeMem (FTNIndexPtr,ArraySize);
          Exit;
     END;

     GetMem (RFCIndexPtr,ArraySize);

     CheckForDuplicateAreas:=TRUE; { assume aborted }

     { read all the area records and build the CRC list }
     FOR Lp:=1 TO AreaCount DO
     BEGIN
          IF ((Lp MOD 25) = 1) THEN
          BEGIN
               PercDone:=Round ((Lp/AreaCount)*100);
               WriteXYC (Xb2,AreaYb,cBoxData,AddUpWithSpaces (Xl2,
                                             'Reading '+Word2String (Lp)+'/'+Word2String (AreaCount)+
                                             ' ('+Byte2String (PercDone)+'%)'));
               Slice_Now;
               IF KeyPressed AND (ReadKey = kEsc) THEN
                  GOTO Abort;
          END;

          ReadAreaBaseRecord (Lp,AreaRec);

          IF AreaRec.Deleted THEN
          BEGIN
               FTNIndexPtr^[Lp]:=0;
               RFCIndexPtr^[Lp]:=0;
          END ELSE
          BEGIN
               Name:=AddUpWithSpaces (MaxLenAreaName,UpCaseString (AreaRec.AreaName_F));
               FTNIndexPtr^[Lp]:=UpdateCRC32 ($FFFFFFFF,Name[1],MaxLenAreaName);

               Name:=AddUpWithSpaces (MaxLenAreaName,UpCaseString (AreaRec.AreaName_U));
               RFCIndexPtr^[Lp]:=UpdateCRC32 ($FFFFFFFF,Name[1],MaxLenAreaName);
          END;
     END; { for }

     { check for dupes }

     DupesFound:=0;
     DupesSolved:=0;

     FOR Lp:=1 TO AreaCount DO
     BEGIN
          IF ((Lp MOD 25) = 1) THEN
          BEGIN
               PercDone:=Round ((Lp/AreaCount)*100);
               WriteXYC (Xb2,AreaYb,cBoxData,AddUpWithSpaces (Xl2,
                                             'Checking '+Word2String (Lp)+'/'+Word2String (AreaCount)+
                                             ' ('+Byte2String (PercDone)+'%)'));
               Slice_Now;
               IF KeyPressed AND (ReadKey = kEsc) THEN
                  GOTO Abort;
          END;

          { FTN name check }
          IF (FTNIndexPtr^[Lp] <> 0{deleted area?}) THEN
          REPEAT
                Value:=FTNIndexPtr^[Lp];  { search for this value }
                FTNIndexPtr^[Lp]:=0;      { avoid finding yourself }
                FoundRecNr:=SearchIndex (FTNIndexPtr,Value);
                FTNIndexPtr^[Lp]:=Value;  { restore }

                IF (FoundRecNr <> NILRecordNr) THEN
                BEGIN
                     Inc (DupesFound);

                     SolvedRecNr:=ResolveDupe (Lp,FoundRecNr);
                     DeleteDupeArea (SolvedRecNr);

                     { if the case was not solved or we deleted ourself }
                     { then exit the loop }
                     IF (SolvedRecNr <> FoundRecNr) THEN
                        FoundRecNr:=NILRecordNr;
                END;

          UNTIL (FoundRecNr = NILRecordNr);

          { RFC name check }
          IF (RFCIndexPtr^[Lp] <> 0{deleted area?}) THEN
          REPEAT
                Value:=RFCIndexPtr^[Lp];  { search for this value }
                RFCIndexPtr^[Lp]:=0;      { avoid finding yourself }
                FoundRecNr:=SearchIndex (RFCIndexPtr,Value);
                RFCIndexPtr^[Lp]:=Value;  { restore }

                IF (FoundRecNr <> NILRecordNr) THEN
                BEGIN
                     Inc (DupesFound);

                     SolvedRecNr:=ResolveDupe (Lp,FoundRecNr);
                     DeleteDupeArea (SolvedRecNr);

                     { if the case was not solved or we deleted ourself }
                     { then exit the loop }
                     IF (SolvedRecNr <> FoundRecNr) THEN
                        FoundRecNr:=NILRecordNr;
                END;
          UNTIL (FoundRecNr = NILRecordNr);
     END; { for }

     IF (DupesFound = 0) THEN
        Name:='No dupes found'
     ELSE
         IF (DupesFound = DupesSolved) THEN
            Name:=Word2String (DupesFound)+' dupes solved'
         ELSE
             Name:=Word2String (DupesFound)+' dupes; '+
                   Word2String (DupesSolved)+' solved';

     WriteXYC (Xb2,AreaYb,cBoxData,AddUpWithSpaces (Xl2,Name));

     IF (DupesFound > 0) THEN
        LogMessage (liGeneral,Name);

     IF (DupesFound <> DupesSolved) THEN
        LogExtraMessage ('NOTE: Please examine and solve other dupes manually!');

     CheckForDuplicateAreas:=FALSE; { completed succesfully }

Abort:
     FreeMem (RFCIndexPtr,ArraySize);
     FreeMem (FTNIndexPtr,ArraySize);
END;


{--------------------------------------------------------------------------}
{ RemoveDeletedAreas                                                       }
{                                                                          }
{ Deze routine verwijderd alle deleted areas uit de base door de rest aan  }
{ te schuiven. Op die manier komen de deleted records aan het einde te     }
{ staan.                                                                   }
{                                                                          }
PROCEDURE RemoveDeletedAreas;

VAR Lp,
    G1,G2,
    P1,P2    : WORD;
    PercDone : BYTE;

BEGIN
     NewAreaRecCount:=0;

     FOR Lp:=1 TO OldAreaRecCount DO
     BEGIN
          G1:=Lp DIV MapRecordsPerArray;
          G2:=Lp MOD MapRecordsPerArray;

          IF (AreaDataTable[G1]^[G2].RecNr <> NILRecordNr) THEN
          BEGIN
               { deze behouden we }
               Inc (NewAreaRecCount); { daar opslaan }

               IF (NewAreaRecCount <> Lp) THEN
               BEGIN
                    { data moet verplaatst worden }
                    P1:=NewAreaRecCount DIV MapRecordsPerArray;
                    P2:=NewAreaRecCount MOD MapRecordsPerArray;

                    { kopieer de data naar dit nieuwe record }
                    AreaDataTable[P1]^[P2]:=AreaDataTable[G1]^[G2];

                    { dit oude record krijgt nu de deleted status }
                    AreaDataTable[G1]^[G2].RecNr:=NILRecordNr;
               END; { if have to copy the data }
          END;

          IF ((Lp MOD 25) = 1) THEN
          BEGIN
               PercDone:=Round (Lp/OldAreaRecCount*100);
               WriteXYC (Xb2,AreaYb+2,cBoxData,Word2String (Lp)+'/'+Word2String (OldAreaRecCount)+
                                               ' ('+Byte2String (PercDone)+'%)');
               Slice_Now;
          END;

     END; { for }

     WriteXYC (Xb2,AreaYb+2,cBoxData,'Deleted '+Word2String (OldAreaRecCount-NewAreaRecCount)+
                                     ', keeping '+Word2String (NewAreaRecCount));
END;


{--------------------------------------------------------------------------}
{ SortAreaBase                                                             }
{                                                                          }
{ Deze routine sorteert de areabase aan de hand van de gegevens die in     }
{ AreaDataTable beschikbaar zijn.                                          }
{ Hier wordt gebruik gemaakt van domme oude BubbleSort. Voornamelijk       }
{ omdat we niet zoveel geheugen vrij hebben. InsertionSort zou ook nog     }
{ kunnen, maar het is niet echt een heap structuur, dus inserten kan       }
{ nogal wat overhead veroorzaken.                                          }
{ Alleen 1..NewAreaRecCount worden gesorteerd.                             }
{ Geeft 1 terug als de user afbreekt, 0 als ie gewoon eindigt en 2 als er  }
{ niets verandert is (no sort / no areas to sort)                          }
{                                                                          }
FUNCTION SortAreaBase : BYTE;

VAR Lp1,
    Lp2      : WORD;
    PercDone : BYTE;
    SwapRec  : MapRecord;
    SPtr,                               { smallest }
    T1Ptr,
    T2Ptr    : MapRecordPtr;
    DidRecS  : BOOLEAN;
    RecS,
    Rec2     : AreaBaseRecord;

BEGIN
     IF (NewAreaRecCount < 1) THEN
     BEGIN
          WriteXYC (Xb2,AreaYb+3,cBoxData,'No work');
          SortAreaBase:=2; { niets aan veranderd }
          Exit; { nothing to sort }
     END;

     { quickly check to see if the whole thing is already sorted }
     T1Ptr:=Addr (AreaDataTable[0]^[1]);
     FOR Lp1:=2 TO NewAreaRecCount DO
     BEGIN
          T2Ptr:=Addr (AreaDataTable[Lp1 DIV MapRecordsPerArray]^[Lp1 MOD MapRecordsPerArray]);

          IF (T1Ptr^.NamePtr^ >= T2Ptr^.NamePtr^) THEN
          BEGIN
               { deze klopt niet! }
               T1Ptr:=NIL;
               Break;
          END;

          T1Ptr:=T2Ptr; { RAWI 980428 }
     END; { for }

     IF (T1Ptr <> NIL) THEN
     BEGIN
          WriteXYC (Xb2,AreaYb+3,cBoxData,'Already sorted');
          SortAreaBase:=2; { niets aan veranderd }
          Exit;
     END;

     FOR Lp1:=1 TO NewAreaRecCount-1 DO
     BEGIN
          T1Ptr:=Addr (AreaDataTable[Lp1 DIV MapRecordsPerArray]^[Lp1 MOD MapRecordsPerArray]);
          SPtr:=T1Ptr;

          DidRecS:=FALSE; { nog niet van disk geladen }

          { ga op zoek naar het kleinste record }

          FOR Lp2:=Lp1+1 TO NewAreaRecCount DO
          BEGIN
               T2Ptr:=Addr (AreaDataTable[Lp2 DIV MapRecordsPerArray]^[Lp2 MOD MapRecordsPerArray]);

               IF (T2Ptr^.NamePtr^ <= SPtr^.NamePtr^) THEN
               BEGIN
                    IF (T2Ptr^.NamePtr^ < SPtr^.NamePtr^) THEN
                    BEGIN
                         SPtr:=T2Ptr;
                         DidRecS:=FALSE; { er is nu een nieuwe }
                    END ELSE
                    BEGIN
                         { ze zijn gelijk, dus we moeten op disk kijken }
                         { voor de zekerheid.                           }

                         IF (NOT DidRecS) THEN
                         BEGIN
                              ReadAreaBaseRecord (SPtr^.RecNr,RecS);
                              DidRecS:=TRUE;
                         END;

                         ReadAreaBaseRecord (T2Ptr^.RecNr,Rec2);

                         { zo. Nu nog eens vergelijken of ie echt kleiner is }
                         IF (Rec2.AreaName_F < RecS.AreaName_F) THEN
                         BEGIN
                              { ja! Het is echt. deze is vanaf nu de kleinste }
                              SPtr:=T2Ptr;
                              RecS:=Rec2; { DidRecS blijft TRUE }
                         END; { echt swappen }
                    END; { disk controle }
               END; { uberhaupt mogelijk kleiner }
          END; { for 2 }

          { als we een kleinere gevonden hebben, ze die dan op deze positie }
          IF (SPtr <> T1Ptr) THEN
          BEGIN
               SwapRec:=T1Ptr^;
               T1Ptr^:=SPtr^;
               SPtr^:=SwapRec;
          END;

          IF ((Lp1 MOD 25) = 1) THEN
          BEGIN
               PercDone:=Round (Lp1/NewAreaRecCount*100);
               WriteXYC (Xb2,AreaYb+3,cBoxData,Word2String (Lp1)+'/'+Word2String (NewAreaRecCount)+
                                               ' ('+Byte2String (PercDone)+'%)');
               Slice_Now;
          END;

          IF KeyPressed AND (ReadKey = kEsc) THEN
          BEGIN
               SortAreaBase:=1; { afgebroken }
               Exit;
          END;

     END; { for 1 }

     SortAreaBase:=0; { niet afgebroken }

     PercDone:=100;
     WriteXYC (Xb2,AreaYb+3,cBoxData,Word2String (NewAreaRecCount)+'/'+Word2String (NewAreaRecCount)+
                                     ' (100%)');
END;


{--------------------------------------------------------------------------}
{ CreateNewAreaBase                                                        }
{                                                                          }
{ Deze routine maakt een nieuwe areabase aan. Alle records uit de oude     }
{ database worden een voor een naar de nieuwe database gekopieerd, zodat   }
{ deze in de juiste volgorde komt te staan. Er worden nog geen             }
{ subscription base records aangemaakt.                                    }
{ Geeft TRUE terug als de user afbreekt.                                   }
{                                                                          }
FUNCTION CreateNewAreaBase : BOOLEAN;

CONST MAXAREAS = 65520 DIV SizeOf (AreaBaseRecord);

TYPE AreasArray    = ARRAY[1..MAXAREAS] OF AreaBaseRecord;
     AreasArrayPtr = ^AreasArray;

VAR Lp,
    ALp,
    RecNr    : WORD;
    AreaCnt  : WORD;
    Area1st  : WORD;
    AreasPtr : AreasArrayPtr;
    PercDone : BYTE;

BEGIN
     { er is net heel veel geheugen vrij gegeven, dus er moet }
     { genoeg beschikbaar zijn.                               }

     GetMem (AreasPtr,SizeOf (AreasArray));

     AreaCnt:=0;
     Area1st:=1;

     FOR Lp:=1 TO NewAreaRecCount DO
     BEGIN
          IF ((Lp MOD 25) = 1) THEN
          BEGIN
               PercDone:=Round (Lp/NewAreaRecCount*100);
               WriteXYC (Xb2,AreaYb+4,cBoxData,Byte2String (PercDone)+'%');

               Slice_Now;

               IF KeyPressed AND (ReadKey = kEsc) THEN
               BEGIN
                    CreateNewAreaBase:=TRUE; { afgebroken }
                    Exit;
               END;
          END;

          { haal het record nummer op van het record dat op deze positie }
          { in de nieuwe database moet komen, maar op dit record nummer  }
          { nog in de oude database staat.                               }
          RecNr:=AreaDataTable[Lp DIV MapRecordsPerArray]^[Lp MOD MapRecordsPerArray].RecNr;

          Inc (AreaCnt);
          ReadAreaBaseRecord (RecNr,AreasPtr^[AreaCnt]);
          AreasPtr^[AreaCnt].UserList:=NILRecordNr;

          { check to make sure that this area is in ANY groups at all }
          IF TestGroupListIsEmpty (AreasPtr^[AreaCnt].IsInGroups) THEN
          BEGIN
               LogMessage (liFatal,'Putting orphan area in group Z1: '+AreasPtr^[AreaCnt].AreaName_F);
               AddGroupToGroupList (AreasPtr^[AreaCnt].IsInGroups,Group_NewAreas);
          END;

          IF (AreaCnt = MAXAREAS) THEN
          BEGIN
               FOR ALp:=1 TO AreaCnt DO
               BEGIN
                    TdbWrite (NewAreaBaseTdbNr,Area1st,AreasPtr^[ALp]);
                    Inc (Area1st);
               END;

               AreaCnt:=0;
          END;

     END; { for }

     IF (AreaCnt > 0) THEN
        FOR ALp:=1 TO AreaCnt DO
        BEGIN
             TdbWrite (NewAreaBaseTdbNr,Area1st,AreasPtr^[ALp]);
             Inc (Area1st);
        END;

     FreeMem (AreasPtr,SizeOf (AreasArray));

     WriteXYC (Xb2,AreaYb+4,cBoxData,'100%');

     CreateNewAreaBase:=FALSE; { niet afgebroken }
END;


{--------------------------------------------------------------------------}
{ CreateNewUserBase                                                        }
{                                                                          }
{ Deze routine bouwt een nieuwe userbase op. Ondertussen wordt voor iedere }
{ user bijgehouden welke areas hij/zij aangesloten heeft. Geeft TRUE       }
{ terug als de user op Escape drukt.                                       }
{                                                                          }
FUNCTION CreateNewUserBase : BOOLEAN;

TYPE DubRecord = RECORD
                       Low,High : AreaBaseRecordNrType;
                 END;

CONST MAXDUBENTRIES = 10000; { max 16000 }

TYPE DubArray    = ARRAY[1..MAXDUBENTRIES] OF DubRecord;
     DubArrayPtr = ^DubArray;

VAR DubPtr   : DubArrayPtr;
    DubCount : 0..MAXDUBENTRIES;
    DubCompr : BYTE; { downcounter voor comprimeren van dublist }
    DubACnt  : WORD; { aantal records nummers feitelijk opgeslagen }

    {----------------------------------------------------------------------}
    { GetNewARecNr                                                         }
    {                                                                      }
    { Deze routine zoekt in de AreaDataTable naar het genoemde oude record }
    { nummer en geeft in de plaats daarvan het nieuwe record nummer terug. }
    { Als het opgegeven record nummer niet in de AreaDataTable voorkomt,   }
    { dan is het een illegaal nummer en kan het verwijderd worden. Dit     }
    { wordt terug gegeven in de vorm van een NILRecordNr, waar StoreARecNr }
    { dan weer op reageert.                                                }
    {                                                                      }
    FUNCTION GetNewARecNr (OldARecNr : WORD) : WORD;

    VAR Lp : WORD;

    BEGIN
         IF (OldARecNr < 1) OR (OldARecNr > OldAreaRecCount) THEN
         BEGIN
              GetNewARecNr:=NILRecordNr; { jammer }
              Exit;
         END;

         FOR Lp:=1 TO NewAreaRecCount DO
             WITH AreaDataTable[Lp DIV MapRecordsPerArray]^[Lp MOD MapRecordsPerArray] DO
                  IF (OldARecNr = RecNr) THEN
                  BEGIN
                       { gevindtd! }
                       GetNewARecNr:=Lp;
                       Exit;
                  END;

         { niet gevonden. Geef NILRecordNr terug }
         GetNewARecNr:=NILRecordNr;
    END;

    {----------------------------------------------------------------------}
    { PackAndSortDub                                                       }
    {                                                                      }
    { Deze routine packt het dub array met de record nummers. Alle blokken }
    { die aan elkaar kunnen worden hier aan elkaar geplakt. Daarna wordt   }
    { de lijst met nummers gesorteerd, zodat het kleinste nummer eerst     }
    { staat. Dit heeft als voordeel dat als we de subscription base voor   }
    { deze user op gaan zetten, dat we dan een gesorteerde lijst krijgen,  }
    { waardoor WtrConf weer super snel wordt.                              }
    {                                                                      }
    PROCEDURE PackAndSortDub;

    VAR Lp,Lp2  : 0..MAXDUBENTRIES;
        SwapDub : DubRecord;

    BEGIN
         DubCompr:=50; { voorlopig weer even niet meer nodig }

         Lp:=1;

         WHILE (Lp < DubCount) DO
         BEGIN
              Lp2:=Lp+1;

              WHILE (Lp2 <= DubCount) DO
              BEGIN
                   IF (DubPtr^[Lp].High = DubPtr^[Lp2].Low-1) THEN
                   BEGIN
                        { deze twee kunnen aan elkaar! }
                        DubPtr^[Lp].High:=DubPtr^[Lp2].High;

                        { de laatste kan nu weg. Vervang deze door de }
                        { laatste entry in de lijst en controleer dan }
                        { weer.                                       }

                        { als dit al de laatste was, dan verdwijnt ie }
                        DubPtr^[Lp2]:=DubPtr^[DubCount];
                        Dec (DubCount);

                        Continue; { while lp2 }
                   END;

                   IF (DubPtr^[Lp2].Low = DubPtr^[Lp2].High+1) THEN
                   BEGIN
                        { ze kunnen aan elkaar }
                        DubPtr^[Lp].Low:=DubPtr^[Lp2].Low;

                        DubPtr^[Lp2]:=DubPtr^[DubCount];
                        Dec (DubCount);

                        Continue; { while lp2 }
                   END;

                   { deze kan niet aan die van lp1. Zoek verder }
                   Inc (Lp2);
              END; { while }

              { alle mogelijkheden tegen deze geprobeerd. Op naar de volgende. }
              Inc (Lp);
         END; { while }

         { Sorteer nu de dub lijst nog even }
         IF (DubCount > 1) THEN
            FOR Lp:=1 TO DubCount-1 DO
                FOR Lp2:=Lp+1 TO DubCount DO
                    IF (DubPtr^[Lp2].High < DubPtr^[Lp].Low) THEN
                    BEGIN
                         SwapDub:=DubPtr^[Lp];
                         DubPtr^[Lp]:=DubPtr^[Lp2];
                         DubPtr^[Lp2]:=SwapDub;
                    END;
    END;

    {----------------------------------------------------------------------}
    { StoreARecNr                                                          }
    {                                                                      }
    { Deze routine voegt een areabase record nummer toe aan de lijst met   }
    { aan te sluiten records voor deze user. Deze lijst wordt in ranges    }
    { bijgehouden, dubbele waarden worden eruit gehouden en aan het eind   }
    { wordt de lijst gesorteerd zodat de subscription base de areabase     }
    { records in gesorteerde volgorde vermeld.                             }
    {                                                                      }
    PROCEDURE StoreARecNr (ARecNr : AreaBaseRecordNrType);

    VAR Lp : 0..MAXDUBENTRIES;

    BEGIN
         IF (ARecNr = NILRecordNr) THEN
            Exit;

         FOR Lp:=1 TO DubCount DO
             WITH DubPtr^[Lp] DO
                  IF (ARecNr >= Low) AND (ARecNr <= High) THEN
                     Exit; { is een dupe }

         { niet gevonden. Voeg toe aan een van de lijsten. }
         FOR Lp:=1 TO DubCount DO
             WITH DubPtr^[Lp] DO
             BEGIN
                  IF (ARecNr = Low-1) THEN
                  BEGIN
                       Dec (Low);
                       Inc (DubACnt);
                       Exit;
                  END;

                  IF (ARecNr = High+1) THEN
                  BEGIN
                       Inc (High);
                       Inc (DubACnt);
                       Exit;
                  END;
             END; { with, for }

         { om zeker te zijn dat er ruimte is, gaan we eerst comprimeren   }
         { als we tegen de limiet aan zitten, of als het gewoon nodig is. }
         Dec (DubCompr);

         IF (DubCompr = 0) OR (DubCount = MAXDUBENTRIES) THEN
            PackAndSortDub;

         { geen range uit kunnen breiden. Maak een nieuwe range aan }
         IF (DubCount = MAXDUBENTRIES) THEN
         BEGIN
              { geen plek. MAJOR probleem!!                              }
              { De kans DAT ie hier komt is heel erg klein, maar toch... }
              LogMessage (liReport,'Out of "dub" space!');

              { result is al FALSE }
              Exit;
         END;

         Inc (DubCount);
         DubPtr^[DubCount].Low:=ARecNr;
         DubPtr^[DubCount].High:=ARecNr;
         Inc (DubACnt);
    END;

    PROCEDURE AttemptRecoverChain (UserRecNr : UserBaseRecordNrType);

    VAR ALp    : AreaBaseRecordNrType;
        ARec   : AreaBaseRecord;
        SRecNr : SubscriptBaseRecordNrType;
        SRec   : SubscriptBaseRecord;
        ELp    : 0..MaxSubscrBaseElements;
        Next   : BOOLEAN;

    BEGIN
         LogMessage (liGeneral,'Starting recover attempt by scanning areas');

         FOR ALp:=1 TO AreaBaseRecCount DO
         BEGIN
              ReadAreaBaseRecord (ALp,ARec);

              SRecNr:=ARec.UserList;

              WHILE (SRecNr <> NILRecordNr) DO
              BEGIN
                   IF (SRecNr > SubscriptBaseRecCount) THEN
                   BEGIN
                        LogMessage (liFatal,'More integrity errors; stopping');
                        Exit;
                   END;

                   ReadSubscriptBaseRecord (SRecNr,SRec);

                   Next:=TRUE;

                   FOR ELp:=1 TO MaxSubscrBaseElements DO
                       IF (SRec.UserList[ELp] = UserRecNr) THEN
                       BEGIN
                            Next:=FALSE;
                            StoreARecNr (GetNewARecNr (ALp));
                            Break;
                       END;

                   IF Next THEN
                   BEGIN
                        IF (SRecNr = SRec.NextSegmentRecordNr) THEN
                        BEGIN
                             LogMessage (liFatal,'More integrity errors; stopping');
                             Exit;
                        END;

                        SRecNr:=SRec.NextSegmentRecordNr;
                   END ELSE
                       SRecNr:=NILRecordNr; { aborts the while }
              END; { while }
         END; { for }

         LogMessage (liGeneral,'Finished recovery scan');
    END;

{CreateNewUserBase}

VAR ULp,
    UNr      : WORD;
    URec     : UserBaseRecord;
    PrevSNr,
    SRecNr   : SubscriptBaseRecordNrType;
    SRec     : SubscriptBaseRecord;
    ELp      : 0..MaxSubscrBaseElements;
    PercDone : BYTE;
    DLp,
    D2Lp,
    DDone    : WORD;
    ARec     : AreaBaseRecord;

LABEL Abort;

BEGIN
     IF (_MaxAvail < SizeOf (DubArray)) THEN
     BEGIN
          LogMessage (liFatal,'Not enough memory ('+Word2String (SizeOf (DubArray))+') to continue.'+
                      ' Mem='+Longint2String (_Memavail)+', Max='+Longint2String (_MaxAvail));
          LogExtraMessage ('Please report to the authors free up more base memory');

          CreateNewUserBase:=TRUE; { abort! }
          Exit;
     END;

     GetMem (DubPtr,SizeOf (DubArray));

     FOR ULp:=1 TO UserBaseRecCount DO
     BEGIN
          Slice_Now;

          PercDone:=Round (ULp/UserBaseRecCount*100);
          WriteXYC (Xb2,UserYb,cBoxData,Word2String (ULp)+'/'+Word2String (UserBaseRecCount)+
                                        ' ('+Byte2String (PercDone)+'%)');

          IF KeyPressed AND (ReadKey = kEsc) THEN
          BEGIN
               CreateNewUserBase:=TRUE; { aborted }
               GOTO Abort;
          END;

          ReadUserBaseRecord (ULp,URec);

          WriteXYC (Xb+8,UserYb+1,cBoxData,' ');
          WriteXY (Xb2,UserYb+1,Spaces (20));

          WriteXY (Xb+8,UserYb+2,' ');
          WriteXY (Xb2,UserYb+2,Spaces (7));

          WriteXY (Xb+8,UserYb+3,' ');
          WriteXY (Xb2,UserYb+3,Spaces (20));

          IF (NOT URec.Deleted) THEN
          BEGIN
               SRecNr:=URec.AreaList;
               URec.AreaList:=NILRecordNr;

               UNr:=TdbRecCount (NewUserBaseTdbNr)+1;
               TdbWrite (NewUserBaseTdbNr,UNr,URec);

               { sluit nu alle areas weer aan voor deze user. Dit wordt }
               { gedaan door de hele subscription base tak van het oude }
               { record te doorlopen en alle dubbele en verwijderde     }
               { records eruit te halen. Daardoor ontstaat een lijst    }
               { met nieuw aan te sluiten, legale, record nummers. Daar }
               { worden dan subscription base records van gemaakt en    }
               { als laatste worden alle areas doorlopen om de user ook }
               { daar te vermelden als aangesloten user.                }

               WriteXYC (Xb+8,UserYb+1,cCustom1,'þ');

               DubCount:=0;
               DubACnt:=0;

               WHILE (SRecNr <> NILRecordNr) DO
               BEGIN
                    ReadSubscriptBaseRecord (SRecNr,SRec);

                    FOR ELp:=1 TO MaxSubscrBaseElements DO
                        StoreARecNr (GetNewARecNr (SRec.AreaList[ELp]));

                    WriteXYC (Xb2,UserYb+1,cBoxData,Word2String (DubACnt)+' areas');

                    IF (SRecNr = SRec.NextSegmentRecordNr) THEN
                    BEGIN
                         LogMessage (liConfig,'Subscribed areas chain is broken for following user');

                         CASE URec.System OF
                              _F : LogExtraMessage ('(FIDO) '+Fido2Str (URec.Address)+' / '+URec.Sysop);
                              _U : LogExtraMessage ('(UUCP) '+URec.UUCPName);
                              _S : LogExtraMessage ('(SMTP) '+URec.UUCPName);
                              _B : LogExtraMessage ('(BAG) '+URec.UUCPName);
                              _P : LogExtraMessage ('(POP3) '+URec.Pop3Recipient);
                         END;

                         AttemptRecoverChain (ULp);

                         LogMessage (liFatal,'Please check user''s subscribed areas manually');

                         SRecNr:=NILRecordNr; { fake end of chain }
                    END ELSE
                        SRecNr:=SRec.NextSegmentRecordNr;

                    IF KeyPressed AND (ReadKey = kEsc) THEN
                    BEGIN
                         CreateNewUserBase:=TRUE; { aborted }
                         GOTO Abort;
                    END;
               END; { while }

               { zorg dat deze lijst uiteindelijk gesorteerd is }
               PackAndSortDub;

               WriteXYC (Xb+8,UserYb+1,cMessage,'*');

               { nu de subscription base records schrijven voor deze user }
               WriteXYC (Xb+8,UserYb+2,cCustom1,'þ');

               PrevSNr:=NILRecordNr;
               ELp:=0;
               DDone:=0;

               FOR DLp:=1 TO DubCount DO
                   WITH DubPtr^[DLp] DO
                        FOR D2Lp:=Low TO High DO
                        BEGIN
                             Inc (ELp);
                             SRec.AreaList[ELp]:=D2Lp;
                             Inc (DDone);

                             IF (ELp = MaxSubscrBaseElements) THEN
                             BEGIN
                                  SRec.NextSegmentRecordNr:=NILRecordNr;
                                  TdbWrite (NewSubscrBaseTdbNr,TdbRecCount (NewSubscrBaseTdbNr)+1,SRec);
                                  ELp:=0;

                                  IF (PrevSNr <> NILRecordNr) THEN
                                  BEGIN
                                       TdbRead (NewSubscrBaseTdbNr,PrevSNr,SRec);
                                       SRec.NextSegmentRecordNr:=TdbRecCount (NewSubscrBaseTdbNr);
                                       TdbWrite (NewSubscrBaseTdbNr,PrevSNr,SRec);
                                  END ELSE
                                  BEGIN
                                       URec.AreaList:=TdbRecCount (NewSubscrBaseTdbNr);
                                       TdbWrite (NewUserBaseTdbNr,UNr,URec);
                                  END;

                                  PrevSNr:=TdbRecCount (NewSubscrBaseTdbNr);

                                  PercDone:=Round (DDone/DubACnt*100);
                                  WriteXYC (Xb2,UserYb+2,cBoxData,Byte2String (PercDone)+'%');
                             END;
                        END; { for, with, for }

               IF (ELp > 0) THEN
               BEGIN
                    WHILE (ELp < MaxSubscrBaseElements) DO
                    BEGIN
                         Inc (ELp);
                         SRec.AreaList[ELp]:=NILRecordNr;
                    END;

                    SRec.NextSegmentRecordNr:=NILRecordNr;
                    TdbWrite (NewSubscrBaseTdbNr,TdbRecCount (NewSubscrBaseTdbNr)+1,SRec);

                    IF (PrevSNr <> NILRecordNr) THEN
                    BEGIN
                         TdbRead (NewSubscrBaseTdbNr,PrevSNr,SRec);
                         SRec.NextSegmentRecordNr:=TdbRecCount (NewSubscrBaseTdbNr);
                         TdbWrite (NewSubscrBaseTdbNr,PrevSNr,SRec);
                    END ELSE
                    BEGIN
                         URec.AreaList:=TdbRecCount (NewSubscrBaseTdbNr);
                         TdbWrite (NewUserBaseTdbNr,UNr,URec);
                    END;

                    PercDone:=Round (DDone/DubACnt*100);
                    WriteXYC (Xb2,UserYb+2,cBoxData,Byte2String (PercDone)+'%');
               END; { ELp > 0 }

               WriteXYC (Xb+8,UserYb+2,cMessage,'*');

               IF KeyPressed AND (ReadKey = kEsc) THEN
               BEGIN
                    CreateNewUserBase:=TRUE; { aborted }
                    GOTO Abort;
               END;

               { stop het user record nummer nu bij alle areas in hun }
               { subscription base record.                            }
               WriteXYC (Xb+8,UserYb+3,cCustom1,'þ');

               DDone:=0;

               FOR DLp:=1 TO DubCount DO
                   WITH DubPtr^[DLp] DO
                        FOR D2Lp:=Low TO High DO
                        BEGIN
                             TdbRead (NewAreaBaseTdbNr,D2Lp,ARec);
                             Inc (DDone);

                             SRecNr:=ARec.UserList;

                             IF (SRecNr = NILRecordNr) THEN
                             BEGIN
                                  { eerste record }
                                  SRec.AreaList[1]:=UNr;

                                  FOR ELp:=2 TO MaxSubscrBaseElements DO
                                      SRec.AreaList[ELp]:=NILRecordNr;

                                  SRec.NextSegmentRecordNr:=NILRecordNr;

                                  TdbWrite (NewSubscrBaseTdbNr,TdbRecCount (NewSubscrBaseTdbNr)+1,SRec);

                                  ARec.UserList:=TdbRecCount (NewSubscrBaseTdbNr);
                                  TdbWrite (NewAreaBaseTdbNr,D2Lp,ARec);
                             END ELSE
                             BEGIN
                                  { we zijn aan het opbouwen. Als er nog }
                                  { een volgend record is, dan moeten we }
                                  { daar gewoon heen.                    }
                                  TdbRead (NewSubscrBaseTdbNr,SRecNr,SRec);
                                  WHILE (SRec.NextSegmentRecordNr <> NILRecordNr) DO
                                  BEGIN
                                       SRecNr:=SRec.NextSegmentRecordNr;
                                       TdbRead (NewSubscrBaseTdbNr,SRecNr,SRec);
                                  END; { while }

                                  FOR ELp:=1 TO MaxSubscrBaseElements DO
                                      IF (SRec.UserList[ELp] = NILRecordNr) THEN
                                      BEGIN
                                           SRec.UserList[ELp]:=UNr;
                                           TdbWrite (NewSubscrBaseTdbNr,SRecNr,SRec);
                                           ELp:=0;
                                           Break; { uit de for }
                                      END; { if, for }

                                  IF (ELp <> 0) THEN
                                  BEGIN
                                       { niet kunnen opslaan,  }
                                       { nieuw record beginnen }
                                       SRec.NextSegmentRecordNr:=TdbRecCount (NewSubscrBaseTdbNr)+1;
                                       TdbWrite (NewSubscrBaseTdbNr,SRecNr,SRec);

                                       SRec.NextSegmentRecordNr:=NILRecordNr;
                                       SRec.UserList[1]:=UNr;
                                       FOR ELp:=2 TO MaxSubscrBaseElements DO
                                           SRec.UserList[ELp]:=NILRecordNr;

                                       TdbWrite (NewSubscrBaseTdbNr,TdbRecCount (NewSubscrBaseTdbNr)+1,SRec);
                                  END; { nieuw record toevoegen }
                             END; { niet eerste record }

                             PercDone:=Round (DDone/DubACnt*100);
                             WriteXYC (Xb2,UserYb+3,cBoxData,Word2String (DDone)+'/'+Word2String (DubACnt)+
                                                             ' ('+Byte2String (PercDone)+'%)');

                             IF KeyPressed AND (ReadKey = kEsc) THEN
                             BEGIN
                                  CreateNewUserBase:=TRUE; { aborted }
                                  GOTO Abort;
                             END;

                        END; { for, with, for }

               WriteXYC (Xb+8,UserYb+3,cMessage,'*');

          END; { not deleted }
     END; { for }

     CreateNewUserBase:=FALSE; { niet afgebroken }

Abort:
     FreeMem (DubPtr,SizeOf (DubArray));
END;


(*
{--------------------------------------------------------------------------}
{ PackListServerDatabase                                                   }
{                                                                          }
{ Verwijderd oude records uit de database, en schrobt deze even flink de   }
{ oren. De lijsten bestaan uit een begin record en de rest is door         }
{ gechained door de hele file heen. Deleted records zijn losstaand.        }
{                                                                          }
FUNCTION PackListServerDatabase : BOOLEAN;

VAR dBaseNr       : TdbNrType;
    ListData      : ListServerRecord;
    OldRecCounter,
    NewRecCounter,
    LSRecTeller   : ListServerRecordNrType;

    {----------------------------------------------------------------------}
    { CopyListToNewFile                                                    }
    {                                                                      }
    { Deze routine kopieert een hele lijst met zijn gebruikers naar de     }
    { nieuwe database file. Dit begint bij het record dat nu in ListData   }
    { zit en in de nieuwe file wordt het record nummer NewRecCounter+1.    }
    {                                                                      }
    PROCEDURE CopyListToNewFile;

    VAR NextRecNr : ListServerRecordNrType;

    BEGIN
         REPEAT
               { reserveer een record voor dit te kopieren record }
               Inc (NewRecCounter);

               NextRecNr:=ListData.NextUser;
               IF (NextRecNr <> NILRecordNr) THEN
                  ListData.NextUser:=NewRecCounter+1; { voorspelling voor opvolger }
               TdbWrite (dBaseNr,NewRecCounter,ListData);

               { als er een opvolger is, dan dat record inlezen }
               IF (NextRecNr <> NILRecordNr) THEN
                  ReadListBaseRecord (NextRecNr,ListData);
         UNTIL (NextRecNr = NILRecordNr);
    END;

{ PackListServerDatabase }

VAR DelCount : WORD;
    Improve  : BYTE;

BEGIN
     PackListServerDatabase:=FALSE; { assume failure }

     OldRecCounter:=ListBaseRecCount;
     NewRecCounter:=0;

     { probeer een nieuwe database file te openen }
     IF (TdbCreate (Config.SystemDir+'TMPLIST.TDB',ListServerHeader,dBaseNr) <> _TdbOk) THEN
        Exit;
     TdbSetIO (dBaseNr,SizeOf (ListServerRecord));

     { doorloop de tabel van voren naar achteren }
     FOR LSRecTeller:=1 TO OldRecCounter DO
     BEGIN
          { zorg dat de mensen niet in de zenuwen gaan zitten ;-) }
          WriteXYC (Xb2,ListYb,cBoxData,LongInt2String ((LSRecTeller*100) DIV OldRecCounter)+'%');

          ReadListBaseRecord (LSRecTeller,ListData);

          IF (NOT ListData.Deleted) AND (ListData.ListSystem = lstName) THEN
             CopyListToNewFile;
     END; { for }

     { sluit de listserver base, delete deze en rename de nieuwe base }
     TdbCloseAndErase (ListServerTdbNr);
     IF (NOT TdbCloseAndRename (dBaseNr,Config.SystemDir+ListServerFileName)) THEN
     BEGIN
          LogMessage (liFatal,'Unable to rename temporary file to List Server database!');
          Exit;
     END;

     {
     LogExtraMessage (' (ListServerBase)   Records Old = '+Word2String (OldRecCounter)+
                                                 ' New = '+Word2String (NewRecCounter));
     }
     DelCount:=OldRecCounter-NewRecCounter;
     IF (OldRecCounter = 0) THEN
        Improve:=0
     ELSE
         Improve:=Round (DelCount/OldRecCounter*100);
     LogExtraMessage ('  ListServerBase: deleted '+AddUpWithSpaces (5,Word2String (DelCount))+
                      ' out of '+AddUpWithSpaces (5,Word2String (NewRecCounter))+
                      ' records: '+Byte2String (Improve)+'%');

     IF (TdbOpen (Config.SystemDir+ListServerFilename,ListServerTdbNr) = _TdbOk) THEN
     BEGIN
          TdbSetIO (ListServerTdbNr,SizeOf (ListServerRecord));
          PackListServerDatabase:=TRUE; { geen problemen }
     END;
END;
*)


{--------------------------------------------------------------------------}
{ PackListUserDatabase                                                     }
{                                                                          }
{ This routine removes old records from the LISTUSER.TDB file by searching }
{ for not-deleted records and copying these to a new file. The old file is }
{ then renamed to .OLD.                                                    }
{                                                                          }
FUNCTION PackListUserDatabase : BOOLEAN;

VAR dBaseNr       : TdbNrType;
    ListUserRec   : ListUserRecord;
    OldRecCounter,
    NewRecCounter,
    Lp            : ListUserRecordNrType;

VAR DelCount : WORD;
    Improve  : BYTE;

BEGIN
     PackListUserDatabase:=FALSE; { assume failure }

     OldRecCounter:=ListUser_RecCount;
     NewRecCounter:=0;

     { try to create a new database }
     IF (TdbCreate (Config.SystemDir+'TMPLIST.TDB',ListUserHeader,dBaseNr) <> _TdbOk) THEN
        Exit;
     TdbSetIO (dBaseNr,SizeOf (ListUserRecord));

     FOR Lp:=1 TO OldRecCounter DO
     BEGIN
          { zorg dat de mensen niet in de zenuwen gaan zitten ;-) }
          WriteXYC (Xb2,ListYb,cBoxData,LongInt2String ((Lp*100) DIV OldRecCounter)+'%');

          ListUser_Read (Lp,ListUserRec);

          IF (ListUserRec.UserType <> lutDeleted) THEN
          BEGIN
               Inc (NewRecCounter);
               TdbWrite (dBaseNr,NewRecCounter,ListUserRec);
          END;
     END; { for }

     TdbCloseAndErase (ListUserTdbNr);
     IF (NOT TdbCloseAndRename (dBaseNr,Config.SystemDir+ListUserFileName)) THEN
     BEGIN
          LogMessage (liFatal,'Unable to rename temporary file to List User database!');
          Exit;
     END;

     DelCount:=OldRecCounter-NewRecCounter;
     IF (OldRecCounter = 0) THEN
        Improve:=0
     ELSE
         Improve:=Round (DelCount/OldRecCounter*100);
     LogExtraMessage ('    ListUserBase: deleted '+AddUpWithSpaces (5,Word2String (DelCount))+
                      ' out of '+AddUpWithSpaces (5,Word2String (OldRecCounter))+
                      ' records: '+Byte2String (Improve)+'%');

     IF (TdbOpen (Config.SystemDir+ListUserFilename,ListUserTdbNr) = _TdbOk) THEN
     BEGIN
          TdbSetIO (ListUserTdbNr,SizeOf (ListUserRecord));
          PackListUserDatabase:=TRUE; { geen problemen }
     END;
END;


{--------------------------------------------------------------------------}
{ UtilPackBases                                                            }
{                                                                          }
{ Deze routine maakt een nieuwe AreaBase, UserBase en SubscriptionBase     }
{ database aan op disk. Daarna worden de records gekopieerd totdat ze      }
{ allemaal in de nieuwe database zitten. De AreaBase wordt gesorteerd      }
{ voor WtrConf.                                                            }
{                                                                          }
PROCEDURE UtilPackBases;

    FUNCTION CalcImprove (DelCount,OldRecCount : WORD) : BYTE;
    BEGIN
         IF (OldRecCount = 0) THEN
            CalcImprove:=0 { niets verwijderd van niets }
         ELSE
             CalcImprove:=Round (DelCount/OldRecCount*100);
    END;

CONST NewAreaBaseFilename   = 'AREABASE.$$$';
      NewUserBaseFilename   = 'USERBASE.$$$';
      NewSubscrBaseFilename = 'SUBSCRIP.$$$';

VAR HulpFile : FILE;
    IORes    : BYTE;
    Lp       : BYTE;
    Abort    : BOOLEAN;
    DelCount : WORD;
    Improve  : BYTE;
    SortRes  : BYTE;
    Attr     : BYTE;

LABEL Aborted,
      FinalEnding;

BEGIN
     LogMessage (liTrivial,'Pack Databases started');

     { verwijder de backup kopien }
     Assign (HulpFile,Config.SystemDir+'AREABASE.OLD');
     {$I-} Erase (HulpFile); {$I+} IORes:=IOResult;
     IF (NOT (IORes IN [0,2])) THEN
     BEGIN
          LogDiskIOError (IORes,'Error delete old backup copy '+Config.SystemDir+'AREABASE.OLD');
          Exit;
     END;

     Assign (HulpFile,Config.SystemDir+'USERBASE.OLD');
     {$I-} Erase (HulpFile); {$I+} IORes:=IOResult;
     IF (NOT (IORes IN [0,2])) THEN
     BEGIN
          LogDiskIOError (IORes,'Error delete old backup copy '+Config.SystemDir+'USERBASE.OLD');
          Exit;
     END;

     Assign (HulpFile,Config.SystemDir+'SUBSCRIP.OLD');
     {$I-} Erase (HulpFile); {$I+} IORes:=IOResult;
     IF (NOT (IORes IN [0,2])) THEN
     BEGIN
          LogDiskIOError (IORes,'Error delete old backup copy '+Config.SystemDir+'SUBSCRIP.OLD');
          Exit;
     END;

     IF (TdbCreate (Config.SystemDir+NewAreaBaseFilename,AreaBaseHeader,NewAreaBaseTdbNr) <> _tdbOk) THEN
     BEGIN
          LogDiskIOError (TdbLastIOResult,'Cannot create '+Config.SystemDir+NewAreaBaseFilename);
          Exit;
     END;

     IF (TdbCreate (Config.SystemDir+NewUserBaseFilename,UserBaseHeader,NewUserBaseTdbNr) <> _tdbOk) THEN
     BEGIN
          LogDiskIOError (TdbLastIOResult,'Cannot create '+Config.SystemDir+NewUserBaseFilename);
          TdbClose (NewAreaBaseTdbNr);
          Exit;
     END;

     IF (TdbCreate (Config.SystemDir+NewSubscrBaseFilename,SubscrBaseHeader,NewSubscrBaseTdbNr) <> _tdbOk) THEN
     BEGIN
          LogDiskIOError (TdbLastIOResult,'Cannot create '+Config.SystemDir+NewSubscrBaseFilename);
          TdbClose (NewUserBaseTdbNr);
          TdbClose (NewAreaBaseTdbNr);
          Exit;
     END;

     TdbSetIO (NewAreaBaseTdbNr,SizeOf (AreaBaseRecord));
     TdbSetIO (NewUserBaseTdbNr,SizeOf (UserBaseRecord));
     TdbSetIO (NewSubscrBaseTdbNr,SizeOf (SubscriptBaseRecord));

     PushKeysLine;
     WriteKeysLine (' ^Esc Abort');

     WindowPush (Xb,Yb,Xl,Yl);
     BoxDraw (Double,Xb,Yb,Xl,Yl);

     WriteXY (Xb+2,Yb,' Pack Databases progress ');

     WriteXY (Xb+2,AreaYb,  '[ ] Check for duplicate areas');
     WriteXY (Xb+2,AreaYb+1,'[ ] Read old areabase data');
     WriteXY (Xb+2,AreaYb+2,'[ ] Remove deleted areas');
     WriteXY (Xb+2,AreaYb+3,'[ ] Sort areabase');
     WriteXY (Xb+2,AreaYb+4,'[ ] Create new areabase');
     WriteXY (Xb+2,UserYb,  '[ ] Create new userbase');
     WriteXY (Xb+2,UserYb+1,'     [ ] Build subscription list');
     WriteXY (Xb+2,UserYb+2,'     [ ] Store user''s subscriptions');
     WriteXY (Xb+2,UserYb+3,'     [ ] Subscribe user to areas');
     WriteXY (Xb+2,ListYb,  '[ ] Pack List User database');
     WriteXY (Xb+2,CfgYb,   '[ ] Pack Config database');
     WriteXY (Xb+2,DupeYb,  '[ ] Pack Dupe database');

     Attr:=GetColorValue (cBoxBack);
     IF (Video.Color) THEN
        ModifyColor (cCustom1,Attr OR cBlink)
     ELSE
         ModifyColor (cCustom1,Attr OR mBlink);

     Abort:=FALSE;

     IF (AreaBaseRecCount = NILRecordNr) THEN
        RecoverFromOversizedAreabase;

     { check for duplicate area names }
     WriteXYC (Xb+3,AreaYb,cCustom1,'þ');
     IF CheckForDuplicateAreas THEN
     BEGIN
          WriteXYC (Xb+3,AreaYb,cError,'X');
          Abort:=TRUE;
          GOTO Aborted;
     END ELSE
         WriteXYC (Xb+3,AreaYb,cMessage,'*');

     { zet nu een tabel op met informatie over de oude database }
     WriteXYC (Xb+3,AreaYb+1,cCustom1,'þ');
     IF InitAreaDataTable THEN
     BEGIN
          WriteXYC (Xb+3,AreaYb+1,cError,'X');
          Abort:=TRUE;
          GOTO Aborted;
     END;
     WriteXYC (Xb+3,AreaYb+1,cMessage,'*');

     { verwijder de deleted areas }
     WriteXYC (Xb+3,AreaYb+2,cCustom1,'þ');
     RemoveDeletedAreas;
     WriteXYC (Xb+3,AreaYb+2,cMessage,'*');

     { sorteer de areabase }
     IF ForceNoSort THEN
     BEGIN
          WriteXYC (Xb+3,AreaYb+3,cBoxData,'-');
          WriteXY (Xb2,AreaYb+3,'Skipping on request');
          SortRes:=2; { niets te sorteren }
     END ELSE
     BEGIN
          WriteXYC (Xb+3,AreaYb+3,cCustom1,'þ');
          SortRes:=SortAreaBase;
          IF (SortRes = 1{afgebroken}) THEN
          BEGIN
               WriteXYC (Xb+3,AreaYb+3,cError,'X');
               Abort:=TRUE;
               GOTO Aborted;
          END;
          WriteXYC (Xb+3,AreaYb+3,cMessage,'*');
     END;

     IF (NewAreaRecCount <> OldAreaRecCount) THEN
        SortRes:=0; { wel wat aan veranderd }

     { de areabase naam gegevens zijn nu niet meer nodig. Verwijder }
     { die structuren om geheugen vrij te maken.                    }
     FOR Lp:=1 TO NameCount DO
         FreeMem (NamePtrs[Lp],NameLengths[Lp]);

     NameCount:=0;

     { maak een nieuwe areabase }
     { als SortRes=2 dan hoeven we geen nieuwe database aan te maken   }
     { maar zitten we even met het behouden van de oude base en toch   }
     { de nieuwe file gebruiken, zonder dat die aan het einde gesloten }
     { en verwijderd wordt. Laar maar even zo dus...                   }
     WriteXYC (Xb+3,AreaYb+4,cCustom1,'þ');
     IF CreateNewAreaBase THEN
     BEGIN
          WriteXYC (Xb+3,AreaYb+4,cError,'X');
          Abort:=TRUE;
          GOTO Aborted;
     END;

     WriteXYC (Xb+3,AreaYb+4,cMessage,'*');

     { maak een nieuwe userbase }
     WriteXYC (Xb+3,UserYb,cCustom1,'þ');
     IF CreateNewUserBase THEN
     BEGIN
          WriteXYC (Xb+3,UserYb,cError,'X');
          Abort:=TRUE;
          GOTO Aborted;
     END;
     WriteXYC (Xb+3,UserYb,cMessage,'*');

Aborted:

     { vernietig de tabel met informatie over de areabase }
     DestroyAreaDataTable;

     { zet de nieuwe databases op hun plaats }

     IF (NOT Abort) THEN
        LogMessage (liTrivial,'Putting new databases in place');

     IF (NOT Abort) THEN
     BEGIN
          { even wat statistieken wegschrijven }
          DelCount:=AreaBaseRecCount-TdbRecCount (NewAreaBaseTdbNr);
          Improve:=CalcImprove (DelCount,AreaBaseRecCount);
          LogExtraMessage ('        AreaBase: deleted '+AddUpWithSpaces (5,Word2String (DelCount))+
                           ' out of '+AddUpWithSpaces (5,Word2String (AreaBaseRecCount))+
                           ' records: '+Byte2String (Improve)+'%');

          DelCount:=UserBaseRecCount-TdbRecCount (NewUserBaseTdbNr);
          Improve:=CalcImprove (Delcount,UserBaseRecCount);
          LogExtraMessage ('        UserBase: deleted '+AddUpWithSpaces (5,Word2String (DelCount))+
                           ' out of '+AddUpWithSpaces (5,Word2String (UserBaseRecCount))+
                           ' records: '+Byte2String (Improve)+'%');

          DelCount:=SubscriptBaseRecCount-TdbRecCount (NewSubscrBaseTdbNr);
          Improve:=CalcImprove (DelCount,SubscriptBaseRecCount);
          LogExtraMessage ('SubscriptionBase: deleted '+AddUpWithSpaces (5,Word2String (DelCount))+
                           ' out of '+AddUpWithSpaces (5,Word2String (SubscriptBaseRecCount))+
                           ' records: '+Byte2String (Improve)+'%');

          { sluit de huidige databases }
          CloseDatabases;

          Assign (HulpFile,Config.SystemDir+AreaBaseFilename);
          {$I-} Rename (HulpFile,Config.SystemDir+'AREABASE.OLD'); {$I+} IORes:=IOResult;
          IF (IORes <> 0) THEN
          BEGIN
               LogDiskIOError (IORes,'Error renaming '+AreaBaseFilename+
                                     ' to '+Config.SystemDir+'AREABASE.OLD');
               GOTO FinalEnding;
          END;

          Assign (HulpFile,Config.SystemDir+UserBaseFilename);
          {$I-} Rename (HulpFile,Config.SystemDir+'USERBASE.OLD'); {$I+} IORes:=IOResult;
          IF (IORes <> 0) THEN
          BEGIN
               LogDiskIOError (IORes,'Error renaming '+Config.SystemDir+UserBaseFilename+
                                     ' to '+Config.SystemDir+'USERBASE.OLD');
               GOTO FinalEnding;
          END;

          Assign (HulpFile,Config.SystemDir+SubscriptBaseFilename);
          {$I-} Rename (HulpFile,Config.SystemDir+'SUBSCRIP.OLD'); {$I+} IORes:=IOResult;
          IF (IORes <> 0) THEN
          BEGIN
               LogDiskIOError (IORes,'Error renaming '+Config.SystemDir+SubscriptBaseFilename+
                                     ' to '+Config.SystemDir+'SUBSCRIP.OLD');
               GOTO FinalEnding;
          END;

          { sluit de nieuwe databases nu en hernoem die naar .TDB }
          IF (NOT TdbCloseAndRename (NewAreaBaseTdbNr,Config.SystemDir+AreaBaseFilename)) THEN
          BEGIN
               LogDiskIOError (TdbLastIOResult,'Error renaming new '+Config.SystemDir+NewAreaBaseFilename+
                                               ' to '+Config.SystemDir+AreaBaseFilename);
               TdbClose (NewUserBaseTdbNr);
               TdbClose (NewSubscrBaseTdbNr);
               GOTO FinalEnding;
          END;

          IF (NOT TdbCloseAndRename (NewUserBaseTdbNr,Config.SystemDir+UserBaseFilename)) THEN
          BEGIN
               LogDiskIOError (TdbLastIOResult,'Error renaming new '+Config.SystemDir+NewUserBaseFilename+
                                               ' to '+Config.SystemDir+UserBaseFilename);
               TdbClose (NewSubscrBaseTdbNr);
               GOTO FinalEnding;
          END;

          IF (NOT TdbCloseAndRename (NewSubscrBaseTdbNr,Config.SystemDir+SubscriptBaseFilename)) THEN
          BEGIN
               LogDiskIOError (TdbLastIOResult,'Error renaming new '+Config.SystemDir+NewSubscrBaseFilename+
                                               ' to '+Config.SystemDir+SubscriptBaseFilename);
               GOTO FinalEnding;
          END;

          { open nu de nieuwe databases }
          OpenDatabases;

          WriteXYC (Xb+3,ListYb,cCustom1,'þ');
          IF PackListUserDatabase THEN
             WriteXYC (Xb+3,ListYb,cMessage,'*')
          ELSE BEGIN
               WriteXYC (Xb+3,ListYb,cError,'X');
               Abort:=TRUE;
          END;

          IF Abort THEN
             WriteXYC (Xb+3,CfgYb,cBoxData,'-')
          ELSE BEGIN
               WriteXYC (Xb+3,CfgYb,cCustom1,'þ');

               IF FlexTdb_Pack THEN
               BEGIN
                    WriteXYC (Xb2,CfgYb,cBoxData,'100%');
                    WriteXYC (Xb+3,CfgYb,cMessage,'*');
               END ELSE
               BEGIN
                    WriteXYC (Xb+3,CfgYb,cError,'X');
                    Abort:=TRUE;
               END;
          END;

          IF Abort THEN
             WriteXYC (Xb+3,DupeYb,cBoxData,'-')
          ELSE BEGIN
               WriteXYC (Xb+3,DupeYb,cCustom1,'þ');

               CASE DupeCheck_PackDupeBase OF
                    0 : BEGIN
                             WriteXYC (Xb+3,DupeYb,cError,'X');
                             Abort:=TRUE;
                        END;
                    1 : WriteXYC (Xb+3,DupeYb,cMessage,'*'); { succes }
                    2 : WriteXYC (Xb+3,DupeYb,cBoxData,'-'); { nothing to do }
               END; { case }
          END;

          LogMessage (liTrivial,'Pack Databases finished');
     END ELSE
     BEGIN
          { abort }

          { sluit en verwijder de databases }
          TdbCloseAndErase (NewAreaBaseTdbNr);
          TdbCloseAndErase (NewUserBaseTdbNr);
          TdbCloseAndErase (NewSubscrBaseTdbNr);

          LogMessage (liGeneral,'Pack Databases aborted')
     END;

FinalEnding:

     LogClose;

     IF (NOT Automatic) THEN
     BEGIN
          WriteKeysLine (' Done, press any key to continue...');
          ReadKey;
     END;

     WindowPop;
     PopKeysLine;
END;


{---------------------------------------------------------------------------}
{ unit initialization                                                       }
{                                                                           }
BEGIN
     ForceNoSort:=FALSE; { altijd sorteren, tenzijn -NOSORT op cmdline }
END.

