{$IFDEF WtrGate}{$IFDEF UseOvr}{$O+,F+}{$ENDIF}{$ENDIF}
UNIT Database;

{$I platform.inc}

{ 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.
     27-12-96 Nu 128 groups, added new group flag handling.
}


{ 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       = 60;
      NILRecordNr : WORD    = 65535;            { record nummer NIL waarde }
      MaxSubscrBaseElements = 5;
      MaxSystemDomains      = 6;
      MaxUserDomains        = 3;
      MaxLenAreaFixPwd      = 20;
      MaxLenPath            = 79;

CONST AreaBaseHeader     = 'WtrGate AreaBase 09';  { 08->09: CharSet fields }
      UserBaseHeader     = 'WtrGate UserBase 14';  { 13->14: INETMAIL fields }
      SubscrBaseHeader   = 'WtrGate SubscrBase 01';
      GrpDescrBaseHeader = 'WtrGate GroupDescr 03';
     {ListServerHeader   = 'WtrGate ListServer 06';}
      ListUserHeader     = 'WtrGate ListUser 02';

CONST AreaBaseFilename      = 'AREABASE.TDB';     { directory }
      SubscriptBaseFilename = 'SUBSCRIP.TDB';
      UserBaseFilename      = 'USERBASE.TDB';
      GroupDescBaseFilename = 'GRPDESCR.TDB';
     {ListServerFileName    = 'LISTSERV.TDB';}
      ListUserFilename      = 'LISTUSER.TDB';

CONST MaxAKAs = 100;

TYPE AkaIndexType = 1..MaxAKAs;

TYPE IndexValueType = LONGINT;  { voor Area/User indexes }

CONST MaxGroups      = 128;  { A1-5,B1-5,..,Y1-5,Z1-3 }
      GroupFlagLen   = MaxGroups DIV 8;
      Group_NewAreas = MaxGroups-2; { Z1, previously group Z }


TYPE GroupFlagType  = ARRAY[1..GroupFlagLen] OF BYTE; { bit mask }
     AreaFlagType   = LONGINT; { bit mask }
     AreaNameString = STRING[MaxLenAreaName];
     mdType         = (mdNONE,mdUSE) {,mdFIDO)};

     AreaRecordType = (Area_Echo,
                       Area_Netmail,
                       Area_Local,
                       Area_EMail);

     SystemType     = (_F,    { 0: FTN  }
                       _U,    { 1: UUCP }
                       _B,    { 2: BAG  }
                       _S,    { 3: SMTP }
                       _P,    { 4: POP3 }
                       _BBS,  { 5: BBS interface }
                       _SOUP, { 6: SOUP }
                       _INETMAIL); { 7: Inet.Mail }

     SendType        = (stNormal,stHold,stCrash,stDirect,stMailTunnel,stSeat);
     CompressionType = (fctARC,fctARJ,fctLZH,fctPAK,fctZIP,fctZOO,fctRAR,fctOP1,fctGUS,fctNone);
     UseCompressType = (uctNone,uctCompress,uctGZip);
     PktFormatType   = (fptPkt,fptPkt2000);

     FidoMsgStyleType = (NoneType,
                         FidoMsgType,
                         SquishType,
                         JamType);

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

CONST MaxLenFidoAddrDomain = 25;
      MaxLenFidoAddrString = 23+MaxLenFidoAddrDomain;

TYPE FidoAddrType = RECORD
                          Zone   : WORD;
                          Net    : WORD;
                          Node   : WORD;
                          Point  : WORD;
                          Domain : STRING[MaxLenFidoAddrDomain];
                    END;

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

     GroupNrType     = 1..MaxGroups;

     UUCPNameString  = STRING[MaxLenUUCPName];
     FilePathStr     = STRING[MaxLenPath];

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

TYPE AkaBitList = ARRAY[0..12] OF BYTE; { 0..12 = 13*8 = 104 > MaxAkas }

TYPE 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 }
                            AddSeenByAKAs : AkaBitList; { ieder bit is 1 AKA, 0.b0 = 1st }

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

                            { voor U->F vertaling }
                            OriginNr      : BYTE; { 1/2 for default 0=custom }
                            Origin        : STRING[MaxLenOrigin];

                            { message bases }
                            FidoMsgStyle  : FidoMsgStyleType;
                            FidoMsgPath   : FilePathStr;
                            FidoMsgAge    : INTEGER; { in dagen     }
                            FidoMsgLimit  : INTEGER; { in berichten }

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

                            { UU/XX-decode? }
                            Decode        : BOOLEAN;
                            DecodePath    : FilePathStr;

                            { Hidden voor areafix/newsfix }
                            { RAWI 970823: Hidden is now Mandatory }
                            Mandatory     : BOOLEAN;

                            { 0.94.PRE3 }
                            RulesFile     : FilePathStr;

                            DupeList      : LONGINT; { position in file }
                            DupeAge       : BYTE;    { in weeks }

                            CharSet_RFC   : STRING[30];
                            Charset_FTN   : STRING[30];
                      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;

                            AllowSubDomains : BOOLEAN;

                            AreaList     : SubscriptBaseRecordNrType;
                            UUCPName     : STRING[MaxLenUUCPName];
                            Domains      : ARRAY[1..MaxUserDomains] OF STRING[MaxLenDomain];

                            CASE INTEGER OF
                         { FTN } 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 }
                                      ExportAKA       : BYTE; { 0,1..MaxAkas }
                                      DecodeFiles     : BOOLEAN;
                                      MaxArcLength    : LONGINT;
                                      TunnelTo        : STRING[MaxLenDomain];
                                      Notify_F        : BOOLEAN;
                                      PktFormat       : PktFormatType;
                                      NodeOutDir      : FilePathStr;
                                     );

                        { UUCP } 1 : (Compress        : UseCompressType;
                                      CunBatch        : BOOLEAN;
                                      MailGrade       : CHAR;
                                      NewsGrade       : CHAR;
                                      GigoT           : BOOLEAN;
                                      Notify_U        : BOOLEAN;
                                     );

                         { BAG } 2 : (BAGbacklink     : STRING[MaxLenUUCPName];
                                      BagPath         : FilePathStr;
                                     );

                        { SMTP } 3 : (SmtpInPath      : FilePathStr;
                                      SmtpOutPath     : FilePathStr;
                                     );

                        { POP3 } 4 : (Pop3File        : FilePathStr;
                                      Pop3Recipient   : STRING[MaxLenDomain{50}];
                                      Pop3Separator   : STRING[15];
                                      Pop3EnvelopeHdr : STRING[25];
                                     );

                         { BBS } 5 : (Inbound         : FilePathStr;
                                      Outbound        : FilePathStr;
                                      SystemAKA       : BYTE; { 1..MaxAkas }
                                      FakeZone        : WORD;
                                      FakeNet         : WORD;
                                      FakeNode        : WORD;
                                      InboundExt      : STRING[3];
                                      KeepSBP         : BOOLEAN;
                                      Reserved1       : BYTE;
                                     );

                        { SOUP } 6 : (SoupInPath      : FilePathStr;
                                      SoupOutPath     : FilePathStr;
                                      SoupEnvelopeHdr : STRING[25];
                                      SoupRecipient   : STRING[MaxLenDomain];
                                      UsingWGSOUP     : BOOLEAN;
                                     );

                        { INET } 7 : (InetMailQueue   : FilePathStr;
                                      InetMailSourceDomain: STRING [MaxLenDomain];
                                     );
                      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;

     ListUserType = (lutDeleted,lutFTN,lutRFC,lutRemoteGW);
     ListAccessType  = (laReadWrite,laReadOnly,laWriteOnly);
     ListConfirmType = (lcNever,lcOk,lcReq1,lcReq2,lcReq3);

     { subscriber to a mailing list defined in a flex record }
     ListUserRecord = RECORD
                            UserType       : ListUserType;

                            ListID         : WORD;

                            Aka            : FidoAddrType;
                            User           : STRING[MaxLenUserName];
                            Email          : STRING[MaxLenDomain];

                            { common fields }
                            Access         : ListAccessType;
                            SubscribedDate : LONGINT;
                            ConfirmedDate  : LONGINT;
                            ConfirmReqDate : LONGINT;
                            ConfirmState   : ListConfirmType;
                            ConfirmCode    : LONGINT; { hex nr }

                            ReceiveOwnMail : BOOLEAN;
                      END;

(*
    ListServerRecord = RECORD
                             Deleted     : BOOLEAN;
{                             ListSystem  : ListSystemType;}
                             NextUser    : ListServerRecordNrType;

                             { common fields for all user types }
                             { RWI960721 }
                             Access          : ListAccessType;
                             { RWI961208 }
                             SubscribedDate  : LONGINT;
                             ConfirmedDate   : LONGINT;
                             ConfirmReqDate  : LONGINT;
                             ConfirmState    : ListConfirmType;
                             ConfirmCode     : LONGINT; { hex nr }

                             CASE INTEGER OF
                                  {ServerInfo}
                                  0 : (ListName        : STRING;
                                       ListDescription : STRING[40];
                                       ListWelcome     : STRING[79];
                                       ListAKA         : BYTE;
                                       ListPrivate     : BOOLEAN;
                                       OnlyKnown       : BOOLEAN;
                                       Active          : BOOLEAN;
                                       AreaName        : STRING[MaxLenAreaName];
                                       EchoList        : BOOLEAN;
                                       ListEcho        : BOOLEAN;
                                       DefaultAccess   : ListAccessType;
                                       MLAddress       : BYTE;
                                       ConfirmInterval : BYTE; { days }
                                       HomeDomain      : BYTE; { 1..MaxSystemDomains }
                                       AdminPassword   : STRING[8];
                                       );

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

                                  { usenet }
                                  2 : (Email     : STRING[MaxLenDomain];
                                      );

                                  { remote gateway }
                                  3 : (GWAddress : FidoAddrType;
                                       GWUser    : STRING[MaxLenSysopName];
                                       GWEmail   : STRING[MaxLenDomain];
                                      );
                       END;
*)

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

{ 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;
FUNCTION  GetAreaBaseRecordNrByAreaName (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;
PROCEDURE ReadAreaBaseRecord (RecNr : AreaBaseRecordNrType; VAR AreaData : AreaBaseRecord);
PROCEDURE WriteAreaBaseRecord (RecNr : AreaBaseRecordNrType; VAR AreaData : AreaBaseRecord);
FUNCTION  WriteNewAreaBaseRecord (VAR AreaData : AreaBaseRecord) : AreaBaseRecordNrType;
PROCEDURE SetSeenByBit (VAR Akas : AkaBitList; AKA : BYTE);
PROCEDURE ResetSeenByBit (VAR Akas : AkaBitList; AKA : BYTE);
FUNCTION  HasSeenByBit (VAR Akas : AkaBitList; AKA : BYTE) : BOOLEAN;
PROCEDURE SetSingleSeenByBit (VAR Akas : AkaBitList; AKA : BYTE);
FUNCTION  IsOnlySeenByBit (VAR Akas : AkaBitList; Aka : BYTE) : BOOLEAN;
FUNCTION  GetAreaSubscriberTypes (AreaRecNr : AreaBaseRecordNrType) : BYTE;

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

{ description builders }
FUNCTION  BuildSingleGroupDesc (Group : GroupNrType) : STRING;
FUNCTION  BuildGroupListDesc (Group : GroupFlagType; MaxLen : BYTE) : STRING;

{ group acties }
PROCEDURE ResetGroupFlags (VAR Group : GroupFlagType);
PROCEDURE AddGroupToGroupList (VAR Group : GroupFlagType; NewGroupNr : GroupNrType);
PROCEDURE DeleteGroupFromGroupList (VAR Group : GroupFlagType; DelGroupNr : GroupNrType);
FUNCTION  TestIfInGroup (Group : GroupFlagType; GroupNr : GroupNrType) : BOOLEAN;
FUNCTION  TestGroupListIsEmpty (VAR Group : GroupFlagType) : BOOLEAN;
FUNCTION  TestGroupListSame (VAR GroupList1,GroupList2 : GroupFlagType) : BOOLEAN;
FUNCTION  TestIfGroupCommon (VAR GroupAny,GroupList : GroupFlagType) : BOOLEAN;
FUNCTION  TestIfGroupCommon3 (VAR GroupList1,GroupList2,GroupList3 : GroupFlagType) : BOOLEAN;
PROCEDURE CreateCommonGroup (VAR GroupCommon,GroupList1,GroupList2 : GroupFlagType);
PROCEDURE MergeGroups (VAR Group,NewGroup : GroupFlagType);

{ 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;

{ 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  CountSubscribedAreas (FirstAreaList : SubscriptBaseRecordNrType) : WORD;
FUNCTION  CountAllowedEchoAreas (GroupsList : GroupFlagType) : WORD;
FUNCTION  CountSubscribedUsers (FirstUserList : SubscriptBaseRecordNrType) : WORD;

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);
*)

{ Mailing list users (subscribers) }
PROCEDURE ListUser_Read (RecNr : ListUserRecordNrType; VAR ListUser : ListUserRecord);
PROCEDURE ListUser_Write (RecNr : ListUserRecordNrType; VAR ListUser : ListUserRecord);
FUNCTION  ListUser_WriteNew (VAR ListUser : ListUserRecord) : ListUserRecordNrType;
FUNCTION  ListUser_RecCount : ListUserRecordNrType;


IMPLEMENTATION

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

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 MaxGroups records  }
{ zijn. Zoniet, dan worden de records aangevuld tot MaxGroups met de       }
{ descriptions dat die nog niet gebruikt 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 ';
      {$IFDEF PLATFORM_DOS_NOT_DPMI}
      MsgLowXMS    = 'Not enough XMS memory to cache ';
      {$ELSE}
      MsgLowXMS    = 'Not enough memory to cache ';
      {$ENDIF}

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;

     { probeer de AREABASE.TDB file te locken. Als dat niet lukt, dan }
     { is ie al door een andere instantie gelockt en dan stoppen we   }
     { het programma gewoon met een speciale melding.                 }
     { CloseDatabases unlockt em weer.                                }
     IF (NOT TdbLockFile (AreaBaseTdbNr)) THEN
     BEGIN
          WriteLn (#13'# Cannot lock AREABASE.TDB');
          TdbClose (AreaBaseTdbNr);
          Exit;
     END;

     TdbSetIO (AreaBaseTdbNr,SizeOf (AreaBaseRecord));

     IF TdbSeemsLocked (AreaBaseTdbNr) THEN
     BEGIN
          WriteLn ('# Another process has locked the WaterGate Databases');
          Exit;
     END;

     IF (TdbReadHeader (AreaBaseTdbNr) <> AreaBaseHeader) THEN
     BEGIN
          WriteLn (MsgIncompTdb,Config.SystemDir,AreaBaseFilename);
          Exit;
     END;

{$IFNDEF WtrUtil}
     IF (TdbRecCount (AreaBaseTdbNr) = NILRecordNr) THEN
     BEGIN
          WriteLn ('# Exploded area base detected. Please run WTRUTIL DATABASE at once!'#7#7);
          Exit;
     END;
{$ENDIF}

     {$IFDEF WtrGate}
     IF Config.CacheTdbs AND TdbCache (AreaBaseTdbNr) THEN
        LogMessage (liGeneral,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,Config.SystemDir,SubscriptBaseFilename);
          Exit;
     END;

     {$IFDEF WtrGate}
     IF Config.CacheTdbs AND TdbCache (SubscriptBaseTdbNr) THEN
        LogMessage (liGeneral,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,Config.SystemDir,UserBaseFilename);
          Exit;
     END;

     {$IFDEF WtrGate}
     IF Config.CacheTdbs AND TdbCache (UserBaseTdbNr) THEN
        LogMessage (liGeneral,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,Config.SystemDir,GroupDescBaseFilename);
          Exit;
     END;

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

     TdbSetIO (ListUserTdbNr,SizeOf (ListUserRecord));
     IF (TdbReadHeader (ListUserTdbNr) <> ListUserHeader) THEN
     BEGIN
          WriteLn (MsgIncompTdb,Config.SystemDir,ListUserFilename);
          Exit;
     END;

     {$IFDEF WtrGate}
     IF Config.CacheTdbs AND TdbCache (ListUserTdbNr) THEN
        LogMessage (liGeneral,MsgLowXMS+ListUserFilename);
     {$ENDIF}

     {$IFDEF WtrConf}
     IF (TdbRecCount (GroupDescBaseTdbNr) < MaxGroups) THEN
     BEGIN
          { overwrite old group Z to avoid confusion }
          IF (TdbRecCount (GroupDescBaseTdbNr) = 26) THEN
          BEGIN
               TdbRead (GroupDescBaseTdbNr,26,GroupData);
               GroupData.GroupDesc:=AddUpWithSpaces (MaxLenGroupDesc,'<old auto created areas>');
               TdbWrite (GroupDescBaseTdbNr,26,GroupData);
          END;

          GroupData.GroupDesc:=AddUpWithSpaces (MaxLenGroupDesc,'<no description>');
          GroupData.OriginAka:=1;
          GroupData.ReadOnly:=FALSE;

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

          { speciaal record for newly created areas }
          GroupData.GroupDesc:=AddUpWithSpaces (MaxLenGroupDesc,'Auto created areas');
          TdbWrite (GroupDescBaseTdbNr,Group_NewAreas,GroupData);
     END;
     {$ENDIF}

     { zet de AllGroups variabele op }
     FOR Lp:=1 TO GroupFlagLen DO
         AllGroups[Lp]:=255;

     { 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:=AllGroups;
     FOR Lp:=1 TO MaxGroups DO
     BEGIN
          TdbRead (GroupDescBaseTdbNr,Lp,GroupData);
          IF GroupData.ReadOnly THEN
             DeleteGroupFromGroupList (ReadWriteGroupsFilter,Lp);
     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 (SubscriptBaseTdbNr <> TdbClosedNr) THEN
        TdbClose (SubscriptBaseTdbNr);

     IF (UserBaseTdbNr <> TdbClosedNr) THEN
        TdbClose (UserBaseTdbNr);

     IF (GroupDescBaseTdbNr <> TdbClosedNr) THEN
        TdbClose (GroupDescBaseTdbNr);

     IF (ListUserTdbNr <> TdbClosedNr) THEN
        TdbClose (ListUserTdbNr);

     { unlock de areabase weer zodat andere programma's deze kunnen openen }
     TdbUnlockFile (AreaBaseTdbNr);

     IF (AreaBaseTdbNr <> TdbClosedNr) THEN
        TdbClose (AreaBaseTdbNr);
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,UpCaseString (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;
    TabSize  : WORD;

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 }

     TabSize:=(AreaIndexTableSize+AreaIndexTableFree)*SizeOf (IndexValueType);
     GetMem (AreaIndexTablePtr_F,TabSize);
     GetMem (AreaIndexTablePtr_U,TabSize);
     PeekMem;

     IF DebugMem THEN
        LogExtraMessage (MEMUSEFOR+'Area names index = '+Longint2String (TabSize*2));

     FOR Lp:=1 TO AreaIndexTableSize DO
     BEGIN
          ReadAreaBaseRecord (Lp,AreaData);
          IF (AreaData.Deleted) OR TestGroupListIsEmpty (AreaData.IsInGroups) 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_F                                        }
{                                                                          }
{ 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;
    {$IFDEF PLATFORM_OS2_OR_WIN32}
    Lp    : AreaBaseRecordNrType;
    {$ENDIF}

BEGIN
     IF (AreaIndexTablePtr_F = NIL) THEN
     BEGIN
          GetAreaBaseRecordNrByIndexValue_F:=NILRecordNr; { RWI 970210: added }
          Error ('[GetareaBaseRecordNrByIndexValue_F] Index table not loaded into memory!');
          Exit;
     END;

     RecNr:=NILRecordNr;

     {$IFDEF PLATFORM_OS2_OR_WIN32}
     {## speed up}
     FOR Lp:=1 TO AreaIndexTableSize DO
         IF (AreaIndexTablePtr_F^[Lp] = Index) THEN
         BEGIN
              RecNr:=Lp;
              Break;
         END;
     {$ELSE}
     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;
     {$ENDIF}

     GetAreaBaseRecordNrByIndexValue_F:=RecNr;
END;


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

VAR RecNr : AreaBaseRecordNrType;
    {$IFDEF PLATFORM_OS2_OR_WIN32}
    Lp    : AreaBaseRecordNrType;
    {$ENDIF}

BEGIN
     IF (AreaIndexTablePtr_U = NIL) THEN
     BEGIN
          GetAreaBaseRecordNrByIndexValue_U:=NILRecordNr; { RWI 970210: added }
          Error ('[GetareaBaseRecordNrByIndexValue_U] Index table not loaded into memory!');
          Exit;
     END;

     RecNr:=NILRecordNr;

     {$IFDEF PLATFORM_OS2_OR_WIN32}
     {## speed up}
     FOR Lp:=1 TO AreaIndexTableSize DO
         IF (AreaIndexTablePtr_U^[Lp] = Index) THEN
         BEGIN
              RecNr:=Lp;
              Break;
         END;
     {$ELSE}
     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;
     {$ENDIF}

     GetAreaBaseRecordNrByIndexValue_U:=RecNr;
END;


{---------------------------------------------------------------------------}
{ GetAreaBaseRecordNrByAreaName_F                                           }
{                                                                           }
{ 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;


{--------------------------------------------------------------------------}
{ GetAreaBaseRecordNrByAreaName                                            }
{                                                                          }
{ Checks both _U and _F, but calculates index value only once.             }
{                                                                          }
FUNCTION GetAreaBaseRecordNrByAreaName (AreaName : AreaNameString) : AreaBaseRecordNrType;

VAR Index : LONGINT;
    RecNr : AreaBaseRecordNrType;

BEGIN
     Index:=GetAreaNameIndexValue (AreaName);

     RecNr:=GetAreaBaseRecordNrByIndexValue_F (Index);

     IF (RecNr = NILRecordNr) THEN
        RecNr:=GetAreaBaseRecordNrByIndexValue_U (Index);

     GetAreaBaseRecordNrByAreaName:=RecNr;
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] Table is already in memory');
          Exit;
     END;

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

     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.                                              }
{                                                                          }
PROCEDURE ReadAreaBaseRecord (RecNr : AreaBaseRecordNrType; VAR AreaData : AreaBaseRecord);
BEGIN
     IF (RecNr <> NILRecordNr) THEN
     BEGIN
          IF NOT TdbRead (AreaBaseTdbNr,RecNr,AreaData) THEN
          BEGIN
               LogMessage (liFatal,'Error reading Area Base record ('+Word2String (RecNr)+')');
               LogExtraMessage ('*** Please run WTRUTIL DATABASE');
          END;
     END ELSE
     BEGIN
          {$IFDEF Pre}
          IF (RecNr = NILRecordNr) THEN
             LogMessage (liFatal,'Program inconsistency error "DRA"');
          {$ENDIF}
          AreaData.Deleted:=TRUE; { that's a good one, isn't it? }
          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
     IF (RecNr = NILRecordNr) THEN
     BEGIN
          {$IFDEF WtrConf}
          Error ('Program inconsistency error "DWA" ** PLEASE REPORT **');
          {$ELSE}
          LogMessage (liReport,'Program inconsistency error "DWA"');
          {$ENDIF}

          Exit; { forget it! }
     END;

     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;


{--------------------------------------------------------------------------}
{ GetAreaSubscriberTypes                                                   }
{                                                                          }
{ This routine quickly checks the subscribers of the given area and        }
{ returns bit0=1 for FTN subscribers and bit1=1 for RFC requirement.       }
{ bit2=1 means it is an Netmail area without subscribers, just a message   }
{ base. 0 means there is no message base and no subscribers of any kind.   }
{                                                                          }
{ Return values:                                                           }
{  0 - no msgbase or subscribers                                           }
{  1 - one or more of msgbase, bbs, ftn subscribers                        }
{  2 - uucp subscribers                                                    }
{  3 - 2 and 3                                                             }
{  4 - netmail, local, or e-mail area (msgbase only)                       }
{                                                                          }
FUNCTION GetAreaSubscriberTypes (AreaRecNr : AreaBaseRecordNrType) : BYTE;

VAR Needs    : BYTE;
    AreaRec  : AreaBaseRecord;
    SubRecNr : SubscriptBaseRecordNrType;
    SubRec   : SubscriptBaseRecord;
    UserRec  : UserBaseRecord;
    Lp       : 1..MaxSubscrBaseElements;

BEGIN
     {## see if we can speed this up with an index}
     ReadAreaBaseRecord (AreaRecNr,AreaRec);

     IF (AreaRec.AreaType IN [Area_Netmail, Area_EMail, Area_Local]) THEN
     BEGIN
          GetAreaSubscriberTypes:=4;
          Exit;
     END;

     { is thus an echomail area }

     Needs:=0;

     { Messagebase attached? }
     IF (AreaRec.FidoMsgStyle <> NoneType) THEN
        Needs:=Needs OR 1; { echomail }

     SubRecNr:=AreaRec.UserList;

     WHILE (SubRecNr <> NILRecordNr) DO
     BEGIN
          ReadSubscriptBaseRecord (SubRecNr,SubRec);

          FOR Lp:=1 TO MaxSubscrBaseElements DO
              IF (SubRec.UserList[Lp] <> NILRecordNr) THEN
              BEGIN
                   ReadUserBaseRecord (SubRec.UserList[Lp],UserRec);
                   CASE UserRec.System OF
                        _F   : Needs:=Needs OR 1; { echomail }
                        _BBS : Needs:=Needs OR 1; { echomail }

                        _U   : Needs:=Needs OR 2; { news, uucp }
                        _P   : {impossible};
                        _S   : {impossible};
                        _B   : Needs:=Needs OR 2; { news, bag }
                        _SOUP: Needs:=Needs OR 2; { news, soup }
                   END; { case }

                   IF (Needs = 3) THEN
                   BEGIN
                        GetAreaSubscriberTypes:=Needs;
                        Exit;
                   END;
              END;

          SubRecNr:=SubRec.NextSegmentRecordNr;
     END; { while }

     GetAreaSubscriberTypes:=Needs;
END;


{--------------------------------------------------------------------------}
{ SetSeenByBit                                                             }
{                                                                          }
PROCEDURE SetSeenByBit (VAR Akas : AkaBitList; AKA : BYTE);

VAR I : BYTE;
    B : BYTE;

BEGIN
     I:=(AKA-1) DIV 8;
     B:=1 SHL ((AKA-1) MOD 8);
     Akas[I]:=Akas[I] OR B;
END;


{--------------------------------------------------------------------------}
{ ResetSeenByBit                                                           }
{                                                                          }
PROCEDURE ResetSeenByBit (VAR Akas : AkaBitList; AKA : BYTE);

VAR I : BYTE;
    B : BYTE;

BEGIN
     I:=(AKA-1) DIV 8;
     B:=1 SHL ((AKA-1) MOD 8);
     Akas[I]:=Akas[I] AND (255-B);
END;


{--------------------------------------------------------------------------}
{ HasSeenByBit                                                             }
{                                                                          }
FUNCTION HasSeenByBit (VAR Akas : AkaBitList; AKA : BYTE) : BOOLEAN;

VAR I : BYTE;
    B : BYTE;

BEGIN
     I:=(AKA-1) DIV 8;
     B:=1 SHL ((AKA-1) MOD 8);
     HasSeenByBit:=(Akas[I] AND B) > 0;
END;


{--------------------------------------------------------------------------}
{ SetSingleSeenByBit                                                       }
{                                                                          }
PROCEDURE SetSingleSeenByBit (VAR Akas : AkaBitList; AKA : BYTE);
BEGIN
     FillChar (Akas,13,0);
     SetSeenByBit (Akas,AKA);
END;


{--------------------------------------------------------------------------}
{ IsOnlySeenByBit                                                          }
{                                                                          }
{ Returns TRUE when the given aka is the only bit set in the seenby list.  }
{                                                                          }
FUNCTION IsOnlySeenByBit (VAR Akas : AkaBitList; Aka : BYTE) : BOOLEAN;

VAR I  : BYTE;
    B  : BYTE;
    Lp : 1..MaxAKAs;

BEGIN
     IsOnlySeenByBit:=FALSE;

     { check that the requested bit is set }
     IF (NOT HasSeenByBit (Akas,Aka)) THEN
        Exit;  { with false }   { ## EXIT ## }

     FOR Lp:=1 TO MaxAKAs DO
         IF (Lp <> Aka) THEN
         BEGIN
              I:=(Lp-1) DIV 8;
              B:=1 SHL ((Lp-1) MOD 8);
              IF ((Akas[I] AND B) <> 0) THEN
                 Exit; { with false }   { ## EXIT ## }
         END; { for }

     IsOnlySeenByBit:=TRUE;
END;


{--------------------------------------------------------------------------}
{ SortAreaBaseQuickPreSort                                                 }
{                                                                          }
{ Deze routine sorteert de AreaBase op het eerste teken.                   }
{                                                                          }
FUNCTION SortAreaBaseQuickPreSort : BOOLEAN;

TYPE QuickArray    = ARRAY[1..65528] OF CHAR;
     QuickArrayPtr = ^QuickArray;

VAR Nr,Nr2,
    SmallNr,
    ACount   : AreaBaseRecordNrType;
    QuickPtr : QuickArrayPtr;
    PercDone : BYTE;
    Rec1,
    Rec2     : AreaBaseRecord;

LABEL Abort;

BEGIN
     SortAreaBaseQuickPreSort:=TRUE; { not aborted }

     Message ('Building list of Quick area names °°°°°°°°°° (0%)  ');

     ACount:=AreaBaseRecCount;
     GetMem (QuickPtr,ACount);
     PeekMem;

     FOR Nr:=1 TO ACount DO
     BEGIN
          ReadAreaBaseRecord (Nr,Rec1);
          QuickPtr^[Nr]:=Rec1.AreaName_U[1];

          PercDone:=Round ((Nr/ACount)*100);
          WriteXYC (49,MessageYB,cMessage,
                                   RepChar (PercDone DIV 10,'±')+
                                   RepChar (10-(PercDone DIV 10),'°')+
                                   ' ('+Byte2String (PercDone)+'%)');

          IF KeyPressed AND (ReadKey = kEsc) THEN
          BEGIN
               SortAreaBaseQuickPreSort:=FALSE; { aborted }
               GOTO Abort;
          END;
     END; { for }

     WindowPop; { message }

     Message ('Sorting the area base (1/2) °°°°°°°°°° (0%)  ');

     FOR Nr:=1 TO ACount-1 DO
     BEGIN
          SmallNr:=Nr;

          { zoek de kleinste in de lijst en zet die vooraan }
          FOR Nr2:=Nr+1 TO ACount DO
          BEGIN
               IF (QuickPtr^[Nr2] < QuickPtr^[SmallNr]) THEN
                  SmallNr:=Nr2;
          END;

          IF (SmallNr <> Nr) THEN
          BEGIN
               { omwisselen die hap }
               ReadAreaBaseRecord (Nr,Rec1);
               ReadAreaBaseRecord (SmallNr,Rec2);

               { let op: omgekeerde volgorde om seek tijd te reduceren! }
               WriteAreaBaseRecord (SmallNr,Rec1);
               WriteAreaBaseRecord (Nr,Rec2);

               QuickPtr^[Nr]:=Rec2.AreaName_U[1];
               QuickPtr^[SmallNr]:=Rec1.AreaName_U[1];
          END;

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

          PercDone:=Round ((Nr/ACount)*100);
          WriteXYC (46,MessageYB,cMessage,
                                   RepChar (PercDone DIV 10,'±')+
                                   RepChar (10-(PercDone DIV 10),'°')+
                                   ' ('+Byte2String (PercDone)+'%)');
     END; { for }

Abort:
     WindowPop; { message }
     FreeMem (QuickPtr,ACount);
END;


{--------------------------------------------------------------------------}
{ SortAreaBase                                                             }
{                                                                          }
{ Deze routine sorteert de areabase op Usenet naam. Omdat niet alle area   }
{ namen in het geheugen kunnen, wordt de database op disk gesorteerd. Een  }
{ goeie cache moet dat echter wel op kunnen vangen.                        }
{                                                                          }
PROCEDURE SortAreaBase;

CONST MAXSHORTS = 65528 DIV SizeOf (StringPtr);

TYPE ShortArray    = ARRAY[1..MAXSHORTS] OF StringPtr;
     ShortArrayPtr = ^ShortArray;

VAR Nr1,
    Nr2,
    SmallNr,
    ACount   : AreaBaseRecordNrType;
    Rec1,
    Rec2     : AreaBaseRecord;
    PercDone : BYTE;

    ShortPtr : ShortArrayPtr;
    Shorts   : WORD;
    ShortLen : BYTE;
    Blocks   : WORD;

LABEL Abort;

BEGIN
     LogMessage (liTrivial,'Sort Areabase started');

     PushKeysLine;
     WriteKeysLine (' ^Esc Abort');

     IF (NOT SortAreaBaseQuickPreSort) THEN
     BEGIN
          PopKeysLine;
          Exit;
     END;

     Message ('Building list of (partial) area names °°°°°°°°°° (0%)  ');

     ACount:=AreaBaseRecCount;

     { als er meer areas zijn dan waar we de naam van kunnen onthouden, }
     { dan onthouden we alleen van de eerste set de naam.               }
     IF (ACount > MAXSHORTS) THEN
        Shorts:=MAXSHORTS
     ELSE
         Shorts:=ACount;

     { vraag geheugen aan voor het array of pointers }
     GetMem (ShortPtr,Shorts*SizeOf (StringPtr));
     PeekMem;

     { bereken nu hoeveel tekens we van iedere areanaam kunnen onthouden }
     { Merk op dat 1 teken van deze lengte straks verloren gaat aan de   }
     { lengtebyte van de string.                                         }
     { Helaas kan je alleen geheugen aanvragen in stappen van 8 bytes,   }
     { dus moeten we daar ook nog eens rekening mee houden.              }
     Blocks:=(_MaxAvail DIV 8);
     ShortLen:=(Blocks DIV Shorts)*8;

     IF (ShortLen > 0) THEN
     BEGIN
          { lees nu van alle areas die we op kunnen slaan het record in en }
          { sla de eerste paar tekens van de naam op.                      }
          FOR Nr1:=1 TO Shorts DO
          BEGIN
               ReadAreaBaseRecord (Nr1,Rec1);
               GetMem (ShortPtr^[Nr1],ShortLen);

               { 1 positie gaat er verloren aan de lengtebyte van de string, }
               { dus uiteindelijk kunnen we maar ShortLen-1 tekens van de    }
               { naam opslaan. Al is het maar 1 teken...                     }
               ShortPtr^[Nr1]^:=Copy (Rec1.AreaName_U,1,ShortLen-1);

               PercDone:=Round ((Nr1/Shorts)*100);
               WriteXYC (51,MessageYB,cMessage,
                                        RepChar (PercDone DIV 10,'±')+
                                        RepChar (10-(PercDone DIV 10),'°')+
                                        ' ('+Byte2String (PercDone)+'%)');
          END; { for }
     END; { if ShortLen > 0 }

     PeekMem;
     WindowPop; { message }

     Message ('Sorting Area Base (2/2):             °°°°°°°°°° (0%)  ');

     Nr1:=1;
     WHILE (Nr1 < ACount) DO
     BEGIN
          ReadAreaBaseRecord (Nr1,Rec1);

          { ga op zoek naar een die hier voor kan }
          SmallNr:=Nr1; { beste tot nu toe }

          Nr2:=Nr1+1;
          WHILE (Nr2 <= ACount) AND (ShortPtr^[Nr2]^[1] = ShortPtr^[SmallNr]^[1]) DO
          BEGIN
               { eerst een snelle test met het "short" array, als deze   }
               { area daarin voorkomt. Als de test goed gaat, dan lezen  }
               { we alsnog het record in en doen we een vergelijking met }
               { de hele naam. Dat moet ook als de ShortName niet in het }
               { array pastte.                                           }
               IF (ShortLen = 0) OR
                  (Nr2 > Shorts) OR
                  ((Nr2 <= Shorts) AND (ShortPtr^[Nr2]^ < Rec1.AreaName_U)) THEN
               BEGIN
                    ReadAreaBaseRecord (Nr2,Rec2);

                    IF (Rec2.AreaName_U < Rec1.AreaName_U) THEN
                    BEGIN
                         { nieuwe kleinste }
                         SmallNr:=Nr2;
                         Rec1:=Rec2;
                    END;
               END;

               Inc (Nr2);

               IF KeyPressed AND (ReadKey = kEsc) THEN
               BEGIN
                    LogMessage (liGeneral,'Sort Areabase aborted by user');
                    GOTO Abort;
               END;

          END; { while }

          IF (SmallNr <> Nr1) THEN
          BEGIN
               { verwissel de records }
               ReadAreaBaseRecord (Nr1,Rec1);
               ReadAreaBaseRecord (SmallNr,Rec2);

               { let op: omgekeerde volgorde om seek tijd te reduceren! }
               WriteAreaBaseRecord (SmallNr,Rec1);
               WriteAreaBaseRecord (Nr1,Rec2);

               IF (ShortLen > 0) THEN
               BEGIN
                    { nu de Short tabel updaten }
                    IF (Nr1 <= Shorts) THEN
                       ShortPtr^[Nr1]^:=Copy (Rec2.AreaName_U,1,ShortLen-1);

                    IF (SmallNr <= Shorts) THEN
                       ShortPtr^[SmallNr]^:=Copy (Rec1.AreaName_U,1,ShortLen-1);
               END;
          END;

          Inc (Nr1);

          WriteXYC (39,MessageYB,cMessage,Word2String (Nr1)+'/'+Word2String (ACount));

          PercDone:=Round ((Nr1/ACount)*100);
          WriteXY (51,MessageYB,RepChar (PercDone DIV 10,'±')+
                                RepChar (10-(PercDone DIV 10),'°')+
                                ' ('+Byte2String (PercDone)+'%)');
     END; { while }

Abort:
     { geef al het geheugen weer vrij }
     { achterstevoren graag, anders krijgen we ongelukken met de admin. }
     IF (ShortLen > 0) THEN
        FOR Nr1:=Shorts DOWNTO 1 DO
            FreeMem (ShortPtr^[Nr1],ShortLen);

     FreeMem (ShortPtr,Shorts*SizeOf (StringPtr));

     WindowPop; { message }
     PopKeysLine;
END;


{--------------------------------------------------------------------------}
{ ChangeAreaInUserSubscrToList                                             }
{                                                                          }
{ Deze routine verwerkt een wijziging omdat een area een nieuwe plek       }
{ krijgt in een andere database. Het oude nummer wordt opgezocht en        }
{ vervangen door het nieuwe nummer.                                        }
{                                                                          }
PROCEDURE ChangeAreaInUserSubscrToList (VAR UserData : UserBaseRecord; OldRecNr,NewRecNr : AreaBaseRecordNrType);

VAR SubRec : SubscriptBaseRecord;
    RecNr  : SubscriptBaseRecordNrType;
    Lp     : 0..MaxSubscrBaseElements;

BEGIN
     RecNr:=UserData.AreaList;

     WHILE (RecNr <> NILRecordNr) DO
     BEGIN
          ReadSubscriptBaseRecord (RecNr,SubRec);

          FOR Lp:=1 TO MaxSubscrBaseElements DO
              IF (SubRec.AreaList[Lp] = OldRecNr) THEN
              BEGIN
                   SubRec.AreaList[Lp]:=NewRecNr; { verwijderen }
                   WriteSubscriptBaseRecord (RecNr,SubRec);
                   Exit;
              END;

          RecNr:=SubRec.NextSegmentRecordNr;
     END; { while }
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 =========================================}

{--------------------------------------------------------------------------}
{ BuildSingleGroupDesc                                                     }
{                                                                          }
{ Deze routine geeft een omschrijving voor e'e'n enkele group terug,       }
{ bijvoorbeeld A1.                                                         }
{                                                                          }
FUNCTION BuildSingleGroupDesc (Group : GroupNrType) : STRING;

VAR L,C : BYTE;

BEGIN
     L:=(Group-1) DIV 5;
     C:=(Group-1) MOD 5;
     BuildSingleGroupDesc:=Char (Ord ('A')+L)+Char (Ord ('1')+C);
END;


{--------------------------------------------------------------------------}
{ 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; MaxLen : BYTE) : STRING;

VAR Desc   : STRING;
    Lp     : GroupNrType;
    I,O    : BYTE;
    L,C    : BYTE;
    LastL  : BYTE;

    PROCEDURE CheckEnd;
    BEGIN
         IF (Length (Desc) > 5) AND (Copy (Desc,Length (Desc)-4,5) = '12345') THEN
            Desc:=Copy (Desc,1,Length (Desc)-5) { geen 12345 meer, alleen letter }
         ELSE
             IF (Length (Desc) > 4) THEN
             BEGIN
                  IF (Copy (Desc,Length (Desc)-3,4) = '1234') THEN
                     Desc:=Copy (Desc,1,Length (Desc)-4)+'1-4'
                  ELSE
                      IF (Copy (Desc,Length (Desc)-3,4) = '2345') THEN
                         Desc:=Copy (Desc,1,Length (Desc)-4)+'2-5';
             END;
    END;

BEGIN
     Desc:='';
     LastL:=255;

     FOR Lp:=1 TO MaxGroups DO
     BEGIN
          I:=(Lp-1) DIV 8;
          O:=(Lp-1) MOD 8;

          L:=(Lp-1) DIV 5;
          C:=(Lp-1) MOD 5;

          IF ((Group[I+1] AND (1 SHL O)) > 0) THEN
          BEGIN
               IF (L <> LastL) THEN
               BEGIN
                    CheckEnd;
                    LastL:=L;
                    IF (Desc <> '') THEN
                       Desc:=Desc+' ';
                    Desc:=Desc+Char (Ord ('A')+L);
               END;

               Desc:=Desc+Char (Ord ('1')+C);
          END;
     END;

     CheckEnd;

     IF (Length (Desc) > MaxLen) THEN
     BEGIN
          { eerst alle spaties tussen twee opeenvolgende letters weghalen }
          { bijvoorbeeld A1 B C D4 -> A1 BC D4 }
          I:=2;
          WHILE (I < Length (Desc)-1) DO
          BEGIN
               { deze een spatie, vorige een letter en volgende een letter }
               { maar niet volgende een letter+cijfer.                     }
               IF (Desc[I] = ' ') AND
                  (Desc[I-1] IN ['A'..'Z']) AND
                  (Desc[I+1] IN ['A'..'Z']) AND
                  (Desc[I+2] = ' ') { altijd Z<cijfer(s)>, nooit alleen Z }
                                    { dus I+2 is veilig.                  }
               THEN
                   Delete (Desc,I,1);

               Inc (I);
          END;
     END;

     IF (Length (Desc) > MaxLen) THEN
        WHILE (Pos (' ',Desc) > 0) DO
              Delete (Desc,Pos (' ',Desc),1);

     IF (Length (Desc) > MaxLen) THEN
        Desc:=Copy (Desc,1,MaxLen-2)+'..';

     BuildGroupListDesc:=Desc;
END;


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

{--------------------------------------------------------------------------}
{ ResetGroupFlags                                                          }
{                                                                          }
{ Deze routine maakt de group flags leeg.                                  }
{                                                                          }
PROCEDURE ResetGroupFlags (VAR Group : GroupFlagType);

VAR Lp : 1..GroupFlagLen;

BEGIN
     FOR Lp:=1 TO GroupFlagLen DO
         Group[Lp]:=0;
END;


{--------------------------------------------------------------------------}
{ 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);

VAR I,O : BYTE;

BEGIN
     I:=1+((NewGroupNr-1) DIV 8);
     O:=(NewGroupNr-1) MOD 8;
     Group[I]:=Group[I] OR (1 SHL O);
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);

VAR I,O : BYTE;

BEGIN
     I:=1+((DelGroupNr-1) DIV 8);
     O:=(DelGroupNr-1) MOD 8;
     Group[I]:=Group[I] AND (255-(1 SHL O));
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;

VAR I,O : BYTE;

BEGIN
     I:=1+((GroupNr-1) DIV 8);
     O:=(GroupNr-1) MOD 8;
     TestIfInGroup:=((Group[I] AND (1 SHL O)) > 0);
END;


{--------------------------------------------------------------------------}
{ TestGroupListIsEmpty                                                     }
{                                                                          }
{ Geeft TRUE terug als de group flags leeg zijn.                           }
{                                                                          }
FUNCTION TestGroupListIsEmpty (VAR Group : GroupFlagType) : BOOLEAN;

VAR Lp : 1..GroupFlagLen;

BEGIN
     TestGroupListIsEmpty:=TRUE;

     FOR Lp:=1 TO GroupFlagLen DO
         IF (Group[Lp] <> 0) THEN
            TestGroupListIsEmpty:=FALSE;
END;


{--------------------------------------------------------------------------}
{ TestGroupListSame                                                        }
{                                                                          }
{ Compare two group lists and return TRUE if exactly the same.             }
{                                                                          }
FUNCTION TestGroupListSame (VAR GroupList1,GroupList2 : GroupFlagType) : BOOLEAN;

VAR Lp : 1..GroupFlagLen;

BEGIN
     FOR Lp:=1 TO GroupFlagLen DO
         IF (GroupList1[Lp] <> GroupList2[Lp]) THEN
         BEGIN
              TestGroupListSame:=FALSE;
              Exit;
         END;

     TestGroupListSame:=TRUE;
END;


{--------------------------------------------------------------------------}
{ TestIfGroupCommon                                                        }
{                                                                          }
{ Geeft TRUE terug als er ten minste e'e'n groep overeen komt.             }
{                                                                          }
FUNCTION TestIfGroupCommon (VAR GroupAny,GroupList : GroupFlagType) : BOOLEAN;

VAR Lp : 1..GroupFlagLen;

BEGIN
     FOR Lp:=1 TO GroupFlagLen DO
         IF ((GroupAny[Lp] AND GroupList[Lp]) <> 0) THEN
         BEGIN
              TestIfGroupCommon:=TRUE;
              Exit;
         END;

     TestIfGroupCommon:=FALSE;
END;


{--------------------------------------------------------------------------}
{ TestIfGroupCommon3                                                       }
{                                                                          }
{ Geeft TRUE terug als een groep gezet is in alle drie de lijsten.         }
{                                                                          }
FUNCTION TestIfGroupCommon3 (VAR GroupList1,GroupList2,GroupList3 : GroupFlagType) : BOOLEAN;

VAR Lp : 1..GroupFlagLen;

BEGIN
     FOR Lp:=1 TO GroupFlagLen DO
         IF ((GroupList1[Lp] AND GroupList2[Lp] AND GroupList3[Lp]) <> 0) THEN
         BEGIN
              TestIfGroupCommon3:=TRUE;
              Exit;
         END;

     TestIfGroupCommon3:=FALSE;
END;


{--------------------------------------------------------------------------}
{ CreateCommonGroup                                                        }
{                                                                          }
{ Deze routine geeft de groepen die hetzelfde zijn in beide sets terug.    }
{                                                                          }
PROCEDURE CreateCommonGroup (VAR GroupCommon,GroupList1,GroupList2 : GroupFlagType);

VAR Lp : 1..GroupFlagLen;

BEGIN
     FOR Lp:=1 TO GroupFlagLen DO
         GroupCommon[Lp]:=GroupList1[Lp] AND GroupList2[Lp];
END;


{--------------------------------------------------------------------------}
{ CreateCommonGroup                                                        }
{                                                                          }
{ This routine merges the NewGroup into the Group. Or in other words: all  }
{ the groups in NewGroup that are not yet in Group area added.             }
{                                                                          }
PROCEDURE MergeGroups (VAR Group,NewGroup : GroupFlagType);

VAR Lp : 1..GroupFlagLen;

BEGIN
     FOR Lp:=1 TO GroupFlagLen DO
         Group[Lp]:=Group[Lp] OR NewGroup[Lp];
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
     {$IFDEF Pre}
     IF (RecNr = NILRecordNr) THEN
        LogMessage (liReport,'Program inconsistency error "DRU"');
     {$ENDIF}

     TdbRead (UserBaseTdbNr,RecNr,UserData);
END;


{--------------------------------------------------------------------------}
{ WriteUserBaseRecord                                                      }
{                                                                          }
{ Deze routine schrijft een User Database record naar de file.             }
{                                                                          }
PROCEDURE WriteUserBaseRecord (RecNr : UserBaseRecordNrType; VAR UserData : UserBaseRecord);
BEGIN
     IF (RecNr = NILRecordNr) THEN
     BEGIN
          {$IFDEF Pre}
          LogMessage (liReport,'Program inconsistency error "DWU"');
          {$ENDIF}
          Exit; { forget it! }
     END;

     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    }
{                                                                          }
{ This routine must NOT find BBS users!                                    }
{                                                                          }
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));
     Do2Too:=FidoGetOtherPointAdres (Search,Search2);
     { RWI 960113: previous is now a function
     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;               { betekenen 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 IN [_INETMAIL,_SOUP,_U,_S]) AND
             CaselessMatch_CC (DeleteBackSpaces (UserData.UUCPName),Search) THEN
          BEGIN
               RecNr:=Lp;
               FindUserBaseRecordByUUCPName:=TRUE;
               Break;
          END;
     END; { for }
END;


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

{$IFNDEF WtrUtil}
CONST ERROR_RUNWTRUTILDATABASE = 'Detected database integrity error!! 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
     {$IFDEF Pre}
     IF (RecNr = NILRecordNr) THEN
        LogMessage (liReport,'Program inconsistency error "DRS"');
     {$ENDIF}

     TdbRead (SubscriptBaseTdbNr,RecNr,Data);
END;


{---------------------------------------------------------------------------}
{ WriteSubscriptBaseRecord                                                  }
{                                                                           }
{ Deze routine schrijft een Subscript Base segment (record) weg.            }
{                                                                           }
PROCEDURE WriteSubscriptBaseRecord (RecNr : SubscriptBaseRecordNrType; VAR Data : SubscriptBaseRecord);
BEGIN
     {$IFDEF Pre}
     IF (RecNr = NILRecordNr) THEN
     BEGIN
          LogMessage (liReport,'Program inconsistency error "DWS"');
          Exit; { forget it! }
     END;
     {$ENDIF}

     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) OR
{ RWI 960915: detect loop }  (NewRecNr = SubscrRecNr) THEN
                          BEGIN
                               {$IFDEF WtrGate}
                               LogMessage (liFatal,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) OR
{ RWI 960915: detect loop }  (NewRecNr = SubscrRecNr) THEN
                          BEGIN
                               {$IFDEF WtrGate}
                               LogMessage (liFatal,ERROR_RUNWTRUTILDATABASE);
                               {$ENDIF}
                               {$IFDEF WtrConf}
                               Error (ERROR_RUNWTRUTILDATABASE);
                               {$ENDIF}
                               Exit; { RWI 960915: added }
                          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;


{--------------------------------------------------------------------------}
{ CountSubscribedAreas                                                     }
{                                                                          }
{ Deze telt heel snel hoeveel areas de user op aangesloten is (of andersom }
{ maar dat wordt niet gebruikt) door de Subscription base chain te         }
{ doorlopen en te tellen hoeveel record nummers er in voorkomen.           }
{                                                                          }
FUNCTION CountSubscribedAreas (FirstAreaList : SubscriptBaseRecordNrType) : WORD;

VAR Count      : WORD;
    SubscrData : SubscriptBaseRecord;
    Lp         : 1..MaxSubscrBaseElements;

BEGIN
     Count:=0;

     WHILE (FirstAreaList <> NILRecordNr) DO
     BEGIN
          ReadSubscriptBaseRecord (FirstAreaList,SubscrData);

          FOR Lp:=1 TO MaxSubscrBaseElements DO
              IF (SubscrData.AreaList[Lp] <> NILRecordNr) THEN
                 Inc (Count);

          IF (FirstAreaList = SubscrData.NextSegmentRecordNr) THEN
          BEGIN
               {$IFDEF WtrGate}
               LogMessage (liFatal,ERROR_RUNWTRUTILDATABASE);
               {$ENDIF}
               {$IFDEF WtrConf}
               Error (ERROR_RUNWTRUTILDATABASE);
               {$ENDIF}
               Break;
          END;

          FirstAreaList:=SubscrData.NextSegmentRecordNr;
     END;

     CountSubscribedAreas:=Count;
END;


{--------------------------------------------------------------------------}
{ CountAllowedEchoAreas                                                    }
{                                                                          }
{ This routine counts how many of all the available areas can be           }
{ subscribed when the user has access to the given groups. This is used    }
{ by the Notify code and can be used by WtrConf in the future.             }
{                                                                          }
FUNCTION CountAllowedEchoAreas (GroupsList : GroupFlagType) : WORD;

VAR ALp     : AreaBaseRecordNrType;
    AreaRec : AreaBaseRecord;
    Count   : WORD;

BEGIN
     Count:=0;

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

          IF (NOT AreaRec.Deleted) AND
             (AreaRec.AreaType = Area_Echo) AND
             TestIfGroupCommon (AreaRec.IsInGroups,GroupsList)
          THEN
              Inc (Count);

     END; { for }

     CountAllowedEchoAreas:=Count;
END;


{--------------------------------------------------------------------------}
{ CountSubscribedUsers                                                     }
{                                                                          }
{ Deze telt heel snel hoeveel users op een area aangesloten zijn door de   }
{ Subscription base chain af te lopen en te tellen hoeveel record nummers  }
{ er in voorkomen.                                                         }
{                                                                          }
FUNCTION CountSubscribedUsers (FirstUserList : SubscriptBaseRecordNrType) : WORD;

VAR Count      : WORD;
    SubscrData : SubscriptBaseRecord;
    Lp         : 1..MaxSubscrBaseElements;

BEGIN
     Count:=0;

     WHILE (FirstUserList <> NILRecordNr) DO
     BEGIN
          ReadSubscriptBaseRecord (FirstUserList,SubscrData);

          FOR Lp:=1 TO MaxSubscrBaseElements DO
              IF (SubscrData.UserList[Lp] <> NILRecordNr) THEN
                 Inc (Count);

          IF (FirstUserList = SubscrData.NextSegmentRecordNr) THEN
          BEGIN
               {$IFDEF WtrGate}
               LogMessage (liFatal,ERROR_RUNWTRUTILDATABASE);
               {$ENDIF}
               {$IFDEF WtrConf}
               Error (ERROR_RUNWTRUTILDATABASE);
               {$ENDIF}
               Break;
          END;

          FirstUserList:=SubscrData.NextSegmentRecordNr;
     END;

     CountSubscribedUsers:=Count;
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;


(* RWI 950810: vervangen door een snellere versie die direct de subscrbase
               benaderd.
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;
*)

{--------------------------------------------------------------------------}
{ 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 SubRec : SubscriptBaseRecord;
    RecNr  : SubscriptBaseRecordNrType;
    Lp     : 0..MaxSubscrBaseElements;

BEGIN
     RecNr:=UserData.AreaList;

     WHILE (RecNr <> NILRecordNr) DO
     BEGIN
          ReadSubscriptBaseRecord (RecNr,SubRec);

          FOR Lp:=1 TO MaxSubscrBaseElements DO
              IF (SubRec.AreaList[Lp] = SearchAreaBaseRecordNr) THEN
              BEGIN
                   SubRec.AreaList[Lp]:=NILRecordNr; { verwijderen }
                   WriteSubscriptBaseRecord (RecNr,SubRec);
                   RemoveAreaFromUserSubscrToList:=FALSE; { wel gevonden }
                   Exit;
              END;

          RecNr:=SubRec.NextSegmentRecordNr;
     END; { while }

     { area niet kunnen vinden }
     RemoveAreaFromUserSubscrToList:=TRUE;
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) OR
{ RWI 960915: detect loop }  (NewRecNr = SubscrRecNr) THEN
                          BEGIN
                               {$IFDEF WtrGate}
                               LogMessage (liFatal,ERROR_RUNWTRUTILDATABASE);
                               {$ENDIF}
                               {$IFDEF WtrConf}
                               Error (ERROR_RUNWTRUTILDATABASE);
                               {$ENDIF}
                               Exit; { RWI 960915 }
                          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) OR
{ RWI 960915: detect loop }  (NewRecNr = SubscrRecNr) THEN
                          BEGIN
                               {$IFDEF WtrGate}
                               LogMessage (liFatal,ERROR_RUNWTRUTILDATABASE);
                               {$ENDIF}
                               {$IFDEF WtrConf}
                               Error (ERROR_RUNWTRUTILDATABASE);
                               {$ENDIF}
                               Exit; { RWI 960915 }
                          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
                     { RWI 960915 }
                     IF (SubscrRecNr = SubscrData.NextSegmentRecordNr) THEN
                     BEGIN
                          {$IFNDEF WtrUtil}
                          Error (ERROR_RUNWTRUTILDATABASE);
                          {$ENDIF}
                          Exit;
                     END;

                     SubscrRecNr:=SubscrData.NextSegmentRecordNr;
                     ReadSubscriptBaseRecord (SubscrRecNr,SubscrData);
                     Element:=1;
                END;
           END ELSE
               Inc (Element);

           { already connected? }
           IF (SubscrData.UserList[Element] = UserBaseRecordNr) THEN
           BEGIN
                AddUserToAreaSubscrList:=TRUE; { already subscribed }
                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 : AreaBaseRecordNrType) : 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;


{===========================================================================}
{ 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
     IF (RecNr = NILRecordNr) THEN
     BEGIN
          {$IFDEF Pre}
          LogMessage (liReport,'Program inconsistency error "DWL"');
          {$ENDIF}
          Exit; { forget it! }
     END;

     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
               LogMessage (liFatal,'Error reading List Server Database record ('+Word2String (RecNr)+')');
               LogExtraMessage ('*** Please run WTRUTIL DATABASE');
               {LogFatalError (#7#7#7'Fatal: List Server Database Integrity error!');}
               ReadListBaseRecord:=FALSE;
          END;
     END ELSE
     BEGIN
          {$IFNDEF WtrGate}
          Error ('Attempt to read NILRecordNr record!');
          {$ELSE}
          {$IFDEF Pre}
          IF (RecNr = NILRecordNr) THEN
             LogMessage (liReport,'Program inconsistency error "DRL"');
          {$ENDIF}
          {$ENDIF}
          ReadListBaseRecord:=FALSE;
          ListData.NextUser:=NILRecordNr; { geen aangesloten users }
     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;
*)


{--------------------------------------------------------------------------}
{ ListUser_Read                                                            }
{
{                                                                          }
PROCEDURE ListUser_Read (RecNr : ListUserRecordNrType; VAR ListUser : ListUserRecord);
BEGIN
     TdbRead (ListUserTdbNr,RecNr,ListUser);
END;


{--------------------------------------------------------------------------}
{ ListUser_Write                                                           }
{
{                                                                          }
PROCEDURE ListUser_Write (RecNr : ListUserRecordNrType; VAR ListUser : ListUserRecord);
BEGIN
     TdbWrite (ListUserTdbNr,RecNr,ListUser);
END;


{--------------------------------------------------------------------------}
{ ListUser_WriteNew                                                        }
{
{                                                                          }
FUNCTION ListUser_WriteNew (VAR ListUser : ListUserRecord) : ListUserRecordNrType;
BEGIN
     ListUser_WriteNew:=TdbRecCount (ListUserTdbNr)+1;
     ListUser_Write (TdbRecCount (ListUserTdbNr)+1,ListUser);
END;


{--------------------------------------------------------------------------}
{ ListUser_RecCount                                                        }
{
{                                                                          }
FUNCTION ListUser_RecCount : ListUserRecordNrType;
BEGIN
     ListUser_RecCount:=TdbRecCount (ListUserTdbNr);
END;


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

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

