Power-Programmierung/CD1.mdf/magazine/drdobbs/1988/02/porter/porter.ls1

Text File | 1979-12-31 | 6KB | 194 lines

Unit criterr;

 { Critical error handler, Turbo Pascal Release 4.0 }

Interface
Uses dos, crt;

{ EXTERNALLY VISIBLE PORTION }

   { The following are for saving and restoring the screen,     }
   { which is assumed to be in text mode and display page 0     }

Const bell = #7;

Type scrnPtr = ^scrnBuffer;
     scrnBuffer = array [1..4096] of byte;

Var  display, saveNode  : scrnPtr;             { display buffer }

   { The following are global variables available to the using  }
   { program to find out if an error occurred and, if so, what  }
   { it was. The program can then take appropriate action.      }

     criticalErrorOccurred : boolean;
     criticalErrorCode     : integer;
     criticalErrorDrive    : integer;
     criticalActionCode    : char;

   { The only externally visible routine installs the critical  }
   { error handler in Int 24h, replacing the DOS default.       }

Procedure InstallCEH;
Implementation
{ ------------------------------------------------------------- }

   { Following is a general-purpose critical error handler }

{$F+}
Procedure CEHandler (
       Flags, CS, IP, AX, BX, CX, DX, SI, DI, DS, ES, BP : word);
Interrupt;

Var  AH, AL    : byte;
     row, col  : integer;
     action    : char;
{ --------------------------- }
  { Local functions }

  { giveReason lists reason for critical error by decoding the  }
  { low byte of the DI register. Called by procs DiskError and  }
  { CharDeviceError. Writes to screen.                          }

  Procedure GiveReason (error : byte);
  Begin
    Case error of
      $00: Writeln ('Write protect');
      $01: Writeln ('Unknown unit');
      $02: Writeln ('Drive not ready');
      $03: Writeln ('Unknown command');
      $04: Writeln ('CRC data error');
      $05: Writeln ('Bad request structure length');
      $06: Writeln ('Seek error');
      $07: Writeln ('Unknown media type');
      $08: Writeln ('Sector not found');
      $0A: Writeln ('Write fault');
      $0B: Writeln ('Read fault');
      $0C: Writeln ('General failure');
      $0D: Writeln ('Bad file allocation table');
      else Writeln ('Unknown');
    End;
  End;
{ --------------------------- }

  { DiskError is dispatched when H/O bit of AH is 0 }

  Function DiskError : word;

  Var   area, why : byte;

  Begin
    Writeln;
    CriticalErrorDrive := AL;
    Writeln ('Disk error on drive ', char (AL + 65));
    Area := (AH and 6) shr 1;                 { get AH bits 1-2 }
    Case area of
      0: Writeln ('Error in DOS communications area');
      2: Writeln ('Error in disk directory');
      3: Writeln ('Error in files area');
    End;
    Why := lo (DI);
    Write ('Type of error: ');
    GiveReason (why);
    DiskError := why;                       { error return code }
  End;
{ --------------------------- }

  { NonDiskError is dispatched when H/O bit of AH is 1. }
  { Usually triggered by a printer problem or bad FAT.  }

  Function NonDiskError : word;

  Var  why         : byte;
       deviceAttr  : ^word;
       deviceName  : ^char;
       ch          : shortInt;

  Begin
    DeviceAttr := ptr (BP, SI+4);   { point to device attr word }
    If (deviceAttr^ and $8000) <> 0 then    { if bit 15 is on.. }
      Begin
        Writeln ('Character device error');
        Write ('Failing device is ');
        ch := 0;
        Repeat
          deviceName := ptr (BP, SI + $0A + ch);
          Write (deviceName^);
          inc (ch);
        Until (deviceName^ = chr (0)) or (ch > 7);
        Writeln;
      End
    Else                                       { assume bad FAT }
      Begin
        Writeln ('Disk error has occurred');
        Write   ('Probable cause: ');
        Why := $0D;
        GiveReason (why);
      End;
    NonDiskError := why;                    { return error code }
  End;
{ --------------------------- }

Begin   { Body of CEHandler procedure }
  CriticalErrorOccurred := TRUE;              { set global flag }
  AH := hi (AX);
  AL := lo (AX);
  Col := whereX;                  { get current cursor position }
  Row := whereY;
  New (saveNode);
  SaveNode^ := display^;                { and save screen image }
  Write (bell);                            { beep to alert user }
  If (AH and $80) = 0 then                    { if AH bit 7 = 0 }
    CriticalErrorCode := DiskError
  Else
    CriticalErrorCode := NonDiskError;
  Repeat                { what are we gonna do about the error? }
    Write ('Abort/Retry/Ignore? ');
    Action := upCase (readKey);
    Writeln (action);
  Until action in ['A', 'I', 'R'];
  CriticalActionCode := action;
  If action = 'I' then begin  { pretend the error didn't happen }
    CriticalErrorOccurred := FALSE;
    CriticalErrorCode     := 0;
    CriticalErrorDrive    := $FF;
    CriticalActionCode    := ' ';
  End;
  Display^ := saveNode^;                 { restore screen image }
  Dispose (saveNode);
  Gotoxy (col, row);                  { restore cursor position }
  AX := 0;                       { tell DOS to ignore the error }
End;
{$F-}
{ ------------------------------------------------------------- }

   { Externally visible: installs the error handler.            }
   { NOTE: Program termination automatically reinstalls the     }
   { default handler in the vector table.                       }

Procedure InstallCEH;

Var   videoMode : byte absolute $0040 : $0049;

Begin
  SetIntVec ($24, @CEHandler);             { install in int 24h }
  CriticalErrorOccurred := FALSE;                 { set globals }
  CriticalErrorCode     := 0;
  CriticalErrorDrive    := $FF;
  CriticalActionCode    := ' ';
  If videoMode = 7 then
    Display := ptr ($B000, $0000)         { set display address }
  Else
    Display := ptr ($B800, $0000);
End;

End.