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

Contents of /trunk/lcore.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 57 - (show annotations)
Sat Oct 31 00:20:41 2009 UTC (10 years, 11 months ago) by plugwash
File size: 25430 byte(s)
change ltimevalstuff to a unit and move defintion of ttimeval on windows 
there

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

Properties

Name Value
svn:executable

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