lcorewsaasyncselect.pas

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