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

Annotation of /trunk/wcore.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 136 - (hide annotations)
Fri Mar 28 03:18:52 2014 UTC (4 years ago) by beware
File size: 9538 byte(s)
fix spelling mistakes
1 plugwash 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 plugwash 10 private
29     fenabled : boolean;
30     procedure setenabled(newvalue : boolean);
31 plugwash 1 public
32     ontimer:tnotifyevent;
33     initialevent:boolean;
34     initialdone:boolean;
35     prevtimer:tltimer;
36     nexttimer:tltimer;
37 beware 136 interval:integer; {milliseconds, default 1000}
38 plugwash 1 nextts:integer;
39 plugwash 10 property enabled:boolean read fenabled write setenabled;
40 plugwash 1 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 beware 92 procedure wcoreinit;
62 plugwash 1
63     var
64 zipplet 79 onshutdown:procedure(s:ansistring);
65 plugwash 1
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 beware 136 timesubtract:integer;
83 plugwash 1 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 plugwash 10 procedure tltimer.setenabled(newvalue : boolean);
99     begin
100     fenabled := newvalue;
101     nextts := 0;
102     initialdone := false;
103     end;
104    
105 plugwash 1 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 beware 136 if (tvnow and ((-1) shl rollover_bits)) <> timesubtract then begin
148 plugwash 1 currenttimer := firsttimer;
149     while assigned(currenttimer) do begin
150     dec(currenttimer.nextts,(1 shl rollover_bits));
151     currenttimer := currenttimer.nexttimer;
152     end;
153 beware 136 timesubtract := tvnow and ((-1) shl rollover_bits);
154 plugwash 1 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 beware 136 // note i don't bother to destroy the links here as that will happen when
221 plugwash 1 // 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 beware 90 dotasks;
279     case auMsg of
280 plugwash 1 {$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 beware 90 {}
294 plugwash 1 end;
295     WM_DESTROY: begin
296 beware 90 {}
297 plugwash 1 end;
298 beware 90 else
299     Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)
300 plugwash 1 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 beware 92 procedure wcoreinit;
317 plugwash 1 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 beware 92 end;
341    
342     procedure messageloop;
343     var
344     MsgRec : TMsg;
345    
346     begin
347    
348 plugwash 1 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 beware 91 MsgRec : TMsg;
369 plugwash 1 begin
370     Result := FALSE;
371 beware 91 if PeekMessage(MsgRec, 0, 0, 0, PM_REMOVE) then begin
372 plugwash 1 Result := TRUE;
373 beware 90 TranslateMessage(MsgRec);
374 beware 91 DispatchMessage(MsgRec);
375 plugwash 1 end;
376     end;
377    
378     procedure processmessages;
379     begin
380     while processmessage do;
381     end;
382    
383    
384     end.
385 beware 90

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.22