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