mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-08-20 11:19:23 +02:00
added workaround for buggy typinfo GetMethodProp function
git-svn-id: trunk@5537 -
This commit is contained in:
mattias
parent
6914eb2235
commit
04b8729158
@ -2056,9 +2056,44 @@ begin
|
||||
Result:=GetMethodValueAt(0);
|
||||
end;
|
||||
|
||||
// workaround for buggy rtl function
|
||||
function LazGetMethodProp(Instance: TObject; PropInfo: PPropInfo): TMethod;
|
||||
type
|
||||
TGetMethodProcIndex=function(Index: Longint): TMethod of object;
|
||||
TGetMethodProc=function(): TMethod of object;
|
||||
PMethod = ^TMethod;
|
||||
var
|
||||
value: PMethod;
|
||||
AMethod : TMethod;
|
||||
begin
|
||||
Result.Code:=nil;
|
||||
Result.Data:=nil;
|
||||
case (PropInfo^.PropProcs) and 3 of
|
||||
ptfield:
|
||||
begin
|
||||
Value:=PMethod(Pointer(Instance)+Longint(PropInfo^.GetProc));
|
||||
if Value<>nil then
|
||||
Result:=Value^;
|
||||
end;
|
||||
ptstatic,
|
||||
ptvirtual :
|
||||
begin
|
||||
if (PropInfo^.PropProcs and 3)=ptStatic then
|
||||
AMethod.Code:=PropInfo^.GetProc
|
||||
else
|
||||
AMethod.Code:=PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.GetProc))^;
|
||||
AMethod.Data:=Instance;
|
||||
if ((PropInfo^.PropProcs shr 6) and 1)<>0 then
|
||||
Result:=TGetMethodProcIndex(AMethod)(PropInfo^.Index)
|
||||
else
|
||||
Result:=TGetMethodProc(AMethod)();
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TPropertyEditor.GetMethodValueAt(Index:Integer):TMethod;
|
||||
begin
|
||||
with FPropList^[Index] do Result:=GetMethodProp(Instance,PropInfo);
|
||||
with FPropList^[Index] do Result:=LazGetMethodProp(Instance,PropInfo);
|
||||
end;
|
||||
|
||||
function TPropertyEditor.GetEditLimit:Integer;
|
||||
@ -2234,7 +2269,7 @@ begin
|
||||
Changed:=false;
|
||||
for I:=0 to FPropCount-1 do
|
||||
with FPropList^[I] do begin
|
||||
AMethod:=GetMethodProp(Instance,PropInfo);
|
||||
AMethod:=LazGetMethodProp(Instance,PropInfo);
|
||||
Changed:=Changed or not CompareMem(@AMethod,@NewValue,SizeOf(TMethod));
|
||||
end;
|
||||
if Changed then begin
|
||||
|
||||
@ -901,8 +901,8 @@ type
|
||||
procedure DrawDragDockImage(DragDockObject: TDragDockObject); dynamic;
|
||||
procedure EraseDragDockImage(DragDockObject: TDragDockObject); dynamic;
|
||||
procedure PositionDockRect(DragDockObject: TDragDockObject); dynamic;
|
||||
procedure SendDockNotification; virtual;
|
||||
procedure SetDragMode(Value: TDragMode); virtual;
|
||||
//procedure SendDockNotification; virtual;
|
||||
protected
|
||||
// mouse
|
||||
procedure Click; dynamic;
|
||||
@ -2320,6 +2320,9 @@ end.
|
||||
{ =============================================================================
|
||||
|
||||
$Log$
|
||||
Revision 1.208 2004/06/01 22:49:50 mattias
|
||||
added workaround for buggy typinfo GetMethodProp function
|
||||
|
||||
Revision 1.207 2004/06/01 09:58:35 mattias
|
||||
implemented setting TCustomPage.PageIndex from Andrew Haines
|
||||
|
||||
|
||||
@ -1075,20 +1075,6 @@ begin
|
||||
Result.Y := APoint.Y + P.Y;
|
||||
end;
|
||||
|
||||
{------------------------------------------------------------------------------
|
||||
TControl.SendDockNotification
|
||||
------------------------------------------------------------------------------}
|
||||
procedure TControl.SendDockNotification;
|
||||
begin
|
||||
// ToDo dock: do we really need this method?
|
||||
if (FHostDockSite<>nil) and (DragObject=nil)
|
||||
and (ComponentState*[csLoading,csDestroying] = []) then
|
||||
begin
|
||||
// ToDo dock
|
||||
//FHostDockSite.Perform
|
||||
end;
|
||||
end;
|
||||
|
||||
{------------------------------------------------------------------------------
|
||||
TControl.DblClick
|
||||
------------------------------------------------------------------------------}
|
||||
@ -1428,25 +1414,24 @@ begin
|
||||
//DebugLn('CCC TControl.WndPRoc ',Name,':',ClassName);
|
||||
if (csDesigning in ComponentState) then
|
||||
begin
|
||||
// redirect messages to designer
|
||||
Form := GetParentForm(Self);
|
||||
if (Form <> nil) and (Form.Designer <> nil)
|
||||
and Form.Designer.IsDesignMsg(Self,TheMessage) then begin
|
||||
Exit;
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
if (TheMessage.Msg >= LM_KeyFirst) and (TheMessage.Msg <= LM_KeyLast) then
|
||||
begin
|
||||
else if (TheMessage.Msg >= LM_KeyFirst) and (TheMessage.Msg <= LM_KeyLast)
|
||||
then begin
|
||||
// keyboard messages
|
||||
Form := GetParentForm(Self);
|
||||
if (Form <> nil) and (Form.WantChildKey(Self,TheMessage)) then exit;
|
||||
end
|
||||
else
|
||||
begin
|
||||
if ((TheMessage.Msg>=LM_MOUSEFIRST) and (TheMessage.Msg<=LM_MOUSELAST))
|
||||
else if ((TheMessage.Msg>=LM_MOUSEFIRST) and (TheMessage.Msg<=LM_MOUSELAST))
|
||||
or ((TheMessage.Msg>=LM_MOUSEFIRST2) and (TheMessage.Msg<=LM_MOUSELAST2))
|
||||
then
|
||||
begin
|
||||
then begin
|
||||
// mouse messages
|
||||
|
||||
// map double clicks for controls, that do not want doubleclicks
|
||||
if not (csDoubleClicks in ControlStyle) then
|
||||
begin
|
||||
@ -1488,13 +1473,12 @@ begin
|
||||
begin
|
||||
if FDragMode = dmAutomatic
|
||||
then begin
|
||||
//Assert(False, 'Trace:Begin AutoDrag called');
|
||||
BeginAutoDrag;
|
||||
{ The VCL holds up the mouse down for dmAutomatic
|
||||
and sends it, when it decides, if it is a drag operation or
|
||||
not.
|
||||
This decision requires full control of focus and mouse, which
|
||||
not all LCL interfaces provide. Therefore the mouse down event
|
||||
do not all LCL interfaces provide. Therefore the mouse down event
|
||||
is sent immediately.
|
||||
}
|
||||
// VCL: exit;
|
||||
@ -1507,19 +1491,7 @@ begin
|
||||
Exclude(FControlState, csLButtonDown);
|
||||
end;
|
||||
end;
|
||||
end
|
||||
else begin
|
||||
if TheMessage.Msg = CM_VISIBLECHANGED
|
||||
then begin
|
||||
// ToDo: call a real method, do not create a win32 message
|
||||
//with TheMessage do SendDockNotification(Msg,WParam,LParam);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
{debug purposes}
|
||||
//Assert(False, 'Trace:TCONTROL.WNDPROC');
|
||||
//Assert(False, Format('Trace:Control = %s -->Message = %d',[CLASSNAME,Message.msg]));
|
||||
Dispatch(TheMessage);
|
||||
end;
|
||||
|
||||
@ -3214,6 +3186,9 @@ end;
|
||||
|
||||
{ =============================================================================
|
||||
$Log$
|
||||
Revision 1.189 2004/06/01 22:49:50 mattias
|
||||
added workaround for buggy typinfo GetMethodProp function
|
||||
|
||||
Revision 1.188 2004/06/01 09:58:35 mattias
|
||||
implemented setting TCustomPage.PageIndex from Andrew Haines
|
||||
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
Name: lazarus
|
||||
Version: LAZVERSION
|
||||
Release: LAZRELEASE
|
||||
Copyright: LGPL2
|
||||
Copyright: LGPL2/GPL2
|
||||
Group: Development/Tools
|
||||
Source: LAZSOURCE
|
||||
Summary: Lazarus Component Library and IDE
|
||||
@ -17,6 +17,7 @@ Requires: gdk-pixbuf-devel >= 0.18.0
|
||||
%description
|
||||
Lazarus is a free and opensource RAD tool for freepascal using the lazarus
|
||||
component library - LCL, which is also included in this package.
|
||||
The LCL is licensed under LGPL2, the IDE is licensed under GPL2.
|
||||
|
||||
%prep
|
||||
%setup -c
|
||||
|
||||
Loading…
Reference in New Issue
Block a user