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

renamed lazqueue to lazlinkedlist, patch from Jeroen

Browse Source 
git-svn-id: trunk@4495 -
This commit is contained in:
mattias 2003-08-18 13:26:06 +00:00
parent a27b3206fe
commit 9af0a719c4
11 changed files with 548 additions and 437 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitattributes vendored
View File

@ -853,6 +853,7 @@ lcl/interfaces/gtk/gtkint.pp svneol=native#text/pascal
lcl/interfaces/gtk/gtklistsl.inc svneol=native#text/pascal
lcl/interfaces/gtk/gtklistslh.inc svneol=native#text/pascal
lcl/interfaces/gtk/gtklistviewcallback.inc svneol=native#text/pascal
lcl/interfaces/gtk/gtkmsgqueue.pp svneol=native#text/pascal
lcl/interfaces/gtk/gtkobject.inc svneol=native#text/pascal
lcl/interfaces/gtk/gtkproc.inc svneol=native#text/pascal
lcl/interfaces/gtk/gtkproc.pp svneol=native#text/pascal
@ -900,7 +901,7 @@ lcl/languages/lcl.fr.po svneol=native#text/plain
lcl/languages/lcl.pl.po svneol=native#text/plain
lcl/languages/lcl.po svneol=native#text/plain
lcl/languages/lcl.ru.po svneol=native#text/plain
lcl/lazqueue.pp svneol=native#text/pascal
lcl/lazlinkedlist.pas svneol=native#text/pascal
lcl/lcllinux.pp svneol=native#text/pascal
lcl/lclmemmanager.pas svneol=native#text/pascal
lcl/lclproc.pas svneol=native#text/pascal

5
ide/lazarus.pp
View File

@ -40,7 +40,7 @@ program Lazarus;
{$R *.res}
{$ENDIF}
{ $DEFINE IDE_MEM_CHECK}
{$DEFINE IDE_MEM_CHECK}
uses
//cmem,
@ -99,6 +99,9 @@ end.
{
$Log$
Revision 1.51 2003/08/18 13:21:23 mattias
renamed lazqueue to lazlinkedlist, patch from Jeroen
Revision 1.50 2003/08/08 07:52:33 mattias
deactivated memcheck

5
lcl/allunits.pp
View File

@ -28,7 +28,7 @@ uses
// resource strings
LCLStrConsts,
// base classes
LazQueue, DynHashArray, LCLMemManager, AvgLvlTree, StringHashList,
LazLinkedList, DynHashArray, LCLMemManager, AvgLvlTree, StringHashList,
ExtendedStrings, DynamicArray, UTrace, TextStrings,
// base types and base functions
LCLProc, LCLType, GraphMath, VCLGlobals, FileCtrl, LMessages,
@ -47,6 +47,9 @@ end.
{ =============================================================================
$Log$
Revision 1.27 2003/08/18 13:21:23 mattias
renamed lazqueue to lazlinkedlist, patch from Jeroen
Revision 1.26 2003/08/01 09:44:52 mattias
added SelectDirectory dialog

2
lcl/interfaces/gtk/gtkglobals.pp
View File

@ -26,7 +26,7 @@ uses
glib, gdk, gtk,
{$ENDIF}
LMessages, Controls, Forms,
VclGlobals, LCLLinux, LCLType, GTKDef, DynHashArray, LazQueue;
VclGlobals, LCLLinux, LCLType, GTKDef, DynHashArray, LazLinkedList;
{$I dragicons.inc}

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

@ -55,7 +55,7 @@ uses
{$ENDIF}
xlib,
SysUtils, LMessages, Classes, Controls, Forms, LCLStrConsts,
VclGlobals, LCLProc, LCLLinux, LCLType, gtkDef, DynHashArray, LazQueue,
VclGlobals, LCLProc, LCLLinux, LCLType, gtkDef, DynHashArray, gtkMsgQueue,
GraphType, GraphMath;
@ -65,8 +65,7 @@ type
FKeyStateList: TList; // Keeps track of which keys are pressed
FDeviceContexts: TDynHashArray;// hasharray of HDC
FGDIObjects: TDynHashArray; // hasharray of PGdiObject
FMessageQueue: TLazQueue; // queue of PMsg
FPaintMessages: TDynHashArray; // hasharray of PLazQueueItem
FMessageQueue: TGtkMessageQueue; // queue of PMsg
WaitingForMessages: boolean;
FRCFilename: string;
@ -216,8 +215,6 @@ type
procedure ResizeChild(Sender : TObject; Left,Top,Width,Height : Integer);virtual;
procedure SetResizeRequest(Widget: PGtkWidget);virtual;
procedure UnsetResizeRequest(Widget: PGtkWidget);virtual;
function HashPaintMessage(p: pointer): integer;virtual;
function FindPaintMessage(HandleWnd: HWnd): PLazQueueItem;virtual;
procedure RemoveCallbacks(Sender : TObject); virtual;
public
// for gtk specific components:
@ -351,6 +348,9 @@ end.
{ =============================================================================
$Log$
Revision 1.138 2003/08/18 13:21:23 mattias
renamed lazqueue to lazlinkedlist, patch from Jeroen
Revision 1.137 2003/08/13 16:18:58 mattias
started check compiler options

237
lcl/interfaces/gtk/gtkmsgqueue.pp Normal file
View File

@ -0,0 +1,237 @@
{***************************************************************************
GtkMsgQueue - Messagequeue for Gtk interface
--------------------------------------------
Initial Revision : Thu Aug 16, 2003
***************************************************************************/
*****************************************************************************
* *
* This file is part of the Lazarus Component Library (LCL) *
* *
* See the file COPYING.LCL, included in this distribution, *
* for details about the copyright. *
* *
* This program is distributed in the hope that it will be useful, *
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
* *
*****************************************************************************
}
unit GtkMsgQueue;
{$mode objfpc}{$H+}
interface
uses LazLinkedList, LCLType, LMessages, GtkGlobals, DynHashArray, GtkProc;
type
TFinalPaintMessageFlag=(FPMF_None,FPMF_Internal,FPMF_All);
TGtkMessageQueueItem=class(TLinkListitem)
private
fMsg : PMsg;
public
property Msg: PMsg read fMsg write fMsg;
function IsPaintMessage : boolean;
procedure DestroyMessage(ParFinalInternalOnly: TFinalPaintMessageFlag;
DisposeMessage: boolean);
constructor Create;
end;
TGtkMessageQueue=class(TLinkList)
private
FPaintMessages: TDynHashArray; // Hash for paint messages
protected
function CreateItem : TLinkListItem;override;
function CalculateHash(ParWnd : Hwnd):integer;
function HashPaintMessage(p: pointer): integer;
public
constructor Create;
destructor destroy;override;
function FirstMessageItem : TGtkMessageQueueItem;
function LastMessageItem : TGtkMessageQueueItem;
function FirstMessage : PMsg;
function LastMessage : PMsg;
procedure AddMessage(ParMsg : PMsg);
procedure RemoveMessage(ParItem: TGtkMessageQueueItem;
ParFinalOnlyInternal: TFinalPaintMessageFlag;
DisposeMessage: boolean);
function FindPaintMessage(HandleWnd: HWnd): TGtkMessageQueueItem;
function HasPaintMessages:boolean;
function HasNonPaintMessages:boolean;
function NumberOfPaintMessages:integer;
function PopFirstMessage: PMsg;
end;
implementation
{---(TGtkMessageQueueItem)----------------------}
function TGtkMessageQueueItem.IsPaintMessage : boolean;
begin
Result := false;
if fMsg <> nil then begin
Result := (Msg^.Message = LM_Paint) or (Msg^.Message = LM_GtkPaint);
end;
end;
constructor TGtkMessageQueueItem.Create;
begin
inherited Create;
fMsg := nil;
end;
procedure TGtkMessageQueueItem.DestroyMessage(
ParFinalInternalOnly: TFinalPaintMessageFlag; DisposeMessage: boolean);
begin
if (ParFinalInternalOnly in [FPMF_All,FPMF_Internal])
and (fMsg^.message = LM_GtkPaint)
then
FinalizePaintTagMsg(fMsg);
if DisposeMessage then
Dispose(fMsg);
fMsg := nil;
end;
{---(TGtkMessageQueue )---------------------------}
constructor TGtkMessageQueue.Create;
begin
inherited Create;
FPaintMessages := TDynHashArray.Create(-1);
FPaintMessages.OwnerHashFunction := @HashPaintMessage;
end;
destructor TGtkMessageQueue.destroy;
begin
inherited Destroy;
fPaintMessages.destroy;
end;
{------------------------------------------------------------------------------
Function: FindPaintMessage
Params: a window handle
Returns: nil or a Paint Message to the widget
Searches in FPaintMessages for a LM_PAINT message with HandleWnd.
------------------------------------------------------------------------------}
function TGtkMessageQueue.FindPaintMessage(HandleWnd: HWnd): TGtkMessageQueueItem;
var h: integer;
HashItem: PDynHashArrayItem;
begin
h:= CalculateHash(HandleWnd);
HashItem:=FPaintMessages.GetHashItem(h);
if HashItem<>nil then begin
Result:=TGtkMessageQueueItem(HashItem^.Item);
if Result.Msg^.hWnd=HandleWnd then
exit;
HashItem:=HashItem^.Next;
while (HashItem<>nil) and (HashItem^.IsOverflow) do begin
Result:=TGtkMessageQueueItem(HashItem^.Item);
if Result.Msg^.hWnd=HandleWnd then
exit;
HashItem:=HashItem^.Next;
end;
end;
Result:=nil;
end;
function TGtkMessageQueue.HashPaintMessage(p: pointer): integer;
begin
result := CalculateHash(TGtkMessageQueueItem(p).Msg^.Hwnd);
end;
function TGtkMessageQueue.CalculateHash(ParWnd : Hwnd):integer;
var
h:integer;
begin
h :=ParWnd;
if h<0 then h:=-h;
Result:=((h mod 5364329)+(h mod 17)) mod FPaintMessages.Capacity;
end;
function TGtkMessageQueue.CreateItem : TLinkListItem;
begin
result := TGtkMessageQueueItem.Create;
result.ResetItem;
end;
procedure TGtkMessageQueue.AddMessage(ParMsg : PMsg);
var
vLItem : TGtkMessageQueueItem;
begin
vlItem := TGtkMessageQueueItem(GetNewItem);
vlItem.fMsg := ParMsg;
AddAsLast(vlItem);
if vlItem.IsPaintMessage then fPaintMessages.Add(vlitem);
end;
function TGtkMessageQueue.FirstMessageItem : TGtkMessageQueueItem;
begin
Result :=TGtkMessageQueueItem(First);
end;
function TGtkMessageQueue.FirstMessage : PMsg;
begin
Result := nil;
if FirstMessageItem <> nil then Result := FirstMessageItem.fMsg;
end;
function TGtkMessageQueue.LastMessageItem : TGtkMessageQueueItem;
begin
result:= TGtkMessageQueueItem(Last);
end;
function TGtkMessageQueue.LastMessage : PMsg;
begin
Result := nil;
if LastMessageItem <> nil then result := LastMessageItem.fMsg;
end;
{ Remove from queue and destroy message
ParItem : Queue Item for removel
ParFinalOnlyInterl : finalyze message only for LM_GtkPaint }
procedure TGtkMessageQueue.RemoveMessage(ParItem: TGtkMessageQueueItem;
ParFinalOnlyInternal: TFinalPaintMessageFlag; DisposeMessage: boolean);
begin
if (ParItem.IsPaintMessage) then
fPaintMessages.Remove(ParItem);
ParItem.DestroyMessage(ParFinalOnlyInternal,DisposeMessage);
Delete(ParItem);
end;
function TGtkMessageQueue.HasPaintMessages:boolean;
begin
result := fPaintMessages.Count > 0;
end;
function TGtkMessageQueue.NumberOfPaintMessages:integer;
begin
result := fPaintMessages.Count;
end;
function TGtkMessageQueue.HasNonPaintMessages:boolean;
begin
result := fPaintMessages.Count <> count;
end;
function TGtkMessageQueue.PopFirstMessage: PMsg;
var
vlItem : TGtkMessageQueueItem;
begin
vlItem := FirstMessageItem;
Result := vlItem.Msg;
RemoveMessage(vlItem,FPMF_none,false);
end;
end.

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

@ -145,9 +145,7 @@ begin
FDefaultFont:= nil;
// messages
FMessageQueue := TLazQueue.Create;
FPaintMessages := TDynHashArray.Create(-1);
FPaintMessages.OwnerHashFunction := @HashPaintMessage;
FMessageQueue := TGtkMessageQueue.Create;
WaitingForMessages := false;
FWidgetsWithResizeRequest := TDynHashArray.Create(-1);
FWidgetsWithResizeRequest.Options:=
@ -268,12 +266,12 @@ const
'gdiBitmap', 'gdiBrush', 'gdiFont', 'gdiPen', 'gdiRegion', 'gdiPalette');
var
n: Integer;
p: PMsg;
pTimerInfo : PGtkITimerinfo;
GDITypeCount: array[TGDIType] of Integer;
GDIType: TGDIType;
HashItem: PDynHashArrayItem;
QueueItem, OldQueueItem: PLazQueueItem;
QueueItem : TGtkMessageQueueItem;
NextQueueItem : TGtkMessageQueueItem;
begin
FreeAllStyles;
FreeGDKCursors;
@ -284,25 +282,18 @@ begin
FGTKToolTips := nil;
end;
// tidy up the messages
QueueItem:=FMessageQueue.First;
// tidy up the paint messages
QueueItem:=FMessageQueue.FirstMessageItem;
while (QueueItem<>nil) do begin
p := PMsg(QueueItem^.Data);
if (p^.Message=LM_PAINT) or (p^.Message=LM_GtkPAINT) then begin
//writeln('[TgtkObject.Destroy] freeing unused paint message ',HexStr(p^.WParam,8));
FPaintMessages.Remove(QueueItem);
FinalizePaintTagMsg(p);
Dispose(P);
OldQueueItem:=QueueItem;
QueueItem:=QueueItem^.Next;
FMessageQueue.Delete(OldQueueItem);
end else
QueueItem:=QueueItem^.Next;
NextQueueItem := TGtkMessageQueueItem(QueueItem.Next);
if QueueItem.IsPaintMessage then
fMessageQueue.RemoveMessage(QueueItem,FPMF_All,true);
QueueItem := NextQueueItem;
end;
if FPaintMessages.Count>0 then begin
if fMessageQueue.HasPaintMessages then begin
WriteLn(ProcName, Format(rsWarningUnremovedPaintMessages,
[IntToStr(FPaintMessages.Count)]));
[IntToStr(fMessageQueue.NumberOfPaintMessages)]));
end;
if (FDeviceContexts.Count > 0)
@ -348,15 +339,12 @@ begin
WriteLN(ProcName,Format(' %s: %d', [GDITYPENAME[GDIType], GDITypeCount[GDIType]]));
end;
if FMessageQueue.Count > 0
then begin
WriteLN(ProcName, Format(rsWarningUnreleasedMessagesInQueue,[
FMessageQueue.Count]));
while FMessageQueue.First<>nil do begin
p := PMsg(FMessageQueue.First^.Data);
Dispose(P);
FMessageQueue.Delete(FMessageQueue.First);
end;
// tidy up messages
if FMessageQueue.Count > 0 then begin
WriteLN(ProcName, Format(rsWarningUnreleasedMessagesInQueue,[FMessageQueue.Count]));
while FMessageQueue.First<>nil do
fMessageQueue.RemoveMessage(fMessageQueue.FirstMessageItem,FPMF_All,true);
end;
n := FTimerData.Count;
@ -376,7 +364,6 @@ begin
FreeAndNil(FWidgetsResized);
FreeAndNil(FFixWidgetsResized);
FMessageQueue.Free;
FPaintMessages.Free;
FDeviceContexts.Free;
FGDIObjects.Free;
FKeyStateList.Free;
@ -1269,9 +1256,10 @@ procedure TgtkObject.HandleEvents;
end;
var
Msg: TMsg;
p: pMsg;
IsPaintMessage: boolean;
vlItem : TGtkMessageQueueItem;
vlMsg : PMSg;
begin
repeat
// send cached LCL messages to the gtk
@ -1283,38 +1271,33 @@ begin
// send cached gtk messages to the lcl
SendCachedGtkMessages;
// then handle our own messages
with FMessageQueue do begin
while First<>nil do
begin
// fetch first message
p := PMsg(First^.Data);
Msg := p^;
IsPaintMessage:=(Msg.Message=LM_PAINT) or (Msg.Message=LM_GtkPaint);
while true do begin
// fetch first message
vlItem := fMessageQueue.FirstMessageItem;
if vlItem = nil then break;
// remove message from queue
if IsPaintMessage then begin
// paint messages are the most expensive messages in the LCL,
// therefore they are sent always after all other
if Count>FPaintMessages.Count then begin
// there are non paint messages -> keep paint message back
MoveToLast(First);
continue;
end else begin
// there are only paint messages left in the queue
// -> check other queues
if PendingGtkMessagesExists then break;
end;
FPaintMessages.Remove(First);
// remove message from queue
if vlItem.IsPaintMessage then begin
// paint messages are the most expensive messages in the LCL,
// therefore they are sent always after all other
if fMessageQueue.HasNonPaintMessages then begin
// there are non paint messages -> keep paint message back
fMessageQueue.MoveToLast(FMessageQueue.First);
continue;
end else begin
// there are only paint messages left in the queue
// -> check other queues
if PendingGtkMessagesExists then break;
end;
Delete(First);
// Send message
with Msg do
SendMessage(hWND, Message, WParam, LParam);
Dispose(p);
end;
vlMsg:=fMessageQueue.PopFirstMessage;
// Send message
with vlMsg^ do SendMessage(hWND, Message, WParam, LParam);
Dispose(vlMsg);
end;
// proceed until all messages are handled
@ -4274,7 +4257,8 @@ end;
procedure TGTKObject.DestroyLCLComponent(Sender : TObject);
var
handle: hwnd; // handle of sender
QueueItem, OldQueueItem: PLazQueueItem;
QueueItem : TGtkMessageQueueItem;
NextItem : TGtkMessageQueueItem;
MsgPtr: PMsg;
Widget: PGtkWidget;
FixWidget: PGtkWidget;
@ -4376,22 +4360,13 @@ begin
//writeln('>>> LM_DESTROY END ',Sender.Classname,' Sender=',HexStr(Cardinal(Sender),8),' Handle=',HexStr(Cardinal(Handle),8));
// remove all remaining messages to this component
QueueItem:=FMessageQueue.First;
QueueItem:=FMessageQueue.FirstMessageItem;
while (QueueItem<>nil) do begin
MsgPtr := PMsg(QueueItem^.Data);
if (MsgPtr^.hWnd=Handle) then begin
// remove message
if (MsgPtr^.Message=LM_PAINT) or (MsgPtr^.Message=LM_GtkPAINT) then begin
FPaintMessages.Remove(QueueItem);
FinalizePaintTagMsg(MsgPtr);
end;
Dispose(MsgPtr);
OldQueueItem:=QueueItem;
QueueItem:=QueueItem^.Next;
FMessageQueue.Delete(OldQueueItem);
end else begin
QueueItem:=QueueItem^.Next;
end;
MsgPtr := QueueItem.Msg;
NextItem := TGtkMessagequeueItem(QueueItem.Next);
if (MsgPtr^.hWnd=Handle) then
fMessageQueue.RemoveMessage(QueueItem,FPMF_All,true);
QueueItem := NextItem;
end;
// mouse click messages
@ -7584,51 +7559,8 @@ begin
end;
end;
{------------------------------------------------------------------------------
Function: HashPaintMessage
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;
var h: integer;
begin
h:=PMsg(PLazQueueItem(p)^.Data)^.hWnd;
if h<0 then h:=-h;
Result:=((h mod 5364329)+(h mod 17)) mod FPaintMessages.Capacity;
end;
{------------------------------------------------------------------------------
Function: FindPaintMessage
Params: a window handle
Returns: nil or a Paint Message to the widget
Searches in FPaintMessages for a LM_PAINT message with HandleWnd.
------------------------------------------------------------------------------}
function TgtkObject.FindPaintMessage(HandleWnd: HWnd): PLazQueueItem;
var h: integer;
HashItem: PDynHashArrayItem;
begin
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
Result:=PLazQueueItem(HashItem^.Item);
if PMsg(Result^.Data)^.hWnd=HandleWnd then
exit;
HashItem:=HashItem^.Next;
while (HashItem<>nil) and (HashItem^.IsOverflow) do begin
Result:=PLazQueueItem(HashItem^.Item);
if PMsg(Result^.Data)^.hWnd=HandleWnd then
exit;
HashItem:=HashItem^.Next;
end;
end;
Result:=nil;
end;
{------------------------------------------------------------------------------
TgtkObject SetResizeRequest
@ -8038,6 +7970,9 @@ end;
{ =============================================================================
$Log$
Revision 1.399 2003/08/18 13:21:23 mattias
renamed lazqueue to lazlinkedlist, patch from Jeroen
Revision 1.398 2003/08/15 14:01:20 mattias
combined lazconf things for unix

8
lcl/interfaces/gtk/gtkproc.pp
View File

@ -36,10 +36,10 @@ uses
glib, gdk, gtk, {$Ifndef NoGdkPixbufLib}gdkpixbuf,{$EndIf}
{$ENDIF}
LMessages, Controls, Forms, VclGlobals, LCLProc,
LCLStrConsts, LCLLinux, LCLType, gtkDef, DynHashArray, LazQueue, GraphType,
GraphMath, Graphics, Buttons, Menus, GTKWinApiWindow, StdCtrls, ComCtrls,
CListBox, KeyMap, Calendar, Arrow, Spin, CommCtrl, ExtCtrls, Dialogs,
FileCtrl, LResources, Math, GTKGlobals;
LCLStrConsts, LCLLinux, LCLType, gtkDef, DynHashArray, LazLinkedList,
GraphType, GraphMath, Graphics, Buttons, Menus, GTKWinApiWindow, StdCtrls,
ComCtrls, CListBox, KeyMap, Calendar, Arrow, Spin, CommCtrl, ExtCtrls,
Dialogs, FileCtrl, LResources, Math, GTKGlobals;
{$IFDEF gtk2}

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

@ -5789,27 +5789,17 @@ end;
function TgtkObject.PeekMessage(var lpMsg: TMsg; Handle : HWND;
wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): Boolean;
var
AMessage: PMsg;
vlItem : TGtkMessageQueueItem;
begin
//TODO Filtering
Result := FMessageQueue.Count > 0;
if Result
then begin
AMessage := FMessageQueue.First^.Data;
lpMsg := AMessage^;
if (wRemoveMsg and PM_REMOVE) = PM_REMOVE
then begin
if (AMessage^.Message=LM_PAINT) or (AMessage^.Message=LM_GtkPAINT) then
begin
FPaintMessages.Remove(FMessageQueue.First);
// don't free the DC, this is work for the caller.
// Free the data of our internal gtk messages
if AMessage^.Message=LM_GtkPAINT then
FinalizePaintTagMsg(AMessage);
end;
FMessageQueue.Delete(FMessageQueue.First);
end;
writeln('Peek !!!' );
vlItem := fMessageQueue.FirstMessageItem;
Result := vlItem <> nil;
if Result then begin
lpMsg := vlItem.Msg^;
if (wRemoveMsg and PM_REMOVE) = PM_REMOVE then
fMessageQueue.RemoveMessage(vlItem,FPMF_Internal,true);
end;
end;
@ -6043,7 +6033,7 @@ function TGTKObject.PostMessage(Handle: HWND; Msg: Cardinal; wParam: LongInt;
Parent:=Target.Parent;
while Parent<>nil do begin
ParentHandle:=Parent.Handle;
if FindPaintMessage(ParentHandle)<>nil then begin
if fMessageQueue.FindPaintMessage(ParentHandle)<>nil then begin
Result:=true;
end;
Parent:=Parent.Parent;
@ -6051,27 +6041,17 @@ function TGTKObject.PostMessage(Handle: HWND; Msg: Cardinal; wParam: LongInt;
end;
end;
function ExtractPaintMessageForHandle(hnd: HWnd): PMsg;
var
OldPaintMessage: PLazQueueItem;
begin
Result:=nil;
if (hnd=0) then exit;
OldPaintMessage:=FindPaintMessage(hnd);
if OldPaintMessage<>nil then begin
// delete paint message from queue
Result:=PMsg(OldPaintMessage^.Data);
FPaintMessages.Remove(OldPaintMessage);
FMessageQueue.Delete(OldPaintMessage);
end;
end;
procedure CombinePaintMessages(NewMsg, OldMsg: PMsg);
procedure CombinePaintMessages(NewMsg:PMsg);
// combine NewMsg and OldMsg paint message into NewMsg and free OldMsg
var
vlItem : TGtkMessageQueueItem;
NewData: TLMGtkPaintData;
OldData: TLMGtkPaintData;
OldMsg : PMsg;
begin
vlItem := fMessageQueue.FindPaintMessage(NewMsg^.Hwnd);
if vlItem = nil then exit;
OldMsg := vlItem.Msg;
if OldMsg=nil then exit;
if (NewMsg^.Message=LM_PAINT) or (OldMsg^.Message=LM_PAINT) then begin
// LM_PAINT means: repaint all
@ -6096,13 +6076,11 @@ function TGTKObject.PostMessage(Handle: HWND; Msg: Cardinal; wParam: LongInt;
NewData.Rect.Bottom:=Max(NewData.Rect.Bottom,OldData.Rect.Bottom);
end;
end;
FinalizePaintTagMsg(OldMsg);
Dispose(OldMsg);
fMessageQueue.RemoveMessage(vlItem,FPMF_All,true);
end;
var
AMessage: PMsg;
OldPaintMsg: PMsg;
begin
Result := True;
@ -6114,25 +6092,24 @@ begin
// Message^.Time :=
if (AMessage^.Message=LM_PAINT) or (AMessage^.Message=LM_GtkPAINT) then begin
{ Obsolete, because InvalidateRectangle now works.
// paint messages are the most expensive messages in the LCL
// A paint message to a control will also repaint all child controls.
// -> check if there is already a paint message for one of its parents
// if yes, then skip this message
{if ParentPaintMessageInQueue then begin
if ParentPaintMessageInQueue then begin
FinalizePaintTagMsg(AMessage^);
exit;
end;}
// delete old paint message to this widget,
// so that the widget repaints only once
OldPaintMsg:=ExtractPaintMessageForHandle(Handle);
CombinePaintMessages(AMessage,OldPaintMsg);
FMessageQueue.AddLast(AMessage);
FPaintMessages.Add(FMessageQueue.Last);
end else begin
FMessageQueue.AddLast(AMessage);
end;
CombinePaintMessages(AMessage);
end ;
FMessageQueue.AddMessage(AMessage);
end;
{------------------------------------------------------------------------------
@ -8753,6 +8730,9 @@ end;
{ =============================================================================
$Log$
Revision 1.268 2003/08/18 13:21:23 mattias
renamed lazqueue to lazlinkedlist, patch from Jeroen
Revision 1.267 2003/08/16 15:29:56 mattias
fixed TBitmap.GetHandle

209
lcl/lazlinkedlist.pas Normal file
View File

@ -0,0 +1,209 @@
{
*****************************************************************************
* *
* This file is part of the Lazarus Component Library (LCL) *
* *
* See the file COPYING.LCL, included in this distribution, *
* for details about the copyright. *
* *
* This program is distributed in the hope that it will be useful, *
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
* *
*****************************************************************************
Authors: Mattias Gaertner, Jeroen van Iddekinge
Abstract:
Defines the simple double connected queue TLinkList.
It supports Adding, Deleting, getting First and getting Last in O(1).
Finding can be done in time O(n).
}
unit LazLinkedList;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils;
type
TLinkListItem = class
Next : TLinkListItem;
Prior : TLinkListItem;
procedure ResetItem; virtual;
end;
TLinkList = class
private
FFirstFree: TLinkListItem;
FFreeCount: integer;
FFirst: TLinkListItem;
FLast: TLinkListItem;
FCount: integer;
procedure DisposeItem(AnItem: TLinkListItem);
procedure Unbind(AnItem: TLinkListItem);
protected
function CreateItem: TLinkListItem; virtual; abstract;
function GetNewItem: TLinkListItem;
procedure AddAsLast(AnItem: TLinkListItem);
public
property First: TLinkListItem read FFirst;
property Last: TLinkListItem read FLast;
property Count: integer read FCount;
procedure Delete(AnItem: TLinkListItem);
procedure MoveToLast(AnItem: TLinkListItem);
procedure Clear;
function ConsistencyCheck: integer;
constructor Create;
destructor Destroy; override;
end;
implementation
{ TLinkList }
procedure TLinkListItem.ResetItem;
begin
Next := nil;
Prior := nil;
end;
constructor TLinkList.Create;
begin
inherited Create;
end;
destructor TLinkList.Destroy;
var AnItem: TLinkListItem;
begin
Clear;
// clear the free list
while FFirstFree<>nil do begin
AnItem:=FFirstFree;
FFirstFree:=AnItem.Next;
AnItem.Destroy;
end;
inherited Destroy;
end;
procedure TLinkList.Delete(AnItem: TLinkListItem);
begin
if AnItem=nil then exit;
Unbind(AnItem);
AnItem.Destroy;
end;
procedure TLinkList.MoveToLast(AnItem: TLinkListItem);
begin
if AnItem=nil then exit;
Unbind(AnItem);
AddAsLast(AnItem);
end;
procedure TLinkList.Clear;
begin
while First<>nil do Delete(First);
end;
function TLinkList.GetNewItem: TLinkListItem;
begin
if FFirstFree<>nil then begin
Result:=FFirstFree;
FFirstFree:=FFirstFree.Next;
if FFirstFree<>nil then
FFirstFree.Prior:=nil;
dec(FFreeCount);
end else begin
Result := CreateItem;
end;
Result.Next:=nil;
Result.Prior:=nil;
end;
procedure TLinkList.DisposeItem(AnItem: TLinkListItem);
var i: integer;
begin
if FFreeCount<=2*FCount then begin
AnItem.ResetItem;
AnItem.Next:=FFirstFree;
FFirstFree:=AnItem;
if AnItem.Next<>nil then AnItem.Next.Prior:=AnItem;
inc(FFreeCount);
end else begin
AnItem.Destroy;
if (FCount+5)<2*FFreeCount then begin
for i:=1 to 2 do begin
if FFirstFree<>nil then begin
AnItem:=FFirstFree;
FFirstFree:=FFirstFree.Next;
if FFirstFree<>nil then
FFirstFree.Prior:=nil;
AnItem.Destroy;
dec(FFreeCount);
end;
end;
end;
end;
end;
procedure TLinkList.Unbind(AnItem: TLinkListItem);
begin
if AnItem=nil then exit;
if FFirst=AnItem then FFirst:=FFirst.Next;
if FLast=AnItem then FLast:=FLast.Prior;
if AnItem.Prior<>nil then AnItem.Prior.Next:=AnItem.Next;
if AnItem.Next<>nil then AnItem.Next.Prior:=AnItem.Prior;
AnItem.Prior:=nil;
AnItem.Next:=nil;
dec(FCount);
end;
procedure TLinkList.AddAsLast(AnItem: TLinkListItem);
begin
AnItem.Prior:=FLast;
AnItem.Next:=nil;
FLast:=AnItem;
if AnItem.Prior<>nil then
AnItem.Prior.Next:=AnItem
else
FFirst:=AnItem;
inc(FCount);
end;
function TLinkList.ConsistencyCheck: integer;
var RealCount: integer;
AnItem: TLinkListItem;
begin
// test free list
RealCount:=0;
AnItem:=FFirstFree;
while AnItem<>nil do begin
inc(RealCount);
AnItem:=AnItem.Next;
end;
if FFreeCount<>RealCount then begin
Result:=-1; exit;
end;
// test items
RealCount:=0;
AnItem:=FFirst;
while AnItem<>nil do begin
if (AnItem.Next<>nil) and (AnItem.Next.Prior<>AnItem) then begin
Result:=-2; exit;
end;
if (AnItem.Prior<>nil) and (AnItem.Prior.Next<>AnItem) then begin
Result:=-3; exit;
end;
inc(RealCount);
AnItem:=AnItem.Next;
end;
if FCount<>RealCount then begin
Result:=-4; exit;
end;
Result:=0;
end;
end.

257
lcl/lazqueue.pp
View File

@ -1,257 +0,0 @@
{
Author: Mattias Gaertner
*****************************************************************************
* *
* This file is part of the Lazarus Component Library (LCL) *
* *
* See the file COPYING.LCL, included in this distribution, *
* for details about the copyright. *
* *
* This program is distributed in the hope that it will be useful, *
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
* *
*****************************************************************************
Abstract:
Defines the simple double connected queue TLazQueue.
A Queue stores a set of pointers and supports Adding, Deleting, getting
First and getting Last in O(1).
Finding can be done in time O(n).
}
unit LazQueue;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils;
type
PLazQueueItem = ^TLazQueueItem;
TLazQueueItem = record
Next, Prior: PLazQueueItem;
Data: Pointer;
end;
TLazQueue = class
private
FFirstFree: PLazQueueItem;
FFreeCount: integer;
FFirst: PLazQueueItem;
FLast: PLazQueueItem;
FCount: integer;
function GetNewItem: PLazQueueItem;
procedure DisposeItem(AnItem: PLazQueueItem);
procedure Unbind(AnItem: PLazQueueItem);
procedure AddAsLast(AnItem: PLazQueueItem);
public
property First: PLazQueueItem read FFirst;
property Last: PLazQueueItem read FLast;
function FirstData: Pointer;
function LastData: Pointer;
property Count: integer read FCount;
procedure AddLast(Data: Pointer);
procedure Delete(AnItem: PLazQueueItem);
procedure MoveToLast(AnItem: PLazQueueItem);
function Find(Data: Pointer): PLazQueueItem;
procedure Clear;
function ConsistencyCheck: integer;
procedure WriteDebugReport;
constructor Create;
destructor Destroy; override;
end;
implementation
{ TLazQueue }
constructor TLazQueue.Create;
begin
inherited Create;
end;
destructor TLazQueue.Destroy;
var AnItem: PLazQueueItem;
begin
Clear;
// clear the free list
while FFirstFree<>nil do begin
AnItem:=FFirstFree;
FFirstFree:=AnItem^.Next;
Dispose(AnItem);
end;
inherited Destroy;
end;
function TLazQueue.FirstData: Pointer;
begin
if FFirst<>nil then
Result:=FFirst^.Data
else
Result:=nil;
end;
function TLazQueue.LastData: Pointer;
begin
if FLast<>nil then
Result:=FLast^.Data
else
Result:=nil;
end;
procedure TLazQueue.AddLast(Data: Pointer);
var NewItem: PLazQueueItem;
begin
NewItem:=GetNewItem;
NewItem^.Data:=Data;
AddAsLast(NewItem);
end;
procedure TLazQueue.Delete(AnItem: PLazQueueItem);
begin
if AnItem=nil then exit;
Unbind(AnItem);
DisposeItem(AnItem);
end;
procedure TLazQueue.MoveToLast(AnItem: PLazQueueItem);
begin
if AnItem=nil then exit;
Unbind(AnItem);
AddAsLast(AnItem);
end;
procedure TLazQueue.Clear;
begin
while First<>nil do Delete(First);
end;
function TLazQueue.GetNewItem: PLazQueueItem;
begin
if FFirstFree<>nil then begin
Result:=FFirstFree;
FFirstFree:=FFirstFree^.Next;
if FFirstFree<>nil then
FFirstFree^.Prior:=nil;
dec(FFreeCount);
end else begin
New(Result);
end;
Result^.Next:=nil;
Result^.Prior:=nil;
Result^.Data:=nil;
end;
procedure TLazQueue.DisposeItem(AnItem: PLazQueueItem);
var i: integer;
begin
if FFreeCount<=2*FCount then begin
AnItem^.Next:=FFirstFree;
AnItem^.Prior:=nil;
AnItem^.Data:=nil;
FFirstFree:=AnItem;
if AnItem^.Next<>nil then AnItem^.Next^.Prior:=AnItem;
inc(FFreeCount);
end else begin
Dispose(AnItem);
if (FCount+5)<2*FFreeCount then begin
for i:=1 to 2 do begin
if FFirstFree<>nil then begin
AnItem:=FFirstFree;
FFirstFree:=FFirstFree^.Next;
if FFirstFree<>nil then
FFirstFree^.Prior:=nil;
Dispose(AnItem);
dec(FFreeCount);
end;
end;
end;
end;
end;
procedure TLazQueue.Unbind(AnItem: PLazQueueItem);
begin
if AnItem=nil then exit;
if FFirst=AnItem then FFirst:=FFirst^.Next;
if FLast=AnItem then FLast:=FLast^.Prior;
if AnItem^.Prior<>nil then AnItem^.Prior^.Next:=AnItem^.Next;
if AnItem^.Next<>nil then AnItem^.Next^.Prior:=AnItem^.Prior;
AnItem^.Prior:=nil;
AnItem^.Next:=nil;
dec(FCount);
end;
procedure TLazQueue.AddAsLast(AnItem: PLazQueueItem);
begin
AnItem^.Prior:=FLast;
AnItem^.Next:=nil;
FLast:=AnItem;
if AnItem^.Prior<>nil then
AnItem^.Prior^.Next:=AnItem
else
FFirst:=AnItem;
inc(FCount);
end;
function TLazQueue.Find(Data: Pointer): PLazQueueItem;
begin
Result:=FFirst;
while (Result<>nil) do
if Result^.Data=Data then exit;
end;
function TLazQueue.ConsistencyCheck: integer;
var RealCount: integer;
AnItem: PLazQueueItem;
begin
// test free list
RealCount:=0;
AnItem:=FFirstFree;
while AnItem<>nil do begin
inc(RealCount);
AnItem:=AnItem^.Next;
end;
if FFreeCount<>RealCount then begin
Result:=-1; exit;
end;
// test items
RealCount:=0;
AnItem:=FFirst;
while AnItem<>nil do begin
if (AnItem^.Next<>nil) and (AnItem^.Next^.Prior<>AnItem) then begin
Result:=-2; exit;
end;
if (AnItem^.Prior<>nil) and (AnItem^.Prior^.Next<>AnItem) then begin
Result:=-3; exit;
end;
inc(RealCount);
AnItem:=AnItem^.Next;
end;
if FCount<>RealCount then begin
Result:=-4; exit;
end;
Result:=0;
end;
procedure TLazQueue.WriteDebugReport;
var AnItem: PLazQueueItem;
begin
writeln('TLazQueue.WriteDebugReport: Consistency=',ConsistencyCheck
,' Count=',Count,' FreeCount=',FFreeCount);
AnItem:=FFirst;
while AnItem<>nil do begin
writeln(' Item: Data=',HexStr(Cardinal(AnItem^.Data),8)
,' Self=',HexStr(Cardinal(AnItem),8)
,' Next=',HexStr(Cardinal(AnItem^.Next),8)
,' Prior=',HexStr(Cardinal(AnItem^.Prior),8)
);
AnItem:=AnItem^.Next;
end;
end;
end.