-unit lcorewsaasyncselect;\r
-\r
-interface\r
-\r
-implementation\r
-uses wcore,lcore,bsearchtree,sysutils,windows,winsock,pgtypes,messages,classes;\r
-type\r
- twineventcore=class(teventcore)\r
- public\r
- procedure processmessages; override;\r
- procedure messageloop; override;\r
- procedure exitmessageloop;override;\r
- procedure setfdreverse(fd : integer;reverseto : tlasio); override;\r
- procedure rmasterset(fd : integer;islistensocket : boolean); override;\r
- procedure rmasterclr(fd: integer); override;\r
- procedure wmasterset(fd : integer); override;\r
- procedure wmasterclr(fd: integer); override;\r
- end;\r
-const\r
- wm_dotasks=wm_user+1;\r
-type\r
- twintimerwrapperinterface=class(ttimerwrapperinterface)\r
- public\r
- function createwrappedtimer : tobject;override;\r
-// procedure setinitialevent(wrappedtimer : tobject;newvalue : boolean);override;\r
- procedure setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);override;\r
- procedure setenabled(wrappedtimer : tobject;newvalue : boolean);override;\r
- procedure setinterval(wrappedtimer : tobject;newvalue : integer);override;\r
- end;\r
-\r
-procedure twineventcore.processmessages;\r
-begin\r
- wcore.processmessages;//pass off to wcore\r
-end;\r
-procedure twineventcore.messageloop;\r
-begin\r
- wcore.messageloop; //pass off to wcore\r
-end;\r
-procedure twineventcore.exitmessageloop;\r
-begin\r
- wcore.exitmessageloop;\r
-end;\r
-var\r
- fdreverse : thashtable;\r
- fdwatches : thashtable;\r
-\r
-procedure twineventcore.setfdreverse(fd : integer;reverseto : tlasio);\r
-begin\r
- if findtree(@fdreverse,inttostr(fd)) <> nil then deltree(@fdreverse,inttostr(fd));\r
- if reverseto <> nil then addtree(@fdreverse,inttostr(fd),reverseto);\r
-end;\r
-\r
-var\r
- hwndlcore : hwnd;\r
-procedure dowsaasyncselect(fd:integer; leventadd: integer; leventremove : integer);\r
-var\r
- leventold : integer;\r
- leventnew : integer;\r
- wsaaresult : integer;\r
-begin\r
- leventold := taddrint(findtree(@fdwatches,inttostr(fd)));\r
- leventnew := leventold or leventadd;\r
- leventnew := leventnew and not leventremove;\r
- if leventold <> leventnew then begin\r
- if leventold <> 0 then deltree(@fdwatches,inttostr(fd));\r
- if leventnew <> 0 then addtree(@fdwatches,inttostr(fd),pointer(leventnew));\r
- end;\r
- wsaaresult := wsaasyncselect(fd,hwndlcore,wm_user,leventnew);\r
-\r
-end;\r
-\r
-\r
-//to allow detection of errors:\r
-//if we are asked to monitor for read or accept we also monitor for close\r
-//if we are asked to monitor for write we also monitor for connect\r
-\r
-\r
-procedure twineventcore.rmasterset(fd : integer;islistensocket : boolean);\r
-begin\r
- if islistensocket then begin\r
- //writeln('setting accept watch for socket number ',fd);\r
- dowsaasyncselect(fd,FD_ACCEPT or FD_CLOSE,0);\r
- end else begin\r
- //writeln('setting read watch for socket number',fd);\r
- dowsaasyncselect(fd,FD_READ or FD_CLOSE,0);\r
- end;\r
-end;\r
-procedure twineventcore.rmasterclr(fd: integer);\r
-begin\r
- //writeln('clearing read of accept watch for socket number ',fd);\r
- dowsaasyncselect(fd,0,FD_ACCEPT or FD_READ or FD_CLOSE);\r
-end;\r
-procedure twineventcore.wmasterset(fd : integer);\r
-begin\r
- dowsaasyncselect(fd,FD_WRITE or FD_CONNECT,0);\r
-end;\r
-\r
-procedure twineventcore.wmasterclr(fd: integer);\r
-begin\r
- dowsaasyncselect(fd,0,FD_WRITE or FD_CONNECT);\r
-end;\r
-\r
-var\r
- tasksoutstanding : boolean;\r
-\r
-function MyWindowProc(\r
- ahWnd : HWND;\r
- auMsg : Integer;\r
- awParam : WPARAM;\r
- alParam : LPARAM): Integer; stdcall;\r
-var\r
- socket : integer;\r
- event : integer;\r
- error : integer;\r
- readtrigger : boolean;\r
- writetrigger : boolean;\r
- lasio : tlasio;\r
-begin\r
- //writeln('got a message');\r
- Result := 0; // This means we handled the message\r
- if (ahwnd=hwndlcore) and (aumsg=wm_user) then begin\r
- //writeln('it appears to be a response to our wsaasyncselect');\r
- socket := awparam;\r
- event := alparam and $FFFF;\r
- error := alparam shr 16;\r
- //writeln('socket=',socket,' event=',event,' error=',error);\r
- readtrigger := false;\r
- writetrigger := false;\r
- lasio := findtree(@fdreverse,inttostr(socket));\r
- if assigned(lasio) then begin\r
- if (error <> 0) or ((event and FD_CLOSE) <> 0) then begin\r
- if lasio.state = wsconnecting then begin\r
- lasio.onsessionconnected(lasio,error);\r
- end;\r
- lasio.internalclose(error);\r
- end else begin\r
- if (event and (FD_READ or FD_ACCEPT)) <> 0 then readtrigger := true;\r
- if (event and (FD_WRITE)) <> 0 then writetrigger := true;\r
-\r
- if readtrigger or writetrigger then lasio.handlefdtrigger(readtrigger,writetrigger);\r
- end;\r
- dowsaasyncselect(socket,0,0); //reset watches\r
- end;\r
- end else if (ahwnd=hwndlcore) and (aumsg=wm_dotasks) then begin\r
- //writeln('processing tasks');\r
- tasksoutstanding := false;\r
- processtasks;\r
- end else begin\r
- //writeln('passing unknown message to defwindowproc');\r
- //not passing unknown messages on to defwindowproc will cause window\r
- //creation to fail! --plugwash\r
- Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)\r
- end;\r
-\r
-end;\r
-\r
-procedure winaddtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);\r
-begin\r
- if not tasksoutstanding then PostMessage(hwndlcore,wm_dotasks,0,0);\r
-end;\r
-type\r
- twcoretimer = wcore.tltimer;\r
-\r
-function twintimerwrapperinterface.createwrappedtimer : tobject;\r
-begin\r
- result := twcoretimer.create(nil);\r
-end;\r
-procedure twintimerwrapperinterface.setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);\r
-begin\r
- twcoretimer(wrappedtimer).ontimer := newvalue;\r
-end;\r
-procedure twintimerwrapperinterface.setenabled(wrappedtimer : tobject;newvalue : boolean);\r
-begin\r
- twcoretimer(wrappedtimer).enabled := newvalue;\r
-end;\r
-\r
-\r
-procedure twintimerwrapperinterface.setinterval(wrappedtimer : tobject;newvalue : integer);\r
-begin\r
- twcoretimer(wrappedtimer).interval := newvalue;\r
-end;\r
-\r
-var\r
- MyWindowClass : TWndClass = (style : 0;\r
- lpfnWndProc : @MyWindowProc;\r
- cbClsExtra : 0;\r
- cbWndExtra : 0;\r
- hInstance : 0;\r
- hIcon : 0;\r
- hCursor : 0;\r
- hbrBackground : 0;\r
- lpszMenuName : nil;\r
- lpszClassName : 'lcoreClass');\r
- GInitData: TWSAData;\r
-\r
-begin\r
- eventcore := twineventcore.create;\r
- if Windows.RegisterClass(MyWindowClass) = 0 then halt;\r
- //writeln('about to create lcore handle, hinstance=',hinstance);\r
- hwndlcore := CreateWindowEx(WS_EX_TOOLWINDOW,\r
- MyWindowClass.lpszClassName,\r
- '', { Window name }\r
- WS_POPUP, { Window Style }\r
- 0, 0, { X, Y }\r
- 0, 0, { Width, Height }\r
- 0, { hWndParent }\r
- 0, { hMenu }\r
- HInstance, { hInstance }\r
- nil); { CreateParam }\r
- //writeln('lcore hwnd is ',hwndlcore);\r
- //writeln('last error is ',GetLastError);\r
- onaddtask := winaddtask;\r
- timerwrapperinterface := twintimerwrapperinterface.create(nil);\r
-\r
- WSAStartup($200, GInitData);\r
-end.\r
lcore.org gitweb / lcore.git / blobdiff