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

Contents of /trunk/lcoreselect.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 60 - (show annotations)
Thu Nov 12 20:47:41 2009 UTC (9 years, 10 months ago) by plugwash
File size: 10614 byte(s)
add support for fpc 2.2.4rc1

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