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