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

* TTimer uses winapi-interface now instead of sendmessage-interface, stoppok

Browse Source 
git-svn-id: trunk@258 -
This commit is contained in:
lazarus 2001-04-06 22:25:15 +00:00
parent d278671970
commit b11e8615f1
9 changed files with 216 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
lcl/include/interfacebase.inc
View File

@ -248,6 +248,11 @@ begin
Result := false;
end;
function TInterfaceBase.KillTimer (hWnd : HWND; uIDEvent : cardinal) : boolean;
begin
Result := false;
end;
function TInterfaceBase.LineTo(DC: HDC; X, Y: Integer): Boolean;
begin
Result := False;
@ -386,6 +391,11 @@ begin
Result := CLR_INVALID;
end;
function TInterfaceBase.SetTimer(hWnd: HWND; nIDEvent, uElapse: integer; lpTimerFunc: TFNTimerProc) : integer;
begin
Result := 0;
end;
function TInterfacebase.SetWindowLong(Handle: HWND; Idx: Integer; NewLong : Longint): LongInt;
begin
Result := -1;
@ -438,6 +448,9 @@ end;
{ =============================================================================
$Log$
Revision 1.14 2001/04/06 22:25:14 lazarus
* TTimer uses winapi-interface now instead of sendmessage-interface, stoppok
Revision 1.13 2001/03/26 14:58:31 lazarus
MG: setwindowpos + bugfixes

66
lcl/include/timer.inc
View File

@ -4,24 +4,36 @@
{
TTimer Delphi compatibility:
In contrast to the Delphi timer there are some more public
properties and functions, because the GTK interface needs
access to them. To avoid invalid access to them, there's a
new private variable "AllowIDAccess" which controls access
to the timerID property which is vital for the class.
I'm not sure if this approach is thread safe but it works
for the moment. Just keep in mind not to modify the TimerID
from your application.
nearly 100% compatible, only WndProc is missing
The procedure Timer is also public now, because the gtk-
implementation of the timer makes this neccessary (as far as
I know now)
TODO: -
Possible improvements: -
Bugs: unknown
}
const
cIdNoTimer = -1; { timer ID for an invalid timer }
{------------------------------------------------------------------------------
Method: TimerCBProc
Params: handle - handle (self) of the TTimer instance
message - should be LM_Timer, currently unused (s. Win32 API)
IDEvent - currently unused (s. Win32 API)
Time - currently unused (s. Win32 API)
Returns: Nothing
Callback for a timer which will call TTimer.Timer. This proc will be used
if the InterfaceObject uses a callback instead of delivering a LM_Timer
message.
------------------------------------------------------------------------------}
procedure TimerCBProc(Handle: HWND; message : cardinal; IDEvent: Integer; Time: Cardinal);
begin
// Cast Handle back to timer
TTimer(Handle).Timer (message);
end;
{------------------------------------------------------------------------------
Method: TTimer.Create
Params: AOwner: the owner of the class
@ -35,7 +47,6 @@ begin
FInterval := 1000;
FTimerID := cIdNoTimer;
FEnabled := true;
AllowIdAccess := false;
end;
{------------------------------------------------------------------------------
@ -51,18 +62,6 @@ begin
inherited Destroy;
end;
{------------------------------------------------------------------------------
Method: TTimer.SetTimerID
Params: Value - a timer id
Returns: Nothing
Sets an id for the timer if access to the id is currently allowed.
------------------------------------------------------------------------------}
procedure TTimer.SetTimerID (Value : integer);
begin
if AllowIdAccess then FTimerID := value;
end;
{------------------------------------------------------------------------------
Method: TTimer.KillTimer
Params: Nothing
@ -72,8 +71,12 @@ end;
------------------------------------------------------------------------------}
procedure TTimer.KillTimer;
begin
Assert(False, 'Trace:In TTimer.KillTimer');
if FTimerID <> cIdNoTimer then
CNSendMessage(LM_DESTROY, Self, nil);
begin
FEnabled := false;
InterfaceObject.KillTimer (integer(Self), FTimerID);
end;
FTimerID := cIdNoTimer;
end;
@ -87,12 +90,8 @@ end;
procedure TTimer.UpdateTimer;
begin
KillTimer;
if (FEnabled) and (FInterval > 0) and Assigned (FOnTimer) then
begin
AllowIdAccess := true;
CNSendMessage(LM_CREATE, Self, nil);
AllowIdAccess := false;
end;
if (FEnabled) and (FInterval > 0) and Assigned (FOnTimer)
then FTimerID := InterfaceObject.SetTimer(Integer(Self), 0, FInterval, @TimerCBProc);
end;
{------------------------------------------------------------------------------
@ -104,7 +103,7 @@ end;
------------------------------------------------------------------------------}
procedure TTimer.Timer (var msg);
begin
Assert(False, 'Trace:Timer received a message -TIMER');
Assert(false, 'Trace:Timer received a message -TIMER');
if Assigned (FOnTimer) and (FEnabled) and (FInterval > 0) then
FOnTimer(Self);
end;
@ -159,6 +158,9 @@ end;
{
$Log$
Revision 1.2 2001/04/06 22:25:14 lazarus
* TTimer uses winapi-interface now instead of sendmessage-interface, stoppok
Revision 1.1 2000/07/13 10:28:28 michael
+ Initial import

13
lcl/include/winapi.inc
View File

@ -251,6 +251,11 @@ begin
Result := InterfaceObject.InvalidateRect(aHandle, Rect, bErase);
end;
function KillTimer (hWnd : HWND; uIDEvent : cardinal) : boolean;
begin
Result := InterfaceObject.KillTimer(hWnd, uIDEvent);
end;
function LineTo(DC: HDC; X, Y: Integer): Boolean;
begin
Result := InterfaceObject.LineTo(DC, X, Y);
@ -386,6 +391,11 @@ begin
Result := InterfaceObject.SetTextColor(DC, Color);
end;
function SetTimer(hWnd: HWND; nIDEvent, uElapse: integer; lpTimerFunc: TFNTimerProc) : integer;
begin
Result := InterfaceObject.SetTimer(hWnd, nIDEvent, uElapse, lpTimerFunc);
end;
function SetWindowLong(Handle: HWND; Idx: Integer; NewLong : Longint): LongInt;
begin
Result := InterfaceObject.SetWindowLong(handle, Idx, NewLong);
@ -971,6 +981,9 @@ end;
{ =============================================================================
$Log$
Revision 1.13 2001/04/06 22:25:14 lazarus
* TTimer uses winapi-interface now instead of sendmessage-interface, stoppok
Revision 1.12 2001/03/26 14:58:31 lazarus
MG: setwindowpos + bugfixes

8
lcl/include/winapih.inc
View File

@ -13,7 +13,6 @@
!! if needed
******************************************************************************)
{******************************************************************************
Platform specific stuff
******************************************************************************}
@ -84,6 +83,8 @@ Function InvalidateRect(aHandle : HWND; Rect : pRect; bErase : Boolean) : Boolea
//function IsCharAlphaNumeric --> independent
//function IsRectEmpty --> independent
function KillTimer (hWnd : HWND; uIDEvent : cardinal) : boolean; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
function LineTo(DC: HDC; X, Y: Integer): Boolean; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
function MaskBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc, YSrc: Integer; Mask: HBITMAP; XMask, YMask: Integer; Rop: DWORD): Boolean; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
@ -123,6 +124,7 @@ function SetScrollInfo(Handle: HWND; SBStyle : Integer; ScrollInfo: TScrollInfo;
function SetSysColors(cElements: Integer; const lpaElements; const lpaRgbValues): Boolean; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
Function SetTextCharacterExtra(_hdc : hdc; nCharExtra : Integer):Integer; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
function SetTextColor(DC: HDC; Color: TColorRef): TColorRef; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
function SetTimer(hWnd: HWND; nIDEvent, uElapse: integer; lpTimerFunc: TFNTimerProc) : integer; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
function SetWindowLong(Handle: HWND; Idx: Integer; NewLong : Longint): Longint;{$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
function SetWindowOrgEx(dc : hdc; NewX, NewY : Integer; Var Point : TPoint): Boolean; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
function SetWindowPos(hWnd: HWND; hWndInsertAfter: HWND;
@ -168,6 +170,7 @@ type
LPARAM = LongInt;
LRESULT = LongInt;
//##apiwiz##spi## // Do not remove
function AdjustWindowRectEx( Var Rect: TRect; Style1: Word; MenuExist : Boolean; Style2 : Word) : Boolean;
@ -223,6 +226,9 @@ function UnionRect(var lprcDst: TRect; const lprcSrc1, lprcSrc2: TRect): Boolean
{ =============================================================================
$Log$
Revision 1.10 2001/04/06 22:25:14 lazarus
* TTimer uses winapi-interface now instead of sendmessage-interface, stoppok
Revision 1.9 2001/03/26 14:58:31 lazarus
MG: setwindowpos + bugfixes

47
lcl/interfaces/gtk/gtkcallback.inc
View File

@ -897,19 +897,43 @@ begin
Result := DeliverMessage(Data, Mess) = 0;
end;
{ Directly call the Timer function of the TTimer object.
(As far as I know this can't be dispatched like it's done in the other callbacks!) }
// MWE: Post a LM_Timer message !!!
{------------------------------------------------------------------------------
Method: gtkTimerCB
Params: Data - pointer TGtkITimerInfo structure
Returns: 1 - 1 tells gtk to restart the timer
0 - 0 will stop the gtk timer
function gtkTimerCB (data : gpointer) : gint; cdecl;
Callback for gtk timer. Depending on "data" either user-callback function
will be called or a timer message will be delivered.
WARNING: There seems to be a bug in gtk-1.2.x which breaks
gtk_timeout_remove so we have to dispose data here & return 0
(s.a. KillTimer).
------------------------------------------------------------------------------}
function gtkTimerCB(Data: gPointer): gint; cdecl;
var
P : ^TTimer;
Mess : TLMessage;
begin
EventTrace('timer', data);
P := @data;
P^.Timer(TTimer(data));
result := 1; { returning 0 would stop the timer, 1 will restart it }
EventTrace ('TimerCB', data);
Result := 1; // assume: timer will continue
if PGtkITimerinfo(Data)^.TimerFunc <> nil
then begin // Call users timer function
PGtkITimerinfo(Data)^.TimerFunc(PGtkITimerinfo(Data)^.Handle,
LM_TIMER,
PGtkITimerinfo(Data)^.IDEvent,
0{WARN: should be: GetTickCount});
end
else if (pointer (PGtkITimerinfo(Data)^.Handle) <> nil)
then begin // Handle through default message handler
Mess.msg := LM_TIMER;
Mess.WParam := PGtkITimerinfo(Data)^.IDEvent;
Mess.LParam := LongInt (PGtkITimerinfo(Data)^.TimerFunc);
DeliverMessage (Pointer (PGtkITimerinfo(Data)^.Handle), Mess);
end
else begin
result := 0; // stop timer
dispose (PGtkITimerinfo(Data)); // free memory with timer data
end;
end;
function gtkFocusInNotifyCB (widget : PGtkWidget; event : PGdkEvent; data : gpointer) : GBoolean; cdecl;
@ -1116,6 +1140,9 @@ end;
{ =============================================================================
$Log$
Revision 1.30 2001/04/06 22:25:14 lazarus
* TTimer uses winapi-interface now instead of sendmessage-interface, stoppok
Revision 1.29 2001/03/27 11:11:13 lazarus
MG: fixed mouse msg, added filedialog initialdir

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

@ -43,6 +43,7 @@ type
FMessageQueue: TList;
FGTKToolTips: PGtkToolTips;
FAccelGroup: PgtkAccelGroup;
FTimerData : TList; // keeps track of timer evenet structures
FStockNullBrush: HBRUSH;
FStockBlackBrush: HBRUSH;
@ -203,6 +204,14 @@ type
destroy_func: TGtkSignalDestroy;
end;
{ lazarus GtkInterface definition for additional timer data, not in gtk }
PGtkITimerInfo = ^TGtkITimerinfo;
TGtkITimerInfo = record
Handle : hWND;
IDEvent : Integer;
TimerFunc: TFNTimerProc;
end;
var
Event : TGDKEVENTCONFIGURE;
gtk_handler_quark: TGQuark;
@ -249,6 +258,9 @@ end.
{ =============================================================================
$Log$
Revision 1.13 2001/04/06 22:25:14 lazarus
* TTimer uses winapi-interface now instead of sendmessage-interface, stoppok
Revision 1.12 2001/03/27 21:12:54 lazarus
MWE:
+ Turned on longstrings

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

@ -26,6 +26,7 @@ begin
FGDIObjects := TDynHashArray.Create(-1);
FMessageQueue := TList.Create;
FAccelGroup := gtk_accel_group_new();
FTimerData := TList.Create;
end;
{------------------------------------------------------------------------------
@ -42,6 +43,7 @@ const
var
n: Integer;
p: PMsg;
pTimerInfo : PGtkITimerinfo;
GDITypeCount: array[TGDIType] of Integer;
GDIType: TGDIType;
HashItem: PDynHashArrayItem;
@ -113,10 +115,24 @@ begin
end;
end;
n := FTimerData.Count;
if (n > 0) then
begin
WriteLN(Format('[TgtkObject.Destroy] WARNING: There are %d TimerInfo structures left, I''ll free them' ,[n]));
while (n > 0) do
begin
dec (n);
pTimerInfo := PGtkITimerinfo (FTimerData.Items[n]);
Dispose (pTimerInfo);
FTimerData.Delete (n);
end;
end;
FMessageQueue.Free;
FDeviceContexts.Free;
FGDIObjects.Free;
FKeyStateList.Free;
FTimerData.Free;
gtk_accel_group_unref(FAccelGroup);
inherited Destroy;
@ -390,11 +406,8 @@ begin
LM_DESTROY :
begin
if (Sender is TTimer) then begin
Assert(False, 'Trace:removing timer!!!');
gtk_timeout_remove((Sender as TTimer).TimerID);
end
else if (Sender is TWinControl) or (Sender is TCommonDialog) then begin
if (Sender is TWinControl) or (Sender is TCommonDialog) then
begin
if Handle<>0 then
gtk_widget_destroy(PGtkWidget(Handle));
end
@ -1642,8 +1655,8 @@ begin
then CompStyle := TMenu(Sender).FCompStyle
else if (Sender is TCommonDialog)
then CompStyle := TCommonDialog(Sender).FCompStyle
else if (Sender is TTimer)
then CompStyle := csTimer;
else
;
// the following is for debug only
if caption = '' then caption := Sender.ClassName;
@ -2077,13 +2090,6 @@ begin
gtk_widget_show (P);
end;
csTimer:
begin
Assert(False, 'Trace:Creating a timer in CreateComponent');
with (Sender as TTimer) do
TimerID := gtk_timeout_add (Interval, @gtkTimerCB, Sender);
end;
csPage: // TPage - Notebook page
begin
P := gtk_hbox_new(false, 0);
@ -2817,6 +2823,9 @@ end;
{ =============================================================================
$Log$
Revision 1.43 2001/04/06 22:25:14 lazarus
* TTimer uses winapi-interface now instead of sendmessage-interface, stoppok
Revision 1.42 2001/03/27 21:12:54 lazarus
MWE:
+ Turned on longstrings

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

@ -2216,6 +2216,38 @@ begin
end;
{------------------------------------------------------------------------------
Function: KillTimer
Params: hWnd:
nIDEvent:
Returns:
WARNING: There seems to be a bug in gtk-1.2.x which breaks gtk_timeout_remove
thus we can't dispose PGtkITimerinfo here (s.a. gtkTimerCB).
------------------------------------------------------------------------------}
function TGTKObject.KillTimer (hWnd : HWND; uIDEvent : cardinal) : boolean;
var
n : integer;
p : PGtkITimerinfo;
begin
Assert(False, 'Trace:removing timer!!!');
n := FTimerData.Count;
while (n > 0) do
begin
dec (n);
p := PGtkITimerinfo (FTimerData.Items[n]);
if ((pointer (hWnd) <> nil) and (hWnd = p^.Handle)) or
((pointer(hWnd) = nil) and (uIDEvent = p^.IDEvent)) then
begin
gtk_timeout_remove (uIDEvent);
FTimerData.Delete (n);
pointer (p^.Handle) := nil; // mark as invalid
p^.TimerFunc := nil;
// Dispose (p); // this will be done in gtkTimerCB!
end;
end;
end;
{------------------------------------------------------------------------------
Function: LineTo
Params: none
@ -3179,6 +3211,42 @@ begin
Assert(False, Format('trace:< [TgtkObject.SetTextColor] DC: 0x%x Color: %8x --> %8x', [Integer(DC), Color, Result]));
end;
{------------------------------------------------------------------------------
Function: SetTimer
Params: hWnd:
nIDEvent:
uElapse:
lpTimerFunc:
Returns: a GTK-timer id
This function will create a GTK timer object and associate a callback to it.
Design: Currently only a callback to the TTimer class is implemented.
------------------------------------------------------------------------------}
function TGTKObject.SetTimer(hWnd: HWND; nIDEvent, uElapse: integer; lpTimerFunc: TFNTimerProc) : integer;
var
PTimerInfo: PGtkITimerinfo;
begin
if ((hWnd = 0) and (lpTimerFunc = nil))
then Result := 0
else begin
New (PTimerInfo);
PTimerInfo^.Handle := hWND;
PTimerInfo^.IDEvent := nIDEvent;
PTimerInfo^.TimerFunc := lpTimerFunc;
gtk_timeout_add(uElapse, @gtkTimerCB, PTimerInfo);
FTimerData.Add (PTimerInfo);
end;
end;
(*begin
if (hWnd <> 0)
then Result := gtk_timeout_add(uElapse, @gtkTimerCB, Pointer (hWnd))
else if (lpTimerFunc <> nil)
then Result := gtk_timeout_add(uElapse, @gtkTimerCBDirect, Pointer (hWnd))
else
Result := 0
end;*)
{------------------------------------------------------------------------------
Procedure: SetWindowLong
Params: none
@ -3446,6 +3514,9 @@ end;
{ =============================================================================
$Log$
Revision 1.32 2001/04/06 22:25:14 lazarus
* TTimer uses winapi-interface now instead of sendmessage-interface, stoppok
Revision 1.31 2001/03/26 14:58:31 lazarus
MG: setwindowpos + bugfixes

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

@ -59,6 +59,8 @@ function HideCaret(hWnd: HWND): Boolean; override;
function InvalidateRect(aHandle : HWND; Rect : pRect; bErase : Boolean) : Boolean; override;
function KillTimer (hWnd : HWND; uIDEvent : cardinal) : boolean; override;
function LineTo(DC: HDC; X, Y: Integer): Boolean; override;
function MaskBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc, YSrc: Integer; Mask: HBITMAP; XMask, YMask: Integer; Rop: DWORD): Boolean; override;
@ -90,6 +92,7 @@ function SetScrollInfo(Handle : HWND; SBStyle : Integer; ScrollInfo: TScrollInfo
function SetSysColors(cElements: Integer; const lpaElements; const lpaRgbValues): Boolean; override;
Function SetTextCharacterExtra(_hdc : hdc; nCharExtra : Integer):Integer; override;
function SetTextColor(DC: HDC; Color: TColorRef): TColorRef; override;
function SetTimer(hWnd: HWND; nIDEvent, uElapse: integer; lpTimerFunc: TFNTimerProc) : integer; override;
function SetWindowLong(Handle: HWND; Idx: Integer; NewLong : Longint): LongInt;
function SetWindowOrgEx(dc : hdc; NewX, NewY : Integer; Var lpPoint : TPoint) : Boolean; override;
function SetWindowPos(hWnd: HWND; hWndInsertAfter: HWND;
@ -108,6 +111,9 @@ Function WindowFromPoint(Point : TPoint) : HWND; override;
{ =============================================================================
$Log$
Revision 1.14 2001/04/06 22:25:15 lazarus
* TTimer uses winapi-interface now instead of sendmessage-interface, stoppok
Revision 1.13 2001/03/26 14:58:32 lazarus
MG: setwindowpos + bugfixes