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