excmagic.pas

一个异常处理的类

{$ENDIF}
{$IFDEF EXCMAGIC_DEMO}
  ExcMagicVersion = 'Demo freeware ver ' + ExcMagicVerNum + ' (' + ExcMagicType + ')';
{$ELSE}
  ExcMagicVersion = 'Full registered ver ' + ExcMagicVerNum + ' (' + ExcMagicType + ')';
{$ENDIF}

const
  FB09_SIGNATURE = $39304246; // 'FB09' - Delphi  TDS
  FB0A_SIGNATURE = $41304246; // 'FB0A' - Builder TDS
  DSI1_SIGNATURE = $31495344; // 'DSI1'

const
  SST_MODULE      = $120;
  SST_ALIGNSYM    = $125;
  SST_SRCMODULE   = $127;
  SST_NAMES       = $130;
  SST_GLOBALTYPES = $12B;

  SST_PREFIXNAMES = $F000 + SST_NAMES;
  SST_PROCARRAY   = $F000 + SST_ALIGNSYM; // new in 1.51

const
  ALIGN_SEARCH    = 5;       // must be 1st chunk
  ALIGN_END       = 6;
  ALIGN_LPROC     = $204;
  ALIGN_GPROC     = $205;
  ALIGN_DIM_LPROC = $F000 + ALIGN_LPROC;
  ALIGN_DIM_GPROC = $F000 + ALIGN_GPROC;

type
  TLongJump = packed record
    OpCode: Byte;
    Offset: DWORD;
  end;

  TDSIHeader = packed record
    Signature    : Longint; // = DSI1_SIGNATURE
    HeaderSize   : Longint; // = SizeOf(TDSIHeader)
    PackedSize   : Longint;
    OriginalSize : Longint;
  end;
  PTDSIHeader = ^TDSIHeader;

  TDSITail = packed record
    Signature    : Longint; // = DSI1_SIGNATURE
    TotalSize    : Longint; // Header + Data + Tail
  end;
  PTDSITail = ^TDSITail;

  PExcFrame = ^TExcFrame;
  TExcFrame =
  record
    next: PExcFrame;
    desc: Pointer;
    hEBP: Pointer;
  end;

var
  ErrorMessageAddr,ShowErrorAddr,ExceptionHandlerAddr: Pointer;
  HandleAnyExceptAddr,HandleAutoExceptAddr,HandleOnExceptAddr: Pointer;

  OldBytesMessage,OldBytesShow: array[0..4] of Byte;
  OldBytesHandleAny:  array[0..10] of Byte;
  OldBytesHandleOn:   array[0..10] of Byte;
  OldBytesHandleAuto: array[0..10] of Byte;
  OldBytesExcHandler: array[0..10] of Byte;
  NewBytesHandleAny:  array[0..10] of Byte = ( $E8, 0, 0, 0, 0,
                                               $66, $F7, $40, $04, $06, $00 );
  NewBytesHandleOn:   array[0..10] of Byte = ( $E8, 0, 0, 0, 0,
                                               $66, $F7, $40, $04, $06, $00 );
  NewBytesHandleAuto: array[0..10] of Byte = ( $E8, 0, 0, 0, 0,
                                               $66, $F7, $40, $04, $06, $00 );
  NewBytesExcHandler: array[0..10] of Byte = ( $E8, 0, 0, 0, 0,
                                               $66, $F7, $40, $04, $06, $00 );
  NewBytesMessage,NewBytesShow: TLongJump;

{$IFDEF EXCMAGIC_GUI}
var
  AppShowExceptionAddr: Pointer;
  OldBytesAppShow: array[0..4] of Byte;
  NewBytesAppShow: TLongJump;
{$ENDIF}

type
  PsstModuleHeader = ^TsstModuleHeader;
  TsstModuleHeader = packed record // 1Ch bytes
    OvlNum    : Word;
    LibIndex  : Word;
    SegCount  : SmallInt;
    DebugStyle: Word;
    NameIndex : Dword;
    TimeStamp : Dword;
    res       : array[0..2] of Dword;
  end;

  PsstModuleSegInfo = ^TsstModuleSegInfo;
  TsstModuleSegInfo = packed record // 0Ch bytes
    SegNumber : Word;
    Flags     : Word; // 0001 = CODE else DATA ???
    Start     : LongWord;
    Size      : LongWord;
  end;

  PsstAlignProc32 = ^TsstAlignProc32;
  TsstAlignProc32 = packed record
    dwReserved1:  LongWord;
    dwParentEnd:  LongWord;
    dwParentNext: LongWord;
    dwLength:     LongWord;
    dwDebugStart: LongWord;
    dwDebugEnd:   LongWord;
    dwStart:      LongWord;
    wSegNumber:   Word;
    wReserved2:   Word;
    dwTypeNumber: LongWord;
    dwNameIndex:  LongWord;
    dwBrowserOfs: LongWord;
    // optional ShortString (linker name)
  end;

  PsstAlignDimusProc32 = ^TsstAlignDimusProc32;
  TsstAlignDimusProc32 = packed record
    dwStart:     LongWord;
    dwEnd:       LongWord;
    dwNameIndex: LongWord;
  end;

// ---------------------------------------------------------------------------

threadvar
  _ExcContext  : TContext;
  _ExcRecord   : TExceptionRecord;
  _ExcMsgInfo  : TExceptionMessageInfo;

var
  ExcMagicLock: TRTLCriticalSection;

procedure SwitchMagicHandler( TurnON: Boolean ); forward;

// ---------------------------------------------------------------------------

function GetModuleName(Module: HMODULE): string;
var
  ModName: array[0..MAX_PATH] of Char;
begin
  SetString(Result, ModName, Windows.GetModuleFileName(Module, ModName, SizeOf(ModName)));
end;

// ---------------------------------------------------------------------------

//
//  Inst = instance of module (= starting virtual address)
//
constructor TModuleDebugInfo.Create( const FileName: String; const Inst: THandle );
begin
  inherited Create;

  FName      := FileName;
  FInstance  := Inst;
  FLoaded    := False;
  // setup pointers to MZ & PE EXE headers
  FPDosHdr   := Pointer( Inst );
  FPImgHdr   := Pointer( Longint(FPDosHdr) + FPDosHdr^._lfanew );

{$IFDEF EXCMAGIC_DEBUG}
  with FPImgHdr^.OptionalHeader do
    begin
      DebugFmt( 'Creating TModuleDebugInfo for %s'#13#10 +
                'Instance %Xh, Base of code: %Xh, Size of code: %Xh',
                [FileName,Inst,BaseOfCode,SizeOfCode] );
    end;
{$ENDIF}

  LoadDebugInfo( FileName );
end;

destructor  TModuleDebugInfo.Destroy;
begin
  UnLoadDebugInfo;
  inherited Destroy;
end;

function TModuleDebugInfo.IsInCode( Address: Pointer ): Boolean;
var
  Info: TMemoryBasicInformation;
begin
{ // this code doesn't work in packed EXEs !!!
  with FPImgHdr^.OptionalHeader do
    Result := (Longword(Address) >= (FInstance + BaseOfCode)) and
              (Longword(Address) <  (FInstance + BaseOfCode + SizeOfCode));
  // so we use less accurate method :-(
  PAGE_EXECUTE and PAGE_EXECUTE_READ and PAGE_EXECUTE_READWRITE and PAGE_EXECUTE_WRITECOPY
}
  Result := False;
  if VirtualQuery(Address, Info, sizeof(Info)) = sizeof(Info) then
    Result := (Info.AllocationBase = Pointer(FInstance)) and
              (Info.State = MEM_COMMIT);
end;

function TModuleDebugInfo.GetLogicalAddr( Address: Pointer ): Pointer;
begin
{
  hard-coded $1000 instead of more correct FPImgHdr^.OptionalHeader.BaseOfCode
  because there are problems with corrupted header in packed EXEs
  BTW Inprise linkers always set code base = $1000 :)
}
  if Address <> nil then Result := Pointer(Longword(Address)-$1000)
                    else Result := nil;
end;

function TModuleDebugInfo.GetConvertedAddress( Address: Pointer ): Pointer;
var
  Info: TMemoryBasicInformation;
begin
  VirtualQuery(Address, Info, sizeof(Info));
  if Info.State <> MEM_COMMIT then
    Result := GetLogicalAddr(Address)
  else
    Result := GetLogicalAddr( Pointer(Integer(Address)-Integer(Info.AllocationBase)) );
end;

procedure TModuleDebugInfo.GetModuleName( Address: Pointer; ModuleName: PChar; ModuleNameSize: Integer );
var
  Info: TMemoryBasicInformation;
  Temp: array[0..MAX_PATH] of Char;
begin
  VirtualQuery(Address, Info, sizeof(Info));
  if (Info.State <> MEM_COMMIT) or (GetModuleFilename(THandle(Info.AllocationBase), Temp, SizeOf(Temp)) = 0) then
    GetModuleFileName(HInstance, Temp, SizeOf(Temp));

  StrLCopy(ModuleName, AnsiStrRScan(Temp, '\') + 1, ModuleNameSize - 1);
end;

function TModuleDebugInfo.GetIsDelphi: Boolean;
begin
  Result := FSignature = FB09_SIGNATURE;
end;

function TModuleDebugInfo.CreateNamesArray: Boolean;
var
  i,j: Integer;
  NameLen: Longword;
{$IFDEF EXCMAGIC_DEMO}
  MH: TsstModuleHeader;
  ModuleOfs: Dword;
{$ENDIF}
begin
  Result := False;
  for i := FTDSSubdir.sshRecordCount-1 downto 0 do
    if FTDSEntries^[i].sseType = SST_NAMES then
      begin
        FMMFile.Seek( EntryOffset(i), soFromBeginning );
        FNamesCount := FMMFile.ReadDword;
        GetMem( FNameIndexes, FNamesCount * SizeOf(Dword) );
        for j := 0 to FNamesCount-1 do
          begin
            FNameIndexes^[j] := FMMFile.Position;
            NameLen := Word(FMMFile.ReadByte);
            FMMFile.Seek( NameLen+1, soFromCurrent );
          end;
        Result := True;
        Break;
      end;
{$IFDEF EXCMAGIC_DEMO}
  FsstSrcCount := 0;
  for i := FTDSSubdir.sshRecordCount-1 downto 0 do
    if FsstSrcCount >= MAX_SRCMODULE then Break
    else
      if FTDSEntries^[i].sseType = SST_SRCMODULE then
        begin
          FsstSrcTable[FsstSrcCount] := FTDSEntries^[i];
          Inc(FsstSrcCount);

          // 1. Find sstModule for current sstSrcModule
          for j := 0 to FTDSSubdir.sshRecordCount-1 do
            if (FTDSEntries^[j].sseType = SST_MODULE) and
               (FTDSEntries^[j].sseModIndex = FTDSEntries^[i].sseModIndex) then
              begin
                ModuleOfs := EntryOffset( j );
                FMMFile.Seek( ModuleOfs, soFromBeginning );
                FMMFile.Read( MH, SizeOf(MH) );
              {$IFDEF EXCMAGIC_DEBUG}
                DebugFmt( '  demo module #%d: %s', [FsstSrcCount,Names[MH.NameIndex]] );
              {$ENDIF}
              end;
        end;
{$ENDIF};
end;

{ index = 1..FNamesCount }
function TModuleDebugInfo.GetName( Index: Integer ): String;
begin
  if (Index > 0) and (Index <= FNamesCount) and (FNameIndexes <> nil) then
    begin
      FMMFile.Seek( FNameIndexes^[Index-1], soFromBeginning );
      SetLength( Result, FMMFile.ReadByte );
      FMMFile.Read( Result[1], Length(Result) );
    end
  else
    Result := '';
end;

{ returns offset from start of file, not start of debuginfo }
function  TModuleDebugInfo.EntryOffset( Index: Integer ): Longword;
begin
  Result := 0;
  if (Index >= 0) and (Index < FTDSSubdir.sshRecordCount) then
    Result := FTDSOffset + FTDSEntries^[Index].sseOffset;
end;

function TModuleDebugInfo.FindProc( Address: Pointer; Module: Integer ): Integer;
var
  i: Integer;
  Proc32: TsstAlignProc32;
  DimProc32: TsstAlignDimusProc32;
  PtrDimProc32: PsstAlignDimusProc32;
  StartOfs,CurOffset,ProcCount: Longword;
  wChunkType,wChunkSize: Word;
begin
  Result := -1;

  if not FLoaded then Exit;

  // 1. Find Module with Address
  for i := 0 to FTDSSubdir.sshRecordCount-1 do
    if FTDSEntries^[i].sseModIndex = Module then
      case FTDSEntries^[i].sseType of
        SST_ALIGNSYM:
          begin
            StartOfs := EntryOffset( i );
            FMMFile.Seek( StartOfs, soFromBeginning );
            if FMMFile.ReadDword <> 1 then Continue; // Check sstAlignSym signature

            // Find S_LPROC32 or S_GPROC32 chunk
            CurOffset := 4;
            while CurOffset < FTDSEntries^[i].sseSize do
              begin
                wChunkSize := FMMFile.ReadWord;
                wChunkType := FMMFile.ReadWord;
                case wChunkType of
                  ALIGN_LPROC,
                  ALIGN_GPROC:
                    begin
                      FMMFile.Read( Proc32, SizeOf(Proc32) );
                      if (Longword(Address) >= Proc32.dwStart) and (Longword(Address) < Proc32.dwStart+Proc32.dwLength) then
                        begin
                          Result := Proc32.dwNameIndex;
                          Exit;
                        end;
                    end;
                  ALIGN_DIM_LPROC,
                  ALIGN_DIM_GPROC:
                    begin
                      FMMFile.Read( DimProc32, SizeOf(DimProc32) );
                      if (Longword(Address) >= DimProc32.dwStart) and (Longword(Address) <= DimProc32.dwEnd) then
                        begin
                          Result := DimProc32.dwNameIndex;
                          Exit;
                        end;
                    end
                end;
                Inc( CurOffset, wChunkSize+2 );
                FMMFile.Seek( StartOfs + CurOffset, soFromBeginning );
              end;
          end;
        SST_PROCARRAY: // new in 1.51
          begin
            StartOfs := EntryOffset( i );
            FMMFile.Seek( StartOfs, soFromBeginning );
            ProcCount := FMMFile.ReadDword;

            PtrDimProc32 := FMMFile.MapData( StartOfs+4, FTDSEntries^[i].sseSize-4 );
            while ProcCount > 0 do
              begin
                if (Longword(Address) >= PtrDimProc32^.dwStart) and (Longword(Address) <= PtrDimProc32^.dwEnd) then
                  begin