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