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

Contents of /trunk/lcorewsaasyncselect.pas

Parent Directory Parent Directory | Revision Log Revision Log


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

1 unit lcorewsaasyncselect;
2
3 interface
4
5 implementation
6 uses wcore,lcore,bsearchtree,sysutils,windows,winsock,pgtypes,messages,classes;
7 type
8 twineventcore=class(teventcore)
9 public
10 procedure processmessages; override;
11 procedure messageloop; override;
12 procedure exitmessageloop;override;
13 procedure setfdreverse(fd : integer;reverseto : tlasio); override;
14 procedure rmasterset(fd : integer;islistensocket : boolean); override;
15 procedure rmasterclr(fd: integer); override;
16 procedure wmasterset(fd : integer); override;
17 procedure wmasterclr(fd: integer); override;
18 end;
19 const
20 wm_dotasks=wm_user+1;
21 type
22 twintimerwrapperinterface=class(ttimerwrapperinterface)
23 public
24 function createwrappedtimer : tobject;override;
25 // procedure setinitialevent(wrappedtimer : tobject;newvalue : boolean);override;
26 procedure setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);override;
27 procedure setenabled(wrappedtimer : tobject;newvalue : boolean);override;
28 procedure setinterval(wrappedtimer : tobject;newvalue : integer);override;
29 end;
30
31 procedure twineventcore.processmessages;
32 begin
33 wcore.processmessages;//pass off to wcore
34 end;
35 procedure twineventcore.messageloop;
36 begin
37 wcore.messageloop; //pass off to wcore
38 end;
39 procedure twineventcore.exitmessageloop;
40 begin
41 wcore.exitmessageloop;
42 end;
43 var
44 fdreverse : thashtable;
45 fdwatches : thashtable;
46
47 procedure twineventcore.setfdreverse(fd : integer;reverseto : tlasio);
48 begin
49 if findtree(@fdreverse,inttostr(fd)) <> nil then deltree(@fdreverse,inttostr(fd));
50 if reverseto <> nil then addtree(@fdreverse,inttostr(fd),reverseto);
51 end;
52
53 var
54 hwndlcore : hwnd;
55 procedure dowsaasyncselect(fd:integer; leventadd: integer; leventremove : integer);
56 var
57 leventold : integer;
58 leventnew : integer;
59 wsaaresult : integer;
60 begin
61 leventold := taddrint(findtree(@fdwatches,inttostr(fd)));
62 leventnew := leventold or leventadd;
63 leventnew := leventnew and not leventremove;
64 if leventold <> leventnew then begin
65 if leventold <> 0 then deltree(@fdwatches,inttostr(fd));
66 if leventnew <> 0 then addtree(@fdwatches,inttostr(fd),pointer(leventnew));
67 end;
68 wsaaresult := wsaasyncselect(fd,hwndlcore,wm_user,leventnew);
69
70 end;
71
72
73 //to allow detection of errors:
74 //if we are asked to monitor for read or accept we also monitor for close
75 //if we are asked to monitor for write we also monitor for connect
76
77
78 procedure twineventcore.rmasterset(fd : integer;islistensocket : boolean);
79 begin
80 if islistensocket then begin
81 //writeln('setting accept watch for socket number ',fd);
82 dowsaasyncselect(fd,FD_ACCEPT or FD_CLOSE,0);
83 end else begin
84 //writeln('setting read watch for socket number',fd);
85 dowsaasyncselect(fd,FD_READ or FD_CLOSE,0);
86 end;
87 end;
88 procedure twineventcore.rmasterclr(fd: integer);
89 begin
90 //writeln('clearing read of accept watch for socket number ',fd);
91 dowsaasyncselect(fd,0,FD_ACCEPT or FD_READ or FD_CLOSE);
92 end;
93 procedure twineventcore.wmasterset(fd : integer);
94 begin
95 dowsaasyncselect(fd,FD_WRITE or FD_CONNECT,0);
96 end;
97
98 procedure twineventcore.wmasterclr(fd: integer);
99 begin
100 dowsaasyncselect(fd,0,FD_WRITE or FD_CONNECT);
101 end;
102
103 var
104 tasksoutstanding : boolean;
105
106 function MyWindowProc(
107 ahWnd : HWND;
108 auMsg : Integer;
109 awParam : WPARAM;
110 alParam : LPARAM): Integer; stdcall;
111 var
112 socket : integer;
113 event : integer;
114 error : integer;
115 readtrigger : boolean;
116 writetrigger : boolean;
117 lasio : tlasio;
118 begin
119 //writeln('got a message');
120 Result := 0; // This means we handled the message
121 if (ahwnd=hwndlcore) and (aumsg=wm_user) then begin
122 //writeln('it appears to be a response to our wsaasyncselect');
123 socket := awparam;
124 event := alparam and $FFFF;
125 error := alparam shr 16;
126 //writeln('socket=',socket,' event=',event,' error=',error);
127 readtrigger := false;
128 writetrigger := false;
129 lasio := findtree(@fdreverse,inttostr(socket));
130 if assigned(lasio) then begin
131 if (error <> 0) or ((event and FD_CLOSE) <> 0) then begin
132 if lasio.state = wsconnecting then begin
133 lasio.onsessionconnected(lasio,error);
134 end;
135 lasio.internalclose(error);
136 end else begin
137 if (event and (FD_READ or FD_ACCEPT)) <> 0 then readtrigger := true;
138 if (event and (FD_WRITE)) <> 0 then writetrigger := true;
139
140 if readtrigger or writetrigger then lasio.handlefdtrigger(readtrigger,writetrigger);
141 end;
142 dowsaasyncselect(socket,0,0); //reset watches
143 end;
144 end else if (ahwnd=hwndlcore) and (aumsg=wm_dotasks) then begin
145 //writeln('processing tasks');
146 tasksoutstanding := false;
147 processtasks;
148 end else begin
149 //writeln('passing unknown message to defwindowproc');
150 //not passing unknown messages on to defwindowproc will cause window
151 //creation to fail! --plugwash
152 Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)
153 end;
154
155 end;
156
157 procedure winaddtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);
158 begin
159 if not tasksoutstanding then PostMessage(hwndlcore,wm_dotasks,0,0);
160 end;
161 type
162 twcoretimer = wcore.tltimer;
163
164 function twintimerwrapperinterface.createwrappedtimer : tobject;
165 begin
166 result := twcoretimer.create(nil);
167 end;
168 procedure twintimerwrapperinterface.setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);
169 begin
170 twcoretimer(wrappedtimer).ontimer := newvalue;
171 end;
172 procedure twintimerwrapperinterface.setenabled(wrappedtimer : tobject;newvalue : boolean);
173 begin
174 twcoretimer(wrappedtimer).enabled := newvalue;
175 end;
176
177
178 procedure twintimerwrapperinterface.setinterval(wrappedtimer : tobject;newvalue : integer);
179 begin
180 twcoretimer(wrappedtimer).interval := newvalue;
181 end;
182
183 var
184 MyWindowClass : TWndClass = (style : 0;
185 lpfnWndProc : @MyWindowProc;
186 cbClsExtra : 0;
187 cbWndExtra : 0;
188 hInstance : 0;
189 hIcon : 0;
190 hCursor : 0;
191 hbrBackground : 0;
192 lpszMenuName : nil;
193 lpszClassName : 'lcoreClass');
194 GInitData: TWSAData;
195
196 begin
197 eventcore := twineventcore.create;
198 if Windows.RegisterClass(MyWindowClass) = 0 then halt;
199 //writeln('about to create lcore handle, hinstance=',hinstance);
200 hwndlcore := CreateWindowEx(WS_EX_TOOLWINDOW,
201 MyWindowClass.lpszClassName,
202 '', { Window name }
203 WS_POPUP, { Window Style }
204 0, 0, { X, Y }
205 0, 0, { Width, Height }
206 0, { hWndParent }
207 0, { hMenu }
208 HInstance, { hInstance }
209 nil); { CreateParam }
210 //writeln('lcore hwnd is ',hwndlcore);
211 //writeln('last error is ',GetLastError);
212 onaddtask := winaddtask;
213 timerwrapperinterface := twintimerwrapperinterface.create(nil);
214
215 WSAStartup($200, GInitData);
216 end.

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