clrdemotableform.pas

East make Tray Icon in delphi

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