/[lcore]/trunk/lcore.pas
ViewVC logotype

Contents of /trunk/lcore.pas

Parent Directory Parent Directory | Revision Log Revision Log


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

Properties

Name Value
svn:eol-style CRLF

No admin address has been configured">No admin address has been configured
ViewVC Help
Powered by ViewVC 1.1.5