Componentes.Terceros.jcl/official/1.96/source/windows/JclCLR.pas

1789 lines
56 KiB
ObjectPascal

{**************************************************************************************************}
{ }
{ 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/12/26 18:03:58 $
// 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;
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;
TJclClrStreamClass = class of TJclClrStream;
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: PJclByteArray;
FOffset: DWORD;
function GetData: PJclByteArray;
protected
constructor Create(const AStream: TJclClrStream; APtr: PJclByteArray);
public
function Dump(Indent: string): string;
property Ptr: PJclByteArray read FPtr;
property Offset: DWORD read FOffset;
property Data: PJclByteArray 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;
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;
TJclClrTableRowClass = class of TJclClrTableRow;
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;
TJclClrTableClass = class of TJclClrTable;
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;
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: PJclByteArray);
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: PJclByteArray;
begin
Result := PJclByteArray(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;
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;
begin
if AToken = 0 then
Result := nil
else
try
Result := Tables[TokenTable(AToken)].Rows[TokenIndex(AToken)-1];
except
Result := nil;
end;
end;
function TJclPeMetadata.GetString(const Idx: Integer): WideString;
begin
if Assigned(FStringStream) or
FindStream(TJclClrStringsStream, TJclClrStream(FStringStream)) then
Result := FStringStream.Strings[Idx]
else
Result := '';
end;
function TJclPeMetadata.GetStringCount: Integer;
begin
if Assigned(FStringStream) or
FindStream(TJclClrStringsStream, TJclClrStream(FStringStream)) then
Result := FStringStream.StringCount
else
Result := 0;
end;
function TJclPeMetadata.UserGetString(const Idx: Integer): WideString;
begin
if Assigned(FUserStringStream) or
FindStream(TJclClrUserStringStream, TJclClrStream(FUserStringStream)) then
Result := FUserStringStream.Strings[Idx-1]
else
Result := '';
end;
function TJclPeMetadata.UserGetStringCount: Integer;
begin
if Assigned(FUserStringStream) or
FindStream(TJclClrUserStringStream, TJclClrStream(FUserStringStream)) then
Result := FUserStringStream.StringCount
else
Result := 0;
end;
function TJclPeMetadata.StringAt(const Offset: DWORD): WideString;
begin
if Assigned(FStringStream) or
FindStream(TJclClrStringsStream, TJclClrStream(FStringStream)) then
Result := FStringStream.At(Offset)
else
Result := '';
end;
function TJclPeMetadata.UserStringAt(const Offset: DWORD): WideString;
begin
if Assigned(FUserStringStream) or
FindStream(TJclClrUserStringStream, TJclClrStream(FUserStringStream)) then
Result := TJclClrUserStringStream(FUserStringStream).At(Offset)
else
Result := '';
end;
function TJclPeMetadata.BlobAt(const Offset: DWORD): TJclClrBlobRecord;
begin
if Assigned(FBlobStream) or
FindStream(TJclClrBlobStream, TJclClrStream(FBlobStream)) then
Result := TJclClrBlobStream(FBlobStream).At(Offset)
else
Result := nil;
end;
function TJclPeMetadata.GetGuid(const Idx: Integer): TGUID;
begin
if Assigned(FGuidStream) or
FindStream(TJclClrGuidStream, TJclClrStream(FGuidStream)) then
Result := FGuidStream.Guids[Idx]
else
Result := GUID_NULL;
end;
function TJclPeMetadata.GetGuidCount: Integer;
begin
if Assigned(FGuidStream) or
FindStream(TJclClrGuidStream, TJclClrStream(FGuidStream)) then
Result := FGuidStream.GuidCount
else
Result := 0;
end;
function TJclPeMetadata.GetBlob(const Idx: Integer): TJclClrBlobRecord;
begin
if Assigned(FBlobStream) or
FindStream(TJclClrBlobStream, TJclClrStream(FBlobStream)) then
Result := FBlobStream.Blobs[Idx]
else
Result := nil;
end;
function TJclPeMetadata.GetBlobCount: Integer;
begin
if Assigned(FBlobStream) or
FindStream(TJclClrBlobStream, TJclClrStream(FBlobStream)) then
Result := FBlobStream.BlobCount
else
Result := 0;
end;
function TJclPeMetadata.GetTable(const AKind: TJclClrTableKind): TJclClrTable;
begin
if Assigned(FTableStream) or
FindStream(TJclClrTableStream, TJclClrStream(FTableStream)) then
Result := FTableStream.Tables[AKind]
else
Result := nil;
end;
function TJclPeMetadata.GetTableCount: Integer;
begin
if Assigned(FTableStream) or
FindStream(TJclClrTableStream, TJclClrStream(FTableStream)) then
Result := FTableStream.TableCount
else
Result := 0;
end;
function TJclPeMetadata.TokenExists(const Token: TJclClrToken): Boolean;
begin
Result := TokenIndex(Token) in [1..Tables[TokenTable(Token)].RowCount];
end;
class function TJclPeMetadata.TokenTable(const Token: TJclClrToken): TJclClrTableKind;
begin
Result := TJclClrTableKind(Token shr 24);
end;
class function TJclPeMetadata.TokenIndex(const Token: TJclClrToken): Integer;
begin
Result := Token and DWORD($FFFFFF);
end;
class function TJclPeMetadata.TokenCode(const Token: TJclClrToken): Integer;
begin
Result := Token and $FF000000;
end;
class function TJclPeMetadata.MakeToken(const Table: TJclClrTableKind;
const Idx: Integer): TJclClrToken;
begin
Result := (DWORD(Table) shl 24) and TokenIndex(Idx);
end;
function TJclPeMetadata.DumpIL: string;
begin
with TStringList.Create do
try
Add(Format('.imagebase 0x%.8x', [Image.OptionalHeader.ImageBase]));
Add(Format('.subsystem 0x%.8x', [Image.OptionalHeader.SubSystem]));
Add(Format('.file alignment %d', [Image.OptionalHeader.FileAlignment]));
if Assigned(FTableStream) then
begin
FTableStream.Update;
Result := Text + AnsiLineBreak + FTableStream.DumpIL;
end;
finally
Free;
end;
end;
//=== { TJclClrResourceRecord } ==============================================
constructor TJclClrResourceRecord.Create(const AData: PChar;
const AOffset: DWORD; const ARVA: DWORD);
begin
FData := AData;
FOffset := AOffset;
FRVA := ARVA;
inherited Create(Pointer(DWORD(Data)+SizeOf(DWORD)), PDWORD(Data)^);
end;
//=== { TJclClrVTableFixupRecord } ===========================================
constructor TJclClrVTableFixupRecord.Create(AData: PImageCorVTableFixup);
begin
inherited Create;
FData := AData;
end;
function TJclClrVTableFixupRecord.GetCount: DWORD;
begin
Result := Data.Count;
end;
function TJclClrVTableFixupRecord.GetKinds: TJclClrVTableKinds;
begin
Result := VTableKinds(Data.Kind);
end;
function TJclClrVTableFixupRecord.GetRVA: DWORD;
begin
Result := Data.RVA;
end;
class function TJclClrVTableFixupRecord.VTableKinds(const Kinds: TJclClrVTableKinds): DWORD;
var
AKind: TJclClrVTableKind;
begin
Result := 0;
for AKind := Low(TJclClrVTableKind) to High(TJclClrVTableKind) do
if AKind in Kinds then
Result := Result or ClrVTableKindMapping[AKind];
end;
class function TJclClrVTableFixupRecord.VTableKinds(const Kinds: DWORD): TJclClrVTableKinds;
var
AKind: TJclClrVTableKind;
begin
Result := [];
for AKind := Low(TJclClrVTableKind) to High(TJclClrVTableKind) do
if (ClrVTableKindMapping[AKind] and Kinds) = ClrVTableKindMapping[AKind] then
Include(Result, AKind);
end;
//=== { TJclClrInformation } =================================================
constructor TJclClrHeaderEx.Create(const AImage: TJclPeImage);
procedure UpdateVTableFixups;
begin
// (rom) What is this?
if Header.VTableFixups.VirtualAddress = 0 then
end;
begin
inherited Create(AImage);
FFlags := ClrImageFlag(Header.Flags);
FMetadata := nil;
FResources := nil;
FStrongNameSignature := nil;
FVTableFixups := nil;
end;
destructor TJclClrHeaderEx.Destroy;
begin
FreeAndNil(FVTableFixups);
FreeAndNil(FStrongNameSignature);
FreeAndNil(FResources);
FreeAndNil(FMetadata);
inherited Destroy;
end;
class function TJclClrHeaderEx.ClrImageFlag(const Flags: DWORD): TJclClrImageFlags;
var
AFlag: TJclClrImageFlag;
begin
Result := [];
for AFlag := Low(TJclClrImageFlag) to High(TJclClrImageFlag) do
if (ClrImageFlagMapping[AFlag] and Flags) = ClrImageFlagMapping[AFlag] then
Include(Result, AFlag);
end;
class function TJclClrHeaderEx.ClrImageFlag(const Flags: TJclClrImageFlags): DWORD;
var
AFlag: TJclClrImageFlag;
begin
Result := 0;
for AFlag := Low(TJclClrImageFlag) to High(TJclClrImageFlag) do
if AFlag in Flags then
Result := Result or ClrImageFlagMapping[AFlag];
end;
function TJclClrHeaderEx.GetMetadata: TJclPeMetadata;
begin
if not Assigned(FMetadata) and HasMetadata then
FMetadata := TJclPeMetadata.Create(Image);
Result := FMetadata;
end;
function TJclClrHeaderEx.HasStrongNameSignature: Boolean;
begin
with Header.StrongNameSignature do
Result := Assigned(FStrongNameSignature) or
((Size > 0) and not IsBadReadPtr(Image.RvaToVa(VirtualAddress), Size));
end;
function TJclClrHeaderEx.HasVTableFixup: Boolean;
begin
with Header.VTableFixups do
Result := Assigned(FVTableFixups) or
((Size > 0) and not IsBadReadPtr(Image.RvaToVa(VirtualAddress), Size));
end;
function TJclClrHeaderEx.GetStrongNameSignature: TCustomMemoryStream;
begin
if not Assigned(FStrongNameSignature) and HasStrongNameSignature then
with Header.StrongNameSignature do
FStrongNameSignature := TJClreferenceMemoryStream.Create(Image.RvaToVa(VirtualAddress), Size);
Result := FStrongNameSignature;
end;
function TJclClrHeaderEx.HasResources: Boolean;
begin
with Header.Resources do
Result := Assigned(FResources) or
((Size > 0) and not IsBadReadPtr(Image.RvaToVa(VirtualAddress), Size));
end;
procedure TJclClrHeaderEx.UpdateResources;
var
Base, Ptr: PChar;
ARes: TJclClrResourceRecord;
begin
FResources := TObjectList.Create;
with Header.Resources do
begin
Base := Image.RvaToVa(VirtualAddress);
Ptr := Base;
while DWORD(Ptr-Base) < Size do
begin
ARes := TJclClrResourceRecord.Create(Ptr, Ptr-Base, Ptr-Image.LoadedImage.MappedAddress);
FResources.Add(ARes);
Ptr := PChar(ARes.Memory) + ARes.Size;
end;
end;
end;
function TJclClrHeaderEx.GetResource(
const Idx: Integer): TJclClrResourceRecord;
begin
if not Assigned(FResources) and HasResources then
UpdateResources;
Result := TJclClrResourceRecord(FResources.Items[Idx]);
end;
function TJclClrHeaderEx.GetResourceCount: Integer;
begin
if not Assigned(FResources) and HasResources then
UpdateResources;
if Assigned(FResources) then
Result := FResources.Count
else
Result := 0;
end;
function TJclClrHeaderEx.GetEntryPointToken: TJclClrTableRow;
begin
Result := Metadata.Tokens[Header.EntryPointToken]
end;
function TJclClrHeaderEx.GetVTableFixup(
const Idx: Integer): TJclClrVTableFixupRecord;
var
I: Integer;
pData: PImageCorVTableFixup;
begin
if not Assigned(FVTableFixups) and HasVTableFixup then
begin
FVTableFixups := TObjectList.Create;
with Header.VTableFixups do
begin
pData := PImageCorVTableFixup(Image.RvaToVa(VirtualAddress));
for I := 0 to GetVTableFixupCount-1 do
begin
FVTableFixups.Add(TJclClrVTableFixupRecord.Create(pData));
Inc(pData);
end;
end;
end;
Result := TJclClrVTableFixupRecord(FVTableFixups.Items[Idx]);
end;
function TJclClrHeaderEx.GetVTableFixupCount: Integer;
begin
Result := Header.VTableFixups.Size div SizeOf(TImageCorVTableFixup);
end;
function TJclClrHeaderEx.ResourceAt(const Offset: DWORD): TJclClrResourceRecord;
var
I: Integer;
begin
if HasResources then
for I := 0 to ResourceCount-1 do
begin
Result := Resources[I];
if Result.Offset = Offset then
Exit;
end;
Result := nil;
end;
function TJclClrHeaderEx.DumpIL: string;
begin
with TStringList.Create do
try
Add(RsClrCopyright);
Add(Format('.corflags 0x%.8x', [Header.Flags]));
Result := Text + AnsiLineBreak + Metadata.DumpIL;
finally
Free;
end;
end;
// History:
// $Log: JclCLR.pas,v $
// Revision 1.16 2005/12/26 18:03:58 outchy
// Enhanced bds support (including C#1 and D8)
// Introduction of dll experts
// Project types in templates
//
// Revision 1.15 2005/08/07 13:09:56 outchy
// Changed PByteArray to PJclByteArray to avoid RangeCheck exceptions.
//
// Revision 1.14 2005/03/08 08:33:22 marquardt
// overhaul of exceptions and resourcestrings, minor style cleaning
//
// Revision 1.13 2005/03/06 18:15:03 marquardt
// JclGUIDToString and JclStringToGUID moved to JclSysUtils.pas, CrLf replaced by AnsiLineBreak
//
// Revision 1.12 2005/02/25 07:20:15 marquardt
// add section lines
//
// Revision 1.11 2005/02/24 16:34:52 marquardt
// remove divider lines, add section lines (unfinished)
//
// Revision 1.10 2004/10/17 21:00:14 mthoma
// cleaning
//
// Revision 1.9 2004/08/01 11:40:23 marquardt
// move constructors/destructors
//
// Revision 1.8 2004/07/31 06:21:03 marquardt
// fixing TStringLists, adding BeginUpdate/EndUpdate, finalization improved
//
// Revision 1.7 2004/06/14 13:05:21 marquardt
// style cleaning ENDIF, Tabs
//
// Revision 1.6 2004/05/13 07:35:09 rrossmair
// removed obsolete TODO
//
// Revision 1.5 2004/05/05 07:33:49 rrossmair
// header updated according to new policy: initial developers & contributors listed
//
// Revision 1.4 2004/04/06 04:55:17
// adapt compiler conditions, add log entry
//
end.