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