jclclr.pas

East make Tray Icon in delphi

  TJclClrImageFlag = (cifILOnly, cif32BitRequired, cifStrongNameSinged, cifTrackDebugData);
  TJclClrImageFlags = set of TJclClrImageFlag;

  TJclClrHeaderEx = class(TJclPeClrHeader)
  private
    FMetadata: TJclPeMetadata;
    FFlags: TJclClrImageFlags;
    FStrongNameSignature: TCustomMemoryStream;
    FResources: TObjectList;
    FVTableFixups: TObjectList;
    function GetMetadata: TJclPeMetadata;
    function GetStrongNameSignature: TCustomMemoryStream;
    function GetEntryPointToken: TJclClrTableRow;
    function GetVTableFixup(const Idx: Integer): TJclClrVTableFixupRecord;
    function GetVTableFixupCount: Integer;
    procedure UpdateResources;
    function GetResource(const Idx: Integer): TJclClrResourceRecord;
    function GetResourceCount: Integer;
  public
    constructor Create(const AImage: TJclPeImage);
    destructor Destroy; override;
    function DumpIL: string;
    function HasResources: Boolean;
    function HasStrongNameSignature: Boolean;
    function HasVTableFixup: Boolean;
    function ResourceAt(const Offset: DWORD): TJclClrResourceRecord;
    class function ClrImageFlag(const Flags: DWORD): TJclClrImageFlags; overload;
    class function ClrImageFlag(const Flags: TJclClrImageFlags): DWORD; overload;
    property Metadata: TJclPeMetadata read GetMetadata;
    property Flags: TJclClrImageFlags read FFlags;
    property EntryPointToken: TJclClrTableRow read GetEntryPointToken;
    property StrongNameSignature: TCustomMemoryStream read GetStrongNameSignature;
    property Resources[const Idx: Integer]: TJclClrResourceRecord read GetResource;
    property ResourceCount: Integer read GetResourceCount;
    property VTableFixups[const Idx: Integer]: TJclClrVTableFixupRecord read GetVTableFixup;
    property VTableFixupCount: Integer read GetVTableFixupCount;
  end;

implementation

uses
  Math, TypInfo,
  JclMetadata, JclResources, JclStrings, JclUnicode;

const
  MetadataHeaderSignature = $424A5342; // 'BSJB'

  GUID_NULL: TGUID = '{00000000-0000-0000-0000-000000000000}';

  ValidTableMapping: array [TJclClrTableKind] of TJclClrTableClass = (
    TJclClrTableModule,               //  $00 ttModule
    TJclClrTableTypeRef,              //  $01 ttTypeRef
    TJclClrTableTypeDef,              //  $02 ttTypeDef
    TJclClrTableFieldPtr,             //  $03 ttFieldPtr
    TJclClrTableFieldDef,             //  $04 ttFieldDef
    TJclClrTableMethodPtr,            //  $05 ttMethodPtr
    TJclClrTableMethodDef,            //  $06 ttMethodDef
    TJclClrTableParamPtr,             //  $07 ttParamPtr
    TJclClrTableParamDef,             //  $08 ttParamDef
    TJclClrTableInterfaceImpl,        //  $09 ttInterfaceImpl
    TJclClrTableMemberRef,            //  $0a ttMemberRef
    TJclClrTableConstant,             //  $0b ttConstant
    TJclClrTableCustomAttribute,      //  $0c ttCustomAttribute
    TJclClrTableFieldMarshal,         //  $0d ttFieldMarshal
    TJclClrTableDeclSecurity,         //  $0e ttDeclSecurity
    TJclClrTableClassLayout,          //  $0f ttClassLayout
    TJclClrTableFieldLayout,          //  $10 ttFieldLayout
    TJclClrTableStandAloneSig,        //  $11 ttSignature
    TJclClrTableEventMap,             //  $12 ttEventMap
    TJclClrTableEventPtr,             //  $13 ttEventPtr
    TJclClrTableEventDef,             //  $14 ttEventDef
    TJclClrTablePropertyMap,          //  $15 ttPropertyMap
    TJclClrTablePropertyPtr,          //  $16 ttPropertyPtr
    TJclClrTablePropertyDef,          //  $17 ttPropertyDef
    TJclClrTableMethodSemantics,      //  $18 ttMethodSemantics
    TJclClrTableMethodImpl,           //  $19 ttMethodImpl
    TJclClrTableModuleRef,            //  $1a ttModuleRef
    TJclClrTableTypeSpec,             //  $1b ttTypeSpec
    TJclClrTableImplMap,              //  $1c ttImplMap
    TJclClrTableFieldRVA,             //  $1d ttFieldRVA
    TJclClrTableENCLog,               //  $1e ttENCLog
    TJclClrTableENCMap,               //  $1f ttENCMap
    TJclClrTableAssembly,             //  $20 ttAssembly
    TJclClrTableAssemblyProcessor,    //  $21 ttAssemblyProcessor
    TJclClrTableAssemblyOS,           //  $22 ttAssemblyOS
    TJclClrTableAssemblyRef,          //  $23 ttAssemblyRef
    TJclClrTableAssemblyRefProcessor, //  $24 ttAssemblyRefProcessor
    TJclClrTableAssemblyRefOS,        //  $25 ttAssemblyRefOS
    TJclClrTableFile,                 //  $26 ttFile
    TJclClrTableExportedType,         //  $27 ttExportedType
    TJclClrTableManifestResource,     //  $28 ttManifestResource
    TJclClrTableNestedClass,          //  $29 ttNestedClass
    TJclClrTable,                     //  $2A ttGenericPar
    TJclClrTableMethodSpec);          //  $2B ttMethodSpec

// CLR Header entry point flags.
const
  COMIMAGE_FLAGS_ILONLY           = $00000001;  // Always 1 (see Section 23.1).
  COMIMAGE_FLAGS_32BITREQUIRED    = $00000002;
    // Image may only be loaded into a 32-bit process,
    // for instance if there are 32-bit vtablefixups,
    // or casts from native integers to int32.
    // CLI implementations that have 64 bit native integers shall refuse
    // loading binaries with this flag set.
  COMIMAGE_FLAGS_STRONGNAMESIGNED = $00000008;  // Image has a strong name signature.
  COMIMAGE_FLAGS_TRACKDEBUGDATA   = $00010000;  // Always 0 (see Section 23.1).
  ClrImageFlagMapping: array [TJclClrImageFlag] of DWORD =
    (COMIMAGE_FLAGS_ILONLY, COMIMAGE_FLAGS_32BITREQUIRED,
     COMIMAGE_FLAGS_STRONGNAMESIGNED, COMIMAGE_FLAGS_TRACKDEBUGDATA);

// V-table constants
const
  COR_VTABLE_32BIT             = $01;          // V-table slots are 32-bits in size.
  COR_VTABLE_64BIT             = $02;          // V-table slots are 64-bits in size.
  COR_VTABLE_FROM_UNMANAGED    = $04;          // If set, transition from unmanaged.
  COR_VTABLE_CALL_MOST_DERIVED = $10;          // Call most derived method described by

  ClrVTableKindMapping: array [TJclClrVTableKind] of DWORD =
    (COR_VTABLE_32BIT, COR_VTABLE_64BIT,
     COR_VTABLE_FROM_UNMANAGED, COR_VTABLE_CALL_MOST_DERIVED);

//=== { TJclClrStream } ======================================================

constructor TJclClrStream.Create(const AMetadata: TJclPeMetadata;
  AHeader: PClrStreamHeader);
begin
  inherited Create;
  FMetadata := AMetadata;
  FHeader := AHeader;
end;

function TJclClrStream.GetName: string;
begin
  Result := FHeader.Name;
end;

function TJclClrStream.GetOffset: DWORD;
begin
  Result := Data - Metadata.Image.LoadedImage.MappedAddress;
end;

function TJclClrStream.GetSize: DWORD;
begin
  Result := FHeader.Size;
end;

function TJclClrStream.GetData: Pointer;
begin
  Result := Pointer(DWORD(FMetadata.Header) + FHeader.Offset);
end;

//=== { TJclClrStringsStream } ===============================================

constructor TJclClrStringsStream.Create(const AMetadata: TJclPeMetadata;
  AHeader: PClrStreamHeader);
var
  pch: PChar;
  off: DWORD;
begin
  inherited Create(AMetadata, AHeader);
  FStrings := TStringList.Create;
  pch := Data;
  off := 0;
  while off < Size do
  begin
    if pch^ <> #0 then
      FStrings.AddObject(pch, TObject(off));
    pch := pch + StrLen(pch) + 1;
    off := DWORD(pch - Data);
  end;
end;

destructor TJclClrStringsStream.Destroy;
begin
  FreeAndNil(FStrings);
  inherited Destroy;
end;

function TJclClrStringsStream.GetString(const Idx: Integer): WideString;
begin
  Result := UTF8ToWideString(FStrings.Strings[Idx]);
end;

function TJclClrStringsStream.GetOffset(const Idx: Integer): DWORD;
begin
  Result := DWord(FStrings.Objects[Idx]);
end;

function TJclClrStringsStream.GetStringCount: Integer;
begin
  Result := FStrings.Count;
end;

function TJclClrStringsStream.At(const Offset: DWORD): WideString;
var
  Idx: Integer;
begin
  Idx := FStrings.IndexOfObject(TObject(Offset));
  if Idx <> -1 then
    Result := GetString(Idx)
  else
    Result := '';
end;

//=== { TJclClrGuidStream } ==================================================

constructor TJclClrGuidStream.Create(const AMetadata: TJclPeMetadata;
  AHeader: PClrStreamHeader);
var
  I: Integer;
  pg: PGUID;
begin
  inherited Create(AMetadata, AHeader);
  SetLength(FGuids, Size div SizeOf(TGuid));
  pg := Data;
  for I := 0 to GetGuidCount-1 do
  begin
    FGuids[I] := pg^;
    Inc(pg);
  end;
end;

function TJclClrGuidStream.GetGuid(const Idx: Integer): TGUID;
begin
  Assert((0 <= Idx) and (Idx < GetGuidCount));
  Result := FGuids[Idx];
end;

function TJclClrGuidStream.GetGuidCount: Integer;
begin
  Result := Length(FGuids);
end;

//=== { TJclClrBlobRecord } ==================================================

constructor TJclClrBlobRecord.Create(const AStream: TJclClrStream; APtr: PByteArray);
var
  b: Byte;
  AData: Pointer;
  ASize: DWORD;
begin
  FPtr := APtr;
  FOffset := DWORD(FPtr) - DWORD(AStream.Data);

  b := FPtr[0];
  if b = 0 then
  begin
    AData := @FPtr[1];
    ASize := 0;
  end
  else
  if ((b and $C0) = $C0) and ((b and $20) = 0) then    // 110bs
  begin
    AData := @FPtr[4];
    ASize := ((b and $1F) shl 24) + (FPtr[1] shl 16) + (FPtr[2] shl 8) + FPtr[3];
  end
  else
  if ((b and $80) = $80) and ((b and $40) = 0) then    // 10bs
  begin
    AData := @FPtr[2];
    ASize := ((b and $3F) shl 8) + FPtr[1];
  end
  else
  begin
    AData := @FPtr[1];
    ASize := b and $7F;
  end;
  Assert(not IsBadReadPtr(AData, ASize));
  inherited Create(AData, ASize);
end;

function TJclClrBlobRecord.Dump(Indent: string): string;
const
  BufSize = 16;
var
  I, Len: Integer;

  function DumpBuf(Buf: PChar; Size: Integer; IsHead, IsTail: Boolean): string;
  var
    I: Integer;
    HexStr, AsciiStr: string;
  begin
    for I := 0 to Size-1 do
    begin
      HexStr := HexStr + IntToHex(Integer(Buf[I]), 2) + ' ';
      if CharIsPrintable(Buf[I]) and ((Byte(Buf[I]) and $80) <> $80) then
        AsciiStr := AsciiStr + Buf[I]
      else
        AsciiStr := AsciiStr + '.';
    end;

    if IsTail then
      Result := HexStr + ')' + StrRepeat(' ', (BufSize-Size)*3) + ' // ' + AsciiStr
    else
      Result := HexStr + ' ' + StrRepeat(' ', (BufSize-Size)*3) + ' // ' + AsciiStr;
    if IsHead then
      Result := Indent + '( ' + Result
    else
      Result := StrRepeat(' ', Length(Indent)+2) + Result;
  end;

begin
  with TStringList.Create do
  try
    Len := (Size + BufSize - 1) div BufSize;
    for I := 0 to Len-1 do
      if I = Len - 1 then
        Add(DumpBuf(PChar(Memory) + I * BufSize, Size - I * BufSize, I=0, I=Len-1))
      else
        Add(DumpBuf(PChar(Memory) + I * BufSize, BufSize, I=0, I=Len-1));
    Result := Text;
  finally
    Free;
  end;
end;

function TJclClrBlobRecord.GetData: PByteArray;
begin
  Result := PByteArray(LongInt(Memory) + Position);
end;

//=== { TJclClrBlobStream } ==================================================

constructor TJclClrBlobStream.Create(const AMetadata: TJclPeMetadata;
  AHeader: PClrStreamHeader);
var
  ABlob: TJclClrBlobRecord;
begin
  inherited Create(AMetadata, AHeader);
  FBlobs := TObjectList.Create;
  ABlob := TJclClrBlobRecord.Create(Self, Data);
  while Assigned(ABlob) do
  begin
    if ABlob.Size > 0 then
      FBlobs.Add(ABlob);
    if (Integer(ABlob.Memory) + ABlob.Size) < (Integer(Self.Data) + Integer(Self.Size)) then
      ABlob := TJclClrBlobRecord.Create(Self, Pointer(Integer(ABlob.Memory) + ABlob.Size))
    else
      ABlob := nil;
  end;
end;

destructor TJclClrBlobStream.Destroy;
begin
  FreeAndNil(FBlobs);
  inherited Destroy;
end;

function TJclClrBlobStream.At(const Offset: DWORD): TJclClrBlobRecord;
var
  I: Integer;
begin
  for I := 0 to FBlobs.Count-1 do
  begin
    Result := TJclClrBlobRecord(FBlobs.Items[I]);
    if Result.Offset = Offset then
      Exit;
  end;
  Result := nil;
end;

function TJclClrBlobStream.GetBlob(const Idx: Integer): TJclClrBlobRecord;
begin
  Result := TJclClrBlobRecord(FBlobs.Items[Idx])
end;

function TJclClrBlobStream.GetBlobCount: Integer;
begin
  Result := FBlobs.Count;
end;

//=== { TJclClrUserStringStream } ============================================

function TJclClrUserStringStream.BlobToString(const ABlob: TJclClrBlobRecord): WideString;
begin
  if Assigned(ABlob) then
  begin
    SetLength(Result, ABlob.Size div 2);
    Move(PWideChar(ABlob.Memory)^, PWideChar(Result)^, ABlob.Size and not 1);
  end
  else
    Result := '';
end;

function TJclClrUserStringStream.GetString(const Idx: Integer): WideString;
begin
  Result := BlobToString(Blobs[Idx]);
end;

function TJclClrUserStringStream.GetOffset(const Idx: Integer): DWORD;
begin
  Result := Blobs[Idx].Offset;
end;

function TJclClrUserStringStream.GetStringCount: Integer;
begin
  Result := BlobCount;
end;

function TJclClrUserStringStream.At(const Offset: DWORD): WideString;
begin
  Result := BlobToString(inherited At(Offset));
end;

//=== { TJclClrTableRow } ====================================================

constructor TJclClrTableRow.Create(const ATable: TJclClrTable);
begin
  inherited Create;
  FTable := ATable;
  FIndex := Table.RealRowCount;
end;

function TJclClrTableRow.DecodeResolutionScope(const Encoded: DWORD): TJclClrTableRow;
const
  ResolutionScopeEncoded: array [0..3] of TJclClrTableKind =
    (ttModule, ttModuleRef, ttAssemblyRef, ttTypeRef);
begin
  Result := Table.Stream.Tables[ResolutionScopeEncoded[Encoded and 3]].Rows[Encoded shr 2 - 1];
end;

function TJclClrTableRow.DecodeTypeDefOrRef(const Encoded: DWORD): TJclClrTableRow;
const
  TypeDefOrRefEncoded: array [0..2] of TJclClrTableKind =
    (ttTypeDef, ttTypeRef, ttTypeSpec);
begin
  Result := Table.Stream.Tables[TypeDefOrRefEncoded[Encoded and 3]].Rows[Encoded shr 2 - 1];
end;

function TJclClrTableRow.DumpIL: string;
begin
  // (rom) needs comment why empty
end;

function TJclClrTableRow.GetToken: TJclClrToken;

  function GetTableId: TJclClrTableKind;
  begin
    for Result := Low(TJclClrTableKind) to High(TJclClrTableKind) do
      if ValidTableMapping[Result] = Table.ClassType then
        Exit;
    raise EJclError.CreateResFmt(@RsUnknownTableFmt, [LoadResString(@RsUnknownTable), ClassName]);
  end;