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