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

Contents of /trunk/lcoreselect.pas

Parent Directory Parent Directory | Revision Log Revision Log


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

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