+++ /dev/null
-{lsocket.pas}\r
-\r
-{io and timer code by plugwash}\r
-\r
-{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
- For conditions of distribution and use, see copyright notice in zlib_license.txt\r
- which is included in the package\r
- ----------------------------------------------------------------------------- }\r
-\r
-{note: you must use the @ in the last param to tltask.create not doing so will\r
- compile without error but will cause an access violation -pg}\r
-\r
-//note: events after release are normal and are the apps responsibility to deal with safely\r
-\r
-unit lcore;\r
-{$ifdef fpc}\r
- {$mode delphi}\r
-{$endif}\r
-{$ifdef win32}\r
- {$define nosignal}\r
-{$endif}\r
-interface\r
- uses\r
- sysutils,\r
- {$ifndef win32}\r
- {$ifdef VER1_0}\r
- linux,\r
- {$else}\r
- baseunix,unix,\r
- {$endif}\r
- fd_utils,\r
- {$endif}\r
- classes,pgtypes,bfifo;\r
- procedure processtasks;\r
-\r
-\r
-\r
-\r
-\r
-\r
-\r
- const\r
- receivebufsize=1460;\r
-\r
- type\r
- {$ifdef ver1_0}\r
- sigset= array[0..31] of longint;\r
- {$endif}\r
-\r
- ESocketException = class(Exception);\r
- TBgExceptionEvent = procedure (Sender : TObject;\r
- E : Exception;\r
- var CanClose : Boolean) of object;\r
-\r
- // note : tsocketstate is defined in the same way as it is in François PIETTE's twsocket\r
- // however tlsocket currently only uses wsClosed wsConnecting wsconnected and wsListening\r
- TSocketState = (wsInvalidState,\r
- wsOpened, wsBound,\r
- wsConnecting, wsConnected,\r
- wsAccepting, wsListening,\r
- wsClosed);\r
-\r
- TWSocketOption = (wsoNoReceiveLoop, wsoTcpNoDelay);\r
- TWSocketOptions = set of TWSocketOption;\r
-\r
- TSocketevent = procedure(Sender: TObject; Error: word) of object;\r
- //Tdataavailevent = procedure(data : string);\r
- TSendData = procedure (Sender: TObject; BytesSent: Integer) of object;\r
-\r
- tlcomponent = class(tcomponent)\r
- public\r
- released:boolean;\r
- procedure release; virtual;\r
- destructor destroy; override;\r
- end;\r
-\r
- tlasio = class(tlcomponent)\r
- public\r
- state : tsocketstate ;\r
- ComponentOptions : TWSocketOptions;\r
- fdhandlein : Longint ; {file discriptor}\r
- fdhandleout : Longint ; {file discriptor}\r
-\r
- onsessionclosed : tsocketevent ;\r
- ondataAvailable : tsocketevent ;\r
- onsessionAvailable : tsocketevent ;\r
-\r
- onsessionconnected : tsocketevent ;\r
- onsenddata : tsenddata ;\r
- ondatasent : tsocketevent ;\r
- //connected : boolean ;\r
- nextasin : tlasio ;\r
- prevasin : tlasio ;\r
-\r
- recvq : tfifo;\r
- OnBgException : TBgExceptionEvent ;\r
- //connectread : boolean ;\r
- sendq : tfifo;\r
- closehandles : boolean ;\r
- writtenthiscycle : boolean ;\r
- onfdwrite : procedure (Sender: TObject; Error: word) of object; //added for bewarehttpd\r
- lasterror:integer;\r
- destroying:boolean;\r
- function receivestr:string; virtual;\r
- procedure close;\r
- procedure abort;\r
- procedure internalclose(error:word); virtual;\r
- constructor Create(AOwner: TComponent); override;\r
-\r
- destructor destroy; override;\r
- procedure fdcleanup;\r
- procedure HandleBackGroundException(E: Exception);\r
- procedure handlefdtrigger(readtrigger,writetrigger:boolean); virtual;\r
- procedure dup(invalue:longint);\r
-\r
- function sendflush : integer;\r
- procedure sendstr(const str : string);virtual;\r
- procedure putstringinsendbuffer(const newstring : string);\r
- function send(data:pointer;len:integer):integer;virtual;\r
- procedure putdatainsendbuffer(data:pointer;len:integer); virtual;\r
- procedure deletebuffereddata;\r
-\r
- //procedure messageloop;\r
- function Receive(Buf:Pointer;BufSize:integer):integer; virtual;\r
- procedure flush;virtual;{$ifdef win32} abstract;{$endif}\r
- procedure dodatasent(wparam,lparam:longint);\r
- procedure doreceiveloop(wparam,lparam:longint);\r
- procedure sinkdata(sender:tobject;error:word);\r
-\r
- procedure release; override; {test -beware}\r
-\r
- function RealSend(Data : Pointer; Len : Integer) : Integer; //added for bewarehttpd\r
-\r
- procedure myfdclose(fd : integer); virtual;{$ifdef win32}abstract;{$endif}\r
- function myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt; virtual;{$ifdef win32}abstract;{$endif}\r
- function myfdread(fd: LongInt;var buf;size: LongInt):LongInt; virtual;{$ifdef win32}abstract;{$endif}\r
- protected\r
- procedure dupnowatch(invalue:longint);\r
- end;\r
- ttimerwrapperinterface=class(tlcomponent)\r
- public\r
- function createwrappedtimer : tobject;virtual;abstract;\r
-// procedure setinitialevent(wrappedtimer : tobject;newvalue : boolean);virtual;abstract;\r
- procedure setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);virtual;abstract;\r
- procedure setenabled(wrappedtimer : tobject;newvalue : boolean);virtual;abstract;\r
- procedure setinterval(wrappedtimer : tobject;newvalue : integer);virtual;abstract;\r
- end;\r
-\r
- var\r
- timerwrapperinterface : ttimerwrapperinterface;\r
- type\r
- {$ifdef win32}\r
- ttimeval = record\r
- tv_sec : longint;\r
- tv_usec : longint;\r
- end;\r
- {$endif}\r
- tltimer=class(tlcomponent)\r
- protected\r
-\r
-\r
- wrappedtimer : tobject;\r
-\r
-\r
-// finitialevent : boolean ;\r
- fontimer : tnotifyevent ;\r
- fenabled : boolean ;\r
- finterval : integer ; {miliseconds, default 1000}\r
- {$ifndef win32}\r
- procedure resettimes;\r
- {$endif}\r
-// procedure setinitialevent(newvalue : boolean);\r
- procedure setontimer(newvalue:tnotifyevent);\r
- procedure setenabled(newvalue : boolean);\r
- procedure setinterval(newvalue : integer);\r
- public\r
- //making theese public for now, this code should probablly be restructured later though\r
- prevtimer : tltimer ;\r
- nexttimer : tltimer ;\r
- nextts : ttimeval ;\r
-\r
- constructor create(aowner:tcomponent);override;\r
- destructor destroy;override;\r
-// property initialevent : boolean read finitialevent write setinitialevent;\r
- property ontimer : tnotifyevent read fontimer write setontimer;\r
- property enabled : boolean read fenabled write setenabled;\r
- property interval : integer read finterval write setinterval;\r
-\r
- end;\r
-\r
- ttaskevent=procedure(wparam,lparam:longint) of object;\r
-\r
- tltask=class(tobject)\r
- public\r
- handler : ttaskevent;\r
- obj : tobject;\r
- wparam : longint;\r
- lparam : longint;\r
- nexttask : tltask;\r
- constructor create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
- end;\r
-\r
-\r
-\r
- teventcore=class\r
- public\r
- procedure processmessages; virtual;abstract;\r
- procedure messageloop; virtual;abstract;\r
- procedure exitmessageloop; virtual;abstract;\r
- procedure setfdreverse(fd : integer;reverseto : tlasio);virtual;abstract;\r
- procedure rmasterset(fd : integer;islistensocket : boolean); virtual;abstract;\r
- procedure rmasterclr(fd: integer); virtual;abstract;\r
- procedure wmasterset(fd : integer); virtual;abstract;\r
- procedure wmasterclr(fd: integer); virtual;abstract;\r
- end;\r
-var\r
- eventcore : teventcore;\r
-\r
-procedure processmessages;\r
-procedure messageloop;\r
-procedure exitmessageloop;\r
-\r
-var\r
- firstasin : tlasio ;\r
- firsttimer : tltimer ;\r
- firsttask , lasttask , currenttask : tltask ;\r
-\r
- numread : integer ;\r
- mustrefreshfds : boolean ;\r
-{ lcoretestcount:integer;}\r
-\r
- asinreleaseflag:boolean;\r
-\r
-\r
-procedure disconnecttasks(aobj:tobject);\r
-procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
-type\r
- tonaddtask = procedure(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
-var\r
- onaddtask : tonaddtask;\r
-\r
-\r
-procedure sleep(i:integer);\r
-{$ifndef nosignal}\r
- procedure prepsigpipe;inline;\r
-{$endif}\r
-\r
-\r
-implementation\r
-{$ifndef nosignal}\r
- uses {sockets,}lloopback,lsignal;\r
-{$endif}\r
-{$ifdef win32}\r
- uses windows;\r
-{$endif}\r
-{$ifndef win32}\r
- {$include unixstuff.inc}\r
-{$endif}\r
-{$include ltimevalstuff.inc}\r
-\r
-\r
-{!!! added sleep call -beware}\r
-procedure sleep(i:integer);\r
-var\r
- tv:ttimeval;\r
-begin\r
- {$ifdef win32}\r
- windows.sleep(i);\r
- {$else}\r
- tv.tv_sec := i div 1000;\r
- tv.tv_usec := (i mod 1000) * 1000;\r
- select(0,nil,nil,nil,@tv);\r
- {$endif}\r
-end;\r
-\r
-destructor tlcomponent.destroy;\r
-begin\r
- disconnecttasks(self);\r
- inherited destroy;\r
-end;\r
-\r
-\r
-\r
-\r
-procedure tlcomponent.release;\r
-begin\r
- released := true;\r
-end;\r
-\r
-procedure tlasio.release;\r
-begin\r
- asinreleaseflag := true;\r
- inherited release;\r
-end;\r
-\r
-procedure tlasio.doreceiveloop;\r
-begin\r
- if recvq.size = 0 then exit;\r
- if assigned(ondataavailable) then ondataavailable(self,0);\r
- if not (wsonoreceiveloop in componentoptions) then\r
- if recvq.size > 0 then tltask.create(self.doreceiveloop,self,0,0);\r
-end;\r
-\r
-function tlasio.receivestr;\r
-begin\r
- setlength(result,recvq.size);\r
- receive(@result[1],length(result));\r
-end;\r
-\r
-function tlasio.receive(Buf:Pointer;BufSize:integer):integer;\r
-var\r
- i,a,b:integer;\r
- p:pointer;\r
-begin\r
- i := bufsize;\r
- if recvq.size < i then i := recvq.size;\r
- a := 0;\r
- while (a < i) do begin\r
- b := recvq.get(p,i-a);\r
- move(p^,buf^,b);\r
- inc(taddrint(buf),b);\r
- recvq.del(b);\r
- inc(a,b);\r
- end;\r
- result := i;\r
- if wsonoreceiveloop in componentoptions then begin\r
- if recvq.size = 0 then eventcore.rmasterset(fdhandlein,false);\r
- end;\r
-end;\r
-\r
-constructor tlasio.create;\r
-begin\r
- inherited create(AOwner);\r
- sendq := tfifo.create;\r
- recvq := tfifo.create;\r
- state := wsclosed;\r
- fdhandlein := -1;\r
- fdhandleout := -1;\r
- nextasin := firstasin;\r
- prevasin := nil;\r
- if assigned(nextasin) then nextasin.prevasin := self;\r
- firstasin := self;\r
-\r
- released := false;\r
-end;\r
-\r
-destructor tlasio.destroy;\r
-begin\r
- destroying := true;\r
- if state <> wsclosed then close;\r
- if prevasin <> nil then begin\r
- prevasin.nextasin := nextasin;\r
- end else begin\r
- firstasin := nextasin;\r
- end;\r
- if nextasin <> nil then begin\r
- nextasin.prevasin := prevasin;\r
- end;\r
- recvq.destroy;\r
- sendq.destroy;\r
- inherited destroy;\r
-end;\r
-\r
-procedure tlasio.close;\r
-begin\r
- internalclose(0);\r
-end;\r
-\r
-procedure tlasio.abort;\r
-begin\r
- close;\r
-end;\r
-\r
-procedure tlasio.fdcleanup;\r
-begin\r
- if fdhandlein <> -1 then begin\r
- eventcore.rmasterclr(fdhandlein); //fd_clr(fdhandlein,fdsrmaster)\r
- end;\r
- if fdhandleout <> -1 then begin\r
- eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster)\r
- end;\r
- if fdhandlein=fdhandleout then begin\r
- if fdhandlein <> -1 then begin\r
- myfdclose(fdhandlein);\r
- end;\r
- end else begin\r
- if fdhandlein <> -1 then begin\r
- myfdclose(fdhandlein);\r
- end;\r
- if fdhandleout <> -1 then begin\r
- myfdclose(fdhandleout);\r
- end;\r
- end;\r
- fdhandlein := -1;\r
- fdhandleout := -1;\r
-end;\r
-\r
-procedure tlasio.internalclose(error:word);\r
-begin\r
- if state<>wsclosed then begin\r
- if (fdhandlein < 0) or (fdhandleout < 0) then raise exception.create('internalclose called with invalid fd handles');\r
- eventcore.rmasterclr(fdhandlein);//fd_clr(fdhandlein,fdsrmaster);\r
- eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster);\r
-\r
- if closehandles then begin\r
- {$ifndef win32}\r
- //anyone remember why this is here? --plugwash\r
- fcntl(fdhandlein,F_SETFL,0);\r
- {$endif}\r
- myfdclose(fdhandlein);\r
- if fdhandleout <> fdhandlein then begin\r
- {$ifndef win32}\r
- fcntl(fdhandleout,F_SETFL,0);\r
- {$endif}\r
- myfdclose(fdhandleout);\r
- end;\r
- eventcore.setfdreverse(fdhandlein,nil);\r
- eventcore.setfdreverse(fdhandleout,nil);\r
-\r
- fdhandlein := -1;\r
- fdhandleout := -1;\r
- end;\r
- state := wsclosed;\r
-\r
- if assigned(onsessionclosed) then if not destroying then onsessionclosed(self,error);\r
- end;\r
- sendq.del(maxlongint);\r
-end;\r
-\r
-\r
-{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}\r
-{ All exceptions *MUST* be handled. If an exception is not handled, the }\r
-{ application will most likely be shut down ! }\r
-procedure tlasio.HandleBackGroundException(E: Exception);\r
-var\r
- CanAbort : Boolean;\r
-begin\r
- CanAbort := TRUE;\r
- { First call the error event handler, if any }\r
- if Assigned(OnBgException) then begin\r
- try\r
- OnBgException(Self, E, CanAbort);\r
- except\r
- end;\r
- end;\r
- { Then abort the socket }\r
- if CanAbort then begin\r
- try\r
- close;\r
- except\r
- end;\r
- end;\r
-end;\r
-\r
-procedure tlasio.sendstr(const str : string);\r
-begin\r
- putstringinsendbuffer(str);\r
- sendflush;\r
-end;\r
-\r
-procedure tlasio.putstringinsendbuffer(const newstring : string);\r
-begin\r
- if newstring <> '' then putdatainsendbuffer(@newstring[1],length(newstring));\r
-end;\r
-\r
-function tlasio.send(data:pointer;len:integer):integer;\r
-begin\r
- if state <> wsconnected then begin\r
- result := -1;\r
- exit;\r
- end;\r
- if len < 0 then len := 0;\r
- result := len;\r
- putdatainsendbuffer(data,len);\r
- sendflush;\r
-end;\r
-\r
-\r
-procedure tlasio.putdatainsendbuffer(data:pointer;len:integer);\r
-begin\r
- sendq.add(data,len);\r
-end;\r
-\r
-function tlasio.sendflush : integer;\r
-var\r
- lensent : integer;\r
- data:pointer;\r
-// fdstestr : fdset;\r
-// fdstestw : fdset;\r
-begin\r
- if state <> wsconnected then exit;\r
-\r
- lensent := sendq.get(data,2920);\r
- if assigned(data) then result := myfdwrite(fdhandleout,data^,lensent) else result := 0;\r
-\r
- if result = -1 then lensent := 0 else lensent := result;\r
-\r
- //sendq := copy(sendq,lensent+1,length(sendq)-lensent);\r
- sendq.del(lensent);\r
-\r
- //fd_clr(fdhandleout,fdsw); // this prevents the socket being closed by a write\r
- // that sends nothing because a previous socket has\r
- // slready flushed this socket when the message loop\r
- // reaches it\r
-// if sendq.size > 0 then begin\r
- eventcore.wmasterset(fdhandleout);//fd_set(fdhandleout,fdswmaster);\r
-// end else begin\r
-// wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster);\r
-// end;\r
- if result > 0 then begin\r
- if assigned(onsenddata) then onsenddata(self,result);\r
-// if sendq.size=0 then if assigned(ondatasent) then begin\r
-// tltask.create(self.dodatasent,self,0,0);\r
-// //begin test code\r
-// fd_zero(fdstestr);\r
-// fd_zero(fdstestw);\r
-// fd_set(fdhandlein,fdstestr);\r
-// fd_set(fdhandleout,fdstestw);\r
-// select(maxs,@fdstestr,@fdstestw,nil,0);\r
-// writeln(fd_isset(fdhandlein,fdstestr),' ',fd_isset(fdhandleout,fdstestw));\r
-// //end test code\r
-// \r
-// end;\r
- writtenthiscycle := true;\r
- end;\r
-end;\r
-\r
-procedure tlasio.dupnowatch(invalue:longint);\r
-begin\r
- { debugout('invalue='+inttostr(invalue));}\r
- //readln;\r
- if state<> wsclosed then close;\r
- fdhandlein := invalue;\r
- fdhandleout := invalue;\r
- eventcore.setfdreverse(fdhandlein,self);\r
- {$ifndef win32}\r
- fcntl(fdhandlein,F_SETFL,OPEN_NONBLOCK);\r
- {$endif}\r
- state := wsconnected;\r
-\r
-end;\r
-\r
-\r
-procedure tlasio.dup(invalue:longint);\r
-begin\r
- dupnowatch(invalue);\r
- eventcore.rmasterset(fdhandlein,false);//fd_set(fdhandlein,fdsrmaster);\r
- eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster);\r
-end;\r
-\r
-\r
-procedure tlasio.handlefdtrigger(readtrigger,writetrigger:boolean);\r
-var\r
- sendflushresult : integer;\r
- tempbuf:array[0..receivebufsize-1] of byte;\r
-begin\r
- if (state=wsconnected) and writetrigger then begin\r
- //writeln('write trigger');\r
-\r
- if (sendq.size >0) then begin\r
-\r
- sendflushresult := sendflush;\r
- if (sendflushresult <= 0) and (not writtenthiscycle) then begin\r
- if sendflushresult=0 then begin // linuxerror := 0;\r
- internalclose(0);\r
-\r
- end else begin\r
- internalclose({$ifdef win32}getlasterror{$else}linuxerror{$endif});\r
- end;\r
- end;\r
-\r
- end else begin\r
- //everything is sent fire off ondatasent event\r
- if fdhandleout >= 0 then eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster);\r
- if assigned(ondatasent) then tltask.create(self.dodatasent,self,0,0);\r
- end;\r
- if assigned(onfdwrite) then onfdwrite(self,0);\r
- end;\r
- writtenthiscycle := false;\r
- if (state =wsconnected) and readtrigger then begin\r
- if recvq.size=0 then begin\r
- numread := myfdread(fdhandlein,tempbuf,sizeof(tempbuf));\r
- if (numread=0) and (not mustrefreshfds) then begin\r
- {if i remember correctly numread=0 is caused by eof\r
- if this isn't dealt with then you get a cpu eating infinite loop\r
- however if onsessionconencted has called processmessages that could\r
- cause us to drop to here with an empty recvq and nothing left to read\r
- and we don't want that to cause the socket to close}\r
-\r
- internalclose(0);\r
- end else if (numread=-1) then begin\r
- numread := 0;\r
- internalclose({$ifdef win32}getlasterror{$else}linuxerror{$endif});\r
- end else if numread > 0 then recvq.add(@tempbuf,numread);\r
- end;\r
-\r
- if recvq.size > 0 then begin\r
- if wsonoreceiveloop in componentoptions then eventcore.rmasterclr(fdhandlein); //fd_clr(fdhandlein,fdsrmaster);\r
- if assigned(ondataavailable) then ondataAvailable(self,0);\r
- if not (wsonoreceiveloop in componentoptions) then if recvq.size > 0 then\r
- tltask.create(self.doreceiveloop,self,0,0);\r
- end;\r
- //until (numread = 0) or (currentsocket.state<>wsconnected);\r
-{ debugout('inner loop complete');}\r
- end;\r
-end;\r
-\r
-{$ifndef win32}\r
- procedure tlasio.flush;\r
- var\r
- fds : fdset;\r
- begin\r
- fd_zero(fds);\r
- fd_set(fdhandleout,fds);\r
- while sendq.size>0 do begin\r
- select(fdhandleout+1,nil,@fds,nil,nil);\r
- if sendflush <= 0 then exit;\r
- end;\r
- end;\r
-{$endif}\r
-\r
-procedure tlasio.dodatasent(wparam,lparam:longint);\r
-begin\r
- if assigned(ondatasent) then ondatasent(self,lparam);\r
-end;\r
-\r
-procedure tlasio.deletebuffereddata;\r
-begin\r
- sendq.del(maxlongint);\r
-end;\r
-\r
-procedure tlasio.sinkdata(sender:tobject;error:word);\r
-begin\r
- tlasio(sender).recvq.del(maxlongint);\r
-end;\r
-\r
-{$ifndef win32}\r
- procedure tltimer.resettimes;\r
- begin\r
- gettimeofday(nextts);\r
- {if not initialevent then} tv_add(nextts,interval);\r
- end;\r
-{$endif}\r
-\r
-{procedure tltimer.setinitialevent(newvalue : boolean);\r
-begin\r
- if newvalue <> finitialevent then begin\r
- finitialevent := newvalue;\r
- if assigned(timerwrapperinterface) then begin\r
- timerwrapperinterface.setinitialevent(wrappedtimer,newvalue);\r
- end else begin\r
- resettimes;\r
- end;\r
- end;\r
-end;}\r
-\r
-procedure tltimer.setontimer(newvalue:tnotifyevent);\r
-begin\r
- if @newvalue <> @fontimer then begin\r
- fontimer := newvalue;\r
- if assigned(timerwrapperinterface) then begin\r
- timerwrapperinterface.setontimer(wrappedtimer,newvalue);\r
- end else begin\r
-\r
- end;\r
- end;\r
-\r
-end;\r
-\r
-\r
-procedure tltimer.setenabled(newvalue : boolean);\r
-begin\r
- if newvalue <> fenabled then begin\r
- fenabled := newvalue;\r
- if assigned(timerwrapperinterface) then begin\r
- timerwrapperinterface.setenabled(wrappedtimer,newvalue);\r
- end else begin\r
- {$ifdef win32}\r
- raise exception.create('non wrapper timers are not permitted on windows');\r
- {$else}\r
- resettimes;\r
- {$endif}\r
- end;\r
- end;\r
-end;\r
-\r
-procedure tltimer.setinterval(newvalue:integer);\r
-begin\r
- if newvalue <> finterval then begin\r
- finterval := newvalue;\r
- if assigned(timerwrapperinterface) then begin\r
- timerwrapperinterface.setinterval(wrappedtimer,newvalue);\r
- end else begin\r
- {$ifdef win32}\r
- raise exception.create('non wrapper timers are not permitted on windows');\r
- {$else}\r
- resettimes;\r
- {$endif}\r
- end;\r
- end;\r
-\r
-end;\r
-\r
-\r
-\r
-\r
-constructor tltimer.create;\r
-begin\r
- inherited create(AOwner);\r
- if assigned(timerwrapperinterface) then begin\r
- wrappedtimer := timerwrapperinterface.createwrappedtimer;\r
- end else begin\r
-\r
-\r
- nexttimer := firsttimer;\r
- prevtimer := nil;\r
-\r
- if assigned(nexttimer) then nexttimer.prevtimer := self;\r
- firsttimer := self;\r
- end;\r
- interval := 1000;\r
- enabled := true;\r
- released := false;\r
-\r
-end;\r
-\r
-destructor tltimer.destroy;\r
-begin\r
- if assigned(timerwrapperinterface) then begin\r
- wrappedtimer.free;\r
- end else begin\r
- if prevtimer <> nil then begin\r
- prevtimer.nexttimer := nexttimer;\r
- end else begin\r
- firsttimer := nexttimer;\r
- end;\r
- if nexttimer <> nil then begin\r
- nexttimer.prevtimer := prevtimer;\r
- end;\r
- \r
- end;\r
- inherited destroy;\r
-end;\r
-\r
-constructor tltask.create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
-begin\r
- inherited create;\r
- if assigned(onaddtask) then onaddtask(ahandler,aobj,awparam,alparam);\r
- handler := ahandler;\r
- obj := aobj;\r
- wparam := awparam;\r
- lparam := alparam;\r
- {nexttask := firsttask;\r
- firsttask := self;}\r
- if assigned(lasttask) then begin\r
- lasttask.nexttask := self;\r
- end else begin\r
- firsttask := self;\r
- end;\r
- lasttask := self;\r
- //ahandler(wparam,lparam);\r
-end;\r
-\r
-procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
-begin\r
-\r
- tltask.create(ahandler,aobj,awparam,alparam);\r
-end;\r
-\r
-\r
-\r
-\r
-{$ifndef nosignal}\r
- procedure prepsigpipe;inline;\r
- begin\r
- starthandlesignal(sigpipe);\r
- if not assigned(signalloopback) then begin\r
- signalloopback := tlloopback.create(nil);\r
- signalloopback.ondataAvailable := signalloopback.sinkdata;\r
-\r
- end;\r
-\r
- end;\r
-{$endif}\r
-\r
-procedure processtasks;//inline;\r
-var\r
- temptask : tltask ;\r
-\r
-begin\r
-\r
- if not assigned(currenttask) then begin\r
- currenttask := firsttask;\r
- firsttask := nil;\r
- lasttask := nil;\r
- end;\r
- while assigned(currenttask) do begin\r
-\r
- if assigned(currenttask.handler) then currenttask.handler(currenttask.wparam,currenttask.lparam);\r
- if assigned(currenttask) then begin\r
- temptask := currenttask;\r
- currenttask := currenttask.nexttask;\r
- temptask.free;\r
- end;\r
- //writeln('processed a task');\r
- end;\r
-\r
-end;\r
-\r
-\r
-\r
-\r
-procedure disconnecttasks(aobj:tobject);\r
-var\r
- currenttasklocal : tltask ;\r
- counter : byte ;\r
-begin\r
- for counter := 0 to 1 do begin\r
- if counter = 0 then begin\r
- currenttasklocal := firsttask; //main list of tasks\r
- end else begin\r
- currenttasklocal := currenttask; //needed in case called from a task\r
- end;\r
- // note i don't bother to sestroy the links here as that will happen when\r
- // the list of tasks is processed anyway\r
- while assigned(currenttasklocal) do begin\r
- if currenttasklocal.obj = aobj then begin\r
- currenttasklocal.obj := nil;\r
- currenttasklocal.handler := nil;\r
- end;\r
- currenttasklocal := currenttasklocal.nexttask;\r
- end;\r
- end;\r
-end;\r
-\r
-\r
-procedure processmessages;\r
-begin\r
- eventcore.processmessages;\r
-end;\r
-procedure messageloop;\r
-begin\r
- eventcore.messageloop;\r
-end;\r
-\r
-procedure exitmessageloop;\r
-begin\r
- eventcore.exitmessageloop;\r
-end;\r
-\r
-function tlasio.RealSend(Data : Pointer; Len : Integer) : Integer;\r
-begin\r
- result := myfdwrite(fdhandleout,data^,len);\r
- if (result > 0) and assigned(onsenddata) then onsenddata(self,result);\r
- eventcore.wmasterset(fdhandleout);\r
-end;\r
-{$ifndef win32}\r
- procedure tlasio.myfdclose(fd : integer);\r
- begin\r
- fdclose(fd);\r
- end;\r
- function tlasio.myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt;\r
- begin\r
- result := fdwrite(fd,buf,size);\r
- end;\r
-\r
- function tlasio.myfdread(fd: LongInt;var buf;size: LongInt):LongInt;\r
- begin\r
- result := fdread(fd,buf,size);\r
- end;\r
-\r
-\r
-{$endif}\r
-\r
-\r
-begin\r
- firstasin := nil;\r
- firsttask := nil;\r
- \r
-\r
- {$ifndef nosignal}\r
- signalloopback := nil;\r
- {$endif}\r
-end.\r
-\r
-\r
-\r
-\r
-\r
lcore.org gitweb / lcore.git / blobdiff