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

Annotation of /trunk/wcore.pas

Parent Directory Parent Directory | Revision Log Revision Log


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

1 plugwash 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