lcorewsaasyncselect.pas

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