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