lcore.pas

   1 {lsocket.pas}\r
   2 \r
   3 {io and timer code by plugwash}\r
   4 \r
   5 { Copyright (C) 2005 Bas Steendijk and Peter Green\r
   6   For conditions of distribution and use, see copyright notice in zlib_license.txt\r
   7   which is included in the package\r
   8   ----------------------------------------------------------------------------- }\r
   9 \r
  10 {note: you must use the @ in the last param to tltask.create not doing so will\r
  11  compile without error but will cause an access violation -pg}\r
  12 \r
  13 //note: events after release are normal and are the apps responsibility to deal with safely\r
  14 \r
  15 unit lcore;\r
  16 {$ifdef fpc}\r
  17   {$mode delphi}\r
  18 {$endif}\r
  19 {$ifdef win32}\r
  20   {$define nosignal}\r
  21 {$endif}\r
  22 interface\r
  23   uses\r
  24     sysutils,\r
  25     {$ifndef win32}\r
  26       {$ifdef VER1_0}\r
  27         linux,\r
  28       {$else}\r
  29         baseunix,unix,unixutil,\r
  30       {$endif}\r
  31       fd_utils,\r
  32     {$endif}\r
  33     classes,pgtypes,bfifo;\r
  34   procedure processtasks;\r
  35 \r
  36 \r
  37   const\r
  38     receivebufsize=1460;\r
  39 \r
  40   type\r
  41     {$ifdef ver1_0}\r
  42       sigset= array[0..31] of longint;\r
  43     {$endif}\r
  44 \r
  45     ESocketException   = class(Exception);\r
  46     TBgExceptionEvent  = procedure (Sender : TObject;\r
  47                                   E : Exception;\r
  48                                   var CanClose : Boolean) of object;\r
  49 \r
  50     // note : tsocketstate is defined in the same way as it is in François PIETTE's twsocket\r
  51     // however tlsocket currently only uses wsClosed wsConnecting wsconnected and wsListening\r
  52     TSocketState       = (wsInvalidState,\r
  53                         wsOpened,     wsBound,\r
  54                         wsConnecting, wsConnected,\r
  55                         wsAccepting,  wsListening,\r
  56                         wsClosed);\r
  57 \r
  58     TWSocketOption       = (wsoNoReceiveLoop, wsoTcpNoDelay);\r
  59     TWSocketOptions      = set of TWSocketOption;\r
  60 \r
  61     TSocketevent     = procedure(Sender: TObject; Error: word) of object;\r
  62     //Tdataavailevent  = procedure(data : string);\r
  63     TSendData          = procedure (Sender: TObject; BytesSent: Integer) of object;\r
  64 \r
  65     tlcomponent = class(tcomponent)\r
  66     public\r
  67       released:boolean;\r
  68       procedure release; virtual;\r
  69       destructor destroy; override;\r
  70     end;\r
  71 \r
  72     tlasio = class(tlcomponent)\r
  73     public\r
  74       state              : tsocketstate      ;\r
  75       ComponentOptions   : TWSocketOptions;\r
  76       fdhandlein         : Longint           ;  {file discriptor}\r
  77       fdhandleout        : Longint           ;  {file discriptor}\r
  78 \r
  79       onsessionclosed    : tsocketevent      ;\r
  80       ondataAvailable    : tsocketevent      ;\r
  81       onsessionAvailable : tsocketevent      ;\r
  82 \r
  83       onsessionconnected : tsocketevent      ;\r
  84       onsenddata         : tsenddata      ;\r
  85       ondatasent         : tsocketevent      ;\r
  86       //connected          : boolean         ;\r
  87       nextasin           : tlasio            ;\r
  88       prevasin           : tlasio            ;\r
  89 \r
  90       recvq              : tfifo;\r
  91       OnBgException      : TBgExceptionEvent ;\r
  92       //connectread        : boolean           ;\r
  93       sendq              : tfifo;\r
  94       closehandles       : boolean           ;\r
  95       writtenthiscycle   : boolean           ;\r
  96       onfdwrite           : procedure (Sender: TObject; Error: word) of object; //added for bewarehttpd\r
  97       lasterror:integer;\r
  98       destroying:boolean;\r
  99       function receivestr:string; virtual;\r
 100       procedure close;\r
 101       procedure abort;\r
 102       procedure internalclose(error:word); virtual;\r
 103       constructor Create(AOwner: TComponent); override;\r
 104 \r
 105       destructor destroy; override;\r
 106       procedure fdcleanup;\r
 107       procedure HandleBackGroundException(E: Exception);\r
 108       procedure handlefdtrigger(readtrigger,writetrigger:boolean); virtual;\r
 109       procedure dup(invalue:longint);\r
 110 \r
 111       function sendflush : integer;\r
 112       procedure sendstr(const str : string);virtual;\r
 113       procedure putstringinsendbuffer(const newstring : string);\r
 114       function send(data:pointer;len:integer):integer;virtual;\r
 115       procedure putdatainsendbuffer(data:pointer;len:integer); virtual;\r
 116       procedure deletebuffereddata;\r
 117 \r
 118       //procedure messageloop;\r
 119       function Receive(Buf:Pointer;BufSize:integer):integer; virtual;\r
 120       procedure flush;virtual;{$ifdef win32} abstract;{$endif}\r
 121       procedure dodatasent(wparam,lparam:longint);\r
 122       procedure doreceiveloop(wparam,lparam:longint);\r
 123       procedure sinkdata(sender:tobject;error:word);\r
 124 \r
 125       procedure release; override; {test -beware}\r
 126 \r
 127       function RealSend(Data : Pointer; Len : Integer) : Integer; //added for bewarehttpd\r
 128 \r
 129       procedure myfdclose(fd : integer); virtual;{$ifdef win32}abstract;{$endif}\r
 130       function myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt; virtual;{$ifdef win32}abstract;{$endif}\r
 131       function myfdread(fd: LongInt;var buf;size: LongInt):LongInt; virtual;{$ifdef win32}abstract;{$endif}\r
 132     protected\r
 133       procedure dupnowatch(invalue:longint);\r
 134     end;\r
 135     ttimerwrapperinterface=class(tlcomponent)\r
 136     public\r
 137       function createwrappedtimer : tobject;virtual;abstract;\r
 138 //      procedure setinitialevent(wrappedtimer : tobject;newvalue : boolean);virtual;abstract;\r
 139       procedure setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);virtual;abstract;\r
 140       procedure setenabled(wrappedtimer : tobject;newvalue : boolean);virtual;abstract;\r
 141       procedure setinterval(wrappedtimer : tobject;newvalue : integer);virtual;abstract;\r
 142     end;\r
 143 \r
 144   var\r
 145     timerwrapperinterface : ttimerwrapperinterface;\r
 146   type\r
 147     {$ifdef win32}\r
 148       ttimeval = record\r
 149         tv_sec : longint;\r
 150         tv_usec : longint;\r
 151       end;\r
 152     {$endif}\r
 153     tltimer=class(tlcomponent)\r
 154     protected\r
 155 \r
 156 \r
 157       wrappedtimer : tobject;\r
 158 \r
 159 \r
 160 //      finitialevent       : boolean           ;\r
 161       fontimer            : tnotifyevent      ;\r
 162       fenabled            : boolean           ;\r
 163       finterval           : integer          ; {miliseconds, default 1000}\r
 164       {$ifndef win32}\r
 165         procedure resettimes;\r
 166       {$endif}\r
 167 //      procedure setinitialevent(newvalue : boolean);\r
 168       procedure setontimer(newvalue:tnotifyevent);\r
 169       procedure setenabled(newvalue : boolean);\r
 170       procedure setinterval(newvalue : integer);\r
 171     public\r
 172       //making theese public for now, this code should probablly be restructured later though\r
 173       prevtimer          : tltimer           ;\r
 174       nexttimer          : tltimer           ;\r
 175       nextts             : ttimeval          ;\r
 176 \r
 177       constructor create(aowner:tcomponent);override;\r
 178       destructor destroy;override;\r
 179 //      property initialevent : boolean read finitialevent write setinitialevent;\r
 180       property ontimer : tnotifyevent read fontimer write setontimer;\r
 181       property enabled : boolean read fenabled write setenabled;\r
 182       property interval : integer read finterval write setinterval;\r
 183 \r
 184     end;\r
 185 \r
 186     ttaskevent=procedure(wparam,lparam:longint) of object;\r
 187 \r
 188     tltask=class(tobject)\r
 189     public\r
 190       handler  : ttaskevent;\r
 191       obj      : tobject;\r
 192       wparam   : longint;\r
 193       lparam   : longint;\r
 194       nexttask : tltask;\r
 195       constructor create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
 196     end;\r
 197 \r
 198 \r
 199 \r
 200     teventcore=class\r
 201     public\r
 202       procedure processmessages; virtual;abstract;\r
 203       procedure messageloop; virtual;abstract;\r
 204       procedure exitmessageloop; virtual;abstract;\r
 205       procedure setfdreverse(fd : integer;reverseto : tlasio);virtual;abstract;\r
 206       procedure rmasterset(fd : integer;islistensocket : boolean);  virtual;abstract;\r
 207       procedure rmasterclr(fd: integer);  virtual;abstract;\r
 208       procedure wmasterset(fd : integer); virtual;abstract;\r
 209       procedure wmasterclr(fd: integer);  virtual;abstract;\r
 210     end;\r
 211 var\r
 212     eventcore : teventcore;\r
 213 \r
 214 procedure processmessages;\r
 215 procedure messageloop;\r
 216 procedure exitmessageloop;\r
 217 \r
 218 var\r
 219   firstasin                             : tlasio     ;\r
 220   firsttimer                            : tltimer    ;\r
 221   firsttask  , lasttask   , currenttask : tltask     ;\r
 222 \r
 223   numread                               : integer    ;\r
 224   mustrefreshfds                        : boolean    ;\r
 225 {  lcoretestcount:integer;}\r
 226 \r
 227   asinreleaseflag:boolean;\r
 228 \r
 229 \r
 230 procedure disconnecttasks(aobj:tobject);\r
 231 procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
 232 type\r
 233   tonaddtask = procedure(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
 234 var\r
 235   onaddtask : tonaddtask;\r
 236 \r
 237 \r
 238 procedure sleep(i:integer);\r
 239 {$ifndef nosignal}\r
 240   procedure prepsigpipe;{$ifndef ver1_0}inline;{$endif}\r
 241 {$endif}\r
 242 \r
 243 \r
 244 implementation\r
 245 {$ifndef nosignal}\r
 246   uses {sockets,}lloopback,lsignal;\r
 247 {$endif}\r
 248 {$ifdef win32}\r
 249   uses windows,winsock;\r
 250 {$endif}\r
 251 {$ifndef win32}\r
 252   {$include unixstuff.inc}\r
 253 {$endif}\r
 254 {$include ltimevalstuff.inc}\r
 255 \r
 256 \r
 257 {!!! added sleep call -beware}\r
 258 procedure sleep(i:integer);\r
 259 var\r
 260   tv:ttimeval;\r
 261 begin\r
 262   {$ifdef win32}\r
 263     windows.sleep(i);\r
 264   {$else}\r
 265     tv.tv_sec := i div 1000;\r
 266     tv.tv_usec := (i mod 1000) * 1000;\r
 267     select(0,nil,nil,nil,@tv);\r
 268   {$endif}\r
 269 end;\r
 270 \r
 271 destructor tlcomponent.destroy;\r
 272 begin\r
 273   disconnecttasks(self);\r
 274   inherited destroy;\r
 275 end;\r
 276 \r
 277 \r
 278 \r
 279 \r
 280 procedure tlcomponent.release;\r
 281 begin\r
 282   released := true;\r
 283 end;\r
 284 \r
 285 procedure tlasio.release;\r
 286 begin\r
 287   asinreleaseflag := true;\r
 288   inherited release;\r
 289 end;\r
 290 \r
 291 procedure tlasio.doreceiveloop;\r
 292 begin\r
 293   if recvq.size = 0 then exit;\r
 294   if assigned(ondataavailable) then ondataavailable(self,0);\r
 295   if not (wsonoreceiveloop in componentoptions) then\r
 296   if recvq.size > 0 then tltask.create(self.doreceiveloop,self,0,0);\r
 297 end;\r
 298 \r
 299 function tlasio.receivestr;\r
 300 begin\r
 301   setlength(result,recvq.size);\r
 302   receive(@result[1],length(result));\r
 303 end;\r
 304 \r
 305 function tlasio.receive(Buf:Pointer;BufSize:integer):integer;\r
 306 var\r
 307   i,a,b:integer;\r
 308   p:pointer;\r
 309 begin\r
 310   i := bufsize;\r
 311   if recvq.size < i then i := recvq.size;\r
 312   a := 0;\r
 313   while (a < i) do begin\r
 314     b := recvq.get(p,i-a);\r
 315     move(p^,buf^,b);\r
 316     inc(taddrint(buf),b);\r
 317     recvq.del(b);\r
 318     inc(a,b);\r
 319   end;\r
 320   result := i;\r
 321   if wsonoreceiveloop in componentoptions then begin\r
 322     if recvq.size = 0 then eventcore.rmasterset(fdhandlein,false);\r
 323   end;\r
 324 end;\r
 325 \r
 326 constructor tlasio.create;\r
 327 begin\r
 328   inherited create(AOwner);\r
 329   sendq := tfifo.create;\r
 330   recvq := tfifo.create;\r
 331   state := wsclosed;\r
 332   fdhandlein := -1;\r
 333   fdhandleout := -1;\r
 334   nextasin := firstasin;\r
 335   prevasin := nil;\r
 336   if assigned(nextasin) then nextasin.prevasin := self;\r
 337   firstasin := self;\r
 338 \r
 339   released := false;\r
 340 end;\r
 341 \r
 342 destructor tlasio.destroy;\r
 343 begin\r
 344   destroying := true;\r
 345   if state <> wsclosed then close;\r
 346   if prevasin <> nil then begin\r
 347     prevasin.nextasin := nextasin;\r
 348   end else begin\r
 349     firstasin := nextasin;\r
 350   end;\r
 351   if nextasin <> nil then begin\r
 352     nextasin.prevasin := prevasin;\r
 353   end;\r
 354   recvq.destroy;\r
 355   sendq.destroy;\r
 356   inherited destroy;\r
 357 end;\r
 358 \r
 359 procedure tlasio.close;\r
 360 begin\r
 361   internalclose(0);\r
 362 end;\r
 363 \r
 364 procedure tlasio.abort;\r
 365 begin\r
 366   close;\r
 367 end;\r
 368 \r
 369 procedure tlasio.fdcleanup;\r
 370 begin\r
 371   if fdhandlein <> -1 then begin\r
 372     eventcore.rmasterclr(fdhandlein); //fd_clr(fdhandlein,fdsrmaster)\r
 373   end;\r
 374   if fdhandleout <> -1 then begin\r
 375     eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster)\r
 376   end;\r
 377   if fdhandlein=fdhandleout then begin\r
 378     if fdhandlein <> -1 then begin\r
 379       myfdclose(fdhandlein);\r
 380     end;\r
 381   end else begin\r
 382     if fdhandlein <> -1 then begin\r
 383       myfdclose(fdhandlein);\r
 384     end;\r
 385     if fdhandleout <> -1 then begin\r
 386       myfdclose(fdhandleout);\r
 387     end;\r
 388   end;\r
 389   fdhandlein := -1;\r
 390   fdhandleout := -1;\r
 391 end;\r
 392 \r
 393 procedure tlasio.internalclose(error:word);\r
 394 begin\r
 395   if state<>wsclosed then begin\r
 396     if (fdhandlein < 0) or (fdhandleout < 0) then raise exception.create('internalclose called with invalid fd handles');\r
 397     eventcore.rmasterclr(fdhandlein);//fd_clr(fdhandlein,fdsrmaster);\r
 398     eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster);\r
 399 \r
 400     if closehandles then begin\r
 401       {$ifndef win32}\r
 402         //anyone remember why this is here? --plugwash\r
 403         fcntl(fdhandlein,F_SETFL,0);\r
 404       {$endif}\r
 405       myfdclose(fdhandlein);\r
 406       if fdhandleout <> fdhandlein then begin\r
 407         {$ifndef win32}\r
 408           fcntl(fdhandleout,F_SETFL,0);\r
 409         {$endif}\r
 410         myfdclose(fdhandleout);\r
 411       end;\r
 412       eventcore.setfdreverse(fdhandlein,nil);\r
 413       eventcore.setfdreverse(fdhandleout,nil);\r
 414 \r
 415       fdhandlein := -1;\r
 416       fdhandleout := -1;\r
 417     end;\r
 418     state := wsclosed;\r
 419 \r
 420     if assigned(onsessionclosed) then if not destroying then onsessionclosed(self,error);\r
 421   end;\r
 422   sendq.del(maxlongint);\r
 423 end;\r
 424 \r
 425 \r
 426 {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}\r
 427 { All exceptions *MUST* be handled. If an exception is not handled, the     }\r
 428 { application will most likely be shut down !                               }\r
 429 procedure tlasio.HandleBackGroundException(E: Exception);\r
 430 var\r
 431   CanAbort : Boolean;\r
 432 begin\r
 433   CanAbort := TRUE;\r
 434   { First call the error event handler, if any }\r
 435   if Assigned(OnBgException) then begin\r
 436     try\r
 437       OnBgException(Self, E, CanAbort);\r
 438     except\r
 439     end;\r
 440   end;\r
 441   { Then abort the socket }\r
 442   if CanAbort then begin\r
 443     try\r
 444       close;\r
 445     except\r
 446     end;\r
 447   end;\r
 448 end;\r
 449 \r
 450 procedure tlasio.sendstr(const str : string);\r
 451 begin\r
 452   putstringinsendbuffer(str);\r
 453   sendflush;\r
 454 end;\r
 455 \r
 456 procedure tlasio.putstringinsendbuffer(const newstring : string);\r
 457 begin\r
 458   if newstring <> '' then putdatainsendbuffer(@newstring[1],length(newstring));\r
 459 end;\r
 460 \r
 461 function tlasio.send(data:pointer;len:integer):integer;\r
 462 begin\r
 463   if state <> wsconnected then begin\r
 464     result := -1;\r
 465     exit;\r
 466   end;\r
 467   if len < 0 then len := 0;\r
 468   result := len;\r
 469   putdatainsendbuffer(data,len);\r
 470   sendflush;\r
 471 end;\r
 472 \r
 473 \r
 474 procedure tlasio.putdatainsendbuffer(data:pointer;len:integer);\r
 475 begin\r
 476   sendq.add(data,len);\r
 477 end;\r
 478 \r
 479 function tlasio.sendflush : integer;\r
 480 var\r
 481   lensent : integer;\r
 482   data:pointer;\r
 483 //  fdstestr : fdset;\r
 484 //  fdstestw : fdset;\r
 485 begin\r
 486   if state <> wsconnected then exit;\r
 487 \r
 488   lensent := sendq.get(data,2920);\r
 489   if assigned(data) then result := myfdwrite(fdhandleout,data^,lensent) else result := 0;\r
 490 \r
 491   if result = -1 then lensent := 0 else lensent := result;\r
 492 \r
 493   //sendq := copy(sendq,lensent+1,length(sendq)-lensent);\r
 494   sendq.del(lensent);\r
 495 \r
 496   //fd_clr(fdhandleout,fdsw); // this prevents the socket being closed by a write\r
 497                             // that sends nothing because a previous socket has\r
 498                             // slready flushed this socket when the message loop\r
 499                             // reaches it\r
 500 //  if sendq.size > 0 then begin\r
 501     eventcore.wmasterset(fdhandleout);//fd_set(fdhandleout,fdswmaster);\r
 502 //  end else begin\r
 503 //    wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster);\r
 504 //  end;\r
 505   if result > 0 then begin\r
 506     if assigned(onsenddata) then onsenddata(self,result);\r
 507 //    if sendq.size=0 then if assigned(ondatasent) then begin\r
 508 //      tltask.create(self.dodatasent,self,0,0);\r
 509 //      //begin test code\r
 510 //      fd_zero(fdstestr);\r
 511 //      fd_zero(fdstestw);\r
 512 //      fd_set(fdhandlein,fdstestr);\r
 513 //      fd_set(fdhandleout,fdstestw);\r
 514 //      select(maxs,@fdstestr,@fdstestw,nil,0);\r
 515 //      writeln(fd_isset(fdhandlein,fdstestr),' ',fd_isset(fdhandleout,fdstestw));\r
 516 //      //end test code\r
 517 //    \r
 518 //    end;\r
 519     writtenthiscycle := true;\r
 520   end;\r
 521 end;\r
 522 \r
 523 procedure tlasio.dupnowatch(invalue:longint);\r
 524 begin\r
 525   {  debugout('invalue='+inttostr(invalue));}\r
 526   //readln;\r
 527   if state<> wsclosed then close;\r
 528   fdhandlein := invalue;\r
 529   fdhandleout := invalue;\r
 530   eventcore.setfdreverse(fdhandlein,self);\r
 531   {$ifndef win32}\r
 532     fcntl(fdhandlein,F_SETFL,OPEN_NONBLOCK);\r
 533   {$endif}\r
 534   state := wsconnected;\r
 535 \r
 536 end;\r
 537 \r
 538 \r
 539 procedure tlasio.dup(invalue:longint);\r
 540 begin\r
 541   dupnowatch(invalue);\r
 542   eventcore.rmasterset(fdhandlein,false);//fd_set(fdhandlein,fdsrmaster);\r
 543   eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster);\r
 544 end;\r
 545 \r
 546 \r
 547 procedure tlasio.handlefdtrigger(readtrigger,writetrigger:boolean);\r
 548 var\r
 549   sendflushresult : integer;\r
 550   tempbuf:array[0..receivebufsize-1] of byte;\r
 551 begin\r
 552   if (state=wsconnected) and writetrigger then begin\r
 553     //writeln('write trigger');\r
 554 \r
 555     if (sendq.size >0) then begin\r
 556 \r
 557       sendflushresult := sendflush;\r
 558       if (sendflushresult <= 0) and (not writtenthiscycle) then begin\r
 559         if sendflushresult=0 then begin // linuxerror := 0;\r
 560           internalclose(0);\r
 561 \r
 562         end else begin\r
 563           internalclose({$ifdef win32}getlasterror{$else}linuxerror{$endif});\r
 564         end;\r
 565       end;\r
 566 \r
 567     end else begin\r
 568       //everything is sent fire off ondatasent event\r
 569       if fdhandleout >= 0 then eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster);\r
 570       if assigned(ondatasent) then tltask.create(self.dodatasent,self,0,0);\r
 571     end;\r
 572     if assigned(onfdwrite) then onfdwrite(self,0);\r
 573   end;\r
 574   writtenthiscycle := false;\r
 575   if (state =wsconnected) and readtrigger then begin\r
 576     if recvq.size=0 then begin\r
 577       numread := myfdread(fdhandlein,tempbuf,sizeof(tempbuf));\r
 578       if (numread=0) and (not mustrefreshfds) then begin\r
 579         {if i remember correctly numread=0 is caused by eof\r
 580         if this isn't dealt with then you get a cpu eating infinite loop\r
 581         however if onsessionconencted has called processmessages that could\r
 582         cause us to drop to here with an empty recvq and nothing left to read\r
 583         and we don't want that to cause the socket to close}\r
 584 \r
 585         internalclose(0);\r
 586       end else if (numread=-1) then begin\r
 587         {$ifdef win32}\r
 588           //sometimes on windows we get stale messages due to the inherent delays\r
 589           //in the windows message queue\r
 590           if WSAGetLastError = wsaewouldblock then begin\r
 591             //do nothing\r
 592           end else\r
 593         {$endif}\r
 594         begin\r
 595           numread := 0;\r
 596           internalclose({$ifdef win32}wsagetlasterror{$else}linuxerror{$endif});\r
 597         end;\r
 598       end else if numread > 0 then recvq.add(@tempbuf,numread);\r
 599     end;\r
 600 \r
 601     if recvq.size > 0 then begin\r
 602       if wsonoreceiveloop in componentoptions then eventcore.rmasterclr(fdhandlein); //fd_clr(fdhandlein,fdsrmaster);\r
 603       if assigned(ondataavailable) then ondataAvailable(self,0);\r
 604       if not (wsonoreceiveloop in componentoptions) then if recvq.size > 0 then\r
 605       tltask.create(self.doreceiveloop,self,0,0);\r
 606     end;\r
 607     //until (numread = 0) or (currentsocket.state<>wsconnected);\r
 608 {    debugout('inner loop complete');}\r
 609   end;\r
 610 end;\r
 611 \r
 612 {$ifndef win32}\r
 613   procedure tlasio.flush;\r
 614   var\r
 615     fds : fdset;\r
 616   begin\r
 617     fd_zero(fds);\r
 618     fd_set(fdhandleout,fds);\r
 619     while sendq.size>0 do begin\r
 620       select(fdhandleout+1,nil,@fds,nil,nil);\r
 621       if sendflush <= 0 then exit;\r
 622     end;\r
 623   end;\r
 624 {$endif}\r
 625 \r
 626 procedure tlasio.dodatasent(wparam,lparam:longint);\r
 627 begin\r
 628   if assigned(ondatasent) then ondatasent(self,lparam);\r
 629 end;\r
 630 \r
 631 procedure tlasio.deletebuffereddata;\r
 632 begin\r
 633   sendq.del(maxlongint);\r
 634 end;\r
 635 \r
 636 procedure tlasio.sinkdata(sender:tobject;error:word);\r
 637 begin\r
 638   tlasio(sender).recvq.del(maxlongint);\r
 639 end;\r
 640 \r
 641 {$ifndef win32}\r
 642   procedure tltimer.resettimes;\r
 643   begin\r
 644     gettimeofday(nextts);\r
 645     {if not initialevent then} tv_add(nextts,interval);\r
 646   end;\r
 647 {$endif}\r
 648 \r
 649 {procedure tltimer.setinitialevent(newvalue : boolean);\r
 650 begin\r
 651   if newvalue <> finitialevent then begin\r
 652     finitialevent := newvalue;\r
 653     if assigned(timerwrapperinterface) then begin\r
 654       timerwrapperinterface.setinitialevent(wrappedtimer,newvalue);\r
 655     end else begin\r
 656       resettimes;\r
 657     end;\r
 658   end;\r
 659 end;}\r
 660 \r
 661 procedure tltimer.setontimer(newvalue:tnotifyevent);\r
 662 begin\r
 663   if @newvalue <> @fontimer then begin\r
 664     fontimer := newvalue;\r
 665     if assigned(timerwrapperinterface) then begin\r
 666       timerwrapperinterface.setontimer(wrappedtimer,newvalue);\r
 667     end else begin\r
 668 \r
 669     end;\r
 670   end;\r
 671 \r
 672 end;\r
 673 \r
 674 \r
 675 procedure tltimer.setenabled(newvalue : boolean);\r
 676 begin\r
 677   if newvalue <> fenabled then begin\r
 678     fenabled := newvalue;\r
 679     if assigned(timerwrapperinterface) then begin\r
 680       timerwrapperinterface.setenabled(wrappedtimer,newvalue);\r
 681     end else begin\r
 682       {$ifdef win32}\r
 683         raise exception.create('non wrapper timers are not permitted on windows');\r
 684       {$else}\r
 685         resettimes;\r
 686       {$endif}\r
 687     end;\r
 688   end;\r
 689 end;\r
 690 \r
 691 procedure tltimer.setinterval(newvalue:integer);\r
 692 begin\r
 693   if newvalue <> finterval then begin\r
 694     finterval := newvalue;\r
 695     if assigned(timerwrapperinterface) then begin\r
 696       timerwrapperinterface.setinterval(wrappedtimer,newvalue);\r
 697     end else begin\r
 698       {$ifdef win32}\r
 699         raise exception.create('non wrapper timers are not permitted on windows');\r
 700       {$else}\r
 701         resettimes;\r
 702       {$endif}\r
 703     end;\r
 704   end;\r
 705 \r
 706 end;\r
 707 \r
 708 \r
 709 \r
 710 \r
 711 constructor tltimer.create;\r
 712 begin\r
 713   inherited create(AOwner);\r
 714   if assigned(timerwrapperinterface) then begin\r
 715     wrappedtimer := timerwrapperinterface.createwrappedtimer;\r
 716   end else begin\r
 717 \r
 718 \r
 719     nexttimer := firsttimer;\r
 720     prevtimer := nil;\r
 721 \r
 722     if assigned(nexttimer) then nexttimer.prevtimer := self;\r
 723     firsttimer := self;\r
 724   end;\r
 725   interval := 1000;\r
 726   enabled := true;\r
 727   released := false;\r
 728 \r
 729 end;\r
 730 \r
 731 destructor tltimer.destroy;\r
 732 begin\r
 733   if assigned(timerwrapperinterface) then begin\r
 734     wrappedtimer.free;\r
 735   end else begin\r
 736     if prevtimer <> nil then begin\r
 737       prevtimer.nexttimer := nexttimer;\r
 738     end else begin\r
 739       firsttimer := nexttimer;\r
 740     end;\r
 741     if nexttimer <> nil then begin\r
 742       nexttimer.prevtimer := prevtimer;\r
 743     end;\r
 744     \r
 745   end;\r
 746   inherited destroy;\r
 747 end;\r
 748 \r
 749 constructor tltask.create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
 750 begin\r
 751   inherited create;\r
 752   if assigned(onaddtask) then onaddtask(ahandler,aobj,awparam,alparam);\r
 753   handler   := ahandler;\r
 754   obj       := aobj;\r
 755   wparam    := awparam;\r
 756   lparam    := alparam;\r
 757   {nexttask  := firsttask;\r
 758   firsttask := self;}\r
 759   if assigned(lasttask) then begin\r
 760     lasttask.nexttask := self;\r
 761   end else begin\r
 762     firsttask := self;\r
 763   end;\r
 764   lasttask := self;\r
 765   //ahandler(wparam,lparam);\r
 766 end;\r
 767 \r
 768 procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
 769 begin\r
 770 \r
 771   tltask.create(ahandler,aobj,awparam,alparam);\r
 772 end;\r
 773 \r
 774 {$ifndef nosignal}\r
 775   procedure prepsigpipe;{$ifndef ver1_0}inline;\r
 776 {$endif}\r
 777   begin\r
 778     starthandlesignal(sigpipe);\r
 779     if not assigned(signalloopback) then begin\r
 780       signalloopback := tlloopback.create(nil);\r
 781       signalloopback.ondataAvailable := signalloopback.sinkdata;\r
 782 \r
 783     end;\r
 784 \r
 785   end;\r
 786 {$endif}\r
 787 \r
 788 procedure processtasks;//inline;\r
 789 var\r
 790   temptask                : tltask   ;\r
 791 \r
 792 begin\r
 793 \r
 794   if not assigned(currenttask) then begin\r
 795     currenttask := firsttask;\r
 796     firsttask := nil;\r
 797     lasttask  := nil;\r
 798   end;\r
 799   while assigned(currenttask) do begin\r
 800 \r
 801     if assigned(currenttask.handler) then currenttask.handler(currenttask.wparam,currenttask.lparam);\r
 802     if assigned(currenttask) then begin\r
 803       temptask := currenttask;\r
 804       currenttask := currenttask.nexttask;\r
 805       temptask.free;\r
 806     end;\r
 807     //writeln('processed a task');\r
 808   end;\r
 809 \r
 810 end;\r
 811 \r
 812 \r
 813 \r
 814 \r
 815 procedure disconnecttasks(aobj:tobject);\r
 816 var\r
 817   currenttasklocal : tltask ;\r
 818   counter          : byte   ;\r
 819 begin\r
 820   for counter := 0 to 1 do begin\r
 821     if counter = 0 then begin\r
 822       currenttasklocal := firsttask; //main list of tasks\r
 823     end else begin\r
 824       currenttasklocal := currenttask; //needed in case called from a task\r
 825     end;\r
 826     // note i don't bother to sestroy the links here as that will happen when\r
 827     // the list of tasks is processed anyway\r
 828     while assigned(currenttasklocal) do begin\r
 829       if currenttasklocal.obj = aobj then begin\r
 830         currenttasklocal.obj := nil;\r
 831         currenttasklocal.handler := nil;\r
 832       end;\r
 833       currenttasklocal := currenttasklocal.nexttask;\r
 834     end;\r
 835   end;\r
 836 end;\r
 837 \r
 838 \r
 839 procedure processmessages;\r
 840 begin\r
 841   eventcore.processmessages;\r
 842 end;\r
 843 procedure messageloop;\r
 844 begin\r
 845   eventcore.messageloop;\r
 846 end;\r
 847 \r
 848 procedure exitmessageloop;\r
 849 begin\r
 850   eventcore.exitmessageloop;\r
 851 end;\r
 852 \r
 853 function tlasio.RealSend(Data : Pointer; Len : Integer) : Integer;\r
 854 begin\r
 855   result := myfdwrite(fdhandleout,data^,len);\r
 856   if (result > 0) and assigned(onsenddata) then onsenddata(self,result);\r
 857   eventcore.wmasterset(fdhandleout);\r
 858 end;\r
 859 {$ifndef win32}\r
 860   procedure tlasio.myfdclose(fd : integer);\r
 861   begin\r
 862     fdclose(fd);\r
 863   end;\r
 864   function tlasio.myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt;\r
 865   begin\r
 866     result := fdwrite(fd,buf,size);\r
 867   end;\r
 868 \r
 869   function tlasio.myfdread(fd: LongInt;var buf;size: LongInt):LongInt;\r
 870   begin\r
 871     result := fdread(fd,buf,size);\r
 872   end;\r
 873 \r
 874 \r
 875 {$endif}\r
 876 \r
 877 \r
 878 begin\r
 879   firstasin := nil;\r
 880   firsttask := nil;\r
 881   \r
 882 \r
 883   {$ifndef nosignal}\r
 884     signalloopback := nil;\r
 885   {$endif}\r
 886 end.\r
 887 \r
 888 \r
 889 \r
 890 \r
 891 \r