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