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

MG: reduced paint messages

Browse Source 
git-svn-id: trunk@300 -
This commit is contained in:
lazarus 2001-06-26 21:44:33 +00:00
parent bc488d5e04
commit b8d28a65c6
10 changed files with 139 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
ide/uniteditor.pp
View File

@ -21,12 +21,12 @@
a class that controls the editors (TSourceEditor)
}
//{$DEFINE NEW_EDITOR}
{$DEFINE NEW_EDITOR_SYNEDIT}
unit UnitEditor;
{$mode objfpc}
{$H+}
//{$DEFINE NEW_EDITOR}
{$DEFINE NEW_EDITOR_SYNEDIT}
interface
@ -805,7 +805,6 @@ Begin
end; //case
end;
Procedure TSourceEditor.CommandProcessed(Sender: TObject;
var Command: TSynEditorCommand; var AChar: char; Data: pointer);
begin

4
lcl/extctrls.pp
View File

@ -63,6 +63,7 @@ type
procedure AttachSignals; override;
procedure ReadState(Reader: TAbstractReader); override;
procedure Paint; override;
procedure WMPaint(var Msg: TLMPaint); message LM_PAINT;
public
procedure AddControl; override;
constructor Create(AOwner: TComponent); override;
@ -332,6 +333,9 @@ end.
{
$Log$
Revision 1.12 2001/06/26 21:44:32 lazarus
MG: reduced paint messages
Revision 1.11 2001/06/12 18:31:01 lazarus
MG: small bugfixes

5
lcl/include/interfacebase.inc
View File

@ -334,7 +334,7 @@ begin
Result := 0;
end;
function TInterfaceBase.SendMessage(hWnd: HWND; Msg: Cardinal; wParam: LongInt; lParam: LongInt): Integer;
function TInterfaceBase.SendMessage(HandleWnd: HWND; Msg: Cardinal; wParam: LongInt; lParam: LongInt): Integer;
begin
Result := 0;
end;
@ -448,6 +448,9 @@ end;
{ =============================================================================
$Log$
Revision 1.16 2001/06/26 21:44:32 lazarus
MG: reduced paint messages
Revision 1.15 2001/06/14 23:13:30 lazarus
MWE:
* Fixed some syntax errors for the latest 1.0.5 compiler

21
lcl/include/page.inc
View File

@ -26,7 +26,6 @@ begin
{ The alignment is performed by the notebook component }
Caption := '';
end;
{------------------------------------------------------------------------------
@ -63,7 +62,22 @@ end;
------------------------------------------------------------------------------}
procedure TPage.Paint;
begin
{ Nothing to do here yet }
{ Nothing to do here yet }
end;
{------------------------------------------------------------------------------
TPage WMPaint
Params: a TLMPaint message
------------------------------------------------------------------------------}
procedure TPage.WMPaint(var Msg: TLMPaint);
var Notebook: TNoteBook;
begin
if (Parent is TNoteBook) then begin
NoteBook:=TNoteBook(Parent);
if NoteBook.Page[NoteBook.PageIndex]=Self then
inherited WMPaint(Msg);
end else
inherited WMPaint(Msg);
end;
{------------------------------------------------------------------------------
@ -76,6 +90,9 @@ end;
{
$Log$
Revision 1.3 2001/06/26 21:44:32 lazarus
MG: reduced paint messages
Revision 1.2 2001/01/12 18:27:32 lazarus
Streaming additions by MAttias
Shane

7
lcl/include/winapi.inc
View File

@ -326,9 +326,9 @@ begin
Result := InterfaceObject.ScrollWindowEx(hWnd, dx, dy, prcScroll, prcClip, hrgnUpdate, prcUpdate, flags);
end;
function SendMessage(hWnd: HWND; Msg: Cardinal; wParam: LongInt; lParam: LongInt): Integer;
function SendMessage(HandleWnd: HWND; Msg: Cardinal; wParam: LongInt; lParam: LongInt): Integer;
begin
Result := InterfaceObject.SendMessage(hWnd, Msg, wParam, lParam);
Result := InterfaceObject.SendMessage(HandleWnd, Msg, wParam, lParam);
end;
function SetBkColor(DC: HDC; Color: TColorRef): TColorRef; //pbd
@ -980,6 +980,9 @@ end;
{ =============================================================================
$Log$
Revision 1.15 2001/06/26 21:44:32 lazarus
MG: reduced paint messages
Revision 1.14 2001/06/14 23:13:30 lazarus
MWE:
* Fixed some syntax errors for the latest 1.0.5 compiler

5
lcl/include/winapih.inc
View File

@ -109,7 +109,7 @@ Function ScreenToClient(Handle : HWND; var P : TPoint) : Integer; {$IFDEF IF_BAS
function ScrollWindowEx(hWnd: HWND; dx, dy: Integer; prcScroll, prcClip: PRect; hrgnUpdate: HRGN; prcUpdate: PRect; flags: UINT): Boolean; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
function SelectObject(DC: HDC; GDIObj: HGDIOBJ): HGDIOBJ; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
function SelectPalette(DC: HDC; Palette: HPALETTE; ForceBackground: Boolean): HPALETTE; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
function SendMessage(hWnd: HWND; Msg: Cardinal; wParam: LongInt; lParam: LongInt): Integer; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
function SendMessage(HandleWnd: HWND; Msg: Cardinal; wParam: LongInt; lParam: LongInt): Integer; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
function SetBkColor(DC: HDC; Color: TColorRef): TColorRef; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF} //pbd
Function SetBkMode(DC: HDC; bkMode : Integer) : Integer; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
Function SetCapture (Value : LongInt): LongInt; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
@ -226,6 +226,9 @@ function UnionRect(var lprcDst: TRect; const lprcSrc1, lprcSrc2: TRect): Boolean
{ =============================================================================
$Log$
Revision 1.12 2001/06/26 21:44:32 lazarus
MG: reduced paint messages
Revision 1.11 2001/06/14 23:13:30 lazarus
MWE:
* Fixed some syntax errors for the latest 1.0.5 compiler

14
lcl/interfaces/gtk/gtkint.pp
View File

@ -38,9 +38,10 @@ type
TgtkObject = class(TInterfaceBase)
private
FKeyStateList: TList; // Keeps track of which keys are pressed
FDeviceContexts: TDynHashArray;
FGDIObjects: TDynHashArray;
FMessageQueue: TLazQueue;
FDeviceContexts: TDynHashArray;// hasharray of HDC
FGDIObjects: TDynHashArray; // hasharray of PGdiObject
FMessageQueue: TLazQueue; // queue of PMsg
FPaintMessages: TDynHashArray; // hasharray of PLazQueueItem
FGTKToolTips: PGtkToolTips;
FAccelGroup: PgtkAccelGroup;
FTimerData : TList; // keeps track of timer evenet structures
@ -80,6 +81,9 @@ type
function SetValue (Sender : TObject; Data : pointer) : integer;
function SetProperties (Sender: TObject) : integer;
procedure AttachMenu(Sender: TObject);
function HashPaintMessage(p: pointer): integer;
function FindPaintMessage(HandleWnd: HWnd): PLazQueueItem;
protected
Cursor_Watch : pGDKCursor;
Cursor_Arrow : pGDKCursor;
@ -252,8 +256,8 @@ end.
{ =============================================================================
$Log$
Revision 1.16 2001/06/16 09:14:38 lazarus
MG: added lazqueue and used it for the messagequeue
Revision 1.17 2001/06/26 21:44:32 lazarus
MG: reduced paint messages
Revision 1.15 2001/06/14 14:57:59 lazarus
MG: small bugfixes and less notes

67
lcl/interfaces/gtk/gtkobject.inc
View File

@ -27,8 +27,8 @@ begin
FDeviceContexts := TDynHashArray.Create(-1);
FGDIObjects := TDynHashArray.Create(-1);
FMessageQueue := TLazQueue.Create;
{FPaintMessages := TDynHashArray.Create(-1);
FPaintMessages.OwnerHashFunction := @HashPaintMessage;}
FPaintMessages := TDynHashArray.Create(-1);
FPaintMessages.OwnerHashFunction := @HashPaintMessage;
FAccelGroup := gtk_accel_group_new();
FTimerData := TList.Create;
end;
@ -59,7 +59,7 @@ begin
p := PMsg(QueueItem^.Data);
if p^.Message=LM_PAINT then begin
//writeln('[TgtkObject.Destroy] freeing unused paint message ',HexStr(p^.WParam,8));
//FPaintMessages.Remove(P);
FPaintMessages.Remove(QueueItem);
ReleaseDC(0,P^.WParam);
Dispose(P);
OldQueueItem:=QueueItem;
@ -69,10 +69,10 @@ begin
QueueItem:=QueueItem^.Next;
end;
{if FPaintMessages.Count>0 then begin
if FPaintMessages.Count>0 then begin
WriteLn('[TgtkObject.Destroy] WARNING: There are ',FPaintMessages.Count
,' unremoved LM_PAINT message links left.');
end;}
end;
if (FDeviceContexts.Count > 0)
then begin
@ -142,7 +142,7 @@ begin
end;
FMessageQueue.Free;
//FPaintMessages.Free;
FPaintMessages.Free;
FDeviceContexts.Free;
FGDIObjects.Free;
FKeyStateList.Free;
@ -172,10 +172,10 @@ begin
while First<>nil do
begin
p := PMsg(First^.Data);
Delete(First);
Msg := p^;
{if Msg.Message=LM_PAINT then
FPaintMessages.Remove(p);}
if Msg.Message=LM_PAINT then
FPaintMessages.Remove(First);
Delete(First);
with Msg do
SendMessage(hWND, Message, WParam, LParam);
case Msg.Message of
@ -769,7 +769,8 @@ activate_time : the time at which the activation event occurred.
if Sender is TCustomForm then begin
if (Handle<>0) and (Data<>nil) then begin
FormIconGdiObject:=Data;
if FormIconGdiObject<>nil then begin
if (FormIconGdiObject<>nil) and (pgtkWidget(Handle)^.Window<>nil)
then begin
gdk_window_set_icon(pgtkWidget(Handle)^.Window, nil,
FormIconGdiObject^.GDIBitmapObject,
FormIconGdiObject^.GDIBitmapMaskObject);
@ -2722,10 +2723,10 @@ end;
------------------------------------------------------------------------------}
function TgtkObject.IsValidGDIObject(const GDIObject: HGDIOBJ): Boolean;
begin
Result := FGDIObjects.Contains(Pointer(GDIObject));
Result := (GDIObject<>0) and (FGDIObjects.Contains(Pointer(GDIObject)));
// Result := (GDIObject <> 0);
if Result then
try
// try
with PGdiObject(GDIObject)^ do
case GDIType of
gdiBitmap : begin
@ -2744,9 +2745,9 @@ begin
else
Result := False;
end;
except
on Exception do Result := False;
end;
// except
// on Exception do Result := False;
// end;
Assert(False, Format('Trace: [TgtkObject.IsValidGDIObject] GDIObject: 0x%x --> %s', [Integer(GDIObject), BOOL_RESULT[Result]]));
end;
@ -2894,51 +2895,49 @@ end;
{------------------------------------------------------------------------------
Function: HashPaintMessage
Params: a PaintMessage
Params: a PaintMessage in the Message queue (= PLazQueueItem)
Returns: a hash index
Calculates a hash of the handle in the PaintMessage which is used by the
FPaintMessages (which is a TDynHashArray).
------------------------------------------------------------------------------}
{function TgtkObject.HashPaintMessage(p: pointer): integer;
function TgtkObject.HashPaintMessage(p: pointer): integer;
var h: integer;
begin
h:=PMsg(p)^.WParam;
h:=PMsg(PLazQueueItem(p)^.Data)^.HWnd;
if h<0 then h:=-h;
Result:=((h mod 5364329)+(h mod 17)) mod FPaintMessages.Capacity;
end;}
end;
{------------------------------------------------------------------------------
Function: FindPaintMessage
Params: a Device Context
Returns: nil or a Paint Message to the device context
Params: a window handle
Returns: nil or a Paint Message to the widget
Searches in FPaintMessages for a LM_PAINT message with DC as device context.
Searches in FPaintMessages for a LM_PAINT message with HandleWnd.
------------------------------------------------------------------------------}
{function TgtkObject.FindPaintMessage(DC: HDC): pMsg;
function TgtkObject.FindPaintMessage(HandleWnd: HWnd): PLazQueueItem;
var h: integer;
HashItem: PDynHashArrayItem;
begin
h:=DC;
h:=HandleWnd;
if h<0 then h:=-h;
h:=((h mod 5364329)+(h mod 17)) mod FPaintMessages.Capacity;
HashItem:=FPaintMessages.GetHashItem(h);
if HashItem<>nil then begin
if pMsg(HashItem^.Item)^.wParam=DC then begin
Result:=pMsg(HashItem^.Item);
Result:=PLazQueueItem(HashItem^.Item);
if PMsg(Result^.Data)^.HWnd=HandleWnd then
exit;
end;
HashItem:=HashItem^.Next;
while (HashItem<>nil) and (HashItem^.IsOverflow) do begin
if pMsg(HashItem^.Item)^.wParam=DC then begin
Result:=pMsg(HashItem^.Item);
Result:=PLazQueueItem(HashItem^.Item);
if PMsg(Result^.Data)^.HWnd=HandleWnd then
exit;
end;
HashItem:=HashItem^.Next;
end;
end;
Result:=nil;
end;}
end;
{$IFDEF ASSERT_IS_ON}
@ -2949,9 +2948,15 @@ end;}
{ =============================================================================
$Log$
Revision 1.52 2001/06/26 21:44:32 lazarus
MG: reduced paint messages
<<<<<<< gtkobject.inc
=======
Revision 1.51 2001/06/26 00:08:36 lazarus
MG: added code for form icons from Rene E. Beszon
>>>>>>> 1.51
Revision 1.49 2001/06/14 14:57:59 lazarus
MG: small bugfixes and less notes

64
lcl/interfaces/gtk/gtkwinapi.inc
View File

@ -1297,9 +1297,9 @@ begin
}
Assert(False, 'Trace:GetCaretPos');
gdk_window_get_pointer(nil,@lpPoint.X,@lpPoint.y,@modmask);
gdk_window_get_pointer(nil,@lpPoint.X,@lpPoint.y,@modmask);
Assert(False, 'Trace:GetCaretPos');
Result := True;
Result := True;
end;
{------------------------------------------------------------------------------
@ -2450,7 +2450,7 @@ end;
function TgtkObject.PeekMessage(var lpMsg: TMsg; Handle : HWND;
wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): Boolean;
var
Message: PMSG;
Message: PMsg;
begin
//TODO Filtering
@ -2461,10 +2461,11 @@ begin
lpMsg := Message^;
if (wRemoveMsg and PM_REMOVE) = PM_REMOVE
then begin
if Message^.Message=LM_PAINT then
FPaintMessages.Remove(FMessageQueue.First);
FMessageQueue.Delete(FMessageQueue.First);
end;
end;
end;
{------------------------------------------------------------------------------
@ -2478,9 +2479,12 @@ end;
The PostMessage function places (posts) a message in the message queue and
then returns without waiting.
------------------------------------------------------------------------------}
function TGTKObject.PostMessage(hWnd: HWND; Msg: Cardinal; wParam: LongInt; lParam: LongInt): Boolean;
function TGTKObject.PostMessage(hWnd: HWND; Msg: Cardinal; wParam: LongInt;
lParam: LongInt): Boolean;
var
Message: PMsg;
Message, OldMessage: PMsg;
Target: TObject;
OldPaintMessage: PLazQueueItem;
begin
New(Message);
Message^.HWnd := hWnd;
@ -2488,7 +2492,23 @@ begin
Message^.WParam := WParam;
Message^.LParam := LParam;
// Message^.Time :=
FMessageQueue.AddLast(Message);
if Message^.Message=LM_PAINT then begin
OldPaintMessage:=FindPaintMessage(hWnd);
if OldPaintMessage<>nil then begin
// delete old message from queue, so that the widget repaints only once
OldMessage:=PMsg(OldPaintMessage^.Data);
FPaintMessages.Remove(OldPaintMessage);
FMessageQueue.Delete(OldPaintMessage);
ReleaseDC(0,OldMessage^.WParam);
Dispose(OldMessage);
end;
FMessageQueue.AddLast(Message);
FPaintMessages.Add(FMessageQueue.Last);
end else begin
FMessageQueue.AddLast(Message);
end;
Result := True;
end;
@ -2855,20 +2875,40 @@ end;
The function calls the window procedure for the specified window and does
not return until the window procedure has processed the message.
------------------------------------------------------------------------------}
function TGTKObject.SendMessage(hWnd: HWND; Msg: Cardinal; wParam: LongInt;
function TGTKObject.SendMessage(HandleWnd: HWND; Msg: Cardinal; wParam: LongInt;
lParam: LongInt): Integer;
var
Message: TLMessage;
Target: TObject;
ParentControl: TWinControl;
ParentHandle: HWnd;
begin
Message.Msg := Msg;
Message.WParam := WParam;
Message.LParam := LParam;
Message.Result := 0;
Target := GetLCLObject(Pointer(hWnd));
if Target<>nil then
Target := GetLCLObject(Pointer(HandleWnd));
if Target<>nil then begin
if Msg=LM_PAINT then begin
// The LCL repaints controls in a top-down hierachy. But the gtk sends
// gtkdraw events bottom-up. So, controls at the bottom are repainted
// many times. To avoid this the queue is checked for LM_PAINT messages
// for the parent control. If there is a parent LM_PAINT, this message
// is ignored.
if (Target is TControl) then begin
ParentControl:=TControl(Target).Parent;
while ParentControl<>nil do begin
ParentHandle:=TWinControl(ParentControl).Handle;
if FindPaintMessage(ParentHandle)<>nil then
exit;
ParentControl:=ParentControl.Parent;
end;
end;
end;
Result := DeliverMessage(Target, Message);
end;
end;
{------------------------------------------------------------------------------
@ -3520,8 +3560,8 @@ end;
{ =============================================================================
$Log$
Revision 1.38 2001/06/16 09:14:39 lazarus
MG: added lazqueue and used it for the messagequeue
Revision 1.39 2001/06/26 21:44:32 lazarus
MG: reduced paint messages
Revision 1.37 2001/06/14 23:13:30 lazarus
MWE:

5
lcl/interfaces/gtk/gtkwinapih.inc
View File

@ -81,7 +81,7 @@ Function ScreenToClient(Handle : HWND; var P : TPoint) : Integer; override;
function ScrollWindowEx(hWnd: HWND; dx, dy: Integer; prcScroll, prcClip: PRect; hrgnUpdate: HRGN; prcUpdate: PRect; flags: UINT): Boolean; override;
function SelectObject(DC: HDC; GDIObj: HGDIOBJ): HGDIOBJ; override;
function SelectPalette(DC: HDC; Palette: HPALETTE; ForceBackground: Boolean): HPALETTE; override;
function SendMessage(hWnd: HWND; Msg: Cardinal; wParam: LongInt; lParam: LongInt): Integer; override;
function SendMessage(HandleWnd: HWND; Msg: Cardinal; wParam: LongInt; lParam: LongInt): Integer; override;
function SetBkColor(DC: HDC; Color: TColorRef): TColorRef; override;
Function SetBkMode(DC: HDC; bkMode : Integer) : Integer; override;
Function SetCapture(Value : Longint): Longint; override;
@ -111,6 +111,9 @@ Function WindowFromPoint(Point : TPoint) : HWND; override;
{ =============================================================================
$Log$
Revision 1.16 2001/06/26 21:44:33 lazarus
MG: reduced paint messages
Revision 1.15 2001/06/14 23:13:30 lazarus
MWE:
* Fixed some syntax errors for the latest 1.0.5 compiler