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

Contents of /trunk/lcore.pas

Parent Directory Parent Directory | Revision Log Revision Log


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

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.22