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';
0ドルA : msg := 'Environment Scrambled';
0ドルB : msg := 'Bad Program EXE File';
0ドルC : msg := 'Invalid file access mode';
0ドルD : msg := 'Invalid Data';
0ドルE : msg := 'Unknown Unit';
0ドルF : 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';
1ドルA : msg := 'Unknown Media Type';
1ドルB : msg := 'Sector Not Found';
1ドルC : msg := 'Printer Out Of Paper';
1ドルD : msg := 'Disk Write Error';
1ドルE : msg := 'Disk Read Error';
1ドルF : 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';
3ドルA : msg := 'Incorrect Response From NETWORK';
3ドルB : msg := 'Unexpected NETWORK Error';
3ドルC : msg := 'Remote Adapter Incompatible';
3ドルD : msg := 'Print QUEUE FULL';
3ドルE : msg := 'No space For Print File';
3ドルF : 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';
5ドルA : 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.