UNIT Database;

{ Routines om de .TDB databases te manipuleren }

{ History:

RvdW 20-02-93 Deze unit was er al bij WtrConf
     26-02-93 Uitgebreid met FindUserBaseRecordByFidoAddress om vanuit de
              Import routines een UserBase record nummer te kunnen vinden.
     02-03-93 IndexTable aangemaakt in plaats van de AreaIndexDatabase.
     27-03-93 Opgeruimd. Oude AreaIndexBase routines verwijdered.
              Velden Moderated en Moderator toegevoegd.
     27-03-93 Bij het editten van een System Config werd de SystemDir
              pathname aangvuld met spaties. Bij het aanroepen van
              OpenDatabases mislukten de pad-constructies en dit resulteerde
              in foutmeldingen in de TDB unit, die niet terug te voeren
              waren. Kut bug, maar is nu weg!
     27-03-93 Aliases bij de Node gegevens toegevoegd.
     30-03-93 Index tabel kan nu on-line uitgebreid worden door de extra
              20 entries die nu bij inlezen vrijgehouden worden. Daarna moet
              er alsnog gejunked en opniew ingelezen woden. Nieuwe procedure:
              AddIndexValueToAreaBaseIndexTable
     30-03-93 AddUserToAreaSubscrList en AddAreaToUserSubscrToList
              uitgebreid met controle of de connectie er al is. Dan wordt
              deze niet nog een gelegd. Dit voorkomt dubbel aansluiten bij
              twee keer importeren.
     02-04-93 Bugfixje in GetFirstAreaUserIsSubscrTo. Als er meerdere
              Subscription record door een user in gebruik waren en de eerste
              bevatte alleen NILRecordNr's, dan werd de tweede ingeladen en
              op element 0 ipv 1 verder gegaan. Dit gaf af en toe een area
              die aangesloten zou zijn terwijl deze het niet was.
     16-05-93 FindUserBaseRecordByFidoAddress verbeterd. UserBase records
              die Deleted zijn worden nu niet meer bekeken.
     31-05-93 UserBase Index routines toegevoegd.
     07-06-93 .TDB headers ingevoerd.
     13-06-93 Index op de domain namen aangelegd. Nu hoeft er nog maar in
              een tabel met (zonet 7) domain naam CRC waarden gekeken te
              worden en niet meer alle userbase record ingelezen te worden
              en een voor een gecontroleerd. Dit was nodig ivm de path line
              controleer routines voor het Exported vlaggen.

MD   18-06-93 Toevoegen van AreaRecord.FidoMsgPath   Doel Directory
                                       FidoMsgStyle  Exporteren naar Fido *.MSG ?
                                       FidoMsgLimit  Maximum berichten in directory
                                       FidoMsgAge    Maximum leeftijd berichten
MD   25-06-93 Toevoegen van UserBase   SendType
     17-07-93 Bugfix in FindUserBaseRecordByUUCPname (opgelost met DeleteBackspaces)
     25-07-93 FidoMsgStyle veranderd van een boolean naar een keuze naar het type
              MsgBase ( None , FidoMsg , Squish )
     10-09-93 Toevoegen van JAM aan de MsgBase lijst
     06-11-93 Bugfix in de SubScriptionPack routine, de teller werd voor
              lege entry's niet altijd correct geupdate.
              Toevoegen van een controle tabel, elk userbase of areabase
              record dat GEEN nieuwe entry in de subscription base krijgt
              wordt gereset.
              De WorldRegistered Option veranderd in een Allow SubDomains
              Option. Het is nu mogenlijk om een node te verbieden om
              mail voor sub-domains te ontvangen. Als deze optie aan staat
              wordt mail voor Jaap@Subdomain.Domain.nl ook via Domain.Nl
              gestuurd.
     23-05-94 Subscription base pack flink versnelt?
RWI  18-10-94 Takeover, re-layout van nieuwe routines en packing bugfixing
              van de UserBase.
     19-10-94 ReWrite van PackAreaBase en PackSubscrBase routines.
     26-11-94 Groups database uitgebreid met Read-Only vlag en
              ReadWriteGroupsFilter toegevoegd.
}


{ belangrijke opmerking over de SubscriptBase: Deze wordt dubbel gebruikt.
  Vanaf de AreaBase wordt daar in groepjes van 5 bijgehouden welke users
  (=nodes/systemen/etc) er op ingeschreven zijn. Vanaf de UserBase wordt
  er in dezelfde groepjes in bijgehouden welke areas die user heeft aan-
  gesloten. In de SubscriptBase zitten dus alleen record nummers.         }

{ het bovenstaande nog duidelijker: een subscription base record bevat OF
  vijf userbase record nummers OF vijf areabase record nummers. In het
  areabase record staat in het veld UserList het recordnummer van de
  subscription base waarin vijf userbase record nummers staan. Omgekeerd
  staat in het userbase record in AreaList het subscriptionbase record
  nummer waarin maximaal vijf areabase record nummers staan van areas waarop
  de user is aangesloten. Als het er meer dan 5 moeten zijn, dan wijst het
  subscriptionbase record door naar een volgend subscription base record. }

INTERFACE

USES Tdb;

CONST MaxLenAreaName        = 60;      { maximale lengte van een area name }
      MaxLenComment         = 60;    { maximale lengte van de omschrijving }
      MaxLenOrigin          = 61;
      MaxLenUserName        = 50;
      MaxLenSysopName       = MaxLenUserName;
      MaxLenModerator       = MaxLenUserName;
      MaxLenUUCPName        = 10;
      MaxLenDomain          = 50; {100}
      MaxLenOrganization    = 60;
      MaxLenGroupDesc       = 30;
      MaxLenListNameType    = 30;
      MaxLenListPswdType    = 12;
      NILRecordNr : WORD    = 65535;            { record nummer NIL waarde }
      MaxSubscrBaseElements = 5;
      MaxDomains            = 6;
      MaxLenAreaFixPwd      = 20;

      Group_Z = $02000000;
      GR_ALL  = $03FFFFFF;

TYPE
{ index }
     IndexValueType = LONGINT;

{ area base }
     GroupFlagType  = LONGINT; { bit mask }
     AreaFlagType   = LONGINT; { bit mask }
     AreaNameString = STRING[MaxLenAreaName];
     mdType         = (mdNONE,mdUSE) {,mdFIDO)};

     AreaRecordType = (area_echo,area_netmail,area_local);

{ user base }
     SystemType      = (_F,_U,_B);
     ListSystemType  = (lstName,lstFido,lstUsenet);
     SendType        = (NORMAL,HOLD,CRASH,DIRECT);
     CompressionType = (ARC,ARJ,LZH,PAK,ZIP,ZOO,OP1,GUS,PKT);
     UseCompressType = (USE_NONE,USE_COMPRESS,USE_ZIP);

{ listserver base }
     ListNameType = STRING[MaxLenListNameType];
     ListPswdType = STRING[MaxLenListPswdType];

     { Tof, nu beginnen de meeste namen toch wel gebruikt te raken..}
     FidoMsgStyleType = (NoneType,
                         FidoMsgType,
                         SquishType,
                         JamType,
                         PCBoardType);

CONST ComprDescr : ARRAY[ARC..PKT] OF STRING[3] = ('ARC','ARJ','LZH','PAK','ZIP','ZOO','OP1','GUS','PKT');
      SendName   : ARRAY[SENDTYPE] OF STRING[3] = ('FLO','HLO','CLO','DLO');

{======= Verplaatsingen uit FIDO.PAS ivm Circulair Unit References ======}
CONST MaxLenFidoAddrDomain = 25;
      MaxLenFidoAddrString = 23+MaxLenFidoAddrDomain;

TYPE FidoAddrType = RECORD
                          Zone   : WORD;
                          Net    : WORD;
                          Node   : WORD;
                          Point  : WORD;
                          Domain : STRING[MaxLenFidoAddrDomain];
                    END;
{======= Einde verplaatsingen uit FIDO.PAS =======}

{ group desc base }
TYPE GroupDescRecord = RECORD
                             GroupDesc : STRING[MaxLenGroupDesc];
                             OriginAka : 1..10; { hard code, sorry... }
                             Readonly  : BOOLEAN; { RWI 941126: New }
                       END;

     GroupNrType     = 1..26; { A..Z }

     UUCPNameString  = STRING[MaxLenUUCPName];

{ databases }
     BaseRecordNrType          = WORD;  { max. WORD ivm Select Routines!! }
     AreaBaseRecordNrType      = BaseRecordNrType;
     SubscriptBaseRecordNrType = BaseRecordNrType;
     UserBaseRecordNrType      = BaseRecordNrType;
     GroupDescBaseRecordNrType = BaseRecordNrType;
     ListServerRecordNrType    = BaseRecordNrType;

     AreaBaseRecord = RECORD
                            Deleted    : BOOLEAN; { deleted record? (=TRUE) }

                            AreaType   : AreaRecordType;

                            AreaName_U,
                            AreaName_F : AreaNameString;

                            Comment    : STRING[MaxLenComment];
                            IsInGroups : GroupFlagType;
                            UserList   : SubscriptBaseRecordNrType;

                            { Fido special }
                            OriginAka  : BYTE;    { offset in Config.NodeNrs }
                            SeenByAkas : LONGINT; { bits 0-9: aan SeenBy toe te voegen AKAs  }

                            Passive    : BOOLEAN; { Make passive when uplink is disconnected }
                            AlwPassive : BOOLEAN; { Do not make this area passive            }

                            { bij import van Usenet }
                            OriginNr   : BYTE; {1/2 for default 0=custom }
                            Origin     : STRING[MaxLenOrigin];

                            { Fidonet special }
                            FidoMsgStyle: FidoMsgStyleType;
                            FidoMsgPath : STRING[79];
                            FidoMsgAge  : INTEGER; { in dagen     }
                            FidoMsgLimit: INTEGER; { in berichten }

                            { Usenet special  }
                            Moderated    : mdType;
                            Moderator    : STRING[MaxLenModerator];
                      END;

     SubscriptBaseRecord = RECORD
                                 NextSegmentRecordNr : SubscriptBaseRecordNrType;

                                 CASE INTEGER OF
                                      0 : (UserList : ARRAY[1..MaxSubscrBaseElements] OF UserBaseRecordNrType);
                                      1 : (AreaList : ARRAY[1..MaxSubscrBaseElements] OF AreaBaseRecordNrType);
                           END;

     UserBaseRecord = RECORD
                            Deleted       : BOOLEAN; { record is free? }

                            System        : SystemType;
                            Organization  : STRING[MaxLenOrganization];
                            Groups        : GroupFlagType;
                            Passive       : BOOLEAN;
                            AreaFixPwd    : STRING[MaxLenAreaFixPwd];
                            AllowFrom     : BOOLEAN;
                            AllowCreate   : BOOLEAN;

                            NewAreaDefault: GroupFlagType; {*}
                            AllowForward  : BOOLEAN; {*}

                            AreaList     : SubscriptBaseRecordNrType;
                            UUCPName     : STRING[MaxLenUUCPName];
{ Allow Sub Domains }       WorldReg     : BOOLEAN;
                            Domains      : ARRAY[1..MaxDomains] OF STRING[MaxLenDomain];

                            CASE INTEGER OF
                        { Fido } 0 : (Address      : FidoAddrType;
                                      Sysop        : STRING[MaxLenSysopName];
                                      PacketPwd    : STRING[8];
                                      Compression  : CompressionType;
                                      MaxPktLength : LONGINT;
                                      SendFormat   : SendType;
                                      LastArchDow  : BYTE; { 0 = first, 1..7 = dow }
                                      LastArchNr   : BYTE; { 0..n = nummer }
                                     );

                      { Usenet } 1 : (Compress     : UseCompressType;
                                      CunBatch     : BOOLEAN;
                                      BAGbacklink  : STRING[MaxLenUUCPName];
                                     );
                      END;

{ subscriberslist search record }
     SubscrSearchRecord = RECORD
                                { public fields:}
                                Found : BOOLEAN;

                                {private fields:}
                                SubscrRecNr : SubscriptBaseRecordNrType;
                                SubscrData  : SubscriptBaseRecord;
                                Element     : 0..MaxSubscrBaseElements;

                                { public fields: }
                                CASE INTEGER OF
                                     0 : (UserBaseRecordNr : UserBaseRecordNrType);
                                     1 : (AreaBaseRecordNr : AreaBaseRecordNrType);
                          END;

{ ListServer database record }
    ListServerRecord = RECORD
                             Deleted     : BOOLEAN;
                             ListSystem  : ListSystemType;
                             NextUser    : ListServerRecordNrType;

                             CASE INTEGER OF
                                  {ServerInfo}
                                  0 : (ListName        : ListNameType;
                                       ListDescription : STRING[40];
                                       ListWelcome     : STRING[79]; {*}
                                       ListAKA         : BYTE;
                                       AllowRemote     : BOOLEAN;
                                       OnlyKnown       : BOOLEAN;
                                       Active          : BOOLEAN;
                                       AreaName        : STRING[MaxLenAreaName];
                                       EchoList        : BOOLEAN; { From list to echo }
                                       ListEcho        : BOOLEAN); { From echo to list }

                                  {Fido}
                                  1 : (Address : FidoAddrType;
                                       Name    : STRING[MaxLenSysopName]);

                                  {Usenet}
                                  2 : (Domain  : STRING[MaxLenDomain]);
                       END;

VAR AreaIndexBaseTdbNr,
    AreaBaseTdbNr,
    SubscriptBaseTdbNr,
    UserBaseTdbNr,
    ListServerTdbNr,
    GroupDescBaseTdbNr    : TdbNrType;
    ReadWriteGroupsFilter : GroupFlagType; { GR_ALL min all Read-only groups bits }

{ algemeen }
FUNCTION  OpenDatabases : BOOLEAN;
PROCEDURE CloseDatabases;

{ area index base acties }
FUNCTION  GetAreaNameIndexValue (AreaName : AreaNameString) : IndexValueType;
PROCEDURE ReadAreaBaseIndexTable;
PROCEDURE JunkAreaBaseIndexTable;
PROCEDURE AddIndexValueToAreaBaseIndexTable (IndexValue : IndexValueType);
{PROCEDURE DeleteIndexValueFromAreaBaseIndexTable (IndexValue : IndexValueType);}
FUNCTION  GetAreaBaseRecordNrByIndexValue_U (Index : IndexValueType) : AreaBaseRecordNrType;
FUNCTION  GetAreaBaseRecordNrByIndexValue_F (Index : IndexValueType) : AreaBaseRecordNrType;
FUNCTION  GetAreaBaseRecordNrByAreaName_F (AreaName : AreaNameString) : AreaBaseRecordNrType;
FUNCTION  GetAreaBaseRecordNrByAreaName_U (AreaName : AreaNameString) : AreaBaseRecordNrType;

{ user index base acties }
FUNCTION  GetUserBaseRecordNrByAddress (Zone,Net,Node,Point : WORD) : UserBaseRecordNrType;
{FUNCTION  GetUserBaseRecordNrByAddress (Net,Node : WORD) : UserBaseRecordNrType;}
PROCEDURE ReadUserBaseIndexTable;
PROCEDURE JunkUserBaseIndexTable;

{ area base acties }
FUNCTION  AreaBaseRecCount : AreaBaseRecordNrType;
FUNCTION  ReadAreaBaseRecord (RecNr : AreaBaseRecordNrType; VAR AreaData : AreaBaseRecord): BOolean;
PROCEDURE WriteAreaBaseRecord (RecNr : AreaBaseRecordNrType; VAR AreaData : AreaBaseRecord);
FUNCTION  WriteNewAreaBaseRecord (VAR AreaData : AreaBaseRecord) : AreaBaseRecordNrType;
FUNCTION  PackAreaBase : BOOLEAN;

{ group descriptions }
PROCEDURE ReadGroupDescRecord (RecNr : GroupDescBaseRecordNrType; VAR GroupData : GroupDescRecord);
PROCEDURE WriteGroupDescRecord (RecNr : GroupDescBaseRecordNrType; VAR GroupData : GroupDescRecord);

{ description builders }
FUNCTION  BuildGroupListDesc (Group : GroupFlagType) : STRING;

{ group acties }
PROCEDURE AddGroupToGroupList (VAR Group : GroupFlagType; NewGroupNr : GroupNrType);
PROCEDURE DeleteGroupFromGroupList (VAR Group : GroupFlagType; DelGroupNr : GroupNrType);
FUNCTION  TestIfInGroup (Group : GroupFlagType; GroupNr : GroupNrType) : BOOLEAN;

{ user base acties }
FUNCTION  UserBaseRecCount : UserBaseRecordNrType;
PROCEDURE ReadUserBaseRecord (RecNr : UserBaseRecordNrType; VAR UserData : UserBaseRecord);
PROCEDURE WriteUserBaseRecord (RecNr : UserBaseRecordNrType; VAR UserData : UserBaseRecord);
FUNCTION  FindUserBaseRecordByFidoAddress (Search : FidoAddrType; VAR RecNr : UserBaseRecordNrType) : BOOLEAN;
FUNCTION  FindUserBaseRecordByUUCPName (Search : UUCPNameString; VAR RecNr : UserBaseRecordNrType) : BOOLEAN;
FUNCTION  PackUserBase : BOOLEAN;
{PROCEDURE ReadDomainsList;}
{PROCEDURE JunkDomainsList;}
{FUNCTION  IsKnownDomain (Name : STRING) : UserBaseRecordNrType;}

{ subscript base acties }
PROCEDURE FixSubScrRecord (VAR Search : SubscrSearchRecord; InvalidValue : LONGINT; InAreaList : BOOLEAN);
PROCEDURE GetFirstUserSubscribedToThisArea (FirstUserList : SubscriptBaseRecordNrType; VAR Search : SubscrSearchRecord);
PROCEDURE GetNextUserSubscribedToThisArea (VAR Search : SubscrSearchRecord);

FUNCTION  AddAreaToUserSubscrToList (VAR UserData : UserBaseRecord; AreaBaseRecordNr : AreaBaseRecordNrType) : BOOLEAN;
FUNCTION  RemoveAreaFromUserSubscrToList (VAR UserData : UserBaseRecord;
                                          SearchAreaBaseRecordNr : AreaBaseRecordNrType) : BOOLEAN;
FUNCTION  PackSubScrBase : BOOLEAN;
FUNCTION  SubscriptBaseRecCount : SubscriptBaseRecordNrType;
PROCEDURE ReadSubscriptBaseRecord (RecNr : SubscriptBaseRecordNrType; VAR Data : SubscriptBaseRecord);
PROCEDURE WriteSubscriptBaseRecord (RecNr : SubscriptBaseRecordNrType; VAR Data : SubscriptBaseRecord);
PROCEDURE EmptySubscriptBaseRecord (VAR SubscrData : SubscriptBaseRecord);
PROCEDURE GetFirstAreaUserIsSubscribedTo (FirstAreaList : SubscriptBaseRecordNrType; VAR Search : SubscrSearchRecord);
PROCEDURE GetNextAreaUserIsSubscribedTo (VAR Search : SubscrSearchRecord);
FUNCTION  AddUserToAreaSubscrList (VAR AreaData : AreaBaseRecord; UserBaseRecordNr : UserBaseRecordNrType) : BOOLEAN;
PROCEDURE RemoveUserFromAreaSubscrList (VAR AreaData : AreaBaseRecord; SearchUserBaseRecordNr : UserBaseRecordNrType);
FUNCTION  TestIfUserIsInAreaRec_UserList (UserList : SubscriptBaseRecordNrType; UserRecNr : UserBaseRecordNrType) : BOOLEAN;
FUNCTION  TestIfAreaIsInUserRec_AreaList (AreaList : SubscriptBaseRecordNrType; AreaRecNr : AreaBaseRecordNrType) : BOOLEAN;

{ List Server routines }
FUNCTION  ReadListBaseRecord (RecNr : ListServerRecordNrType; VAR ListData : ListServerRecord) : BOOLEAN;
FUNCTION  WriteNewListBaseRecord (VAR ListData : ListServerRecord) : ListServerRecordNrType;
PROCEDURE WriteListBaseRecord (RecNr : ListServerRecordNrType; VAR ListData : ListServerRecord);
FUNCTION  ListBaseRecCount : ListServerRecordNrType;
PROCEDURE AddUserToList (SourceList : ListServerRecordNrType; VAR Source : ListServerRecord; VAR User : ListServerRecord);
FUNCTION  PackListServerDatabase : BOOLEAN;


IMPLEMENTATION

USES Ramon,
     Cfg,
     Globals,
     Logs,
     DList,
     Fido;

CONST AreaBaseHeader     = 'WtrGate AreaBase 03';
      UserBaseHeader     = 'WtrGate UserBase 03';
      SubscrBaseHeader   = 'WtrGate SubscrBase 01';
      GrpDescrBaseHeader = 'WtrGate GroupDescr 02';
      ListServerHeader   = 'WtrGate ListServer 02';

      AreaIndexBaseFilename = 'AREAINDX.TDB';     { allemaal in de current }
      AreaBaseFilename      = 'AREABASE.TDB';     { directory }
      SubscriptBaseFilename = 'SUBSCRIP.TDB';
      UserBaseFilename      = 'USERBASE.TDB';
      GroupDescBaseFilename = 'GRPDESCR.TDB';
      ListServerFileName    = 'LISTSERV.TDB';

TYPE AreaBaseIndexTablePtr = ^AreaBaseIndexTable;
     AreaBaseIndexTable    = ARRAY[1..16382] OF IndexValueType;

     UserBaseIndexRecord   = RECORD
                                   RZone,
                                   RNet,
                                   RNode,
                                   RPoint: Word;
                             END;

     UserBaseIndexTablePtr = ^UserBaseIndexTable;
     UserBaseIndexTable    = ARRAY[1..8191] OF UserBaseIndexRecord;

{    DomainsListPointer = ^DomainsListArray; }
     DomainsListRecord  = RECORD
                                AllowSub  : Boolean;
                                DomainPtr : ^String;
{                               CRC : IndexValueType;             {4}
                                UserRecNr : UserBaseRecordNrType; {2}
                          END;
{    DomainsListArray   = ARRAY[1..10921] OF DomainsListRecord; }

VAR AreaIndexTablePtr_U,
    AreaIndexTablePtr_F: AreaBaseIndexTablePtr;
    AreaIndexTableSize : WORD;                   { voor FreeMem en zoeken }
    AreaIndexTableFree : BYTE;                { voor FreeMem en toevoegen }

    UserIndexTablePtr  : UserBaseIndexTablePtr;
    UserIndexTableSize : WORD;  { aantal entries, is sneller dan UserCnt  }

    DomainsListCount   : WORD;
    DomainsList        : LIST; { van DomainsListRecord }


{=== Algemene Routines ====================================================}

{--------------------------------------------------------------------------}
{ OpenDatabases                                                            }
{                                                                          }
{ Deze routine opent alle vier de databases. Deze routine moet worden aan- }
{ geroepen voordat de andere routines in deze unit gebruikt kunnen worden. }
{ Aan het eind met CloseDatabases aangeroepen worden.                      }
{ Deze routine gaat er een beetje grof vanuit dat de files bestaan, als    }
{ dat niet zo is worden nieuwe files opgezet. Dit kan problemen met        }
{ verwijzingen opleveren als een van de files niet bestaat...              }
{ Voor de GroupDesc lijst wordt gecontroleerd of er wel 26 records zijn.   }
{ Zoniet, dan worden de records aangevuld tot 26 met de descriptions dat   }
{ die nog niet ingevuld is.                                                }
{                                                                          }
{ Dit zomaar aanmaken heeft funny gevolgen als je aan het testen bent      }
{ en er staan wat directory's scheef, gevolg een halve harde schijf met    }
{ *.TDB's.                                                                 }
{                                                                          }
FUNCTION OpenDatabases : BOOLEAN;

CONST MsgIncompTdb = 'þ Incompatible database type for ';
      MsgCantOpen  = 'þ Cannot open ';
      MsgLowXMS    = '[OpenDatabases] Not enough XMS memory to cache ';

VAR GroupData : GroupDescRecord;
    Lp        : GroupDescBaseRecordNrType;

BEGIN
     OpenDatabases:=FALSE; { assume error }

     Config.SystemDir:=DeleteBackSpaces (Config.SystemDir);

     IF (TdbOpen (Config.SystemDir+AreaBaseFilename,AreaBaseTdbNr) = _TdbNotFound) THEN
{$IFDEF WtrConf}
        IF (TdbOpen (AreaBaseFilename,AreaBaseTdbNr) = _TdbNotFound) THEN
           IF (TdbCreate (Config.SystemDir+AreaBaseFilename,AreaBaseHeader,AreaBaseTdbNr) <> _TdbOk) THEN
{$ENDIF}
           BEGIN
                WriteLn (MsgCantOpen,Config.SystemDir,AreaBaseFilename);
                Exit;
           END;

     TdbSetIO (AreaBaseTdbNr,SizeOf (AreaBaseRecord));
     IF (TdbReadHeader (AreaBaseTdbNr) <> AreaBaseHeader) THEN
     BEGIN
          WriteLn (MsgIncompTdb,AreaBaseFilename);
          Exit;
     END;

{$IFDEF WtrGate}
     IF Config.CacheTdbs AND TdbCache (AreaBaseTdbNr) THEN
        LogMessage (MsgLowXMS+AreaBaseFilename);
{$ENDIF}

     IF (TdbOpen (Config.SystemDir+SubscriptBaseFilename,SubscriptBaseTdbNr) = _TdbNotFound) THEN
{$IFDEF WtrConf}
        IF (TdbOpen (SubscriptBaseFilename,SubscriptBaseTdbNr) = _TdbNotFound) THEN
           IF (TdbCreate (Config.SystemDir+SubscriptBaseFilename,SubscrBaseHeader,SubscriptBaseTdbNr) <> _TdbOk) THEN
{$ENDIF}
           BEGIN
                WriteLn (MsgCantOpen,Config.SystemDir,SubscriptBaseFilename);
                Exit;
           END;

     TdbSetIO (SubscriptBaseTdbNr,SizeOf (SubscriptBaseRecord));
     IF (TdbReadHeader (SubscriptBaseTdbNr) <> SubscrBaseHeader) THEN
     BEGIN
          Writeln (MsgIncompTdb,SubscriptBaseFilename);
          Exit;
     END;

{$IFDEF WtrGate}
     IF Config.CacheTdbs AND TdbCache (SubscriptBaseTdbNr) THEN
        LogMessage (MsgLowXMS+SubscriptBaseFilename);
{$ENDIF}

     IF (TdbOpen (Config.SystemDir+UserBaseFilename,UserBaseTdbNr) = _TdbNotFound) THEN
{$IFDEF WtrConf}
        IF (TdbOpen (UserBaseFilename,UserBaseTdbNr) = _TdbNotFound) THEN
           IF (TdbCreate (Config.SystemDir+UserBaseFilename,UserBaseHeader,UserBaseTdbNr) <> _TdbOk) THEN
{$ENDIF}
           BEGIN
                WriteLn (MsgCantOpen,Config.SystemDir,UserBaseFilename);
                Exit;
           END;

     TdbSetIO (UserBaseTdbNr,SizeOf (UserBaseRecord));
     IF (TdbReadHeader (UserBaseTdbNr) <> UserBaseHeader) THEN
     BEGIN
          Writeln (MsgIncompTdb,UserBaseFilename);
          Exit;
     END;

{$IFDEF WtrGate}
     IF Config.CacheTdbs AND TdbCache (UserBaseTdbNr) THEN
        LogMessage (MsgLowXMS+UserBaseFilename);
{$ENDIF}

     IF (TdbOpen (Config.SystemDir+GroupDescBaseFilename,GroupDescBaseTdbNr) = _TdbNotFound) THEN
{$IFDEF WtrConf}
        IF (TdbOpen (GroupDescBaseFilename,GroupDescBaseTdbNr) = _TdbNotFound) THEN
           IF (TdbCreate (Config.SystemDir+GroupDescBaseFilename,GrpDescrBaseHeader,GroupDescBaseTdbNr) <> _TdbOk) THEN
{$ENDIF}
           BEGIN
                WriteLn (MsgCantOpen+Config.SystemDir,GroupDescBaseFilename);
                Exit;
           END;

     TdbSetIO (GroupDescBaseTdbNr,SizeOf (GroupDescRecord));
     IF (TdbReadHeader (GroupDescBaseTdbNr) <> GrpDescrBaseHeader) THEN
     BEGIN
          WriteLn (MsgIncompTdb,GroupDescBaseFilename);
          Exit;
     END;

     IF (TdbOpen (Config.SystemDir+ListServerFileName,ListServerTdbNr) = _TdbNotFound) THEN
{$IFDEF WtrConf}
        IF (TdbOpen (ListServerFileName,ListServerTdbNr) = _TdbNotFound) THEN
           IF (TdbCreate (Config.SystemDir+ListServerFilename,ListServerHeader,ListServerTdbNr) <> _TdbOk) THEN
{$ENDIF}
           BEGIN
                WriteLn (MsgCantOpen,Config.SystemDir,ListServerFilename);
                Exit;
           END;

     TdbSetIO (ListServerTdbNr,SizeOf (ListServerRecord));
     IF (TdbReadHeader (ListServerTdbNr) <> ListServerHeader) THEN
     BEGIN
          WriteLn (MsgIncompTdb,ListServerFilename);
          Exit;
     END;

{$IFDEF WtrGate}
     IF Config.CacheTdbs AND TdbCache (ListServerTdbNr) THEN
        LogMessage (MsgLowXMS+ListServerFilename);
{$ENDIF}

     IF (TdbRecCount (GroupDescBaseTdbNr) < 26) THEN
     BEGIN
          GroupData.GroupDesc:=AddUpWithSpaces (MaxLenGroupDesc,'<no description>');
          GroupData.OriginAka:=1;
          GroupData.ReadOnly:=FALSE;

          FOR Lp:=TdbRecCount (GroupDescBaseTdbNr)+1 TO 25 DO
              TdbWrite (GroupDescBaseTdbNr,Lp,GroupData);

          GroupData.GroupDesc:=AddUpWithSpaces (MaxLenGroupDesc,'Auto created Areas');
          TdbWrite (GroupDescBaseTdbNr,26,GroupData);
     END;

     { doorloop de groups database en kijk welke areas read-only zijn. }
     { dit filter is belangrijk bij het verwerken om te kijken of de   }
     { area ook in een group zit die read/write is EN waar de user     }
     { toegang toe heeft. Voor iedere area die NIET read-only is wordt }
     { het bitje gezet. Het wordt dus een AND filter voor read/write   }
     { groups.                                                         }
     ReadWriteGroupsFilter:=GR_ALL;
     FOR Lp:=1 TO 26 DO
     BEGIN
          TdbRead (GroupDescBaseTdbNr,Lp,GroupData);
          IF GroupData.ReadOnly THEN
             ReadWriteGroupsFilter:=ReadWriteGroupsFilter-(Longint (1) SHL (Lp-1));
     END;

     OpenDatabases:=TRUE; { no error found }
END;


{--------------------------------------------------------------------------}
{ CloseDatabases                                                           }
{                                                                          }
{ Deze routine sluit de databases die met OpenDatabases zijn geopend.      }
{ RWI 181094: Close List Server database toegevoegd.                       }
{                                                                          }
PROCEDURE CloseDatabases;
BEGIN
     IF (AreaBaseTdbNr      <> TdbClosedNr) THEN TdbClose (AreaBaseTdbNr);
     IF (SubscriptBaseTdbNr <> TdbClosedNr) THEN TdbClose (SubscriptBaseTdbNr);
     IF (UserBaseTdbNr      <> TdbClosedNr) THEN TdbClose (UserBaseTdbNr);
     IF (GroupDescBaseTdbNr <> TdbClosedNr) THEN TdbClose (GroupDescBaseTdbNr);
     IF (ListServerTdbNr    <> TdbClosedNr) THEN TdbClose (ListServerTdbNr);
END;


{=== AreaIndexBase Routines ===============================================}

{---------------------------------------------------------------------------}
{ GetAreaNameIndexValue                                                     }
{                                                                           }
{ Deze routine berekend de IndexValue voor de AreaNameIndexDatabase waarmee }
{ snel gezocht kan worden naar een area. De AreaName wordt eerst op lengte  }
{ gemaakt door deze aan te vullen met spaties tot de MaxLenAreaName lengte. }
{                                                                           }
FUNCTION GetAreaNameIndexValue (AreaName : AreaNameString) : IndexValueType;

VAR LocalAreaName : STRING[MaxLenAreaName];

BEGIN
     LocalAreaName:=AddUpWithSpaces (MaxLenAreaName,AreaName);
     GetAreaNameIndexValue:=UpdateCRC32 (0,LocalAreaName[1],Length (LocalAreaName));
END;


{--------------------------------------------------------------------------}
{ ReadAreaBaseIndexTable                                                   }
{                                                                          }
{ Deze routine maakt in het geheugen een tabel aan met de index values van }
{ alle areabase records. Hiervoor worden alle areabase records een voor    }
{ een ingelezen en aan de hand van de AreaName in het record een Index     }
{ Value berekend en opgeslagen in de tabel. Net voor het aantal aanwezige  }
{ areabase records wordt er geheugen aangevraagd. De databases moeten open }
{ zijn.                                                                    }
{                                                                          }
PROCEDURE ReadAreaBaseIndexTable;

VAR Lp       : AreaBaseRecordNrType;
    AreaData : AreaBaseRecord;

BEGIN
     IF (AreaIndexTablePtr_F <> NIL) THEN
     BEGIN
          Error ('[ReadAreaBaseIndexTable] AreaIndexTablePtr is not NIL; Junk IndexTable first!');
          Exit;
     END;

     AreaIndexTableSize:=AreaBaseRecCount;
     AreaIndexTableFree:=40; { aantal online toevoegbare entries }

     GetMem (AreaIndexTablePtr_F,(AreaIndexTableSize+AreaIndexTableFree)*sizeof( IndexValueType ));
     GetMem (AreaIndexTablePtr_U,(AreaIndexTableSize+AreaIndexTableFree)*sizeof( IndexValueType ));
     PeekMem;
     FOR Lp:=1 TO AreaIndexTableSize DO
     BEGIN
          ReadAreaBaseRecord (Lp,AreaData);
          IF (AreaData.Deleted) OR (AreaData.IsInGroups = 0) THEN
          BEGIN
               AreaIndexTablePtr_F^[Lp]:=0;
               AreaIndexTablePtr_U^[Lp]:=0;
          END ELSE
          BEGIN
               AreaIndexTablePtr_F^[Lp]:=GetAreaNameIndexValue (AreaData.AreaName_F);
               AreaIndexTablePtr_U^[Lp]:=GetAreaNameIndexValue (AreaData.AreaName_U);
          END;
     END;
END;


{--------------------------------------------------------------------------}
{ JunkAreaBaseIndexTable                                                   }
{                                                                          }
{ Deze routine gooit de index tabel die in het geheugen is aangemaakt weer }
{ weg. Dit moet zowiezo aan het einde van het programma, maar moet ook als }
{ er online nieuwe areas zijn aangemaakt en de index tabel dus niet meer   }
{ up to date is.                                                           }
{                                                                          }
PROCEDURE JunkAreaBaseIndexTable;
BEGIN
     IF (AreaIndexTablePtr_F = NIL) THEN
        Exit;

     FreeMem (AreaIndexTablePtr_F,(AreaIndexTableSize+AreaIndexTableFree)*SizeOf (IndexValueType));
     FreeMem (AreaIndexTablePtr_U,(AreaIndexTableSize+AreaIndexTableFree)*SizeOf (IndexValueType));

     AreaIndexTablePtr_F:=NIL;
     AreaIndexTablePtr_U:=NIL;
END;


{--------------------------------------------------------------------------}
{ AddIndexValueToAreaBaseIndexTable                                        }
{                                                                          }
{ Deze routine voegt een IndexValue toe aan de index tabel. Eerst zijn er  }
{ nog een paar vrij, maar daarna moet eerst de hele tabel geJunked worden  }
{ en opnieuw ingelezen worden.                                             }
{                                                                          }
PROCEDURE AddIndexValueToAreaBaseIndexTable (IndexValue : IndexValueType);

VAR OldColor : ColorSet;

BEGIN
     IF (AreaIndexTableFree = 0) THEN
     BEGIN
          OldColor:=GetColor;
          Message ('Reconstructing index tables after adding new areas');
          JunkAreaBaseIndexTable;
          ReadAreaBaseIndexTable;
          WindowPop; { message }
          SetColor (OldColor);
     END;

     Dec (AreaIndexTableFree);
     Inc (AreaIndexTableSize);

     AreaIndexTablePtr_F^[AreaIndexTableSize]:=IndexValue;
     AreaIndexTablePtr_U^[AreaIndexTableSize]:=IndexValue;
END;

{
PROCEDURE DeleteIndexValueFromAreaBaseIndexTable (IndexValue : IndexValueType);
BEGIN
     AreaIndexTablePtr^[AreaIndexTableSize]:=0;
END;
}


{--------------------------------------------------------------------------}
{ GetAreaBaseRecordNrByIndexValue                                          }
{                                                                          }
{ Deze routine zoekt in de index tabel die in het geheugen moet zijn inge- }
{ laden naar het AreaBase record nummer dat bij de opgegeven Index Value   }
{ hoort.                                                                   }
{                                                                          }
FUNCTION GetAreaBaseRecordNrByIndexValue_F (Index : IndexValueType) : AreaBaseRecordNrType;

VAR RecNr : AreaBaseRecordNrType;

BEGIN
     IF (AreaIndexTablePtr_F = NIL) THEN
     BEGIN
          Error ('[GetareaBaseRecordNrByIndexValue_F] Index table not loaded into memory!');
          Exit;
     END;

     RecNr:=NILRecordNr;

     ASM
        LES DI,AreaIndexTablePtr_F  { adres van het buffer ophalen }
        MOV CX,AreaIndexTableSize { aantal te doorzoeken }
        SHL CX,1                  { *2 omdat we in words zoeken }

        LEA SI,Index              { 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,AreaIndexTableSize { bereken de offset in de tabel }
        SUB AX,CX
        MOV RecNr,AX              { geef het record nummer terug }

      @NotFound:
     END;

     GetAreaBaseRecordNrByIndexValue_F:=RecNr;
END;


{---------------------------------------------------------------------------}
{ GetAreaBaseRecordNrByIndexValue_U                                         }
{                                                                           }
FUNCTION GetAreaBaseRecordNrByIndexValue_U (Index : IndexValueType) : AreaBaseRecordNrType;

VAR RecNr : AreaBaseRecordNrType;

BEGIN
     IF (AreaIndexTablePtr_U = NIL) THEN
     BEGIN
          Error ('[GetareaBaseRecordNrByIndexValue_U] Index table not loaded into memory!');
          Exit;
     END;

     RecNr:=NILRecordNr;

     ASM
        LES DI,AreaIndexTablePtr_U { adres van het buffer ophalen }
        MOV CX,AreaIndexTableSize  { aantal te doorzoeken }
        SHL CX,1                   { *2 omdat we in words zoeken }

        LEA SI,Index              { 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,AreaIndexTableSize { bereken de offset in de tabel }
        SUB AX,CX
        MOV RecNr,AX              { geef het record nummer terug }

      @NotFound:
     END;

     GetAreaBaseRecordNrByIndexValue_U:=RecNr;
END;


{---------------------------------------------------------------------------}
{ GetAreaBaseRecordNrByAreaName                                             }
{                                                                           }
{ Deze routine bepaald eerst de Index Value van de AreaName en vraagt       }
{ daarna het AreaBase record nummer op met GetAreaBaseRecordNrByIndexValue. }
{                                                                           }
FUNCTION GetAreaBaseRecordNrByAreaName_F (AreaName : AreaNameString) : AreaBaseRecordNrType;
BEGIN
     GetAreaBaseRecordNrByAreaName_F:=GetAreaBaseRecordNrByIndexValue_F (GetAreaNameIndexValue (AreaName));
END;


{---------------------------------------------------------------------------}
{ GetAreaBaseRecordNrByAreaName_U                                           }
{                                                                           }
FUNCTION GetAreaBaseRecordNrByAreaName_U (AreaName : AreaNameString) : AreaBaseRecordNrType;
BEGIN
     GetAreaBaseRecordNrByAreaName_U:=GetAreaBaseRecordNrByIndexValue_U (GetAreaNameIndexValue (AreaName));
END;



{=== User Index Base Routines =============================================}

{--------------------------------------------------------------------------}
{ GetUserBaseRecordNrByAddress                                             }
{                                                                          }
{ Met behulp van deze routine kan snel het record van de opgegeven user    }
{ worden gevonden. Voor iedere user bevat de tabel een entry met daarin    }
{ het adres. Als het adres overeen komt, dan wordt het record nummer (de   }
{ index in de tabel) terug gegeven.                                        }
{                                                                          }
FUNCTION GetUserBaseRecordNrByAddress (Zone,Net,Node,Point : WORD) : UserBaseRecordNrType;

VAR Lp : UserBaseRecordNrType;

BEGIN
     FOR Lp:=1 TO UserIndexTableSize DO
         WITH UserIndexTablePtr^[Lp] DO
         IF (RNet = Net) AND (RZone=Zone) AND (RPoint=RPoint) AND
            (RNode = Node) THEN
         BEGIN
              GetUserBaseRecordNrByAddress:=Lp;
              Exit;
         END;

     GetUserBaseRecordNrByAddress:=NILRecordNr; { niet gevonden }
END;


{--------------------------------------------------------------------------}
{ ReadUserBaseIndexTable                                                   }
{                                                                          }
{ Deze routine leest de UserBase in en stopt voor alle Fido nodes hun      }
{ adres in de index tabel. In principe kan deze tabel NIET groeien tussen- }
{ door, maar door de hele tabel eerst te junken en dan opnieuw aan te      }
{ maken met deze routine kan het wel.                                      }
{                                                                          }
PROCEDURE ReadUserBaseIndexTable;

VAR Lp       : UserBaseRecordNrType;
    UserData : UserBaseRecord;

BEGIN
     IF (UserIndexTablePtr <> NIL) THEN
     BEGIN
          Error ('[ReadUserBaseIndexTable] Tabel is already in memory');
          Exit;
     END;

     UserIndexTableSize:=UserBaseRecCount;
     GetMem (UserIndexTablePtr,UserIndexTableSize*SizeOf (UserBaseIndexRecord));

     FOR Lp:=1 TO UserIndexTableSize DO
     BEGIN
          ReadUserBaseRecord (Lp,UserData);

          IF (NOT UserData.Deleted) AND (UserData.System = _F) THEN
             BEGIN
             WITH UserIndexTablePtr^[Lp] DO
             BEGIN
                  RZone:=UserData.Address.Zone;
                  RNet:=UserData.Address.Net;
                  RNode:=UserData.Address.Node;
                  RPoint:=UserData.Address.Point;
             END;
             END
           ELSE
             UserIndexTablePtr^[Lp].RZone:= 0;

     END;
END;


{--------------------------------------------------------------------------}
{ JunkUserBaseIndexTable                                                   }
{                                                                          }
{ Deze routine gooit de UserBase index tabel weer weg en zet de pointer op }
{ NIL en de teller op 0. Hierdoor weten de zoek routines dat de tabel niet }
{ meer bestaat en kunnen ze gaan klagen.                                   }
{                                                                          }
PROCEDURE JunkUserBaseIndexTable;
BEGIN

     IF (UserIndexTablePtr = NIL) THEN
     BEGIN
{$IFDEF DEBUG}
          Error ('[JunkUserBaseIndexTable] Tabel is not in memory!');
{$ENDIF}
          Exit;
     END;

     FreeMem (UserIndexTablePtr,UserIndexTableSize*SizeOf (UserBaseIndexRecord));
     UserIndexTablePtr:=NIL;
     UserIndexTableSize:=0;
END;


{! DDD                                              }
{! D  D                                             }
{! D  D omains routines worden niet meer gebruikt ! }
{! DDD                                              }

(*
{--------------------------------------------------------------------------}
{ ReadDomainsList                                                          }
{                                                                          }
{ Deze routine bouwt een lijst op van alle CRC-32 waarden van de bij ons   }
{ bekende domain adressen en UUCPName van WorldReg systemen. Hierin kan    }
{ snel gekeken worden of een hostname in de paths file bekend is bij ons.  }
{ De CRC32 wordt genomen over een string die aangevuld is met spaties tot  }
{ MaxLenDomain lengte. Op die manier kunnen een UUCPName en domain nooit   }
{ per ongeluk overeen komen.                                               }
{                                                                          }
{ Vraag: Wat kan ons die WorldReg nou schelen ?  Elk systeem dat wij       }
{        direct kennen mogen we de berichten toch naar doorsturen ?        }
{        Als we 'm niet kennen sturen we het door naar de smarthost        }
{        die beslist of het adres op de wereld bekent is.                  }
{                                                                          }
PROCEDURE ReadDomainsList;

VAR ULp      : UserBaseRecordNrType;
    UserData : UserBaseRecord;
    TmpRec   : ^DomainsListRecord;
    DLp      : 1..MaxDomains;
    TmpDomain: STRING[MaxLenDomain];

BEGIN
  DomainsListCount:=0;

  { Doorloop de userbase record voor record en voeg }
  { voor elke niet lege domains entry een regel     }
  { aan de lijst toe.                               }

  DomainsList.Init( Sizeof( DomainsListRecord ) );

  FOR ULp:=1 TO UserBaseRecCount DO
   BEGIN
   ReadUserBaseRecord (ULp,UserData);

    IF (NOT UserData.Deleted) THEN
    BEGIN

     { Voeg informatie over de UUCP naam van een systeem toe }
     IF (UserData.System = _U) AND (UserData.UUCPName <> '') THEN
      BEGIN
       GetMem( TmpRec , sizeof( DomainsListRecord ));
       GetMem( TmpRec^.DomainPtr , length( UserData.UUCPName ) +1 );
       UserData.UUCPName := DeleteBackSpaces( UserData.UUCPName );
       Move(  UserData.UUCPName[0], TmpRec^.DomainPtr^ , Length( UserData.UUCPName ) + 1);
       TmpRec^.AllowSub := False;
       TmpRec^.UserRecNr:= ULp;
       DomainsList.Add( TmpRec );
      END;

     FOR DLp:=1 TO MaxDomains DO
      BEGIN
       TmpDomain := DeleteBackSpaces( UpcaseString( UserData.Domains[Dlp] ));

       { Vraag geheugen voor een nieuwe domain entry, vul deze }
       { en plaats hem in de lijst.                            }

       IF TmpDomain <> '' THEN
         BEGIN
         GetMem( TmpRec , sizeof( DomainsListRecord ));
         GetMem( TmpRec^.DomainPtr , length( TmpDomain ) +1 );
         Move( TmpDomain[0], TmpRec^.DomainPtr^ , Length( TmpDomain ) + 1);
         TmpRec^.AllowSub := UserData.AllSubDom;
         TmpRec^.UserRecNr:= ULp;
         DomainsList.Add( TmpRec );
         END;
      END; { For }

    END; { If }
   END; {For UserBase}

END; { ReadDomainsList }


{--------------------------------------------------------------------------}
{ JunkDomainsList                                                          }
{                                                                          }
{ Deze routine gooit de lijst met domain namen weer weg.                   }
{                                                                          }
PROCEDURE JunkDomainsList;
VAR TmpRec   : ^DomainsListRecord;
BEGIN

  { Doorloop de lijst van voren naar achteren }
  TmpRec := DomainsList.GetFirstItem;

  WHILE TmpRec <> NIL DO
   BEGIN
    { Geef het geheugen van de string vrij , deze kan niet door }
    { de list routines zelf worden vrijgegeven.                 }
    FreeMem( TmpRec^.DomainPtr , length( TmpRec^.DomainPtr^ ) +1 );
    TmpRec := DomainsList.GetNextItem;
   END;

   { Ruim de restanten van de lijst op }
   DomainsList.Clear;
END;


{--------------------------------------------------------------------------}
{ IsKnownDomain                                                            }
{                                                                          }
{ Deze routine kijkt of de opgegeven naam voorkomt in de lijst met bekende }
{ domain adressen. Als deze niet voorkomt wordt NILRecordNr terug gegeven, }
{ anders het userbase record nummer van de node waarbij het domain adres   }
{ hoort, zodat de Exported vlag gezet kan worden.                          }
{                                                                          }
FUNCTION IsKnownDomain (Name : STRING) : UserBaseRecordNrType;

VAR Temp   : STRING[MaxLenDomain];
    TmpRec : ^DomainsListRecord;
    CRC    : IndexValueType;
    Lp     : WORD;

BEGIN
  Temp   := DeleteBackSpaces(UpCaseString (Name));
  TmpRec := DomainsList.GetFirstItem;

  WHILE TmpRec <> NIL DO
   BEGIN

     { Als de domain naam groter is dan de gezochte heeft verder }
     { vergelijken geen zin.                                     }

     IF Length( TmpRec^.DomainPtr^ ) <= Length(Temp) THEN
      BEGIN

       { Als subdomains toegestaan zijn controleren we alleen of het einde }
       { van de 2 namen overeenstemmen.                                    }

       IF NOT TmpRec^.AllowSub THEN
        BEGIN
        IF TmpRec^.DomainPtr^ = Name THEN
         BEGIN
         IsKnownDomain := TmpRec^.UserRecNr;
         Exit;
         END;
        END
       ELSE
        IF Copy( Temp , Length(Temp) - Length(TmpRec^.DomainPtr^) + 1, 255 ) = TmpRec^.DomainPtr^ THEN
         BEGIN
         IsKnownDomain := TmpRec^.UserRecNr;
         Exit;
         END;
      END; { IF > }

      TmpRec := DomainsList.GetNextItem;
     END;

  IsKnownDomain:=NILRecordNr;
END;
*)

{=== AreaBase Routines ====================================================}

{--------------------------------------------------------------------------}
{ AreaBaseRecCount                                                         }
{                                                                          }
{ Deze routine geeft het aantal records terug dat in de database aanwezig  }
{ is. Merk op dat ook de Deleted records hierbij zitten. Alleen door een   }
{ voor een uitlezen van de records en testen op het Deleted veld kan het   }
{ werkelijke aantal bepaald worden. Dit lijkt me geen tekortkoming.        }
{                                                                          }
FUNCTION AreaBaseRecCount : AreaBaseRecordNrType;
BEGIN
     AreaBaseRecCount:=TdbRecCount (AreaBaseTdbNr);
END;


{--------------------------------------------------------------------------}
{ ReadAreaBaseRecord                                                       }
{                                                                          }
{ Met deze routine kan de inhoud van een van de database records van de    }
{ Area Database uitgelezen worden. Als er een illegaal record nummer wordt }
{ opgegeven, dan wordt het AreaName veld leeg gemaakt zodat de fout        }
{ daaraan herkend kan worden.                                              }
{                                                                          }
FUNCTION ReadAreaBaseRecord (RecNr : AreaBaseRecordNrType; VAR AreaData : AreaBaseRecord) : Boolean;
BEGIN
     ReadAreaBaseRecord := True;

     IF (RecNr <> NILRecordNr) THEN
     BEGIN
          IF NOT TdbRead (AreaBaseTdbNr,RecNr,AreaData) THEN
          BEGIN
               LogFatalError (#7#7#7'Fatal: Area Database Integrity error, run Pack Databases in WtrUtil');
               ReadAreaBaseRecord:=FALSE;
          END;
     END ELSE
     BEGIN
{         Error ('Attempt to read NILRecordNr record!'); }
          ReadAreaBaseRecord:=FALSE;
          AreaData.AreaName_F:=''; { niet in kunnen lezen }
          AreaData.AreaName_U:=''; { niet in kunnen lezen }
          AreaData.UserList:=NILRecordNr; { geen aangesloten users }
     END;
END;


{--------------------------------------------------------------------------}
{ WriteAreaBaseRecord                                                      }
{                                                                          }
{ Met deze routine kan de inhoud van een van de database records van de    }
{ Area Database uitgelezen worden.                                         }
{ De VAR zorgt ervoor dat niet het hele record op de stack gekopieerd      }
{ wordt.                                                                   }
{                                                                          }
PROCEDURE WriteAreaBaseRecord (RecNr : AreaBaseRecordNrType; VAR AreaData : AreaBaseRecord);
BEGIN
     TdbWrite (AreaBaseTdbNr,RecNr,AreaData);
END;


{--------------------------------------------------------------------------}
{ WriteNewAreaBaseRecord                                                   }
{                                                                          }
{ Met deze routine kan een nieuwe AreaBase record aangemaakt worden. Er    }
{ wordt een nieuw record aan het einde van de AreaName database aangemaakt }
{ en een tegelijkertijd een index record aangemaakt. Terug gegeven wordt   }
{ het record nummer van het nieuw aangemaakte record.                      }
{ 02-03-93: De AreaIndexBase bestaat niet meer en de index wordt daarom nu }
{ niet meer geschreven. Wel moet na het aanmaken van een nieuwe record de  }
{ index table - die nu in het geheugen staat - geupdate worden door deze   }
{ eerst te Junken en daarna opnieuw te Readen.                             }
{                                                                          }
FUNCTION WriteNewAreaBaseRecord (VAR AreaData : AreaBaseRecord) : AreaBaseRecordNrType;
BEGIN
     WriteNewAreaBaseRecord:=AreaBaseRecCount+1;
     WriteAreaBaseRecord (AreaBaseRecCount+1,AreaData);
END;


{--------------------------------------------------------------------------}
{ PackAreaBase                                                             }
{                                                                          }
{ Verwijdert gedelete records uit de database, en past de userbase         }
{ aan.                                                                     }
{                                                                          }
FUNCTION PackAreaBase : BOOLEAN;

VAR dBaseNr      : TdbNrType;
    PackAreaRec  : AreaBaseRecord;
    PackUserRec  : UserBaseRecord;
    Subscrdata   : SubscriptBaseRecord;
    SubScrSearch : SubscrSearchRecord;
    SubRec,
    NxtRec       : SubscriptBaseRecordNrType;
    ActualCopied,
    UserCnt,
    SubCnt,
    AreaCnt,
    LoopCnt      : LONGINT;

BEGIN
     PackAreaBase:=FALSE; { assume error }

     { Probeer een nieuwe database file te openen }
     IF (TdbCreate (Config.SystemDir+'TMPAREA.TDB',AreaBaseHeader,dBaseNr) <> _TdbOk) THEN
        Exit;
     TdbSetIO (dBaseNr,SizeOf (AreabaseRecord));

     AreaCnt:=AreaBaseRecCount;
     UserCnt:=UserBaseRecCount;
     SubCnt:=SubscriptBaseRecCount;
     ActualCopied:=0;

     { loop door de gehele areabase record voor record }
     FOR LoopCnt:=1 TO AreaCnt DO
     BEGIN
          ReadAreaBaseRecord (LoopCnt,PackAreaRec);

          WITH PackAreaRec DO
          BEGIN
               { als een record niet meer bestaat, zorg dan dat zijn  }
               { entries in de SubScrBase als gedelete geflagt worden }

               { controleer of een area geen naam heeft (bad) }
               { of in geen groupen meer voorkomt (bad)       }
               IF (NOT Deleted) THEN
                  IF (PackAreaRec.AreaName_F <> '') AND (PackAreaRec.AreaName_U <> '') THEN
                     IF (PackAreaRec.IsInGroups <> 0) THEN
                     BEGIN
                          { schrijf het record naar de tijdelijke area base }
                          Inc (ActualCopied);
                          TdbWrite (dBaseNr,ActualCopied,PackAreaRec);

                          { Zorg dat alle USERBASE records worden voorzien  }
                          { van een verwijzing naar de juiste area          }
                          GetFirstUserSubscribedToThisArea (UserList,SubscrSearch);

                          { Update alleen als er verschillen zijn }
                          IF (ActualCopied <> LoopCnt) THEN
                             WHILE SubScrSearch.Found DO
                             BEGIN
                                  { Lees een user zijn info in, sluit het huidige record nr }
                                  { af, en leg een verwijzing naar de nieuwe lokatie in de  }
                                  { nieuwe areabase.                                        }
                                  IF (SubScrSearch.UserBaseRecordNr > UserCnt) THEN
                                  BEGIN
                                       FixSubScrRecord (SubScrSearch,SubScrSearch.UserBaseRecordNr,FALSE{UserList});
                                  END ELSE
                                  BEGIN
                                       ReadUserBaseRecord (SubScrSearch.UserBaseRecordNr,PackUserRec);
                                       RemoveAreaFromUserSubscrToList (PackUserRec,LoopCnt);
                                       AddAreaToUserSubScrToList (PackUserRec,ActualCopied);
                                  END;

                                  GetNextUserSubScribedToThisArea (SubScrSearch);
                             END;

                     END; { if }
          END; { with }

          { Schrijf de status naar het scherm }
          WriteXY (40,9,LongInt2String ((LoopCnt*100) DIV AreaCnt)+'%');

     END; { for}

     { sluit de areabase, delete deze en rename de nieuwe base }
     TdbCloseAndErase (AreaBaseTdbNr);
     IF (NOT TdbCloseAndRename (dBaseNr,Config.SystemDir+AreaBaseFilename)) THEN
     BEGIN
          LogMessage ('Unable to rename temporary file to areabase !');
          Exit;
     END;

     LogExtraMessage (' (Areabase)         Records Old = '+Word2String (AreaCnt)+' New = '+Word2String (ActualCopied));

     { opnieuw openen, uncached dus! }
     IF (TdbOpen (Config.SystemDir+AreaBaseFilename,AreaBaseTdbNr) = _TdbOk) THEN
     BEGIN
          TdbSetIO (AreaBaseTdbNr,SizeOf (AreabaseRecord)); { RWI 191094 (!!) }
          PackAreaBase:=TRUE;
     END;
END;


{=== Group Description Routines ===========================================}

{--------------------------------------------------------------------------}
{ ReadGroupDescRecord                                                      }
{                                                                          }
{ Met deze routine kan de inhoud van een van de database records van de    }
{ GroupDesc Database uitgelezen worden.                                    }
{                                                                          }
PROCEDURE ReadGroupDescRecord (RecNr : GroupDescBaseRecordNrType; VAR GroupData : GroupDescRecord);
BEGIN
     TdbRead (GroupDescBaseTdbNr,RecNr,GroupData);
END;


{--------------------------------------------------------------------------}
{ WriteGroupDescRecord                                                     }
{                                                                          }
{ Met deze routine kan de omschrijving van een group weer naar de database }
{ geschreven worden voor update.                                           }
{ De VAR zorgt ervoor dat niet het hele record op de stack gekopieerd      }
{ wordt.                                                                   }
{                                                                          }
PROCEDURE WriteGroupDescRecord (RecNr : GroupDescBaseRecordNrType; VAR GroupData : GroupDescRecord);
BEGIN
     TdbWrite (GroupDescBaseTdbNr,RecNr,GroupData);
END;


{=== Description Builder Routines =========================================}

{--------------------------------------------------------------------------}
{ BuildGroupListDesc                                                       }
{                                                                          }
{ Deze routine geeft een string van maximaal 26 tekens terug met daarin de }
{ hoofdletters van het alfabet op de posities waarvan de opgegevens groups }
{ list bitmask een 1 staat. De rest zijn spaties.                          }
{ Voor de snelheid maakt deze routine _niet_ gebruikt van de GR_? CONSTs,  }
{ maar worden de bits gewoon langsgelopen met een lusje.                   }
{                                                                          }
FUNCTION BuildGroupListDesc (Group : GroupFlagType) : STRING;

VAR Desc : STRING[MaxLenGroupDesc];
    Ch   : CHAR;
    Lp   : BYTE;

BEGIN
     Ch:='A';
     Desc:='';

     FOR Lp:=1 TO 26 DO
     BEGIN
          IF TestIfInGroup (Group,Lp) THEN Desc:=Desc+Ch
                                      ELSE Desc:=Desc+' ';
          Inc (Ch);
     END;

     BuildGroupListDesc:=Desc;
END;


{=== Group Routines =======================================================}

{--------------------------------------------------------------------------}
{ AddGroupToGroupList                                                      }
{                                                                          }
{ Deze routine voegt de opgegeven group toe aan de opgegeven groupslist.   }
{ Zie DeleteGroupFromGroupList voor een opmerking over het gebruik.        }
{                                                                          }
PROCEDURE AddGroupToGroupList (VAR Group : GroupFlagType; NewGroupNr : GroupNrType);
BEGIN
     Group:=Group OR Longint (1) SHL (NewGroupNr-1);
END;


{--------------------------------------------------------------------------}
{ DeleteGroupFromGroupList                                                 }
{                                                                          }
{ Deze routine verwijdert de opgegeven group uit de opgegeven groupslist.  }
{ Nu lijkt het sneller om dit direct te doen, maar er komen wat tricky     }
{ zaken om de hoek kijken omdat pascal intern met Integers werkt en dan    }
{ gaat het mis vanaf groep Q... |-(                                        }
{                                                                          }
PROCEDURE DeleteGroupFromGroupList (VAR Group : GroupFlagType; DelGroupNr : GroupNrType);
BEGIN
     Group:=Group AND (GR_ALL - (Longint (1) SHL (DelGroupNr-1)));
END;


{--------------------------------------------------------------------------}
{ TestIfInGroup                                                            }
{                                                                          }
{ Deze routine geeft TRUE terug als de opgegeven group in de opgegeven     }
{ grouplist voorkomt. Anders wordt FALSE terug gegeven.                    }
{ Zie ook de opmerking bij DeleteGroupFromGroupList over het gebruik.      }
{                                                                          }
FUNCTION TestIfInGroup (Group : GroupFlagType; GroupNr : GroupNrType) : BOOLEAN;
BEGIN
     TestIfInGroup:=(Group AND (Longint (1) SHL (GroupNr-1)) > 0);
END;


{=== UserBase Routines ====================================================}

{--------------------------------------------------------------------------}
{ UserBaseRecCount                                                         }
{                                                                          }
{ Deze routine geeft het aantal records in de User Database terug.         }
{                                                                          }
FUNCTION UserBaseRecCount : UserBaseRecordNrType;
BEGIN
     UserBaseRecCount:=TdbRecCount (UserBaseTdbNr);
END;


{--------------------------------------------------------------------------}
{ ReadUserBaseRecord                                                       }
{                                                                          }
{ Deze routine leest een User Database record uit de file.                 }
{                                                                          }
PROCEDURE ReadUserBaseRecord (RecNr : UserBaseRecordNrType; VAR UserData : UserBaseRecord);
BEGIN
     TdbRead (UserBaseTdbNr,RecNr,UserData);
END;


{--------------------------------------------------------------------------}
{ WriteUserBaseRecord                                                      }
{                                                                          }
{ Deze routine schrijft een User Database record naar de file.             }
{                                                                          }
PROCEDURE WriteUserBaseRecord (RecNr : UserBaseRecordNrType; VAR UserData : UserBaseRecord);
BEGIN
     TdbWrite (UserBaseTdbNr,RecNr,UserData);
END;


{--------------------------------------------------------------------------}
{ FindUserBaseRecordByFidoAddress                                          }
{                                                                          }
{ Deze routine zoekt het record van een User aan de hand van zijn adres.   }
{ De hele UserBase wordt sequentieel doorzocht. Later kan dit met een      }
{ index versnelt worden. Als het record niet gevonden is, dan wordt FALSE  }
{ terug gegeven, anders TRUE. De TDB's moeten open zijn (OpenDatabases) en }
{ alleen de Fido systemen worden bekeken.                                  }
{ De domain naam wordt alleen vergeleken als deze bij het Search record    }
{ ook ingevuld is, anders wordt er niet naar gekeken. Als er dan toch twee }
{ Users gedefinieerd staan met een volledig identiek adres en alleen een   }
{ andere Domain naam, dan wordt de eerste gevonden.                        }
{                                                                          }
{ RvdW 16-05-93: Vergelijking op het niet Deleted zijn van een UserBase    }
{                record bij het doorzoeken van de userbase.                }
{                                                                          }
{ MD   06-08-93: Domain vergelijking uitgeschakeld in FindUserBaseRecord   }
{                byFidoAddres, het wordt domweg niet genoeg ondersteund    }
{                                                                          }
FUNCTION FindUserBaseRecordByFidoAddress (Search : FidoAddrType; VAR RecNr : USerBaseRecordNrType) : BOOLEAN;

VAR Lp       : UserBaseRecordNrType;
    UserData : UserBaseRecord;
    Search2  : FidoAddrType;
    Stored   : FIdoAddrType;
    Do2Too   : BOOLEAN;

BEGIN
     FindUserBaseRecordByFidoAddress:=FALSE; { assume not found }
     RecNr:=NILRecordNr;

     Search.Domain:=UpCaseString (DeleteBackSpaces (Search.Domain));
     FidoGetOtherPointAdres (Search,Search2);
     Do2Too:=NOT ((Search2.Zone = 0) AND
                  (Search2.Net = 0) AND
                  (Search2.Node = 0) AND
                  (Search2.Point = 0));

     Stored.Domain:=''; { wel zo netjes, anders staat er troep in RWI950317 }
     FOR Lp:=1 TO UserIndexTableSize DO
         WITH UserIndexTablePtr^[Lp] DO
         BEGIN
              IF (RZone = 0) THEN        { 0 waarden in het zone veld     }
                 Continue;               { betekeken een ongeldig record. }

              Stored.Zone:=RZone;
              Stored.Node:=RNode;
              Stored.Net:=RNet;
              Stored.Point:=RPoint;

              IF FidoCompare (Stored,Search) OR
                 (Do2Too AND FidoCompare (Stored,Search2)) THEN
              BEGIN
                   RecNr:=Lp;
                   FindUserBaseRecordByFidoAddress:=TRUE;
                   Break; { kap de FOR lus }
              END;
         END; { with, for }
END;


{--------------------------------------------------------------------------}
{ FindUserBaseRecordByUUCPName                                             }
{                                                                          }
{ Deze routine doorzoekt de UserBase naar het record waarin de opgegeven   }
{ Usenet node is gedefinieerd. Zijn UUCPName moet de doorslag geven.       }
{ Als het record niet gevonden kan worden, dan wordt FALSE terug gegeven,  }
{ anders TRUE.                                                             }
{                                                                          }
FUNCTION FindUserBaseRecordByUUCPName (Search : UUCPNameString; VAR RecNr : UserBaseRecordNrType) : BOOLEAN;

VAR Lp       : UserBaseRecordNrType;
    UserData : UserBaseRecord;

BEGIN
     FindUserBaseRecordByUUCPName:=FALSE;

     Search:=UpCaseString (Search);

     FOR Lp:=1 TO UserBaseRecCount DO
     BEGIN
          ReadUserBaseRecord (Lp,UserData);

          IF (NOT UserData.Deleted) AND (UserData.System = _U) AND
             (DeleteBackSpaces (UpCaseString (UserData.UUCPName)) = Search) THEN
          BEGIN
               RecNr:=Lp;
               FindUserBaseRecordByUUCPName:=TRUE;
               Break;
          END;
     END; { for }
END;


{--------------------------------------------------------------------------}
{ PackUserBase                                                             }
{                                                                          }
{ Verwijdert gedelete records uit de database, en past de areabase         }
{ aan.                                                                     }
{                                                                          }
FUNCTION PackUserBase : BOOLEAN;

VAR dBaseNr      : TdbNrType;
    PackAreaRec  : AreaBaseRecord;
    PackUserRec  : UserBaseRecord;
    Subscrdata   : SubscriptBaseRecord;
    SubScrSearch : SubscrSearchRecord;
    SubRec,
    NxtRec       : SubscriptBaseRecordNrType;
    ActualCopied,
    AreaCnt,
    SubCnt,
    UserCnt,
    LoopCnt      : LONGINT;

BEGIN
     PackUserBase:=FALSE; { assume error }

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

     AreaCnt:=AreaBaseRecCount;
     UserCnt:=UserBaseRecCount;
     SubCnt:=SubscriptBaseRecCount;
     ActualCopied:=0;

     { loop door de gehele areabase record voor record }
     FOR LoopCnt:=1 TO UserCnt DO
     BEGIN
          ReadUserBaseRecord (LoopCnt,PackUserRec);

          WITH PackUserRec DO
          BEGIN
               { Als een record niet meer bestaat, zorg dan dat zijn  }
               { entries in de SubScrBase als gedelete geflagt worden }

               IF NOT Deleted THEN
               BEGIN
                     { schrijf het record naar de tijdelijke userbase }
                     Inc (ActualCopied);
                     TdbWrite (dBaseNr,ActualCopied,PackUserRec);

                     { Zorg dat alle USERBASE records worden voorzien  }
                     { van een verwijzing naar de juiste area          }

{ RWI 181094: Bugfix. Was GetFirstUserSubscribedToThisArea (AreaList,SubscrSearch) }
{             Serious!                                                             }
                     GetFirstAreaUserIsSubscribedTo (AreaList,SubscrSearch);

                     { alleen wijzigen als het record nummer wijzigt }
                     IF (LoopCnt <> ActualCopied) THEN
                        WHILE SubScrSearch.Found DO
                        BEGIN
                             { lees een area zijn info in, sluit het huidige record nr }
                             { af, en leg een verwijzing naar de nieuwe lokatie in de  }
                             { nieuwe userbase.                                        }
                             IF (SubScrSearch.AreaBaseRecordNr > AreaCnt) THEN
                             BEGIN
                                  FixSubScrRecord (SubScrSearch,SubScrSearch.AreaBaseRecordNr,TRUE{AreaList});
                             END ELSE
                             BEGIN
                                  ReadAreaBaseRecord (SubScrSearch.AreaBaseRecordNr,PackAreaRec);
                                  RemoveUserFromAreaSubscrList (PackAreaRec,LoopCnt);
                                  AddUserToAreaSubScrList (PackAreaRec,ActualCopied);
                             END;

                             GetNextAreaUserIsSubScribedTo (SubScrSearch);
                        END; { while, if }

               END; { if not deleted }
          END; { with }

          WriteXY (40,10,LongInt2String ((LoopCnt*100) DIV UserCnt)+'%');
     END; { for }

     { sluit de userbase, delete deze en rename de nieuwe base }
     TdbCloseAndErase (UserBaseTdbNr);
     IF (NOT TdbCloseAndRename (dBaseNr,Config.SystemDir+UserBaseFilename)) THEN
     BEGIN
          LogMessage ('Error renaming temporary file to userbase!');
          Exit; { with FALSE }
     END;

     LogExtraMessage (' (UserBase)         Records Old = '+Word2String( UserCnt ) + ' New = '+Word2String (ActualCopied));

     { open again. Caching will be lost! }
     IF (TdbOpen (Config.SystemDir+UserBaseFilename,UserBaseTdbNr) = _TdbOk) THEN
     BEGIN
          TdbSetIO (UserBaseTdbNr,SizeOf (UserBaseRecord)); { RWI 191094 (!) }
          PackUserBase:=TRUE;
     END;
END;


{=== Subscription list routines ===========================================}

{$IFNDEF WtrUtil}
CONST ERROR_RUNWTRUTILDATABASE = 'Subscription base error; please run WTRUTIL DATABASE';
{$ENDIF}

{--------------------------------------------------------------------------}
{ EmptySubscriptBaseRecord                                                 }
{                                                                          }
{ Met deze routine kan een Subscript Base Segment (record) leeg gemaakt    }
{ worden.                                                                  }
{                                                                          }
PROCEDURE EmptySubscriptBaseRecord (VAR SubscrData : SubscriptBaseRecord);

VAR Lp : 1..MaxSubscrBaseElements;

BEGIN
     WITH SubscrData DO
     BEGIN
          NextSegmentRecordNr:=NILRecordNr;
          FOR Lp:=1 TO MaxSubscrBaseElements DO
              UserList[Lp]:=NILRecordNr;
     END;
END;


{--------------------------------------------------------------------------}
{ SubscriptBaseRecCount                                                    }
{                                                                          }
{ Deze routine geeft terug hoeveel records er in de Subscript Base aan-    }
{ wezig zijn.                                                              }
{                                                                          }
FUNCTION SubscriptBaseRecCount : SubscriptBaseRecordNrType;
BEGIN
     SubscriptBaseRecCount:=TdbRecCount (SubscriptBaseTdbNr);
END;


{--------------------------------------------------------------------------}
{ ReadSubscriptBaseRecord                                                  }
{                                                                          }
{ Deze routine leest een Subscript Base segment (record) in.               }
{                                                                          }
PROCEDURE ReadSubscriptBaseRecord (RecNr : SubscriptBaseRecordNrType; VAR Data : SubscriptBaseRecord);
BEGIN
     TdbRead (SubscriptBaseTdbNr,RecNr,Data);
END;


{---------------------------------------------------------------------------}
{ WriteSubscriptBaseRecord                                                  }
{                                                                           }
{ Deze routine schrijft een Subscript Base segment (record) weg.            }
{                                                                           }
PROCEDURE WriteSubscriptBaseRecord (RecNr : SubscriptBaseRecordNrType; VAR Data : SubscriptBaseRecord);
BEGIN
     TdbWrite (SubscriptBaseTdbNr,RecNr,Data);
END;


{---------------------------------------------------------------------------}
{ GetFirstAreaUserIsSubscribedTo                                            }
{                                                                           }
{ Deze routine geeft de het record nummer van de eerste area terug waar de  }
{ user op aangesloten is. Dit wordt dus vanuit het user record bekeken.     }
{ Als er geen area aangesloten is, dan wordt Found FALSE, anders TRUE. Met  }
{ GetNext... kan de volgende opgevraagd worden.                             }
{                                                                           }
PROCEDURE GetFirstAreaUserIsSubscribedTo (FirstAreaList : SubscriptBaseRecordNrType; VAR Search : SubscrSearchRecord);

VAR NewRecNr : SubscriptBaseRecordNrType;

BEGIN
     Search.Found:=FALSE;

     IF (FirstAreaList = NILRecordNr) THEN
        Exit;

     ReadSubscriptBaseRecord (FirstAreaList,Search.SubscrData);
     Search.SubscrRecNr:=FirstAreaList;

     WITH Search DO
     BEGIN
          Element:=0;

          REPEAT
                IF (Element = MaxSubscrBaseElements) THEN
                BEGIN
                     IF (SubscrData.NextSegmentRecordNr = NILRecordNr) THEN
                        Exit { end of users; not found dus }
                     ELSE BEGIN
                          NewRecNr:=SubscrData.NextSegmentRecordNr;
                          IF (NewRecNr > SubscriptBaseRecCount) THEN
                          BEGIN
                               {$IFDEF WtrGate}
                               LogMessage (ERROR_RUNWTRUTILDATABASE);
                               {$ENDIF}
                               {$IFDEF WtrConf}
                               Error (ERROR_RUNWTRUTILDATABASE);
                               {$ENDIF}
                               Exit; { not found }
                          END;
                          ReadSubscriptBaseRecord (NewRecNr,SubscrData);
                          SubscrRecNr:=NewRecNr;
                          Element:=1; { RvdW 02-04-93 veranderd van 0 in 1 }
                     END;
                END ELSE
                    Inc (Element);

               {IF (SubscrData.AreaList[Element] <> NILRecordNr) THEN}
                IF (SubscrData.AreaList[Element] <= AreaBaseRecCount) THEN
                BEGIN
                     AreaBaseRecordNr:=SubscrData.AreaList[Element];
                     Found:=TRUE;
                END;
          UNTIL Found;
     END; { with }
END;


{---------------------------------------------------------------------------}
{ GetNextAreaUserIsSubscribedTo                                             }
{                                                                           }
{ Deze routine met na GetFirst.. gebruikt worden om de volgende aangesloten }
{ area op te vragen. Als Found FALSE wordt zijn er niet meer aangesloten    }
{ areas.                                                                    }
{                                                                           }
PROCEDURE GetNextAreaUserIsSubscribedTo (VAR Search : SubscrSearchRecord);

VAR NewRecNr : SubscriptBaseRecordNrType;

BEGIN
     WITH Search DO
     BEGIN
          Found:=FALSE;

          REPEAT
                IF (Element = MaxSubscrBaseElements) THEN
                BEGIN
                     IF (SubscrData.NextSegmentRecordNr = NILRecordNr) THEN
                        Exit { not found }
                     ELSE BEGIN
                          NewRecNr:=SubscrData.NextSegmentRecordNr;
                          IF (NewRecNr > SubscriptBaseRecCount) THEN
                          BEGIN
                               {$IFDEF WtrGate}
                               LogMessage (ERROR_RUNWTRUTILDATABASE);
                               {$ENDIF}
                               {$IFDEF WtrConf}
                               Error (ERROR_RUNWTRUTILDATABASE);
                               {$ENDIF}
                          END;
                          ReadSubscriptBaseRecord (NewRecNr,SubscrData);
                          Search.SubscrRecNr:=NewRecNr;
                          Element:=1;
                     END;
                END ELSE
                    Inc (Element);

               {IF (SubscrData.AreaList[Element] <> NILRecordNr) THEN}
                IF (SubscrData.AreaList[Element] <= AreaBaseRecCount) THEN
                BEGIN
                     AreaBaseRecordNr:=SubscrData.AreaList[Element];
                     Found:=TRUE;
                END;
          UNTIL Found;
     END;
END;


{--------------------------------------------------------------------------}
{ FixSubSubScrRecord                                                       }
{                                                                          }
{ Deze routine wordt aangeroepen als de purge routine een ongeldige waarde }
{ vinden. Het gegeven record zal NIL gemaakt worden.                       }
{ RWI 181094: Bugfix: Werd alleen op AreaList gedaan, niet op de UserList, }
{             terwijl deze routine wel vanuit PackUserBase werd            }
{             aangeroepen om van daaruit problemen op te lossen.           }
{                                                                          }
PROCEDURE FixSubScrRecord (VAR Search : SubscrSearchRecord; InvalidValue : LONGINT; InAreaList : BOOLEAN);

VAR Lp : 1..MaxSubscrBaseElements;

BEGIN
     { zoek het gewraakte record en schrijf een NILRecord op de plaats }
     FOR Lp:=1 TO MaxSubScrBaseElements DO
         CASE InAreaList OF
              TRUE :
                  IF (Search.SubScrData.AreaList[Lp] = InvalidValue) THEN
                     Search.SubScrData.AreaList[Lp]:=NILRecordNr;

              FALSE :
                  IF (Search.SubscrData.UserList[Lp] = InvalidValue) THEN
                     Search.SubScrData.UserList[Lp]:=NILRecordNr;
         END;

     { schrijf het geupdate record terug naar disk }
     WriteSubscriptBaseRecord (Search.SubscrRecNr,Search.SubScrData);
END;


{--------------------------------------------------------------------------}
{ AddAreaToUserSubscrToList                                                }
{                                                                          }
{ Met deze routine kan een area bij een user aangesloten worden. Alleen de }
{ record nummers van beiden moeten worden opgegeven. Deze routine regelt   }
{ het dynamisch linken via de SubscriptDatabase.                           }
{                                                                          }
{ RvdW 31-05-93 Deze routine geeft nu TRUE terug als de area al            }
{               aangesloten was en anders FALSE. Dit is voor de AreaMgr    }
{               routines die dat dan kunnen terug schrijven aan de user.   }
{                                                                          }
FUNCTION AddAreaToUserSubscrToList (VAR UserData : UserBaseRecord; AreaBaseRecordNr : AreaBaseRecordNrType) : BOOLEAN;

VAR AreaData    : AreaBaseRecord;
    SubscrData  : SubscriptBaseRecord;
    SubscrRecNr : SubscriptBaseRecordNrType;
    Element     : 0..MaxSubscrBaseElements;

BEGIN
     AddAreaToUserSubscrToList:=FALSE; { nog niet aangesloten op area }

{ vanuit de user in de segmenten gaan zoeken naar een lege positie en daar }
{ de area toevoegen }

{ nog geen segmenten? }
     IF (UserData.AreaList = NILRecordNr) THEN
     BEGIN
          EmptySubscriptBaseRecord (SubscrData);
          SubscrData.AreaList[1]:=AreaBaseRecordNr;
          UserData.AreaList:=SubscriptBaseRecCount+1;
          WriteSubscriptBaseRecord (UserData.AreaList,SubscrData);
          Exit;
     END;

{ eerste segment inlezen }
     ReadSubscriptBaseRecord (UserData.AreaList,SubscrData);
     SubscrRecNr:=UserData.AreaList;               { voor het wegschrijven }

     Element:=0;
     REPEAT
           IF (Element = MaxSubscrBaseElements) THEN
           BEGIN
                IF (SubscrData.NextSegmentRecordNr = NILRecordNr) THEN
                BEGIN
{ nieuw segment toevoegen }
{ verwijzing naar nieuwe segment aanleggen }
                     SubscrData.NextSegmentRecordNr:=SubscriptBaseRecCount+1;
                     WriteSubscriptBaseRecord (SubscrRecNr,SubscrData);

{ nieuwe segment vullen en wegschrijven als nieuw record }
                     EmptySubscriptBaseRecord (SubscrData);
                     SubscrData.AreaList[1]:=AreaBaseRecordNr;
                     WriteSubscriptBaseRecord (SubscriptBaseRecCount+1,SubscrData);
                     Exit;
                END ELSE
                BEGIN
                     SubscrRecNr:=SubscrData.NextSegmentRecordNr;
                     ReadSubscriptBaseRecord (SubscrRecNr,SubscrData);
                     Element:=1;
                END;
           END ELSE
               Inc (Element);

{ already subscribed? }
           IF (SubscrData.AreaList[Element] = AreaBaseRecordNr) THEN
           BEGIN
                AddAreaToUserSubscrToList:=TRUE; { al aangesloten }
                Exit;
           END;

{ lege plek gevonden? }
           IF (SubscrData.AreaList[Element] = NILRecordNr) THEN
           BEGIN
{ dan het userbase recnr invullen en dit subscr record weer wegschrijven }
                SubscrData.AreaList[Element]:=AreaBaseRecordNr;
                WriteSubscriptBaseRecord (SubscrRecNr,SubscrData);
                Exit;
           END;
     UNTIL 0=1;
END;


{--------------------------------------------------------------------------}
{ RemoveAreaFromUserSubscrToList                                           }
{                                                                          }
{ Met deze routine kan een area bij een user afgekoppeld worden.           }
{ RvdW 31-05-93 Aanpassing gemaakt zodat deze routine nu TRUE terug geeft  }
{               als de area niet was aangesloten.                          }
{                                                                          }
FUNCTION RemoveAreaFromUserSubscrToList (VAR UserData : UserBaseRecord;
                                         SearchAreaBaseRecordNr : AreaBaseRecordNrType) : BOOLEAN;

VAR Search : SubscrSearchRecord;

BEGIN
     RemoveAreaFromUserSubscrToList:=FALSE; { area was wel aangesloten }

     GetFirstAreaUserIsSubscribedTo (UserData.AreaList,Search);

     WHILE (Search.Found) DO
     BEGIN
          IF (Search.AreaBaseRecordNr = SearchAreaBaseRecordNr) THEN
          BEGIN
               Search.SubscrData.AreaList[Search.Element]:=NILRecordNr;
               WriteSubscriptBaseRecord (Search.SubscrRecNr,Search.SubscrData);
               Break; { uit de WHILE }
          END;

          GetNextAreaUserIsSubscribedTo (Search);
     END;

     IF (NOT Search.Found) THEN
        RemoveAreaFromUserSubscrToList:=TRUE; { was niet aangesloten }
END;


{--------------------------------------------------------------------------}
{ GetFirstUserSubscribedToThisArea                                         }
{                                                                          }
{ Deze routine haalt het record nummer van de eerste aangesloten user op   }
{ en geeft deze terug via het Search record. Als er geen user aangesloten  }
{ is wordt Search.Found FALSE, anders TRUE. Met GetNext.. moet de volgende }
{ user bepaald worden.                                                     }
{                                                                          }
PROCEDURE GetFirstUserSubscribedToThisArea (FirstUserList : SubscriptBaseRecordNrType; VAR Search : SubscrSearchRecord);

VAR NewRecNr : SubscriptBaseRecordNrType;

BEGIN
     Search.Found:=FALSE;

{ zijn er uberhaupt wel segmenten met user gegevens aangesloten? }
     IF (FirstUserList = NILRecordNr) THEN
        Exit; { nee, dus geen users }

{ lees het eerste segment }
     ReadSubscriptBaseRecord (FirstUserList,Search.SubscrData);
     Search.SubscrRecNr:=FirstUserList;

     WITH Search DO
     BEGIN
          Element:=0;

          REPEAT
                IF (Element = MaxSubscrBaseElements) THEN
                BEGIN
                     IF (SubscrData.NextSegmentRecordNr = NILRecordNr) THEN
                        Exit { end of users; not found dus }
                     ELSE BEGIN
                          NewRecNr:=SubscrData.NextSegmentRecordNr;
                          IF (NewRecNr > SubscriptBaseRecCount) THEN
                          BEGIN
                               {$IFDEF WtrGate}
                               LogMessage (ERROR_RUNWTRUTILDATABASE);
                               {$ENDIF}
                               {$IFDEF WtrConf}
                               Error (ERROR_RUNWTRUTILDATABASE);
                               {$ENDIF}
                          END;
                          ReadSubscriptBaseRecord (NewRecNr,SubscrData);
                          SubscrRecNr:=NewRecNr;
                          Element:=1;
                     END;
                END ELSE
                    Inc (Element);

               {IF (SubscrData.UserList[Element] <> NILRecordNr) THEN}
                IF (SubscrData.UserList[Element] <= UserBaseRecCount) THEN
                BEGIN
                     UserBaseRecordNr:=SubscrData.UserList[Element];
                     Found:=TRUE;
                END;
          UNTIL Found;
     END; { with }
END;


{--------------------------------------------------------------------------}
{ GetNextUserSubscribedToThisArea                                          }
{                                                                          }
{ Deze routine moet gebruikt worden nA GetFirst... om de volgende user op  }
{ te halen. Als er niet meer users zijn wordt Search.Found FALSE gemaakt.  }
{                                                                          }
PROCEDURE GetNextUserSubscribedToThisArea (VAR Search : SubscrSearchRecord);

VAR NewRecNr : SubscriptBaseRecordNrType;

BEGIN
     WITH Search DO
     BEGIN
          Found:=FALSE;

          REPEAT
                IF (Element = MaxSubscrBaseElements) THEN
                BEGIN
                     IF (SubscrData.NextSegmentRecordNr = NILRecordNr) THEN
                        Exit { not found; not found dus }
                     ELSE BEGIN
                          NewRecNr:=SubscrData.NextSegmentRecordNr;
                          IF (NewRecNr > SubscriptBaseRecCount) THEN
                          BEGIN
                               {$IFDEF WtrGate}
                               LogMessage (ERROR_RUNWTRUTILDATABASE);
                               {$ENDIF}
                               {$IFDEF WtrConf}
                               Error (ERROR_RUNWTRUTILDATABASE);
                               {$ENDIF}
                          END;
                          ReadSubscriptBaseRecord (NewRecNr,SubscrData);
                          SubscrRecNr:=NewRecNr;
                          Element:=1;
                     END;
                END ELSE
                    Inc (Element);

               {IF (SubscrData.UserList[Element] <> NILRecordNr) THEN}
                IF (SubscrData.UserList[Element] <= UserBaseRecCount) THEN
                BEGIN
                     UserBaseRecordNr:=SubscrData.UserList[Element];
                     Found:=TRUE;
                END;
          UNTIL Found;
     END;
END;


{--------------------------------------------------------------------------}
{ AddUserToAreaSubscrList                                                  }
{                                                                          }
{ Met deze routine kan een User bij een area worden aangesloten. Na de     }
{ aanroep van deze routine moet ook altijd AddAreaToUserSubscrList aange-  }
{ roepen worden om de area ook bij de user aan te sluiten.                 }
{ Deze routine voorkomt dubbele links.                                     }
{ De nieuwste versie van deze routine geeft TRUE terug als de user al      }
{ aangesloten was.                                                         }
{                                                                          }
FUNCTION AddUserToAreaSubscrList (VAR AreaData : AreaBaseRecord; UserBaseRecordNr : UserBaseRecordNrType) : BOOLEAN;

VAR UserData    : UserBaseRecord;
    SubscrData  : SubscriptBaseRecord;
    SubscrRecNr : SubscriptBaseRecordNrType;
    Element     : 0..MaxSubscrBaseElements;

BEGIN
     AddUserToAreaSubscrList:=FALSE; { assume new connection }

{ vanuit de area in de segmenten gaan zoeken naar een lege positie en daar }
{ de user toevoegen }

{ nog geen segmenten? }
     IF (AreaData.UserList = NILRecordNr) THEN
     BEGIN
          EmptySubscriptBaseRecord (SubscrData);
          SubscrData.UserList[1]:=UserBaseRecordNr;
          AreaData.UserList:=SubscriptBaseRecCount+1;
          WriteSubscriptBaseRecord (AreaData.UserList,SubscrData);
          Exit;
     END;

{ eerste segment inlezen }
     ReadSubscriptBaseRecord (AreaData.UserList,SubscrData);
     SubscrRecNr:=AreaData.UserList;               { voor het wegschrijven }

     Element:=0;
     REPEAT
           IF (Element = MaxSubscrBaseElements) THEN
           BEGIN
                IF (SubscrData.NextSegmentRecordNr = NILRecordNr) THEN
                BEGIN
{ nieuw segment toevoegen }
{ verwijzing naar nieuwe segment aanleggen }
                     SubscrData.NextSegmentRecordNr:=SubscriptBaseRecCount+1;
                     WriteSubscriptBaseRecord (SubscrRecNr,SubscrData);

{ nieuwe segment vullen en wegschrijven als nieuw record }
                     EmptySubscriptBaseRecord (SubscrData);
                     SubscrData.UserList[1]:=UserBaseRecordNr;
                     WriteSubscriptBaseRecord (SubscriptBaseRecCount+1,SubscrData);
                     Exit;
                END ELSE
                BEGIN
                     SubscrRecNr:=SubscrData.NextSegmentRecordNr;
                     ReadSubscriptBaseRecord (SubscrRecNr,SubscrData);
                     Element:=1;
                END;
           END ELSE
               Inc (Element);

{ already connected? }
           IF (SubscrData.UserList[Element] = UserBaseRecordNr) THEN
           BEGIN
                AddUserToAreaSubscrList:=TRUE; { assume new connection }
                Exit;
           END;

{ lege plek gevonden? }
           IF (SubscrData.UserList[Element] = NILRecordNr) THEN
           BEGIN
{ dan het userbase recnr invullen en dit subscr record weer wegschrijven }
                SubscrData.UserList[Element]:=UserBaseRecordNr;
                WriteSubscriptBaseRecord (SubscrRecNr,SubscrData);
                Exit;
           END;
     UNTIL 0=1;
END;


{--------------------------------------------------------------------------}
{ RemoveUserFromAreaSubscrList                                             }
{                                                                          }
{ Met deze routine kan een user van een area afgekoppeld worden.           }
{                                                                          }
PROCEDURE RemoveUserFromAreaSubscrList (VAR AreaData : AreaBaseRecord; SearchUserBaseRecordNr : UserBaseRecordNrType);

VAR Search : SubscrSearchRecord;

BEGIN
     GetFirstUserSubscribedToThisArea (AreaData.UserList,Search);

     WHILE (Search.Found) DO
     BEGIN
          IF (Search.UserBaseRecordNr = SearchUserBaseRecordNr) THEN
          BEGIN
               Search.SubscrData.UserList[Search.Element]:=NILRecordNr;
               WriteSubscriptBaseRecord (Search.SubscrRecNr,Search.SubscrData);
               Break; { uit de WHILE }
          END;

          GetNextUserSubscribedToThisArea (Search);
     END;
END;


{---------------------------------------------------------------------------}
{ TestIfUserIsInAreaSubscrList                                              }
{                                                                           }
{ Deze routine wordt gebruikt om te controleren of een user aangesloten is  }
{ op een area, waarvan alleen het area record beschikbaar is en niet het    }
{ recnr van dat area record. Via de AreaRec.UserList kan het eerste         }
{ subscriptionbase record nummer doorgegeven worden aan deze routine en kan }
{ in de subscriptionbase gekeken worden of het user record nummer erin      }
{ voorkomt. TRUE als dat zo is, anders FALSE.                               }
{                                                                           }
FUNCTION TestIfUserIsInAreaRec_UserList (UserList : SubscriptBaseRecordNrType; UserRecNr : UserBaseRecordNrType) : BOOLEAN;

VAR Search : SubscrSearchRecord;

BEGIN
     GetFirstUserSubscribedToThisArea (UserList,Search);
     WHILE Search.Found DO
     BEGIN
          IF (Search.UserBaseRecordNr = UserRecNr) THEN
          BEGIN
               TestIfUserIsInAreaRec_UserList:=TRUE;
               Exit;
          END;

          GetNextUserSubscribedToThisArea (Search);
     END;

     TestIfUserIsInAreaRec_UserList:=FALSE;
END;


{---------------------------------------------------------------------------}
{ TestIfAreaIsInUserSubscrList                                              }
{                                                                           }
{ Zie commentaar in routine hierboven.                                      }
{                                                                           }
FUNCTION TestIfAreaIsInUserRec_AreaList (AreaList : SubscriptBaseRecordNrType; AreaRecNr : UserBaseRecordNrType) : BOOLEAN;

VAR Search : SubscrSearchRecord;

BEGIN
     GetFirstAreaUserIsSubscribedTo (AreaList,Search);
     WHILE Search.Found DO
     BEGIN
          IF (Search.AreaBaseRecordNr = AreaRecNr) THEN
          BEGIN
               TestIfAreaIsInUserRec_AreaList:=TRUE;
               Exit;
          END;

          GetNextAreaUserIsSubscribedTo (Search);
     END;

     TestIfAreaIsInUserRec_AreaList:=FALSE;
END;


{--------------------------------------------------------------------------}
{ PackSubScrBase                                                           }
{                                                                          }
{ Verwijderd niet meer gebruikte records uit de subscription base. Aan de  }
{ hand van de userbase kan bekeken worden welke users welke areas willen   }
{ en daarvan kan dan een nieuwe subscription base gemaakt worden.          }
{ Methode:                                                                 }
{ Voor iedere area waar minimaal 1 user op aangesloten is moet een         }
{ subscriptionbase record bijgehouden worden. Door een array bij te houden }
{ met voor ieder areabase record de verwijzing naar het subscriptionbase   }
{ record bij te houden, kan daar snel een user aan toegevoegd worden. Als  }
{ er nog geen subscriptionbase record voor is, dan staat er NIL in het     }
{ array. Als er meer dan 5 users op aangesloten moet worden, dan wordt de  }
{ link vanuit het huidige subscriptionbase record doorverwezen naar het    }
{ nieuwe record en dat nummer in het array gezet.                          }
{ Hetzelfde geldt vanuit de userbase.                                      }
{ De lijst kan natuurlijk aan puin zijn. Daarom wordt er vanuit de         }
{ userbase gewerkt en de areabase wordt daar een afspiegeling van.         }
{ De AreaBase en UserBase moeten al gepacked zijn.                         }
{ RWI 191094.                                                              }
{                                                                          }
FUNCTION PackSubScrBase : BOOLEAN;

CONST MAXLISTENTRIES = 32000; { ook max aantal users/areas }

TYPE ListEntryNrType = 1..MAXLISTENTRIES;
     ListArray       = ARRAY[ListEntryNrType] OF BaseRecordNrType;
     ListArrayPtr    = ^ListArray;

VAR TmpTdbNr : TdbNrType;

    {----------------------------------------------------------------------}
    { MakeRef                                                              }
    {                                                                      }
    { Deze routine legt de referentie vanuit het opgegeven record van de   }
    { areabaselist of userbaselist naar het opgegeven RefNr: het record    }
    { nummer van de userbase of areabase.                                  }
    { Als er nog geen subscriptionbase record aanwezig is (List entry      }
    { bevat NILRecordNr), dan wordt een nieuw record aangemaakt en het     }
    { RefNr erin gezet. Dit gebeurd overigens altijd via de AreaList, wat  }
    { niet uitmaakt omdat de AreaList en UserList over elkaar heen liggen. }
    { Als het huidige subscriptionbase record vol zit, dan wordt een       }
    { nieuwe aangemaakt.                                                   }
    { Uitbreiding RWI 941102: voorkoming van dubbele entries.              }
    {                                                                      }
    PROCEDURE MakeRef (ListPtr : ListArrayPtr; EntryNr : ListEntryNrType; RefNr : BaseRecordNrType);

    { ik weet wel dat dit lokale variabelen zijn en die dezelfde naam mogen }
    { hebben als bij PackSubScrBase, maar het is toch duidelijker als er    }
    { andere namen gebruikt worden.                                         }

    VAR PrevNr,
        Nr    : SubscriptBaseRecordNrType;
        SRec2 : SubscriptBaseRecord;
        ELp2  : 1..MaxSubscrBaseElements;

    BEGIN
         { kijk of er al een subscriptionbase record is }
         IF (ListPtr^[EntryNr] = NILRecordNr) THEN
         BEGIN
              { eerste subscriptionbase record aanmaken }
              WITH SRec2 DO
              BEGIN
                   NextSegmentRecordNr:=NILRecordNr; { geen opvolger }
                   AreaList[1]:=RefNr; { eerste entry invullen }
                   FOR ELp2:=2 TO MaxSubscrBaseElements DO
                       AreaList[ELp2]:=NILRecordNr; { nog niet in gebruik }
              END; { with }

              { schrijf het nieuwe record naar disk en vul het nummer in }
              { in de List.                                              }
              ListPtr^[EntryNr]:=TdbRecCount (TmpTdbNr)+1; { nieuwe record nummer }
              TdbWrite (TmpTdbNr,ListPtr^[EntryNr],SRec2);
              Exit; { klaar }
         END; { nieuw record aangemaakt }

         { begin bij het eerste subscription record nummer }
         Nr:=ListPtr^[EntryNr];
         { eerste keer gaat altijd goed }
         WHILE (Nr <> NILRecordNr) DO
         BEGIN
              { lees het record in uit de nieuwe database }
              TdbRead (TmpTdbNr,Nr,SRec2);

              { kijk of er nog ruimte is in het record. Zoja, voeg het }
              { RefNr dan toe aan de lijst. Als ie stiekum al bestaat, }
              { dan wordt ie niet toegevoegd en keren we terug.        }
              FOR ELp2:=1 TO MaxSubscrBaseElements DO
                  IF (SRec2.AreaList[ELp2] = RefNr) THEN
                     Exit { bestaat al! snel terug }
                  ELSE
                      IF (SRec2.AreaList[ELp2] = NILRecordNr) THEN
                      BEGIN
                           { lege entry gevonden. Zet RefNr hier neer, }
                           { schrijf het record weer naar disk en dan  }
                           { zijn we klaar.                            }
                           SRec2.AreaList[ELp2]:=RefNr;
                           TdbWrite (TmpTdbNr,Nr,SRec2);
                           Exit;
                      END; { if, for }

              PrevNr:=Nr; { voor saven bij aanmaak nieuw record }
              Nr:=SRec2.NextSegmentRecordNr;
         END; { while }

         { er is geen ruimte meer in het record. Maak een nieuw record }
         { aan in de subscription base en link deze aan dit record.    }

         { link het record door en schrijf dit record weer naar disk }
         Nr:=TdbRecCount (TmpTdbNr)+1; { nieuwe record nummer }
         SRec2.NextSegmentRecordNr:=Nr;

         { uitgebreidde vorige nummer weer opslaan }
         TdbWrite (TmpTdbNr,PrevNr,SRec2);

         { record leegmaken }
         WITH SRec2 DO
         BEGIN
              NextSegmentRecordNr:=NILRecordNr; { geen opvolger }
              AreaList[1]:=RefNr; { nieuwe nummer invullen }
              FOR ELp2:=2 TO MaxSubscrBaseElements DO
                  AreaList[ELp2]:=NILRecordNr; { rest is nog niet in gebruik }
         END; { with }

         { schrijf dit nieuwe record naar disk }
         TdbWrite (TmpTdbNr,Nr,SRec2);
    END; { procedure MakeRef }

VAR ULp        : UserBaseRecordNrType;
    URec       : UserBaseRecord;
    ELp        : 1..MaxSubscrBaseElements;
    ListLp,
    AListCount,
    UListCount : 0..MAXLISTENTRIES;
    AListPtr,
    UListPtr   : ListArrayPtr;
    SRecCount,
    SRecNr     : SubscriptBaseRecordNrType;
    SRec       : SubscriptBaseRecord;
    ARecCount,
    ARecNr     : AreaBaseRecordNrType;
    ARec       : AreaBaseRecord;

BEGIN
     PackSubScrBase:=FALSE; { assume error }

     { tijdelijke database file aanmaken }
     IF (TdbCreate (Config.SystemDir+'TMPSUB.TDB',SubScrBaseHeader,TmpTdbNr) <> _TdbOk) THEN
        Exit; { pech, zal toch wel nooit voorkomen }
     TdbSetIO (TmpTdbNr,SizeOf (SubScriptbaseRecord));

     { geheugen aanvragen voor lijsten }
     GetMem (AListPtr,MAXLISTENTRIES*SizeOf (BaseRecordNrType));
     GetMem (UListPtr,MAXLISTENTRIES*SizeOf (BaseRecordNrType));

     { lijsten leegmaken door ze te vullen met NILRecordNr's }
     AListCount:=AreaBaseRecCount;
     FOR ListLp:=1 TO AListCount DO
         AListPtr^[ListLp]:=NILRecordNr;

     UListCount:=UserBaseRecCount;
     FOR ListLp:=1 TO UListCount DO
         UListPtr^[ListLp]:=NILRecordNr;

     { reccount van de subscriptionbase even lokaal opslaan, dat scheelt }
     { verwerkingstijd als we het niet steeds hoeven te berekenen.       }
     SRecCount:=SubscriptBaseRecCount;
     ARecCount:=AreaBaseRecCount;

     { nu alle users aflopen }
     FOR ULp:=1 TO UserBaseRecCount DO
     BEGIN
          WriteXY (40,11,Longint2String ((ULp*100) DIV UserBaseRecCount)+'%');

          { lees het user record in }
          ReadUserBaseRecord (ULp,URec);

          { bepaal het begin van de lijst }
          SRecNr:=URec.AreaList;

          { doorloop de hele chain van subscriptionbase records }
          WHILE (SRecNr <> NILRecordNr) AND { niet einde van subscr-chain bereikt }
                (SRecNr >= 1) AND (SRecNr <= SRecCount) DO { valid record nr }
          BEGIN
               { lees het oude subscriptionbase record in }
               ReadSubscriptBaseRecord (SRecNr,SRec);

               { doorloop de 5 areabase record nummers die in het }
               { subscriptionbase record staan.                   }
               FOR ELp:=1 TO MaxSubscrBaseElements DO
               BEGIN
                    ARecNr:=SRec.AreaList[ELp];

                    IF (ARecNr <> NILRecordNr) AND { niet ongebruikt }
                       (ARecNr >= 1) AND (ARecNr <= ARecCount) THEN { en voorkomend in areabase }
                    BEGIN
                         { het recordnummer in het subscriptionbase record }
                         { is legaal. De user is dus aangesloten op deze   }
                         { area. Zet dit in het nieuwe subscriptionbase    }
                         { record van de user en wijs naar de user vanuit  }
                         { het subscriptionbase record van de area.        }

                         { MakeRef voorkomt NU WEL dubbele entries! }
                         MakeRef (AListPtr,ARecNr,ULp);
                         MakeRef (UListPtr,ULp,ARecNr);
                    END;
               END; { for }

               { verder met het volgende record.    }
               { wordt NILRecordNr bij einde chain. }
               SRecNr:=SRec.NextSegmentRecordNr;
          END; { while }

          { nieuwe subscriptionbase record nummer in user record stoppen   }
          { en record dan alvast updaten door deze naar disk te schrijven. }
          URec.AreaList:=UListPtr^[ULp];
          WriteUserBaseRecord (ULp,URec);
     END; { for }

     { nu de lijst met nieuwe subscriptionbase record nummers voor de }
     { areabase ook in de areabase zetten.                            }
     WriteXY (32,11,'Storing         ');
     FOR ARecNr:=1 TO AreaBaseRecCount DO
     BEGIN
          WriteXY (40,11,Longint2String ((Longint (ARecNr)*100) DIV AreaBaseRecCount)+'%');

          ReadAreaBaseRecord (ARecNr,ARec);
          IF (ARec.UserList <> AListPtr^[ARecNr]) THEN
          BEGIN
               { alleen schrijven als het echt nodig is }
               ARec.UserList:=AListPtr^[ARecNr];
               WriteAreaBaseRecord (ARecNr,ARec);
          END;
     END; { for }

     { oude subscriptionbase weggooien en nieuwe in gebruik nemen. }
     TdbCloseAndErase (SubscriptBaseTdbNr);
     IF (NOT TdbCloseAndRename (TmpTdbNr,Config.SystemDir+SubScriptBaseFilename)) THEN
     BEGIN
          LogMessage ('Error renaming temporary file to SubScription base!');
          Exit;
     END;

     { heropen de subscription base, no caching }
     IF (TdbOpen (Config.SystemDir+SubscriptBaseFilename,SubscriptBaseTdbNr) <> _TdbOk) THEN
     BEGIN
          LogMessage ('Cannot open new subscription base');
          Exit; { error... gelukkig zijn de AreaBase en UserBase al geupdate }
     END ELSE
         TdbSetIO (SubscriptBaseTdbNr,SizeOf (SubscriptBaseRecord));

     { write stats about packing }
     LogExtraMessage (' (Subscriptionbase) Records Old = '+Word2String (SRecCount)+
                                                 ' New = '+Word2String (SubscriptBaseRecCount));

     { geheugen van lijsten weer vrijgeven }
     FreeMem (AListPtr,MAXLISTENTRIES*SizeOf (BaseRecordNrType));
     FreeMem (UListPtr,MAXLISTENTRIES*SizeOf (BaseRecordNrType));

     PackSubScrBase:=TRUE; { geen fouten gevonden }
END;


{===========================================================================}
{ ListServer database routines                                              }
{                                                                           }

{--------------------------------------------------------------------------}
{ ListBaseRecCount                                                         }
{                                                                          }
{ Deze routine geeft het aantal records in de List Server Database terug.  }
{                                                                          }
FUNCTION ListBaseRecCount : ListServerRecordNrType;
BEGIN
     ListBaseRecCount:=TdbRecCount (ListServerTdbNr);
END;


{--------------------------------------------------------------------------}
{ WriteListBaseRecord                                                      }
{                                                                          }
{ Met deze routine kan de inhoud van een van de database records van de    }
{ List Server Database uitgelezen worden.                                  }
{ De VAR zorgt ervoor dat niet het hele record op de stack gekopieerd      }
{ wordt.                                                                   }
{                                                                          }
PROCEDURE WriteListBaseRecord (RecNr : ListServerRecordNrType; VAR ListData : ListServerRecord);
BEGIN
     TdbWrite (ListServerTdbNr,RecNr,ListData);
END;


{--------------------------------------------------------------------------}
{ WriteNewListBaseRecord                                                   }
{                                                                          }
FUNCTION WriteNewListBaseRecord (VAR ListData : ListServerRecord) : ListServerRecordNrType;
BEGIN
     WriteNewListBaseRecord:=ListBaseRecCount+1;
     WriteListBaseRecord (ListBaseRecCount+1,ListData);
END;


{--------------------------------------------------------------------------}
{ ReadListBaseRecord                                                       }
{                                                                          }
{ Met deze routine kan de inhoud van een van de database records van de    }
{ List Database uitgelezen worden. Als er een illegaal record nummer wordt }
{ opgegeven, dan wordt het AreaName veld leeg gemaakt zodat de fout        }
{ daaraan herkend kan worden.                                              }
{                                                                          }
FUNCTION ReadListBaseRecord (RecNr : ListServerRecordNrType; VAR ListData : ListServerRecord) : Boolean;
BEGIN
     ReadListBaseRecord:=TRUE;

     IF (RecNr <> NILRecordNr) THEN
     BEGIN
          IF (NOT TdbRead (ListServerTdbNr,RecNr,ListData)) THEN
          BEGIN
               LogFatalError (#7#7#7'Fatal: List Server Database Integrity error!');
               ReadListBaseRecord:=FALSE;
          END;
     END ELSE
     BEGIN
          Error ('Attempt to read NILRecordNr record!');
          ReadListBaseRecord:=FALSE;
          ListData.NextUser:=NILRecordNr; { geen aangesloten users }
     END;
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 }
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 ;-) }
          WriteXY (40,12,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 ('Unable to rename temporary file to List Server database!');
          Exit;
     END;

     LogExtraMessage (' (ListServerBase)   Records Old = '+Word2String (OldRecCounter)+
                                                 ' New = '+Word2String (NewRecCounter));
     IF (TdbOpen (Config.SystemDir+ListServerFilename,ListServerTdbNr) = _TdbOk) THEN
     BEGIN
          TdbSetIO (ListServerTdbNr,SizeOf (ListServerRecord));
          PackListServerDatabase:=TRUE; { geen problemen }
     END;
END;


{--------------------------------------------------------------------------}
{ AddUserToList                                                            }
{                                                                          }
{ Linkt een user in op de plek tussen het hoofdrecord en het oude eerste   }
{ record.                                                                  }
{                                                                          }
PROCEDURE AddUserToList (SourceList : ListServerRecordNrType; VAR Source : ListServerRecord; VAR User : ListServerRecord);

VAR RecNo : ListServerRecordNrType;

BEGIN
     User.NextUser:=Source.NextUser;
     RecNo:=WriteNewListBaseRecord (User);
     Source.NextUser:=RecNo;
     WriteListBaseRecord (SourceList,Source);
END;


{--------------------------------------------------------------------------}
{ unit initialization                                                      }
{                                                                          }
BEGIN
     AreaIndexTablePtr_F:=NIL;
     AreaIndexTablePtr_U:=NIL;
     UserIndexTablePtr:=NIL;

     AreaBaseTdbNr:=TdbClosedNr;
     SubscriptBaseTdbNr:=TdbClosedNr;
     UserBaseTdbNr:=TdbClosedNr;
     GroupDescBaseTdbNr:=TdbClosedNr;
     ListServerTdbNr:=TdbClosedNr;
END.

