{$I- $F+}
UNIT Errtrp;
INTERFACE

USES
crt,
dos;

CONST
ScrSeg : WORD = $B800;
FGNorm = lightgray;
BGNorm = blue;
FGErr = white;
BGErr = red;

VAR
SaveInt24 : POINTER;
ErrorRetry : BOOLEAN;
IOCode    : INTEGER;
version   : INTEGER;

PROCEDURE DisplayError (ErrNo : INTEGER);
PROCEDURE RuntimeError;
PROCEDURE DisableErrorHandler;
PROCEDURE ErrTrap (ErrNo : INTEGER);


IMPLEMENTATION


VAR
  ExitSave : POINTER;
  regs : REGISTERS;


(**************************************************************************)

CONST
 INT59ERROR  : INTEGER  = 0;
 ERRORACTION : BYTE = 0;
 ERRORTYPE   : BYTE = 0;
 ERRORAREA   : BYTE = 0;
 ERRORRESP   : BYTE = 0;
 ERRORRESULT : INTEGER = 0;

TYPE
errmsg         = ARRAY [0..89] OF STRING;
ermsgPtr       = ^errmsg;

VAR
Errs : ermsgPTR;

PROCEDURE HideCursor; Assembler;
Asm
  MOV   ax, $0100
  MOV   cx, $2607
  INT   $10
END;

PROCEDURE ShowCursor; Assembler;
Asm
  MOV   ax, $0100
  MOV   cx, $0506
  INT   $10
END;


PROCEDURE box;
VAR
 i : INTEGER;
BEGIN
  TEXTCOLOR (FGErr);
  TEXTBACKGROUND (BGErr);
  GOTOXY (1, 1);
  WRITELN ('ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ  Critical Error  ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿');
    FOR i := 1 TO 5 DO
  WRITELN ('³                                                ³');
  WRITE  ('ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ');
END;{box}

FUNCTION DosVer : INTEGER;
VAR
 Maj : shortint;
 Min : shortint;
 regs : REGISTERS;

BEGIN
 regs.ah := $30;
 MSDOS (Regs);
 Maj := regs.al;
 Min := regs.ah;
 DosVer := Maj;
END;

PROCEDURE InitErrs;
BEGIN
NEW (Errs);
Errs^ [0] :=   '             No error occured           ';
Errs^ [1] :=    '          Invalid function number       ';
Errs^ [2] :=    '              File not found            ';
Errs^ [3] :=    '              Path not found            ';
Errs^ [4] :=    '            No handle available         ';
Errs^ [5] :=    '              Access denied             ';
Errs^ [6] :=    '             Invalid handle             ';
Errs^ [7] :=    '     Memory control blocks destroyed    ';
Errs^ [8] :=    '           Insufficient memory          ';
Errs^ [9] :=    '      Invalid memory block address      ';
Errs^ [10] :=    '       Invalid SET command string       ';
Errs^ [11] :=    '             Invalid format             ';
Errs^ [12] :=    '          Invalid access code           ';
Errs^ [13] :=    '              Invalid data              ';
Errs^ [14] :=    '                Reserved                ';
Errs^ [15] :=    '       Invalid drive specification      ';
Errs^ [16] :=    '   Attempt to remove current directory  ';
Errs^ [17] :=    '             Not same device            ';
Errs^ [18] :=    '        No more files to be found       ';
Errs^ [19] :=    '          Disk write protected          ';
Errs^ [20] :=    '            Unknown unit ID             ';
Errs^ [21] :=    '          Disk drive not ready          ';
Errs^ [22] :=    '          Command not defined           ';
Errs^ [23] :=    '            Disk data error             ';
Errs^ [24] :=    '      Bad request structure length      ';
Errs^ [25] :=    '             Disk seek error            ';
Errs^ [26] :=    '         Unknown disk media type        ';
Errs^ [27] :=    '          Disk sector not found         ';
Errs^ [28] :=    '          Printer out of paper          ';
Errs^ [29] :=    '      Write error - Printer Error?      ';
Errs^ [30] :=    '               Read error               ';
Errs^ [31] :=    '            General failure             ';
Errs^ [32] :=    '         File sharing violation         ';
Errs^ [33] :=    '         File locking violation         ';
Errs^ [34] :=    '          Improper disk change          ';
Errs^ [35] :=    '             No FCB available           ';
Errs^ [36] :=    '         Sharing buffer overflow        ';
Errs^ [37] :=    '                Reserved                ';
Errs^ [38] :=    '                Reserved                ';
Errs^ [39] :=    '                Reserved                ';
Errs^ [40] :=    '                Reserved                ';
Errs^ [41] :=    '                Reserved                ';
Errs^ [42] :=    '                Reserved                ';
Errs^ [43] :=    '                Reserved                ';
Errs^ [44] :=    '                Reserved                ';
Errs^ [45] :=    '                Reserved                ';
Errs^ [46] :=    '                Reserved                ';
Errs^ [47] :=    '                Reserved                ';
Errs^ [48] :=    '                Reserved                ';
Errs^ [49] :=    '                Reserved                ';
Errs^ [50] :=    '      Network request not supported     ';
Errs^ [51] :=    '      Remote computer not listening     ';
Errs^ [52] :=    '        Duplicate name on network       ';
Errs^ [53] :=    '         Network name not found         ';
Errs^ [54] :=    '             Network busy               ';
Errs^ [55] :=    '      Network device no longer exists   ';
Errs^ [56] :=    '      NetBIOS command limit exceeded    ';
Errs^ [57] :=    '      Network adapter hardware error    ';
Errs^ [58] :=    '      Incorrect response from network   ';
Errs^ [59] :=    '        Unexpected network error        ';
Errs^ [60] :=    '      Incompatible remote adapter       ';
Errs^ [61] :=    '            Print queue full            ';
Errs^ [62] :=    '      Not enough space for print file   ';
Errs^ [63] :=    '         Print file was deleted         ';
Errs^ [64] :=    '        Network name was deleted        ';
Errs^ [65] :=    '             Access denied              ';
Errs^ [66] :=    '       Network device type incorrect    ';
Errs^ [67] :=    '          Network name not found        ';
Errs^ [68] :=    '        Network name limit exceeded     ';
Errs^ [69] :=    '      NetBIOS session limit exceeded    ';
Errs^ [70] :=    '           Temporarily paused           ';
Errs^ [71] :=    '       Network request not accepted     ';
Errs^ [72] :=    '  Print or disk re-direction is paused  ';
Errs^ [73] :=    '                Reserved                ';
Errs^ [74] :=    '                Reserved                ';
Errs^ [75] :=    '                Reserved                ';
Errs^ [76] :=    '                Reserved                ';
Errs^ [77] :=    '                Reserved                ';
Errs^ [78] :=    '                Reserved                ';
Errs^ [79] :=    '                Reserved                ';
Errs^ [80] :=    '           File already exists          ';
Errs^ [81] :=    '                Reserved                ';
Errs^ [82] :=    '              Cannot make               ';
Errs^ [83] :=    '     Critical-error interrupt failure   ';
Errs^ [84] :=    '          Too many redirections         ';
Errs^ [85] :=    '          Duplicate redirection         ';
Errs^ [86] :=    '           Duplicate password           ';
Errs^ [87] :=    '            Invalid parameter           ';
Errs^ [88] :=    '            Network data fault          ';
Errs^ [89] :=    '             Undefined Error            ';
END;

PROCEDURE CritError (Flags, CS, IP, AX, BX, CX, DX, SI, DI, DS, ES, BP : WORD);
 INTERRUPT;
TYPE
ScrPtr         = ^ScrBuff;
ScrBuff        = ARRAY [1..4096] OF BYTE;

VAR
  Display,
  SaveScr    : ScrPtr;

  c         : CHAR;
  ErrorPrompt,
  msg        : STRING;
  ErrNum     : BYTE;

  drive,
  area,
  al, ah      : BYTE;

  deviceattr : ^WORD;
  devicename : ^CHAR;
  ch,
  i          : shortint;
  actmsg,
  tmsg,
  amsg,
  dname      : STRING;
BEGIN
    ah := HI (ax);
    al := LO (ax);                            { in case DOS version < 3     }
    ErrNum := LO (DI) + 19;                     { save the error and add      }
    msg := Errs^ [ErrNum];                    { add 19 to convert to        }
                                           { standard DOS error          }
    tmsg := '';
    actmsg := '';                            { we can't suggest a response }

 IF (ah AND $80) = 0 THEN                    { if a disk error then        }
   BEGIN                                   { get the drive and area      }
     amsg := ' drive ' + CHR (al + 65) + ':';
     area := (ah AND 6) SHR 1;
     CASE area OF
     0 : amsg := amsg + ' dos communications area ';
     1 : amsg := amsg + ' disk directory area ';
     2 : amsg := amsg + ' files area ';
     END;
   END
ELSE                                       { else if a device error }
   BEGIN                                   { get type of device     }
     deviceattr := PTR (bp, si + 4);
     i := 0;
     IF (deviceattr^ AND $8000) <> 0 THEN     { if a character device }
       BEGIN                                { like a printer        }
         amsg := 'character device';
         ch := 0;
         REPEAT
         i := i + 1;
         devicename := PTR (bp, si + $0a + ch);      { get the device name  }
         dname [i] := devicename^;
         dname [0] := CHR (i);
         INC (ch);
         UNTIL (devicename^ = CHR (0) ) OR (ch > 7);
       END
    ELSE                                     { else }
      BEGIN                                  { just inform of the error }
        dname := 'disk in ' + CHR (al) + ':';
        msg := ' general failure ' ;
        END;
     amsg := amsg + ' ' + dname;
     END;

 INLINE ($FA);                           { Enable interrupts       }
 Display := PTR (ScrSeg, $0000);            { save the current screen }
 NEW (SaveScr);
 SaveScr^ := Display^;
 WINDOW (15, 10, 65, 16);                   { make a box to display the}
 TEXTCOLOR (FGErr);                      { error message            }
 TEXTBACKGROUND (BGErr);
 CLRSCR;
 box;

  IF Version >= 3 THEN                     { check the DOS version   }
  BEGIN                                  { major component         }
  regs.ah := $59;                          { and use DosExtErr since }
  regs.bx := $00;                          { it is available         }
  MSDOS (Regs);
  INT59ERROR := regs.ax;
  ERRORTYPE := regs.bh;
  ERRORACTION := regs.bl;
  ERRORAREA := regs.ch;
  msg := Errs^ [INT59ERROR];                { get the error information}
(*
  case ERRORAREA of
  1: amsg:='Unknown';
  2: amsg:='Block Device';               { usually disk access error}
  3: amsg:='Network Problem';
  4: amsg:='Serial Device';              { printer or COM problem   }
  5: amsg:='Memory';                     { corrupted memory         }
  end;
*)
  CASE ERRORTYPE OF
  1 : tmsg := 'Out of Resource';            { no channels, space       }
  2 : tmsg := 'Temporary situation';        { file locked for instance;}
                                          { not an error and will    }
                                          { clear eventually         }
  3 : tmsg := 'Authorization Violation';     { permission problem e.g.  }
                                          { write to read only file  }
  4 : tmsg := 'Internal Software Error';     { system software bug      }
  5 : tmsg := 'Hardware Error';              { serious trouble -- fix   }
                                          { the machine              }
  6 : tmsg := 'System Error';                { serious trouble software }
                                          { at fault -- e.g. missing }
                                          { CONFIG file              }
  7 : tmsg := 'Program Error';               { inconsistent request     }
                                          { from your program        }
  8 : tmsg := 'Not found';                   { as stated                }
  9 : tmsg := 'Bad Format';                  { as stated                }
  10 : tmsg := 'Locked';                      { interlock situation      }
  11 : tmsg := 'Media Error';                 { CRC error, wrong disk in }
                                          { drive, bad disk cluster  }
  12 : tmsg := 'Exists';                      { collision with existing  }
                                          { item, e.g. duplicate     }
                                          { device name              }
  13 : tmsg := 'Unknown Error';
  END;

  CASE ERRORACTION OF
  1 : actmsg := 'Retry';                     { retry a few times then   }
                                          { give user abort option   }
                                          { if not fixed             }
  2 : actmsg := 'Delay Retry';               { pause, retry, then give  }
                                          { user abort option        }
  3 : actmsg := 'User Action';               { ask user to reenter item }
                                          { e.g. bad drive letter or }
                                          { filename used            }
  4 : actmsg := 'Abort';                      { invoke an orderly shut   }
                                          { down -- close files, etc }
  5 : actmsg := 'Immediate Exit';             { don't clean up, you may  }
                                          { really screw something up}
  6 : actmsg := 'Ignore';
  7 : actmsg := 'Retry';                     { after user intervention: }
  END;                                    { let the user fix it first}

  END;
amsg := tmsg + amsg;
actmsg := 'Suggested Action: ' + actmsg;

GOTOXY ( (54 - LENGTH (msg) ) DIV 2, 3);
WRITE (msg);

GOTOXY ( (54 - LENGTH (amsg) ) DIV 2, 4);
WRITE (amsg);

GOTOXY ( (54 - LENGTH (actmsg) ) DIV 2, 6);
WRITE (actmsg);
                                          { display it              }

ErrorPrompt := ' I)gnore R)etry A)bort F)ail ? ';
GOTOXY ( (54 - LENGTH (ErrorPrompt) ) DIV 2, 5);
WRITE (ErrorPrompt);
REPEAT                                     { get the user response  }
c := READKEY;
c := UPCASE (c);
UNTIL c IN ['A', 'R', 'I', 'F'];
WINDOW (1, 1, 80, 25);                         { restore the screen     }
TEXTCOLOR (FGNorm);
TEXTBACKGROUND (BGNorm);
Display^ := SaveScr^;
DISPOSE (SaveScr);
CASE c OF
  'I' : BEGIN
        AX := 0;
        ERRORRETRY := FALSE;
      END;
  'R' : BEGIN
        AX := 1;
        ERRORRETRY := TRUE;
      END;
  'A' : BEGIN
        Ax := 2;
        ERRORRETRY := FALSE;
        Showcursor;
      END;
  'F' : BEGIN
        Ax := 3;
        ERRORRETRY := FALSE;
        Showcursor;
      END;
END;

END;{procedure CritError}

(**************************************************************************)
PROCEDURE DisplayError (ErrNo : INTEGER);
VAR
msg,
exitmsg : STRING;
BEGIN
    CASE ErrNo OF
    2 : exitmsg := 'File not found';
    3 : exitmsg := 'Path not found';
    4 : exitmsg := 'Too many open files';
    5 : exitmsg := 'Access denied';
    6 : exitmsg := 'Invalid file handle';
    12 : exitmsg := 'Invalid file access code';
    15 : exitmsg := 'Invalid drive';
    16 : exitmsg := 'Cannot remove current directory';
    17 : exitmsg := 'Cannot rename across drives';
    100 : exitmsg := 'Disk read error';
    101 : exitmsg := 'Disk write error - Disk Full ?';
    102 : exitmsg := 'File not assigned';
    103 : exitmsg := 'File not opened';
    104 : exitmsg := 'File not open for input';
    105 : exitmsg := 'File not open for output';
    106 : exitmsg := 'Invalid numeric format';
    150 : exitmsg := 'Disk is write protected';
    151 : exitmsg := 'Unknown unit';
    152 : exitmsg := 'Drive not ready';
    153 : exitmsg := 'Unkown command';
    154 : exitmsg := 'CRC error in data';
    155 : exitmsg := 'Bad drive request structure length';
    156 : exitmsg := 'Disk seek error';
    157 : exitmsg := 'Unknown media type';
    158 : exitmsg := 'Sector not found';
    159 : exitmsg := 'Printer out of paper';
    160 : exitmsg := 'Device write fault';
    161 : exitmsg := 'Device read fault';
    162 : exitmsg := 'Hardware failure';
    200 : exitmsg := 'Division by zero';
    201 : exitmsg := 'Range check error';
    202 : exitmsg := 'Stack overflow';
    203 : exitmsg := 'Heap overflow';
    204 : exitmsg := 'Invalid pointer operation';
    205 : exitmsg := 'Floating point overflow';
    206 : exitmsg := 'Floating point underflow';
    207 : exitmsg := 'Invalid floating point operation'
    ELSE exitmsg := 'Unknown Error # ';
    END;

  msg := exitmsg;

  TEXTCOLOR (FGErr);
  TEXTBACKGROUND (BGErr);
  GOTOXY ( (50 - LENGTH (msg) ) DIV 2, 3);
  WRITE (msg);

END;

PROCEDURE ErrTrap (ErrNo : INTEGER);
TYPE
ScrPtr         = ^ScrBuff;
ScrBuff        = ARRAY [1..4096] OF BYTE;

VAR
  Display,
  SaveScr    : ScrPtr;

  c         : CHAR;
  ErrorPrompt,
  msg : STRING;

BEGIN

 Display := PTR (ScrSeg, $0000);            { save the current screen }
 NEW (SaveScr);
 SaveScr^ := Display^;
 WINDOW (15, 10, 65, 16);                   { make a box to display the}
 TEXTCOLOR (FGErr);                      { error message            }
 TEXTBACKGROUND (BGErr);
 CLRSCR;
 box;

  ErrorRetry := TRUE;
  DisplayError (ErrNo);

                                          { display it              }

ErrorPrompt := ' I)gnore R)etry A)bort F)ail ? ';
GOTOXY ( (54 - LENGTH (ErrorPrompt) ) DIV 2, 5);
WRITE (ErrorPrompt);
REPEAT                                     { get the user response  }
c := READKEY;
c := UPCASE (c);
UNTIL c IN ['A', 'R', 'I', 'F'];
CASE c OF
  'I' : ErrorRetry := FALSE;
  'R' : ErrorRetry := TRUE;
  'A' : BEGIN
        ErrorRetry := FALSE;
        Showcursor;
      END;
  'F' : BEGIN
        ErrorRetry := FALSE;
        Showcursor;
      END;
  END;
  IF ErrorRetry = FALSE THEN
    BEGIN
      GOTOXY (4, 4);
      WRITE ('If you are unable to correct the error');
      GOTOXY (4, 5);
      WRITE ('please report the error ', #40, Errno, #41, ' and      ');
      GOTOXY (4, 6);
      WRITE ('exact circumstances when it occurred to us.');
      WINDOW (1, 1, 80, 25);                         { restore the screen     }
      TEXTCOLOR (FGNorm);
      TEXTBACKGROUND (BGNorm);
      Display^ := SaveScr^;
      DISPOSE (SaveScr);

      ErrorAddr := NIL;
      GOTOXY (1, 1);
      Showcursor;
      HALT;
    END;
WINDOW (1, 1, 80, 25);                         { restore the screen     }
TEXTCOLOR (FGNorm);
TEXTBACKGROUND (BGNorm);
Display^ := SaveScr^;
DISPOSE (SaveScr);
END;

PROCEDURE RuntimeError;

TYPE
ScrPtr         = ^ScrBuff;
ScrBuff        = ARRAY [1..4096] OF BYTE;

VAR
  Display,
  SaveScr    : ScrPtr;

  c         : CHAR;
  ErrorPrompt,
  msg : STRING;

BEGIN
  IF ErrorAddr <> NIL THEN
    BEGIN
      Display := PTR (ScrSeg, $0000);            { save the current screen }
      NEW (SaveScr);
      SaveScr^ := Display^;
      WINDOW (15, 10, 65, 16);                   { make a box to display the}
      TEXTCOLOR (FGErr);                      { error message            }
      TEXTBACKGROUND (BGErr);
      CLRSCR;
      box;
      GOTOXY (15, 1);
      WRITE ('   Fatal  Error   ');
      DisplayError (ExitCode);
      GOTOXY (20, 2);
      WRITE ('Run time error ', ExitCode);
      GOTOXY (4, 4);
      WRITE ('If you are unable to correct the error');
      GOTOXY (4, 5);
      WRITE ('Please report the error and exact');
      GOTOXY (4, 6);
      WRITE ('circumstances when it occurred to us.');
      GOTOXY (4, 7);
      WRITE ( ' Press a key to continue ');
      ErrorAddr := NIL;

      ExitProc := ExitSave;
      c := READKEY;
    END;
  WINDOW (1, 1, 80, 25);                         { restore the screen     }
  TEXTCOLOR (FGNorm);
  TEXTBACKGROUND (BGNorm);
  Display^ := SaveScr^;
  DISPOSE (SaveScr);

  ShowCursor;
  TEXTCOLOR (lightgray);
  TEXTBACKGROUND (black);

  SETINTVEC ($24, SaveInt24);
END;

PROCEDURE DisableErrorHandler;
BEGIN
  SETINTVEC ($24, SaveInt24);
  ExitProc := ExitSave;
END;

(**************************************************************************)
BEGIN
  InitErrs;
  Version := DosVer;
  Hidecursor;
  IF mem [$0000 : $0449] <> 7 THEN ScrSeg := $B800 ELSE ScrSeg := $B000;
  GETINTVEC ($24, SaveInt24);
  SETINTVEC ($24, @CritError);
  ExitSave := ExitProc;
  ExitProc := @RuntimeError;
END.

{ ---------------------   DEMO PROGRAM -------------------------- }

{$I-}  { THIS MUST BE HERE FOR THE ERROR TRAP TO WORK !! }
PROGRAM testerr;
USES dos, crt, printer, errtrp;
VAR
regs : REGISTERS;
fil : FILE;
Pchar : STRING;
BEGIN
CLRSCR;
(*COMMENT OUT THE FUNCTIONS NOT BEING TESTED*)
(*       USING THE CRITICAL ERROR HANDLER PROCEDURE CRITERR  *)

(* remove disc from A: drive to test this *)
(******************************************)

WRITE ('trying to write to drive a: ');

  ASSIGN (fil, 'A:filename.ext');
  REWRITE (fil);

DisableErrorHandler;

(*  USING THE ERRTRAP PROCEDURE *)

WRITE ('trying to write to drive a: using ERRTRAP');
REPEAT
ASSIGN (fil, 'A:filename.ext');
REWRITE (fil);
iocode := IORESULT;
IF IOCode <> 0 THEN ErrTrap (IOCode);
UNTIL ERRORRETRY = FALSE;

END.