/[lcore]/trunk/wcore.pas
ViewVC logotype

Contents of /trunk/wcore.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 136 - (show annotations)
Fri Mar 28 03:18:52 2014 UTC (3 years, 8 months ago) by beware
File size: 9538 byte(s)
fix spelling mistakes
1 unit wcore;
2
3 {
4 lcore compatible interface for windows
5
6 - messageloop
7
8 - tltimer
9
10 }
11 //note: events after release are normal and are the apps responsibility to deal with safely
12 interface
13
14 uses
15 classes,windows,mmsystem;
16
17 type
18 float=double;
19
20 tlcomponent = class(tcomponent)
21 public
22 released:boolean;
23 procedure release;
24 destructor destroy; override;
25 end;
26
27 tltimer=class(tlcomponent)
28 private
29 fenabled : boolean;
30 procedure setenabled(newvalue : boolean);
31 public
32 ontimer:tnotifyevent;
33 initialevent:boolean;
34 initialdone:boolean;
35 prevtimer:tltimer;
36 nexttimer:tltimer;
37 interval:integer; {milliseconds, default 1000}
38 nextts:integer;
39 property enabled:boolean read fenabled write setenabled;
40 constructor create(aowner:tcomponent);override;
41 destructor destroy;override;
42 end;
43
44 ttaskevent=procedure(wparam,lparam:longint) of object;
45
46 tltask=class(tobject)
47 public
48 handler : ttaskevent;
49 obj : tobject;
50 wparam : longint;
51 lparam : longint;
52 nexttask : tltask;
53 constructor create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);
54 end;
55
56 procedure messageloop;
57 procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);
58 procedure disconnecttasks(aobj:tobject);
59 procedure exitmessageloop;
60 procedure processmessages;
61 procedure wcoreinit;
62
63 var
64 onshutdown:procedure(s:ansistring);
65
66 implementation
67
68 uses
69 {$ifdef fpc}
70 bmessages;
71 {$else}
72 messages;
73 {$endif}
74
75
76 const
77 WINMSG_TASK=WM_USER;
78
79 var
80 hwndwcore:hwnd;
81 firsttimer:tltimer;
82 timesubtract:integer;
83 firsttask,lasttask,currenttask:tltask;
84
85 procedure tlcomponent.release;
86 begin
87 released := true;
88 end;
89
90 destructor tlcomponent.destroy;
91 begin
92 disconnecttasks(self);
93 inherited destroy;
94 end;
95
96 {------------------------------------------------------------------------------}
97
98 procedure tltimer.setenabled(newvalue : boolean);
99 begin
100 fenabled := newvalue;
101 nextts := 0;
102 initialdone := false;
103 end;
104
105 constructor tltimer.create;
106 begin
107 inherited create(AOwner);
108 nexttimer := firsttimer;
109 prevtimer := nil;
110
111 if assigned(nexttimer) then nexttimer.prevtimer := self;
112 firsttimer := self;
113
114 interval := 1000;
115 enabled := true;
116 released := false;
117 end;
118
119 destructor tltimer.destroy;
120 begin
121 if prevtimer <> nil then begin
122 prevtimer.nexttimer := nexttimer;
123 end else begin
124 firsttimer := nexttimer;
125 end;
126 if nexttimer <> nil then begin
127 nexttimer.prevtimer := prevtimer;
128 end;
129 inherited destroy;
130 end;
131
132 {------------------------------------------------------------------------------}
133
134 function wcore_timehandler:integer;
135 const
136 rollover_bits=30;
137 var
138 tv,tvnow:integer;
139 currenttimer,temptimer:tltimer;
140 begin
141 if not assigned(firsttimer) then begin
142 result := 1000;
143 exit;
144 end;
145
146 tvnow := timegettime;
147 if (tvnow and ((-1) shl rollover_bits)) <> timesubtract then begin
148 currenttimer := firsttimer;
149 while assigned(currenttimer) do begin
150 dec(currenttimer.nextts,(1 shl rollover_bits));
151 currenttimer := currenttimer.nexttimer;
152 end;
153 timesubtract := tvnow and ((-1) shl rollover_bits);
154 end;
155 tvnow := tvnow and ((1 shl rollover_bits)-1);
156
157 currenttimer := firsttimer;
158 while assigned(currenttimer) do begin
159 if tvnow >= currenttimer.nextts then begin
160 if assigned(currenttimer.ontimer) then begin
161 if currenttimer.enabled then begin
162 if currenttimer.initialevent or currenttimer.initialdone then currenttimer.ontimer(currenttimer);
163 currenttimer.initialdone := true;
164 end;
165 end;
166 currenttimer.nextts := tvnow+currenttimer.interval;
167 end;
168 temptimer := currenttimer;
169 currenttimer := currenttimer.nexttimer;
170 if temptimer.released then temptimer.free;
171 end;
172
173 tv := maxlongint;
174 currenttimer := firsttimer;
175 while assigned(currenttimer) do begin
176 if currenttimer.nextts < tv then tv := currenttimer.nextts;
177 currenttimer := currenttimer.nexttimer;
178 end;
179 result := tv-tvnow;
180 if result < 15 then result := 15;
181 end;
182
183 {------------------------------------------------------------------------------}
184
185 constructor tltask.create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);
186 begin
187 inherited create;
188 handler := ahandler;
189 obj := aobj;
190 wparam := awparam;
191 lparam := alparam;
192 {nexttask := firsttask;
193 firsttask := self;}
194 if assigned(lasttask) then begin
195 lasttask.nexttask := self;
196 end else begin
197 firsttask := self;
198 postmessage(hwndwcore,WINMSG_TASK,0,0);
199 end;
200 lasttask := self;
201 //ahandler(wparam,lparam);
202 end;
203
204 procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);
205 begin
206 tltask.create(ahandler,aobj,awparam,alparam);
207 end;
208
209 procedure disconnecttasks(aobj:tobject);
210 var
211 currenttasklocal : tltask ;
212 counter : byte ;
213 begin
214 for counter := 0 to 1 do begin
215 if counter = 0 then begin
216 currenttasklocal := firsttask; //main list of tasks
217 end else begin
218 currenttasklocal := currenttask; //needed in case called from a task
219 end;
220 // note i don't bother to destroy the links here as that will happen when
221 // the list of tasks is processed anyway
222 while assigned(currenttasklocal) do begin
223 if currenttasklocal.obj = aobj then begin
224 currenttasklocal.obj := nil;
225 currenttasklocal.handler := nil;
226 end;
227 currenttasklocal := currenttasklocal.nexttask;
228 end;
229 end;
230 end;
231
232 procedure dotasks;
233 var
234 temptask:tltask;
235 begin
236 if firsttask = nil then exit;
237
238 currenttask := firsttask;
239 firsttask := nil;
240 lasttask := nil;
241 while assigned(currenttask) do begin
242 if assigned(currenttask.handler) then currenttask.handler(currenttask.wparam,currenttask.lparam);
243 temptask := currenttask;
244 currenttask := currenttask.nexttask;
245 temptask.free;
246 end;
247 currenttask := nil;
248 end;
249
250 {------------------------------------------------------------------------------}
251
252 procedure exitmessageloop;
253 begin
254 postmessage(hwndwcore,WM_QUIT,0,0);
255 end;
256
257 {$ifdef threadtimer}
258 'thread timer'
259 {$else}
260 const timerid_wcore=$1000;
261 {$endif}
262
263 function MyWindowProc(
264 ahWnd : HWND;
265 auMsg : Integer;
266 awParam : WPARAM;
267 alParam : LPARAM): Integer; stdcall;
268 var
269 MsgRec : TMessage;
270 a:integer;
271 begin
272 Result := 0; // This means we handled the message
273
274 {MsgRec.hwnd := ahWnd;}
275 MsgRec.wParam := awParam;
276 MsgRec.lParam := alParam;
277
278 dotasks;
279 case auMsg of
280 {$ifndef threadtimer}
281 WM_TIMER: begin
282 if msgrec.wparam = timerid_wcore then begin
283 a := wcore_timehandler;
284 killtimer(hwndwcore,timerid_wcore);
285 settimer(hwndwcore,timerid_wcore,a,nil);
286 end;
287 end;
288 {$endif}
289
290 {WINMSG_TASK:dotasks;}
291
292 WM_CLOSE: begin
293 {}
294 end;
295 WM_DESTROY: begin
296 {}
297 end;
298 else
299 Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)
300 end;
301 end;
302
303
304 var
305 MyWindowClass : TWndClass = (style : 0;
306 lpfnWndProc : @MyWindowProc;
307 cbClsExtra : 0;
308 cbWndExtra : 0;
309 hInstance : 0;
310 hIcon : 0;
311 hCursor : 0;
312 hbrBackground : 0;
313 lpszMenuName : nil;
314 lpszClassName : 'wcoreClass');
315
316 procedure wcoreinit;
317 begin
318 if Windows.RegisterClass(MyWindowClass) = 0 then halt;
319 //writeln('about to create wcore handle, hinstance=',hinstance);
320 hwndwcore := CreateWindowEx(WS_EX_TOOLWINDOW,
321 MyWindowClass.lpszClassName,
322 '', { Window name }
323 WS_POPUP, { Window Style }
324 0, 0, { X, Y }
325 0, 0, { Width, Height }
326 0, { hWndParent }
327 0, { hMenu }
328 HInstance, { hInstance }
329 nil); { CreateParam }
330
331 if hwndwcore = 0 then halt;
332
333 {$ifdef threadtimer}
334 'thread timer'
335 {$else}
336 if settimer(hwndwcore,timerid_wcore,15,nil) = 0 then halt;
337 {$endif}
338
339
340 end;
341
342 procedure messageloop;
343 var
344 MsgRec : TMsg;
345
346 begin
347
348 while GetMessage(MsgRec, 0, 0, 0) do begin
349 TranslateMessage(MsgRec);
350 DispatchMessage(MsgRec);
351 {if not peekmessage(msgrec,0,0,0,PM_NOREMOVE) then onidle}
352 end;
353
354 if hWndwcore <> 0 then begin
355 DestroyWindow(hwndwcore);
356 hWndwcore := 0;
357 end;
358
359 {$ifdef threadtimer}
360 'thread timer'
361 {$else}
362 killtimer(hwndwcore,timerid_wcore);
363 {$endif}
364 end;
365
366 function ProcessMessage : Boolean;
367 var
368 MsgRec : TMsg;
369 begin
370 Result := FALSE;
371 if PeekMessage(MsgRec, 0, 0, 0, PM_REMOVE) then begin
372 Result := TRUE;
373 TranslateMessage(MsgRec);
374 DispatchMessage(MsgRec);
375 end;
376 end;
377
378 procedure processmessages;
379 begin
380 while processmessage do;
381 end;
382
383
384 end.
385

Properties

Name Value
svn:eol-style CRLF

No admin address has been configured">No admin address has been configured
ViewVC Help
Powered by ViewVC 1.1.5