typinfoex.pas

cipher 5.1。一个几乎包含了所有常见的加密算法的控件

{Copyright:      Heiko Behrens, Hagen Reddmann
 Author:         Heiko Behrens (Initiator and Developer), Hagen Reddmann
 Descriptions:   TypeInfoEx allows RTTI retrieval of all modules (BPLs, Dlls) in a
                 comfortable and reversed way.
 Versions:       Delphi 5 and above, testet on D5
 Remarks:        this Copyright must be included


 * THIS SOFTWARE IS PROVIDED BY THE AUTHORS ''AS IS'' AND ANY EXPRESS
 * OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
 * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 * ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE
 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
 * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
 * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
 * EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

}
unit TypInfoEx;

interface

uses TypInfo;

type
  TTypeInfoArray = array of PTypeInfo;
  TTypeInfoEnumCallback = function(AUserData: Pointer; ATypeInfo: PTypeInfo): Boolean; register;
  TTypeInfoEnumMethod = function(ATypeInfo: PTypeInfo): Boolean of object;
  TTypeInfoSortCallback = function(AUserData: Pointer; ATypeInfo1, ATypeInfo2: PTypeInfo): Integer; register;
  TTypeInfoSortMethod = function(ATypeInfo1, ATypeInfo2: PTypeInfo): Integer of object;

const
  allModules = 0;

// enumeriert 黚er alle RTTI Records eines Modules oder aller geladenen Module, gibt gefundene PTypeInfo zur點k falls ACallback TRUE ergibt
// falls ACallback =nil gibt die Funktion den ersten RTTI Record zur點k
function EnumTypeInfo(ACallback: TTypeInfoEnumCallback; AModule: LongWord = allModules; AUserData: Pointer = nil): PTypeInfo; overload;
// enumeriert 黚er alle RTTI Records eines TTypeInfoArray's, gibt gefundene PTypeInfo zur點k falls ACallback TRUE ergibt
function EnumTypeInfo(const ATypeInfoArray: TTypeInfoArray; ACallback: TTypeInfoEnumCallback; AUserData: Pointer = nil): PTypeInfo; overload;
function EnumTypeInfo(const ACallback: TTypeInfoEnumMethod; AModule: LongWord = allModules): PTypeInfo; overload;
// erzeugt ein Array aller PTypeInfo's die ACallback mit TRUE filtert
// falls ACallback =nil gibt die Funktion alle RTTI Record's zur點k
function CollectTypeInfo(ACallback: TTypeInfoEnumCallback; AModule: LongWord = allModules; AUserData: Pointer = nil): TTypeInfoArray; overload;
function CollectTypeInfo(const ACallback: TTypeInfoEnumMethod; AModule: LongWord = allModules): TTypeInfoArray; overload;
function CollectTypeInfo(const ATypeInfoArray: TTypeInfoArray; ACallback: TTypeInfoEnumCallback; AUserData: Pointer = nil): TTypeInfoArray; overload;
function CollectTypeInfo(const ATypeInfoArray: TTypeInfoArray; const ACallback: TTypeInfoEnumMethod): TTypeInfoArray; overload;
// erzeugt ein Array aller PTypeInfo's die ein Interface darstellen
function CollectInterfaces(AModule: LongWord = allModules): TTypeInfoArray;
// erzeugt ein Array aller PTypeInfo's die ein Interface darstellen und durch die Klasse AClass impelemntiert werden
function CollectInterfaceTypesOfClass(AClass: TClass = nil; AModule: LongWord = 0): TTypeInfoArray; overload;
function CollectInterfaceTypesOfClass(const ATypeInfoArray: TTypeInfoArray; AClass: TClass = nil): TTypeInfoArray; overload;
// sucht TypeInfo des Interfaces das die AGUID hat
function FindTypeInfo(const ATypeInfoArray: TTypeInfoArray; const AGUID: TGUID): PTypeInfo; overload;
function FindTypeInfo(const AGUID: TGUID; AModule: LongWord = allModules): PTypeInfo; overload;
// sucht TypeInfo mit dem TypeName
function FindTypeInfo(const ATypeName: String; AModule: LongWord = allModules): PTypeInfo; overload;
function FindTypeInfo(const ATypeInfoArray: TTypeInfoArray; const ATypeName: String): PTypeInfo; overload;
// sucht Klasse mit dem AClassName
function FindClassByName(const AClassName: String; AModule: LongWord = allModules): TClass; overload;
function FindClassByName(const ATypeInfoArray: TTypeInfoArray; const AClassName: String): TClass; overload;
// sucht alle TypInfo's aller Klasse die von der Klasse AInheritsFrom abgeleitet wurden
function FindClasses(AInheritsFrom: TClass; AModule: LongWord = allModules): TTypeInfoArray; overload;
function FindClasses(const ATypeInfoArray: TTypeInfoArray; AInheritsFrom: TClass): TTypeInfoArray; overload;
// wandelt ATypeInfo einer Klasse in deren Klassentyp um
function TypeInfoToClass(ATypeInfo: PTypeInfo): TClass;
// gibt das Modul zur點k in dem ATypeInfo residiert
function FindHInstanceOfTypeInfo(ATypeInfo: PTypeInfo): LongWord;
function ModuleHasType(AModule: LongWord; ATypeInfo: PTypeInfo): Boolean;
// sortiert ATypeInfoArray per ACallback
function SortTypeInfoArray(var ATypeInfoArray: TTypeInfoArray; ACallback: TTypeInfoSortCallback; AUserData: Pointer = nil): Boolean; overload;
function SortTypeInfoArray(var ATypeInfoArray: TTypeInfoArray; const ACallback: TTypeInfoSortMethod): Boolean; overload;

implementation

uses SysUtils;

function CompareGUID(const GUID1, GUID2: TGUID): Integer;
// can be used to sort a list of GUIDs
asm
        MOV   ECX,EAX
        MOV   EAX,[ECX + 0]
        SUB   EAX,[EDX + 0]
        JNZ   @Exit
        MOV   EAX,[ECX + 4]
        SUB   EAX,[EDX + 4]
        JNZ   @Exit
        MOV   EAX,[ECX + 8]
        SUB   EAX,[EDX + 8]
        JNZ   @Exit
        MOV   EAX,[ECX + 12]
        SUB   EAX,[EDX + 12]
@Exit:
end;

function DoEnumTypeInfo(AModule: LongWord; ACallback: TTypeInfoEnumCallback; AUserData: Pointer): PTypeInfo; overload;
// copyright (c) 1998 Hagen Reddmann

  function GetBaseOfCode(AModule: LongWord; var ACodeStart, ACodeEnd: PChar): Boolean; register;
  // get Codesegment pointers, check if module is a valid PE
  asm
           PUSH  EDI
           PUSH  ESI
           AND   EAX,not 3
           JZ    @@2
           CMP   Word Ptr [EAX],'ZM';
           JNE   @@1
           MOV   ESI,[EAX + 03Ch]
           CMP   Word Ptr [ESI + EAX],'EP'
           JNE   @@1
           MOV   EDI,[EAX + ESI + 014h + 008h]
           ADD   EAX,[EAX + ESI + 014h + 018h]
           ADD   EDI,EAX
           MOV   [EDX],EAX
           MOV   [ECX],EDI
           XOR   EAX,EAX
    @@1:   SETE  AL
    @@2:   POP   ESI
           POP   EDI
  end;

type
  PLongWord = ^LongWord;
  PByte = ^Byte;
var
  P,E,K,N: PChar;
  L: Integer;
begin
  Result := nil;
  try
    if GetBaseOfCode(AModule, P, E) then
      while P < E do
      begin
        LongWord(P) := LongWord(P) and not 3;
        K := P + 4;
        if (PLongWord(P)^ = LongWord(K)) and (TTypeKind(K^) >= Low(TTypeKind)) and (TTypeKind(K^) <= High(TTypeKind)) then
        begin
          L := PByte(K + 1)^;  // length Info.Name
          N := K + 2;          // @Info.Name[1]
          if (L > 0) and (N^ in ['_', 'a'..'z', 'A'..'Z']) then  // valid ident ??
          begin
            repeat
              Inc(N);
              Dec(L);
            until (L = 0) or not (N^ in ['_', 'a'..'z', 'A'..'Z', '0'..'9']);
            if L = 0 then // length and ident valid
              if not Assigned(ACallback) or ACallback(AUserData, Pointer(K)) then // tell it and if needed abort iteration
              begin
                Result := Pointer(K);
                Exit;
              end else K := N;
          end;
        end;
        P := K;
      end;
  except
  end;
end;

function EnumTypeInfo(ACallback: TTypeInfoEnumCallback; AModule: LongWord; AUserData: Pointer): PTypeInfo;
type
  PModulesEnumData = ^TModulesEnumData;
  TModulesEnumData = packed record
    ACallback: TTypeInfoEnumCallback;
    AUserData: Pointer;
    AResult: PTypeInfo;
  end;

  function DoEnum(AModule: LongWord; AData: PModulesEnumData): Boolean; register;
  begin
    with AData^ do
    begin
      AResult := DoEnumTypeInfo(AModule, ACallback, AUserData);
      Result := AResult = nil;
    end;
  end;

var
  Data: TModulesEnumData;
begin
  Data.ACallback := ACallback;
  Data.AUserData := AUserData;
  Data.AResult := nil;
  if AModule = allModules then EnumModules(TEnumModuleFuncLW(@DoEnum), @Data)
    else Data.AResult := DoEnumTypeInfo(AModule, ACallback, AUserData);
  Result := Data.AResult;
end;

function EnumTypeInfo(const ATypeInfoArray: TTypeInfoArray; ACallback: TTypeInfoEnumCallback; AUserData: Pointer): PTypeInfo;
var
  I: Integer;
begin
  Result := nil;
  for I := Low(ATypeInfoArray) to High(ATypeInfoArray) do
    if not Assigned(ACallback) or ACallback(AUserData, ATypeInfoArray[I]) then
    begin
      Result := ATypeInfoArray[I];
      Break;
    end;
end;

function EnumTypeInfo(const ACallback: TTypeInfoEnumMethod; AModule: LongWord): PTypeInfo;
begin
  if not Assigned(ACallback) then Result := EnumTypeInfo(nil, AModule)
    else Result := EnumTypeInfo(TMethod(ACallback).Code, AModule, TMethod(ACallback).Data);
end;

type
  PCollectEnumData = ^TCollectEnumData;
  TCollectEnumData =  packed record
    ACallback: TTypeInfoEnumCallback;
    AUserData: Pointer;
    ACount: Cardinal;
    AResult: TTypeInfoArray;
  end;