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