{*******************************************************************} { } { ExpressScript Engine by Developer Express } { } { Copyright (c) 2000-2008 Developer Express Inc. } { ALL RIGHTS RESERVED } { } { The entire contents of this file is protected by U.S. and } { International Copyright Laws. Unauthorized reproduction, } { reverse-engineering, and distribution of all or any portion of } { the code contained in this file is strictly prohibited and may } { result in severe civil and criminal penalties and will be } { prosecuted to the maximum extent possible under the law. } { } { RESTRICTIONS } { } { THIS SOURCE CODE AND ALL RESULTING INTERMEDIATE FILES } { (DCU, OBJ, DLL, ETC.) ARE CONFIDENTIAL AND PROPRIETARY TRADE } { SECRETS OF DEVELOPER EXPRESS INC. THE REGISTERED DEVELOPER IS } { LICENSED TO DISTRIBUTE THE EXPRESSWEB FRAMEWORK AND ALL } { ACCOMPANYING VCL CLASSES AS PART OF AN EXECUTABLE WEB } { APPLICATION ONLY. } { } { THE SOURCE CODE CONTAINED WITHIN THIS FILE AND ALL RELATED } { FILES OR ANY PORTION OF ITS CONTENTS SHALL AT NO TIME BE } { COPIED, TRANSFERRED, SOLD, DISTRIBUTED, OR OTHERWISE MADE } { AVAILABLE TO OTHER INDIVIDUALS WITHOUT EXPRESS WRITTEN CONSENT } { AND PERMISSION FROM DEVELOPER EXPRESS INC. } { } { CONSULT THE END USER LICENSE AGREEMENT FOR INFORMATION ON } { ADDITIONAL RESTRICTIONS. } { } {*******************************************************************} unit cxScriptDispImpl; interface {$I cxVer.inc} uses {$IFDEF VCL}ActiveX, Windows, {$ENDIF}Classes, SysUtils, Variants, TypInfo; type TcxScriptDispEnumImp = class; IcxScriptDispImplGetComponent = interface ['{F06EC3EC-AF90-4189-92E6-12CE65839BF7}'] function GetDispOwner: TComponent; end; TcxScriptDispImpl = class(TInterfacedPersistent, IDispatch, IcxScriptDispImplGetComponent) private FOwner: TObject; FComponent: TComponent; FIsOwnerComponent: Boolean; function GetComponent: TComponent; function GetMethodAddress(APropInfo: PPropInfo; AFlags: Word): Pointer; procedure DestroyDelphiParams(AList: TList); function GetDelphiParamCount(AList: TList; AIncludeIndexed: Boolean = False; ADestList: TList = nil): Integer; function CreateDelphiParamList(APropInfo: PPropInfo; AFlags: Integer): TList; function GetDelphiParamList(APropInfo: PPropInfo; Params: TDispParams; AFlags: Integer): TList; function GetMethodDataAddress(APropInfo: PPropInfo): Pointer; procedure SetInternalDirectParam(APointerValue: PPointer; AParams: TList); function InternalDirectParamInvoke(AMethodAddress, ADataAddress: Pointer; ADelphiParams: TList; AFlags: Integer; VarResult: Pointer): HResult; function InternalRegisterParamInvoke(AMethodAddress, ADataAddress: Pointer; ADelphiParams: TList; AFlags: Integer; VarResult, ExcepInfo, ArgErr: Pointer): HResult; procedure PrepareFuncCall(ADelphiParams: TList; var AEDX, AECX: Integer; AStack: PPointerArray; var ARegCount, AStackCount: Integer); function IsNeedReturnDispatch(PropInfo: PPropInfo; ADelphiParams: TList): Boolean; protected function GetTypeInfoCount(out Count: Integer): HResult; stdcall; function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall; function GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall; function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall; function GetDispOwner: TComponent; function GetEnumerator: TcxScriptDispEnumImp; virtual; function IsSupportEnum: Boolean; function GetDefaultPropInfo: PPropInfo; virtual; function GetPropertyInfo(AObject: TObject; APropName: string): PPropInfo; function IsSupportDefaultProperty: Boolean; function GetCollectionValue(Index: Integer): OleVariant; virtual; function GetCollectionCount: Integer; virtual; public constructor Create(AOwner: TObject); virtual; class function GetObjectClass: TClass; virtual; property Owner: TObject read FOwner; property Component: TComponent read GetComponent; end; TcxScriptDispImplClass = class of TcxScriptDispImpl; TcxScriptDispEnumImp_Next = function(celt: LongWord; var rgvar : OleVariant; out pceltFetched: LongWord): HResult of object; stdcall; TcxScriptDispEnumImp_Skip = function(celt: LongWord): HResult of object; stdcall; TcxScriptDispEnumImp_Reset = function: HResult of object; stdcall; TcxScriptDispEnumImp_Clone = function(out Enum: IEnumVariant): HResult of object; stdcall; { TcxScriptDispEnumImp } TcxScriptDispEnumImp = class(TcxScriptDispImpl, IEnumVariant) private FIndex: Integer; FDispatch_Next: TcxScriptDispEnumImp_Next; FDispatch_Skip: TcxScriptDispEnumImp_Skip; FDispatch_Reset: TcxScriptDispEnumImp_Reset; FDispatch_Clone: TcxScriptDispEnumImp_Clone; protected // Implementation of IEnumVariant function IEnumVariant.Next = Dispatch_Next; function IEnumVariant.Skip = Dispatch_Skip; function IEnumVariant.Reset = Dispatch_Reset; function IEnumVariant.Clone = Dispatch_Clone; function Dispatch_Next(celt: LongWord; var rgvar : OleVariant; out pceltFetched: LongWord): HResult; stdcall; function Dispatch_Skip(celt: LongWord): HResult; stdcall; function Dispatch_Reset: HResult; stdcall; function Dispatch_Clone(out Enum: IEnumVariant): HResult; stdcall; function GetCollection: TcxScriptDispImpl; property Collection: TcxScriptDispImpl read GetCollection; public constructor Create(ACollection: TcxScriptDispImpl); reintroduce; constructor CreateClone(ACollection: TcxScriptDispImpl; AIndex: Integer); published property Next: TcxScriptDispEnumImp_Next read FDispatch_Next; property Skip: TcxScriptDispEnumImp_Skip read FDispatch_Skip; property Reset: TcxScriptDispEnumImp_Reset read FDispatch_Reset; property Clone: TcxScriptDispEnumImp_Clone read FDispatch_Clone; end; TcxScriptDispStringsImpl_Append = procedure(const Value: string) of object; TcxScriptDispStringsImpl_Add = function(const Value: string): Integer of object; TcxScriptDispStringsImpl_AddObject = function(const Value: string; Obj: TObject): Integer of object; TcxScriptDispStringsImpl_Delete = procedure(Index: Integer) of object; TcxScriptDispStringsImpl_IndexOf = function(const Value: string): Integer of object; TcxScriptDispStringsImpl_Clear = procedure of object; TcxScriptDispStringsImpl_Values = function(const Value: string): string of object; TcxScriptDispStringsImpl = class(TcxScriptDispImpl) private FDispatch_Append: TcxScriptDispStringsImpl_Append; FDispatch_Add: TcxScriptDispStringsImpl_Add; FDispatch_AddObject: TcxScriptDispStringsImpl_AddObject; FDispatch_Delete: TcxScriptDispStringsImpl_Delete; FDispatch_IndexOf: TcxScriptDispStringsImpl_IndexOf; FDispatch_Clear: TcxScriptDispStringsImpl_Clear; FDispatch_Values: TcxScriptDispStringsImpl_Values; procedure Dispatch_Append(const Value: String); function Dispatch_Add(const Value: string): Integer; function Dispatch_AddObject(const Value: string; Obj: TObject): Integer; procedure Dispatch_Delete(Index: Integer); function Dispatch_IndexOf(const Value: string): Integer; procedure Dispatch_Clear; function Dispatch_Values(const Value: string): string; function GetCount: Integer; protected function GetStrings: TStrings; function GetEnumerator: TcxScriptDispEnumImp; override; function GetCollectionValue(Index: Integer): OleVariant; override; function GetCollectionCount: Integer; override; function GetDefaultPropInfo: PPropInfo; override; property Strings: TStrings read GetStrings; public constructor Create(AOwner: TObject); override; class function GetObjectClass: TClass; override; published property Count: Integer read GetCount; property Append: TcxScriptDispStringsImpl_Append read FDispatch_Append; property Add: TcxScriptDispStringsImpl_Add read FDispatch_Add; property AddObject: TcxScriptDispStringsImpl_AddObject read FDispatch_AddObject; property Delete: TcxScriptDispStringsImpl_Delete read FDispatch_Delete; property IndexOf: TcxScriptDispStringsImpl_IndexOf read FDispatch_IndexOf; property Clear: TcxScriptDispStringsImpl_Clear read FDispatch_Clear; property Values: TcxScriptDispStringsImpl_Values read FDispatch_Values; end; TcxScriptDispPersistentImpl_GetNamePath = function: string of object; TcxScriptDispPersistentImpl_Assign = procedure(Source: TPersistent) of object; { TcxScriptDispPersistentImpl } TcxScriptDispPersistentImpl = class(TcxScriptDispImpl) private FDispatch_GetNamePath: TcxScriptDispPersistentImpl_GetNamePath; FDispatch_Assign: TcxScriptDispPersistentImpl_Assign; function Dispatch_GetNamePath: string; procedure Dispatch_Assign(Source: TPersistent); protected function Persistent: TPersistent; public constructor Create(AOwner: TObject); override; class function GetObjectClass: TClass; override; published property NamePath: TcxScriptDispPersistentImpl_GetNamePath read FDispatch_GetNamePath; property Assign_: TcxScriptDispPersistentImpl_Assign read FDispatch_Assign; end; TcxScriptDispCollectionItemImpl = class(TcxScriptDispPersistentImpl) private function GetCollection: TCollection; function GetDisplayName: string; function GetID: Integer; function GetIndex: Integer; function GetNamePath__: string; procedure SetCollection(const Value: TCollection); procedure SetDisplayName(const Value: string); procedure SetIndex(const Value: Integer); protected function CollectionItem: TCollectionItem; public constructor Create(AOwner: TObject); override; class function GetObjectClass: TClass; override; published property GetNamePath_: string read GetNamePath__; property Collection: TCollection read GetCollection write SetCollection; property ID: Integer read GetID; property Index: Integer read GetIndex write SetIndex; property DisplayName: string read GetDisplayName write SetDisplayName; end; TcxScriptDispCollectionImpl_Add = function: TCollectionItem of object; TcxScriptDispCollectionImpl_Clear = procedure of object; TcxScriptDispCollectionImpl_Delete = procedure(Index: Integer) of object; TcxScriptDispCollectionImpl_Insert = function(Index: Integer): TCollectionItem of object; TcxScriptDispCollectionImpl_Items = function(Index: Integer): TCollectionItem of object; TcxScriptDispCollectionImpl = class(TcxScriptDispPersistentImpl) private FDispatch_Add: TcxScriptDispCollectionImpl_Add; FDispatch_Clear: TcxScriptDispCollectionImpl_Clear; FDispatch_Delete: TcxScriptDispCollectionImpl_Delete; FDispatch_Insert: TcxScriptDispCollectionImpl_Insert; FDispatch_Items: TcxScriptDispCollectionImpl_Items; FDispatch_FindItemId: TcxScriptDispCollectionImpl_Items; function Dispatch_Add: TCollectionItem; procedure Dispatch_Clear; procedure Dispatch_Delete(Index: Integer); function Dispatch_Insert(Index: Integer): TCollectionItem; function Dispatch_Items(Index: Integer): TCollectionItem; function Dispatch_FindItemID(Index: Integer): TCollectionItem; function GetCount: Integer; function GetOwner_: TPersistent; protected function Collection: TCollection; public constructor Create(AOwner: TObject); override; class function GetObjectClass: TClass; override; published property Count: Integer read GetCount; property Owner_: TPersistent read GetOwner_; property Add: TcxScriptDispCollectionImpl_Add read FDispatch_Add; property Clear: TcxScriptDispCollectionImpl_Clear read FDispatch_Clear; property Delete: TcxScriptDispCollectionImpl_Delete read FDispatch_Delete; property Insert: TcxScriptDispCollectionImpl_Insert read FDispatch_Insert; property Items: TcxScriptDispCollectionImpl_Items read FDispatch_Items; property FindItemID: TcxScriptDispCollectionImpl_Items read FDispatch_FindItemID; end; TcxScriptDispComponentImpl_BeforeDestruction = procedure of object; TcxScriptDispComponentImpl_DestroyComponents = procedure of object; TcxScriptDispComponentImpl_Destroying = procedure of object; TcxScriptDispComponentImpl_ExecuteAction = function(Action: TBasicAction): Boolean of object; TcxScriptDispComponentImpl_FindComponent = function(const AName: string): TComponent of object; TcxScriptDispComponentImpl_FreeNotification = procedure(AComponent: TComponent) of object; TcxScriptDispComponentImpl_RemoveFreeNotification = procedure(AComponent: TComponent) of object; TcxScriptDispComponentImpl_FreeOnRelease = procedure of object; TcxScriptDispComponentImpl_GetParentComponent = function: TComponent of object; TcxScriptDispComponentImpl_HasParent = function: Boolean of object; TcxScriptDispComponentImpl_InsertComponent = procedure(AComponent: TComponent) of object; TcxScriptDispComponentImpl_RemoveComponent = procedure(AComponent: TComponent) of object; TcxScriptDispComponentImpl_SetSubComponent = procedure(IsSubComponent: Boolean) of object; TcxScriptDispComponentImpl_SafeCallException = function(ExceptObject: TObject; ExceptAddr: Pointer): HResult of object; TcxScriptDispComponentImpl_UpdateAction = function(Action: TBasicAction): Boolean of object; TcxScriptDispComponentImpl_IsImplementorOf = function(const I: IInterface): Boolean of object; TcxScriptDispComponentImpl_ReferenceInterface = function(const I: IInterface; Operation: TOperation): Boolean of object; TcxScriptDispComponentImpl_GetComponents = function(Index: Integer): TComponent of object; { TcxScriptDispComponentImpl } TcxScriptDispComponentImpl = class(TcxScriptDispPersistentImpl) private FDispatch_BeforeDestruction: TcxScriptDispComponentImpl_BeforeDestruction; FDispatch_DestroyComponents: TcxScriptDispComponentImpl_DestroyComponents; FDispatch_Destroying: TcxScriptDispComponentImpl_Destroying; FDispatch_ExecuteAction: TcxScriptDispComponentImpl_ExecuteAction; FDispatch_FindComponent: TcxScriptDispComponentImpl_FindComponent; FDispatch_FreeNotification: TcxScriptDispComponentImpl_FreeNotification; FDispatch_RemoveFreeNotification: TcxScriptDispComponentImpl_RemoveFreeNotification; FDispatch_FreeOnRelease: TcxScriptDispComponentImpl_FreeOnRelease; FDispatch_GetParentComponent: TcxScriptDispComponentImpl_GetParentComponent; FDispatch_HasParent: TcxScriptDispComponentImpl_HasParent; FDispatch_InsertComponent: TcxScriptDispComponentImpl_InsertComponent; FDispatch_RemoveComponent: TcxScriptDispComponentImpl_RemoveComponent; FDispatch_SetSubComponent: TcxScriptDispComponentImpl_SetSubComponent; FDispatch_SafeCallException: TcxScriptDispComponentImpl_SafeCallException; FDispatch_UpdateAction: TcxScriptDispComponentImpl_UpdateAction; FDispatch_IsImplementorOf: TcxScriptDispComponentImpl_IsImplementorOf; FDispatch_ReferenceInterface: TcxScriptDispComponentImpl_ReferenceInterface; FDispatch_GetComponents: TcxScriptDispComponentImpl_GetComponents; procedure Dispatch_BeforeDestruction; procedure Dispatch_DestroyComponents; procedure Dispatch_Destroying; function Dispatch_ExecuteAction(Action: TBasicAction): Boolean; function Dispatch_FindComponent(const AName: string): TComponent; procedure Dispatch_FreeNotification(AComponent: TComponent); procedure Dispatch_RemoveFreeNotification(AComponent: TComponent); procedure Dispatch_FreeOnRelease; function Dispatch_GetParentComponent: TComponent; function Dispatch_HasParent: Boolean; procedure Dispatch_InsertComponent(AComponent: TComponent); procedure Dispatch_RemoveComponent(AComponent: TComponent); procedure Dispatch_SetSubComponent(IsSubComponent: Boolean); function Dispatch_SafeCallException(ExceptObject: TObject; ExceptAddr: Pointer): HResult; function Dispatch_UpdateAction(Action: TBasicAction): Boolean; function Dispatch_IsImplementorOf(const I: IInterface): Boolean; function Dispatch_ReferenceInterface(const I: IInterface; Operation: TOperation): Boolean; function Dispatch_GetComponents(Index: Integer): TComponent; function GetComponentCount: Integer; function GetComponentIndex: Integer; procedure SetComponentIndex(aComponentIndex: Integer); function GetComponentState: TComponentState; function GetComponentStyle: TComponentStyle; function GetOwner: TComponent; reintroduce; function Dispatch_GetNamePath: string; public constructor Create(AOwner: TObject); override; class function GetObjectClass: TClass; override; published property BeforeDestruction_: TcxScriptDispComponentImpl_BeforeDestruction read FDispatch_BeforeDestruction; property DestroyComponents: TcxScriptDispComponentImpl_DestroyComponents read FDispatch_DestroyComponents; property Destroying: TcxScriptDispComponentImpl_Destroying read FDispatch_Destroying; property ExecuteAction: TcxScriptDispComponentImpl_ExecuteAction read FDispatch_ExecuteAction; property FindComponent: TcxScriptDispComponentImpl_FindComponent read FDispatch_FindComponent; property FreeNotification: TcxScriptDispComponentImpl_FreeNotification read FDispatch_FreeNotification; property RemoveFreeNotification: TcxScriptDispComponentImpl_RemoveFreeNotification read FDispatch_RemoveFreeNotification; property FreeOnRelease: TcxScriptDispComponentImpl_FreeOnRelease read FDispatch_FreeOnRelease; property GetParentComponent: TcxScriptDispComponentImpl_GetParentComponent read FDispatch_GetParentComponent; property HasParent: TcxScriptDispComponentImpl_HasParent read FDispatch_HasParent; property InsertComponent: TcxScriptDispComponentImpl_InsertComponent read FDispatch_InsertComponent; property RemoveComponent: TcxScriptDispComponentImpl_RemoveComponent read FDispatch_RemoveComponent; property SetSubComponent: TcxScriptDispComponentImpl_SetSubComponent read FDispatch_SetSubComponent; property SafeCallException_: TcxScriptDispComponentImpl_SafeCallException read FDispatch_SafeCallException; property UpdateAction: TcxScriptDispComponentImpl_UpdateAction read FDispatch_UpdateAction; property IsImplementorOf: TcxScriptDispComponentImpl_IsImplementorOf read FDispatch_IsImplementorOf; property ReferenceInterface: TcxScriptDispComponentImpl_ReferenceInterface read FDispatch_ReferenceInterface; property ComponentCount: Integer read GetComponentCount; property ComponentIndex: Integer read GetComponentIndex write SetComponentIndex; property Components: TcxScriptDispComponentImpl_GetComponents read FDispatch_GetComponents; property ComponentState: TComponentState read GetComponentState; property ComponentStyle: TComponentStyle read GetComponentStyle; property Owner: TComponent read GetOwner; end; implementation uses cxScriptDispFactory, ComObj; { TcxScriptDispStringsImpl } constructor TcxScriptDispStringsImpl.Create(AOwner: TObject); begin inherited Create(AOwner); FDispatch_Append := Dispatch_Append; FDispatch_Add := Dispatch_Add; FDispatch_AddObject := Dispatch_AddObject; FDispatch_Delete := Dispatch_Delete; FDispatch_IndexOf := Dispatch_IndexOf; FDispatch_Clear := Dispatch_Clear; FDispatch_Values := Dispatch_Values; end; class function TcxScriptDispStringsImpl.GetObjectClass: TClass; begin Result := TStrings; end; function TcxScriptDispStringsImpl.GetStrings: TStrings; begin if Owner is TStrings then Result := TStrings(Owner) else Result := nil; end; function TcxScriptDispStringsImpl.GetCount: Integer; begin Result := Strings.Count; end; procedure TcxScriptDispStringsImpl.Dispatch_Append(const Value: String); begin Strings.Append(Value); end; function TcxScriptDispStringsImpl.Dispatch_Add(const Value: string): Integer; begin Result := Strings.Add(Value); end; function TcxScriptDispStringsImpl.Dispatch_AddObject(const Value: string; Obj: TObject): Integer; begin Result := Strings.AddObject(Value, Obj); end; procedure TcxScriptDispStringsImpl.Dispatch_Delete(Index: Integer); begin Strings.Delete(Index); end; function TcxScriptDispStringsImpl.Dispatch_IndexOf(const Value: string): Integer; begin Result := Strings.IndexOf(Value); end; procedure TcxScriptDispStringsImpl.Dispatch_Clear; begin Strings.Clear; end; function TcxScriptDispStringsImpl.Dispatch_Values(const Value: string): string; begin Result := Strings.Values[Value]; end; { TcxDispatchHelper } const INVOKE_PROPERTYSET = INVOKE_PROPERTYPUT or INVOKE_PROPERTYPUTREF; type PPointer2 = ^Pointer2; Pointer2 = array [0..1] of Pointer; PPointer3 = ^Pointer3; Pointer3 = array [0..2] of Pointer; PShortString = ^ShortString; PWideString = ^WideString; PParamRec = ^TParamRec; TParamRec = record Value: Pointer3; TypeKind: TTypeKind; OrdType: TOrdType; FloatType: TFloatType; TypeInfo: PTypeInfo; IsReturn: Boolean; IsIndexed: Boolean; StringValue: String; ShortStringValue: ShortString; WideStringValue: WideString; end; function IsStackParam(AParamRec: PParamRec): Boolean; begin Result := AParamRec^.TypeKind in [tkFloat, {tkVariant, }tkArray, tkRecord, tkDynArray] end; function GetByteCount(AParamRec: PParamRec): Integer; begin if IsStackParam(AParamRec) then begin Result := 2; if AParamRec^.FloatType = ftExtended then Result := 3; if AParamRec^.FloatType = ftSingle then Result := 1; end else if AParamRec^.TypeKind = tkInt64 then Result := 2 else Result := 1; end; procedure GetTypeKindByName(AName: String; var ATypeKind: TTypeKind; var AOrdType: TOrdType; var AFloatType: TFloatType; var ATypeInfo: PTypeInfo); begin if GetClass(AName) <> nil then begin ATypeKind := tkClass; AOrdType := otSLong; exit; end; AName := UpperCase(AName); ATypeInfo := nil; //TODO ATypeKind := tkInteger; AOrdType := otSLong; AFloatType := ftDouble; if (AName = 'DOUBLE') then ATypeKind := tkFloat; if (AName = 'STRING') then ATypeKind := tkLString; if (AName = 'VARIANT') then ATypeKind := tkVariant; //TODO end; function GetVarTypeByTypeKind(AParam: PParamRec): Integer; begin Result := varEmpty; case AParam^.TypeKind of {tkUnknown:} tkInteger: begin { case AParam^.OrdType of otUByte: Result := varByte; otSByte: Result := varShortInt; otSWord: Result := varSmallInt; otUWord: Result := varWord; otULong: Result := varLongWord; else} Result := varInteger; // end; end; tkSet, tkClass: Result := varInteger; tkEnumeration: if AParam^.TypeInfo = System.TypeInfo(Boolean) then Result := varBoolean else Result := varInteger; tkChar, tkWChar, tkWString, tkString, tkLString: Result := varOleStr; tkFloat: begin case AParam^.FloatType of ftSingle: Result := varSingle; ftDouble, ftExtended, ftComp: Result := varDouble; ftCurr: Result := varCurrency; end; end; tkMethod: Result := varInteger; tkVariant: Result := varVariant; tkInterface: Result := varDispatch; tkInt64: Result := varInt64; {tkArray, tkRecord, tkDynArray} end; end; procedure GetPointerByVariant(AParam: PParamRec; PValue: PPointer; const Value: Variant); var PP3: ^Pointer3; procedure SetValueToPointer(ACount: Integer); var I: Integer; PTempValue: PPointer; begin PTempValue := PValue; for I := 0 to ACount - 1 do begin PTempValue^ := PP3^[I]; Inc(PTempValue); end; end; var AExtendedValue: Extended; ASingleValue: Single; ACurrencyValue: Currency; ACompValue: Comp; ADoubleValue: Double; AByteValue: Byte; AShortIntValue: ShortInt; AWordValue: Word; ASmallIntValue: SmallInt; ALongWordValue: LongWord; ALongIntValue: Longint; AInt64Value: Int64; AGetComponent: IcxScriptDispImplGetComponent; ADispatch: IDispatch; begin if VarIsNull(Value) or (TVarData(Value).VType = varEmpty) then exit; case AParam^.TypeKind of tkVariant: PValue^ := @Value; {tkUnknown:} tkInteger: begin case AParam^.OrdType of otSByte: begin AShortIntValue := Value; PValue^ := Pointer(AShortIntValue); end; otUByte: begin AByteValue := Value; PValue^ := Pointer(AByteValue); end; otSWord: begin ASmallIntValue := Value; PValue^ := Pointer(ASmallIntValue); end; otUWord: begin AWordValue := Value; PValue^ := Pointer(AWordValue); end; otULong: begin ALongWordValue := Value; PValue^ := Pointer(ALongWordValue); end; otSLong: begin ALongIntValue := Value; PValue^ := Pointer(ALongIntValue); end; else PValue^ := Pointer(TVarData(Value).vInteger); end; end; tkEnumeration, tkSet: PValue^ := Pointer(TVarData(Value).vInteger); tkLString: begin case TVarData(Value).VType of varInteger: AParam^.StringValue := IntToStr(TVarData(Value).VInteger); varDouble: AParam^.StringValue := FloatToStr(TVarData(Value).VDouble); varDate: AParam^.StringValue := DateTimeToStr(TVarData(Value).VDouble); varBoolean: AParam^.StringValue := BoolToStr(TVarData(Value).VBoolean); else AParam^.StringValue := String(WideString(TVarData(Value).VOleStr)); end; PValue^ := Pointer(AParam^.StringValue); end; tkWString: begin AParam^.WideStringValue := String(WideString(TVarData(Value).VOleStr)); PValue^ := Pointer(PWideString(AParam^.WideStringValue)); end; tkString: begin AParam^.ShortStringValue := String(WideString(TVarData(Value).VOleStr)); PValue^ := Pointer(PShortString(@AParam^.ShortStringValue)); end; tkChar: begin AParam^.StringValue := String(WideString(TVarData(Value).VOleStr)); PValue^ := Pointer(Ord(AParam^.StringValue[1])); end; tkWChar: begin AParam^.StringValue := String(WideString(TVarData(Value).VOleStr)); PValue^ := Pointer(Ord(AParam^.StringValue[1])); end; tkFloat: begin //ftSingle, ftDouble, ftExtended, ftComp, ftCurr case AParam^.FloatType of ftSingle: begin ASingleValue := Value; Single(PValue^) := ASingleValue; {case TVarData(Value).VType of varInteger: begin ASingleValue := TVarData(Value).VInteger; Single(PValue^) := ASingleValue; end; varDouble: begin ASingleValue := TVarData(Value).VDouble; Single(PValue^) := ASingleValue; end; else Single(PValue^) := TVarData(Value).VSingle; end;} end; ftExtended: begin AExtendedValue := Value; PP3 := @AExtendedValue; SetValueToPointer(3); end; ftDouble: begin ADoubleValue := Value; PP3 := @ADoubleValue; // PP3 := @TVarData(Value).VDouble; SetValueToPointer(2); end; ftComp: begin ACompValue := Value; PP3 := @ACompValue; SetValueToPointer(2); end; ftCurr: begin { case TVarData(Value).VType of varInteger: ACurrencyValue := TVarData(Value).VInteger; varDouble: ACurrencyValue := TVarData(Value).VDouble; else ACurrencyValue := TVarData(Value).VCurrency; end;} ACurrencyValue := Value; PP3 := @ACurrencyValue; SetValueToPointer(2); end; end; end; { tkMethod: tkVariant: tkInterface:} tkInt64: begin AInt64Value := Value; PP3 := @AInt64Value; SetValueToPointer(2); end; tkClass: begin if TVarData(Value).VType = varDispatch then begin PValue^ := nil; if (TVarData(Value).VDispatch <> nil) then begin ADispatch := IInterface(TVarData(Value).VDispatch) as IDispatch; if Supports(ADispatch, IcxScriptDispImplGetComponent, AGetComponent) then PValue^ := Pointer(AGetComponent.GetDispOwner) end; end else PValue^ := Pointer(TVarData(Value).vInteger); end; {tkArray, tkRecord, tkDynArray} end; end; procedure GetVariantByPointer(AParam: PParamRec; PValue: PPointer; Value: PVariant); var AExtendedValue: Extended; ACompValue: Comp; AByteValue: Byte; AShortIntValue: ShortInt; AWordValue: Word; ASmallIntValue: SmallInt; ALongWordValue: LongWord; AInt64Value: Int64; begin TVarData(Value^).VType := GetVarTypeByTypeKind(AParam); case AParam^.TypeKind of {tkUnknown:} tkInteger: begin case AParam^.OrdType of otUByte: begin Move(PValue^, AByteValue, 1); Value^ := AByteValue; end; otSByte: begin Move(PValue^, AShortIntValue, 1); Value^ := AShortIntValue; end; otUWord: begin Move(PValue^, AWordValue, 2); Value^ := AWordValue; end; otSWord: begin Move(PValue^, ASmallIntValue, 2); Value^ := ASmallIntValue; end; otULong: begin ALongWordValue := LongWord(PValue^); Value^ := ALongWordValue; end; else TVarData(Value^).VInteger := Integer(PValue^); end; end; tkEnumeration, tkSet, tkClass: TVarData(Value^).VInteger := Integer(PValue^); tkChar: TVarData(Value^).VOleStr := StringToOleStr(string(PChar(PValue)^)); tkWChar: TVarData(Value^).VOleStr := PWideChar(PWChar(PValue)^); tkLString: begin TVarData(Value^).VType := varOleStr; TVarData(Value^).VOleStr := StringToOleStr(String(PValue^)); end; tkString: begin TVarData(Value^).VType := varOleStr; TVarData(Value^).VOleStr := StringToOleStr(String(PShortString(PValue)^)); end; tkWString: begin TVarData(Value^).VType := varOleStr; TVarData(Value^).VOleStr := PWideChar(PWideString(PValue)^); end; tkFloat: begin //ftSingle, ftDouble, ftExtended, ftComp, ftCurr case AParam^.FloatType of ftSingle: TVarData(Value^).VSingle := Single(PValue^); ftExtended: begin Move(PValue^, AExtendedValue, 10); TVarData(Value^).VDouble := AExtendedValue; end; ftComp: begin ACompValue := Comp(PPointer2(PValue)^); Value^ := ACompValue; end; ftDouble: TVarData(Value^).VDouble := Double(PPointer2(PValue)^); ftCurr: TVarData(Value^).VCurrency := Currency(PPointer2(PValue)^); end; end; tkVariant: begin if TVarData(PVariant(PValue)^).VType = varString then begin TVarData(Value^).VType := varOleStr; TVarData(Value^).VOleStr := StringToOleStr(String(PVariant(PValue)^)) end else Value^ := PVariant(PValue)^; end; { tkMethod: tkInterface:} tkInt64: begin AInt64Value := Int64(PPointer2(PValue)^); Value^ := AInt64Value; end; {tkArray, tkRecord, tkDynArray} end; end; // 0 - no return value, 1 - return via EAX, 2 - return via ST register (float types), // 3 - Pascal String, 4 - Variant function GetReturnTypes(ADelphiParams: TList): Byte; var ARetType: TTypeKind; begin if (ADelphiParams.Count > 0) and PParamRec(ADelphiParams.Last)^.IsReturn then begin ARetType := PParamRec(ADelphiParams.Last)^.TypeKind; if IsStackParam(PParamRec(ADelphiParams.Last)) then Result := 2 else if ARetType in [tkString, tkLString, tkWString] then Result := 3 else if ARetType = tkVariant then Result := 4 else if ARetType = tkInt64 then Result := 5 else Result := 1; end else Result := 0; end; procedure GetReturnValue(AParam: PParamRec; dwEAX: Integer; dwEDX: Integer; ARetPointer: PPointer; Value: PVariant); var Byte8: Pointer2; AVar: Variant; AString: string; begin TVarData(Value^).VType := GetVarTypeByTypeKind(AParam); if AParam^.TypeKind in [tkInteger, tkEnumeration, tkSet, tkClass] then begin TVarData(Value^).VPointer := ptr(dwEAX); AVar := Value^; end else if AParam^.TypeKind = tkInt64 then begin Byte8[0] := Pointer(dwEAX); Byte8[1] := Pointer(dwEDX); TVarData(Value^).VInt64 := Int64(PPointer2(@Byte8)^); end else if AParam^.TypeKind in [tkChar, tkWChar] then begin AString := Chr(Byte(dwEAX)); TVarData(Value^).VOleStr := StringToOleStr(AString); end else if AParam^.TypeKind in [tkString] then TVarData(Value^).VOleStr := StringToOleStr(string(PShortString(ARetPointer)^)) else if AParam^.TypeKind in [tkWString] then TVarData(Value^).VOleStr := StringToOleStr(string(PWideString(ARetPointer)^)) else GetVariantByPointer(AParam, ARetPointer, Value); end; constructor TcxScriptDispImpl.Create(AOwner: TObject); begin FOwner := AOwner; FIsOwnerComponent := (FOwner <> nil) and (FOwner is TComponent); end; class function TcxScriptDispImpl.GetObjectClass: TClass; begin Result := TObject; end; function TcxScriptDispImpl.GetComponent: TComponent; begin if FComponent <> nil then Result := FComponent else if FIsOwnerComponent then Result := TComponent(FOwner) else Result := nil; end; function TcxScriptDispImpl.GetMethodAddress(APropInfo: PPropInfo; AFlags: Word): Pointer; var AMethod: TMethod; begin if APropInfo.PropType^.Kind = tkMethod then begin AMethod := GetMethodProp(TObject(GetMethodDataAddress(APropInfo)), APropInfo); Result := AMethod.Code; end else if AFlags and INVOKE_PROPERTYSET = INVOKE_PROPERTYSET then Result := APropInfo.SetProc else Result := APropInfo.GetProc; if (Integer(Result) and $FF000000) = $FE000000 then // Virtual method Result := Pointer(PInteger(PInteger(GetMethodDataAddress(APropInfo))^ + SmallInt(Result))^) end; procedure TcxScriptDispImpl.DestroyDelphiParams(AList: TList); var i: Integer; begin for i := 0 to AList.Count - 1 do Dispose(PParamRec(AList[I])); AList.Free; end; function TcxScriptDispImpl.GetDelphiParamCount( AList: TList; AIncludeIndexed: Boolean; ADestList: TList): Integer; var I: Integer; begin Result := 0; for I := 0 to AList.Count - 1 do if not PParamRec(AList[I])^.IsReturn and (AIncludeIndexed or not PParamRec(AList[I])^.IsIndexed) then begin Inc(Result); if ADestList <> nil then ADestList.Add(AList[I]); end; end; function TcxScriptDispImpl.CreateDelphiParamList(APropInfo: PPropInfo; AFlags: Integer): TList; var APos: Integer; ATypeData: PTypeData; function ReadString: shortString; var ALen: Byte; i: Integer; begin ALen := Byte(ATypeData.ParamList[APos]); Inc(APos); SetLength(Result, ALen); for i := 0 to ALen - 1 do Result[i + 1] := ATypeData.ParamList[APos + i]; Inc(APos, ALen); end; procedure AddParameter(AName: string; AIsReturn: Boolean); var AParamRect: PParamRec; begin new(AParamRect); Result.Add(AParamRect); AParamRect^.Value[0] := nil; AParamRect^.Value[1] := nil; AParamRect^.IsReturn := AIsReturn; AParamRect^.IsIndexed := False; with AParamRect^ do if AName <> '' then GetTypeKindByName(AName, TypeKind, OrdType, FloatType, TypeInfo) else begin TypeKind := APropInfo.PropType^.Kind; OrdType := ATypeData.OrdType; FloatType := ATypeData.FloatType; TypeInfo := APropInfo.PropType^; end; end; var I: Integer; begin Result := TList.Create; ATypeData := GetTypeData(APropInfo.PropType^); if (APropInfo.PropType^.Kind = tkMethod) then begin APos := 0; for i := 0 to ATypeData.ParamCount - 1 do begin Inc(APos); ReadString; AddParameter(ReadString, False); end; if ATypeData.MethodKind in [mkFunction, mkClassFunction] then AddParameter(ReadString, True); end else begin if (APropInfo.Index <> Integer($80000000)) then //has index begin AddParameter('Integer', False); PParamRec(Result.Last)^.Value[0] := Pointer(APropInfo.Index); PParamRec(Result.Last)^.IsIndexed := True; end; if AFlags and INVOKE_PROPERTYGET = INVOKE_PROPERTYGET then AddParameter('', True) else AddParameter('', False); end; end; function TcxScriptDispImpl.GetDelphiParamList(APropInfo: PPropInfo; Params: TDispParams; AFlags: Integer): TList; var AParamCount: Integer; AValues: PVariantArgList; I: Integer; ASetParams: TList; begin Result := CreateDelphiParamList(APropInfo, AFlags); AValues := Params.rgvarg; AParamCount := GetDelphiParamCount(Result); if AParamCount = Params.cArgs then begin ASetParams := TList.Create; GetDelphiParamCount(Result, False, ASetParams); for I := 0 to ASetParams.Count - 1 do with PParamRec(ASetParams[I])^ do GetPointerByVariant(PParamRec(ASetParams[I]), @Value[0], Variant(AValues[ASetParams.Count - 1 - I])); ASetParams.Free; end else begin DestroyDelphiParams(Result); Result := nil; end; end; function TcxScriptDispImpl.GetMethodDataAddress(APropInfo: PPropInfo): Pointer; begin if (FOwner <> nil) and (GetPropInfo(FOwner, APropInfo.Name) = APropInfo) then Result := FOwner else Result := self; end; function TcxScriptDispImpl.InternalDirectParamInvoke( AMethodAddress, ADataAddress: Pointer; ADelphiParams: TList; AFlags: Integer; VarResult: Pointer): HResult; var APointerValue: PPointer; begin APointerValue := Pointer(Integer(ADataAddress) + (Integer(AMethodAddress) and $00FFFFFF)); if AFlags and INVOKE_PROPERTYGET = INVOKE_PROPERTYGET then begin if VarResult <> nil then GetVariantByPointer(PParamRec(ADelphiParams.Last), APointerValue, PVariant(VarResult)); end else begin SetInternalDirectParam(APointerValue, ADelphiParams); end; Result := S_OK; end; function TcxScriptDispImpl.InternalRegisterParamInvoke( AMethodAddress, ADataAddress: Pointer; ADelphiParams: TList; AFlags: Integer; VarResult, ExcepInfo, ArgErr: Pointer): HResult; var AEAX, AEDX, AECX: Integer; ARegCount, AStackCount: Integer; AStack: Array[0..256] of Pointer; AStackValue: Pointer; ARetType: Byte; ARetByteCount: Integer; ARetIsCurrency: Byte; ARetIsByte: Byte; ARetIsWord: Byte; ARetIsShortString: Byte; ARetIsWideString: Byte; ARetExtended: Extended; ARetSt: String; ARetShortSt: ShortString; ARetWideSt: WideString; ARetVariant: Variant; I: Integer; begin ARetType := GetReturnTypes(ADelphiParams); ARetIsCurrency := 0; ARetIsByte := 0; ARetIsWord := 0; ARetIsShortString := 0; ARetIsWideString := 0; ARetByteCount := 0; if (ARetType = 2) or (ARetType = 5) then begin ARetByteCount := GetByteCount(PParamRec(ADelphiParams.Last)); if PParamRec(ADelphiParams.Last)^.FloatType in [ftCurr, ftComp] then ARetIsCurrency := 1; end else if ARetType = 3 then begin if PParamRec(ADelphiParams.Last)^.TypeKind = tkString then ARetIsShortString := 1 else if PParamRec(ADelphiParams.Last)^.TypeKind = tkWString then ARetIsWideString := 1; end else if (ARetType = 1) and (PParamRec(ADelphiParams.Last)^.TypeKind <> tkClass) then begin if PParamRec(ADelphiParams.Last)^.OrdType in [otUByte, otSByte] then ARetIsByte := 1 else if PParamRec(ADelphiParams.Last)^.OrdType in [otUWord, otSWord] then ARetIsWord := 1; end; AEAX := Integer(ADataAddress); AEDX := 0; AECX := 0; PrepareFuncCall(ADelphiParams, AEDX, AECX, @AStack, ARegCount, AStackCount); for I := 0 to AStackCount - 1 do begin AStackValue := AStack[I]; asm push dword ptr[AStackValue] end; end; asm @@finishsetupreg: cmp ARetType, 5 // is return value int64? je @@preparecallmethod cmp ARetType, 3 //is return value string? jb @@preparecallmethod jne @@assignvariant cmp ARetIsShortString, 1 je @@AssignShortString cmp ARetIsWideString, 1 je @@AssignWideString lea EAX, dword ptr [ARetSt] //Asssign String jmp @@AssignRetValToRightRegister @@AssignShortString: lea EAX, dword ptr [ARetShortSt] // Assign ShortString jmp @@AssignRetValToRightRegister @@AssignWideString: lea EAX, dword ptr [ARetWideSt] // Assign WideString jmp @@AssignRetValToRightRegister @@assignvariant: lea EAX, dword ptr [ARetVariant] //Assign Variant //assign to the right register @@AssignRetValToRightRegister: cmp ARegCount, 1 //assign to EDX? ja @@assignRetValuetoEAX // ? > 1 (2) jb @@assignRetValuetoEDX // ? < 1 (0) mov ECX, EAX // 1 jmp @@preparecallmethod @@assignRetValuetoEDX: mov EDX, EAX jmp @@preparecallmethod @@assignRetValuetoEAX: push EAX @@preparecallmethod: mov EAX, AEAX //pointer to the Owner or self cmp ARegCount, 0 je @@callmethod mov EDX, AEDX //first ord parameter cmp ARegCount, 1 je @@callmethod mov ECX, AECX //second ord parameter @@callmethod: call AMethodAddress //make the call cmp ARetType, 1 //get the return value: ord or complex, except string (ARetType in [1, 2, 3]) je @@ret_eax cmp ARetType, 2 je @@ret_stpf cmp AretType, 5 je @@ret_eax_edx jmp @@exit @@ret_eax: cmp ARetIsByte, 1 je @@ret_al cmp ARetIsWord, 1 je @@ret_ax mov AEAX, EAX jmp @@exit @@ret_al: mov AEAX, 0 mov byte ptr [AEAX], al jmp @@exit @@ret_ax: mov AEAX, 0 mov word ptr [AEAX], ax jmp @@exit @@ret_eax_edx: mov AEAX, EAX mov AEDX, EDX jmp @@exit @@ret_stpf: cmp ARetByteCount, 2 je @@ret_stpf_qword ja @@ret_stpf_tbyte fstp dword ptr [ARetExtended] jmp @@exit @@ret_stpf_qword: cmp ARetIsCurrency, 1 je @@ret_currency fstp qword ptr [ARetExtended] jmp @@exit @@ret_currency: fistp qword ptr [ARetExtended] jmp @@exit @@ret_stpf_tbyte: fstp tbyte ptr [ARetExtended] @@exit: end; if (ARetType <> 0) and (VarResult <> nil) then begin case ARetType of 1, 2: GetReturnValue(PParamRec(ADelphiParams.Last), AEAX, AEDX, @ARetExtended, PVariant(VarResult)); 3: begin if ARetIsShortString = 1 then GetReturnValue(PParamRec(ADelphiParams.Last), AEAX, AEDX, @ARetShortSt, PVariant(VarResult)) else if ARetIsWideString = 1 then GetReturnValue(PParamRec(ADelphiParams.Last), AEAX, AEDX, @ARetWideSt, PVariant(VarResult)) else GetReturnValue(PParamRec(ADelphiParams.Last), AEAX, AEDX, @ARetSt, PVariant(VarResult)); end; 4: GetReturnValue(PParamRec(ADelphiParams.Last), AEAX, AEDX, @ARetVariant, PVariant(VarResult)); 5: GetReturnValue(PParamRec(ADelphiParams.Last), AEAX, AEDX, @ARetExtended, PVariant(VarResult)); end; end; Result := S_OK; end; procedure TcxScriptDispImpl.PrepareFuncCall(ADelphiParams: TList; var AEDX, AECX: Integer; AStack: PPointerArray; var ARegCount, AStackCount: Integer); var I, J: Integer; AByteCount: Integer; begin ARegCount := 0; AStackCount := 0; for I := 0 to GetDelphiParamCount(ADelphiParams, True) - 1 do with PParamRec(ADelphiParams[I])^ do begin if IsStackParam(ADelphiParams[I]) or (ARegCount = 2) or (TypeKind = tkInt64) then begin AByteCount := GetByteCount(PParamRec(ADelphiParams[I])); for J := AByteCount - 1 downto 0 do begin AStack^[AStackCount] := Value[J]; Inc(AStackCount); end; end { else if TypeKind = tkChar then begin // AEDX := (Value[0]); end} else begin case ARegCount of 0: AEDX := Integer(Value[0]); 1: AECX := Integer(Value[0]); end; Inc(ARegCount); end; end; end; function TcxScriptDispImpl.GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; var i: Integer; APropInfo: PPropInfo; begin Result := S_OK; for i := 0 to NameCount - 1 do begin if (FOwner <> nil) then APropInfo := GetPropInfo(FOwner, POleStrList(Names)^[I]) else APropInfo := nil; if (APropInfo <> nil) and (APropInfo.PropType^.Kind = tkMethod) then APropInfo := nil; if APropInfo = nil then APropInfo := GetPropInfo(self, POleStrList(Names)^[I]); if (APropInfo = nil) and (FOwner <> nil) then // Published class field begin APropInfo := FOwner.FieldAddress(string(POleStrList(Names)^[I])); if APropInfo <> nil then APropInfo := Pointer(Int64(APropInfo) or $FF000000); end; if APropInfo <> nil then PDispIDList(DispIDs)^[I] := Integer(APropInfo) else begin Result := DISP_E_UNKNOWNNAME; break; end; end; end; function TcxScriptDispImpl.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; begin Result := E_NOTIMPL; end; function TcxScriptDispImpl.GetTypeInfoCount(out Count: Integer): HResult; begin Count := 0; Result := S_OK; end; function TcxScriptDispImpl.IsNeedReturnDispatch(PropInfo: PPropInfo; ADelphiParams: TList): Boolean; begin if PropInfo.PropType^.Kind = tkClass then begin if (ADelphiParams.Count > 0) then with PParamRec(ADelphiParams.Last)^ do Result := IsReturn else Result := True; end else begin if(PropInfo.PropType^.Kind = tkMethod) and (ADelphiParams.Count > 0) then with PParamRec(ADelphiParams.Last)^ do Result := IsReturn and (TypeKind = tkClass) else Result := False; end; end; function TcxScriptDispImpl.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; const DISPID_CLASSFIELD = -10; var AMethodAddress: Pointer; ADelphiParams: TList; AIDispatchObject: TcxScriptDispImpl; PropInfo: PPropInfo; begin PropInfo := nil; Result := S_OK; if Flags and INVOKE_PROPERTYSET <> 0 then Flags := INVOKE_PROPERTYSET; ADelphiParams := nil; if (DispID <> DISPID_NEWENUM) and (DispID and $FF000000 = $FF000000) then //Published class field begin TVarData(PVariant(VarResult)^).VType := varInteger; TVarData(PVariant(VarResult)^).VInteger := Integer(Pointer(Int64(DispID) xor $FF000000)^); DispID := DISPID_CLASSFIELD; end else if DispId = DISPID_NEWENUM then //Enumerator begin if not IsSupportEnum then begin Result := DISP_E_UNKNOWNINTERFACE; Exit; end; TVarData(PVariant(VarResult)^).VType := varInteger; TVarData(PVariant(VarResult)^).VInteger := Integer(Pointer(GetEnumerator)); end else if DispId = DISPID_VALUE then //Default value begin if not IsSupportDefaultProperty then begin Result := DISP_E_MEMBERNOTFOUND; Exit; end; PropInfo := GetDefaultPropInfo; end else PropInfo := PPropInfo(DispId); if PropInfo <> nil then begin AMethodAddress := GetMethodAddress(PropInfo, Flags); if AMethodAddress = nil then begin Result := DISP_E_UNKNOWNINTERFACE; exit; end; ADelphiParams := GetDelphiParamList(PropInfo, TDispParams(Params), Flags); if ADelphiParams = nil then begin Result := DISP_E_BADPARAMCOUNT; exit; end; if (Integer(AMethodAddress) and $FF000000 = $FF000000) then Result := InternalDirectParamInvoke(AMethodAddress, GetMethodDataAddress(PropInfo), ADelphiParams, Flags, VarResult) else Result := InternalRegisterParamInvoke(AMethodAddress, GetMethodDataAddress(PropInfo), ADelphiParams, Flags, VarResult, ExcepInfo, ArgErr); end; if (DispId = DISPID_NEWENUM) or (DispId = DISPID_CLASSFIELD) or IsNeedReturnDispatch(PropInfo, ADelphiParams) then begin TVarData(VarResult^).VType := varDispatch; AIDispatchObject := ScriptDispFactory.GetDispatch(TObject(TVarData(VarResult^).VPointer)); if AIDispatchObject <> nil then begin { TODO if (DispId = -4) or (ADelphiParams <> nil) and (ADelphiParams.Count = 1) then begin Result := IDispatch(AIDispatchObject).Invoke(0, IID, LocaleID, Flags, Params, VarResult, ExcepInfo, ArgErr); if Result <> S_OK then TVarData(VarResult^).VDispatch := nil; end else } begin if (TObject(TVarData(VarResult^).VPointer) is TComponent) and (TComponent(TVarData(VarResult^).VPointer).GetParentComponent = Component) then AIDispatchObject.FComponent := Component; TVarData(VarResult^).VDispatch := Pointer(AIDispatchObject as IDispatch); end; end else TVarData(VarResult^).VDispatch := nil; end; if ADelphiParams <> nil then DestroyDelphiParams(ADelphiParams); end; function TcxScriptDispImpl.GetDispOwner: TComponent; begin if FIsOwnerComponent then Result := TComponent(FOwner) else Result := FComponent; end; procedure TcxScriptDispImpl.SetInternalDirectParam(APointerValue: PPointer; AParams: TList); var ATempPointerValue: PPointer; begin ATempPointerValue := APointerValue; case PParamRec(AParams[0])^.TypeKind of tkInteger, tkEnumeration: begin case PParamRec(AParams[0])^.OrdType of otSByte, otUByte: Move(PParamRec(AParams[0])^.Value[0], ATempPointerValue^, 1); otSWord, otUWord: Move(PParamRec(AParams[0])^.Value[0], ATempPointerValue^, 2); else ATempPointerValue^ := PParamRec(AParams[0])^.Value[0]; end; end; tkFloat: begin ATempPointerValue^ := PParamRec(AParams[0])^.Value[0]; case PParamRec(AParams[0])^.FloatType of ftDouble, ftComp, ftCurr, ftExtended: begin Inc(ATempPointerValue); ATempPointerValue^ := PParamRec(AParams[0])^.Value[1]; case PParamRec(AParams[0])^.FloatType of ftExtended: begin Inc(ATempPointerValue); Move(PParamRec(AParams[0])^.Value[2], ATempPointerValue^, 2) end; end; end; end; end; tkInt64: begin ATempPointerValue^ := PParamRec(AParams[0])^.Value[0]; Inc(ATempPointerValue); ATempPointerValue^ := PParamRec(AParams[0])^.Value[1]; end; tkChar: PChar(ATempPointerValue)^ := PParamRec(AParams[0])^.StringValue[1]; tkWChar: PWChar(ATempPointerValue)^ := WideChar(PParamRec(AParams[0])^.StringValue[1]); tkString: PShortString(ATempPointerValue)^ := PShortString(PParamRec(AParams[0])^.Value[0])^; tkWString: PWideString(ATempPointerValue)^ := PParamRec(AParams[0])^.WideStringValue; else ATempPointerValue^ := PParamRec(AParams[0])^.Value[0]; end; end; function TcxScriptDispStringsImpl.GetEnumerator: TcxScriptDispEnumImp; begin Result := TcxScriptDispEnumImp.Create(Self); end; function TcxScriptDispStringsImpl.GetCollectionCount: Integer; begin Result := Strings.Count; end; function TcxScriptDispStringsImpl.GetCollectionValue( Index: Integer): OleVariant; begin Result := Strings.Strings[Index]; end; function TcxScriptDispStringsImpl.GetDefaultPropInfo: PPropInfo; begin Result := GetPropertyInfo(Self, 'Add'); end; { TcxScriptDispPersistentImpl } constructor TcxScriptDispPersistentImpl.Create(AOwner: TObject); begin inherited Create(AOwner); FDispatch_GetNamePath := Dispatch_GetNamePath; FDispatch_Assign := Dispatch_Assign; end; procedure TcxScriptDispPersistentImpl.Dispatch_Assign(Source: TPersistent); begin Persistent.Assign(Source); end; function TcxScriptDispPersistentImpl.Dispatch_GetNamePath: string; begin Result := Persistent.GetNamePath; end; class function TcxScriptDispPersistentImpl.GetObjectClass: TClass; begin Result := TPersistent; end; function TcxScriptDispPersistentImpl.Persistent: TPersistent; begin if Owner is TPersistent then Result := TPersistent(Owner) else Result := nil; end; { TcxScriptDispCollectionItemImpl } constructor TcxScriptDispCollectionItemImpl.Create(AOwner: TObject); begin inherited; end; function TcxScriptDispCollectionItemImpl.GetCollection: TCollection; begin Result := CollectionItem.Collection; end; function TcxScriptDispCollectionItemImpl.GetDisplayName: string; begin Result := CollectionItem.DisplayName; end; function TcxScriptDispCollectionItemImpl.GetID: Integer; begin Result := CollectionItem.ID; end; function TcxScriptDispCollectionItemImpl.GetIndex: Integer; begin Result := CollectionItem.Index; end; function TcxScriptDispCollectionItemImpl.GetNamePath__: string; begin Result := CollectionItem.GetNamePath; end; class function TcxScriptDispCollectionItemImpl.GetObjectClass: TClass; begin Result := TCollectionItem; end; procedure TcxScriptDispCollectionItemImpl.SetCollection(const Value: TCollection); begin CollectionItem.Collection := Value; end; procedure TcxScriptDispCollectionItemImpl.SetDisplayName(const Value: string); begin CollectionItem.DisplayName := Value; end; procedure TcxScriptDispCollectionItemImpl.SetIndex(const Value: Integer); begin CollectionItem.Index := Value; end; function TcxScriptDispCollectionItemImpl.CollectionItem: TCollectionItem; begin if Owner is TCollectionItem then Result := TCollectionItem(Owner) else Result := nil; end; { TcxScriptDispCollectionImpl } constructor TcxScriptDispCollectionImpl.Create(AOwner: TObject); begin inherited; FDispatch_Add := Dispatch_Add; FDispatch_Clear := Dispatch_Clear; FDispatch_Delete := Dispatch_Delete; FDispatch_Insert := Dispatch_Insert; FDispatch_Items := Dispatch_Items; FDispatch_FindItemID := Dispatch_FindItemID; end; function TcxScriptDispCollectionImpl.Dispatch_Add: TCollectionItem; begin Result := Collection.Add; end; procedure TcxScriptDispCollectionImpl.Dispatch_Clear; begin Collection.Clear; end; procedure TcxScriptDispCollectionImpl.Dispatch_Delete(Index: Integer); begin Collection.Delete(Index); end; function TcxScriptDispCollectionImpl.Dispatch_Insert(Index: Integer): TCollectionItem; begin Result := Collection.Insert(Index); end; function TcxScriptDispCollectionImpl.Dispatch_Items(Index: Integer): TCollectionItem; begin Result := Collection.Items[Index]; end; function TcxScriptDispCollectionImpl.Dispatch_FindItemID(Index: Integer): TCollectionItem; begin Result := Collection.FindItemID(Index); end; function TcxScriptDispCollectionImpl.GetCount: Integer; begin Result := Collection.Count; end; function TcxScriptDispCollectionImpl.GetOwner_: TPersistent; begin Result := Collection.Owner; end; class function TcxScriptDispCollectionImpl.GetObjectClass: TClass; begin Result := TCollection; end; function TcxScriptDispCollectionImpl.Collection: TCollection; begin if Owner is TCollection then Result := Owner as TCollection else Result := nil; end; { TcxScriptDispComponentImpl } constructor TcxScriptDispComponentImpl.Create(AOwner: TObject); begin inherited Create(AOwner); FDispatch_BeforeDestruction := Dispatch_BeforeDestruction; FDispatch_DestroyComponents := Dispatch_DestroyComponents; FDispatch_Destroying := Dispatch_Destroying; FDispatch_ExecuteAction := Dispatch_ExecuteAction; FDispatch_FindComponent := Dispatch_FindComponent; FDispatch_FreeNotification := Dispatch_FreeNotification; FDispatch_RemoveFreeNotification := Dispatch_RemoveFreeNotification; FDispatch_FreeOnRelease := Dispatch_FreeOnRelease; FDispatch_GetParentComponent := Dispatch_GetParentComponent; FDispatch_GetNamePath := Dispatch_GetNamePath; FDispatch_HasParent := Dispatch_HasParent; FDispatch_InsertComponent := Dispatch_InsertComponent; FDispatch_RemoveComponent := Dispatch_RemoveComponent; FDispatch_SetSubComponent := Dispatch_SetSubComponent; FDispatch_SafeCallException := Dispatch_SafeCallException; FDispatch_UpdateAction := Dispatch_UpdateAction; FDispatch_IsImplementorOf := Dispatch_IsImplementorOf; FDispatch_ReferenceInterface := Dispatch_ReferenceInterface; FDispatch_GetComponents := Dispatch_GetComponents; end; procedure TcxScriptDispComponentImpl.Dispatch_BeforeDestruction; begin Component.BeforeDestruction; end; procedure TcxScriptDispComponentImpl.Dispatch_DestroyComponents; begin Component.DestroyComponents; end; procedure TcxScriptDispComponentImpl.Dispatch_Destroying; begin Component.Destroying; end; function TcxScriptDispComponentImpl.Dispatch_ExecuteAction( Action: TBasicAction): Boolean; begin Result := Component.ExecuteAction(Action); end; function TcxScriptDispComponentImpl.Dispatch_FindComponent( const AName: string): TComponent; begin Result := Component.FindComponent(AName); end; procedure TcxScriptDispComponentImpl.Dispatch_FreeNotification( AComponent: TComponent); begin Component.FreeNotification(AComponent); end; procedure TcxScriptDispComponentImpl.Dispatch_FreeOnRelease; begin Component.FreeOnRelease; end; function TcxScriptDispComponentImpl.Dispatch_GetComponents( Index: Integer): TComponent; begin Result := Component.Components[Index]; end; function TcxScriptDispComponentImpl.Dispatch_GetNamePath: string; begin Result := Component.GetNamePath; end; function TcxScriptDispComponentImpl.Dispatch_GetParentComponent: TComponent; begin Result := Component.GetParentComponent; end; function TcxScriptDispComponentImpl.Dispatch_HasParent: Boolean; begin Result := Component.HasParent; end; procedure TcxScriptDispComponentImpl.Dispatch_InsertComponent( AComponent: TComponent); begin Component.InsertComponent(AComponent); end; function TcxScriptDispComponentImpl.Dispatch_IsImplementorOf( const I: IInterface): Boolean; begin Result := Component.IsImplementorOf(I); end; function TcxScriptDispComponentImpl.Dispatch_ReferenceInterface( const I: IInterface; Operation: TOperation): Boolean; begin Result := Component.ReferenceInterface(I, Operation); end; procedure TcxScriptDispComponentImpl.Dispatch_RemoveComponent( AComponent: TComponent); begin Component.RemoveComponent(AComponent); end; procedure TcxScriptDispComponentImpl.Dispatch_RemoveFreeNotification( AComponent: TComponent); begin Component.RemoveFreeNotification(AComponent); end; function TcxScriptDispComponentImpl.Dispatch_SafeCallException( ExceptObject: TObject; ExceptAddr: Pointer): HResult; begin Result := Component.SafeCallException(ExceptObject, ExceptAddr); end; procedure TcxScriptDispComponentImpl.Dispatch_SetSubComponent( IsSubComponent: Boolean); begin Component.SetSubComponent(IsSubComponent); end; function TcxScriptDispComponentImpl.Dispatch_UpdateAction( Action: TBasicAction): Boolean; begin Result := Component.UpdateAction(Action); end; { function TcxScriptDispComponentImpl.GetComponent: TComponent; begin if Owner is TComponent then Result := TComponent(Owner) else Result := nil; end; } function TcxScriptDispComponentImpl.GetComponentCount: Integer; begin Result := Component.ComponentCount; end; function TcxScriptDispComponentImpl.GetComponentIndex: Integer; begin Result := Component.ComponentIndex; end; function TcxScriptDispComponentImpl.GetComponentState: TComponentState; begin Result := Component.ComponentState; end; function TcxScriptDispComponentImpl.GetComponentStyle: TComponentStyle; begin Result := Component.ComponentStyle; end; class function TcxScriptDispComponentImpl.GetObjectClass: TClass; begin Result := TComponent; end; function TcxScriptDispComponentImpl.GetOwner: TComponent; begin Result := Component.Owner; end; procedure TcxScriptDispComponentImpl.SetComponentIndex( aComponentIndex: Integer); begin Component.ComponentIndex := aComponentIndex; end; { TcxScriptDispCustomEnumImp } function TcxScriptDispEnumImp.Dispatch_Clone(out Enum: IEnumVariant): HResult; var NewEnumerator: TcxScriptDispEnumImp; begin try NewEnumerator := TcxScriptDispEnumImp.CreateClone(Collection, FIndex); except Result := E_OUTOFMEMORY; Exit; end; Enum := NewEnumerator as IEnumVariant; Result := S_OK; end; constructor TcxScriptDispEnumImp.Create(ACollection: TcxScriptDispImpl); begin inherited Create(ACollection); FIndex := 0; FDispatch_Next := Dispatch_Next; FDispatch_Skip := Dispatch_Skip; FDispatch_Reset := Dispatch_Reset; FDispatch_Clone := Dispatch_Clone; end; {function TcxScriptDispEnumImp.Dispatch_Next(celt: LongWord; var rgvar: OleVariant; out pceltFetched: LongWord): HResult; var I: Integer; LocalCeltFetched: LongWord; VarArrayBounds: array of Integer; NewIndexValue: Integer; begin SetLength(VarArrayBounds, 2); VarArrayBounds[0] := 0; VarArrayBounds[1] := Integer(celt - 1); VariantInit(rgvar); rgvar := VarArrayCreate(VarArrayBounds, varVariant); Result := S_OK; if Collection.GetCollectionCount <= 0 then begin NewIndexValue := 0; LocalCeltFetched := 0; end else begin NewIndexValue := FIndex + celt; LocalCeltFetched := celt; for I := 0 to celt - 1 do begin if FIndex + I < Collection.GetCollectionCount then rgvar[I] := Collection.GetCollectionValue(FIndex + I) else begin NewIndexValue := Collection.GetCollectionCount - 1; LocalCeltFetched := I; VariantClear(rgvar); Result := S_FALSE; Break; end; end; end; FIndex := NewIndexValue; if @pceltFetched <> nil then pceltFetched := LocalCeltFetched; VarArrayBounds := nil; end;} function TcxScriptDispEnumImp.Dispatch_Next(celt: LongWord; var rgvar: OleVariant; out pceltFetched: LongWord): HResult; var LocalCeltFetched: LongWord; begin if celt > 1 then begin Result := E_INVALIDARG; Exit; end; Result := S_OK; if Collection.GetCollectionCount <= 0 then LocalCeltFetched := 0 else begin VariantInit(rgvar); if FIndex < Collection.GetCollectionCount then begin rgvar := Collection.GetCollectionValue(FIndex); Inc(FIndex); LocalCeltFetched := 1; end else begin VariantClear(rgvar); LocalCeltFetched := 0; Result := S_FALSE; end; end; if @pceltFetched <> nil then pceltFetched := LocalCeltFetched; end; function TcxScriptDispEnumImp.Dispatch_Reset: HResult; begin FIndex := 0; Result := S_OK; end; function TcxScriptDispEnumImp.Dispatch_Skip(celt: LongWord): HResult; begin FIndex := FIndex + Integer(celt); if FIndex >= Collection.GetCollectionCount then begin FIndex := Collection.GetCollectionCount - 1; Result := S_FALSE; end else Result := S_OK; end; { TcxScriptDispStringsEnumImp } function TcxScriptDispImpl.GetEnumerator: TcxScriptDispEnumImp; begin Result := nil; end; function TcxScriptDispImpl.IsSupportEnum: Boolean; var Enum: TcxScriptDispEnumImp; begin Enum := GetEnumerator; if Enum <> nil then begin Result := True; Enum.Free; end else Result := False; end; function TcxScriptDispEnumImp.GetCollection: TcxScriptDispImpl; begin if FOwner is TcxScriptDispImpl then Result := TcxScriptDispImpl(FOwner) else Result := nil; end; constructor TcxScriptDispEnumImp.CreateClone( ACollection: TcxScriptDispImpl; AIndex: Integer); begin inherited Create(ACollection); FIndex := AIndex; FDispatch_Next := Dispatch_Next; FDispatch_Skip := Dispatch_Skip; FDispatch_Reset := Dispatch_Reset; FDispatch_Clone := Dispatch_Clone; end; function TcxScriptDispImpl.GetDefaultPropInfo: PPropInfo; begin Result := nil; end; function TcxScriptDispImpl.IsSupportDefaultProperty: Boolean; begin if GetDefaultPropInfo = nil then Result := False else Result := True; end; function TcxScriptDispImpl.GetPropertyInfo(AObject: TObject; APropName: string): PPropInfo; begin Result := GetPropInfo(AObject.ClassInfo, APropName); end; function TcxScriptDispImpl.GetCollectionCount: Integer; begin Result := 0; end; function TcxScriptDispImpl.GetCollectionValue(Index: Integer): OleVariant; begin Result := OleVariant(0); end; initialization ScriptDispClassFactory.RegisterDispatch(TcxScriptDispImpl); ScriptDispClassFactory.RegisterDispatch(TcxScriptDispStringsImpl); ScriptDispClassFactory.RegisterDispatch(TcxScriptDispPersistentImpl); ScriptDispClassFactory.RegisterDispatch(TcxScriptDispCollectionItemImpl); ScriptDispClassFactory.RegisterDispatch(TcxScriptDispCollectionImpl); ScriptDispClassFactory.RegisterDispatch(TcxScriptDispComponentImpl); end.