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

Contents of /trunk/lcoreselect.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 10 - (show annotations)
Sun Mar 30 21:39:57 2008 UTC (11 years, 5 months ago) by plugwash
File size: 11875 byte(s)
* make disabling/enabling a timer on windows reset it like on linux
* fix some line ending issues

1 {lsocket.pas}
2
3 {io and timer code by plugwash}
4
5 { Copyright (C) 2005 Bas Steendijk and Peter Green
6 For conditions of distribution and use, see copyright notice in zlib_license.txt
7 which is included in the package
8 ----------------------------------------------------------------------------- }
9
10 {$ifdef fpc}
11 {$ifndef ver1_0}
12 {$define useinline}
13 {$endif}
14 {$endif}
15
16 unit lcoreselect;
17
18
19 interface
20 uses
21 {$ifdef VER1_0}
22 linux,
23 {$else}
24 baseunix,unix,unixutil,
25 {$endif}
26 fd_utils;
27 var
28 maxs : longint ;
29 exitloopflag : boolean ; {if set by app, exit mainloop}
30
31 function getfdsrmaster : fdset; {$ifdef useinline}inline;{$endif}
32 function getfdswmaster : fdset; {$ifdef useinline}inline;{$endif}
33
34 implementation
35 uses
36 lcore,sysutils,
37 classes,pgtypes,bfifo,
38 {$ifndef nosignal}
39 lsignal;
40 {$endif}
41
42 {$include unixstuff.inc}
43 {$include ltimevalstuff.inc}
44
45 const
46 absoloutemaxs_select = (sizeof(fdset)*8)-1;
47
48 var
49 fdreverse:array[0..absoloutemaxs_select] of tlasio;
50 type
51 tselecteventcore=class(teventcore)
52 public
53 procedure processmessages; override;
54 procedure messageloop; override;
55 procedure exitmessageloop;override;
56 procedure setfdreverse(fd : integer;reverseto : tlasio); override;
57 procedure rmasterset(fd : integer;islistensocket : boolean); override;
58 procedure rmasterclr(fd: integer); override;
59 procedure wmasterset(fd : integer); override;
60 procedure wmasterclr(fd: integer); override;
61 end;
62
63 procedure processtimers;inline;
64 var
65 tv ,tvnow : ttimeval ;
66 currenttimer : tltimer ;
67 temptimer : tltimer ;
68
69 begin
70 gettimeofday(tvnow);
71 currenttimer := firsttimer;
72 while assigned(currenttimer) do begin
73 //writeln(currenttimer.enabled);
74 if tv_compare(tvnow,ttimeval(currenttimer.nextts)) and currenttimer.enabled then begin
75 //if assigned(currenttimer.ontimer) then begin
76 // if currenttimer.enabled then if currenttimer.initialevent or currenttimer.initialdone then currenttimer.ontimer(currenttimer);
77 // currenttimer.initialdone := true;
78 //end;
79 if assigned(currenttimer.ontimer) then currenttimer.ontimer(currenttimer);
80 currenttimer.nextts := timeval(tvnow);
81 tv_add(ttimeval(currenttimer.nextts),currenttimer.interval);
82 end;
83 temptimer := currenttimer;
84 currenttimer := currenttimer.nexttimer;
85 if temptimer.released then temptimer.free;
86 end;
87 end;
88
89 procedure processasios(var fdsr,fdsw:fdset);//inline;
90 var
91 currentsocket : tlasio ;
92 tempsocket : tlasio ;
93 socketcount : integer ; // for debugging perposes :)
94 dw,bt:integer;
95 begin
96 { inc(lcoretestcount);}
97
98 //the message loop will exit if all lasio's and ltimer's and lsignal's are destroyed
99 //if (not assigned(firstasin)) and (not assigned(firsttimer)) and (not assigned(firstsignal)) then exit;
100
101
102 {------- test optimised loop}
103 socketcount := 0;
104 for dw := (maxs shr 5) downto 0 do if (fdsr[dw] or fdsw[dw]) <> 0 then begin
105 for bt := 0 to 31 do if (fdsr[dw] or fdsw[dw]) and (1 shl bt) <> 0 then begin
106 inc(socketcount);
107 currentsocket := fdreverse[dw shl 5 or bt];
108 {if not assigned(currentsocket) then raise exception.create('currentsocket not assigned');
109 if currentsocket.fdhandlein < 0 then raise exception.create('currentsocket.fdhandlein out of range');}
110 {i've seen the out of range case actually happening, so it can happen. test: just close the fd - beware}
111 if not assigned(currentsocket) then begin
112 fdclose(dw shl 5 or bt);
113 continue
114 end;
115 if currentsocket.fdhandlein < 0 then begin
116 fdclose(dw shl 5 or bt);
117 continue
118 end;
119 try
120 currentsocket.handlefdtrigger(fd_isset(currentsocket.fdhandlein,fdsr),fd_isset(currentsocket.fdhandleout,fdsw));
121 except
122 on E: exception do begin
123 currentsocket.HandleBackGroundException(e);
124 end;
125 end;
126
127 if mustrefreshfds then begin
128 if select(maxs+1,@fdsr,@fdsw,nil,0) <= 0 then begin
129 fd_zero(fdsr);
130 fd_zero(fdsw);
131 end;
132 end;
133 end;
134 end;
135
136 if asinreleaseflag then begin
137 asinreleaseflag := false;
138 currentsocket := firstasin;
139 while assigned(currentsocket) do begin
140 tempsocket := currentsocket;
141 currentsocket := currentsocket.nextasin;
142 if tempsocket.released then begin
143 tempsocket.free;
144 end;
145 end;
146 end;
147 {
148 !!! issues:
149 - sockets which are released may not be freed because theyre never processed by the loop
150 made new code for handling this, using asinreleaseflag
151
152 - when/why does the mustrefreshfds select apply, sheck if i did it correctly?
153
154 - what happens if calling handlefdtrigger for a socket which does not have an event
155 }
156 {------- original loop}
157
158 (*
159 currentsocket := firstasin;
160 socketcount := 0;
161 while assigned(currentsocket) do begin
162 if mustrefreshfds then begin
163 if select(maxs,@fdsr,@fdsw,nil,0) <= 0 then begin
164 fd_zero(fdsr);
165 fd_zero(fdsw);
166 end;
167 end;
168 try
169 if fd_isset(currentsocket.fdhandlein,fdsr) or fd_isset(currentsocket.fdhandleout,fdsw) then begin
170 currentsocket.handlefdtrigger(fd_isset(currentsocket.fdhandlein,fdsr),fd_isset(currentsocket.fdhandleout,fdsw));
171 end;
172 except
173 on E: exception do begin
174 currentsocket.HandleBackGroundException(e);
175 end;
176 end;
177 tempsocket := currentsocket;
178 currentsocket := currentsocket.nextasin;
179 inc(socketcount);
180 if tempsocket.released then begin
181 tempsocket.free;
182 end;
183 end; *)
184 { debugout('socketcount='+inttostr(socketcount));}
185 end;
186
187 procedure tselecteventcore.processmessages;
188 var
189 fdsr , fdsw : fdset ;
190 selectresult : longint ;
191 begin
192 mustrefreshfds := false;
193 {$ifndef nosignal}
194 prepsigpipe;
195 {$endif}
196 selectresult := select(maxs+1,@fdsr,@fdsw,nil,0);
197 while (selectresult>0) or assigned(firsttask) or assigned(currenttask) do begin;
198
199 processtasks;
200 processtimers;
201 if selectresult > 0 then begin
202 processasios(fdsr,fdsw);
203 end;
204 selectresult := select(maxs+1,@fdsr,@fdsw,nil,0);
205
206 end;
207 mustrefreshfds := true;
208 end;
209
210
211 var
212 FDSR , FDSW : fdset;
213
214 var
215 fdsrmaster , fdswmaster : fdset ;
216
217 function getfdsrmaster : fdset; {$ifdef fpc}inline;{$endif}
218 begin
219 result := fdsrmaster;
220 end;
221 function getfdswmaster : fdset; {$ifdef fpc}inline;{$endif}
222 begin
223 result := fdswmaster;
224 end;
225
226
227 Function doSelect(timeOut:PTimeVal):longint;//inline;
228 var
229 localtimeval : ttimeval;
230 maxslocal : integer;
231 begin
232 //unblock signals
233 //zeromemory(@sset,sizeof(sset));
234 //sset[0] := ;
235 fdsr := getfdsrmaster;
236 fdsw := getfdswmaster;
237
238 if assigned(firsttask) then begin
239 localtimeval.tv_sec := 0;
240 localtimeval.tv_usec := 0;
241 timeout := @localtimeval;
242 end;
243
244 maxslocal := maxs;
245 mustrefreshfds := false;
246 { debugout('about to call select');}
247 {$ifndef nosignal}
248 sigprocmask(SIG_UNBLOCK,@blockset,nil);
249 {$endif}
250 result := select(maxslocal+1,@FDSR,@FDSW,nil,timeout);
251 if result <= 0 then begin
252 fd_zero(FDSR);
253 fd_zero(FDSW);
254 if result=-1 then begin
255 if linuxerror = SYS_EINTR then begin
256 // we received a signal it's not a problem
257 end else begin
258 raise esocketexception.create('select returned error '+inttostr(linuxerror));
259 end;
260 end;
261 end;
262 {$ifndef nosignal}
263 sigprocmask(SIG_BLOCK,@blockset,nil);
264 {$endif}
265 { debugout('select complete');}
266 end;
267
268 procedure tselecteventcore.exitmessageloop;
269 begin
270 exitloopflag := true
271 end;
272
273
274
275 procedure tselecteventcore.messageloop;
276 var
277 tv ,tvnow : ttimeval ;
278 currenttimer : tltimer ;
279 selectresult:integer;
280 begin
281 {$ifndef nosignal}
282 prepsigpipe;
283 {$endif}
284 {currentsocket := firstasin;
285 if not assigned(currentsocket) then exit; //the message loop will exit if all lsockets are destroyed
286 repeat
287
288 if currentsocket.state = wsconnected then currentsocket.sendflush;
289 currentsocket := currentsocket.nextasin;
290 until not assigned(currentsocket);}
291
292
293 repeat
294
295 //the message loop will exit if all lasio's and ltimer's and lsignal's are destroyed
296 if (not assigned(firstasin)) and (not assigned(firsttimer)) {$ifndef nosignal} and (not assigned(firstsignal)){$endif} then exit;
297 {fd_zero(FDSR);
298 fd_zero(FDSW);
299 currentsocket := firstasin;
300 if not assigned(currentsocket) then exit; //the message loop will exit if all lsockets are destroyed
301
302 repeat
303 if (not currentsocket.released) and (currentsocket.state<>wsclosed) then fd_set(currentsocket.fdhandlein,fdsr);
304 if (not currentsocket.released) and (currentsocket.state=wsconnecting) then fd_set(currentsocket.fdhandleout,fdsw);
305 if currentsocket is tlsocket then begin
306 if (not currentsocket.released) and (currentsocket.state=wsconnected) and(tlsocket(currentsocket).sendq <> '') then fd_set(currentsocket.fdhandleout,fdsw);
307 end;
308 tempsocket := currentsocket;
309 currentsocket := currentsocket.nextasin;
310 if tempsocket.released then begin
311 tempsocket.free;
312 end;
313 until not assigned(currentsocket);
314 }
315 processtasks;
316 //currenttask := nil;
317 {beware}
318 //if assigned(firsttimer) then begin
319 // tv.tv_sec := maxlongint;
320 tv := tv_invalidtimebig;
321 currenttimer := firsttimer;
322 while assigned(currenttimer) do begin
323 if tv_compare(tv,currenttimer.nextts) and currenttimer.enabled then tv := currenttimer.nextts;
324 currenttimer := currenttimer.nexttimer;
325 end;
326
327
328 if tv_compare(tv,tv_invalidtimebig) then begin
329 //writeln('no timers active');
330 if exitloopflag then break;
331 { sleep(10);}
332 selectresult := doselect(nil);
333
334 end else begin
335 gettimeofday(tvnow);
336 tv_substract(tv,tvnow);
337
338 //writeln('timers active');
339 if tv.tv_sec < 0 then begin
340 tv.tv_sec := 0;
341 tv.tv_usec := 0; {0.1 sec}
342 end;
343 if exitloopflag then break;
344 { sleep(10);}
345 selectresult := doselect(@tv);
346 processtimers;
347
348 end;
349 if selectresult > 0 then processasios(fdsr,fdsw);
350 {!!!only call processasios if select has asio events -beware}
351
352 {artificial delay to throttle the number of processasios per second possible and reduce cpu usage}
353 until false;
354 end;
355
356
357 procedure tselecteventcore.rmasterset(fd : integer;islistensocket : boolean);
358 begin
359 if fd > absoloutemaxs then raise esocketexception.create('file discriptor out of range');
360 if fd > maxs then maxs := fd;
361 if fd_isset(fd,fdsrmaster) then exit;
362 fd_set(fd,fdsrmaster);
363
364 end;
365
366 procedure tselecteventcore.rmasterclr(fd: integer);
367 begin
368 if not fd_isset(fd,fdsrmaster) then exit;
369 fd_clr(fd,fdsrmaster);
370
371 end;
372
373
374 procedure tselecteventcore.wmasterset(fd : integer);
375 begin
376 if fd > absoloutemaxs then raise esocketexception.create('file discriptor out of range');
377 if fd > maxs then maxs := fd;
378
379 if fd_isset(fd,fdswmaster) then exit;
380 fd_set(fd,fdswmaster);
381
382 end;
383
384 procedure tselecteventcore.wmasterclr(fd: integer);
385 begin
386 if not fd_isset(fd,fdswmaster) then exit;
387 fd_clr(fd,fdswmaster);
388 end;
389
390 procedure tselecteventcore.setfdreverse(fd : integer;reverseto : tlasio);
391 begin
392 fdreverse[fd] := reverseto;
393 end;
394
395
396
397 begin
398 eventcore := tselecteventcore.create;
399
400 absoloutemaxs := absoloutemaxs_select;
401
402 maxs := 0;
403 fd_zero(fdsrmaster);
404 fd_zero(fdswmaster);
405 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.22