lcore.pas

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