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

Contents of /trunk/lcore.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1 - (show annotations)
Fri Mar 28 02:26:58 2008 UTC (13 years, 2 months ago) by plugwash
File size: 24888 byte(s)
initial import

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

Properties

Name Value
svn:executable

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