{
 ßßßßßßßß  ßßßßßß    ßß   ßß
   ßß     ßß   ßß   ßß  ßß
  ßß     ßß   ßßß  ßßßßß  The DoorKit!
 ßß     ßß   ßß   ßß  ßß
ßß     ßßßßßß    ßß    ßß
The BBS Door Development Kit By The People - For The People!


   Feel free to modify or optimize this code at will. All I ask is that if
   find a better way to do things (and you will), please send me a copy of
   your modifications. Thanks in advance!....Larry L. Athey....}

UNIT _EXIT;

{   This unit will do the following:
    --------------------------------
 1. Installs a new exit procedure. If your program is halted by some sort of
    internal error this will bypass the Pascal exit procedure and display a
    better discription of the error as well as "Error Logging" the error.

 2. Saves and restores the HEAP marker automatically. This means that you
    don't have to use dispose or freemem before your program exits, because
    this will free the entire heap that was used, so you don't have to do a
    thing!

 3. Installs a new memory handler. If you try to allocate a chunk of memory
    to something and there's not enough heap, instead of halting with an
    out of memory error like TP does, this will continue normally with the
    program, but the variable that you tried to assign the memory to will
    have the value NIL. This makes it easier to do error checks when
    allocating memory.                                                         }

INTERFACE

USES DOS;

CONST
  MAX_ExitProcs = 16; {Adjust as needed, up to 256 processes allowed.}

TYPE
  TExitProc = PROCEDURE;
  TProcAry  = ARRAY[1..Max_ExitProcs] OF tExitProc; {Ary=1024 bytes}

FUNCTION AddtoExitChain(Proc : tExitProc) : BOOLEAN;
{^ This adds a procedure to the "Exit Chain". Any procedures in the Exit
   Chain are called when your program ends, automatically...No matter how
   the program gets terminated (Normally, Carrier Drop, HALT(), ^C).

   Proc = Procedure to add. The procedure cannot have any parameters,
          and MUST be compiled FAR.

   The procedures are called in a "LIFO" (Last In First Out) fashion. This
   is so the Comport routines will be the very last thing to DeInit itself.
   For 2 reasons. 1] So you don't have to worry about Calling DeInitComport
   at the end of your program. The DoorKit adds its own procedure to the
   ExitChain to DeInit itself for you (it's always the very first procedure
   in the chain)  2] Since The DoorKit itself is last to be shut down, any
   of your procedures in the Exit Chain can use the comport still, if you
   need / want to (so long as you don't call DeInitComport yourself!)....}

IMPLEMENTATION

TYPE
  String10 = STRING[10];

CONST
  ChainNum : INTEGER = 0;

VAR
  ExitChain     : TProcAry;
  SavedExitProc : POINTER;
  Hp            : POINTER;

CONST
  Hx : ARRAY[0..15] OF CHAR = '0123456789ABCDEF';

{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
FUNCTION AddtoExitChain;
BEGIN
  AddtoExitChain := FALSE;
  IF (ChainNum < MAX_ExitProcs) AND (@Proc <> NIL) THEN BEGIN
    INC(ChainNum);
    ExitChain[ChainNum] := Proc;
    AddtoExitChain := TRUE;
  END;
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
FUNCTION Hex2(B : BYTE) : String10;
BEGIN
  Hex2 := Hx[(B SHR 4) AND 15] + Hx[B AND 15];
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
FUNCTION Hex4(W : WORD) : String10;
BEGIN
  Hex4 := Hex2(HI(W)) + Hex2(LO(W));
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
FUNCTION CustomHeapError(Size : WORD) : INTEGER; Far;
BEGIN
  CustomHeapError := 1;
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
FUNCTION ErrorMessage(ECode : WORD) : STRING;
BEGIN
  CASE ECode OF
      1 : ErrorMessage := 'Invalid function number.';
      2 : ErrorMessage := 'File not found.';
      3 : ErrorMessage := 'Path not found.';
      4 : ErrorMessage := 'Too many open files.';
      5 : ErrorMessage := 'File access denied.';
      6 : ErrorMessage := 'Invalid file handle.';
     12 : ErrorMessage := 'Invalid file access code.';
     15 : ErrorMessage := 'Invalid drive number.';
     16 : ErrorMessage := 'Cannot remove current directory.';
     17 : ErrorMessage := 'Cannot rename across drives.';
     18 : ErrorMessage := 'No more files.';
    100 : ErrorMessage := 'Disk read error.';
    101 : ErrorMessage := 'Disk write error.';
    102 : ErrorMessage := 'File not assigned.';
    103 : ErrorMessage := 'File not open.';
    104 : ErrorMessage := 'File not open for input.';
    105 : ErrorMessage := 'File not open for output.';
    106 : ErrorMessage := 'Invalid numeric format.';
    150 : ErrorMessage := 'Disk is write-protected.';
    151 : ErrorMessage := 'Bad drive request struct length.';
    152 : ErrorMessage := 'Drive not ready.';
    154 : ErrorMessage := 'CRC error in data.';
    156 : ErrorMessage := 'Disk seek error.';
    157 : ErrorMessage := 'Unknown media type.';
    158 : ErrorMessage := 'Sector Not Found.';
    159 : ErrorMessage := 'Printer out of paper.';
    160 : ErrorMessage := 'Device write fault.';
    161 : ErrorMessage := 'Device read fault.';
    162 : ErrorMessage := 'Hardware failure.';
    200 : ErrorMessage := 'Division by zero.';
    201 : ErrorMessage := 'Range check error.';
    202 : ErrorMessage := 'Stack overflow error.';
    203 : ErrorMessage := 'Heap overflow error.';
    204 : ErrorMessage := 'Invalid pointer operation.';
    205 : ErrorMessage := 'Floating point overflow.';
    206 : ErrorMessage := 'Floating point underflow.';
    207 : ErrorMessage := 'Invalid floating point operation.';
    208 : ErrorMessage := 'Overlay manager not installed.';
    209 : ErrorMessage := 'Overlay file read error.';
    210 : ErrorMessage := 'Object not initialized.';
    211 : ErrorMessage := 'Call to abstract method.';
    212 : ErrorMessage := 'Stream registration error.';
    213 : ErrorMessage := 'Collection index out of range.';
    214 : ErrorMessage := 'Collection overflow error.';
    215 : ErrorMessage := 'Arithmetic overflow error.';
    216 : ErrorMessage := 'General Protection fault.';
  END;
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
PROCEDURE CustomExit; Far;
VAR
  I       : INTEGER;
  Txt     : TEXT;
  Msg     : STRING;
  DirInfo : SearchRec;
BEGIN
  IF ErrorAddr <> NIL THEN BEGIN
    Msg := ErrorMessage(ExitCode);
    Asm mov ax,3; INT 10h END;
    ASSIGN(Txt,'ERROR.LOG');
    FINDFIRST('ERROR.LOG',Archive,DirInfo);
    IF DOSERROR <> 0 THEN BEGIN
      REWRITE(Txt);
      CLOSE(Txt);
    END;
    APPEND(Txt);
    WRITELN(Txt,'ž A RunTime Error Has Occured - Program Halted!');
    WRITELN(Txt,'  Address  = ',Hex4(SEG(ErrorAddr^)),':',Hex4(OFS(ErrorAddr^)));
    WRITELN(Txt,'  ExitCode = ',ExitCode);
    WRITELN(Txt,'  Error    = ',Msg);
    WRITELN(Txt);
    CLOSE(Txt);
    RESET(Input);
    ErrorAddr := NIL;
    ExitCode  := 0;
  END;
  FOR I := ChainNum DOWNTO 1 DO IF @ExitChain[I] <> NIL THEN ExitChain[I];
  RELEASE(Hp);
  ExitProc := SavedExitProc;
END;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
BEGIN
  SavedExitProc := ExitProc;
  ExitProc      := @CustomExit;
  HeapError     := @CustomHeapError;
  MARK(Hp);
END.
