jcltd32.pas

East make Tray Icon in delphi

            AnalyseAlignSymbols(pSubsection, Size);
          SUBSECTION_TYPE_SOURCE_MODULE:
            AnalyseSourceModules(pSubsection, Size);
          SUBSECTION_TYPE_NAMES:
            AnalyseNames(pSubsection, Size);
        else
          AnalyseUnknownSubSection(pSubsection, Size);
        end;
      end;
    {$IFDEF RANGECHECKS_ON}
    {$RANGECHECKS ON}
    {$ENDIF RANGECHECKS_ON}
    if pDirHeader.lfoNextDir <> 0 then
      pDirHeader := PDirectoryHeader(LfaToVa(pDirHeader.lfoNextDir))
    else
      Break;
  end;
end;

procedure TJclTD32InfoParser.AnalyseNames(const pSubsection: Pointer; const Size: DWORD);
var
  I, Count, Len: Integer;
  pszName: PChar;
begin
  Count := PDWORD(pSubsection)^;
  pszName := PChar(DWORD(pSubsection) + SizeOf(DWORD));
  for I := 0 to Count - 1 do
  begin
    // Get the length of the name
    Len := Ord(pszName^);
    Inc(pszName);
    // Get the name
    FNames.Add(pszName);
    // skip the length of name and a NULL at the end
    Inc(pszName, Len + 1);
  end;
end;

procedure TJclTD32InfoParser.AnalyseAlignSymbols(pSymbols: PSymbolInfos; const Size: DWORD);
var
  Offset: DWORD;
  pInfo: PSymbolInfo;
  Symbol: TJclSymbolInfo;
begin
  Offset := DWORD(@pSymbols.Symbols[0]) - DWORD(pSymbols);
  while Offset < Size do
  begin
    pInfo := PSymbolInfo(DWORD(pSymbols) + Offset);
    case pInfo.SymbolType of
      SYMBOL_TYPE_LPROC32:
        Symbol := TJclLocalProcSymbolInfo.Create(pInfo);
      SYMBOL_TYPE_GPROC32:
        Symbol := TJclGlobalProcSymbolInfo.Create(pInfo);
    else
      Symbol := nil;
    end;
    if Assigned(Symbol) then
      FSymbols.Add(Symbol);
    Inc(Offset, pInfo.Size + SizeOf(pInfo.Size));
  end;
end;

procedure TJclTD32InfoParser.AnalyseModules(pModInfo: PModuleInfo; const Size: DWORD);
begin
  FModules.Add(TJclModuleInfo.Create(pModInfo));
end;

procedure TJclTD32InfoParser.AnalyseSourceModules(pSrcModInfo: PSourceModuleInfo; const Size: DWORD);
var
  I: Integer;
  pSrcFile: PSourceFileEntry;
begin
  {$RANGECHECKS OFF}
  for I := 0 to pSrcModInfo.FileCount - 1 do
  begin
    pSrcFile := PSourceFileEntry(DWORD(pSrcModInfo) + pSrcModInfo.BaseSrcFiles[I]);
    if pSrcFile.NameIndex > 0 then
      FSourceModules.Add(TJclSourceModuleInfo.Create(pSrcFile, DWORD(pSrcModInfo)));
  end;
  {$IFDEF RANGECHECKS_ON}
  {$RANGECHECKS ON}
  {$ENDIF RANGECHECKS_ON}
end;

procedure TJclTD32InfoParser.AnalyseUnknownSubSection(const pSubsection: Pointer; const Size: DWORD);
begin
  // do nothing
end;

function TJclTD32InfoParser.GetModule(const Idx: Integer): TJclModuleInfo;
begin
  Result := TJclModuleInfo(FModules.Items[Idx]);
end;

function TJclTD32InfoParser.GetModuleCount: Integer;
begin
  Result := FModules.Count;
end;

function TJclTD32InfoParser.GetName(const Idx: Integer): string;
begin
  Result := PChar(FNames.Items[Idx]);
end;

function TJclTD32InfoParser.GetNameCount: Integer;
begin
  Result := FNames.Count;
end;

function TJclTD32InfoParser.GetSourceModule(const Idx: Integer): TJclSourceModuleInfo;
begin
  Result := TJclSourceModuleInfo(FSourceModules.Items[Idx]);
end;

function TJclTD32InfoParser.GetSourceModuleCount: Integer;
begin
  Result := FSourceModules.Count;
end;

function TJclTD32InfoParser.GetSymbol(const Idx: Integer): TJclSymbolInfo;
begin
  Result := TJclSymbolInfo(FSymbols.Items[Idx]);
end;

function TJclTD32InfoParser.GetSymbolCount: Integer;
begin
  Result := FSymbols.Count;
end;

function TJclTD32InfoParser.FindModule(const AAddr: DWORD;
  var AMod: TJclModuleInfo): Boolean;
var
  I, J: Integer;
begin
  if ValidData then
    for I := 0 to ModuleCount - 1 do
    with Modules[I] do
      for J := 0 to SegmentCount - 1 do
      begin
        if AAddr >= FSegments[J].Offset then
        begin
          if AAddr - FSegments[J].Offset <= Segment[J].Size then
          begin
            Result := True;
            AMod := Modules[I];
            Exit;
          end;
        end;
      end;
  Result := False;
  AMod := nil;
end;

function TJclTD32InfoParser.FindSourceModule(const AAddr: DWORD;
  var ASrcMod: TJclSourceModuleInfo): Boolean;
var
  I, J: Integer;
begin
  if ValidData then
    for I := 0 to SourceModuleCount - 1 do
    with SourceModules[I] do
      for J := 0 to SegmentCount - 1 do
      with Segment[J] do
        if (StartOffset <= AAddr) and (AAddr < EndOffset) then
        begin
          Result := True;
          ASrcMod := SourceModules[I];
          Exit;
        end;
  Result := False;
  ASrcMod := nil;
end;

function TJclTD32InfoParser.FindProc(const AAddr: DWORD; var AProc: TJclProcSymbolInfo): Boolean;
var
  I: Integer;
begin
  if ValidData then
    for I := 0 to SymbolCount - 1 do
      if Symbols[I].InheritsFrom(TJclProcSymbolInfo) then
      with Symbols[I] as TJclProcSymbolInfo do
        if (Offset <= AAddr) and (AAddr < Offset + Size) then
        begin
          Result := True;
          AProc := TJclProcSymbolInfo(Symbols[I]);
          Exit;
        end;
  Result := False;
  AProc := nil;
end;

class function TJclTD32InfoParser.IsTD32DebugInfoValid(
  const DebugData: Pointer; const DebugDataSize: LongWord): Boolean;
var
  Sign: TJclTD32FileSignature;
  EndOfDebugData: LongWord;
begin
  Assert(not IsBadReadPtr(DebugData, DebugDataSize));
  Result := False;
  EndOfDebugData := LongWord(DebugData) + DebugDataSize;
  if DebugDataSize > SizeOf(Sign) then
  begin
    Sign := PJclTD32FileSignature(EndOfDebugData - SizeOf(Sign))^;
    if IsTD32Sign(Sign) and (Sign.Offset <= DebugDataSize) then
    begin
      Sign := PJclTD32FileSignature(EndOfDebugData - Sign.Offset)^;
      Result := IsTD32Sign(Sign);
    end;
  end;
end;

class function TJclTD32InfoParser.IsTD32Sign(const Sign: TJclTD32FileSignature): Boolean;
begin
  Result := (Sign.Signature = Borland32BitSymbolFileSignatureForDelphi) or
    (Sign.Signature = Borland32BitSymbolFileSignatureForBCB);
end;

function TJclTD32InfoParser.LfaToVa(Lfa: DWORD): Pointer;
begin
  Result := Pointer(DWORD(FBase) + Lfa)
end;

//=== { TJclTD32InfoScanner } ================================================

function TJclTD32InfoScanner.LineNumberFromAddr(AAddr: DWORD): Integer;
var
  Dummy: Integer;
begin
  Result := LineNumberFromAddr(AAddr, Dummy);
end;

function TJclTD32InfoScanner.LineNumberFromAddr(AAddr: DWORD; var Offset: Integer): Integer;
var
  ASrcMod: TJclSourceModuleInfo;
  ALine: TJclLineInfo;
begin
  if FindSourceModule(AAddr, ASrcMod) and ASrcMod.FindLine(AAddr, ALine) then
  begin
    Result := ALine.LineNo;
    Offset := AAddr - ALine.Offset;
  end
  else
  begin
    Result := 0;
    Offset := 0;
  end;
end;

function TJclTD32InfoScanner.ModuleNameFromAddr(AAddr: DWORD): string;
var
  AMod: TJclModuleInfo;
begin
  if FindModule(AAddr, AMod) then
    Result := Names[AMod.NameIndex]
  else
    Result := '';
end;

function TJclTD32InfoScanner.ProcNameFromAddr(AAddr: DWORD): string;
var
  Dummy: Integer;
begin
  Result := ProcNameFromAddr(AAddr, Dummy);
end;

function TJclTD32InfoScanner.ProcNameFromAddr(AAddr: DWORD; var Offset: Integer): string;
var
  AProc: TJclProcSymbolInfo;

  function FormatProcName(const ProcName: string): string;
  var
    pchSecondAt, P: PChar;
  begin
    Result := ProcName;
    if (Length(ProcName) > 0) and (ProcName[1] = '@') then
    begin
      pchSecondAt := StrScan(PChar(Copy(ProcName, 2, Length(ProcName) - 1)), '@');
      if pchSecondAt <> nil then
      begin
        Inc(pchSecondAt);
        Result := pchSecondAt;
        P := PChar(Result);
        while P^ <> #0 do
        begin
          if (pchSecondAt^ = '@') and ((pchSecondAt - 1)^ <> '@') then
            P^ := '.';
          Inc(P);
          Inc(pchSecondAt);
        end;
      end;
    end;
  end;

begin
  if FindProc(AAddr, AProc) then
  begin
    Result := FormatProcName(Names[AProc.NameIndex]);
    Offset := AAddr - AProc.Offset;
  end
  else
  begin
    Result := '';
    Offset := 0;
  end;
end;

function TJclTD32InfoScanner.SourceNameFromAddr(AAddr: DWORD): string;
var
  ASrcMod: TJclSourceModuleInfo;
begin
  if FindSourceModule(AAddr, ASrcMod) then
    Result := Names[ASrcMod.NameIndex];
end;

//=== { TJclPeBorTD32Image } =================================================

procedure TJclPeBorTD32Image.AfterOpen;
begin
  inherited AfterOpen;
  CheckDebugData;
end;

procedure TJclPeBorTD32Image.CheckDebugData;
begin
  FIsTD32DebugPresent := IsDebugInfoInImage(FTD32DebugData);
  if not FIsTD32DebugPresent then
    FIsTD32DebugPresent := IsDebugInfoInTds(FTD32DebugData);
  if FIsTD32DebugPresent then
  begin
    FTD32Scanner := TJclTD32InfoScanner.Create(FTD32DebugData);
    if not FTD32Scanner.ValidData then
    begin
      ClearDebugData;
      if not NoExceptions then
        raise EJclError.CreateResFmt(@RsHasNotTD32Info, [FileName]);
    end;
  end;
end;

procedure TJclPeBorTD32Image.Clear;
begin
  ClearDebugData;
  inherited Clear;
end;

procedure TJclPeBorTD32Image.ClearDebugData;
begin
  FIsTD32DebugPresent := False;
  FreeAndNil(FTD32Scanner);
  FreeAndNil(FTD32DebugData);
end;

function TJclPeBorTD32Image.IsDebugInfoInImage(var DataStream: TCustomMemoryStream): Boolean;
var
  DebugDir: TImageDebugDirectory;
  BugDataStart: Pointer;
  DebugDataSize: Integer;
begin
  Result := False;
  DataStream := nil;
  if IsBorlandImage and (DebugList.Count = 1) then
  begin
    DebugDir := DebugList[0];
    if DebugDir._Type = IMAGE_DEBUG_TYPE_UNKNOWN then
    begin
      BugDataStart := RvaToVa(DebugDir.AddressOfRawData);
      DebugDataSize := DebugDir.SizeOfData;
      Result := TJclTD32InfoParser.IsTD32DebugInfoValid(BugDataStart, DebugDataSize);
      if Result then
        DataStream := TJclReferenceMemoryStream.Create(BugDataStart, DebugDataSize);
    end;
  end;
end;

function TJclPeBorTD32Image.IsDebugInfoInTds(var DataStream: TCustomMemoryStream): Boolean;
var
  TdsFileName: TFileName;
  TempStream: TCustomMemoryStream;
begin
  Result := False;
  DataStream := nil;
  TdsFileName := ChangeFileExt(FileName, TurboDebuggerSymbolExt);
  if FileExists(TdsFileName) then
  begin
    TempStream := TJclFileMappingStream.Create(TdsFileName);
    try
      Result := TJclTD32InfoParser.IsTD32DebugInfoValid(TempStream.Memory, TempStream.Size);
      if Result then
        DataStream := TempStream
      else
        TempStream.Free;
    except
      TempStream.Free;
      raise;
    end;
  end;
end;

// History:

// $Log: JclTD32.pas,v $
// Revision 1.13  2005/03/08 08:33:23  marquardt
// overhaul of exceptions and resourcestrings, minor style cleaning
//
// Revision 1.12  2005/02/25 07:20:16  marquardt
// add section lines
//
// Revision 1.11  2005/02/24 16:34:53  marquardt
// remove divider lines, add section lines (unfinished)
//
// Revision 1.10  2004/10/17 21:00:16  mthoma
// cleaning
//
// Revision 1.9  2004/06/14 13:05:21  marquardt
// style cleaning ENDIF, Tabs
//
// Revision 1.8  2004/05/05 07:33:49  rrossmair
// header updated according to new policy: initial developers & contributors listed
//
// Revision 1.7  2004/04/06 04:55:18  
// adapt compiler conditions, add log entry
//

end.