lcore.pas

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