Contributor: GAYLE DAVIS
{$S-,R-,V-,I-,N-,B-,F-}
{$IFNDEF Ver40}
{Allow overlays}
{$F+,O-,X+,A-}
{$ENDIF}
UNIT CritErr;
INTERFACE
USES DOS;
TYPE
Str10 = STRING[10];
IOErrorRec = Record
RoutineName : PathStr;
ErrorAddr : Str10;
ErrorType : Str10;
TurboResult : Word; { TP Error number }
IOResult : Word; { DOS Extended number }
ErrMsg : PathStr;
End;
{}PROCEDURE IOResultTOErrorMessage (IOCode : WORD; VAR MSG : STRING);
{}PROCEDURE GetDOSErrorMessage (VAR Msg : STRING);
{}FUNCTION UserIOError(ErrNum : INTEGER; VAR IOErr : IOErrorRec) : BOOLEAN;
{}PROCEDURE CriticalErrorDOS;
{}PROCEDURE CriticalErrorTP;
{}PROCEDURE CriticalErrorOwn(ErrAddr: POINTER);
IMPLEMENTATION
VAR
TurboInt24: POINTER; { Holds address of TP's error handler }
function Hex(v: Longint; w: Integer): String;
var
s : String;
i : Integer;
const
hexc : array [0 .. 15] of Char= '0123456789abcdef';
begin
s[0] := Chr(w);
for i := w downto 1 do begin
s[i] := hexc[v and $F];
v := v shr 4
end;
Hex := s;
end {Hex};
PROCEDURE CriticalErrorDOS;
BEGIN
SetIntVec($24,SaveInt24);
END;
PROCEDURE CriticalErrorTP;
BEGIN
SetIntVec($24,TurboInt24);
END;
PROCEDURE CriticalErrorOwn(ErrAddr: POINTER);
BEGIN
SetIntVec($24,ErrAddr);
END;
PROCEDURE GetDOSErrorMessage (VAR Msg : STRING);
TYPE pointerwords =
RECORD
ofspoint, segpoint : WORD;
END;
VAR
breakdown : pointerwords ABSOLUTE erroraddr;
BEGIN
IOResultToErrorMessage (ExitCode, MSG);
WITH breakdown DO
Msg := Msg + ' $' + hex (SegPoint, 4) + ':' + hex (OfsPoint, 4);
END; {Exitprogram}
PROCEDURE IOResultToErrorMessage (IOCode : WORD; VAR MSG : STRING);
BEGIN
CASE IOCode OF
$01 : msg := 'Invalid DOS Function Number';
$02 : msg := 'File not found ';
$03 : msg := 'Path not found ';
$04 : msg := 'Too many open files ';
$05 : msg := 'File access denied ';
$06 : msg := 'Invalid file handle ';
$07 : msg := 'Memory Control Block Destroyed';
$08 : msg := 'Not Enough Memory';
$09 : msg := 'Invalid Memory Block Address';
$0A : msg := 'Environment Scrambled';
$0B : msg := 'Bad Program EXE File';
$0C : msg := 'Invalid file access mode';
$0D : msg := 'Invalid Data';
$0E : msg := 'Unknown Unit';
$0F : msg := 'Invalid drive number ';
$10 : msg := 'Cannot remove current directory';
$11 : msg := 'Cannot rename across drives';
$12 : msg := 'Disk Read/Write Error';
$13 : msg := 'Disk Write-Protected';
$14 : msg := 'Unknown Unit';
$15 : msg := 'Drive Not Ready';
$16 : msg := 'Unknown Command';
$17 : msg := 'Data CRC Error';
$18 : msg := 'Bad Request Structure Length';
$19 : msg := 'Seek Error';
$1A : msg := 'Unknown Media Type';
$1B : msg := 'Sector Not Found';
$1C : msg := 'Printer Out Of Paper';
$1D : msg := 'Disk Write Error';
$1E : msg := 'Disk Read Error';
$1F : msg := 'General Failure';
$20 : msg := 'Sharing Violation';
$21 : msg := 'Lock Violation';
$22 : msg := 'Invalid Disk Change';
$23 : msg := 'File Control Block Gone';
$24 : msg := 'Sharing Buffer Exceeded';
$32 : msg := 'Unsupported Network Request';
$33 : msg := 'Remote Machine Not Listening';
$34 : msg := 'Duplicate Network Name';
$35 : msg := 'Network Name NOT Found';
$36 : msg := 'Network BUSY';
$37 : msg := 'Device No Longer Exists On NETWORK';
$38 : msg := 'NetBIOS Command Limit Exceeded';
$39 : msg := 'Adapter Hardware ERROR';
$3A : msg := 'Incorrect Response From NETWORK';
$3B : msg := 'Unexpected NETWORK Error';
$3C : msg := 'Remote Adapter Incompatible';
$3D : msg := 'Print QUEUE FULL';
$3E : msg := 'No space For Print File';
$3F : msg := 'Print File Cancelled';
$40 : msg := 'Network Name Deleted';
$41 : msg := 'Network Access Denied';
$42 : msg := 'Incorrect Network Device Type';
$43 : msg := 'Network Name Not Found';
$44 : msg := 'Network Name Limit Exceeded';
$45 : msg := 'NetBIOS session limit exceeded';
$46 : msg := 'Filer Sharing temporarily paused';
$47 : msg := 'Network Request Not Accepted';
$48 : msg := 'Print or Disk File Paused';
$50 : msg := 'File Already Exists';
$52 : msg := 'Cannot Make Directory';
$53 : msg := 'Fail On Critical Error';
$54 : msg := 'Too Many Redirections';
$55 : msg := 'Duplicate Redirection';
$56 : msg := 'Invalid Password';
$57 : msg := 'Invalid Parameter';
$58 : msg := 'Network Device Fault';
$59 : msg := 'Function Not Supported By NETWORK';
$5A : msg := 'Required Component NOT Installed';
(* Pascal Errors *)
94 : msg := 'EMS Memory Swap Error';
98 : msg := 'Disk Full';
100 : msg := 'Disk read error ';
101 : msg := 'Disk write error ';
102 : msg := 'File not assigned ';
103 : msg := 'File not open ';
104 : msg := 'File not open for input ';
105 : msg := 'File not open for output ';
106 : msg := 'Invalid numeric format ';
150 : msg := 'Disk is write_protected';
151 : msg := 'Unknown unit';
152 : msg := 'Drive not ready';
153 : msg := 'Unknown command';
154 : msg := 'CRC error in data';
155 : msg := 'Bad drive request structure length';
156 : msg := 'Disk seek error';
157 : msg := 'Unknown media type';
158 : msg := 'Sector not found';
159 : msg := 'Printer out of paper';
160 : msg := 'Device write fault';
161 : msg := 'Device read fault';
162 : msg := 'Hardware Failure';
163 : msg := 'Sharing Confilct';
200 : msg := 'Division by zero ';
201 : msg := 'Range check error ';
202 : msg := 'Stack overflow error ';
203 : msg := 'Heap overflow error ';
204 : msg := 'Invalid pointer operation ';
205 : msg := 'Floating point overflow ';
206 : msg := 'Floating point underflow ';
207 : msg := 'Invalid floating point operation ';
390 : msg := 'Serial Port TIMEOUT';
399 : msg := 'Serial Port NOT Responding';
1008 : Msg := 'EMS Memory Swap Error '
ELSE
GetDosErrorMessage (Msg);
END;
END;
FUNCTION UserIOError(ErrNum : INTEGER; VAR IOErr : IOErrorRec) : BOOLEAN;
{ RETURN ALL INFO ABOUT THE ERROR IF IT OCCURED}
CONST
ErrTitles : ARRAY [1..5] OF STRING [10] =
('System', 'Disk', 'Network', 'Serial', 'Memory');
VAR
Msg : STRING;
Regs : REGISTERS;
BEGIN
UserIOError := FALSE;
FILLCHAR(IOErr,SizeOf(IOErr),#0);
IF ErrNum <=0 THEN EXIT;
{ GET DOS Extended Error }
WITH Regs DO
BEGIN
AH := $59;
BX := $00;
MSDOS (Regs);
END;
IOResultToErrorMessage (Regs.AX, Msg);
IOErr.RoutineName := PARAMSTR (0);
IOErr.ErrorAddr := Hex (SEG (ErrorAddr^), 4) + ':' + Hex (OFS (ErrorAddr^), 4);
IOErr.ErrorType := ErrTitles[Regs.CH];
IOErr.TurboResult := ErrNum;
IOErr.IOResult := Regs.AX;
IOErr.ErrMsg := Msg;
UserIOError := (ErrNum > 0);
END;
BEGIN
GetIntVec($24,TurboInt24);
CriticalErrorDOS;
END.
{ -------------------------- DEMO --------------------- }
{ EXAMPLE FOR CRITICAL ERROR HANDLER UNIT }
{ COMPILE AND RUN FROM DOS !!! WILL NOT WORK PROPERLY FROM THE IDE }
{$I-} { A MUST FOR THE CRITICAL HANDLER TO WORK !!!! }
USES
CRT, CRITERR;
VAR
f: TEXT;
i: INTEGER;
ErrMsg : STRING;
IOErr : IOErrorRec;
BEGIN
ClrScr;
WriteLn(' EXAMPLE PROGRAM FOR CRITICAL ERROR HANDLER ');
WriteLn;
WriteLn('Turbo Pascal replaces the operating system''s critical-error');
WriteLn('handler with its own. For this demonstration we will generate');
WriteLn('a critical error by attempting to access a diskette that is not');
WriteLn('present. Please ensure that no diskette is in drive A, then');
WriteLn('press RETURN...');
ReadLn;
CriticalErrorTP;
Assign(f,'A:NOFILE.$$$');
WriteLn;
WriteLn('Now attempting to access drive...');
Reset(f);
IF UserIOError(IOResult,IOErr) THEN
BEGIN
WriteLn(IOErr.RoutineName);
WriteLn(IOErr.ErrorAddr);
WriteLn(IOErr.ErrorType);
WriteLn(IOErr.TurboResult);
WriteLn(IOErr.IOResult);
WriteLn(IOErr.ErrMsg);
END;
WriteLn;
Write('Press RETURN to continue...');
ReadLn;
WriteLn;
CriticalErrorDOS;
WriteLn('With the DOS error handler restored, you will be presented');
WriteLn('with the usual "Abort, Retry, Ignore?" prompt when such an');
WriteLn('error occurs. (Later DOS versions allow a "Fail" option.)');
WriteLn('Run this program several times and try different responses.');
Write('Press RETURN to continue...');
ReadLn;
WriteLn('Now attempting to access drive again...');
Reset(f);
IF UserIOError(IOResult,IOErr) THEN
BEGIN
WriteLn(IOErr.RoutineName);
WriteLn(IOErr.ErrorAddr);
WriteLn(IOErr.ErrorType);
WriteLn(IOErr.TurboResult);
WriteLn(IOErr.IOResult);
WriteLn(IOErr.ErrMsg);
END;
Readkey;
END.