lcore.pas

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