jclclr.pas

East make Tray Icon in delphi

begin
  Result := Byte(GetTableId) shl 24 + Index + 1;
end;

procedure TJclClrTableRow.Update;
begin
  // do nothing, just for override
end;

//=== {  TJclClrTable } ======================================================

constructor TJclClrTable.Create(const AStream: TJclClrTableStream;
  const Ptr: Pointer; const ARowCount: Integer);
begin
  inherited Create;
  FStream := AStream;
  FData := Ptr;
  FRows  := nil; // Create on demand
  FRowCount := ARowCount;
  Reset;
  Load;
  SetSize(FPtr - FData);
end;

destructor TJclClrTable.Destroy;
begin
  FreeAndNil(FRows);
  inherited Destroy;
end;

procedure TJclClrTable.Reset;
begin
  FPtr := FData;
end;

procedure TJclClrTable.Load;
var
  I: Integer;
begin
  Assert(RowCount > 0);

  if TableRowClass <> TJclClrTableRow then
    for I := 0 to RowCount-1 do
      AddRow(TableRowClass.Create(Self));
end;

procedure TJclClrTable.SetSize(const Value: Integer);
begin
  FSize := Value;
  Assert(not IsBadReadPtr(FData, FSize));
end;

function TJclClrTable.GetOffset: DWORD;
begin
  Result := DWORD(Data) - DWORD(Stream.Metadata.Image.LoadedImage.MappedAddress);
end;

function TJclClrTable.GetRow(const Idx: Integer): TJclClrTableRow;
begin
  Result := TJclClrTableRow(FRows.Items[Idx]);
end;

function TJclClrTable.GetRowCount: Integer;
begin
  Result := FRowCount;
end;

function TJclClrTable.AddRow(const ARow: TJclClrTableRow): Integer;
begin
  if not Assigned(FRows) then
    FRows := TObjectList.Create;
  Result := FRows.Add(ARow);
end;

function TJclClrTable.RealRowCount: Integer;
begin
  if Assigned(FRows) then
    Result := FRows.Count
  else
    Result := 0;
end;

function TJclClrTable.ReadIndex(const HeapKind: TJclClrHeapKind): DWORD;
begin
  if IsWideIndex(HeapKind) then
    Result := ReadDWord
  else
    Result := ReadWord;
end;

function TJclClrTable.ReadIndex(const TableKinds: array of TJclClrTableKind): DWORD;
begin
  if IsWideIndex(TableKinds) then
    Result := ReadDWord
  else
    Result := ReadWord;
end;

function TJclClrTable.IsWideIndex(const HeapKind: TJclClrHeapKind): Boolean;
begin
  Result := Stream.BigHeap[HeapKind];
end;

function TJclClrTable.IsWideIndex(const TableKinds: array of TJclClrTableKind): Boolean;
var
  I: Integer;
  ATable: TJclClrTable;
begin
  Result := False;
  for I := Low(TableKinds) to High(TableKinds) do
    if Stream.FindTable(TableKinds[I], ATable) then
      Result := Result or (ATable.RowCount > MAXWORD);
end;

function TJclClrTable.ReadByte: Byte;
begin
  Result := PByte(FPtr)^;
  Inc(FPtr, SizeOf(Byte));
end;

function TJclClrTable.ReadWord: Word;
begin
  Result := PWord(FPtr)^;
  Inc(FPtr, SizeOf(Word));
end;

function TJclClrTable.ReadDWord: DWORD;
begin
  Result := PDWORD(FPtr)^;
  Inc(FPtr, SizeOf(DWORD));
end;

function TJclClrTable.ReadCompressedValue: DWORD;
var
  I: Integer;
begin
  Result := ReadByte;
  if Result = 0 then
  begin
    Exit;
  end
  else
  if ((Result and $C0) = $C0) and ((Result and $20) = 0) then    // 110bs
  begin
    Result := Result and $1F;
    for I := 0 to 2 do
      Result := Result shl 8 + ReadByte;
  end
  else
  if ((Result and $80) = $80) and ((Result and $40) = 0) then    // 10bs
  begin
    Result := ((Result and $3F) shl 8) + ReadByte;
  end
  else
  begin
    Result := Result and $7F;
  end;
end;

class function TJclClrTable.TableRowClass: TJclClrTableRowClass;
begin
  Result := TJclClrTableRow;
end;

procedure TJclClrTable.Update;
var
  I: Integer;
begin
  if Assigned(FRows) then
  for I := 0 to RowCount-1 do
    Rows[I].Update;
end;

function TJclClrTable.GetCodedIndexTag(const CodedIndex, TagWidth: DWORD;
  const WideIndex: Boolean): DWORD;
var
  I, TagMask: DWORD;
begin
  TagMask := 0;
  for I := 0 to TagWidth-1 do
    TagMask := TagMask or (1 shl I);
  Result := CodedIndex and TagMask;
end;

function TJclClrTable.GetCodedIndexValue(const CodedIndex, TagWidth: DWORD;
  const WideIndex: Boolean): DWORD;
const
  IndexBits: array [Boolean] of DWORD = (SizeOf(WORD) * 8, SizeOf(DWORD) * 8);
var
  I, ValueMask: DWORD;
begin
  ValueMask := 0;
  for I := TagWidth to IndexBits[WideIndex]-1 do
    ValueMask := ValueMask or (1 shl I);
  Result := (CodedIndex and ValueMask) shr TagWidth;
end;

function TJclClrTable.DumpIL: string;
var
  I: Integer;
begin
  Result := '// Dump ' + ClassName + AnsiLineBreak;
  {$IFDEF RTL140_UP}
  if Supports(ClassType, ITableCanDumpIL) then
  {$ELSE RTL140_UP}
  if ClassType.GetInterfaceEntry(ITableCanDumpIL) <> nil then
  {$ENDIF RTL140_UP}
    for I := 0 to FRows.Count - 1 do
      Result := Result + TJclClrTableRow(FRows[I]).DumpIL;
end;

//=== { TJclClrTableStream } =================================================

constructor TJclClrTableStream.Create(const AMetadata: TJclPeMetadata;
  AHeader: PClrStreamHeader);

  function BitCount(const Value: Int64): Integer;
  var
    AKind: TJclClrTableKind;
  begin
    Result := 0;
    for AKind := Low(TJclClrTableKind) to High(TJclClrTableKind) do
      if (Value and (Int64(1) shl Integer(AKind))) <> 0 then
        Inc(Result);
  end;

  procedure EnumTables;
  var
    AKind: TJclClrTableKind;
    pTable: Pointer;
  begin
    pTable := @Header.Rows[BitCount(Header.Valid)];
    FTableCount := 0;
    for AKind := Low(TJclClrTableKind) to High(TJclClrTableKind) do
    begin
      if (Header.Valid and (Int64(1) shl Integer(AKind))) <> 0 then
      begin
        FTables[AKind] := ValidTableMapping[AKind].Create(Self, pTable, Header.Rows[FTableCount]);
        pTable := Pointer(DWORD(pTable) + FTables[AKind].Size);
        Inc(FTableCount);
      end
      else
        FTables[AKind] := nil;
    end;
  end;

begin
  inherited Create(AMetadata, AHeader);
  FHeader := Data;
  EnumTables;
end;

destructor TJclClrTableStream.Destroy;
begin
  FreeAndNil(FTables);
  inherited Destroy;
end;

function TJclClrTableStream.GetVersionString: string;
begin
  Result := FormatVersionString(Header.MajorVersion, Header.MinorVersion);
end;

function TJclClrTableStream.GetTable(const AKind: TJclClrTableKind): TJclClrTable;
begin
  Result := TJclClrTable(FTables[AKind]);
end;

function TJclClrTableStream.GetBigHeap(const AHeapKind: TJclClrHeapKind): Boolean;
const
  HeapSizesMapping: array [TJclClrHeapKind] of DWORD = (1, 2, 4);
begin
  Result := (Header.HeapSizes and HeapSizesMapping[AHeapKind]) <> 0;
end;

function TJclClrTableStream.FindTable(const AKind: TJclClrTableKind;
  var ATable: TJclClrTable): Boolean;
begin
  ATable := FTables[AKind];
  Result := Assigned(ATable);
end;

procedure TJclClrTableStream.Update;
var
  AKind: TJclClrTableKind;
begin
  for AKind := Low(TJclClrTableKind) to High(TJclClrTableKind) do
    if Assigned(FTables[AKind]) then
      FTables[AKind].Update;
end;

function TJclClrTableStream.DumpIL: string;
var
  AKind: TJclClrTableKind;
begin
  for AKind := Low(TJclClrTableKind) to High(TJclClrTableKind) do
    if Assigned(FTables[AKind]) then
      Result := Result + FTables[AKind].DumpIL;
end;

//=== { TJclPeMetadata } =====================================================

constructor TJclPeMetadata.Create(const AImage: TJclPeImage);

  function GetStreamClass(const Name: string): TJclClrStreamClass;
  begin
    if CompareText(Name, '#Strings') = 0 then
      Result := TJclClrStringsStream
    else
    if CompareText(Name, '#GUID') = 0 then
      Result := TJclClrGuidStream
    else
    if CompareText(Name, '#Blob') = 0 then
      Result := TJclClrBlobStream
    else
    if CompareText(Name, '#US') = 0 then
      Result := TJclClrUserStringStream
    else
    if CompareText(Name, '#~') = 0 then
      Result := TJclClrTableStream
    else
      Result := TJclClrStream;
  end;

  procedure UpdateStreams;
  type
    PStreamPartitionHeader = ^TStreamPartitionHeader;
    TStreamPartitionHeader = packed record
      Flags,
      StreamCount: Word;
      StreamHeaders: array [0..0] of TClrStreamHeader;
    end;
  var
    pStreamPart: PStreamPartitionHeader;
    pStream: PClrStreamHeader;
    I: Integer;
    TableStream: TJclClrTableStream;
  begin
    pStreamPart := PStreamPartitionHeader(DWORD(@Header.Version[0]) + Header.Length);
    pStream := @pStreamPart.StreamHeaders[0];
    for I := 0 to pStreamPart.StreamCount-1 do
    begin
      FStreams.Add(GetStreamClass(pStream.Name).Create(Self, pStream));

      pStream := PClrStreamHeader(DWORD(@pStream.Name[0]) +
        DWORD((((StrLen(@pStream.Name[0])+1)+3) and (not $3))));
    end;
    if FindStream(TJclClrTableStream, TJclClrStream(TableStream)) then
      TableStream.Update;
  end;

begin
  Assert(AImage.IsClr and AImage.ClrHeader.HasMetadata);
  inherited Create;
  FImage := AImage;
  with Image.ClrHeader.Header.MetaData do
  begin
    Assert(Size > SizeOf(FHeader^));
    FHeader := Image.RvaToVa(VirtualAddress);
    Assert(not IsBadReadPtr(FHeader, Size));
  end;

  FStreams := TObjectList.Create;
  UpdateStreams;

  FindStream(TJclClrStringsStream, TJclClrStream(FStringStream));
  FindStream(TJclClrGuidStream, TJclClrStream(FGuidStream));
  FindStream(TJclClrBlobStream, TJclClrStream(FBlobStream));
  FindStream(TJclClrUserStringStream, TJclClrStream(FUserStringStream));
  FindStream(TJclClrTableStream, TJclClrStream(FTableStream));
end;

destructor TJclPeMetadata.Destroy;
begin
  FreeAndNil(FStreams);
  inherited Destroy;
end;

function TJclPeMetadata.GetVersionString: WideString;
var
  VerStr: string;
begin
  SetLength(VerStr, Header.Length+1);
  StrlCopy(PChar(VerStr), @Header.Version[0], Header.Length);
  SetLength(VerStr, StrLen(PChar(VerStr)));
  Result := UTF8ToWideString(VerStr)
end;

function TJclPeMetadata.GetVersion: string;
begin
  Result := FormatVersionString(Header.MajorVersion, Header.MinorVersion);
end;

function TJclPeMetadata.GetFlags: Word;
begin
  Result := PWord(PChar(@Header.Version[0]) + (Header.Length + 3) and (not 3))^;
end;

function TJclPeMetadata.GetStream(const Idx: Integer): TJclClrStream;
begin
  Result := TJclClrStream(FStreams.Items[Idx]);
end;

function TJclPeMetadata.GetStreamCount: Integer;
begin
  Result := FStreams.Count;
end;

function TJclPeMetadata.FindStream(const AName: string;
  var Stream: TJclClrStream): Boolean;
var
  I: Integer;
begin
  for I := 0 to GetStreamCount-1 do
  begin
    Stream := Streams[I];
    if CompareText(Stream.Name, AName) = 0 then
    begin
      Result := True;
      Exit;
    end;
  end;
  Result := False;
  Stream := nil;
end;

function TJclPeMetadata.FindStream(const AClass: TJclClrStreamClass;
  var Stream: TJclClrStream): Boolean;
var
  I: Integer;
begin
  for I := 0 to GetStreamCount-1 do
  begin
    Stream := Streams[I];
    if Stream.ClassType = AClass then
    begin
      Result := True;
      Exit;
    end;
  end;
  Result := False;
  Stream := nil;
end;

function TJclPeMetadata.GetToken(const AToken: TJclClrToken): TJclClrTableRow;