lcore/trunk/lcorewsaasyncselect.pas

unit lcorewsaasyncselect;

interface

procedure lcoreinit;

implementation

uses
  dnswin, //to call init
  wcore,lcore,bsearchtree,sysutils,windows,winsock,pgtypes,messages,classes,lsocket;

type
  twineventcore=class(teventcore)
  public
    procedure processmessages; override;
    procedure messageloop; override;
    procedure exitmessageloop;override;
    procedure setfdreverse(fd : integer;reverseto : tlasio); override;
    procedure rmasterset(fd : integer;islistensocket : boolean); override;
    procedure rmasterclr(fd: integer); override;
    procedure wmasterset(fd : integer); override;
    procedure wmasterclr(fd: integer); override;
  end;
const
  wm_dotasks=wm_user+1;
type
  twintimerwrapperinterface=class(ttimerwrapperinterface)
  public
    function createwrappedtimer : tobject;override;
//    procedure setinitialevent(wrappedtimer : tobject;newvalue : boolean);override;
    procedure setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);override;
    procedure setenabled(wrappedtimer : tobject;newvalue : boolean);override;
    procedure setinterval(wrappedtimer : tobject;newvalue : integer);override;
  end;

procedure twineventcore.processmessages;
begin
  wcore.processmessages;//pass off to wcore
end;
procedure twineventcore.messageloop;
begin
  wcore.messageloop; //pass off to wcore
end;
procedure twineventcore.exitmessageloop;
begin
  wcore.exitmessageloop;
end;
var
  fdreverse : thashtable;
  fdwatches : thashtable;

procedure twineventcore.setfdreverse(fd : integer;reverseto : tlasio);
begin
  if findtree(@fdreverse,inttostr(fd)) <> nil then deltree(@fdreverse,inttostr(fd));
  if reverseto <> nil then addtree(@fdreverse,inttostr(fd),reverseto);
end;

var
  hwndlcore : hwnd;
procedure dowsaasyncselect(fd:integer; leventadd: integer; leventremove : integer);
var
  leventold : integer;
  leventnew : integer;
  wsaaresult : integer;
begin
  leventold := taddrint(findtree(@fdwatches,inttostr(fd)));
  leventnew := leventold or leventadd;
  leventnew := leventnew and not leventremove;
  if leventold <> leventnew then begin
    if leventold <> 0 then deltree(@fdwatches,inttostr(fd));
    if leventnew <> 0 then addtree(@fdwatches,inttostr(fd),pointer(leventnew));
  end;
  wsaaresult := wsaasyncselect(fd,hwndlcore,wm_user,leventnew);

end;


//to allow detection of errors:
//if we are asked to monitor for read or accept we also monitor for close
//if we are asked to monitor for write we also monitor for connect


procedure twineventcore.rmasterset(fd : integer;islistensocket : boolean);
begin
  if islistensocket then begin
//    writeln('setting accept watch for socket number ',fd);
    dowsaasyncselect(fd,FD_ACCEPT or FD_CLOSE,0);
  end else begin
//    writeln('setting read watch for socket number',fd);
    dowsaasyncselect(fd,FD_READ or FD_CLOSE,0);
  end;
end;
procedure twineventcore.rmasterclr(fd: integer);
begin
  //writeln('clearing read of accept watch for socket number ',fd);
  dowsaasyncselect(fd,0,FD_ACCEPT or FD_READ or FD_CLOSE);
end;
procedure twineventcore.wmasterset(fd : integer);
begin
  dowsaasyncselect(fd,FD_WRITE or FD_CONNECT,0);
end;

procedure twineventcore.wmasterclr(fd: integer);
begin
  dowsaasyncselect(fd,0,FD_WRITE or FD_CONNECT);
end;

var
  tasksoutstanding : boolean;

function MyWindowProc(
    ahWnd   : HWND;
    auMsg   : Integer;
    awParam : WPARAM;
    alParam : LPARAM): Integer; stdcall;
var
  socket : integer;
  event : integer;
  error : integer;
  readtrigger : boolean;
  writetrigger : boolean;
  lasio : tlasio;
begin
//  writeln('got a message');
  Result := 0;  // This means we handled the message
  if (ahwnd=hwndlcore) and (aumsg=wm_user) then begin
//    writeln('it appears to be a response to our wsaasyncselect');
    socket := awparam;
    event := alparam and $FFFF;
    error := alparam shr 16;
//    writeln('socket=',socket,' event=',event,' error=',error);
    readtrigger := false;
    writetrigger := false;
    lasio := findtree(@fdreverse,inttostr(socket));
    if assigned(lasio) then begin
      if (error <> 0) or ((event and FD_CLOSE) <> 0) then begin
        if (lasio.state = wsconnecting) and (error <> 0) then begin
          if lasio is tlsocket then tlsocket(lasio).connectionfailedhandler(error)
        end else begin
          lasio.internalclose(error);
        end;
      end else begin
        if (event and (FD_READ or FD_ACCEPT)) <> 0 then readtrigger := true;
        if (event and (FD_WRITE)) <> 0 then writetrigger := true;

        if readtrigger or writetrigger then lasio.handlefdtrigger(readtrigger,writetrigger);
      end;
      // don't reset the event manually for listen sockets to avoid unwanted
      // extra onsessionavailable events
      if (taddrint(findtree(@fdwatches,inttostr(socket))) and (FD_ACCEPT)) = 0 then dowsaasyncselect(socket,0,0); // if not a listen socket reset watches
    end;
  end else if (ahwnd=hwndlcore) and (aumsg=wm_dotasks) then begin
      //writeln('processing tasks');
      tasksoutstanding := false;
      processtasks;
  end else begin
      //writeln('passing unknown message to defwindowproc');
      //not passing unknown messages on to defwindowproc will cause window
      //creation to fail! --plugwash
      Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)
  end;

end;

procedure winaddtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);
begin
  if not tasksoutstanding then PostMessage(hwndlcore,wm_dotasks,0,0);
  tasksoutstanding := true;
end;
type
  twcoretimer = wcore.tltimer;

function twintimerwrapperinterface.createwrappedtimer : tobject;
begin
  result := twcoretimer.create(nil);
end;
procedure twintimerwrapperinterface.setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);
begin
  twcoretimer(wrappedtimer).ontimer := newvalue;
end;
procedure twintimerwrapperinterface.setenabled(wrappedtimer : tobject;newvalue : boolean);
begin
  twcoretimer(wrappedtimer).enabled := newvalue;
end;


procedure twintimerwrapperinterface.setinterval(wrappedtimer : tobject;newvalue : integer);
begin
  twcoretimer(wrappedtimer).interval := newvalue;
end;

var
  MyWindowClass : TWndClass = (style         : 0;
                                 lpfnWndProc   : @MyWindowProc;
                                 cbClsExtra    : 0;
                                 cbWndExtra    : 0;
                                 hInstance     : 0;
                                 hIcon         : 0;
                                 hCursor       : 0;
                                 hbrBackground : 0;
                                 lpszMenuName  : nil;
                                 lpszClassName : 'lcoreClass');
  GInitData: TWSAData;

var
  inited:boolean;
procedure lcoreinit;
begin
  if (inited) then exit;

  dnswin.init;

  eventcore := twineventcore.create;
  if Windows.RegisterClass(MyWindowClass) = 0 then halt;
  //writeln('about to create lcore handle, hinstance=',hinstance);
  hwndlcore := CreateWindowEx(WS_EX_TOOLWINDOW,
                               MyWindowClass.lpszClassName,
                               '',        { Window name   }
                               WS_POPUP,  { Window Style  }
                               0, 0,      { X, Y          }
                               0, 0,      { Width, Height }
                               0,         { hWndParent    }
                               0,         { hMenu         }
                               HInstance, { hInstance     }
                               nil);      { CreateParam   }
  //writeln('lcore hwnd is ',hwndlcore);
  //writeln('last error is ',GetLastError);
  onaddtask := winaddtask;
  timerwrapperinterface := twintimerwrapperinterface.create(nil);

  WSAStartup(2, GInitData);
  absolutemaxs := maxlongint;

  wcoreinit;

  inited := true;
end;

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