httpserver_20080306/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,\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 \r
  38 \r
  39 \r
  40 \r
  41 \r
  42   const\r
  43     receivebufsize=1460;\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       function receivestr:string; virtual;\r
 105       procedure close;\r
 106       procedure abort;\r
 107       procedure internalclose(error:word); virtual;\r
 108       constructor Create(AOwner: TComponent); override;\r
 109 \r
 110       destructor destroy; override;\r
 111       procedure fdcleanup;\r
 112       procedure HandleBackGroundException(E: Exception);\r
 113       procedure handlefdtrigger(readtrigger,writetrigger:boolean); virtual;\r
 114       procedure dup(invalue:longint);\r
 115 \r
 116       function sendflush : integer;\r
 117       procedure sendstr(const str : string);virtual;\r
 118       procedure putstringinsendbuffer(const newstring : string);\r
 119       function send(data:pointer;len:integer):integer;virtual;\r
 120       procedure putdatainsendbuffer(data:pointer;len:integer); virtual;\r
 121       procedure deletebuffereddata;\r
 122 \r
 123       //procedure messageloop;\r
 124       function Receive(Buf:Pointer;BufSize:integer):integer; virtual;\r
 125       procedure flush;virtual;{$ifdef win32} abstract;{$endif}\r
 126       procedure dodatasent(wparam,lparam:longint);\r
 127       procedure doreceiveloop(wparam,lparam:longint);\r
 128       procedure sinkdata(sender:tobject;error:word);\r
 129 \r
 130       procedure release; override; {test -beware}\r
 131 \r
 132       function RealSend(Data : Pointer; Len : Integer) : Integer; //added for bewarehttpd\r
 133 \r
 134       procedure myfdclose(fd : integer); virtual;{$ifdef win32}abstract;{$endif}\r
 135       function myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt; virtual;{$ifdef win32}abstract;{$endif}\r
 136       function myfdread(fd: LongInt;var buf;size: LongInt):LongInt; virtual;{$ifdef win32}abstract;{$endif}\r
 137     protected\r
 138       procedure dupnowatch(invalue:longint);\r
 139     end;\r
 140     ttimerwrapperinterface=class(tlcomponent)\r
 141     public\r
 142       function createwrappedtimer : tobject;virtual;abstract;\r
 143 //      procedure setinitialevent(wrappedtimer : tobject;newvalue : boolean);virtual;abstract;\r
 144       procedure setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);virtual;abstract;\r
 145       procedure setenabled(wrappedtimer : tobject;newvalue : boolean);virtual;abstract;\r
 146       procedure setinterval(wrappedtimer : tobject;newvalue : integer);virtual;abstract;\r
 147     end;\r
 148 \r
 149   var\r
 150     timerwrapperinterface : ttimerwrapperinterface;\r
 151   type\r
 152     {$ifdef win32}\r
 153       ttimeval = record\r
 154         tv_sec : longint;\r
 155         tv_usec : longint;\r
 156       end;\r
 157     {$endif}\r
 158     tltimer=class(tlcomponent)\r
 159     protected\r
 160 \r
 161 \r
 162       wrappedtimer : tobject;\r
 163 \r
 164 \r
 165 //      finitialevent       : boolean           ;\r
 166       fontimer            : tnotifyevent      ;\r
 167       fenabled            : boolean           ;\r
 168       finterval           : integer          ; {miliseconds, default 1000}\r
 169       {$ifndef win32}\r
 170         procedure resettimes;\r
 171       {$endif}\r
 172 //      procedure setinitialevent(newvalue : boolean);\r
 173       procedure setontimer(newvalue:tnotifyevent);\r
 174       procedure setenabled(newvalue : boolean);\r
 175       procedure setinterval(newvalue : integer);\r
 176     public\r
 177       //making theese public for now, this code should probablly be restructured later though\r
 178       prevtimer          : tltimer           ;\r
 179       nexttimer          : tltimer           ;\r
 180       nextts             : ttimeval          ;\r
 181 \r
 182       constructor create(aowner:tcomponent);override;\r
 183       destructor destroy;override;\r
 184 //      property initialevent : boolean read finitialevent write setinitialevent;\r
 185       property ontimer : tnotifyevent read fontimer write setontimer;\r
 186       property enabled : boolean read fenabled write setenabled;\r
 187       property interval : integer read finterval write setinterval;\r
 188 \r
 189     end;\r
 190 \r
 191     ttaskevent=procedure(wparam,lparam:longint) of object;\r
 192 \r
 193     tltask=class(tobject)\r
 194     public\r
 195       handler  : ttaskevent;\r
 196       obj      : tobject;\r
 197       wparam   : longint;\r
 198       lparam   : longint;\r
 199       nexttask : tltask;\r
 200       constructor create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
 201     end;\r
 202 \r
 203 \r
 204 \r
 205     teventcore=class\r
 206     public\r
 207       procedure processmessages; virtual;abstract;\r
 208       procedure messageloop; virtual;abstract;\r
 209       procedure exitmessageloop; virtual;abstract;\r
 210       procedure setfdreverse(fd : integer;reverseto : tlasio);virtual;abstract;\r
 211       procedure rmasterset(fd : integer;islistensocket : boolean);  virtual;abstract;\r
 212       procedure rmasterclr(fd: integer);  virtual;abstract;\r
 213       procedure wmasterset(fd : integer); virtual;abstract;\r
 214       procedure wmasterclr(fd: integer);  virtual;abstract;\r
 215     end;\r
 216 var\r
 217     eventcore : teventcore;\r
 218 \r
 219 procedure processmessages;\r
 220 procedure messageloop;\r
 221 procedure exitmessageloop;\r
 222 \r
 223 var\r
 224   firstasin                             : tlasio     ;\r
 225   firsttimer                            : tltimer    ;\r
 226   firsttask  , lasttask   , currenttask : tltask     ;\r
 227 \r
 228   numread                               : integer    ;\r
 229   mustrefreshfds                        : boolean    ;\r
 230 {  lcoretestcount:integer;}\r
 231 \r
 232   asinreleaseflag:boolean;\r
 233 \r
 234 \r
 235 procedure disconnecttasks(aobj:tobject);\r
 236 procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
 237 type\r
 238   tonaddtask = procedure(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
 239 var\r
 240   onaddtask : tonaddtask;\r
 241 \r
 242 \r
 243 procedure sleep(i:integer);\r
 244 {$ifndef nosignal}\r
 245   procedure prepsigpipe;inline;\r
 246 {$endif}\r
 247 \r
 248 \r
 249 implementation\r
 250 {$ifndef nosignal}\r
 251   uses {sockets,}lloopback,lsignal;\r
 252 {$endif}\r
 253 {$ifdef win32}\r
 254   uses windows;\r
 255 {$endif}\r
 256 {$ifndef win32}\r
 257   {$include unixstuff.inc}\r
 258 {$endif}\r
 259 {$include ltimevalstuff.inc}\r
 260 \r
 261 \r
 262 {!!! added sleep call -beware}\r
 263 procedure sleep(i:integer);\r
 264 var\r
 265   tv:ttimeval;\r
 266 begin\r
 267   {$ifdef win32}\r
 268     windows.sleep(i);\r
 269   {$else}\r
 270     tv.tv_sec := i div 1000;\r
 271     tv.tv_usec := (i mod 1000) * 1000;\r
 272     select(0,nil,nil,nil,@tv);\r
 273   {$endif}\r
 274 end;\r
 275 \r
 276 destructor tlcomponent.destroy;\r
 277 begin\r
 278   disconnecttasks(self);\r
 279   inherited destroy;\r
 280 end;\r
 281 \r
 282 \r
 283 \r
 284 \r
 285 procedure tlcomponent.release;\r
 286 begin\r
 287   released := true;\r
 288 end;\r
 289 \r
 290 procedure tlasio.release;\r
 291 begin\r
 292   asinreleaseflag := true;\r
 293   inherited release;\r
 294 end;\r
 295 \r
 296 procedure tlasio.doreceiveloop;\r
 297 begin\r
 298   if recvq.size = 0 then exit;\r
 299   if assigned(ondataavailable) then ondataavailable(self,0);\r
 300   if not (wsonoreceiveloop in componentoptions) then\r
 301   if recvq.size > 0 then tltask.create(self.doreceiveloop,self,0,0);\r
 302 end;\r
 303 \r
 304 function tlasio.receivestr;\r
 305 begin\r
 306   setlength(result,recvq.size);\r
 307   receive(@result[1],length(result));\r
 308 end;\r
 309 \r
 310 function tlasio.receive(Buf:Pointer;BufSize:integer):integer;\r
 311 var\r
 312   i,a,b:integer;\r
 313   p:pointer;\r
 314 begin\r
 315   i := bufsize;\r
 316   if recvq.size < i then i := recvq.size;\r
 317   a := 0;\r
 318   while (a < i) do begin\r
 319     b := recvq.get(p,i-a);\r
 320     move(p^,buf^,b);\r
 321     inc(taddrint(buf),b);\r
 322     recvq.del(b);\r
 323     inc(a,b);\r
 324   end;\r
 325   result := i;\r
 326   if wsonoreceiveloop in componentoptions then begin\r
 327     if recvq.size = 0 then eventcore.rmasterset(fdhandlein,false);\r
 328   end;\r
 329 end;\r
 330 \r
 331 constructor tlasio.create;\r
 332 begin\r
 333   inherited create(AOwner);\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.destroy;\r
 360   sendq.destroy;\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 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   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 begin\r
 557   if (state=wsconnected) and writetrigger then begin\r
 558     //writeln('write trigger');\r
 559 \r
 560     if (sendq.size >0) then begin\r
 561 \r
 562       sendflushresult := sendflush;\r
 563       if (sendflushresult <= 0) and (not writtenthiscycle) then begin\r
 564         if sendflushresult=0 then begin // linuxerror := 0;\r
 565           internalclose(0);\r
 566 \r
 567         end else begin\r
 568           internalclose({$ifdef win32}getlasterror{$else}linuxerror{$endif});\r
 569         end;\r
 570       end;\r
 571 \r
 572     end else begin\r
 573       //everything is sent fire off ondatasent event\r
 574       if fdhandleout >= 0 then eventcore.wmasterclr(fdhandleout);//fd_clr(fdhandleout,fdswmaster);\r
 575       if assigned(ondatasent) then tltask.create(self.dodatasent,self,0,0);\r
 576     end;\r
 577     if assigned(onfdwrite) then onfdwrite(self,0);\r
 578   end;\r
 579   writtenthiscycle := false;\r
 580   if (state =wsconnected) and readtrigger then begin\r
 581     if recvq.size=0 then begin\r
 582       numread := myfdread(fdhandlein,tempbuf,sizeof(tempbuf));\r
 583       if (numread=0) and (not mustrefreshfds) then begin\r
 584         {if i remember correctly numread=0 is caused by eof\r
 585         if this isn't dealt with then you get a cpu eating infinite loop\r
 586         however if onsessionconencted has called processmessages that could\r
 587         cause us to drop to here with an empty recvq and nothing left to read\r
 588         and we don't want that to cause the socket to close}\r
 589 \r
 590         internalclose(0);\r
 591       end else if (numread=-1) then begin\r
 592         numread := 0;\r
 593         internalclose({$ifdef win32}getlasterror{$else}linuxerror{$endif});\r
 594       end else if numread > 0 then recvq.add(@tempbuf,numread);\r
 595     end;\r
 596 \r
 597     if recvq.size > 0 then begin\r
 598       if wsonoreceiveloop in componentoptions then eventcore.rmasterclr(fdhandlein); //fd_clr(fdhandlein,fdsrmaster);\r
 599       if assigned(ondataavailable) then ondataAvailable(self,0);\r
 600       if not (wsonoreceiveloop in componentoptions) then if recvq.size > 0 then\r
 601       tltask.create(self.doreceiveloop,self,0,0);\r
 602     end;\r
 603     //until (numread = 0) or (currentsocket.state<>wsconnected);\r
 604 {    debugout('inner loop complete');}\r
 605   end;\r
 606 end;\r
 607 \r
 608 {$ifndef win32}\r
 609   procedure tlasio.flush;\r
 610   var\r
 611     fds : fdset;\r
 612   begin\r
 613     fd_zero(fds);\r
 614     fd_set(fdhandleout,fds);\r
 615     while sendq.size>0 do begin\r
 616       select(fdhandleout+1,nil,@fds,nil,nil);\r
 617       if sendflush <= 0 then exit;\r
 618     end;\r
 619   end;\r
 620 {$endif}\r
 621 \r
 622 procedure tlasio.dodatasent(wparam,lparam:longint);\r
 623 begin\r
 624   if assigned(ondatasent) then ondatasent(self,lparam);\r
 625 end;\r
 626 \r
 627 procedure tlasio.deletebuffereddata;\r
 628 begin\r
 629   sendq.del(maxlongint);\r
 630 end;\r
 631 \r
 632 procedure tlasio.sinkdata(sender:tobject;error:word);\r
 633 begin\r
 634   tlasio(sender).recvq.del(maxlongint);\r
 635 end;\r
 636 \r
 637 {$ifndef win32}\r
 638   procedure tltimer.resettimes;\r
 639   begin\r
 640     gettimeofday(nextts);\r
 641     {if not initialevent then} tv_add(nextts,interval);\r
 642   end;\r
 643 {$endif}\r
 644 \r
 645 {procedure tltimer.setinitialevent(newvalue : boolean);\r
 646 begin\r
 647   if newvalue <> finitialevent then begin\r
 648     finitialevent := newvalue;\r
 649     if assigned(timerwrapperinterface) then begin\r
 650       timerwrapperinterface.setinitialevent(wrappedtimer,newvalue);\r
 651     end else begin\r
 652       resettimes;\r
 653     end;\r
 654   end;\r
 655 end;}\r
 656 \r
 657 procedure tltimer.setontimer(newvalue:tnotifyevent);\r
 658 begin\r
 659   if @newvalue <> @fontimer then begin\r
 660     fontimer := newvalue;\r
 661     if assigned(timerwrapperinterface) then begin\r
 662       timerwrapperinterface.setontimer(wrappedtimer,newvalue);\r
 663     end else begin\r
 664 \r
 665     end;\r
 666   end;\r
 667 \r
 668 end;\r
 669 \r
 670 \r
 671 procedure tltimer.setenabled(newvalue : boolean);\r
 672 begin\r
 673   if newvalue <> fenabled then begin\r
 674     fenabled := newvalue;\r
 675     if assigned(timerwrapperinterface) then begin\r
 676       timerwrapperinterface.setenabled(wrappedtimer,newvalue);\r
 677     end else begin\r
 678       {$ifdef win32}\r
 679         raise exception.create('non wrapper timers are not permitted on windows');\r
 680       {$else}\r
 681         resettimes;\r
 682       {$endif}\r
 683     end;\r
 684   end;\r
 685 end;\r
 686 \r
 687 procedure tltimer.setinterval(newvalue:integer);\r
 688 begin\r
 689   if newvalue <> finterval then begin\r
 690     finterval := newvalue;\r
 691     if assigned(timerwrapperinterface) then begin\r
 692       timerwrapperinterface.setinterval(wrappedtimer,newvalue);\r
 693     end else begin\r
 694       {$ifdef win32}\r
 695         raise exception.create('non wrapper timers are not permitted on windows');\r
 696       {$else}\r
 697         resettimes;\r
 698       {$endif}\r
 699     end;\r
 700   end;\r
 701 \r
 702 end;\r
 703 \r
 704 \r
 705 \r
 706 \r
 707 constructor tltimer.create;\r
 708 begin\r
 709   inherited create(AOwner);\r
 710   if assigned(timerwrapperinterface) then begin\r
 711     wrappedtimer := timerwrapperinterface.createwrappedtimer;\r
 712   end else begin\r
 713 \r
 714 \r
 715     nexttimer := firsttimer;\r
 716     prevtimer := nil;\r
 717 \r
 718     if assigned(nexttimer) then nexttimer.prevtimer := self;\r
 719     firsttimer := self;\r
 720   end;\r
 721   interval := 1000;\r
 722   enabled := true;\r
 723   released := false;\r
 724 \r
 725 end;\r
 726 \r
 727 destructor tltimer.destroy;\r
 728 begin\r
 729   if assigned(timerwrapperinterface) then begin\r
 730     wrappedtimer.free;\r
 731   end else begin\r
 732     if prevtimer <> nil then begin\r
 733       prevtimer.nexttimer := nexttimer;\r
 734     end else begin\r
 735       firsttimer := nexttimer;\r
 736     end;\r
 737     if nexttimer <> nil then begin\r
 738       nexttimer.prevtimer := prevtimer;\r
 739     end;\r
 740     \r
 741   end;\r
 742   inherited destroy;\r
 743 end;\r
 744 \r
 745 constructor tltask.create(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
 746 begin\r
 747   inherited create;\r
 748   if assigned(onaddtask) then onaddtask(ahandler,aobj,awparam,alparam);\r
 749   handler   := ahandler;\r
 750   obj       := aobj;\r
 751   wparam    := awparam;\r
 752   lparam    := alparam;\r
 753   {nexttask  := firsttask;\r
 754   firsttask := self;}\r
 755   if assigned(lasttask) then begin\r
 756     lasttask.nexttask := self;\r
 757   end else begin\r
 758     firsttask := self;\r
 759   end;\r
 760   lasttask := self;\r
 761   //ahandler(wparam,lparam);\r
 762 end;\r
 763 \r
 764 procedure addtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
 765 begin\r
 766 \r
 767   tltask.create(ahandler,aobj,awparam,alparam);\r
 768 end;\r
 769 \r
 770 \r
 771 \r
 772 \r
 773 {$ifndef nosignal}\r
 774   procedure prepsigpipe;inline;\r
 775   begin\r
 776     starthandlesignal(sigpipe);\r
 777     if not assigned(signalloopback) then begin\r
 778       signalloopback := tlloopback.create(nil);\r
 779       signalloopback.ondataAvailable := signalloopback.sinkdata;\r
 780 \r
 781     end;\r
 782 \r
 783   end;\r
 784 {$endif}\r
 785 \r
 786 procedure processtasks;//inline;\r
 787 var\r
 788   temptask                : tltask   ;\r
 789 \r
 790 begin\r
 791 \r
 792   if not assigned(currenttask) then begin\r
 793     currenttask := firsttask;\r
 794     firsttask := nil;\r
 795     lasttask  := nil;\r
 796   end;\r
 797   while assigned(currenttask) do begin\r
 798 \r
 799     if assigned(currenttask.handler) then currenttask.handler(currenttask.wparam,currenttask.lparam);\r
 800     if assigned(currenttask) then begin\r
 801       temptask := currenttask;\r
 802       currenttask := currenttask.nexttask;\r
 803       temptask.free;\r
 804     end;\r
 805     //writeln('processed a task');\r
 806   end;\r
 807 \r
 808 end;\r
 809 \r
 810 \r
 811 \r
 812 \r
 813 procedure disconnecttasks(aobj:tobject);\r
 814 var\r
 815   currenttasklocal : tltask ;\r
 816   counter          : byte   ;\r
 817 begin\r
 818   for counter := 0 to 1 do begin\r
 819     if counter = 0 then begin\r
 820       currenttasklocal := firsttask; //main list of tasks\r
 821     end else begin\r
 822       currenttasklocal := currenttask; //needed in case called from a task\r
 823     end;\r
 824     // note i don't bother to sestroy the links here as that will happen when\r
 825     // the list of tasks is processed anyway\r
 826     while assigned(currenttasklocal) do begin\r
 827       if currenttasklocal.obj = aobj then begin\r
 828         currenttasklocal.obj := nil;\r
 829         currenttasklocal.handler := nil;\r
 830       end;\r
 831       currenttasklocal := currenttasklocal.nexttask;\r
 832     end;\r
 833   end;\r
 834 end;\r
 835 \r
 836 \r
 837 procedure processmessages;\r
 838 begin\r
 839   eventcore.processmessages;\r
 840 end;\r
 841 procedure messageloop;\r
 842 begin\r
 843   eventcore.messageloop;\r
 844 end;\r
 845 \r
 846 procedure exitmessageloop;\r
 847 begin\r
 848   eventcore.exitmessageloop;\r
 849 end;\r
 850 \r
 851 function tlasio.RealSend(Data : Pointer; Len : Integer) : Integer;\r
 852 begin\r
 853   result := myfdwrite(fdhandleout,data^,len);\r
 854   if (result > 0) and assigned(onsenddata) then onsenddata(self,result);\r
 855   eventcore.wmasterset(fdhandleout);\r
 856 end;\r
 857 {$ifndef win32}\r
 858   procedure tlasio.myfdclose(fd : integer);\r
 859   begin\r
 860     fdclose(fd);\r
 861   end;\r
 862   function tlasio.myfdwrite(fd: LongInt;const buf;size: LongInt):LongInt;\r
 863   begin\r
 864     result := fdwrite(fd,buf,size);\r
 865   end;\r
 866 \r
 867   function tlasio.myfdread(fd: LongInt;var buf;size: LongInt):LongInt;\r
 868   begin\r
 869     result := fdread(fd,buf,size);\r
 870   end;\r
 871 \r
 872 \r
 873 {$endif}\r
 874 \r
 875 \r
 876 begin\r
 877   firstasin := nil;\r
 878   firsttask := nil;\r
 879   \r
 880 \r
 881   {$ifndef nosignal}\r
 882     signalloopback := nil;\r
 883   {$endif}\r
 884 end.\r
 885 \r
 886 \r
 887 \r
 888 \r
 889 \r