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

Contents of /trunk/wcore.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1 - (show annotations)
Fri Mar 28 02:26:58 2008 UTC (13 years, 4 months ago) by plugwash
File size: 9435 byte(s)
initial import

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

Properties

Name Value
svn:executable

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