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

Contents of /trunk/lcorelazarus.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 149 - (show annotations)
Sun Sep 10 20:02:13 2017 UTC (3 months ago) by plugwash
File size: 4700 byte(s)
Replace obsolete/broken lcoregtklaz with new lcorelazarus
Rename lmessages to lcoremessages due to unit name conflict with Lazarus

1 { Copyright (C) 2005-2017 Robin Green, Bas Steendijk, Peter Green
2 For conditions of distribution and use, see copyright notice in zlib_license.
3 txt
4 which is included in the package
5 -----------------------------------------------------------------------------
6 }
7
8 unit lcorelazarus;
9 {$mode delphi}
10 interface
11
12 uses
13 lcore,
14 Classes, SysUtils,Forms,fd_utils,LCLIntf,InterfaceBase,ExtCtrls;
15
16
17 procedure lcoreinit;
18
19 implementation
20 const
21 absolutemaxs_select = (sizeof(fdset)*8)-1;
22
23 var
24 fdreverse:array[0..absolutemaxs_select] of tlasio;
25 fdEventHandlers:array[0..absolutemaxs_select] of PEventHandler;
26 fdflags:array[0..absolutemaxs_select] of byte;
27 tasksoutstanding : boolean;
28 type
29 tlazaruseventcore=class(teventcore)
30 public
31 procedure processmessages; override;
32 procedure messageloop; override;
33 procedure exitmessageloop;override;
34 procedure setfdreverse(fd : integer;reverseto : tlasio); override;
35 procedure rmasterset(fd : integer;islistensocket : boolean); override;
36 procedure rmasterclr(fd: integer); override;
37 procedure wmasterset(fd : integer); override;
38 procedure wmasterclr(fd: integer); override;
39 procedure WaitHandleEvent(AData: PtrInt; AFlags: dword);
40 procedure taskcb(Data: PtrInt);
41 end;
42
43 tlaztimerwrapperinterface=class(ttimerwrapperinterface)
44 public
45 function createwrappedtimer : tobject;override;
46 // procedure setinitialevent(wrappedtimer : tobject;newvalue : boolean);override;
47 procedure setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);override;
48 procedure setenabled(wrappedtimer : tobject;newvalue : boolean);override;
49 procedure setinterval(wrappedtimer : tobject;newvalue : integer);override;
50 end;
51 const
52 G_IO_IN = 1;
53 G_IO_OUT = 4;
54
55 procedure tlazaruseventcore.taskcb(Data: PtrInt);
56 begin
57
58 tasksoutstanding := false;
59 processtasks;
60 end;
61
62 procedure tlazaruseventcore.WaitHandleEvent(AData: PtrInt; AFlags: dword);
63 var lasio:tlasio;
64 begin
65 lasio:=fdreverse[AData];
66 if lasio<>nil then lasio.handlefdtrigger((AFlags and G_IO_IN)<>0,(AFlags and G_IO_OUT)<>0);
67 end;
68
69 procedure tlazaruseventcore.processmessages;
70 begin
71 Application.ProcessMessages;
72 end;
73 procedure tlazaruseventcore.messageloop;
74 begin
75 Application.Run;
76 end;
77 procedure tlazaruseventcore.exitmessageloop;
78 begin
79 Application.Terminate;
80 end;
81 procedure tlazaruseventcore.setfdreverse(fd : integer;reverseto : tlasio);
82 begin
83 fdreverse[fd] := reverseto;
84
85 end;
86 procedure addfdflags(fd : integer;flags:byte);
87 begin
88 fdflags[fd]:=fdflags[fd] or flags;
89 if fdEventHandlers[fd]=nil then begin
90 fdEventHandlers[fd]:=AddEventHandler(fd,flags,tlazaruseventcore(eventcore).WaitHandleEvent,fd);
91 end else begin
92
93 SetEventHandlerFlags(fdEventHandlers[fd], fdflags[fd]);
94 end;
95 end;
96
97 procedure removefdflags(fd : integer;flags:byte);
98 begin
99 if fdEventHandlers[fd]<>nil then begin
100 fdflags[fd]:=fdflags[fd] and (not flags);
101 if fdflags[fd]=0 then begin
102 RemoveEventHandler(fdEventHandlers[fd]);
103 fdEventHandlers[fd]:=nil;
104 end else begin
105
106 SetEventHandlerFlags(fdEventHandlers[fd], fdflags[fd]);
107 end;
108 end;
109 end;
110
111 procedure tlazaruseventcore.rmasterset(fd : integer;islistensocket : boolean);
112 begin
113 addfdflags(fd,G_IO_IN);
114 end;
115 procedure tlazaruseventcore.rmasterclr(fd: integer);
116 begin
117 removefdflags(fd,G_IO_IN);
118 end;
119 procedure tlazaruseventcore.wmasterset(fd : integer);
120 begin
121 addfdflags(fd,G_IO_OUT);
122
123 end;
124 procedure tlazaruseventcore.wmasterclr(fd: integer);
125 begin
126 removefdflags(fd,G_IO_OUT);
127 end;
128
129 procedure lazaddtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);
130 begin
131 if not tasksoutstanding then Application.QueueAsyncCall(tlazaruseventcore(eventcore).taskcb,0);
132 tasksoutstanding := true;
133 end;
134
135 function tlaztimerwrapperinterface.createwrappedtimer : tobject;
136 begin
137 result := ttimer.create(nil);
138 end;
139 procedure tlaztimerwrapperinterface.setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);
140 begin
141 ttimer(wrappedtimer).ontimer := newvalue;
142 end;
143 procedure tlaztimerwrapperinterface.setenabled(wrappedtimer : tobject;newvalue : boolean);
144 begin
145 ttimer(wrappedtimer).enabled := newvalue;
146 end;
147
148
149 procedure tlaztimerwrapperinterface.setinterval(wrappedtimer : tobject;newvalue : integer);
150 begin
151 ttimer(wrappedtimer).interval := newvalue;
152 end;
153 var
154 inited:boolean;
155 procedure lcoreinit;
156 begin
157 if (inited) then exit;
158 eventcore := tlazaruseventcore.create;
159 onaddtask := lazaddtask;
160
161 absolutemaxs := absolutemaxs_select;
162 inited := true;
163 end;
164
165 end.
166

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