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           internalclose({$ifdef win32}getlasterror{$else}linuxerror{$endif});\r
 577         end;\r
 578       end;\r
 579 \r
 580     end else begin\r
 581       //everything is sent fire off ondatasent event\r
 582       if fdhandleout >= 0 then eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster);\r
 583       if assigned(ondatasent) then tltask.create(self.dodatasent,self,0,0);\r
 584     end;\r
 585     if assigned(onfdwrite) then onfdwrite(self,0);\r
 586   end;\r
 587   writtenthiscycle := false;\r
 588   if (state =wsconnected) and readtrigger then begin\r
 589     if recvq.size=0 then begin\r
 590       a := recvbufsize;\r
 591       if (a <= 0) or (a > sizeof(tempbuf)) then a := sizeof(tempbuf);\r
 592       numread := myfdread(fdhandlein,tempbuf,a);\r
 593       if (numread=0) and (not mustrefreshfds) then begin\r
 594         {if i remember correctly numread=0 is caused by eof\r
 595         if this isn't dealt with then you get a cpu eating infinite loop\r
 596         however if onsessionconencted has called processmessages that could\r
 597         cause us to drop to here with an empty recvq and nothing left to read\r
 598         and we don't want that to cause the socket to close}\r
 599 \r
 600         internalclose(0);\r
 601       end else if (numread=-1) then begin\r
 602         {$ifdef win32}\r
 603           //sometimes on windows we get stale messages due to the inherent delays\r
 604           //in the windows message queue\r
 605           if WSAGetLastError = wsaewouldblock then begin\r
 606             //do nothing\r
 607           end else\r
 608         {$endif}\r
 609         begin\r
 610           numread := 0;\r
 611           internalclose({$ifdef win32}wsagetlasterror{$else}linuxerror{$endif});\r
 612         end;\r
 613       end else if numread > 0 then recvq.add(@tempbuf,numread);\r
 614     end;\r
 615 \r
 616     if recvq.size > 0 then begin\r
 617       if wsonoreceiveloop in componentoptions then eventcore.rmasterclr(fdhandlein); //fd_clr(fdhandlein,fdsrmaster);\r
 618       if assigned(ondataavailable) then ondataAvailable(self,0);\r
 619       if not (wsonoreceiveloop in componentoptions) then if recvq.size > 0 then\r
 620       tltask.create(self.doreceiveloop,self,0,0);\r
 621     end;\r
 622     //until (numread = 0) or (currentsocket.state<>wsconnected);\r
 623 {    debugout('inner loop complete');}\r
 624   end;\r
 625 end;\r
 626 \r
 627 procedure tlasio.flush;\r
 628 {$ifdef win32}\r
 629 type fdset = tfdset;\r
 630 {$endif}\r
 631 var\r
 632   fds : fdset;\r
 633 begin\r
 634   fd_zero(fds);\r
 635   fd_set(fdhandleout,fds);\r
 636   while sendq.size>0 do begin\r
 637     select(fdhandleout+1,nil,@fds,nil,nil);\r
 638     if sendflush <= 0 then exit;\r
 639   end;\r
 640 end;\r
 641 \r
 642 procedure tlasio.dodatasent(wparam,lparam:longint);\r
 643 begin\r
 644   if assigned(ondatasent) then ondatasent(self,lparam);\r
 645 end;\r
 646 \r
 647 procedure tlasio.deletebuffereddata;\r
 648 begin\r
 649   sendq.del(maxlongint);\r
 650 end;\r
 651 \r
 652 procedure tlasio.sinkdata(sender:tobject;error:word);\r
 653 begin\r
 654   tlasio(sender).recvq.del(maxlongint);\r
 655 end;\r
 656 \r
 657 {$ifndef win32}\r
 658   procedure tltimer.resettimes;\r
 659   begin\r
 660     gettimeofday(nextts);\r
 661     {if not initialevent then} tv_add(nextts,interval);\r
 662   end;\r
 663 {$endif}\r
 664 \r
 665 {procedure tltimer.setinitialevent(newvalue : boolean);\r
 666 begin\r
 667   if newvalue <> finitialevent then begin\r
 668     finitialevent := newvalue;\r
 669     if assigned(timerwrapperinterface) then begin\r
 670       timerwrapperinterface.setinitialevent(wrappedtimer,newvalue);\r
 671     end else begin\r
 672       resettimes;\r
 673     end;\r
 674   end;\r
 675 end;}\r
 676 \r
 677 procedure tltimer.setontimer(newvalue:tnotifyevent);\r
 678 begin\r
 679   if @newvalue <> @fontimer then begin\r
 680     fontimer := newvalue;\r
 681     if assigned(timerwrapperinterface) then begin\r
 682       timerwrapperinterface.setontimer(wrappedtimer,newvalue);\r
 683     end else begin\r
 684 \r
 685     end;\r
 686   end;\r
 687 \r
 688 end;\r
 689 \r
 690 \r
 691 procedure tltimer.setenabled(newvalue : boolean);\r
 692 begin\r
 693   if newvalue <> fenabled then begin\r
 694     fenabled := newvalue;\r
 695     if assigned(timerwrapperinterface) then begin\r
 696       timerwrapperinterface.setenabled(wrappedtimer,newvalue);\r
 697     end else begin\r
 698       {$ifdef win32}\r
 699         raise exception.create('non wrapper timers are not permitted on windows');\r
 700       {$else}\r
 701         resettimes;\r
 702       {$endif}\r
 703     end;\r
 704   end;\r
 705 end;\r
 706 \r
 707 procedure tltimer.setinterval(newvalue:integer);\r
 708 begin\r
 709   if newvalue <> finterval then begin\r
 710     finterval := newvalue;\r
 711     if assigned(timerwrapperinterface) then begin\r
 712       timerwrapperinterface.setinterval(wrappedtimer,newvalue);\r
 713     end else begin\r
 714       {$ifdef win32}\r
 715         raise exception.create('non wrapper timers are not permitted on windows');\r
 716       {$else}\r
 717         resettimes;\r
 718       {$endif}\r
 719     end;\r
 720   end;\r
 721 \r
 722 end;\r
 723 \r
 724 \r
 725 \r
 726 \r
 727 constructor tltimer.create;\r
 728 begin\r
 729   inherited create(AOwner);\r
 730   if assigned(timerwrapperinterface) then begin\r
 731     wrappedtimer := timerwrapperinterface.createwrappedtimer;\r
 732   end else begin\r
 733 \r
 734 \r
 735     nexttimer := firsttimer;\r
 736     prevtimer := nil;\r
 737 \r
 738     if assigned(nexttimer) then nexttimer.prevtimer := self;\r
 739     firsttimer := self;\r
 740   end;\r
 741   interval := 1000;\r
 742   enabled := true;\r
 743   released := false;\r
 744 \r
 745 end;\r
 746 \r
 747 destructor tltimer.destroy;\r
 748 begin\r
 749   if assigned(timerwrapperinterface) then begin\r
 750     wrappedtimer.free;\r
 751   end else begin\r
 752     if prevtimer <> nil then begin\r
 753       prevtimer.nexttimer := nexttimer;\r
 754     end else begin\r
 755       firsttimer := nexttimer;\r
 756     end;\r
 757     if nexttimer <> nil then begin\r
 758       nexttimer.prevtimer := prevtimer;\r
 759     end;\r
 760     \r
 761   end;\r
 762   inherited destroy;\r
 763 end;\r
 764 \r
 765 constructor tltask.create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
 766 begin\r
 767   inherited create;\r
 768   if assigned(onaddtask) then onaddtask(ahandler,aobj,awparam,alparam);\r
 769   handler   := ahandler;\r
 770   obj       := aobj;\r
 771   wparam    := awparam;\r
 772   lparam    := alparam;\r
 773   {nexttask  := firsttask;\r
 774   firsttask := self;}\r
 775   if assigned(lasttask) then begin\r
 776     lasttask.nexttask := self;\r
 777   end else begin\r
 778     firsttask := self;\r
 779   end;\r
 780   lasttask := self;\r
 781   //ahandler(wparam,lparam);\r
 782 end;\r
 783 \r
 784 procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
 785 begin\r
 786 \r
 787   tltask.create(ahandler,aobj,awparam,alparam);\r
 788 end;\r
 789 \r
 790 {$ifndef nosignal}\r
 791   procedure prepsigpipe;{$ifndef ver1_0}inline;\r
 792 {$endif}\r
 793   begin\r
 794     starthandlesignal(sigpipe);\r
 795     if not assigned(signalloopback) then begin\r
 796       signalloopback := tlloopback.create(nil);\r
 797       signalloopback.ondataAvailable := signalloopback.sinkdata;\r
 798 \r
 799     end;\r
 800 \r
 801   end;\r
 802 {$endif}\r
 803 \r
 804 procedure processtasks;//inline;\r
 805 var\r
 806   temptask                : tltask   ;\r
 807 \r
 808 begin\r
 809 \r
 810   if not assigned(currenttask) then begin\r
 811     currenttask := firsttask;\r
 812     firsttask := nil;\r
 813     lasttask  := nil;\r
 814   end;\r
 815   while assigned(currenttask) do begin\r
 816 \r
 817     if assigned(currenttask.handler) then currenttask.handler(currenttask.wparam,currenttask.lparam);\r
 818     if assigned(currenttask) then begin\r
 819       temptask := currenttask;\r
 820       currenttask := currenttask.nexttask;\r
 821       temptask.free;\r
 822     end;\r
 823     //writeln('processed a task');\r
 824   end;\r
 825 \r
 826 end;\r
 827 \r
 828 \r
 829 \r
 830 \r
 831 procedure disconnecttasks(aobj:tobject);\r
 832 var\r
 833   currenttasklocal : tltask ;\r
 834   counter          : byte   ;\r
 835 begin\r
 836   for counter := 0 to 1 do begin\r
 837     if counter = 0 then begin\r
 838       currenttasklocal := firsttask; //main list of tasks\r
 839     end else begin\r
 840       currenttasklocal := currenttask; //needed in case called from a task\r
 841     end;\r
 842     // note i don't bother to sestroy the links here as that will happen when\r
 843     // the list of tasks is processed anyway\r
 844     while assigned(currenttasklocal) do begin\r
 845       if currenttasklocal.obj = aobj then begin\r
 846         currenttasklocal.obj := nil;\r
 847         currenttasklocal.handler := nil;\r
 848       end;\r
 849       currenttasklocal := currenttasklocal.nexttask;\r
 850     end;\r
 851   end;\r
 852 end;\r
 853 \r
 854 \r
 855 procedure processmessages;\r
 856 begin\r
 857   eventcore.processmessages;\r
 858 end;\r
 859 procedure messageloop;\r
 860 begin\r
 861   eventcore.messageloop;\r
 862 end;\r
 863 \r
 864 procedure exitmessageloop;\r
 865 begin\r
 866   eventcore.exitmessageloop;\r
 867 end;\r
 868 \r
 869 function tlasio.RealSend(Data : Pointer; Len : Integer) : Integer;\r
 870 begin\r
 871   result := myfdwrite(fdhandleout,data^,len);\r
 872   if (result > 0) and assigned(onsenddata) then onsenddata(self,result);\r
 873   eventcore.wmasterset(fdhandleout);\r
 874 end;\r
 875 {$ifndef win32}\r
 876   procedure tlasio.myfdclose(fd : integer);\r
 877   begin\r
 878     fdclose(fd);\r
 879   end;\r
 880   function tlasio.myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt;\r
 881   begin\r
 882     result := fdwrite(fd,buf,size);\r
 883   end;\r
 884 \r
 885   function tlasio.myfdread(fd: LongInt;var buf;size: LongInt):LongInt;\r
 886   begin\r
 887     result := fdread(fd,buf,size);\r
 888   end;\r
 889 \r
 890 \r
 891 {$endif}\r
 892 \r
 893 \r
 894 begin\r
 895   firstasin := nil;\r
 896   firsttask := nil;\r
 897   \r
 898 \r
 899   {$ifndef nosignal}\r
 900     signalloopback := nil;\r
 901   {$endif}\r
 902 end.\r
 903 \r
 904 \r
 905 \r
 906 \r
 907 \r