lcore/trunk/lcoreselect.pas

{lsocket.pas}

{io and timer code by plugwash}

{ Copyright (C) 2005 Bas Steendijk and Peter Green
  For conditions of distribution and use, see copyright notice in zlib_license.txt
  which is included in the package
  ----------------------------------------------------------------------------- }

{$ifdef fpc}
  {$ifndef ver1_0}
    {$define useinline}
  {$endif}
{$endif}

unit lcoreselect;


interface
uses
  {$ifdef VER1_0}
    linux,
  {$else}
    baseunix,unix,unixutil,sockets,
  {$endif}
  fd_utils;
var
  maxs                                  : longint    ;
  exitloopflag                          : boolean    ; {if set by app, exit mainloop}

function getfdsrmaster : fdset; {$ifdef useinline}inline;{$endif}
function getfdswmaster : fdset; {$ifdef useinline}inline;{$endif}

procedure lcoreinit;

implementation
uses
  lcore,sysutils,
  classes,pgtypes,bfifo,
  {$ifndef nosignal}
    lsignal,
  {$endif}
  ltimevalstuff;

{$include unixstuff.inc}

const
  absolutemaxs_select = (sizeof(fdset)*8)-1;

var
  fdreverse:array[0..absolutemaxs_select] of tlasio;
type
  tselecteventcore=class(teventcore)
    public
      procedure processmessages; override;
      procedure messageloop; override;
      procedure exitmessageloop;override;
      procedure setfdreverse(fd : integer;reverseto : tlasio); override;
      procedure rmasterset(fd : integer;islistensocket : boolean); override;
      procedure rmasterclr(fd: integer); override;
      procedure wmasterset(fd : integer); override;
      procedure wmasterclr(fd: integer); override;
    end;

procedure processtimers;inline;
var
  tvnow     : ttimeval ;
  currenttimer            : tltimer   ;
  temptimer               : tltimer  ;

begin
  gettimeofday(tvnow);
  currenttimer := firsttimer;
  while assigned(currenttimer) do begin
    //writeln(currenttimer.enabled);
    if tv_compare(tvnow,ttimeval(currenttimer.nextts)) and currenttimer.enabled then begin
      //if assigned(currenttimer.ontimer) then begin
      //  if currenttimer.enabled then if currenttimer.initialevent or currenttimer.initialdone then currenttimer.ontimer(currenttimer);
      //  currenttimer.initialdone := true;
      //end;
      if assigned(currenttimer.ontimer) then currenttimer.ontimer(currenttimer);
      currenttimer.nextts := timeval(tvnow);
      tv_add(ttimeval(currenttimer.nextts),currenttimer.interval);
    end;
    temptimer := currenttimer;
    currenttimer := currenttimer.nexttimer;
  end;
end;

procedure processasios(var fdsr,fdsw:fdset);//inline;
var
  currentsocket : tlasio  ;
  socketcount   : integer ; // for debugging purposes :)
  dw,bt:integer;
  currentfdword:fdword;
  fd : integer;
begin
  //writeln('entering processasios');
{  inc(lcoretestcount);}

    //the message loop will exit if all lasios and ltimers and lsignals are destroyed
    //if (not assigned(firstasin)) and (not assigned(firsttimer)) and (not assigned(firstsignal)) then exit;


  {------- test optimised loop}
  socketcount := 0;
  for dw := (maxs shr fdwordshift) downto 0 do if (fdsr[dw] or fdsw[dw]) <> 0 then begin
    currentfdword := (fdsr[dw] or fdsw[dw]);
    for bt := fdwordmaxbit downto 0 do if currentfdword and (1 shl bt) <> 0 then begin
      inc(socketcount);
      fd := dw shl fdwordshift or bt;
      //writeln('reversing fd ',fd);
      currentsocket := fdreverse[fd];
      {if not assigned(currentsocket) then raise exception.create('currentsocket not assigned');
      if currentsocket.fdhandlein < 0 then raise exception.create('currentsocket.fdhandlein out of range');}
      {i've seen the out of range case actually happening, so it can happen. test: just close the fd - beware}
      if not assigned(currentsocket) then begin
        fdclose(fd);
        continue
      end;
      if currentsocket.fdhandlein < 0 then begin
        fdclose(fd);
        continue
      end;
      try
        currentsocket.handlefdtrigger(fd_isset(fd,fdsr),fd_isset(fd,fdsw));
      except
        on E: exception do begin
          currentsocket.HandleBackGroundException(e);
        end;
      end;

      if mustrefreshfds then begin
        if select(maxs+1,@fdsr,@fdsw,nil,0) <= 0 then begin
          fd_zero(fdsr);
          fd_zero(fdsw);
        end;
      end;
    end;
  end;

  {
  !!! issues:
  - sockets which are released may not be freed because theyre never processed by the loop
  made new code for handling this, using asinreleaseflag

  - when/why does the mustrefreshfds select apply, check if i did it correctly?

  - what happens if calling handlefdtrigger for a socket which does not have an event
  }
  {------- original loop}

  (*
  currentsocket := firstasin;
  socketcount := 0;
  while assigned(currentsocket) do begin
    if mustrefreshfds then begin
      if select(maxs,@fdsr,@fdsw,nil,0) <= 0 then begin
        fd_zero(fdsr);
        fd_zero(fdsw);
      end;
    end;
    try
      if fd_isset(currentsocket.fdhandlein,fdsr) or fd_isset(currentsocket.fdhandleout,fdsw) then begin
        currentsocket.handlefdtrigger(fd_isset(currentsocket.fdhandlein,fdsr),fd_isset(currentsocket.fdhandleout,fdsw));
      end;
    except
      on E: exception do begin
        currentsocket.HandleBackGroundException(e);
      end;
    end;
    tempsocket := currentsocket;
    currentsocket := currentsocket.nextasin;
    inc(socketcount);
    if tempsocket.released then begin
      tempsocket.free;
    end;
  end; *)
{  debugout('socketcount='+inttostr(socketcount));}
  //writeln('leaving processasios');
end;

procedure tselecteventcore.processmessages;
var
  fdsr         , fdsw : fdset   ;
  selectresult        : longint ;
begin
  mustrefreshfds := false;
  {$ifndef nosignal}
    prepsigpipe;
  {$endif}
  selectresult := select(maxs+1,@fdsr,@fdsw,nil,0);
  while (selectresult>0) or assigned(firsttask) or assigned(currenttask) do begin;

    processtasks;
    processtimers;
    if selectresult > 0 then begin
      processasios(fdsr,fdsw);
    end;
    selectresult := select(maxs+1,@fdsr,@fdsw,nil,0);

  end;
  mustrefreshfds := true;
end;


var
  FDSR , FDSW : fdset;

var
  fdsrmaster , fdswmaster               : fdset      ;

function getfdsrmaster : fdset; {$ifdef fpc}inline;{$endif}
begin
  result := fdsrmaster;
end;
function getfdswmaster : fdset; {$ifdef fpc}inline;{$endif}
begin
  result := fdswmaster;
end;


Function  doSelect(timeOut:PTimeVal):longint;//inline;
var
  localtimeval : ttimeval;
  maxslocal    : integer;
begin
  //unblock signals
  //zeromemory(@sset,sizeof(sset));
  //sset[0] := ;
  fdsr := getfdsrmaster;
  fdsw := getfdswmaster;

  if assigned(firsttask) then begin
    localtimeval.tv_sec  := 0;
    localtimeval.tv_usec := 0;
    timeout := @localtimeval;
  end;

  maxslocal := maxs;
  mustrefreshfds := false;
{  debugout('about to call select');}
  {$ifndef nosignal}
    sigprocmask(SIG_UNBLOCK,@blockset,nil);
  {$endif}
  result := select(maxslocal+1,@FDSR,@FDSW,nil,timeout);
  if result <= 0 then begin
    fd_zero(FDSR);
    fd_zero(FDSW);
    if result=-1 then begin
      if linuxerror = SYS_EINTR then begin
        // we received a signal it's not a problem
      end else begin
        raise esocketexception.create('select returned error '+inttostr(linuxerror));
      end;
    end;
  end;
  {$ifndef nosignal}
    sigprocmask(SIG_BLOCK,@blockset,nil);
  {$endif}
{  debugout('select complete');}
end;

procedure tselecteventcore.exitmessageloop;
begin
  exitloopflag := true
end;


procedure tselecteventcore.messageloop;
var
  tv           ,tvnow     : ttimeval ;
  currenttimer            : tltimer  ;
  selectresult:integer;
begin
  {$ifndef nosignal}
    prepsigpipe;
  {$endif}
  {currentsocket := firstasin;
  if not assigned(currentsocket) then exit; //the message loop will exit if all lsockets are destroyed
  repeat

    if currentsocket.state = wsconnected then currentsocket.sendflush;
    currentsocket := currentsocket.nextasin;
  until not assigned(currentsocket);}


  repeat

    //the message loop will exit if all lasios and ltimers and lsignals are destroyed
    processtasks;
    //currenttask := nil;
    {beware}
    //if assigned(firsttimer) then begin
    //  tv.tv_sec := maxlongint;
    tv := tv_invalidtimebig;
    currenttimer := firsttimer;
    while assigned(currenttimer) do begin
      if tv_compare(tv,currenttimer.nextts) and currenttimer.enabled then tv := currenttimer.nextts;
      currenttimer := currenttimer.nexttimer;
    end;


    if tv_compare(tv,tv_invalidtimebig) then begin    
      //writeln('no timers active');
      if exitloopflag then break;
{    sleep(10);}
      selectresult := doselect(nil);

    end else begin
      gettimeofday(tvnow);
      tv_subtract(tv,tvnow);

      //writeln('timers active');
      if tv.tv_sec < 0 then begin
        tv.tv_sec := 0;
        tv.tv_usec := 0; {0.1 sec}
      end;
      if exitloopflag then break;
{    sleep(10);}
      selectresult := doselect(@tv);
      processtimers;

    end;
    if selectresult > 0 then processasios(fdsr,fdsw);
    {!!!only call processasios if select has asio events -beware}

    {artificial delay to throttle the number of processasios per second possible and reduce cpu usage}
  until false;
end;


procedure tselecteventcore.rmasterset(fd : integer;islistensocket : boolean);
begin
  //writeln('rmasterset called with fd ',fd);
  if fd > absolutemaxs then raise esocketexception.create('file descriptor out of range');
  if fd > maxs then maxs := fd;
  if fd_isset(fd,fdsrmaster) then exit;
  fd_set(fd,fdsrmaster);

end;

procedure tselecteventcore.rmasterclr(fd: integer);
begin
  //writeln('rmasterclr called with fd ',fd);
  if not fd_isset(fd,fdsrmaster) then exit;
  fd_clr(fd,fdsrmaster);

end;


procedure tselecteventcore.wmasterset(fd : integer);
begin
  //writeln('wmasterset called with fd ',fd);
  if fd > absolutemaxs then raise esocketexception.create('file descriptor out of range');
  if fd > maxs then maxs := fd;

  if fd_isset(fd,fdswmaster) then exit;
  fd_set(fd,fdswmaster);

end;

procedure tselecteventcore.wmasterclr(fd: integer);
begin
  //writeln('wmasterclr called with fd ',fd);
  if not fd_isset(fd,fdswmaster) then exit;
  fd_clr(fd,fdswmaster);
end;

procedure tselecteventcore.setfdreverse(fd : integer;reverseto : tlasio);
begin
  fdreverse[fd] := reverseto;
end;

var
  inited:boolean;

procedure lcoreinit;
begin
  if inited then exit;
  inited := true;
  eventcore := tselecteventcore.create;

  absolutemaxs := absolutemaxs_select;

  maxs := 0;
  fd_zero(fdsrmaster);
  fd_zero(fdswmaster);
end;

end.
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	absolutemaxs_select = (sizeof(fdset)*8)-1;
49
50	var
51	fdreverse:array[0..absolutemaxs_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	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	socketcount : integer ; // for debugging purposes :)
94	dw,bt:integer;
95	currentfdword:fdword;
96	fd : integer;
97	begin
98	//writeln('entering processasios');
99	{ inc(lcoretestcount);}
100
101	//the message loop will exit if all lasios and ltimers and lsignals are destroyed
102	//if (not assigned(firstasin)) and (not assigned(firsttimer)) and (not assigned(firstsignal)) then exit;
103
104
105	{------- test optimised loop}
106	socketcount := 0;
107	for dw := (maxs shr fdwordshift) downto 0 do if (fdsr[dw] or fdsw[dw]) <> 0 then begin
108	currentfdword := (fdsr[dw] or fdsw[dw]);
109	for bt := fdwordmaxbit downto 0 do if currentfdword and (1 shl bt) <> 0 then begin
110	inc(socketcount);
111	fd := dw shl fdwordshift or bt;
112	//writeln('reversing fd ',fd);
113	currentsocket := fdreverse[fd];
114	{if not assigned(currentsocket) then raise exception.create('currentsocket not assigned');
115	if currentsocket.fdhandlein < 0 then raise exception.create('currentsocket.fdhandlein out of range');}
116	{i've seen the out of range case actually happening, so it can happen. test: just close the fd - beware}
117	if not assigned(currentsocket) then begin
118	fdclose(fd);
119	continue
120	end;
121	if currentsocket.fdhandlein < 0 then begin
122	fdclose(fd);
123	continue
124	end;
125	try
126	currentsocket.handlefdtrigger(fd_isset(fd,fdsr),fd_isset(fd,fdsw));
127	except
128	on E: exception do begin
129	currentsocket.HandleBackGroundException(e);
130	end;
131	end;
132
133	if mustrefreshfds then begin
134	if select(maxs+1,@fdsr,@fdsw,nil,0) <= 0 then begin
135	fd_zero(fdsr);
136	fd_zero(fdsw);
137	end;
138	end;
139	end;
140	end;
141
142	{
143	!!! issues:
144	- sockets which are released may not be freed because theyre never processed by the loop
145	made new code for handling this, using asinreleaseflag
146
147	- when/why does the mustrefreshfds select apply, check if i did it correctly?
148
149	- what happens if calling handlefdtrigger for a socket which does not have an event
150	}
151	{------- original loop}
152
153	(*
154	currentsocket := firstasin;
155	socketcount := 0;
156	while assigned(currentsocket) do begin
157	if mustrefreshfds then begin
158	if select(maxs,@fdsr,@fdsw,nil,0) <= 0 then begin
159	fd_zero(fdsr);
160	fd_zero(fdsw);
161	end;
162	end;
163	try
164	if fd_isset(currentsocket.fdhandlein,fdsr) or fd_isset(currentsocket.fdhandleout,fdsw) then begin
165	currentsocket.handlefdtrigger(fd_isset(currentsocket.fdhandlein,fdsr),fd_isset(currentsocket.fdhandleout,fdsw));
166	end;
167	except
168	on E: exception do begin
169	currentsocket.HandleBackGroundException(e);
170	end;
171	end;
172	tempsocket := currentsocket;
173	currentsocket := currentsocket.nextasin;
174	inc(socketcount);
175	if tempsocket.released then begin
176	tempsocket.free;
177	end;
178	end; *)
179	{ debugout('socketcount='+inttostr(socketcount));}
180	//writeln('leaving processasios');
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 lasios and ltimers and lsignals are destroyed
292	processtasks;
293	//currenttask := nil;
294	{beware}
295	//if assigned(firsttimer) then begin
296	// tv.tv_sec := maxlongint;
297	tv := tv_invalidtimebig;
298	currenttimer := firsttimer;
299	while assigned(currenttimer) do begin
300	if tv_compare(tv,currenttimer.nextts) and currenttimer.enabled then tv := currenttimer.nextts;
301	currenttimer := currenttimer.nexttimer;
302	end;
303
304
305	if tv_compare(tv,tv_invalidtimebig) then begin
306	//writeln('no timers active');
307	if exitloopflag then break;
308	{ sleep(10);}
309	selectresult := doselect(nil);
310
311	end else begin
312	gettimeofday(tvnow);
313	tv_subtract(tv,tvnow);
314
315	//writeln('timers active');
316	if tv.tv_sec < 0 then begin
317	tv.tv_sec := 0;
318	tv.tv_usec := 0; {0.1 sec}
319	end;
320	if exitloopflag then break;
321	{ sleep(10);}
322	selectresult := doselect(@tv);
323	processtimers;
324
325	end;
326	if selectresult > 0 then processasios(fdsr,fdsw);
327	{!!!only call processasios if select has asio events -beware}
328
329	{artificial delay to throttle the number of processasios per second possible and reduce cpu usage}
330	until false;
331	end;
332
333
334	procedure tselecteventcore.rmasterset(fd : integer;islistensocket : boolean);
335	begin
336	//writeln('rmasterset called with fd ',fd);
337	if fd > absolutemaxs then raise esocketexception.create('file descriptor out of range');
338	if fd > maxs then maxs := fd;
339	if fd_isset(fd,fdsrmaster) then exit;
340	fd_set(fd,fdsrmaster);
341
342	end;
343
344	procedure tselecteventcore.rmasterclr(fd: integer);
345	begin
346	//writeln('rmasterclr called with fd ',fd);
347	if not fd_isset(fd,fdsrmaster) then exit;
348	fd_clr(fd,fdsrmaster);
349
350	end;
351
352
353	procedure tselecteventcore.wmasterset(fd : integer);
354	begin
355	//writeln('wmasterset called with fd ',fd);
356	if fd > absolutemaxs then raise esocketexception.create('file descriptor out of range');
357	if fd > maxs then maxs := fd;
358
359	if fd_isset(fd,fdswmaster) then exit;
360	fd_set(fd,fdswmaster);
361
362	end;
363
364	procedure tselecteventcore.wmasterclr(fd: integer);
365	begin
366	//writeln('wmasterclr called with fd ',fd);
367	if not fd_isset(fd,fdswmaster) then exit;
368	fd_clr(fd,fdswmaster);
369	end;
370
371	procedure tselecteventcore.setfdreverse(fd : integer;reverseto : tlasio);
372	begin
373	fdreverse[fd] := reverseto;
374	end;
375
376	var
377	inited:boolean;
378
379	procedure lcoreinit;
380	begin
381	if inited then exit;
382	inited := true;
383	eventcore := tselecteventcore.create;
384
385	absolutemaxs := absolutemaxs_select;
386
387	maxs := 0;
388	fd_zero(fdsrmaster);
389	fd_zero(fdswmaster);
390	end;
391
392	end.
No admin address has been configured">No admin address has been configured	ViewVC Help
Powered by ViewVC 1.1.26