typinfoex.pas

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

function DoCollect(AData: PCollectEnumData; ATypeInfo: PTypeInfo): Boolean; register;
begin
  with AData^ do
    if not Assigned(ACallback) or ACallback(AUserData, ATypeInfo) then
    begin
      if ACount mod 256 = 0 then SetLength(AResult, ACount + 256);
      AResult[ACount] := ATypeInfo;
      Inc(ACount);
    end;
  Result := False;
end;

function CollectTypeInfo(ACallback: TTypeInfoEnumCallback; AModule: LongWord; AUserData: Pointer): TTypeInfoArray;
var
  Data: TCollectEnumData;
begin
  Data.ACallback := ACallback;
  Data.AUserData := AUserData;
  Data.ACount := 0;
  Data.AResult := nil;
  EnumTypeInfo(@DoCollect, AModule, @Data);
  SetLength(Data.AResult, Data.ACount);
  Result := Data.AResult;
end;

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

function CollectTypeInfo(const ATypeInfoArray: TTypeInfoArray; ACallback: TTypeInfoEnumCallback; AUserData: Pointer): TTypeInfoArray;
var
  Data: TCollectEnumData;
  I: Integer;
begin
  Data.ACallback := ACallback;
  Data.AUserData := AUserData;
  Data.ACount := 0;
  Data.AResult := nil;
  for I := Low(ATypeInfoArray) to High(ATypeInfoArray) do
    DoCollect(@Data, ATypeInfoArray[I]);
  SetLength(Data.AResult, Data.ACount);
  Result := Data.AResult;
end;

function CollectTypeInfo(const ATypeInfoArray: TTypeInfoArray; const ACallback: TTypeInfoEnumMethod): TTypeInfoArray;
begin
  if not Assigned(ACallback) then Result := CollectTypeInfo(ATypeInfoArray, nil)
    else Result := CollectTypeInfo(ATypeInfoArray, TMethod(ACallback).Code, TMethod(ACallback).Data);
end;

function FindHInstanceOfTypeInfo(ATypeInfo: PTypeInfo): LongWord;
begin
  Result := FindHInstance(ATypeInfo);
end;

function ModuleHasType(AModule: LongWord; ATypeInfo: PTypeInfo): Boolean;
begin
  Result := AModule = FindHInstanceOfTypeInfo(ATypeInfo);
end;

function CollectInterfaces(AModule: LongWord): TTypeInfoArray;

  function DoCollect(Dummy: Pointer; ATypeInfo: PTypeInfo): Boolean; register;
  begin
    Result := ATypeInfo.Kind = tkInterface;
  end;

begin
  Result := CollectTypeInfo(@DoCollect, AModule);
end;

function DoGUID(AGUID: PGUID; ATypeInfo: PTypeInfo): Boolean; register;
begin
  if ATypeInfo.Kind <> tkInterface then Result := False else
    with GetTypeData(ATypeInfo)^ do
      Result := (ifHasGuid in IntfFlags) and (CompareGUID(GUID, AGUID^) = 0);
end;

function FindTypeInfo(const ATypeInfoArray: TTypeInfoArray; const AGUID: TGUID): PTypeInfo;
begin
  Result := EnumTypeInfo(ATypeInfoArray, @DoGUID, @AGUID);
end;

function FindTypeInfo(const AGUID: TGUID; AModule: LongWord): PTypeInfo;
begin
  Result := EnumTypeInfo(@DoGUID, AModule, @AGUID);
end;

function DoTypeName(AName: PChar; ATypeInfo: PTypeInfo): Boolean; register;
begin
  Result := AnsiCompareText(AName, ATypeInfo.Name) = 0;
end;

function FindTypeInfo(const ATypeName: String; AModule: LongWord): PTypeInfo;
begin
  Result := EnumTypeInfo(@DoTypeName, AModule, PChar(ATypeName));
end;

function FindTypeInfo(const ATypeInfoArray: TTypeInfoArray; const ATypeName: String): PTypeInfo;
begin
  Result := EnumTypeInfo(ATypeInfoArray, @DoTypeName, PChar(ATypeName));
end;

function TypeInfoToClass(ATypeInfo: PTypeInfo): TClass;
begin
  if not Assigned(ATypeInfo) or (ATypeInfo.Kind <> tkClass) then Result := nil
    else Result := GetTypeData(ATypeInfo).ClassType;
end;

function FindClassByName(const AClassName: String; AModule: LongWord): TClass;
begin
  Result := TypeInfoToClass(FindTypeInfo(AClassName, AModule));
end;

function FindClassByName(const ATypeInfoArray: TTypeInfoArray; const AClassName: String): TClass;
begin
  Result := TypeInfoToClass(FindTypeInfo(ATypeInfoArray, AClassName));
end;

function DoClass(AInheritsFrom: TClass; ATypeInfo: PTypeInfo): Boolean; register;
begin
  Result := (ATypeInfo.Kind = tkClass) and GetTypeData(ATypeInfo).ClassType.InheritsFrom(AInheritsFrom);
end;

function FindClasses(AInheritsFrom: TClass; AModule: LongWord): TTypeInfoArray;
begin
  Result := CollectTypeInfo(@DoClass, AModule, AInheritsFrom);
end;

function FindClasses(const ATypeInfoArray: TTypeInfoArray; AInheritsFrom: TClass): TTypeInfoArray;
begin
  Result := CollectTypeInfo(ATypeInfoArray, @DoClass, AInheritsFrom);
end;

function DoClassGUID(AClass: TClass; ATypeInfo: PTypeInfo): Boolean; register;
begin
  if (AClass = nil) or (ATypeInfo.Kind <> tkInterface) then Result := False else
    with GetTypeData(ATypeInfo)^ do
      Result := (ifHasGuid in IntfFlags) and (AClass.GetInterfaceEntry(GUID) <> nil);
end;

function CollectInterfaceTypesOfClass(AClass: TClass; AModule: LongWord): TTypeInfoArray;
begin
  Result := CollectTypeInfo(@DoClassGUID, AModule, AClass);
end;

function CollectInterfaceTypesOfClass(const ATypeInfoArray: TTypeInfoArray; AClass: TClass): TTypeInfoArray;
begin
  Result := CollectTypeInfo(ATypeInfoArray, @DoClassGUID, AClass);
end;

function SortTypeInfoArray(var ATypeInfoArray: TTypeInfoArray; ACallback: TTypeInfoSortCallback; AUserData: Pointer): Boolean;

  procedure QuickSort(L,R: Integer);
  var
    I,J: Integer;
    M,T: PTypeInfo;
  begin
    I := L;
    repeat
      L := I;
      J := R;
      M := ATypeInfoArray[(L + R) shr 1];
      repeat
        while ACallback(AUserData, ATypeInfoArray[I], M) < 0 do Inc(I);
        while ACallback(AUserData, ATypeInfoArray[J], M) > 0 do Dec(J);
        if I > J then Break;
        T := ATypeInfoArray[I];
        ATypeInfoArray[I] := ATypeInfoArray[J];
        ATypeInfoArray[J] := T;
        Inc(I);
        Dec(J);
      until I > J;
      if L < J then QuickSort(L, J);
    until I >= R;
  end;

begin
  Result := Assigned(ACallback) and (High(ATypeInfoArray) > 0);
  if Result then QuickSort(0, High(ATypeInfoArray));
end;

function SortTypeInfoArray(var ATypeInfoArray: TTypeInfoArray; const ACallback: TTypeInfoSortMethod): Boolean;
begin
  Result := Assigned(ACallback) and SortTypeInfoArray(ATypeInfoArray, TMethod(ACallback).Code, TMethod(ACallback).Data);
end;


{
procedure Test;

  function DoPrint(AUserData: Pointer; ATypeInfo: PTypeInfo): Boolean; register;
  begin
    WriteLn(ATypeInfo.Name);
    Result := False;
  end;

  function DoSort(Dummy: Pointer; ATypeInfo1, ATypeInfo2: PTypeInfo): Integer; register;
  begin
    Result := AnsiCompareText(ATypeInfo1.Name, ATypeInfo2.Name);
  end;

var
  L: TTypeInfoArray;
begin
  L := CollectTypeInfo(nil);
  SortTypeInfoArray(L, @DoSort);
  EnumTypeInfo(L, @DoPrint);
end;
}

end.