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

Annotation of /trunk/lcore.pas

Parent Directory Parent Directory | Revision Log Revision Log


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