david
7ebea5ffa7
git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.jvcl@12 7f62d464-2af8-f54e-996c-e91b33f51cbe
987 lines
30 KiB
ObjectPascal
987 lines
30 KiB
ObjectPascal
{-----------------------------------------------------------------------------
|
|
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/MPL-1.1.html
|
|
|
|
Software distributed under the License is distributed on an "AS IS" basis,
|
|
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
|
|
the specific language governing rights and limitations under the License.
|
|
|
|
The Original Code is: JvDataProviderItemDesign.pas, released on 2003-06-27.
|
|
|
|
The Initial Developers of the Original Code is Marcel Bestebroer.
|
|
Portions created by Marcel Bestebroer are Copyright (C) 2002 - 2003 Project JEDI
|
|
All Rights Reserved.
|
|
|
|
Contributor(s): -
|
|
|
|
You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
|
|
located at http://jvcl.sourceforge.net
|
|
|
|
Known Issues:
|
|
-----------------------------------------------------------------------------}
|
|
// $Id: JvDataProviderItemDesign.pas 11891 2008-09-09 20:33:00Z obones $
|
|
|
|
unit JvDataProviderItemDesign;
|
|
|
|
{$I jvcl.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils, TypInfo,
|
|
JvDataProvider, JvDataProviderIntf;
|
|
|
|
type
|
|
{ Default item designer for IJvDataItem and its supporting interfaces. This designer is able to handle any IJvDataItem
|
|
implementation and injects properties based on the interfaces it supports. This is accomplished by descendants of
|
|
this class (called Views in this context), which can not contain instance fields and who's published properties are
|
|
read and injected into the main designer class. Each descendant should be linked to its accompanying interface using
|
|
the RegisterDataItemIntfProp routine. Note that for the standard interfaces views have already been registered.
|
|
|
|
The downside is that you can only edit properties for registered interfaces. In some situations an interface could
|
|
be setup in multiple ways, ie. using a reference to a TAction or using a simple event, and the system is not able
|
|
to distinguish these two options (unless you provide a separate interface for each possibility and register a view
|
|
for it. See TBaseItemDsgn for the class that is used when the implementer of IJvDataItem is based on the
|
|
TExtensibleInterfacedPersistent class, providing a more flexible approach. }
|
|
TJvDataProviderItem = class(TPersistent)
|
|
private
|
|
FItem: IJvDataItem;
|
|
protected
|
|
function Item: IJvDataItem;
|
|
function GetOwner: TPersistent; override;
|
|
public
|
|
constructor Create(AnItem: IJvDataItem);
|
|
function GetNamePath: string; override;
|
|
end;
|
|
|
|
TJvDataProviderItemClass = class of TJvDataProviderItem;
|
|
|
|
{ Item designer based on implementations with TExtenisbleInterfacedPersistent as their base. Since these
|
|
implementations have access to the various implementers more directly, the property injection is handled slightly
|
|
different.
|
|
|
|
Instead of creating a single instance and linking it to the IJvDataItem implementation, we simply inject the
|
|
published properties from the implementers, and revert it when the item is deselected. The required amount of memory
|
|
is pre-calculated, too, to avoid possible access violations in case there are a lot of implementers and/or
|
|
properties to inject.
|
|
|
|
The downside is a decrease in performance, though the difference isn't much of an issue when in designing mode (who
|
|
really notices or cares about the difference between waiting 10ms or 100ms after selecting an item and seeing its
|
|
properties appear in the Object Inspector?).
|
|
}
|
|
TBaseItemDsgn = class (TExtensibleInterfacedPersistent)
|
|
private
|
|
function GetIsStoredProp(Index: Integer): Boolean;
|
|
{$IFDEF COMPILER10_UP}
|
|
function GetDynArrayProp(Index: Integer): Pointer;
|
|
procedure SetDynArrayProp(Index: Integer; Value: Pointer);
|
|
{$ENDIF COMPILER10_UP}
|
|
function GetFloatProp(Index: Integer): Extended;
|
|
procedure SetFloatProp(Index: Integer; Value: Extended);
|
|
function GetInt64Prop(Index: Integer): Int64;
|
|
procedure SetInt64Prop(Index: Integer; Value: Int64);
|
|
{$IFDEF COMPILER6_UP}
|
|
function GetInterfaceProp(Index: Integer): IInterface;
|
|
procedure SetInterfaceProp(Index: Integer; Value: IInterface);
|
|
{$ENDIF COMPILER6_UP}
|
|
function GetMethodProp(Index: Integer): TMethod;
|
|
procedure SetMethodProp(Index: Integer; Value: TMethod);
|
|
function GetOrdProp(Index: Integer): Longint;
|
|
procedure SetOrdProp(Index: Integer; Value: Longint);
|
|
function GetStrProp(Index: Integer): string;
|
|
procedure SetStrProp(Index: Integer; Value: string);
|
|
function GetVariantProp(Index: Integer): Variant;
|
|
procedure SetVariantProp(Index: Integer; Value: Variant);
|
|
function GetWideStrProp(Index: Integer): WideString;
|
|
procedure SetWideStrProp(Index: Integer; Value: WideString);
|
|
protected
|
|
procedure GetPropDataFromIndex(Index: Integer; out Instance: TObject; out Info: PPropInfo);
|
|
procedure InjectImplementers;
|
|
procedure RevertRTTI;
|
|
end;
|
|
|
|
// Free the item designer
|
|
procedure FreeItemDesigner(var designer: TPersistent);
|
|
// Retrieve an instance of the designer for the given item
|
|
function GetItemDesigner(AnItem: IJvDataItem): TPersistent;
|
|
// Register a property view for an IJvDataItem support interface
|
|
procedure RegisterDataItemIntfProp(const IID: TGUID; const PropClass: TJvDataProviderItemClass);
|
|
|
|
implementation
|
|
|
|
uses
|
|
Windows, ImgList,
|
|
JclSysUtils,
|
|
JvDsgnConsts, JvJCLUtils, JvVCL5Utils;
|
|
|
|
type
|
|
PPropData = ^TPropData;
|
|
|
|
TIntfItem = record
|
|
GUID: TGUID;
|
|
PropClass: TJvDataProviderItemClass;
|
|
end;
|
|
TIntfItems = array of TIntfItem;
|
|
|
|
var
|
|
GIntfPropReg: TIntfItems;
|
|
|
|
procedure FreeItemDesigner(var designer: TPersistent);
|
|
var
|
|
obj: TPersistent;
|
|
begin
|
|
obj := designer;
|
|
designer := nil;
|
|
if (obj <> nil) then
|
|
begin
|
|
if obj is TJvDataProviderItem then
|
|
// free the instance of TJvDataProviderItem we created in GetItemDesigner
|
|
obj.Free
|
|
else
|
|
// revert our changes to the RTTI
|
|
TBaseItemDsgn(obj).RevertRTTI;
|
|
end;
|
|
end;
|
|
|
|
function GetItemDesigner(AnItem: IJvDataItem): TPersistent;
|
|
var
|
|
impl: TObject;
|
|
begin
|
|
impl := AnItem.Implementer;
|
|
if (impl is TExtensibleInterfacedPersistent) then
|
|
begin
|
|
// the implementing instance will be edited directly
|
|
Result := TPersistent(impl);
|
|
// inject published properties from each of the extension implementers
|
|
TBaseItemDsgn(Result).InjectImplementers;
|
|
end
|
|
else
|
|
// create an instance of the designer; will automatically inject properties based on the interfaces it supports
|
|
Result := TJvDataProviderItem.Create(AnItem);
|
|
end;
|
|
|
|
function LocateReg(IID: TGUID): Integer;
|
|
begin
|
|
Result := High(GIntfPropReg);
|
|
while (Result >= 0) and not IsEqualGUID(GIntfPropReg[Result].GUID, IID) do
|
|
Dec(Result);
|
|
end;
|
|
|
|
procedure RegisterDataItemIntfProp(const IID: TGUID; const PropClass: TJvDataProviderItemClass);
|
|
var
|
|
IIDIdx: Integer;
|
|
begin
|
|
IIDIdx := LocateReg(IID);
|
|
if IIDIdx < 0 then
|
|
begin
|
|
IIDIdx := Length(GIntfPropReg);
|
|
SetLength(GIntfPropReg, IIDIdx + 1);
|
|
GIntfPropReg[IIDIdx].GUID := IID;
|
|
end;
|
|
GIntfPropReg[IIDIdx].PropClass := PropClass;
|
|
end;
|
|
|
|
function StringBaseLen(NumItems: Integer; StartString: PChar): Integer;
|
|
begin
|
|
Result := 0;
|
|
while NumItems > 0 do
|
|
begin
|
|
Inc(Result, 1 + PByte(StartString)^);
|
|
Inc(StartString, 1 + PByte(StartString)^);
|
|
Dec(NumItems);
|
|
end;
|
|
end;
|
|
|
|
function PropListSize(ListPos: PChar): Integer;
|
|
var
|
|
Cnt: Integer;
|
|
BaseInfoSize: Integer;
|
|
begin
|
|
Result := SizeOf(Word);
|
|
Cnt := PWord(ListPos)^;
|
|
Inc(ListPos, Result);
|
|
BaseInfoSize := SizeOf(TPropInfo) - SizeOf(ShortString) + 1;
|
|
while Cnt > 0 do
|
|
begin
|
|
Inc(Result, BaseInfoSize + Length(PPropInfo(ListPos)^.Name));
|
|
Inc(ListPos, BaseInfoSize + Length(PPropInfo(ListPos)^.Name));
|
|
Dec(Cnt);
|
|
end;
|
|
end;
|
|
|
|
function TypeInfoSize(TypeInfo: PTypeInfo): Integer;
|
|
var
|
|
TypeData: PTypeData;
|
|
begin
|
|
Result := 2 + Length(TypeInfo.Name);
|
|
TypeData := GetTypeData(TypeInfo);
|
|
case TypeInfo.Kind of
|
|
tkInteger, tkChar, tkEnumeration, tkSet, tkWChar:
|
|
begin
|
|
Inc(Result, SizeOf(TOrdType));
|
|
case TypeInfo.Kind of
|
|
tkInteger, tkChar, tkEnumeration, tkWChar:
|
|
begin
|
|
Inc(Result, 8);
|
|
if TypeInfo.Kind = tkEnumeration then
|
|
Inc(Result, 4 + StringBaseLen(TypeData.MaxValue - TypeData.MinValue + 1, @TypeData.NameList));
|
|
end;
|
|
tkSet:
|
|
Inc(Result, 4);
|
|
end;
|
|
end;
|
|
tkFloat:
|
|
Inc(Result, SizeOf(TFloatType));
|
|
tkString:
|
|
Inc(Result);
|
|
tkClass:
|
|
begin
|
|
Inc(Result, SizeOf(TClass) + SizeOf(PPTypeInfo) + SizeOf(Smallint) + StringBaseLen(1, @TypeData.UnitName));
|
|
Inc(Result, PropListSize(Pointer(Integer(@TypeData.UnitName) + StringBaseLen(1, @TypeData.UnitName))));
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function AllocTypeInfo(Size: Integer): PTypeInfo;
|
|
var
|
|
P: PPointer;
|
|
begin
|
|
P := AllocMem(SizeOf(P) + Size);
|
|
Inc(P);
|
|
Result := PTypeInfo(P);
|
|
end;
|
|
|
|
procedure FreeTypeInfo(ATypeInfo: PTypeInfo);
|
|
var
|
|
P: PPointer;
|
|
begin
|
|
P := PPointer(ATypeInfo);
|
|
Dec(P);
|
|
FreeMem(P);
|
|
end;
|
|
|
|
function GetOrgTypeInfo(ATypeInfo: PTypeInfo): PTypeInfo;
|
|
var
|
|
P: PPointer;
|
|
begin
|
|
P := PPointer(ATypeInfo);
|
|
Dec(P);
|
|
Result := P^;
|
|
end;
|
|
|
|
procedure SetOrgTypeInfo(ATypeInfo, Value: PTypeInfo);
|
|
var
|
|
P: PPointer;
|
|
begin
|
|
P := PPointer(ATypeInfo);
|
|
Dec(P);
|
|
P^ := Value;
|
|
end;
|
|
|
|
function CloneTypeInfo(OrgTypeInfo: PTypeInfo; AdditionalSpace: Longint = 0): PTypeInfo;
|
|
var
|
|
OrgSize: Integer;
|
|
begin
|
|
OrgSize := TypeInfoSize(OrgTypeInfo);
|
|
Result := AllocTypeInfo(OrgSize + AdditionalSpace);
|
|
SetOrgTypeInfo(Result, OrgTypeInfo);
|
|
Move(OrgTypeInfo^, Result^, OrgSize);
|
|
end;
|
|
|
|
function VMTTypeInfoFromClass(const AClass: TClass): PPTypeInfo;
|
|
var
|
|
P: {$IFDEF COMPILER12_UP}PByte{$ELSE}PChar{$ENDIF COMPILER12_UP};
|
|
begin
|
|
P := Pointer(AClass);
|
|
Inc(P, vmtTypeInfo); // Now pointing to TypeInfo of the VMT table.
|
|
Result := PPTypeInfo(P);
|
|
end;
|
|
|
|
procedure CreateTypeInfo(const AClass: TClass);
|
|
var
|
|
VMTTypeInfo: PPTypeInfo;
|
|
NewTypeInfo: PTypeInfo;
|
|
WrittenBytes: Cardinal;
|
|
begin
|
|
VMTTypeInfo := VMTTypeInfoFromClass(AClass);
|
|
{ Below the typeinfo is cloned, while an additional 2048 bytes are reserved at the end. This 2048
|
|
bytes will be used to "inject" additional properties. Since each property takes 27 + the length
|
|
of the property name bytes, assuming an average of 40 bytes/property will allow approximately 50
|
|
properties to be appended to the existing property list. }
|
|
// (rom) is there some security so we do not blow up everything by exceeding the 2048 bytes?
|
|
NewTypeInfo := CloneTypeInfo(VMTTypeInfo^, 2048);
|
|
if not WriteProtectedMemory(VMTTypeInfo, @NewTypeInfo, SizeOf(NewTypeInfo), WrittenBytes) then
|
|
FreeTypeInfo(NewTypeInfo);
|
|
end;
|
|
|
|
procedure ClearTypeInfo(const AClass: TClass);
|
|
var
|
|
VMTTypeInfo: PPTypeInfo;
|
|
OldTypeInfo, NewTypeInfo: PTypeInfo;
|
|
WrittenBytes: Cardinal;
|
|
begin
|
|
VMTTypeInfo := VMTTypeInfoFromClass(AClass);
|
|
OldTypeInfo := VMTTypeInfo^;
|
|
NewTypeInfo := GetOrgTypeInfo(OldTypeInfo);
|
|
|
|
WriteProtectedMemory(VMTTypeInfo, @NewTypeInfo, SizeOf(NewTypeInfo), WrittenBytes);
|
|
|
|
FreeTypeInfo(OldTypeInfo);
|
|
end;
|
|
|
|
function GetPropData(TypeData: PTypeData): PPropData;
|
|
begin
|
|
Result := PPropData(Integer(@TypeData.UnitName) + StringBaseLen(1, @TypeData.UnitName));
|
|
end;
|
|
|
|
procedure ClearPropList(const AClass: TClass);
|
|
var
|
|
RTTI: PTypeInfo;
|
|
TypeData: PTypeData;
|
|
PropList: PPropData;
|
|
begin
|
|
RTTI := PTypeInfo(AClass.ClassInfo);
|
|
TypeData := GetTypeData(RTTI);
|
|
TypeData.PropCount := 0;
|
|
PropList := GetPropData(TypeData);
|
|
PropList.PropCount := 0;
|
|
end;
|
|
|
|
procedure CopyPropInfo(var Source, Dest: PPropInfo; var PropNum: Smallint);
|
|
var
|
|
BaseInfoSize: Integer;
|
|
NameLen: Integer;
|
|
begin
|
|
BaseInfoSize := SizeOf(TPropInfo) - SizeOf(ShortString) + 1;
|
|
NameLen := Length(Source.Name);
|
|
Move(Source^, Dest^, BaseInfoSize + NameLen);
|
|
Dest.NameIndex := PropNum;
|
|
Inc(PChar(Source), BaseInfoSize + NameLen);
|
|
Inc(PChar(Dest), BaseInfoSize + NameLen);
|
|
Inc(PropNum);
|
|
end;
|
|
|
|
procedure AppendPropList(const AClass: TClass; PropList: PPropInfo; Count: Integer);
|
|
var
|
|
RTTI: PTypeInfo;
|
|
TypeData: PTypeData;
|
|
ClassPropList: PPropInfo;
|
|
ExistingCount: Integer;
|
|
BaseInfoSize: Integer;
|
|
PropNum: Smallint;
|
|
begin
|
|
RTTI := PTypeInfo(AClass.ClassInfo);
|
|
TypeData := GetTypeData(RTTI);
|
|
TypeData.PropCount := TypeData.PropCount + Count;
|
|
ClassPropList := PPropInfo(GetPropData(TypeData));
|
|
ExistingCount := PPropData(ClassPropList).PropCount;
|
|
PropNum := ExistingCount;
|
|
PPropData(ClassPropList).PropCount := ExistingCount + Count;
|
|
Inc(PChar(ClassPropList), 2);
|
|
BaseInfoSize := SizeOf(TPropInfo) - SizeOf(ShortString) + 1;
|
|
while ExistingCount > 0 do
|
|
begin
|
|
Inc(PChar(ClassPropList), BaseInfoSize + Length(ClassPropList.Name));
|
|
Dec(ExistingCount);
|
|
end;
|
|
while Count > 0 do
|
|
begin
|
|
CopyPropInfo(PropList, ClassPropList, PropNum);
|
|
Dec(Count);
|
|
end;
|
|
end;
|
|
|
|
{$IFNDEF COMPILER6_UP}
|
|
function GetPropList(TypeInfo: PTypeInfo; out PropList: PPropList): Integer;
|
|
begin
|
|
Result := GetTypeData(TypeInfo)^.PropCount;
|
|
if Result > 0 then
|
|
begin
|
|
GetMem(PropList, Result * SizeOf(Pointer));
|
|
TypInfo.GetPropList(TypeInfo, tkAny, PropList);
|
|
end;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
//=== { TJvDataProviderItem } ================================================
|
|
|
|
constructor TJvDataProviderItem.Create(AnItem: IJvDataItem);
|
|
var
|
|
I: Integer;
|
|
IUnk: IUnknown;
|
|
PrpData: PPropData;
|
|
begin
|
|
inherited Create;
|
|
FItem := AnItem;
|
|
ClearPropList(ClassType);
|
|
for I := High(GIntfPropReg) downto 0 do
|
|
if Supports(AnItem, GIntfPropReg[I].GUID, IUnk) then
|
|
begin
|
|
PrpData := GetPropData(GetTypeData(GIntfPropReg[I].PropClass.ClassInfo));
|
|
AppendPropList(ClassType, PPropInfo(Cardinal(PrpData) + 2), PrpData.PropCount);
|
|
end;
|
|
end;
|
|
|
|
function TJvDataProviderItem.Item: IJvDataItem;
|
|
begin
|
|
Result := FItem;
|
|
end;
|
|
|
|
function TJvDataProviderItem.GetOwner: TPersistent;
|
|
begin
|
|
if Item <> nil then
|
|
Result := (Item.GetItems.Provider as IInterfaceComponentReference).GetComponent
|
|
else
|
|
Result := inherited GetOwner;
|
|
end;
|
|
|
|
function TJvDataProviderItem.GetNamePath: string;
|
|
var
|
|
Comp: TPersistent;
|
|
begin
|
|
Comp := GetOwner;
|
|
if (Comp <> nil) and (Comp is TComponent) then
|
|
Result := (Comp as TComponent).Name
|
|
else
|
|
Result := RsUnknown;
|
|
if Item <> nil then
|
|
Result := Result + ': Item[' + Item.GetID + ']'
|
|
else
|
|
Result := Result + ': ' + RsNoItem;
|
|
end;
|
|
|
|
//=== { TJvDataItemTextPropView } ============================================
|
|
|
|
type
|
|
TJvDataItemTextPropView = class(TJvDataProviderItem)
|
|
protected
|
|
function GetText: string;
|
|
procedure SetText(Value: string);
|
|
published
|
|
property Text: string read GetText write SetText;
|
|
end;
|
|
|
|
function TJvDataItemTextPropView.GetText: string;
|
|
begin
|
|
Result := (Item as IJvDataItemText).Text;
|
|
end;
|
|
|
|
procedure TJvDataItemTextPropView.SetText(Value: string);
|
|
begin
|
|
(Item as IJvDataItemText).Text := Value;
|
|
end;
|
|
|
|
//=== { TJvDataItemImagePropView } ===========================================
|
|
|
|
type
|
|
TJvDataItemImagePropView = class(TJvDataProviderItem)
|
|
protected
|
|
function GetAlignment: TAlignment;
|
|
procedure SetAlignment(Value: TAlignment);
|
|
function GetImageIndex: Integer;
|
|
procedure SetImageIndex(Value: Integer);
|
|
function GetSelectedIndex: Integer;
|
|
procedure SetSelectedIndex(Value: Integer);
|
|
published
|
|
property Alignment: TAlignment read GetAlignment write SetAlignment;
|
|
property ImageIndex: Integer read GetImageIndex write SetImageIndex;
|
|
property SelectedIndex: Integer read GetSelectedIndex write SetSelectedIndex;
|
|
end;
|
|
|
|
function TJvDataItemImagePropView.GetAlignment: TAlignment;
|
|
begin
|
|
Result := (Item as IJvDataItemImage).Alignment;
|
|
end;
|
|
|
|
procedure TJvDataItemImagePropView.SetAlignment(Value: TAlignment);
|
|
begin
|
|
(Item as IJvDataItemImage).Alignment := Value;
|
|
end;
|
|
|
|
function TJvDataItemImagePropView.GetImageIndex: Integer;
|
|
begin
|
|
Result := (Item as IJvDataItemImage).ImageIndex
|
|
end;
|
|
|
|
procedure TJvDataItemImagePropView.SetImageIndex(Value: Integer);
|
|
begin
|
|
(Item as IJvDataItemImage).ImageIndex := Value;
|
|
end;
|
|
|
|
function TJvDataItemImagePropView.GetSelectedIndex: Integer;
|
|
begin
|
|
Result := (Item as IJvDataItemImage).SelectedIndex;
|
|
end;
|
|
|
|
procedure TJvDataItemImagePropView.SetSelectedIndex(Value: Integer);
|
|
begin
|
|
(Item as IJvDataItemImage).SelectedIndex := Value;
|
|
end;
|
|
|
|
//=== { TJvDataItemsImagesPropView } =========================================
|
|
|
|
type
|
|
TJvDataItemsImagesPropView = class(TJvDataProviderItem)
|
|
protected
|
|
function GetDisabledImages: TCustomImageList;
|
|
procedure SetDisabledImages(Value: TCustomImageList);
|
|
function GetHotImages: TCustomImageList;
|
|
procedure SetHotImages(Value: TCustomImageList);
|
|
function GetImages: TCustomImageList;
|
|
procedure SetImages(Value: TCustomImageList);
|
|
published
|
|
property DisabledImages: TCustomImageList read GetDisabledImages write SetDisabledImages;
|
|
property HotImages: TCustomImageList read GetHotImages write SetHotImages;
|
|
property Images: TCustomImageList read GetImages write SetImages;
|
|
end;
|
|
|
|
function TJvDataItemsImagesPropView.GetDisabledImages: TCustomImageList;
|
|
begin
|
|
Result := (Item as IJvDataItemsImages).DisabledImages;
|
|
end;
|
|
|
|
procedure TJvDataItemsImagesPropView.SetDisabledImages(Value: TCustomImageList);
|
|
begin
|
|
(Item as IJvDataItemsImages).DisabledImages := Value;
|
|
end;
|
|
|
|
function TJvDataItemsImagesPropView.GetHotImages: TCustomImageList;
|
|
begin
|
|
Result := (Item as IJvDataItemsImages).HotImages;
|
|
end;
|
|
|
|
procedure TJvDataItemsImagesPropView.SetHotImages(Value: TCustomImageList);
|
|
begin
|
|
(Item as IJvDataItemsImages).HotImages := Value;
|
|
end;
|
|
|
|
function TJvDataItemsImagesPropView.GetImages: TCustomImageList;
|
|
begin
|
|
Result := (Item as IJvDataItemsImages).Images;
|
|
end;
|
|
|
|
procedure TJvDataItemsImagesPropView.SetImages(Value: TCustomImageList);
|
|
begin
|
|
(Item as IJvDataItemsImages).Images := Value;
|
|
end;
|
|
|
|
//=== { TBaseItemDsgn } ======================================================
|
|
|
|
{$IFDEF COMPILER10_UP}
|
|
function TBaseItemDsgn.GetDynArrayProp(Index: Integer): Pointer;
|
|
var
|
|
instance: TObject;
|
|
info: PPropInfo;
|
|
begin
|
|
GetPropDataFromIndex(Index, instance, info);
|
|
Result := TypInfo.GetDynArrayProp(instance, info);
|
|
end;
|
|
|
|
{$ENDIF COMPILER10_UP}
|
|
function TBaseItemDsgn.GetFloatProp(Index: Integer): Extended;
|
|
var
|
|
instance: TObject;
|
|
info: PPropInfo;
|
|
begin
|
|
GetPropDataFromIndex(Index, instance, info);
|
|
Result := TypInfo.GetFloatProp(instance, info);
|
|
end;
|
|
|
|
function TBaseItemDsgn.GetInt64Prop(Index: Integer): Int64;
|
|
var
|
|
instance: TObject;
|
|
info: PPropInfo;
|
|
begin
|
|
GetPropDataFromIndex(Index, instance, info);
|
|
Result := TypInfo.GetInt64Prop(instance, info);
|
|
end;
|
|
|
|
function TBaseItemDsgn.GetIsStoredProp(Index: Integer): Boolean;
|
|
var
|
|
instance: TObject;
|
|
info: PPropInfo;
|
|
begin
|
|
GetPropDataFromIndex(Index, instance, info);
|
|
Result := TypInfo.IsStoredProp(instance, info);
|
|
end;
|
|
|
|
{$IFDEF COMPILER6_UP}
|
|
function TBaseItemDsgn.GetInterfaceProp(Index: Integer): IInterface;
|
|
var
|
|
instance: TObject;
|
|
info: PPropInfo;
|
|
begin
|
|
GetPropDataFromIndex(Index, instance, info);
|
|
Result := TypInfo.GetInterfaceProp(instance, info);
|
|
end;
|
|
|
|
{$ENDIF COMPILER6_UP}
|
|
|
|
function TBaseItemDsgn.GetMethodProp(Index: Integer): TMethod;
|
|
var
|
|
instance: TObject;
|
|
info: PPropInfo;
|
|
begin
|
|
GetPropDataFromIndex(Index, instance, info);
|
|
Result := TypInfo.GetMethodProp(instance, info);
|
|
end;
|
|
|
|
function TBaseItemDsgn.GetOrdProp(Index: Integer): Longint;
|
|
var
|
|
instance: TObject;
|
|
info: PPropInfo;
|
|
begin
|
|
GetPropDataFromIndex(Index, instance, info);
|
|
Result := TypInfo.GetOrdProp(instance, info);
|
|
end;
|
|
|
|
procedure TBaseItemDsgn.GetPropDataFromIndex(Index: Integer; out Instance: TObject; out Info: PPropInfo);
|
|
var
|
|
props: PPropList;
|
|
begin
|
|
// instance is the implementer at index specified in the high-word of the Index parameter
|
|
Instance := GetImplementer(HiWord(Index));
|
|
// Retrieve the property list
|
|
GetPropList(PTypeInfo(Instance.ClassInfo), props);
|
|
try
|
|
// Get the property at the index specified in the low-word of the Index parameter
|
|
Info := props[LoWord(Index)];
|
|
finally
|
|
FreeMem(props);
|
|
end;
|
|
end;
|
|
|
|
function TBaseItemDsgn.GetStrProp(Index: Integer): string;
|
|
var
|
|
instance: TObject;
|
|
info: PPropInfo;
|
|
begin
|
|
GetPropDataFromIndex(Index, instance, info);
|
|
Result := TypInfo.GetStrProp(instance, info);
|
|
end;
|
|
|
|
function TBaseItemDsgn.GetVariantProp(Index: Integer): Variant;
|
|
var
|
|
instance: TObject;
|
|
info: PPropInfo;
|
|
begin
|
|
GetPropDataFromIndex(Index, instance, info);
|
|
Result := TypInfo.GetVariantProp(instance, info);
|
|
end;
|
|
|
|
function TBaseItemDsgn.GetWideStrProp(Index: Integer): WideString;
|
|
var
|
|
instance: TObject;
|
|
info: PPropInfo;
|
|
begin
|
|
GetPropDataFromIndex(Index, instance, info);
|
|
{$IFDEF COMPILER6_UP}
|
|
Result := TypInfo.GetWideStrProp(instance, info);
|
|
{$ELSE ~COMPILER6_UP}
|
|
Result := TypInfo.GetStrProp(instance, info);
|
|
{$ENDIF ~COMPILER6_UP}
|
|
end;
|
|
|
|
procedure TBaseItemDsgn.InjectImplementers;
|
|
var
|
|
lstSize: Integer;
|
|
numNewProps: Integer;
|
|
implInst: TAggregatedPersistentEx;
|
|
implProps: PPropList;
|
|
destProp: PPropInfo;
|
|
destIdx: Integer;
|
|
|
|
procedure CalcAdditionalSize;
|
|
var
|
|
implIndex: Integer;
|
|
thisCount: Integer;
|
|
propIndex: Integer;
|
|
begin
|
|
lstSize := 0;
|
|
numNewProps := 0;
|
|
// iterate over the extension list
|
|
for implIndex := 0 to ImplCount - 1 do
|
|
begin
|
|
// get the implementation
|
|
implInst := GetImplementer(implIndex);
|
|
// get the property info list, including inherited properties
|
|
thisCount := GetPropList(PTypeInfo(implInst.ClassInfo), implProps);
|
|
try
|
|
// update the count
|
|
Inc(numNewProps, thisCount);
|
|
// iterate to determine size
|
|
for propIndex := 0 to thisCount - 1 do
|
|
Inc(lstSize, SizeOf(TPropInfo) - SizeOf(ShortString) + 1 + Length(implProps[propIndex].Name));
|
|
finally
|
|
FreeMem(implProps);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function CreateClonedTypeInfo: Boolean;
|
|
var
|
|
VMTTypeInfo: PPTypeInfo;
|
|
NewTypeInfo: PTypeInfo;
|
|
WrittenBytes: Cardinal;
|
|
begin
|
|
VMTTypeInfo := VMTTypeInfoFromClass(ClassType);
|
|
// make a copy and reserve additional space to include the extension properties
|
|
NewTypeInfo := CloneTypeInfo(VMTTypeInfo^, lstSize);
|
|
// update the RTTI
|
|
Result := WriteProtectedMemory(VMTTypeInfo, @NewTypeInfo, SizeOf(NewTypeInfo), WrittenBytes);
|
|
// if this failed, free the cloned type info
|
|
if not Result then
|
|
FreeTypeInfo(NewTypeInfo);
|
|
end;
|
|
|
|
procedure InitDestinationPointer;
|
|
var
|
|
TypeData: PTypeData;
|
|
ExistingCount: Integer;
|
|
BaseInfoSize: Integer;
|
|
begin
|
|
TypeData := GetTypeData(PTypeInfo(ClassInfo));
|
|
destProp := PPropInfo(GetPropData(TypeData));
|
|
destIdx := TypeData.PropCount;
|
|
ExistingCount := PPropData(destProp).PropCount;
|
|
Inc(Integer(destProp), SizeOf(Word));
|
|
BaseInfoSize := SizeOf(TPropInfo) - SizeOf(ShortString) + 1;
|
|
while ExistingCount > 0 do
|
|
begin
|
|
Inc(Integer(destProp), BaseInfoSize + Length(destProp.Name));
|
|
Dec(ExistingCount);
|
|
end;
|
|
end;
|
|
|
|
procedure MakeNewProperty(implementationIndex, propertyIndex: Integer);
|
|
var
|
|
size: Integer;
|
|
begin;
|
|
// get the size...
|
|
size := SizeOf(TPropInfo) - SizeOf(ShortString) + 1 + Length(implProps[propertyIndex].Name);
|
|
// copy all info...
|
|
Move(implProps[propertyIndex]^, destProp^, size);
|
|
// setup name index
|
|
destProp.NameIndex := destIdx;
|
|
// advance name index
|
|
Inc(destIdx);
|
|
// setup the property index info
|
|
destProp.Index := Word(implementationIndex) shl 16 + Word(propertyIndex);
|
|
// update stored proc
|
|
destProp.StoredProc := @TBaseItemDsgn.GetIsStoredProp;
|
|
// update GetProc/SetProc
|
|
case implProps[propertyIndex].PropType^.Kind of
|
|
tkInteger, tkChar, tkEnumeration, tkSet, tkClass, tkWChar:
|
|
begin
|
|
destProp.GetProc := @TBaseItemDsgn.GetOrdProp;
|
|
destProp.SetProc := @TBaseItemDsgn.SetOrdProp;
|
|
end;
|
|
tkFloat:
|
|
begin
|
|
destProp.GetProc := @TBaseItemDsgn.GetFloatProp;
|
|
destProp.SetProc := @TBaseItemDsgn.SetFloatProp;
|
|
end;
|
|
{$IFDEF UNICODE} tkUString, {$ENDIF}
|
|
tkString, tkLString:
|
|
begin
|
|
destProp.GetProc := @TBaseItemDsgn.GetStrProp;
|
|
destProp.SetProc := @TBaseItemDsgn.SetStrProp;
|
|
end;
|
|
tkMethod:
|
|
begin
|
|
destProp.GetProc := @TBaseItemDsgn.GetMethodProp;
|
|
destProp.SetProc := @TBaseItemDsgn.SetMethodProp;
|
|
end;
|
|
tkWString:
|
|
begin
|
|
destProp.GetProc := @TBaseItemDsgn.GetWideStrProp;
|
|
destProp.SetProc := @TBaseItemDsgn.SetWideStrProp;
|
|
end;
|
|
tkVariant:
|
|
begin
|
|
destProp.GetProc := @TBaseItemDsgn.GetVariantProp;
|
|
destProp.SetProc := @TBaseItemDsgn.SetVariantProp;
|
|
end;
|
|
{$IFDEF COMPILER6_UP}
|
|
tkInterface:
|
|
begin
|
|
destProp.GetProc := @TBaseItemDsgn.GetInterfaceProp;
|
|
destProp.SetProc := @TBaseItemDsgn.SetInterfaceProp;
|
|
end;
|
|
{$ENDIF COMPILER6_UP}
|
|
tkInt64:
|
|
begin
|
|
destProp.GetProc := @TBaseItemDsgn.GetInt64Prop;
|
|
destProp.SetProc := @TBaseItemDsgn.SetInt64Prop;
|
|
end;
|
|
{$IFDEF COMPILER10_UP}
|
|
tkDynArray:
|
|
begin
|
|
destProp.GetProc := @TBaseItemDsgn.GetDynArrayProp;
|
|
destProp.SetProc := @TBaseItemDsgn.SetDynArrayProp;
|
|
end;
|
|
{$ENDIF COMPILER10_UP}
|
|
end;
|
|
// advance destination pointer
|
|
Inc(Integer(destProp), size);
|
|
end;
|
|
|
|
procedure CopyExtensionProperties;
|
|
var
|
|
implIndex: Integer;
|
|
numProps: Integer;
|
|
propIndex: Integer;
|
|
TypeData: PTypeData;
|
|
|
|
begin
|
|
// iterate over the extension list
|
|
for implIndex := 0 to ImplCount - 1 do
|
|
begin
|
|
// get the implementation
|
|
implInst := GetImplementer(implIndex);
|
|
// get the properties to add
|
|
numProps := GetPropList(PTypeInfo(implInst.ClassInfo), implProps);
|
|
try
|
|
// iterate to copy the property
|
|
for propIndex := 0 to numProps - 1 do
|
|
begin
|
|
// create a new property to reference the original one
|
|
MakeNewProperty(implIndex, propIndex);
|
|
end;
|
|
finally
|
|
FreeMem(implProps);
|
|
end;
|
|
end;
|
|
// Update the count
|
|
TypeData := GetTypeData(PTypeInfo(ClassInfo));
|
|
TypeData.PropCount := TypeData.PropCount + numNewProps;
|
|
GetPropData(TypeData).PropCount := GetPropData(TypeData).PropCount + numNewProps;
|
|
end;
|
|
|
|
begin
|
|
// Determine how much more memory we need...
|
|
CalcAdditionalSize;
|
|
// Create a clone, reserving enough additional memory for the properties of all extensions
|
|
if CreateClonedTypeInfo then
|
|
begin
|
|
// init destination pointer
|
|
InitDestinationPointer;
|
|
// Copy extension properties
|
|
CopyExtensionProperties;
|
|
end;
|
|
end;
|
|
|
|
procedure TBaseItemDsgn.RevertRTTI;
|
|
begin
|
|
ClearTypeInfo(ClassType);
|
|
end;
|
|
|
|
{$IFDEF COMPILER10_UP}
|
|
procedure TBaseItemDsgn.SetDynArrayProp(Index: Integer; Value: Pointer);
|
|
var
|
|
instance: TObject;
|
|
info: PPropInfo;
|
|
begin
|
|
GetPropDataFromIndex(Index, instance, info);
|
|
TypInfo.SetDynArrayProp(instance, info, Value);
|
|
end;
|
|
|
|
{$ENDIF COMPILER10_UP}
|
|
procedure TBaseItemDsgn.SetFloatProp(Index: Integer; Value: Extended);
|
|
var
|
|
instance: TObject;
|
|
info: PPropInfo;
|
|
begin
|
|
GetPropDataFromIndex(Index, instance, info);
|
|
TypInfo.SetFloatProp(instance, info, Value);
|
|
end;
|
|
|
|
procedure TBaseItemDsgn.SetInt64Prop(Index: Integer; Value: Int64);
|
|
var
|
|
instance: TObject;
|
|
info: PPropInfo;
|
|
begin
|
|
GetPropDataFromIndex(Index, instance, info);
|
|
TypInfo.SetInt64Prop(instance, info, Value);
|
|
end;
|
|
|
|
{$IFDEF COMPILER6_UP}
|
|
procedure TBaseItemDsgn.SetInterfaceProp(Index: Integer; Value: IInterface);
|
|
var
|
|
instance: TObject;
|
|
info: PPropInfo;
|
|
begin
|
|
GetPropDataFromIndex(Index, instance, info);
|
|
TypInfo.SetInterfaceProp(instance, info, Value);
|
|
end;
|
|
|
|
{$ENDIF COMPILER6_UP}
|
|
procedure TBaseItemDsgn.SetMethodProp(Index: Integer; Value: TMethod);
|
|
var
|
|
instance: TObject;
|
|
info: PPropInfo;
|
|
begin
|
|
GetPropDataFromIndex(Index, instance, info);
|
|
TypInfo.SetMethodProp(instance, info, Value);
|
|
end;
|
|
|
|
procedure TBaseItemDsgn.SetOrdProp(Index, Value: Integer);
|
|
var
|
|
instance: TObject;
|
|
info: PPropInfo;
|
|
begin
|
|
GetPropDataFromIndex(Index, instance, info);
|
|
TypInfo.SetOrdProp(instance, info, Value);
|
|
end;
|
|
|
|
procedure TBaseItemDsgn.SetStrProp(Index: Integer; Value: string);
|
|
var
|
|
instance: TObject;
|
|
info: PPropInfo;
|
|
begin
|
|
GetPropDataFromIndex(Index, instance, info);
|
|
TypInfo.SetStrProp(instance, info, Value);
|
|
end;
|
|
|
|
procedure TBaseItemDsgn.SetVariantProp(Index: Integer; Value: Variant);
|
|
var
|
|
instance: TObject;
|
|
info: PPropInfo;
|
|
begin
|
|
GetPropDataFromIndex(Index, instance, info);
|
|
TypInfo.SetVariantProp(instance, info, Value);
|
|
end;
|
|
|
|
procedure TBaseItemDsgn.SetWideStrProp(Index: Integer; Value: WideString);
|
|
var
|
|
instance: TObject;
|
|
info: PPropInfo;
|
|
begin
|
|
GetPropDataFromIndex(Index, instance, info);
|
|
{$IFDEF COMPILER6_UP}
|
|
TypInfo.SetWideStrProp(instance, info, Value);
|
|
{$ELSE ~COMPILER6_UP}
|
|
TypInfo.SetStrProp(instance, info, Value);
|
|
{$ENDIF ~COMPILER6_UP}
|
|
end;
|
|
|
|
//=== Registration of default interface property views =======================
|
|
|
|
procedure RegProviderItemInterfaces;
|
|
begin
|
|
RegisterDataItemIntfProp(IJvDataItemText, TJvDataItemTextPropView);
|
|
RegisterDataItemIntfProp(IJvDataItemImage, TJvDataItemImagePropView);
|
|
RegisterDataItemIntfProp(IJvDataItemsImages, TJvDataItemsImagesPropView);
|
|
end;
|
|
|
|
initialization
|
|
CreateTypeInfo(TJvDataProviderItem); // Duplicate class type info to allow properties to be injected.
|
|
RegProviderItemInterfaces; // register default interface property views.
|
|
|
|
finalization
|
|
ClearTypeInfo(TJvDataProviderItem); // undo the hacking of TJvDataProviderItem
|
|
|
|
end.
|