jclclr.pas

East make Tray Icon in delphi

{**************************************************************************************************}
{                                                                                                  }
{ Project JEDI Code Library (JCL)                                                                  }
{                                                                                                  }
{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
{ you may not use this file except in compliance with the License. You may obtain a copy of the    }
{ License at http://www.mozilla.org/MPL/                                                           }
{                                                                                                  }
{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF   }
{ ANY KIND, either express or implied. See the License for the specific language governing rights  }
{ and limitations under the License.                                                               }
{                                                                                                  }
{ The Original Code is JclCLR.pas.                                                                 }
{                                                                                                  }
{ The Initial Developer of the Original Code is Flier Lu (<flier_lu att yahoo dott com dott cn>).  }
{ Portions created by Flier Lu are Copyright (C) Flier Lu. All Rights Reserved.                    }
{                                                                                                  }
{ Contributors:                                                                                    }
{   Flier Lu (flier)                                                                               }
{   Robert Marquardt (marquardt)                                                                   }
{   Olivier Sannier (obones)                                                                       }
{   Petr Vones (pvones)                                                                            }
{                                                                                                  }
{**************************************************************************************************}
{                                                                                                  }
{ Microsoft .Net framework Clr information support routines and classes.                           }
{                                                                                                  }
{ Unit owner: Flier Lu                                                                             }
{                                                                                                  }
{**************************************************************************************************}

// Last modified: $Date: 2005/03/08 08:33:22 $
// For history see end of file

unit JclCLR;

interface

{$I jcl.inc}

uses
  {$IFDEF MSWINDOWS}
  Windows,
  {$ENDIF MSWINDOWS}
  Classes, SysUtils,
  {$IFDEF RTL130_UP}
  Contnrs,
  {$ENDIF RTL130_UP}
  JclBase, JclFileUtils, JclPeImage, JclSysUtils;

type
  _IMAGE_COR_VTABLEFIXUP = packed record
    RVA: DWORD;     // Offset of v-table array in image.
    Count: Word;    // How many entries at location.
    Kind: Word;     // COR_VTABLE_xxx type of entries.
  end;
  IMAGE_COR_VTABLEFIXUP = _IMAGE_COR_VTABLEFIXUP;
  TImageCorVTableFixup = _IMAGE_COR_VTABLEFIXUP;
  PImageCorVTableFixup = ^TImageCorVTableFixup;
  TImageCorVTableFixupArray = array [0..MaxWord-1] of TImageCorVTableFixup;
  PImageCorVTableFixupArray = ^TImageCorVTableFixupArray;

type
  PClrStreamHeader = ^TClrStreamHeader;
  TClrStreamHeader = packed record
    Offset: DWORD; // Memory offset to start of this stream from start of the metadata root
    Size: DWORD;   // Size of this stream in bytes, shall be a multiple of 4.
    // Name of the stream as null terminated variable length
    // array of ASCII characters, padded with \0 characters
    Name: array [0..MaxWord] of Char;
  end;

  PClrTableStreamHeader = ^TClrTableStreamHeader;
  TClrTableStreamHeader = packed record
    Reserved: DWORD;    // Reserved, always 0
    MajorVersion: Byte; // Major version of table schemata, always 1
    MinorVersion: Byte; // Minor version of table schemata, always 0
    HeapSizes: Byte;    // Bit vector for heap sizes.
    Reserved2: Byte;    // Reserved, always 1
    Valid: Int64;       // Bit vector of present tables, let n be the number of bits that are 1.
    Sorted: Int64;      // Bit vector of sorted tables.
    // Array of n four byte unsigned integers indicating the number of rows
    // for each present table.
    Rows: array [0..MaxWord] of DWORD;
    //Rows: array [0..n-1] of DWORD;
    //Tables: array
  end;

  PClrMetadataHeader = ^TClrMetadataHeader;
  TClrMetadataHeader = packed record
    Signature: DWORD;   // Magic signature for physical metadata : $424A5342.
    MajorVersion: Word; // Major version, 1
    MinorVersion: Word; // Minor version, 0
    Reserved: DWORD;    // Reserved, always 0
    Length: DWORD;      // Length of version string in bytes, say m.
    Version: array [0..0] of Char;
    // UTF8-encoded version string of length m
    // Padding to next 4 byte boundary, say x.
    {
    Version: array [0..((m+3) and (not $3))-1] of Char;
    Flags,              // Reserved, always 0
    Streams: Word;      // Number of streams, say n.
    // Array of n StreamHdr structures.
    StreamHeaders: array [0..n-1] of TClrStreamHeader;
    }
  end;

type
  TJclClrTableKind = (
    ttModule,               //  $00
    ttTypeRef,              //  $01
    ttTypeDef,              //  $02
    ttFieldPtr,             //  $03
    ttFieldDef,             //  $04
    ttMethodPtr,            //  $05
    ttMethodDef,            //  $06
    ttParamPtr,             //  $07
    ttParamDef,             //  $08
    ttInterfaceImpl,        //  $09
    ttMemberRef,            //  $0a
    ttConstant,             //  $0b
    ttCustomAttribute,      //  $0c
    ttFieldMarshal,         //  $0d
    ttDeclSecurity,         //  $0e
    ttClassLayout,          //  $0f
    ttFieldLayout,          //  $10
    ttSignature,            //  $11
    ttEventMap,             //  $12
    ttEventPtr,             //  $13
    ttEventDef,             //  $14
    ttPropertyMap,          //  $15
    ttPropertyPtr,          //  $16
    ttPropertyDef,          //  $17
    ttMethodSemantics,      //  $18
    ttMethodImpl,           //  $19
    ttModuleRef,            //  $1a
    ttTypeSpec,             //  $1b
    ttImplMap,              //  $1c
    ttFieldRVA,             //  $1d
    ttENCLog,               //  $1e
    ttENCMap,               //  $1f
    ttAssembly,             //  $20
    ttAssemblyProcessor,    //  $21
    ttAssemblyOS,           //  $22
    ttAssemblyRef,          //  $23
    ttAssemblyRefProcessor, //  $24
    ttAssemblyRefOS,        //  $25
    ttFile,                 //  $26
    ttExportedType,         //  $27
    ttManifestResource,     //  $28
    ttNestedClass,          //  $29
    ttTypeTyPar,            //  $2a
    ttMethodTyPar);         //  $2b

  TJclClrToken = DWORD;
  PJclClrToken = ^TJclClrToken;

type
  TJclClrHeaderEx = class;
  TJclPeMetadata = class;

  TJclClrStreamClass = class of TJclClrStream;
  TJclClrStream = class(TObject)
  private
    FMetadata: TJclPeMetadata;
    FHeader: PClrStreamHeader;
    function GetName: string;
    function GetOffset: DWORD;
    function GetSize: DWORD;
    function GetData: Pointer;
  protected
    constructor Create(const AMetadata: TJclPeMetadata;
      AHeader: PClrStreamHeader); virtual;
  public
    property Metadata: TJclPeMetadata read FMetadata;
    property Header: PClrStreamHeader read FHeader;
    property Name: string read GetName;
    property Offset: DWORD read GetOffset;
    property Size: DWORD read GetSize;
    property Data: Pointer read GetData;
  end;

  TJclClrStringsStream = class(TJclClrStream)
  private
    FStrings: TStringList;
    function GetString(const Idx: Integer): WideString;
    function GetOffset(const Idx: Integer): DWORD;
    function GetStringCount: Integer;
  protected
    constructor Create(const AMetadata: TJclPeMetadata;
      AHeader: PClrStreamHeader); override;
  public
    destructor Destroy; override;
    function At(const Offset: DWORD): WideString;
    property Strings[const Idx: Integer]: WideString read GetString; default;
    property Offsets[const Idx: Integer]: DWord read GetOffset;
    property StringCount: Integer read GetStringCount;
  end;

  TJclClrGuidStream = class(TJclClrStream)
  private
    FGuids: array of TGUID;
    function GetGuid(const Idx: Integer): TGUID;
    function GetGuidCount: Integer;
  protected
    constructor Create(const AMetadata: TJclPeMetadata;
      AHeader: PClrStreamHeader); override;
  public
    property Guids[const Idx: Integer]: TGUID read GetGuid; default;
    property GuidCount: Integer read GetGuidCount;
  end;

  TJclClrBlobRecord = class(TJclReferenceMemoryStream)
  private
    FPtr: PByteArray;
    FOffset: DWORD;
    function GetData: PByteArray;
  protected
    constructor Create(const AStream: TJclClrStream; APtr: PByteArray);
  public
    function Dump(Indent: string): string;
    property Ptr: PByteArray read FPtr;
    property Offset: DWORD read FOffset;
    property Data: PByteArray read GetData;
  end;

  TJclClrBlobStream = class(TJclClrStream)
  private
    FBlobs: TObjectList;
    function GetBlob(const Idx: Integer): TJclClrBlobRecord;
    function GetBlobCount: Integer;
  protected
    constructor Create(const AMetadata: TJclPeMetadata;
      AHeader: PClrStreamHeader); override;
  public
    destructor Destroy; override;
    function At(const Offset: DWORD): TJclClrBlobRecord;
    property Blobs[const Idx: Integer]: TJclClrBlobRecord read GetBlob; default;
    property BlobCount: Integer read GetBlobCount;
  end;

  TJclClrUserStringStream = class(TJclClrBlobStream)
  private
    function BlobToString(const ABlob: TJclClrBlobRecord): WideString;
    function GetString(const Idx: Integer): WideString;
    function GetOffset(const Idx: Integer): DWORD;
    function GetStringCount: Integer;
  public
    function At(const Offset: DWORD): WideString;
    property Strings[const Idx: Integer]: WideString read GetString; default;
    property Offsets[const Idx: Integer]: DWord read GetOffset;
    property StringCount: Integer read GetStringCount;
  end;

  TJclClrTableStream = class;

  TJclClrHeapKind = (hkString, hkGuid, hkBlob);
  TJclClrComboIndex = (ciResolutionScope);

  ITableCanDumpIL = interface(IUnknown)
    ['{C7AC787B-5DCD-411A-8674-D424A61B76D1}']
  end;

  TJclClrTable = class;

  TJclClrTableRowClass = class of TJclClrTableRow;
  TJclClrTableRow = class(TObject)
  private
    FTable: TJclClrTable;
    FIndex: Integer;
    function GetToken: TJclClrToken;
  protected
    constructor Create(const ATable: TJclClrTable); virtual;
    procedure Update; virtual;
    function DecodeTypeDefOrRef(const Encoded: DWORD): TJclClrTableRow;
    function DecodeResolutionScope(const Encoded: DWORD): TJclClrTableRow;
  public
    function DumpIL: string; virtual;
    property Table: TJclClrTable read FTable;
    property Index: Integer read FIndex;
    property Token: TJclClrToken read GetToken;
  end;

  TJclClrTableClass = class of TJclClrTable;
  TJclClrTable = class(TInterfacedObject)
  private
    FStream: TJclClrTableStream;
    FData: PChar;
    FPtr: PChar;
    FRows: TObjectList;
    FRowCount: Integer;
    FSize: DWORD;
    function GetOffset: DWORD;
  protected
    constructor Create(const AStream: TJclClrTableStream;
      const Ptr: Pointer; const ARowCount: Integer); virtual;
    procedure Load; virtual;
    procedure SetSize(const Value: Integer);
    procedure Update; virtual;
    function DumpIL: string; virtual;
    function GetRow(const Idx: Integer): TJclClrTableRow;
    function GetRowCount: Integer;
    function AddRow(const ARow: TJclClrTableRow): Integer;
    function RealRowCount: Integer;
    procedure Reset;
    class function TableRowClass: TJclClrTableRowClass; virtual;
  public
    destructor Destroy; override;
    function ReadCompressedValue: DWORD;
    function ReadByte: Byte;
    function ReadWord: Word;
    function ReadDWord: DWORD;
    function ReadIndex(const HeapKind: TJclClrHeapKind): DWORD; overload;
    function ReadIndex(const TableKinds: array of TJclClrTableKind): DWORD; overload;
    function IsWideIndex(const HeapKind: TJclClrHeapKind): Boolean; overload;
    function IsWideIndex(const TableKinds: array of TJclClrTableKind): Boolean; overload;
    function GetCodedIndexTag(const CodedIndex, TagWidth: DWORD;
      const WideIndex: Boolean): DWORD;
    function GetCodedIndexValue(const CodedIndex, TagWidth: DWORD;
      const WideIndex: Boolean): DWORD;
    property Stream: TJclClrTableStream read FStream;
    property Data: PChar read FData;
    property Size: DWORD read FSize;
    property Offset: DWORD read GetOffset;
    property Rows[const Idx: Integer]: TJclClrTableRow read GetRow; default;
    property RowCount: Integer read GetRowCount;
  end;

  TJclClrTableStream = class(TJclClrStream)
  private
    FHeader: PClrTableStreamHeader;
    FTables: array [TJclClrTableKind] of TJclClrTable;
    FTableCount: Integer;
    function GetVersionString: string;
    function GetTable(const AKind: TJclClrTableKind): TJclClrTable;
    function GetBigHeap(const AHeapKind: TJclClrHeapKind): Boolean;
  protected
    constructor Create(const AMetadata: TJclPeMetadata;
      AHeader: PClrStreamHeader); override;
  public
    destructor Destroy; override;
    procedure Update; virtual;
    function DumpIL: string;
    function FindTable(const AKind: TJclClrTableKind;
      var ATable: TJclClrTable): Boolean;
    property Header: PClrTableStreamHeader read FHeader;
    property VersionString: string read GetVersionString;
    property BigHeap[const AHeapKind: TJclClrHeapKind]: Boolean read GetBigHeap;
    property Tables[const AKind: TJclClrTableKind]: TJclClrTable read GetTable;
    property TableCount: Integer read FTableCount;
  end;

  TJclPeMetadata = class(TObject)
  private
    FImage: TJclPeImage;
    FHeader: PClrMetadataHeader;
    FStreams: TObjectList;
    FStringStream: TJclClrStringsStream;
    FGuidStream: TJclClrGuidStream;
    FBlobStream: TJclClrBlobStream;
    FUserStringStream: TJclClrUserStringStream;
    FTableStream: TJclClrTableStream;
    function GetStream(const Idx: Integer): TJclClrStream;
    function GetStreamCount: Integer;
    function GetString(const Idx: Integer): WideString;
    function GetStringCount: Integer;
    function GetGuid(const Idx: Integer): TGUID;
    function GetGuidCount: Integer;
    function GetBlob(const Idx: Integer): TJclClrBlobRecord;
    function GetBlobCount: Integer;
    function GetTable(const AKind: TJclClrTableKind): TJclClrTable;
    function GetTableCount: Integer;
    function GetToken(const AToken: TJclClrToken): TJclClrTableRow;
    function GetVersion: string;
    function GetVersionString: WideString;
    function GetFlags: Word;
    function UserGetString(const Idx: Integer): WideString;
    function UserGetStringCount: Integer;
  protected
    constructor Create(const AImage: TJclPeImage);
  public
    destructor Destroy; override;
    function DumpIL: string;
    function FindStream(const AName: string; var Stream: TJclClrStream): Boolean; overload;
    function FindStream(const AClass: TJclClrStreamClass; var Stream: TJclClrStream): Boolean; overload;
    function StringAt(const Offset: DWORD): WideString;
    function UserStringAt(const Offset: DWORD): WideString;
    function BlobAt(const Offset: DWORD): TJclClrBlobRecord;
    function TokenExists(const Token: TJclClrToken): Boolean;
    class function TokenTable(const Token: TJclClrToken): TJclClrTableKind;
    class function TokenIndex(const Token: TJclClrToken): Integer;
    class function TokenCode(const Token: TJclClrToken): Integer;
    class function MakeToken(const Table: TJclClrTableKind; const Idx: Integer): TJclClrToken;
    property Image: TJclPeImage read FImage;
    property Header: PClrMetadataHeader read FHeader;
    property Version: string read GetVersion;
    property VersionString: WideString read GetVersionString;
    property Flags: Word read GetFlags;
    property Streams[const Idx: Integer]: TJclClrStream read GetStream; default;
    property StreamCount: Integer read GetStreamCount;
    property Strings[const Idx: Integer]: WideString read GetString;
    property StringCount: Integer read GetStringCount;
    property UserStrings[const Idx: Integer]: WideString read UserGetString;
    property UserStringCount: Integer read UserGetStringCount;
    property Guids[const Idx: Integer]: TGUID read GetGuid;
    property GuidCount: Integer read GetGuidCount;
    property Blobs[const Idx: Integer]: TJclClrBlobRecord read GetBlob;
    property BlobCount: Integer read GetBlobCount;
    property Tables[const AKind: TJclClrTableKind]: TJclClrTable read GetTable;
    property TableCount: Integer read GetTableCount;
    property Tokens[const AToken: TJclClrToken]: TJclClrTableRow read GetToken;
  end;

  TJclClrResourceRecord = class(TJClreferenceMemoryStream)
  private
    FData: Pointer;
    FOffset: DWORD;
    FRVA: DWORD;
  protected
    constructor Create(const AData: PChar; const AOffset: DWORD; const ARVA: DWORD);
  public
    property Data: Pointer read FData;
    property Offset: DWORD read FOffset;
    property RVA: DWORD read FRVA;
  end;

  TJclClrVTableKind = (vtk32Bit, vtk64Bit, vtkFromUnmanaged, vtkCallMostDerived);
  TJclClrVTableKinds = set of TJclClrVTableKind;

  TJclClrVTableFixupRecord = class(TObject)
  private
    FData: PImageCorVTableFixup;
    function GetCount: DWORD;
    function GetKinds: TJclClrVTableKinds;
    function GetRVA: DWORD;
  protected
    constructor Create(AData: PImageCorVTableFixup);
    class function VTableKinds(const Kinds: TJclClrVTableKinds): DWORD; overload;
    class function VTableKinds(const Kinds: DWORD): TJclClrVTableKinds; overload;
  public
    property Data: PImageCorVTableFixup read FData;
    property RVA: DWORD read GetRVA;                  // RVA of Vtable
    property Count: DWORD read GetCount;              // Number of entries in Vtable
    property Kinds: TJclClrVTableKinds read GetKinds; // Type of the entries
  end;