{
    This file is part of Chentrah,
    Copyright (C) 2004-2010 Anton Rzheshevski (chebmaster@mail.ru).

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see http://www.gnu.org/licenses/

 **********************************************************************

    This unit contains a hack for the Windows Structured Exception Handling
      mechanism allowing to catch AVs and other system exceptions
      in a DLL (typically these just ignore the try...except blocks
      not belonging to the main executable).

    This unit has some definitions borrowed from the System unit (FreePascal RTL)
      since these were defined in the implementation section,
      unavailable to other units.

 **********************************************************************}


unit cl_seh_hack;
interface
uses SysUtils, Classes {$ifdef windows}, Windows {$else} , baseunix, dl {$endif};

  procedure InitSehHack;
  procedure TerminateSehHack;

implementation
  uses cge;

{$ifdef windows}
//Copy-pasted from the System unit (FPC 2.2.4)--------------------------------\
  const
    EXCEPTION_EXECUTE_HANDLER    =  1;
    EXCEPTION_CONTINUE_EXECUTION = -1;
    EXCEPTION_CONTINUE_SEARCH    =  0;
    EXCEPTION_MAXIMUM_PARAMETERS = 15;
    MAXIMUM_SUPPORTED_EXTENSION  = 512;

  type
    PFloatingSaveArea = ^TFloatingSaveArea;
    TFloatingSaveArea = packed record
            ControlWord : Cardinal;
            StatusWord : Cardinal;
            TagWord : Cardinal;
            ErrorOffset : Cardinal;
            ErrorSelector : Cardinal;
            DataOffset : Cardinal;
            DataSelector : Cardinal;
            RegisterArea : array[0..79] of Byte;
            Cr0NpxState : Cardinal;
    end;

    PContext = ^TContext;
    TContext = packed record
        //
        // The flags values within this flag control the contents of
        // a CONTEXT record.
        //
            ContextFlags : Cardinal;

        //
        // This section is specified/returned if CONTEXT_DEBUG_REGISTERS is
        // set in ContextFlags.  Note that CONTEXT_DEBUG_REGISTERS is NOT
        // included in CONTEXT_FULL.
        //
            Dr0, Dr1, Dr2,
            Dr3, Dr6, Dr7 : Cardinal;

        //
        // This section is specified/returned if the
        // ContextFlags word contains the flag CONTEXT_FLOATING_POINT.
        //
            FloatSave : TFloatingSaveArea;

        //
        // This section is specified/returned if the
        // ContextFlags word contains the flag CONTEXT_SEGMENTS.
        //
            SegGs, SegFs,
            SegEs, SegDs : Cardinal;

        //
        // This section is specified/returned if the
        // ContextFlags word contains the flag CONTEXT_INTEGER.
        //
            Edi, Esi, Ebx,
            Edx, Ecx, Eax : Cardinal;

        //
        // This section is specified/returned if the
        // ContextFlags word contains the flag CONTEXT_CONTROL.
        //
            Ebp : Cardinal;
            Eip : Cardinal;
            SegCs : Cardinal;
            EFlags, Esp, SegSs : Cardinal;

        //
        // This section is specified/returned if the ContextFlags word
        // contains the flag CONTEXT_EXTENDED_REGISTERS.
        // The format and contexts are processor specific
        //
            ExtendedRegisters : array[0..MAXIMUM_SUPPORTED_EXTENSION-1] of Byte;
    end;

  type
    PExceptionRecord = ^TExceptionRecord;
    TExceptionRecord = packed record
            ExceptionCode   : cardinal;
            ExceptionFlags  : Longint;
            ExceptionRecord : PExceptionRecord;
            ExceptionAddress : Pointer;
            NumberParameters : Longint;
            ExceptionInformation : array[0..EXCEPTION_MAXIMUM_PARAMETERS-1] of Pointer;
    end;

    PExceptionPointers = ^TExceptionPointers;
    TExceptionPointers = packed record
            ExceptionRecord   : PExceptionRecord;
            ContextRecord     : PContext;
    end;

  { type of functions that should be used for exception handling }
    TTopLevelExceptionFilter
         = function (excep : PExceptionPointers) : Longint;stdcall;

  function SetUnhandledExceptionFilter( lpTopLevelExceptionFilter:
                            TTopLevelExceptionFilter) : TTopLevelExceptionFilter;
        stdcall;external 'kernel32' name 'SetUnhandledExceptionFilter';
//end copy-paste --------------------------------------------------------------/

 var
   OldFilter: TTopLevelExceptionFilter = nil;
{$endif}

  procedure JumpToDllRaiseFunction;
  begin
    {$ifdef windows}
     SysResetFPU;
    {$endif}
    Module.PassUnhandledException;
    raise Exception.Create('Oops... Internal Error! (the module is probably invalid)');
  end;

 {$ifdef windows}
  function GetModuleByAddr(addr: pointer): THandle;
  var
    Tmm: TMemoryBasicInformation;
  begin
    if VirtualQuery(addr, @Tmm, SizeOf(Tmm)) <> sizeof(Tmm)
      then Result:=0
      else Result:= THandle(Tmm.AllocationBase);
  end;

  function MyExceptionFilter(excep : PExceptionPointers) : Longint; stdcall;
  begin
    if not MotherState.Terminated and Assigned(Module) and Assigned(Module.PassUnhandledException) //DLL is loaded
      and (CurrentOwner <> NOT_A_MODULE) //we are really in the process of calling one of the the DLL functions
      (*and (Module.DllHandle = GetModuleByAddr(pointer(excep^.ContextRecord^.Eip))) //exception is in the module DLL*)
      and (MotherState.ExeHandle <> GetModuleByAddr(pointer(excep^.ContextRecord^.Eip))) //this is NOT inside a mother callback function
      and (MotherState.MainThreadId = GetCurrentThreadId) //threads created by the module set up their own exception filters!
    then begin
      //save the bloody details
      MotherState.sehh_ExceptionCode:= excep^.ExceptionRecord^.ExceptionCode;
      MotherState.sehh_ExceptionAddress:= excep^.ContextRecord^.Eip;

      //cheat changing the return address to a function that calls the module to raise its own language exception
      excep^.ContextRecord^.Eip := cardinal(@JumpToDllRaiseFunction);

      //tell Windows: we have corrected the problem, go on.
      excep^.ExceptionRecord^.ExceptionCode := 0;
      Result := EXCEPTION_CONTINUE_EXECUTION;
    end
    else Result:= OldFilter(excep);
  end;
{$endif}

  procedure InitSehHack;
  begin
    MotherState.ExeHandle:= GetModuleByAddr (@InitSehHack);
    {$ifdef windows}
    MotherState.MainThreadId:= GetCurrentThreadId;
    OldFilter:= SetUnhandledExceptionFilter(@MyExceptionFilter);
    {$endif}
  end;

  procedure TerminateSehHack;
  begin
    {$ifdef windows}
     SetUnhandledExceptionFilter(OldFilter);
    {$endif}
  end;

end.
