Componentes.Terceros.jcl/official/1.96/examples/windows/clr/ClrDemoTableForm.pas

599 lines
20 KiB
ObjectPascal

unit ClrDemoTableForm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Buttons, ComCtrls, JclClr, JclMetadata;
type
TDumpLineKind = (lkWide, lkThin, lkEmpty);
TfrmTable = class(TForm)
lblVer: TLabel;
edtVer: TEdit;
btnOK: TBitBtn;
lstTables: TListView;
memDump: TMemo;
btnDumpIL: TButton;
procedure lstTablesSelectItem(Sender: TObject; Item: TListItem;
Selected: Boolean);
procedure btnDumpILClick(Sender: TObject);
private
FStream: TJclClrTableStream;
procedure Dump(const Msg: string); overload;
procedure Dump(const FmtMsg: string; const Args: array of const); overload;
procedure Dump(const Msg: string; const Blob: TJclClrBlobRecord); overload;
procedure Dump(const LineKind: TDumpLineKind); overload;
procedure ShowTables(const AStream: TJclClrTableStream);
procedure DumpTable(const ATable: TJclClrTableAssembly); overload;
procedure DumpTable(const ATable: TJclClrTableAssemblyRef); overload;
procedure DumpTable(const ATable: TJclClrTableAssemblyOS); overload;
procedure DumpTable(const ATable: TJclClrTableAssemblyProcessor); overload;
procedure DumpTable(const ATable: TJclClrTableModule); overload;
procedure DumpTable(const ATable: TJclClrTableModuleRef); overload;
procedure DumpTable(const ATable: TJclClrTableFieldDef); overload;
procedure DumpTable(const ATable: TJclClrTableMemberRef); overload;
procedure DumpTable(const ATable: TJclClrTableCustomAttribute); overload;
procedure DumpTable(const ATable: TJclClrTableMethodDef); overload;
procedure DumpTable(const ATable: TJclClrTableTypeDef); overload;
procedure DumpTable(const ATable: TJclClrTableTypeRef); overload;
procedure DumpTable(const ATable: TJclClrTablePropertyDef); overload;
procedure DumpTable(const ATable: TJclClrTableManifestResource); overload;
procedure DumpTable(const ATable: TJclClrTableFile); overload;
procedure DumpTable(const ATable: TJclClrTableParamDef); overload;
procedure DumpTable(const ATable: TJclClrTableExportedType); overload;
public
class procedure Execute(const AStream: TJclClrTableStream);
end;
implementation
{$R *.DFM}
{$DEFINE USE_JWA}
uses
ComObj, TypInfo, ClrDemoAbstractFrame,
{$IFDEF USE_JWA}
JwaWinCrypt, JwaWinNT,
{$ENDIF}
JclStrings, ClrDemoMain;
{ TfrmTable }
class procedure TfrmTable.Execute(const AStream: TJclClrTableStream);
begin
with TfrmTable.Create(nil) do
try
ShowTables(AStream);
ShowModal;
finally
Free;
end;
end;
procedure TfrmTable.Dump(const Msg: string);
begin
memDump.Lines.Add(Msg);
end;
procedure TfrmTable.Dump(const FmtMsg: string; const Args: array of const);
begin
Dump(Format(FmtMsg, Args));
end;
procedure TfrmTable.Dump(const Msg: string; const Blob: TJclClrBlobRecord);
begin
Dump(Msg);
TfrmAbstract.DumpBuf(Blob, memDump);
end;
procedure TfrmTable.Dump(const LineKind: TDumpLineKind);
begin
case LineKind of
lkWide: Dump('========================================');
lkThin: Dump('----------------------------------------');
lkEmpty: Dump('');
end;
end;
procedure TfrmTable.ShowTables(const AStream: TJclClrTableStream);
var
AKind: TJclClrTableKind;
begin
FStream := AStream;
edtVer.Text := AStream.VersionString;
with lstTables.Items do
begin
BeginUpdate;
try
Clear;
for AKind:=Low(TJclClrTableKind) to High(TJclClrTableKind) do
if Assigned(AStream.Tables[AKind]) then
with AStream.Tables[AKind], Add do
begin
Caption := IntToStr(Count);
Data := AStream.Tables[AKind];
SubItems.Add(IntToStr(RowCount));
SubItems.Add('$' + IntToHex(Offset, 8));
SubItems.Add(IntToStr(Size));
SubItems.Add(Copy(AStream.Tables[AKind].ClassName, StrLen('TJclClrTable')+1, MaxWord));
end;
finally
EndUpdate;
end;
end;
end;
procedure TfrmTable.lstTablesSelectItem(Sender: TObject; Item: TListItem; Selected: Boolean);
var
ATable: TJclClrTable;
begin
if Selected then
begin
ATable := TJclClrTable(Item.Data);
memDump.Clear;
if ATable.ClassType = TJclClrTableAssembly then
DumpTable(TJclClrTableAssembly(ATable))
else if ATable.ClassType = TJclClrTableAssemblyRef then
DumpTable(TJclClrTableAssemblyRef(ATable))
else if ATable.ClassType = TJclClrTableAssemblyOS then
DumpTable(TJclClrTableAssemblyOS(ATable))
else if ATable.ClassType = TJclClrTableAssemblyProcessor then
DumpTable(TJclClrTableAssemblyProcessor(ATable))
else if ATable.ClassType = TJclClrTableModule then
DumpTable(TJclClrTableModule(ATable))
else if ATable.ClassType = TJclClrTableModuleRef then
DumpTable(TJclClrTableModuleRef(ATable))
else if ATable.ClassType = TJclClrTableTypeDef then
DumpTable(TJclClrTableTypeDef(ATable))
else if ATable.ClassType = TJclClrTableTypeRef then
DumpTable(TJclClrTableTypeRef(ATable))
else if ATable.ClassType = TJclClrTableMethodDef then
DumpTable(TJclClrTableMethodDef(ATable))
else if ATable.ClassType = TJclClrTableFieldDef then
DumpTable(TJclClrTableFieldDef(ATable))
else if ATable.ClassType = TJclClrTableMemberRef then
DumpTable(TJclClrTableMemberRef(ATable))
else if ATable.ClassType = TJclClrTableCustomAttribute then
DumpTable(TJclClrTableCustomAttribute(ATable))
else if ATable.ClassType = TJclClrTableParamDef then
DumpTable(TJclClrTableParamDef(ATable))
else if ATable.ClassType = TJclClrTablePropertyDef then
DumpTable(TJclClrTablePropertyDef(ATable))
else if ATable.ClassType = TJclClrTableFile then
DumpTable(TJclClrTableFile(ATable))
else if ATable.ClassType = TJclClrTableManifestResource then
DumpTable(TJclClrTableManifestResource(ATable))
else if ATable.ClassType = TJclClrTableExportedType then
DumpTable(TJclClrTableExportedType(ATable));
memDump.Perform(WM_VSCROLL, SB_TOP, 0);
end;
end;
procedure TfrmTable.DumpTable(const ATable: TJclClrTableAssembly);
function GetHashAlgName(const HashAlgId: DWORD): string;
begin
{$IFDEF USE_JWA}
case HashAlgId of
CALG_MD2: Result := 'MD2';
CALG_MD4: Result := 'MD4';
CALG_MD5: Result := 'MD5';
CALG_SHA1: Result := 'SHA1';
CALG_MAC: Result := 'MAC';
else
Result := IntToHex(HashAlgId, 8);
end;
{$ELSE}
Result := IntToHex(HashAlgId, 8);
{$ENDIF}
end;
var
AFlag: TJclClrAssemblyFlag;
FlagMsg: string;
begin
Assert(ATable.RowCount = 1);
with ATable[0] do
begin
Dump('Name: ' + Name);
Dump('Version: ' + Version);
FlagMsg := 'Flag: ';
for AFlag := Low(TJclClrAssemblyFlag) to High(TJclClrAssemblyFlag) do
if AFlag in Flags then
FlagMsg := FlagMsg +
GetEnumName(TypeInfo(TJclClrAssemblyFlag), Integer(AFlag)) + ' ';
Dump(FlagMsg);
if CultureOffset <> 0 then
Dump('Culture: ' + Culture);
Dump('Hash Algorithm: ' + GetHashAlgName(HashAlgId));
if Assigned(PublicKey) then
Dump('Public Key: ', PublicKey);
end;
end;
procedure TfrmTable.DumpTable(const ATable: TJclClrTableAssemblyRef);
var
I: Integer;
AFlag: TJclClrAssemblyFlag;
FlagMsg: string;
Assembly: TJclClrTableAssemblyRefRow;
begin
for I:=0 to ATable.RowCount-1 do
begin
Assembly := ATable[I];
Dump('Name: ' + Assembly.Name);
Dump('Version: ' + Assembly.Version);
FlagMsg := 'Flag: ';
for AFlag := Low(TJclClrAssemblyFlag) to High(TJclClrAssemblyFlag) do
if AFlag in Assembly.Flags then
FlagMsg := FlagMsg +
GetEnumName(TypeInfo(TJclClrAssemblyFlag), Integer(AFlag)) + ' ';
Dump(FlagMsg);
if Assembly.CultureOffset <> 0 then
Dump('Culture: ' + Assembly.Culture);
if Assigned(Assembly.PublicKeyOrToken) then
Dump('Public Key or Token: ', Assembly.PublicKeyOrToken);
if Assigned(Assembly.HashValue) then
Dump('Hash Value: ', Assembly.HashValue);
Dump(lkWide);
end;
end;
procedure TfrmTable.DumpTable(const ATable: TJclClrTableAssemblyOS);
function GetOSName(const PlatformID: DWORD): string;
begin
case PlatformID of
VER_PLATFORM_WIN32s: Result := 'Win32s';
VER_PLATFORM_WIN32_WINDOWS: Result := 'Windows';
VER_PLATFORM_WIN32_NT: Result := 'WinNT';
else
Result := IntToHex(PlatformID, 8);
end;
end;
var
I: Integer;
begin
for I:=0 to ATable.RowCount-1 do
begin
Dump('OS : ' + GetOSName(ATable[I].PlatformID));
Dump('Version: ' + ATable[I].Version);
end;
end;
procedure TfrmTable.DumpTable(const ATable: TJclClrTableAssemblyProcessor);
function GetProcessName(const Processor: DWORD): string;
begin
{$IFDEF USE_JWA}
case Processor of
PROCESSOR_INTEL_386: Result := 'Intel 386';
PROCESSOR_INTEL_486: Result := 'Intel 486';
PROCESSOR_INTEL_PENTIUM: Result := 'Intel Pentium';
PROCESSOR_INTEL_IA64: Result := 'Intel IA64';
PROCESSOR_MIPS_R4000: Result := 'MIPS R4000';
PROCESSOR_ALPHA_21064: Result := 'Alpha 21064';
PROCESSOR_PPC_601: Result := 'Power PC 601';
PROCESSOR_PPC_603: Result := 'Power PC 603';
PROCESSOR_PPC_604: Result := 'Power PC 604';
PROCESSOR_PPC_620: Result := 'Power PC 620';
PROCESSOR_OPTIL: Result := 'MS IL';
else
Result := IntToStr(Processor) + ' [' + IntToHex(Processor, 8) + ']';
end;
{$ELSE}
Result := IntToStr(Processor) + ' [' + IntToHex(Processor, 8) + ']';
{$ENDIF}
end;
var
I: Integer;
begin
for I:=0 to ATable.RowCount-1 do
begin
Dump('Processor : ' + GetProcessName(ATable[I].Processor));
end;
end;
procedure TfrmTable.DumpTable(const ATable: TJclClrTableModule);
begin
Assert(ATable.RowCount = 1);
with ATable[0] do
begin
Dump('Name : %s', [Name]);
Dump('Mvid : %s', [GUIDToString(Mvid)]);
if HasEncId then
Dump('EncId : %s', [GUIDToString(EncId)]);
if HasEncBaseId then
Dump('EncBaseId: %s', [GUIDToString(EncBaseId)]);
end;
end;
procedure TfrmTable.DumpTable(const ATable: TJclClrTableModuleRef);
var
I: Integer;
begin
for I:=0 to ATable.RowCount-1 do
Dump('Name : ' + ATable[I].Name);
end;
procedure TfrmTable.DumpTable(const ATable: TJclClrTableTypeDef);
const
ClassSemanticsNames: array[TJclClrClassSemantics] of string =
('.class', 'interface');
TypeVisibilityNames: array[TJclClrTypeVisibility] of string =
('private', 'public', 'nested public', 'nested private', 'nested family',
'nested assembly', 'nested famandassem', 'nested famorassem');
AbstractNames: array[Boolean] of string = ('', 'abstract ');
ClassLayoutNames: array[TJclClrClassLayout] of string =
('auto', 'sequential', 'explicit');
StringFormattingNames: array[TJclClrStringFormatting] of string =
('ansi', 'unicode', 'autochar');
ImportNames: array[Boolean] of string = ('', 'import ');
SerializableNames: array[Boolean] of string = ('', 'serializable');
SealedNames: array[Boolean] of string = ('', 'sealed ');
SpecialNameNames: array[Boolean] of string = ('', 'specialname ');
BeforeFieldInitNames: array[Boolean] of string = ('', 'beforefieldinit ');
RTSpecialNameNames: array[Boolean] of string = ('', 'rtspecialname ');
HasSecurityNames: array[Boolean] of string = ('', 'HasSecurity ');
var
I, J: Integer;
begin
for I:=0 to ATable.RowCount-1 do
with ATable.Rows[I] do
begin
Dump('%s %s %s%s %s %s%s%s%s%s%s%s%s',
[ClassSemanticsNames[ClassSemantics],
TypeVisibilityNames[Visibility],
AbstractNames[taAbstract in Attributes],
ClassLayoutNames[ClassLayout],
StringFormattingNames[StringFormatting],
ImportNames[taImport in Attributes],
SerializableNames[taSerializable in Attributes],
SealedNames[taSealed in Attributes],
SpecialNameNames[taSpecialName in Attributes],
BeforeFieldInitNames[taBeforeFieldInit in Attributes],
RTSpecialNameNames[taRTSpecialName in Attributes],
HasSecurityNames[taHasSecurity in Attributes],
FullName]);
if HasField then
for J:=0 to FieldCount-1 do
Dump(' .field %s', [Fields[J].Name]);
if HasMethod then
for J:=0 to MethodCount-1 do
Dump(' .method %s', [Methods[J].Name]);
end;
end;
procedure TfrmTable.DumpTable(const ATable: TJclClrTableTypeRef);
var
I: Integer;
begin
for I:=0 to ATable.RowCount-1 do
Dump('%s.%s', [ATable.Rows[I].Namespace, ATable.Rows[I].Name])
end;
procedure TfrmTable.DumpTable(const ATable: TJclClrTableMethodDef);
var
I, J: Integer;
AttrStr, ParamStr: string;
begin
for I:=0 to ATable.RowCount-1 do
with ATable.Rows[I] do
begin
if HasParam then
begin
ParamStr := '';
for J:=0 to ParamCount-1 do
begin
if ParamStr <> '' then
ParamStr := ParamStr + ', ';
if Params[J].Flags <> [] then
begin
AttrStr := '';
if pkIn in Params[J].Flags then
AttrStr := AttrStr + 'In';
if pkOut in Params[J].Flags then
begin
if AttrStr <> '' then
AttrStr := AttrStr + ', ';
AttrStr := AttrStr + 'Out';
end;
if pkOptional in Params[J].Flags then
begin
if AttrStr <> '' then
AttrStr := AttrStr + ', ';
AttrStr := AttrStr + 'Opt';
end;
if pkHasDefault in Params[J].Flags then
begin
if AttrStr <> '' then
AttrStr := AttrStr + ', ';
AttrStr := AttrStr + 'Default';
end;
if pkHasFieldMarshal in Params[J].Flags then
begin
if AttrStr <> '' then
AttrStr := AttrStr + ', ';
AttrStr := AttrStr + 'Marshal';
end;
ParamStr := ParamStr + '[' + AttrStr + '] ';
end;
ParamStr := ParamStr + Params[J].Name;
end;
end;
if Assigned(MethodBody) then
begin
Dump('%s.%s::%s(%s) @ %p:%d', [ParentToken.Namespace, ParentToken.Name, Name, ParamStr, Pointer(RVA), MethodBody.Size]);
TfrmAbstract.DumpBuf(MethodBody.Code, MethodBody.Size, memDump, DWORD(MethodBody.Code), False);
end
else
begin
Dump('%s.%s::%s(%s)', [ParentToken.Namespace, ParentToken.Name, Name, ParamStr]);
end;
end;
end;
procedure TfrmTable.DumpTable(const ATable: TJclClrTableFieldDef);
var
I: Integer;
begin
for I:=0 to ATable.RowCount-1 do
Dump('%s', [ATable.Rows[I].Name])
end;
procedure TfrmTable.DumpTable(const ATable: TJclClrTableMemberRef);
var
I: Integer;
begin
for I:=0 to ATable.RowCount-1 do
Dump('%s', [ATable.Rows[I].Name])
end;
procedure TfrmTable.DumpTable(const ATable: TJclClrTableCustomAttribute);
function GetParent(const Attr: TJclClrTableCustomAttributeRow): string;
var
ARow: TJclClrTableRow;
begin
ARow := Attr.Parent;
if ARow is TJclClrTableAssemblyRow then
with ARow as TJclClrTableAssemblyRow do
Result := Name
else if ARow is TJclClrTableTypeDefRow then
with ARow as TJclClrTableTypeDefRow do
Result := Namespace + '.' + Name
else if ARow is TJclClrTableTypeRefRow then
with ARow as TJclClrTableTypeRefRow do
Result := Namespace + '.' + Name
else if ARow is TJclClrTableMethodDefRow then
with ARow as TJclClrTableMethodDefRow do
Result := Name
else if ARow is TJclClrTableParamDefRow then
with ARow as TJclClrTableParamDefRow do
Result := Method.ParentToken.Namespace + '.' + Method.ParentToken.Name + '::' +
Method.Name + '(..., ' + Name + ', ...)'
else
Result := 'Unknown Parent';
Result := Result + ' <' + Copy(ARow.ClassName, Length('TJclClrTable')+1,
Length(ARow.ClassName)-Length('TJclClrTable')-Length('Row')) +
'> [' + IntToHex(Attr.ParentIdx, 8) + ']';
end;
function GetMethod(const Attr: TJclClrTableCustomAttributeRow): string;
function GetParentClassName(const ParentClass: TJclClrTableRow): string;
begin
if ParentClass is TJclClrTableTypeRefRow then
with ParentClass as TJclClrTableTypeRefRow do
Result := Namespace + '.' + Name
else if ParentClass is TJclClrTableModuleRefRow then
with ParentClass as TJclClrTableModuleRefRow do
Result := Name
else if ParentClass is TJclClrTableMethodDefRow then
with ParentClass as TJclClrTableMethodDefRow do
Result := Name
else if ParentClass is TJclClrTableTypeSpecRow then
Result := ''
else if ParentClass is TJclClrTableTypeDefRow then
with ParentClass as TJclClrTableTypeDefRow do
Result := Namespace + '.' + Name
else
Result := 'Unknown Class - ' + ParentClass.ClassName;
end;
var
AMethod: TJclClrTableRow;
begin
AMethod := Attr.Method;
if AMethod is TJclClrTableMethodDefRow then
with AMethod as TJclClrTableMethodDefRow do
Result := ParentToken.Namespace + '.' + ParentToken.Name + ' :: ' + Name
else if AMethod is TJclClrTableMemberRefRow then
with AMethod as TJclClrTableMemberRefRow do
Result := GetParentClassName(ParentClass) + '::' + Name
else
Result := 'Unknown method type - ' + IntToHex(Attr.ParentIdx, 8);
Result := Result + ' <' + Copy(AMethod.ClassName, Length('TJclClrTable')+1,
Length(AMethod.ClassName)-Length('TJclClrTable')-Length('Row')) +
'> [' + IntToHex(Attr.TypeIdx, 8) + ']';
end;
var
I: Integer;
begin
for I:=0 to ATable.RowCount-1 do
begin
Dump('Parent: ' + GetParent(ATable[I]));
Dump('Method: ' + GetMethod(ATable[I]));
Dump('Value: ', ATable[I].Value);
Dump(lkWide);
end;
end;
procedure TfrmTable.DumpTable(const ATable: TJclClrTableParamDef);
var
I: Integer;
Attr: string;
begin
for I:=0 to ATable.RowCount-1 do
begin
Attr := '';
if pkIn in ATable.Rows[I].Flags then
Attr := Attr + 'In ';
if pkOut in ATable.Rows[I].Flags then
Attr := Attr + 'Out ';
if pkOptional in ATable.Rows[I].Flags then
Attr := Attr + 'Opt ';
if pkHasDefault in ATable.Rows[I].Flags then
Attr := Attr + 'Default ';
if pkHasFieldMarshal in ATable.Rows[I].Flags then
Attr := Attr + 'Marshal ';
Dump('%s %s', [ATable.Rows[I].Name, Attr]);
end;
end;
procedure TfrmTable.DumpTable(const ATable: TJclClrTablePropertyDef);
var
I: Integer;
begin
for I:=0 to ATable.RowCount-1 do
Dump('%s', [ATable.Rows[I].Name])
end;
procedure TfrmTable.DumpTable(const ATable: TJclClrTableManifestResource);
var
I: Integer;
begin
for I:=0 to ATable.RowCount-1 do
Dump('%s', [ATable.Rows[I].Name])
end;
procedure TfrmTable.DumpTable(const ATable: TJclClrTableFile);
var
I: Integer;
begin
for I:=0 to ATable.RowCount-1 do
begin
Dump('File Name: ' + ATable[I].Name);
Dump('Contains Metadata: ' + BooleanToStr(ATable[I].ContainsMetadata));
Dump('Hash Value: ', ATable[I].HashValue);
end;
end;
procedure TfrmTable.DumpTable(const ATable: TJclClrTableExportedType);
var
I: Integer;
begin
for I:=0 to ATable.RowCount-1 do
Dump(ATable[I].TypeNamespace + '.' + ATable[I].TypeName);
end;
procedure TfrmTable.btnDumpILClick(Sender: TObject);
begin
frmMain.actFileDump.Execute;
end;
end.