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