{$F+}
UNIT Err_Func;

{$I platform.inc}

INTERFACE

FUNCTION Ptr2HexString (P : POINTER) : STRING;

VAR Old_Exit : POINTER;
    InitSP   : WORD;
    TriedLog : BOOLEAN;

IMPLEMENTATION

USES Crt,
     Dos,
     Ramon,
     Globals,
     {$IFDEF PLATFORM_OS2}
     OS2Base,
     {$ENDIF}
     Logs,
     StackChk;

{---------------------------------------------------------------------------}
{ Ptr2HexString                                                             }
{                                                                           }
{ Deze routine drukt de segment en offset waarden van het error adres af.   }
{                                                                           }
FUNCTION Ptr2HexString (P : POINTER) : STRING;
BEGIN
     IF (P = NIL) THEN
        Ptr2HexString:='NIL'
     ELSE
         {$IFDEF PLATFORM_OS2_OR_WIN32}
         Ptr2HexString:=Long2HexString (Longint (P));
         {$ENDIF}

         {$IFDEF PLATFORM_DOS_ALL}
         { RWI 950205: vervangen ivm DPMI errors bij Seg (P^)
         Ptr2HexString:=AddUpWithPre0s (4,Word2HexString (Seg(P^)))+':'+
                        AddUpWithPre0s (4,Word2HexString (Ofs(P^)));
         }
         { RWI 950317: segment en offset volgorde omgedraaid }
         Ptr2HexString:=Word2HexString (Longint (P) SHR 16)+':'+
                        Word2HexString (Longint (P) AND 65535);
         {$ENDIF}
END;


(*
{--------------------------------------------------------------------------}
{ Ext_Error                                                                }
{                                                                          }
{ Deze routine haalt de laatste fout op en geeft een uitgebreide melding   }
{ ervan.                                                                   }
{                                                                          }
PROCEDURE Ext_Error (VAR ex_code,ex_Class,Action,Locus : BYTE);

VAR Regs : Registers;

BEGIN
     Regs.AH:=$59;
     Regs.BX:=00;
     MsDos (Regs);
     Ex_code:=Regs.AX;
     ex_Class:=Regs.BH;
     Action:=Regs.BL;
     Locus:=Regs.CH;
END;
*)

{$IFDEF PLATFORM_OS2}
{ this one was meant to stop Ctrl+Break during the registration }
{ time-out. It didn't work though and a simple CheckBreak=FALSE }
{ solved the problem (see rtl source code, crt.pas: it installs }
{ an exception handler and check for CheckBreak there.          }
FUNCTION OurExceptionHandler (ExcpRep : PExceptionReportRecord;
                              ExcpReg : PExceptionRegistrationRecord;
                              Context : PContextRecord;
                              P       : POINTER) : LONGINT; cdecl;
BEGIN
     OurExceptionHandler:=XCPT_CONTINUE_SEARCH;

     IF (ExcpRep^.ExceptionNum = xcpt_Signal) THEN
     BEGIN
          IF (DosAcknowledgeSignalException (xcpt_Signal_Break) = NO_ERROR) THEN
          BEGIN
               GlobalAbort:=TRUE;
               OurExceptionHandler:=XCPT_CONTINUE_EXECUTION;
          END ELSE
              LogMessage (liFatal,'Failed to acknowledge signal');
     END;
END;

PROCEDURE InstallOS2ExceptionHandler;

VAR ERegRec : ExceptionRegistrationRecord;

BEGIN
     FillChar (ERegRec,SizeOf (ERegRec),0);
     ERegRec.ExceptionHandler:=OurExceptionHandler;

     { RAWI 970607: added to prevent exception at program exit }
     ERegRec.Prev_Structure:=End_Of_Chain;

     DosSetExceptionHandler (ERegRec)
END;
{$ENDIF}


{--------------------------------------------------------------------------}
{ Exit_Message                                                             }
{                                                                          }
{$F+}
PROCEDURE Exit_Message; FAR;

{
VAR Dos_Err,
    E,C,A,L  : BYTE;
    Err_S    : STRING[60];
    TPas_Err : STRING[60];
}

{$IFDEF PLATFORM_OS2}
VAR ERegRec : ExceptionRegistrationRecord;
{$ENDIF}

LABEL KeepMsg;

BEGIN
     { als het schrijven naar de log weer een error gaf, dan laten }
     { we de message die nu op het scherm staat staan.             }
     IF TriedLog THEN
        GOTO KeepMsg;

     IF (ErrorAddr = NIL) THEN
     BEGIN
          ExitProc:=Old_Exit;            { Niet reargeren op een HALT() }
          Exit;
     END;

     IF (ConditionRed = 0) THEN
        ConditionRed:=99;

     SetColor (cExitPrg);
     FillVideo (0,0,Video.Cols,Video.Rows,' ');

     {$IFDEF PLATFORM_DOS_ALL}
     IF ChangedVideoMode THEN
        SetVideo (OldVideoMode)
     ELSE
     {$ENDIF}
     BEGIN
          Crt.ClrScr;
          CursorOn;
     END;

     LowVideo;
     Crt.TextAttr:=(Crt.TextAttr AND 15); { no blink, black background }

     {TextMode (3);}

     TextColor (White);
     WriteLn (DesktopProgramName+' v'+FullProgramVersion);
     WriteLn;
     TextColor (LightGray);
     WriteLn ('The program had to abort due to an unresolvable error.');
     WriteLn ('Please write down the information listed below, including');
     WriteLn ('the version number of this program and as much information');
     WriteLn ('as possible of what the program was doing at the time of');
     WriteLn ('the crash, and send this information the authors.');
     WriteLn;

     IF (ErrorAddr <> NIL)
        {$IFDEF PLATFORM_DOS_ALL}AND (Mem[PrefixSeg:5] <> $C3){$ENDIF}
        THEN
     BEGIN
          {Error not previously handled, and not in user-interface Turbo}
          {Reset output to CRT, to give some pretty colours}
          AssignCrt (Output);
          ReWrite (Output);

          {STRONGARM SOME HEAP SPACE, If other error functions need heap
          memory make sure they are activated first, ie: Initialised later
          in the program, CONFUSED? Sorry just take my word for it :-}

          {$IFDEF PLATFORM_DOS_NOT_DPMI}
          Release (HeapOrg);
          {$ENDIF}

          { first find out the Turbo Pascal error name }
          (*
          CASE ExitCode of
               1: TPas_Err:='Invalid DOS function code';
               2: TPas_Err:='File not found';
               3: TPas_Err:='Path not found';
               4: TPas_Err:='Too many open files';
               5: TPas_Err:='File access denied';
               6: TPas_Err:='Invalid file handle';
               8: TPas_Err:='Not enough memory';
              12: TPas_Err:='Invalid file access code';
              15: TPas_Err:='Invalid drive number';
              16: TPas_Err:='Cannot remove current directory';
              17: TPas_Err:='Cannot rename across drives';
             100: TPas_Err:='Disk read error';
             101: TPas_Err:='Disk write error';
             102: TPas_Err:='File not assigned';
             103: TPas_Err:='File not open';
             104: TPas_Err:='File not open for input';
             105: TPas_Err:='File not open for output';
             106: TPas_Err:='Invalid numeric format';
             150: TPas_Err:='Disk is write-protected';
             151: TPas_Err:='Unknown unit';
             152: TPas_Err:='Drive not ready';
             153: TPas_Err:='Unknown command';
             154: TPas_Err:='CRC error in data';
             155: TPas_Err:='Bad Drive request structure length';
             156: TPas_Err:='Disk seek error';
             157: TPas_Err:='Unknown media type';
             158: TPas_Err:='Sector not found';
             159: TPas_Err:='Printer out of Paper';
             160: TPas_Err:='Device write fault';
             161: TPas_Err:='Device read fault';
             162: TPas_Err:='Hardware failure';
             200: TPas_Err:='Division by zero';
             201: TPas_Err:='Range check error';
             202: TPas_Err:='Stack overflow error';
             203: TPas_Err:='Heap overflow error';
             204: TPas_Err:='Invalid pointer operation';
             205: TPas_Err:='Floating point overflow';
             206: TPas_Err:='Floating point underflow';
             207: TPas_Err:='Invalid floating point operation';
             208: TPas_Err:='Overlay manager not installed';
             209: TPas_Err:='Overlay file read error';
             ELSE TPas_Err:='Unknown Error code';
          END;
          *)

          {Put out the standard Turbo Run-Time Error message}
          Textcolor (Yellow);
          WriteLn ('Error: '+Integer2String (ExitCode)+'@'+Ptr2HexString (ErrorAddr));

          {Find the extended error code}
          (*
          Ext_Error (e,C,A,L);
          Dos_Err:=DosError;

          IF (Dos_Err <> 0) THEN
          BEGIN
               Textcolor (LightCyan);
               WriteLn ('DOS Extended error report shows:');

               CASE E OF
                    1 : Err_S:='Invalid function number';
                    2 : Err_S:='File not found';
                    3 : Err_S:='Path not found';
                    4 : Err_S:='Too many open files (no handles left)';
                    5 : Err_S:='Access denied (file was opened Read Only)';
                    6 : Err_S:='Invalid handle';
                    7 : Err_S:='Memory control blocks destroyed';
                    8 : Err_S:='Insufficient memory';
                    9 : Err_S:='Invalid memory block address';
                   10 : Err_S:='Invalid environment';
                   11 : Err_S:='Invalid format';
                   12 : Err_S:='Invalid access code';
                   13 : Err_S:='Invalid data';
                   15 : Err_S:='Invalid drive was specified';
                   16 : Err_S:='Attempt to remove current directory';
                   17 : Err_S:='Not same device';
                   18 : Err_S:='No more files';
                   19 : Err_S:='Attempt to write on write-protected diskette';
                   20 : Err_S:='Unknown unit';
                   21 : Err_S:='Drive not ready';
                   22 : Err_S:='Unknown command';
                   23 : Err_S:='Data error (CRC)';
                   24 : Err_S:='Bad request structure length';
                   25 : Err_S:='Seek error';
                   26 : Err_S:='Unknown media type';
                   27 : Err_S:='Sector not found';
                   28 : Err_S:='Printer out of paper';
                   29 : Err_S:='Write fault';
                   30 : Err_S:='Read fault';
                   31 : Err_S:='General failure';
                   32 : Err_S:='Sharing violation';
                   33 : Err_S:='Lock violation';
                   34 : Err_S:='Invalid disk change';
                   35 : Err_S:='FCB unavailable';
                   36 : Err_S:='Sharing buffer overflow';
                   50 : Err_S:='Network request not supported';
                   51 : Err_S:='Remote computer not listening';
                   52 : Err_S:='Duplicate name on network';
                   53 : Err_S:='Network name not found';
                   54 : Err_S:='Network busy';
                   55 : Err_S:='Network device no longer exists';
                   56 : Err_S:='Net BIOS command limit exceeded';
                   57 : Err_S:='Network adapter hardware error';
                   58 : Err_S:='Incorrect response from network';
                   59 : Err_S:='Unexpected network error';
                   60 : Err_S:='Incompatible remote adapter';
                   61 : Err_S:='Print queue full';
                   62 : Err_S:='Not enough space for print file';
                   63 : Err_S:='Print file was deleted';
                   65 : Err_S:='Access denied';
                   66 : Err_S:='Network device type incorrect';
                   67 : Err_S:='Network name not found';
                   68 : Err_S:='Network name limit exceeded';
                   69 : Err_S:='Net BIOS session limit exceeded';
                   70 : Err_S:='Temporarily paused';
                   71 : Err_S:='Network request not accepted';
                   72 : Err_S:='Print or disk redirection is paused';
                   80 : Err_S:='File exists';
                   82 : Err_S:='Cannot make directory entry';
                   83 : Err_S:='Fail on INT 24';
                   84 : Err_S:='Too many redirections';
                   85 : Err_S:='Duplicate redirection';
                   86 : Err_S:='Invalid password';
                   87 : Err_S:='Invalid parameter';
                   88 : Err_S:='Network device fault';
               END;
               WriteLn ('Extended Error Code:',Err_S);

               CASE C OF
                    1 : Err_S:='Out of resource';
                    2 : Err_S:='Temporary situation';
                    3 : Err_S:='Permission problem';
                    4 : Err_S:='Internal error in system software';
                    5 : Err_S:='Hardware failure';
                    6 : Err_S:='Serious failure of system software';
                    7 : Err_S:='Application program error';
                    8 : Err_S:='File/item not found';
                    9 : Err_S:='File/item of invalid format or type';
                   10 : Err_S:='File/item interlocked';
                   11 : Err_S:='Media failure: wrong disk, CRC error...';
                   12 : Err_S:='Collision with existing item';
                   13 : Err_S:='Classification doesn''t exist or is inappropriate';
               END;
               WriteLn ('Error Class        :',Err_S);

               CASE L OF
                    1 : Err_S:='Unknown or inappropriate';
                    2 : Err_S:='Related to disk storage';
                    3 : Err_S:='Related to the network';
                    4 : Err_S:='Serial device';
                    5 : Err_S:='Memory';
               END;
               WriteLn ('Error Locus        :',Err_S);

               WriteLn;
          END;
          *)

          { we will now try to write the same error to the logfile }
          { and then close the logfile. If that action generates a }
          { new error, then we don't want to show that one, so we  }
          { set this boolean.                                      }
          TriedLog:=TRUE;

          ScreenToo:=FALSE;
          LogMessage (liFatal,'!CRASHED! Report this code: '+
                      Integer2String (ExitCode)+'@'+
                      Ptr2HexString (ErrorAddr)+' ['+
                      Word2String (StackChk_FindUnused)+']'+
                      ' ('+FullProgramVersion+')');
          LogClose;

          WriteLn;
          WriteLn ('This error information has been written to the logfile.');

KeepMsg:
          {Show All Error Data}
          {Stop remaining handlers from reporting error}
          ExitProc:=Old_Exit;            { Niet reargeren op een HALT() }
          ErrorAddr:=NIL;
          TextColor (LightGray);
          WriteLn;
          WriteLn;
     END;
END;
{$F-}

BEGIN
     {Save initial stack pointer}
     InitSP:=SPtr+4;
     Old_Exit:=ExitProc;
     Exitproc:=@Exit_Message;
     TriedLog:=FALSE;

     {$IFDEF PLATFORM_OS2}
     {InstallOS2ExceptionHandler;}
     {$ENDIF}
END.

