[Back to DOS SWAG index] [Back to Main SWAG index] [Original]

    {$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.

[Back to DOS SWAG index] [Back to Main SWAG index] [Original]