1 unit customdrawn_x11proc;
2
3 {$mode objfpc}{$H+}
4
5 {$I customdrawndefines.inc}
6
7 interface
8
9 uses
10 // rtl+ftl
11 Types, Classes, SysUtils,
12 fpimage, fpcanvas, ctypes,
13 X, XLib,
14 BaseUnix,Unix,
15 // Custom Drawn Canvas
16 IntfGraphics, lazcanvas,
17 //
18 GraphType, Controls, LCLMessageGlue, WSControls, LCLType, LCLProc,
19 customdrawnproc;
20
21 type
22 TX11WindowInfo = class(TCDForm)
23 public
24 Window: X.TWindow;
25 // Used and valid only during event processing
26 XEvent: PXEvent;
27 // X11 extra objects
28 Attr: XLib.TXWindowAttributes;
29 Colormap: TColormap;
30 GC: TGC;
31 ColorDepth: Byte;
32 {$ifdef CD_X11_SmartPaint}
33 Valid: Boolean;
34 Moved: Boolean;
35 {$endif}
36 end;
37
38 {$ifdef CD_X11_UseNewTimer}
39 TWSTimerProc = procedure of object;
40
41 { TCDX11Timer }
42 TCDX11Timer = class (TObject)
43 Next: TCDX11Timer;
44 Previous: TCDX11Timer;
45 Interval: Integer;
46 Expires: TDateTime;
47 func: TWSTimerProc;
48 constructor create (WSInterval: Integer; WSfunc: TWSTimerProc);
49 procedure Insert;
50 procedure Remove;
51 procedure Expired;
52 destructor destroy;
53 end;
54
55 { TCDX11TimerThread }
56
57 TCDX11TimerThread = class(TThread)
58 private
59 rfds: TFDset;
60 Timeout: cint;
61 retval,ByteRec: integer;
62 protected
63 procedure Execute; override;
64 public
65 X11TimerPipeIn,X11TimerPipeOut: Integer; // Pipe to Timer
66 MainLoopPipeIn,MainLoopPipeOut: Integer; // Pipe to Main Loop
67 constructor Create(CreateSuspended: Boolean; const StackSize: SizeUInt=DefaultStackSize
68 );
69 end;
70
71 var
72 X11TimerThread: TCDX11TimerThread;
73
74 {$endif}
75
76 const
77 fpFD_SETSIZE = 1024; // As defined in typesizes.h
78 KMsToDateTime = 86400000; // # of milliseconds in a day
79
RectToXRectnull80 function RectToXRect(const ARect: TRect): TXRectangle;
XRectToRectnull81 function XRectToRect(const ARect: TXRectangle): TRect;
XButtonToMouseButtonnull82 function XButtonToMouseButton(const XButton: cint; var MouseButton: TMouseButton): Boolean;
GetXEventNamenull83 function GetXEventName(Event: LongInt): String;
84
85 implementation
86 {$ifdef CD_X11_UseNewTimer}
87 uses CustomDrawnInt;
88
89 {$endif}
90
RectToXRectnull91 function RectToXRect(const ARect: TRect): TXRectangle;
92 begin
93 Result.x := ARect.Left;
94 Result.y := ARect.Top;
95 Result.width := ARect.Right - ARect.Left;
96 Result.height := ARect.Bottom - ARect.Top;
97 end;
98
XRectToRectnull99 function XRectToRect(const ARect: TXRectangle): TRect;
100 begin
101 Result.Left := ARect.x;
102 Result.Top := ARect.y;
103 Result.Right := ARect.x + ARect.width;
104 Result.Bottom := ARect.y + ARect.height;
105 end;
106
107 { Returns True if the button is indeed a mouse button
108 and False if it's the mouse wheel }
XButtonToMouseButtonnull109 function XButtonToMouseButton(const XButton: cint; var MouseButton: TMouseButton): Boolean;
110 const
111 ButtonTable: array[1..3] of TMouseButton = (mbLeft, mbMiddle, mbRight);
112 begin
113 Result := False;
114
115 if (XButton > 3) or (XButton < 1) then Exit;
116
117 MouseButton := ButtonTable[XButton];
118
119 Result := True;
120 end;
121
GetXEventNamenull122 function GetXEventName(Event: LongInt): String;
123 const
124 EventNames: array[2..34] of String = (
125 'KeyPress', 'KeyRelease', 'ButtonPress', 'ButtonRelease', 'MotionNotify',
126 'EnterNotify', 'LeaveNotify', 'FocusIn', 'FocusOut', 'KeymapNotify',
127 'Expose', 'GraphicsExpose', 'NoExpose', 'VisibilityNotify', 'CreateNotify',
128 'DestroyNotify', 'UnmapNotify', 'MapNotify', 'MapRequest', 'ReparentNotify',
129 'ConfigureNotify', 'ConfigureRequest', 'GravityNotify', 'ResizeRequest',
130 'CirculateNotify', 'CirculateRequest', 'PropertyNotify', 'SelectionClear',
131 'SelectionRequest', 'SelectionNotify', 'ColormapNotify', 'ClientMessage',
132 'MappingNotify');
133 begin
134 if (Event >= Low(EventNames)) and (Event <= High(EventNames)) then
135 Result := EventNames[Event]
136 else
137 Result := '#' + IntToStr(Event);
138 end;
139
140 {$ifdef CD_X11_UseNewTimer}
141
142 { TCDX11TimerThread }
143
144 procedure TCDX11TimerThread.Execute;
145 var
146 Answ: array [0..80] of byte;
147 Answlen: Integer;
148 ANextTime: TDateTime absolute answ;
149 NextToExpire,TNow,TDiff: TDateTime;
150 HeadTimer: TCDX11Timer;
151 begin
152 retval:= AssignPipe(X11TimerPipeIn,X11TimerPipeOut);
153 retval:= AssignPipe(MainLoopPipeIn,MainLoopPipeOut);
154 WriteLn('TimerThread: Started!');
155 NextToExpire:= Now+10; // Ten days in future - high enough
156 Repeat
157 TNow := Now;
158 if NextToExpire > TNow+7 then // no timers until next week,
159 //or List Head just processed
160 Timeout:= -1 // wait until the first timer is activated
161 else if CDWidgetSet.XTimerListHead = nil then
162 Timeout:= -1
163 else begin
164 // Pick up timer which will expire first
165 // We must recalculate each time, because a message in between
166 // may have interrupted our timeout.
167 HeadTimer := CDWidgetSet.XTimerListHead;
168 NextToExpire:= HeadTimer.Expires;
169 // Compute how many ms from now
170 TDiff:= NextToExpire-Now;
171 Timeout:= DateTimeToMilliseconds(Tdiff);
172 // if already expired (we're late) handle right now
173 if Timeout <=0 then Timeout:= 0;
174 end;
175 // Wait for a message telling that the timer list has changed,
176 // until our current timer (if any) expires
177 fpFD_ZERO(rfds);
178 fpFD_SET(X11TimerPipeIn,rfds);
179 retval:= fpSelect(fpFD_SETSIZE,@rfds,nil,nil,Timeout);
180 if (retval <> 0) then begin // We've received a message
181 ByteRec := FileRead(X11TimerPipeIn,Answ,sizeof(Answ));
182 // Debugln doesn't like to be executed in a thread which isn't the MT
183 // and after a number of writes crashes with a DISK FULL error!
184 //WriteLn('TimerThread: Got message!');
185 if ByteRec >=SizeOf(ANextTime) then begin
186 if ANextTime < NextToExpire then NextToExpire:=ANextTime;
187 end;
188 //WriteLn(Format('TimerThread: Message received - NextTime= %s',[DateTimeToStr(ANextTime)]));
189 end
190 else begin // A Timer has expired - Send a message to Main Loop
191 // message content is irrelevant. We put Timeout for debug
192 ANextTime:= Timeout;
193 FileWrite(MainLoopPipeOut,Answ,sizeOf(Timeout));
194 // we don't want to send twice a messages for the same timer
195 // When timer is processed, the list is updateded and we will receive
196 // a new message. So we set NextToExpire to a value larger than any
197 // expectable value
198 NextToExpire:= TNow+10;
199 end;
200 until Terminated;
201 end;
202
203 constructor TCDX11TimerThread.Create(CreateSuspended: Boolean;
204 const StackSize: SizeUInt);
205 var
206 thisTM: TThreadManager;
207 begin
208 GetThreadManager(thisTM);
209 if not Assigned(thisTM.InitManager) then begin
210 Raise Exception.Create
211 ('You must define UseCThread (-dUseCThreads in Project Options-> Compiler Options) in order to run this program!');
212 end;
213 inherited Create (CreateSuspended);
214 {Priority := 99; // it would be nice to assign priority and policy
215 Policy := SCHED_RR;} // but it depends on application rights to do so
216 FreeOnTerminate := True;
217 // Pipes do not yet exist. Better make it clear
218 MainLoopPipeIn:= -1;
219 MainLoopPipeOut:= -1;
220 X11TimerPipeIn:= -1;
221 X11TimerPipeOut:= -1;
222 end;
223
224 { TCDX11Timer }
225
226 constructor TCDX11Timer.create(WSInterval: Integer; WSfunc: TWSTimerProc);
227 {$ifdef Verbose_CD_X11_Timer}
228 var
229 lTInterval: Integer;
230 TDiff,TNow: TDateTime;
231 {$endif}
232 begin
233 {$ifdef TimerUseCThreads}
234 if X11TimerThread.Suspended then begin
235 X11TimerThread.Suspended:= False; // Activate Timer Thread
236 end;
237 {$endif}
238 Interval:= WSInterval; // Interval in ms
239 Func:= WSfunc; // OnTimeEvent
240 Expires:= Now + Interval/KMsToDateTime; //
241 {$ifdef Verbose_CD_X11_Timer}
242 TNow:= Now;
243 TDiff:= Expires - TNow;
244 lTInterval:=DateTimeToMilliseconds(Tdiff);
245 DebugLn(Format('X11_Timer create: Interval= %d, Calculated=%d',[Interval,lTInterval]));
246 {$endif}
247 Previous:= Nil;
248 Next:= Nil;
249 end;
250
251 procedure TCDX11Timer.Insert;
252 var
253 lTimer,PTimer,NTimer: TCDX11Timer;
254 ABuffer: array[0..15] of byte;
255 ExpireTime: TDateTime absolute ABuffer;
256 begin
257 {$ifdef Verbose_CD_X11_Timer}
258 DebugLn(Format('TCDX11Timer Insert: Interval := %d',[Interval]));
259 {$endif}
260 if CDWidgetSet.XTimerListHead = nil then begin// The list is empty
261 CDWidgetSet.XTimerListHead:= self;
262 Previous:=Nil; // This is the first and only timer
263 Next:=Nil;
264 end
265 else begin
266 PTimer:=nil; // previous in list
267 NTimer:=nil; // Next in list
268 lTimer := CDWidgetSet.XTimerListHead;
269 while lTimer.Expires <= Expires do begin
270 PTimer := ltimer;
271 if not assigned(lTimer.Next) then Break
272 else lTimer:= lTimer.Next;
273 end;
274 if PTimer<>nil then begin //We're not the first one
275 Previous := PTimer;
276 NTimer := PTimer.Next;
277 if Assigned(NTimer) then begin
278 Next := NTimer;
279 NTimer.Previous := self;
280 end
281 else Next := Nil;
282 PTimer.Next := self;
283 end
284 else begin // we're in first place. previous first becomes Next
285 NTimer := CDWidgetSet.XTimerListHead;
286 CDWidgetSet.XTimerListHead := Self;
287 NTimer.Previous := Self;
288 Next:= NTimer;
289 Previous := nil;
290 end;
291 end;
292 {$ifdef TimerUseCThreads}
293 ExpireTime := Expires; // Copy Expire time to Buffer and send to TimerThread
294 FileWrite(X11TimerThread.X11TimerPipeOut,ABuffer,SizeOf(ExpireTime));
295 {$endif}
296 {$ifdef Verbose_CD_X11_Timer}
297 lTimer := CDWidgetSet.XTimerListHead;
298 while lTimer <> Nil do begin
299 DebugLn(Format('TCDX11Timer Insert results: Interval := %d',[lTimer.Interval]));
300 lTimer:= lTimer.Next;
301 end;
302 {$endif}
303 end;
304
305 procedure TCDX11Timer.remove;
306 begin
307 {$ifdef Verbose_CD_X11_Timer}
308 DebugLn(Format('TCDX11Timer Remove: Interval := %d',[Interval]));
309 {$endif}
310 if Previous <> Nil then begin
311 if Next <> Nil then begin
312 Previous.Next := Next;
313 Next.Previous := Previous;
314 end
315 else Previous.Next:= Nil;
316 end
317 else begin
318 CDWidgetSet.XTimerListHead := Next;
319 if Next <> nil then begin
320 Next.Previous:= Nil;
321 end;
322 end;
323 Previous:= Nil;
324 Next := Nil;
325 end;
326
327 procedure TCDX11Timer.Expired;
328 var
329 TNow: TDateTime;
330 {$ifdef Verbose_CD_X11_Timer}
331 lInterval,lTInterval: Integer;
332 TDiff: TDateTime;
333 {$endif}
334 begin
335 TNow:= Now;
336 Expires:= Expires+Interval/KMsToDateTime; // don't leak
337 while Expires <= TNow do begin // but if we're late, let's skip some! Bad kludge
338 Expires:= Expires+Interval/KMsToDateTime;
339 end;
340 {$ifdef Verbose_CD_X11_Timer}
341 TNow:= Now;
342 TDiff:= Expires - TNow;
343 lTInterval:=DateTimeToMilliseconds(Tdiff);
344 DebugLn(Format('X11_Timer Expired: Interval= %d, Calculated=%d',[Interval,lTInterval]));
345 {$endif}
346 Remove; // Remove from list Head
347 if func <> nil then
348 func(); // Execute OnTimer
349 Insert; // And insert again in right place
350 end;
351
352 destructor TCDX11Timer.destroy;
353 begin
354 {$ifdef Verbose_CD_X11_Timer}
355 DebugLn(Format('TCDX11Timer Destroy: Interval := %d',[Interval]));
356 {$endif}
357 remove;
358 //Free;
359 end;
360
361 {$endif}
362
363 end.
364
365