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