4 uses MemStream
,NetAddr
;
13 stream
: tMemoryStream
;
16 type tMessageHandler
=procedure(msg
:tSMsg
);
17 procedure SetMsgHandler(OpCode
:byte; handler
:tMessageHandler
);
18 procedure SetHiMsgHandler(handler
:tMessageHandler
);
20 {#Sheduling and watching#}
21 type tFDEventHandler
=procedure(ev
:Word) of object;
22 type tOnTimer
=procedure of object;
23 procedure WatchFD(fd
:tHandle
; h
:tFDEventHandler
);
24 procedure Shedule(timeout
{ms}: LongWord
; h
:tOnTimer
);
25 procedure UnShedule(h
:tOnTimer
);
26 {note unshed will fail when called from OnTimer proc}
30 USES SysUtils
,Sockets
,UnixType
,BaseUnix
34 {aim for most simple implementation, since could be extended anytime}
39 var pollArr
: packed array [tPollTop
] of tPollFd
;
41 cb
: tFDEventHandler
; {proc+object}
43 var pollHnd
: array [tPollTop
] of tFdHndDsc
;
44 var pollTop
: tPollTop
;
46 var hnd
: array [1..36] of tMessageHandler
;
47 var HiHnd
: tMessageHandler
;
49 type tSheduled_ptr
=^tSheduled
; tSheduled
=record
54 var ShedTop
: ^tSheduled
;
55 var ShedUU
: ^tSheduled
;
56 var LastShed
: UnixType
.timeval
;
57 var PollTimeout
:LongInt;
59 procedure SC(fn
:pointer; retval
:cint
);
61 if retval
< 0 then begin
62 raise eXception
.Create(Format('Socket error %d operation %P',[SocketError
,fn
]));
66 procedure s_SetupInet
;
67 var bind_addr
:tInetSockAddr
;
69 with bind_addr
do begin
73 s_inet
:=fpSocket(family
,SOCK_DGRAM
,IPPROTO_UDP
);
76 SC(@fpBind
,fpBind(s_inet
,@bind_addr
,sizeof(bind_addr
)));
77 with PollArr
[0] do begin
84 var Terminated
:boolean=false;
86 procedure SendMessage(const data
; len
:word; const rcpt
:tSockAddr
);
89 SC(@fpsendto
,fpsendto(s_inet
,@data
,len
,0,@rcpt
,sizeof(sockaddr_in
)));
92 procedure SignalHandler(sig
:cint
);CDecl;
95 if terminated
then raise eControlC
.Create('CtrlC DoubleTap') ;
97 writeln('Shutdown requested');
100 {do not waste stack on statics}
101 var EventsCount
:integer;
102 var Buffer
:array [1..1024] of byte;
104 var From
:tSockAddrL
; {use larger struct so everything fits}
105 var FromLen
:LongWord
;
107 var curhnd
:tMessageHandler
;
111 procedure PrepareHandler
;
113 FromG
.FromSocket(from
);
114 if Buffer
[1]>128 then curhnd
:=HiHnd
else curhnd
:=hnd
[Buffer
[1]];
115 if not assigned(curhnd
) then raise eXception
.Create('No handler for opcode '+IntToStr(Buffer
[1]));
116 Msg
.Source
:=@FromG
; {!thread}
118 Msg
.Data
:=@Buffer
; {!thread}
119 Msg
.stream
.Init(@Buffer
,pkLen
,sizeof(Buffer
));
120 Msg
.channel
:=0; {!multisocket}
126 var now
:UnixType
.timeval
;
128 var olTop
:^tSheduled
;
134 ShedTop
:=nil; {unlink the current shed list}
135 fpgettimeofday(@Now
,nil);
136 delta
:=(Now
.tv_sec
-LastShed
.tv_sec
);
137 if delta
>6 then delta
:=5000 else delta
:=(delta
*1000)+((Now
.tv_usec
-LastShed
.tv_usec
) div 1000);
139 //writeln('DeltaTime: ',delta);
140 while assigned(cur
) do begin
141 if cur
^.left
<delta
then begin
148 DEC(cur
^.left
,delta
);
149 if pollTimeOut
>cur
^.left
then PollTimeOut
:=cur
^.left
;
150 //if pollTimeout>20 then pollTimeOut:=pollTimeOut div 2;
151 if pollTimeout
=0 then pollTimeOut
:=1;
156 pcur
^:=ShedTop
; {append newly added tasks to end of untriggererd list}
157 ShedTop
:=olTop
; {link in the untriggered tasks}
163 while not terminated
do begin
166 EventsCount
:=fpPoll(@PollArr
[0],PollTop
,PollTimeout
);
167 if (eventscount
=-1)and terminated
then break
;
168 if eventscount
=-1 then break
; {fixme: print error}
169 if eventscount
=0 then continue
else begin
171 with PollArr
[0] do begin
172 if (revents
and pollIN
)>0 then begin
173 FromLen
:=sizeof(From
);
174 pkLen
:=fprecvfrom(s_inet
,@Buffer
,sizeof(Buffer
),0,@from
,@fromlen
);
175 SC(@fprecvfrom
,pkLen
);
183 for tp
:=1 to pollTop
do if PollArr
[tp
].revents
>0 then begin
184 PollHnd
[tp
].CB(PollArr
[tp
].rEvents
);
185 PollArr
[tp
].revents
:=0;
189 write('Loop broken [');
194 procedure SetMsgHandler(OpCode
:byte; handler
:tMessageHandler
);
195 begin hnd
[OpCode
]:=handler
; end;
196 procedure SetHiMsgHandler(handler
:tMessageHandler
);
197 begin Hihnd
:=handler
; end;
199 procedure WatchFD(fd
:tHandle
; h
:tFDEventHandler
);
202 if assigned(h
) then begin
203 PollHnd
[pollTop
].CB
:=h
;
204 PollArr
[pollTop
].fd
:=fd
;
205 PollArr
[pollTop
].events
:=POLLERR
or POLLHUP
or POLLIN
or POLLPRI
or
206 POLLRDBAND
or POLLRDNORM
;
207 PollArr
[pollTop
].revents
:=0;
208 //writeln('Add watch ',pollTop,' on ',fd,' to ',IntToHex(qword(@h),8));
210 end else for opt
:=0 to high(opt
) do if PollArr
[opt
].fd
=fd
then begin
211 if (pollTop
-1)>opt
then begin
212 PollArr
[opt
]:=PollArr
[pollTop
-1];
213 PollHnd
[opt
]:=PollHnd
[pollTop
-1];
216 PollArr
[pollTop
].fd
:=-1;
217 PollArr
[pollTop
].events
:=0;
218 PollArr
[pollTop
].revents
:=0;
223 procedure Shedule(timeout
{ms}: LongWord
; h
:tOnTimer
);
227 if Assigned(ShedUU
) then begin
229 ShedUU
:=ShedUU
^.next
;
230 end else New(ShedTop
);
231 ShedTop
^.Left
:=timeout
;
236 procedure UnShedule(h
:tOnTimer
);
242 while assigned(cur
) do begin
243 if cur
^.cb
=h
then begin
244 pcur
^:=cur
^.next
; {unlink from main list}
245 cur
^.next
:=ShedUU
; ShedUU
:=cur
; {link to unused}
256 fpSignal(SigInt
,@SignalHandler
);
257 fpSignal(SigTerm
,@SignalHandler
);
258 for i
:=1 to high(hnd
) do hnd
[i
]:=nil;
259 pollTop
:=1; {1 for basic listen}
262 fpgettimeofday(@LastShed
,nil);