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

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

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