paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-13 21:39:39 +02:00
Code Issues Packages Projects Releases Wiki Activity

added workaround for buggy typinfo GetMethodProp function

Browse Source 
git-svn-id: trunk@5537 -
This commit is contained in:
mattias 2004-06-01 22:49:50 +00:00
parent 6914eb2235
commit 04b8729158
4 changed files with 114 additions and 100 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
ideintf/propedits.pp
View File

@ -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

5
lcl/controls.pp
View File

@ -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

167
lcl/include/control.inc
View File

@ -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,98 +1414,84 @@ 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
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 if ((TheMessage.Msg>=LM_MOUSEFIRST) and (TheMessage.Msg<=LM_MOUSELAST))
or ((TheMessage.Msg>=LM_MOUSEFIRST2) and (TheMessage.Msg<=LM_MOUSELAST2))
then begin
// mouse messages
// map double clicks for controls, that do not want doubleclicks
if not (csDoubleClicks in ControlStyle) then
begin
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))
or ((TheMessage.Msg>=LM_MOUSEFIRST2) and (TheMessage.Msg<=LM_MOUSELAST2))
then
begin
// map double clicks for controls, that do not want doubleclicks
if not (csDoubleClicks in ControlStyle) then
begin
case TheMessage.Msg of
LM_LButtonDBLCLK,
LM_RButtonDBLCLK,
LM_MButtonDBLCLK:
Dec(TheMessage.Msg, LM_LBUTTONDBLCLK - LM_LBUTTONDOWN);
end;
end;
// map triple clicks for controls, that do not want tripleclicks
if not (csTripleClicks in ControlStyle) then
begin
case TheMessage.Msg of
LM_LBUTTONTRIPLECLK: TheMessage.Msg:=LM_LBUTTONDOWN;
LM_MBUTTONTRIPLECLK: TheMessage.Msg:=LM_MBUTTONDOWN;
LM_RBUTTONTRIPLECLK: TheMessage.Msg:=LM_RBUTTONDOWN;
end;
end;
// map quad clicks for controls, that do not want quadclicks
if not (csQuadClicks in ControlStyle) then
begin
case TheMessage.Msg of
LM_LBUTTONQUADCLK: TheMessage.Msg:=LM_LBUTTONDOWN;
LM_MBUTTONQUADCLK: TheMessage.Msg:=LM_MBUTTONDOWN;
LM_RBUTTONQUADCLK: TheMessage.Msg:=LM_RBUTTONDOWN;
end;
end;
case TheMessage.Msg of
LM_MOUSEMOVE:
begin
Application.HintMouseMessage(Self, TheMessage);
end;
LM_LBUTTONDOWN,
LM_LBUTTONDBLCLK:
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
is sent immediately.
}
// VCL: exit;
end;
Include(FControlState,csLButtonDown);
end;
LM_LBUTTONUP:
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;
case TheMessage.Msg of
LM_LButtonDBLCLK,
LM_RButtonDBLCLK,
LM_MButtonDBLCLK:
Dec(TheMessage.Msg, LM_LBUTTONDBLCLK - LM_LBUTTONDOWN);
end;
end;
// map triple clicks for controls, that do not want tripleclicks
if not (csTripleClicks in ControlStyle) then
begin
case TheMessage.Msg of
LM_LBUTTONTRIPLECLK: TheMessage.Msg:=LM_LBUTTONDOWN;
LM_MBUTTONTRIPLECLK: TheMessage.Msg:=LM_MBUTTONDOWN;
LM_RBUTTONTRIPLECLK: TheMessage.Msg:=LM_RBUTTONDOWN;
end;
end;
// map quad clicks for controls, that do not want quadclicks
if not (csQuadClicks in ControlStyle) then
begin
case TheMessage.Msg of
LM_LBUTTONQUADCLK: TheMessage.Msg:=LM_LBUTTONDOWN;
LM_MBUTTONQUADCLK: TheMessage.Msg:=LM_MBUTTONDOWN;
LM_RBUTTONQUADCLK: TheMessage.Msg:=LM_RBUTTONDOWN;
end;
end;
case TheMessage.Msg of
LM_MOUSEMOVE:
begin
Application.HintMouseMessage(Self, TheMessage);
end;
LM_LBUTTONDOWN,
LM_LBUTTONDBLCLK:
begin
if FDragMode = dmAutomatic
then begin
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
do not all LCL interfaces provide. Therefore the mouse down event
is sent immediately.
}
// VCL: exit;
end;
Include(FControlState,csLButtonDown);
end;
LM_LBUTTONUP:
begin
Exclude(FControlState, csLButtonDown);
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

3
tools/install/lazarus.spec
View File

@ -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