lcorewsaasyncselect.pas

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