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

{$I platform.inc}

{$IFDEF PLATFORM_DOS_NOT_DPMI}
{(not)$DEFINE DebugMemUsage}
{$ENDIF}

{(not)$DEFINE DoPeekFiles}

(*
{$IFDEF LogFileIO}PostOpen ();{$ENDIF}
{$IFDEF LogFileIO}PreClose ();{$ENDIF}
*)

INTERFACE

{$IFNDEF Upgrade}
USES Ramon,
     Dos,
     Database,
     PackMem;
{$ENDIF (!Upgrade)}

CONST DotDotDot : STRING[3] = '...';
{$IFNDEF Upgrade}  { if I move this one line up, WtrUtil complains! }

      Month : ARRAY[1..12] OF STRING[3] = ('Jan','Feb','Mar',
                                           'Apr','May','Jun',
                                           'Jul','Aug','Sep',
                                           'Oct','Nov','Dec');

      Day : ARRAY[0..6] OF STRING[3]  = ('Sun','Mon','Tue',
                                         'Wed','Thu','Fri','Sat');

      fmReadOnly  = 0;          {FileMode constants}
      fmWriteOnly = 1;
      fmReadWrite = 2;
      fmDenyAll   = 16;
      fmDenyWrite = 32;
      fmDenyRead  = 48;
      fmDenyNone  = 64;
      fmNoInherit = 128;

      saJustFiles   = $21;      { $20=Archive, $01=Readonly }
      saDirAndFiles = $31;      { saJustFile + $10=Directory }

      MEMUSEFOR = 'Memory usage for ';
{$ENDIF (!Upgrade)}

CONST CopyrightLine = 'Copyright (c) 1993-2000 Ramon van der Winkel and Anthony Tibbs';

      PackageName           = 'WaterGate';

      DesktopProgramName    = 'WaterGate'
                              {$IFDEF PLATFORM_OS2}   +'/2' {$ENDIF}
                              {$IFDEF PLATFORM_WIN32} +'/W' {$ENDIF}
                              ;

      ProgramShortName      = 'WtrGate'
                              {$IFDEF PLATFORM_OS2}   +'/2' {$ENDIF}
                              {$IFDEF PLATFORM_WIN32} +'/W' {$ENDIF}
                              ;
      ProgramUserName       = 'wtrgate';

      MainVersionNr         = '2.00';
      MainRevisionNr        = MainVersionNr+'.PRE4';

      FullProgramVersion    = MainRevisionNr
       {$IFDEF PLATFORM_DPMI} +'-d'     {$ENDIF}
    { IFDEF PLATFORM_OVERLAY  +'-o'       ENDIF} { not anymore }
                {$IFDEF ALFA} +' ALPHA' {$ENDIF}
                {$IFDEF BETA} +' beta'  {$ENDIF}
               {$IFDEF GAMMA} +' gamma' {$ENDIF}
                              ;

      FullProgramName       = DesktopProgramName
             {$IFDEF WtrUtil} +' Util' {$ENDIF}
             {$IFDEF WtrConf} +' Conf' {$ENDIF}
             {$IFDEF WtrTest} +' Test' {$ENDIF}
             {$IFDEF WtrStat} +' Stat' {$ENDIF}
             {$IFDEF TextCfg} +' TextCfg' {$ENDIF}
                              ;
{$IFNDEF Upgrade}

CONST ProgramID = 'WaterGate '
                  +MainVersionNr;

CONST BuildPIDKludge = #1'PID: '+ProgramID;
      BuildTIDKludge = #1'TID: '+ProgramID;

      { version history:
      2.00.PRE4          000822
      2.00.PRE3          000522
      2.00.PRE2          000408
      2.00.PRE1          000220
      0.94.PRE34         991224
      0.94.PRE33         991218
      0.94.PRE32         991108
      0.94.PRE31         990924 (DOS only)
      0.94.PRE30         990915 FUL
      0.94.PRE29         990805 FUL
      0.94.PRE28         990713
      0.94.PRE27         990706
      0.94.PRE26         990621
      0.94.PRE25         990502
      0.94.PRE24         990327
      0.94.PRE23         990304
      0.94.PRE22         990209
      0.94.PRE21         990117
      0.94.PRE20         981117
      0.94.PRE19         981112
      0.94.PRE18         981016
      0.94.PRE17         981014
      0.94.PRE16         981007
      0.94.PRE15         980626
      0.94.PRE14         980614
      0.94.PRE13         980524
      0.94.PRE12         980519
      0.94.PRE11         980511
      0.94.PRE10         980503
      0.94.PRE9          980424
      0.94.PRE8          980330
      0.94.PRE7          980302
      0.94.PRE6          980215
      0.94.PRE5          980201
      0.94.PRE4          980129
      0.94.PRE3          980106
      0.94.PRE2          970831
      0.94.PRE1          970817
      0.93               970706 (branched 0.93 from main code)
      0.93.PRE14.p1      970629
      0.93.PRE14         970617
      0.93.PRE13.p4      970608 (OS2)
      0.93.PRE13.p3      970531
      0.93.PRE13.p2      970528
      0.93.PRE13.p1      970519
      0.93.PRE13         970511
      0.93.PRE12.p4      970510  (Guus only: Squish fixes)
      0.93.PRE12.p3      9705
      0.93.PRE12.p2      97
      0.93.PRE12.p1      97
      0.93.PRE12         970415
      0.93.PRE11.p2      970410
      0.93.PRE11.p1      970409
      0.93.PRE11         970408
      0.93.PRE10.p3      970406  (Francois only: BBS Interface)
      0.93.PRE10.p2      970405  (Francois only: BBS Interface)
      0.93.PRE10.p1      970329
      0.93.PRE10         970323
      0.93.PRE9          970228
      0.93.PRE8          970219
      0.93.PRE7          970215
      0.93.PRE6          970130
      0.93.PRE5          970126
      0.93.PRE4          970116
      0.93.PRE3          970112
      0.93.PRE2          970101
      0.93.PRE1          9612   (started 961208)
      0.93.PRE0 /2       961130
      0.92 alfa /2       961126
      0.92 gamma         961012
      0.92.PRE12 beta    9610??
      0.92.PRE11 beta    9610??
      0.92.PRE10 beta    960922
      0.92.PRE9 beta     960921 WtrTest
      0.92.PRE8 beta     960916
      0.92.PRE7 beta     960906 Overlay files
      0.92.PRE6 beta     960905
      0.92.PRE5 beta     9608??
      0.92.PRE4 beta     960824
      0.92.PRE3 beta     960821
      0.92.PRE2 beta     960819
      0.92.PRE1 beta     960719
      0.91.p1 beta       960
      0.91 beta          960530
      0.90.p10 beta      960505
      0.90.p9 beta       960419 (zegt nog steeds "p8" ;-( ;-( ;-( !!)
      0.90.p8 beta       960408?
      0.90.p7 beta       960324
      0.90.p6 beta       960315 (should have called it alpha.. ;)
      0.90.p5 beta       960313
      0.90.p4 beta       960310
      0.90.p3 cl. beta   9602.. Frans, Christian, Guus
      0.90.p2+ cl. beta  960225
      0.90.p2 cl. beta   960225
      0.90.p1+ cl. beta  960223 Rob Szarka + John Mudge
      0.90.p1 beta       960219
      0.90 beta          960214
      0.22 PRE1 beta     960209 (0.22 = 0.90)
      0.21.p4 beta       960115
      0.21.p3 beta       960113
      0.21.p2 beta       951231
      0.21.p1 beta       951217
      0.21 beta          951203
      0.21 PRE3          951130  voor Giovanni
      0.21.PRE2          951117  voor Giovanni
      0.21.PRE           951110  voor Giovanni
      0.20.p1 beta
      0.20 beta          951103
      0.19.p3 beta       951005  *.msg export loop wanneer geen header lines
      0.19.p2 beta       9509__
      0.19.p1 beta       950910  grote mails export problem
      0.19 beta          950903
      0.19.PRE3 beta     950827
      0.19.PRE2 beta     950816
      0.19.PRE beta      950810
      0.18.0629.p2 beta  950722
      0.18.0629.p1 beta  950721  distributie via mailing list
      0.18.0629 beta
      0.17.0606.p3 beta
      0.17.0606.p2 beta  950621: fixed read-only area problem
      0.17.0606.p1 beta  950612: fixed JAM problem
      0.17.0606 beta
      0.16.0327 beta
      0.15.0220.p5 beta  the usual...
      0.15.0220.p4 beta  voor joop (again... :-( )
      0.15.0220.p3 beta  terug van joop, wijzigingen verwerken
      0.15.0220.p2 beta  debuggen bij joop
      0.15.0220.p1 beta  Toen ik naar joop ging
      0.15.0220 beta
      twee patched versies van wtrgate.exe -> rene vreeman
      0.14.0302 beta
      vier patches
      0.13.1214 beta     Snelle opvolger ivm geen CR tussen tear en origin
      0.12.1128 beta
      0.11.1030 beta

      (RWI takeover)

      0.10.0816 beta
      0.10.0428 beta
      0.05.2002 beta
      others (?)

      }

TYPE PathString     = STRING[79];
     FilenameString = STRING[12];

VAR GroupListDesc    : STRING[54];
    LowestMemReached : LONGINT;

    ConditionRed     : BYTE;
    GlobalAbort      : BOOLEAN;

    FrontDoorAttach  : PackedBoolMem;

    regKeyDate       : LONGINT;
    regKeyNumber     : WORD;
    regUserName      : STRING[49];
    regOrganization  : STRING[49];

    ForceNoNet       : BOOLEAN;
    ForceNoEcho      : BOOLEAN;
    ForceNoRoute     : BOOLEAN;
    ForceNoImport    : BOOLEAN;
    ForceNoExport    : BOOLEAN;
    ForceNoNewsToss  : BOOLEAN;
    ForceNoFAKill    : BOOLEAN;
    ForceNoNewScan   : BOOLEAN;
    ForceCleanScan   : BOOLEAN;
    ForceNoTunnel    : BOOLEAN;

    DebugMem         : BOOLEAN;
    GoSetFMRescan    : BOOLEAN;
    GoSetFDRescan    : BOOLEAN;
    StayQuiet        : BOOLEAN;
    NoFullScreen     : BOOLEAN;

    TempPath         : PathStr;

PROCEDURE WriteMenuKeysLine;
FUNCTION  CopyFromFile (VAR Source,Dest : FILE; StartPos, NumBytes : LongInt ) : Boolean;
PROCEDURE WriteFieldEditDirectKeysLine;
FUNCTION  BuildGroupDesc (Lp : GroupNrType; VAR GroupData : GroupDescRecord) : STRING;
PROCEDURE EditGroupsList (VAR Groups : GroupFlagType; Msg1,Msg2 : STRING; Help1,Help2 : HelpHandleType);
PROCEDURE EditFidoAddr (VAR Address : FidoAddrType; Help : HelpHandleType);
FUNCTION  AreYouSureWithHelp (Title : STRING; Handle : HelpHandleType) : KeyType;
FUNCTION  AreYouSure (Title : STRING) : KeyType;
PROCEDURE PeekMem;
PROCEDURE DumpMem;
PROCEDURE PeekFiles;
{$IFDEF LogFileIO}
PROCEDURE PostOpenT (VAR F : TEXT);
PROCEDURE PreCloseT (VAR F : TEXT);
PROCEDURE PostOpenF (VAR F : FILE);
PROCEDURE PreCloseF (VAR F : FILE);
{$ENDIF}
FUNCTION  ReplaceExtension (Source : STRING; NewExt : STRING) : STRING;
FUNCTION  RenameSerial (Source : STRING; VAR Destination : STRING): BOOLEAN;
FUNCTION  GetUniqueFilename (Directory,Extension : STRING) : STRING;
FUNCTION  AtoI (Invoer : STRING; VAR Uitvoer : WORD) : BYTE;
FUNCTION  Micro2Longint (Invoer : LONGINT) : LONGINT;
FUNCTION  Longint2Micro (Invoer : LONGINT) : LONGINT;
FUNCTION  DeleteCTFBS (Tekst : STRING) : STRING;
FUNCTION  CalcMaxAllowedMem (VAR Allowed : WORD; AtLeast,AtMost : WORD) : BOOLEAN;

{$IFNDEF OS2}
{$IFNDEF WIN32}
PROCEDURE FindClose (VAR Search : SearchRec);
{$ENDIF}
{$ENDIF}

{$ENDIF (!Upgrade)}

IMPLEMENTATION

{$IFNDEF Upgrade}

USES Logs,
     Fido,
     Msgs,
     Cfg,
     Err_func,
     Strings;

{--------------------------------------------------------------------------}
{ WriteFieldEditDirectKeysLine                                             }
{                                                                          }
{ Deze routine drukt de keysline af voor de FieldEditDirect routine.       }
{                                                                          }
PROCEDURE WriteFieldEditDirectKeysLine;
BEGIN
     WriteKeysLine (' ^Esc abort  ^Enter accept  ^Ctrl-End clear rest of field');
END;


{--------------------------------------------------------------------------}
{ WriteMenuKeysLine                                                        }
{                                                                          }
{ Deze routine drukt de keysline af voor de menus.                         }
{                                                                          }
PROCEDURE WriteMenuKeysLine;
BEGIN
     WriteKeysLine (' ^Esc return  ^'#24#25' position  ^Enter select');
END;


{--------------------------------------------------------------------------}
{ BuildGroupDesc                                                           }
{                                                                          }
FUNCTION BuildGroupDesc (Lp : GroupNrType; VAR GroupData : GroupDescRecord) : STRING;

CONST ReadOnlyStrs : ARRAY[FALSE..TRUE] OF STRING[11] = ('','[READ-ONLY]');

BEGIN
     BuildGroupDesc:=BuildSingleGroupDesc (Lp)+': '+
                     AddUpWithSpaces (30,GroupData.GroupDesc)+' '+
                     Fido2Str (Config.NodeNrs[GroupData.OriginAka])+' '+
                     ReadOnlyStrs[GroupData.ReadOnly];
END;


{--------------------------------------------------------------------------}
{ EditGroupsList                                                           }
{                                                                          }
{ Deze routine kan voor zowel UserData als AreaData gebruikt worden om het }
{ groups veld aan te passen. Msg1 komt boven de lijst waar de user/area    }
{ lid van is, dan andere in de diezelfde lijst als er geen groups in       }
{ zitten.                                                                  }
{                                                                          }
PROCEDURE EditGroupsList (VAR Groups : GroupFlagType; Msg1,Msg2 : STRING; Help1,Help2 : HelpHandleType);

CONST GroupKeysLine = ' ^Esc Abort  ^Ins Add group  ^Del Delete group ^F5 (Un)tag';

VAR Quit,Quit2,
    First,
    RebuildList : BOOLEAN;
    GroupData   : GroupDescRecord;
    Lp,Keuze    : WORD;

BEGIN
     ListDefine (3,3,Video.Cols-10,Video.Rows-4,Default,Msg1,Help1);

     FOR Lp:=1 TO MaxGroups DO
         IF TestIfInGroup (Groups,Lp) THEN
         BEGIN
              ReadGroupDescRecord (Lp,GroupData);
              ListAddItem (BuildGroupDesc (Lp,GroupData),Lp,Sorted);
         END;

     Quit:=FALSE;
     REPEAT
           ListTagKeysLine:=GroupKeysLine;

           IF (ListItemCount = 0) THEN
           BEGIN
                ListAddItem (Msg2,65534,Bottom);
                Keuze:=ListSelect (DoTag,[kIns,kF10]);
           END ELSE
               Keuze:=ListSelect (DoTag,[kIns,kDel,kF10]);

           ListTagKeysLine:=ORG_ListTagKeysLine;

           ListRemoveItem (65534);

           CASE Key OF
                kIns : BEGIN
                            ListDefine (78,3,Video.Cols-10,Video.Rows-4,TopRight,'Other groups',Help2);
                            FOR Lp:=1 TO MaxGroups DO
                                IF (NOT TestIfInGroup (Groups,Lp)) THEN
                                BEGIN
                                     ReadGroupDescRecord (Lp,GroupData);
                                     ListAddItem (BuildGroupDesc (Lp,GroupData),Lp,Bottom);
                                END;

                            IF (ListItemCount = 0) THEN
                               ListAddItem ('<no other groups>',65534,Bottom);

                            Quit2:=FALSE;
                            REPEAT
                                  Keuze:=ListSelect (DoTag,[]);

                                  CASE Key OF
                                       kEsc : Quit2:=TRUE;

                                       kRet : BEGIN
                                                   IF (ListTagCount = 0) THEN
                                                   BEGIN
                                                        AddGroupToGroupList (Groups,Keuze);
                                                        ListAddItemToPrevList (ListGetItemTekst (Keuze),Keuze,Sorted);
                                                   END ELSE
                                                       WHILE (ListTagCount > 0) DO
                                                       BEGIN
                                                            Keuze:=ListGetTaggedItemNr (1);
                                                            AddGroupToGroupList (Groups,Keuze);
                                                            ListAddItemToPrevList (ListGetItemTekst (Keuze),Keuze,Sorted);
                                                            ListRemoveItem (Keuze);
                                                       END;

                                                   Quit2:=TRUE;
                                              END; { kRet }
                                  END; { case }
                            UNTIL Quit2;

                            ListErase;
                       END; { kIns }

                kDel : BEGIN
                            IF (ListTagCount = 0) THEN
                            BEGIN
                                 DeleteGroupFromGroupList (Groups,Keuze);
                                 ListRemoveItem (Keuze);
                            END ELSE
                                WHILE (ListTagCount > 0) DO
                                BEGIN
                                     Keuze:=ListGetTaggedItemNr (1);
                                     DeleteGroupFromGroupList (Groups,Keuze);
                                     ListRemoveItem (Keuze);
                                END;

                       END; { kDel }

                kF10,
                kEsc : Quit:=TRUE;
           END;
     UNTIL Quit;

     ListErase;

     GroupListDesc:=AddUpWithSpaces (54,BuildGroupListDesc (Groups,54));
END;


{--------------------------------------------------------------------------}
{ EditFidoAddr                                                             }
{                                                                          }
{ Dit is een universele routine om een Fidonet Addr type te editten.       }
{                                                                          }
PROCEDURE EditFidoAddr (VAR Address : FidoAddrType; Help : HelpHandleType);

CONST Xb = 20;
      Yb = 7;
      Xl = 40;
      Yl = 7;

VAR ZoneStr,
    NetStr,
    NodeStr,
    PointStr  : STRING[5];
    DomainStr : STRING[MaxLenFidoAddrString-23];
    Nop       : ValNop;
    Temp      : WORD;

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

     FieldPushAll;
     FieldInit;

     WITH Address DO
     BEGIN
          Str (Zone,ZoneStr);
          ZoneStr:=AddUpWithSpaces (5,ZoneStr);

          Str (Net,NetStr);
          NetStr:=AddUpWithSpaces (5,NetStr);

          Str (Node,NodeStr);
          NodeStr:=AddUpWithSpaces (5,NodeStr);

          Str (Point,PointStr);
          PointStr:=AddUpWithSpaces (5,PointStr);

          DomainStr:=AddUpWithSpaces (MaxLenFidoAddrString-23,Domain);
     END;

     WriteXY (Xb+2,Yb+1,'Zone');
     FieldDefineOne (1,Xb+9,Yb+1,5,5,2,@ZoneStr,RepChar (5,'%'));
     FieldSetHelp (1,Help);

     WriteXY (Xb+2,Yb+2,'Net');
     FieldDefineOne (2,Xb+9,Yb+2,5,1,3,@NetStr,RepChar (5,'%'));
     FieldSetHelp (2,Help);

     WriteXY (Xb+2,Yb+3,'Node');
     FieldDefineOne (3,Xb+9,Yb+3,5,2,4,@NodeStr,RepChar (5,'%'));
     FieldSetHelp (3,Help);

     WriteXY (Xb+2,Yb+4,'Point');
     FieldDefineOne (4,Xb+9,Yb+4,5,3,5,@PointStr,RepChar (5,'%'));
     FieldSetHelp (4,Help);

     WriteXY (Xb+2,Yb+5,'Domain');
     FieldDefineOne (5,Xb+9,Yb+5,MaxLenFidoAddrString-23,4,1,@DomainStr,RepChar (MaxLenFidoAddrString-23,'$'));
     FieldSetHelp (5,Help);

     FieldEdit;

     WITH Address DO
     BEGIN
          Val (DeleteBackSpaces (ZoneStr),Temp,Nop);
          IF (Nop = 0) THEN Zone:=Temp;

          Val (DeleteBackSpaces (NetStr),Temp,Nop);
          IF (Nop = 0) THEN Net:=Temp;

          Val (DeleteBackSpaces (NodeStr),Temp,Nop);
          IF (Nop = 0) THEN Node:=Temp;

          Val (DeleteBackSpaces (PointStr),Temp,Nop);
          IF (Nop = 0) THEN Point:=Temp;

          Domain:=DeleteBackSpaces (DomainStr);
     END;

     FieldPopAll;
     WindowPop; { adres edit scherm }
END;


{--------------------------------------------------------------------------}
{ AreYouSure(WithHelp)                                                     }
{                                                                          }
{ Deze routine zet een vraag op het scherm waar met Yes of No op           }
{ geantwoord moet worden, Escape werkt niet.
{                                                                          }
FUNCTION AreYouSureWithHelp (Title : STRING; Handle : HelpHandleType) : KeyType;

VAR X : BYTE;

BEGIN
     X:=40-(Length (Title) DIV 2);
     MenuDefine (X,10,Title);
     MenuSetHelp (Handle);
     MenuAddItem ('Yes');
     MenuAddItem ('No');
     MenuShow;

     REPEAT
     UNTIL (MenuSelect IN [mOpt01,mOpt02,kEsc]);

     MenuErase;

     AreYouSureWithHelp:=Key;
END;

FUNCTION AreYouSure (Title : STRING) : KeyType;
BEGIN
     AreYouSure:=AreYouSureWithHelp (Title,0);
END;


{---------------------------------------------------------------------------}
{ PeekMem                                                                   }
{                                                                           }
{ Deze routine drukt de hoeveelheid vrij geheugen af in de linker bovenhoek }
{ van het scherm.                                                           }
{                                                                           }
PROCEDURE PeekMem;
{$IFDEF DebugMemUsage}
TYPE HeapRecPtr = ^HeapRec;
     HeapRec = RECORD
                     NextPtr : HeapRecPtr;
                     N : LONGINT;
               END;

VAR Frags : WORD;
    HPtr  : HeapRecPtr;
{$ENDIF}
BEGIN
     {$IFDEF DebugMemUsage}
     Frags:=0;
     HPtr:=FreeList;
     WHILE (HPtr <> HeapPtr) DO
     BEGIN
          Inc (Frags);
          HPtr:=HPtr^.NextPtr;
     END;
     {$ENDIF}

     IF (_MemAvail < LowestMemReached) THEN
        LowestMemReached:=_MemAvail;

     {$IFDEF DebugMemUsage}
     IF (OldVideoMode <> 0) THEN
        WriteXY (60,2,' '+Longint2String (LowestMemReached)+' '+Longint2String (_MemAvail)+' '+Word2String (Frags)+' ');
     {$ENDIF}
END;


{--------------------------------------------------------------------------}
{ DumpMem                                                                  }
{                                                                          }
{ Deze routine schrijft de geheugen blokken naar disk.                     }
{                                                                          }
PROCEDURE DumpMem;

TYPE HeapRecPtr = ^HeapRec;
     HeapRec = RECORD
                     NextPtr : HeapRecPtr;
                     M,N     : WORD;
               END;

VAR First : LONGINT;
    Last  : LONGINT;
    HPtr  : HeapRecPtr;

    PROCEDURE LogUnfreedBlock;

    TYPE ByteArray = ARRAY[1..20] OF BYTE;

    VAR EOB  : LONGINT;
        Len  : LONGINT;
        Lp   : BYTE;
        Help : STRING[80];
        DPtr : ^ByteArray;

    BEGIN
         { calculate memory address before start of this block }
         EOB:=Ptr2Long (HPtr)-First-1;

         { the length of the not returned block is from the   }
         { first byte after the previous block (Last) until   }
         { the byte before the first of this new block (EOB). }
         Len:=EOB-Last+1;

         LogExtraMessage ('Not returned: +$'+Long2HexString (Last)+
                          '..+$'+Long2HexString (EOB)+
                          ' ('+Longint2String (Len)+')');

         DPtr:=Long2Ptr (First+Last);

         Help:='';

         IF (Len > 16) THEN
            Len:=16;

         FOR Lp:=1 TO Len DO
             Help:=Help+' '+Byte2HexString (DPtr^[Lp]);

         LogExtraMessage ('$'+Long2HexString (Ptr2Long (DPtr)-First)+':'+Help);
    END;

VAR Frags : WORD;

BEGIN
{$IFDEF PLATFORM_DOS_NOT_DPMI}
     {
     GetMem (HPtr,16);
     LogMessage ('GetMem (16) returns '+Ptr2HexString (HPtr));
     GetMem (HPtr,16);
     LogMessage ('GetMem (16) returns '+Ptr2HexString (HPtr));
     }

     {
     LogExtraMessage ('_MemAvail = '+Longint2String (_MemAvail));
     LogExtraMessage ('_MaxAvail = '+Longint2String (_MaxAvail));
     }

     First:=Ptr2Long (HeapOrg);

     {
     LogExtraMessage ('HeapEnd = '+Long2HexString (Ptr2Long (HeapEnd)));
     }

     Last:=0;

     HPtr:=FreeList;

     IF (HPtr <> HeapPtr) THEN
     BEGIN
          LogMessage (liDebug,'Memory dump:');
          LogExtraMessage ('HeapOrg = '+Long2HexString (Ptr2Long (HeapOrg)));
          LogExtraMessage ('HeapPtr = '+Long2HexString (Ptr2Long (HeapPtr))+
                           ' (+$'+Long2HexString (Ptr2Long (HeapPtr)-First)+')');
     END;

     WHILE (HPtr <> HeapPtr) DO
     BEGIN
          IF (HPtr <> HeapOrg) THEN
             LogUnfreedBlock;

          Last:=Ptr2Long (HPtr)-First+(HPtr^.N*16+HPtr^.M);

          LogExtraMessage ('Free block at +$'+Long2HexString (Ptr2Long (HPtr)-First)+
                           '..+$'+Long2HexString (Ptr2Long (HPtr)-First+(HPtr^.N*16+HPtr^.M)-1));

          HPtr:=HPtr^.NextPtr;
     END;

     IF (Last <> 0) AND (Ptr2Long (HPtr) <> Last) THEN
        LogUnfreedBlock;

     LogClose;
{$ENDIF}
END;


{$IFDEF DoPeekFiles}
 {$IFNDEF WtrGate}
 {$UNDEF DoPeekFiles}
 {$ENDIF}

 {$IFDEF PLATFORM_DPMI}
 {$UNDEF DoPeekFiles}
 {$ENDIF}

 {$IFDEF PLATFORM_OS2_WIN32}
 {$UNDEF DoPeekFiles}
 {$ENDIF}
{$ENDIF}

{$IFDEF DoPeekFiles}
FUNCTION GetOpenFilesCount (VAR TabSize : BYTE) : BYTE;

TYPE TabArrayPtr = ^TabArray;
     TabArray = ARRAY[1..256] OF BYTE;

VAR TabPtr    : TabArrayPtr;
    OpenCount,
    FreeCount,
    Lp        : BYTE;

BEGIN
     TabSize:=Mem[PrefixSeg:$32];
     TabPtr:=TabArrayPtr (MemL[PrefixSeg:$34]);

     OpenCount:=0;

     FOR Lp:=1 TO TabSize DO
     BEGIN
          {
          IF (TabPtr^[Lp] = 255) THEN
             Inc (FreeCount)
          ELSE
              Inc (OpenCount);
          }
          IF (TabPtr^[Lp] <> 255) THEN
             Inc (OpenCount);
     END;

     GetOpenFilesCount:=OpenCount;
END;
{$ENDIF}

{---------------------------------------------------------------------------}
{ PeekFiles                                                                 }
{                                                                           }
{ Deze routine bepaald hoeveel files er open zijn en hoeveel nog vrij en    }
{ zet dat in de linker bovenhoek van het scherm.                            }
{                                                                           }
PROCEDURE PeekFiles;
{$IFDEF DoPeekFiles}

VAR TabSize : BYTE;

BEGIN
     { alleen schrijven als de desktop open is }
     IF (DesktopCopyright = 'WSD') THEN
        SneakWrite (40,1,'O:'+Byte2String (GetOpenFilesCount (TabSize))+'/'+Byte2String (TabSize)+' ');
{$ELSE}
BEGIN
{$ENDIF}
END;


{--------------------------------------------------------------------------}
{ AtoI                                                                     }
{                                                                          }
{ Converteerd een string naar integer, totaan het teken dat geen numeriek  }
{ getal meer is. De functie geeft ook de lengte (in tekens) van het getal  }
{ terug.                                                                   }
{                                                                          }
FUNCTION AtoI (Invoer : STRING; VAR Uitvoer : WORD) : BYTE;

VAR LocalStr : STRING;
    Lp       : INTEGER;
    Nop      : ValNop;

BEGIN
     LocalStr:='';
     FOR Lp:=1 TO Length (Invoer) DO
         IF (Invoer[Lp] IN ['0'..'9']) THEN
            LocalStr:=LocalStr+Invoer[Lp]
         ELSE
             Break;

     Val (LocalStr,Uitvoer,Nop);
     AtoI:=Length (LocalStr);
END;


{---------------------------------------------------------------------------}
{ CopyFromFile                                                              }
{                                                                           }
{ Copieerd een stuk van een bestand naar het einde van het doelbestand.     }
{ De routine gaat ervanuit dat zowel bron als doel bestand open zijn.       }
{                                                                           }
FUNCTION CopyFromFile (VAR Source,Dest : FILE; StartPos, NumBytes : LONGINT) : BOOLEAN;

TYPE MemBlock = ARRAY[1..65000] OF BYTE;

VAR Block   : ^MemBlock;
    ToDo    : LONGINT;
    IORes   : WORD;
    BufSize : WORD;

BEGIN
     CopyFromFile:=TRUE;

     { Alloceer een 16Kb geheugen blok , toch wel het minimum om te kunnen }
     { opereren.                                                           }

     IF (_MaxAvail < 65000) THEN
        BufSize:=_MaxAvail
     ELSE
         BufSize:=65000;

     GetMem (Block,BufSize);
     PeekMem;

     WHILE (NumBytes > 0) DO
     BEGIN
          {$I-}
          Seek (Source,StartPos);
          IF (NumBytes > BufSize) THEN
          BEGIN
               BlockRead (Source,Block^,BufSize);
               BlockWrite (Dest,Block^,BufSize);
               Dec (NumBytes,BufSize);
          END ELSE
          BEGIN
               BlockRead (Source,Block^,NumBytes);
               BlockWrite (Dest,Block^,NumBytes);
               NumBytes:=0;
          END;

          {$I+}
          IORes:=IOResult;
          IF (IORes > 0) THEN
          BEGIN
               LogDiskIoError (IORes,'Fatal error copying file blocks');
               Break;
          END;
     END; { while }

     { Geef het geheugen blok weer terug }
     FreeMem (Block,BufSize);
END;


{---------------------------------------------------------------------------}
{ ReplaceExtension                                                          }
{                                                                           }
{ Deze functie vervangt de extensie van de opgegeven naam en geeft deze     }
{ weer volledig terug. De nieuwe extensie moet een punt bevatten.           }
{                                                                           }
FUNCTION ReplaceExtension (Source : STRING; NewExt : STRING) : STRING;

VAR Dir  : DirStr;
    Name : NameStr;
    Ext  : ExtStr;

BEGIN
     FSplit (Source,Dir,Name,Ext);
     ReplaceExtension:=Dir+Name+NewExt;
END;


{--------------------------------------------------------------------------}
{ RenameSerial                                                             }
{                                                                          }
{ Probeer eerst een file te renamen, vervolgens naar .xx0 , dan naar .xx1  }
{ etc. Als er een .xx9 file bestaat, wordt er niet gerenamed. Dan komt     }
{ ie vanzelf in de log.                                                    }
{                                                                          }
FUNCTION RenameSerial (Source : STRING; VAR Destination : STRING): BOOLEAN;

VAR SFile : FILE;
    IORes : BYTE;
    Lp    : Byte;
    LpStr : STRING[2];

BEGIN
     RenameSerial:=FALSE;

     { Probeer eerst of we de file gewoon kunnen renamen }
     Assign (SFile,Source);
     {$I-} Rename (SFile,Destination); {$I+} IORes:=IOResult;
     IF (IORes = 0) THEN
     BEGIN
          RenameSerial:=TRUE;
          Exit;
     END;

     FOR Lp:=0 TO 99 DO
     BEGIN
          LpStr:=Byte2String (Lp);

          Delete (Destination,1,Length (LpStr));
          Destination:=Destination+LpStr;

          {$I-} Rename (SFile,Destination); {$I+} IORes:=IOResult;
          IF (IORes = 0) THEN
          BEGIN
               RenameSerial:=TRUE;
               Exit;
          END;
     END; { for }
END;


{---------------------------------------------------------------------------}
{ GetUniqueFilename                                                         }
{                                                                           }
{ This routine checks the names of all the files in the given directory and }
{ creates a unique new filename. The filename is the next highest number,   }
{ if possible. Only numbers are used in the filename. The complete path to  }
{ the new filename is returned (dir + filename).                            }
{                                                                           }
FUNCTION GetUniqueFilename (Directory,Extension : STRING) : STRING;

VAR Nop    : ValNop;
    Search : SearchRec;
    Nr     : LONGINT;
    HighNr : LONGINT;
    Name   : STRING;
    TestF  : FILE;
    IORes  : BYTE;
    P      : BYTE;

BEGIN
     Directory:=CorrectPath (Directory);

     {## directory must exist!}

     HighNr:=0;

     FindFirst (Directory+'*'+Extension,$3F,Search);
     WHILE (DosError = 0) DO
     BEGIN
          P:=Pos (Extension,Search.Name);

          IF (P = 0{no extension}) THEN
             P:=Pos ('.',Search.Name);

          IF (P = 0{no dot either}) THEN
             P:=Length (Search.Name)+1;

          Val (Copy (Search.Name,1,P-1),Nr,Nop);
          IF (Nop = 0) THEN
             IF (Nr > HighNr) THEN
                HighNr:=Nr;

          FindNext (Search);
     END; { while }

     FindClose (Search);

     { we can now create a file with HighNr+1 as the filename. If a file }
     { with that name already exists (example 00000000 follows FFFFFFF)  }
     { then we increase the number until we find one that is not in use  }
     { yet.                                                              }

     Nr:=HighNr+1;

     WHILE (Nr <> HighNr) DO
     BEGIN
          Name:=Directory+AddUpWithPre0s (8,Longint2String (Nr))+Extension;
          Inc (Nr);

          Assign (TestF,Name);
          {$I-} Reset (TestF,1); {$I+} IORes:=IOResult;

          IF (IORes = 3) THEN
          BEGIN
               LogMessage (liFatal,'Failed to create unique filename: directory does not exist!');
               LogExtraMessage (Name);
               Break; { from the while - will return this path anyway }
          END;

          IF (IORes = 2) THEN
             Break; { from the while - found a valid name }

          IF (IORes = 0) THEN
             Close (TestF);

     END; { while }

     GetUniqueFilename:=Name;
END;


{---------------------------------------------------------------------------}
{ Micro2Longint                                                             }
{                                                                           }
{ Converteert een microsoft 32bit floating point getal naar een longint,    }
{ deze routine werkt alleen voor GEHELE getallen.                           }
{                                                                           }
{ Deze hele routine werkt zonder floating point getallen om de overhead     }
{ zo klein mogenlijk te houden.                                             }
{                                                                           }
{ De PC-Board was zeker eerst in basic geschreven? Het formaat voor deze    }
{ floats werd alleen door IBM basic ondersteund....                         }
{                                                                           }
FUNCTION Micro2Longint (Invoer : LONGINT) : LONGINT;

VAR Mantisse,
    Tmp_Mant,
    Res      : LONGINT;
    Exp      : BYTE;
    Tel      : BYTE;

LABEL Found_1;

BEGIN
     IF (Invoer = 0) THEN                         { Volgens Tanenbaum is 0 }
     BEGIN                                        { een speciaal geval (!) }
          Micro2Longint := 0;
          Exit;
     END;

     Res:=0;
     Exp:=0;
     Tel:=0;

     { Verbeter een reken fout omdat pascal met signed longints werkt }
     { Aagll.. ik stuur de halve wereld een kopie.. is ie buggie      }
{$IFNDEF FPC}
     ASM
        XOR CH,CH
        MOV CL,BYTE PTR Invoer + 3;   { Exponent := (Invoer SHR 24) - $81 }
        SUB CL,$81
        MOV Exp,CL

        XOR DX,DX
        MOV AX,$01                    { Res := 1 SHL Exponent          }
        CMP CL,$00                    { Kijk of er wel een exponent is    }
        JZ  @@10                        { Geen exponent ?                   }
        DEC BYTE PTR Exp              { Exponent := Exponent - 1         }

        CMP CL,15
       JG  @@1
        SHL AX,CL
        JMP @@10
       @@1:
        SUB CL,16
        INC DX
        SHL DX,CL

        @@10:

         MOV WORD PTR Res  , AX
         MOV WORD PTR Res+2, DX

        XOR AH,AH
        MOV BYTE PTR Invoer + 3,AH;  { Invoer   := Invoer AND ($7FFFFF) }
        MOV AX,WORD PTR Invoer       { Mantisse := Invoer               }
        MOV WORD PTR Mantisse, AX
        MOV AX,WORD PTR Invoer + 2
        MOV WORD PTR Mantisse+2,AX

        MOV BL,1                     { Teller = 0                       }

       @@11:

        CMP Exp,$00                  { Exponent = 0 ?                   }
        JL  @@12                       { Dan naar einde lus               }

        MOV AX,WORD PTR Invoer       { Mantisse := Invoer               }
        MOV WORD PTR Mantisse, AX
        MOV AX,WORD PTR Invoer + 2
        MOV WORD PTR Mantisse+2,AX

        MOV AX,$01                   { 1 SHL (22 - Tel)                 }
        XOR DX,DX
        MOV CL,23
        SUB CL,BL

        CMP CL,15
        JG  @@2
        SHL AX,CL
        JMP @@20
       @@2:
        INC DX
        SUB CL,16
        SHL DX,CL

       @@20:
        AND WORD PTR Mantisse+2 , DX
        JNZ @@30
        AND WORD PTR Mantisse   , AX
        JNZ @@30

        DEC BYTE PTR Exp           { Exponent := Exponent - 1           }
        INC BL                     { Tel      := Tel + 1                }

        JMP @@11

       @@30:

        MOV AX,$01                 { Res := Res + 1 SHL Exponent  }
        XOR DX,DX
        XOR CH,CH
        MOV CL,Exp
        CMP CL,0
        JZ  @@21;

        @@25:

         SHL AX,1                     { DX:AX is een 32 bits longint      }
         ROL DX,1                     { Rotate with Carry                 }
         SHL DX,1

         LOOP @@25;

        @@21:

        ADD WORD PTR Res     , AX
        ADC WORD PTR Res + 2 , DX

        DEC BYTE PTR Exp           { Exponent := Exponent - 1           }
        INC BL                     { Tel      := Tel + 1                }

        JMP @@11

        @@12:
     END;
{$ELSE}
(*


 Dec( Exp );
 Tel := 0;
 WHILE (Exp>0) DO
  BEGIN
  IF (Mantisse AND (1 SHL (22 - Tel)))>0 THEN
   Res := Res + (1 SHL Exp);
  Dec(Exp);
  Inc(Tel);
  END; 
*)
{$ENDIF}
     Micro2Longint:=Res;
END;


{--------------------------------------------------------------------------}
{ Longint2Micro                                                            }
{                                                                          }
{ Converteert een longint getal naar een microsoft 32 bit floating point   }
{ Ook hier geldt dat het alleen werkt voor POSITIEVE GEHELE getallen.      }
{                                                                          }
FUNCTION Longint2Micro (Invoer : LONGINT) : LONGINT;

VAR Res     : LONGINT;
    Exponent,
    Tel,
    Start   : BYTE;

BEGIN
     IF (Invoer = 0) THEN                        { 0 is een speciaal geval }
     BEGIN
          Longint2Micro:=0;
          Exit;
     END;

     Tel:=0;
     Res:=0;
     Start:=31;

     { Zoek de grootste 2 macht }
     WHILE (Start > 0) DO
     BEGIN
          IF (Invoer AND (longint (1) SHL Start)) > 0 THEN
             Break;
          Dec (Start);
     END;

{$IFNDEF FPC}
     Exponent:=Start;
     ASM
        MOV AX,1
        XOR DX,DX
        MOV CL,Exponent
        CMP CL, 15
        JG @@1
        SHL AX,CL
        JMP @@2
       @@1:
        SUB CL,16
        INC DX
        SHL DX,CL
       @@2:
       SUB WORD PTR Invoer   , AX
       SBB WORD PTR Invoer+2 , DX
     END;

     {Invoer:=Longint ( Invoer - Longint( 1 SHL Exponent ) );}
     Dec (Start);

     { Zorgt dat de mantisse met zinnige informatie gevuld wordt }
     WHILE (Invoer > 0) DO
     BEGIN
          IF (Invoer-(Longint (1) SHL Start)) >= 0 THEN
          BEGIN
               Invoer:=Invoer-Longint((Longint (1) SHL Start));
               Res:=Res+(Longint (1) SHL (22-Tel));
          END;

          Inc (Tel);
          Dec (Start);
     END; { while }

     Longint2Micro:=Res OR (Longint ((Exponent+$81)) SHL 24);
{$ENDIF}
END;


{---------------------------------------------------------------------------}
{ DeleteCTFBS                                                               }
{                                                                           }
{ Deze routine haalt commentaar uit de regel (beginnend met een puntkomma), }
{ vertaalt tabs naar spaties en verwijderd de spaties aan het begin en het  }
{ einde van de regel. De rest komt terug.                                   }
{                                                                           }
FUNCTION DeleteCTFBS (Tekst : STRING) : STRING;

VAR P : BYTE;

BEGIN
     P:=Pos (';',Tekst);
     IF (P > 0) THEN
        Tekst:=Copy (Tekst,1,P-1);

     DeleteCTFBS:=DeleteFrontAndBackSpaces (CleanTabs (Tekst,1));
END;


{--------------------------------------------------------------------------}
{ CalcAllowedMem                                                           }
{                                                                          }
{ Deze routine berekent hoeveel geheugen voor een buffer aangevraagd mag   }
{ worden zonder dat het systeem in de problemen komt. We zorgen dat er     }
{ altijd MINFREE (=20000) bytes vrijblijven na het aanvragen. Er mag dus   }
{ MaxAvail-MINFREE aangevraagd worden. Als dat niet gaat, dan nemen we het }
{ maximum beschikbare.                                                     }
{ Er kan ook een AtLeast opgegeven worden. Als zoveel bytes niet           }
{ beschikbaar kunnen worden gemaakt, dan wordt FALSE terug gegeven.        }
{ Merk op dat MSGS_LOMEM_GOSWAP op 15000 staat.                            }
{                                                                          }
FUNCTION CalcMaxAllowedMem (VAR Allowed : WORD; AtLeast,AtMost : WORD) : BOOLEAN;

{ 20k is swappen, dan altijd nog 8000 nodig voor een export }
{ buffer en dat kan nu dus nog.                             }

CONST MINMEMFREE = 10000;       { voor CalcMaxAllowedMem }

VAR MaxAllowed : LONGINT;

BEGIN
     { Make sure there is always 20k free in small blocks, so check }
     { with MemAvail.                                               }
     MaxAllowed:=_MemAvail-MINMEMFREE;

     { if there is not enough memory, then abort at once }
     IF (MaxAllowed < 0) THEN
     BEGIN
          LogMessage (liGeneral,'WARNING: Free memory below critical limit in CalcMaxAllowedMem !!');
          CalcMaxAllowedMem:=FALSE; { niet gelukt }
          Exit;
     END;

     { the possible block can of course not be bigger than MaxAvail }
     IF (MaxAllowed > _MaxAvail) THEN
        MaxAllowed:=_MaxAvail;

     { give em what they want }
     Allowed:=AtMost;

     { unless there is not enough space }
     IF (Allowed > MaxAllowed) THEN
        Allowed:=MaxAllowed;

     { return if succesful (hopefully, in most cases) }
     CalcMaxAllowedMem:=(Allowed >= AtLeast);
END;


{$IFNDEF OS2}
PROCEDURE FindClose (VAR Search : SearchRec);
BEGIN
END;
{$ENDIF}


{$IFDEF LogFileIO}
{--------------------------------------------------------------------------}
{ PostOpen                                                                 }
{                                                                          }
{ This routine is called after Reset and ReWrite of either a FILE or TEXT. }
{                                                                          }
PROCEDURE PostOpenF (VAR F : FILE);
BEGIN
     WITH FileRec (F) DO
          LogMessage (liDebug,'OpenF: Handle '+Word2String (Handle)+
                      {', Mode '+Byte2String (Mode)+}
                      ': '+StrPas (Name));
END;


PROCEDURE PostOpenT (VAR F : TEXT);
BEGIN
     WITH TextRec (F) DO
          LogMessage (liDebug,'OpenT: Handle '+Word2String (Handle)+
                      {', Mode '+Byte2String (Mode)+}
                      ': '+StrPas (Name));
END;


{--------------------------------------------------------------------------}
{ PreClose                                                                 }
{                                                                          }
{ This routine is called just before a Close for a FILE or TEXT.           }
{                                                                          }
PROCEDURE PreCloseF (VAR F : FILE);
BEGIN
     WITH FileRec (F) DO
          LogMessage (liDebug,'CloseF: Handle '+Word2String (Handle)+
                      {', Mode '+Word2HexString (Mode)+}
                      ': '+StrPas (Name));
END;


PROCEDURE PreCloseT (VAR F : TEXT);
BEGIN
     WITH TextRec (F) DO
          LogMessage (liDebug,'CloseT: Handle '+Word2String (Handle)+
                      {', Mode '+Word2HexString (Mode)+}
                      ': '+StrPas (Name));
END;
{$ENDIF}


{--------------------------------------------------------------------------}
{ unit initialization                                                      }
{                                                                          }
BEGIN
     FileMode:=fmReadWrite+fmDenyNone;
     LowestMemReached:=_MemAvail;
     regKeyNumber:=$FFFF;

     TempPath:=GetEnv('TEMP');
     IF (TempPath = '') THEN
        TempPath:=GetEnv('TMP');
     TempPath:=CorrectPath (TempPath);
{$ENDIF (!Upgrade)}
END.
