| [476] | 1 | { **************************************************************
|
|---|
| 2 | Package: XWB - Kernel RPCBroker
|
|---|
| 3 | Date Created: Sept 18, 1997 (Version 1.1)
|
|---|
| 4 | Site Name: Oakland, OI Field Office, Dept of Veteran Affairs
|
|---|
| 5 | Developers: Danila Manapsal, Don Craven, Joel Ivey
|
|---|
| 6 | Description: winsock utilities.
|
|---|
| 7 | Current Release: Version 1.1 Patch 40 (January 7, 2005))
|
|---|
| 8 | *************************************************************** }
|
|---|
| 9 |
|
|---|
| 10 |
|
|---|
| 11 | unit RpcNet ;
|
|---|
| 12 | {
|
|---|
| 13 | Changes in v1.1.13 (JLI -- 8/23/00) -- XWB*1.1*13
|
|---|
| 14 | Made changes to cursor dependent on current cursor being crDefault so
|
|---|
| 15 | that the application can set it to a different cursor for long or
|
|---|
| 16 | repeated processes without the cursor 'flashing' repeatedly.
|
|---|
| 17 | }
|
|---|
| 18 | interface
|
|---|
| 19 |
|
|---|
| 20 | uses
|
|---|
| 21 | SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
|
|---|
| 22 | Forms, Dialogs, winsock;
|
|---|
| 23 |
|
|---|
| 24 | Const XWB_GHIP = WM_USER + 10000;
|
|---|
| 25 | //Const XWB_SELECT = WM_USER + 10001;
|
|---|
| 26 |
|
|---|
| 27 | Const WINSOCK1_1 = $0101;
|
|---|
| 28 | Const PF_INET = 2;
|
|---|
| 29 | Const SOCK_STREAM = 1;
|
|---|
| 30 | Const IPPROTO_TCP = 6;
|
|---|
| 31 | Const INVALID_SOCKET = -1;
|
|---|
| 32 | Const SOCKET_ERROR = -1;
|
|---|
| 33 | Const FIONREAD = $4004667F;
|
|---|
| 34 | Const ActiveConnection: boolean = False;
|
|---|
| 35 |
|
|---|
| 36 | type EchatError = class(Exception);
|
|---|
| 37 |
|
|---|
| 38 | type
|
|---|
| 39 | TRPCFRM1 = class(TForm)
|
|---|
| 40 | private
|
|---|
| 41 | { Private declarations }
|
|---|
| 42 | public
|
|---|
| 43 | { Public declarations }
|
|---|
| 44 | procedure XWBGHIP(var msgSock: TMessage);
|
|---|
| 45 | //procedure xwbSelect(var msgSock: TMessage); //P14
|
|---|
| 46 | procedure WndProc(var Message : TMessage); reintroduce; //P14
|
|---|
| 47 | end;
|
|---|
| 48 |
|
|---|
| 49 | type
|
|---|
| 50 | WinTaskRec = record
|
|---|
| 51 | InUse: boolean;
|
|---|
| 52 | pTCPResult: Pointer;
|
|---|
| 53 | strTemp: string; {generic output string for async calls}
|
|---|
| 54 | chrTemp: PChar; {generic out PChar for async calls}
|
|---|
| 55 | hTCP: THandle; {pseudo handle for async calls}
|
|---|
| 56 | hWin: hWnd; {handle for owner window}
|
|---|
| 57 | CallWait: boolean;
|
|---|
| 58 | CallAbort: boolean;
|
|---|
| 59 | RPCFRM1: TRPCFRM1;
|
|---|
| 60 | end;
|
|---|
| 61 |
|
|---|
| 62 | var
|
|---|
| 63 | WRec: array[1..128] of WinTaskRec;
|
|---|
| 64 | Hash: array[0..159] of char;
|
|---|
| 65 |
|
|---|
| 66 | {Windows OS abstraction functions. Should be taken over by VA Kernel}
|
|---|
| 67 |
|
|---|
| 68 | function libGetCurrentProcess: word;
|
|---|
| 69 |
|
|---|
| 70 | {Socket functions using library RPCLIB.DLL, in this case called locally}
|
|---|
| 71 |
|
|---|
| 72 | //function libAbortCall(inst: integer): integer; export; //P14
|
|---|
| 73 | function libGetHostIP1(inst: integer; HostName: PChar;
|
|---|
| 74 | var outcome: PChar): integer; export;
|
|---|
| 75 | function libGetLocalIP(inst: integer; var outcome: PChar): integer; export;
|
|---|
| 76 | procedure libClose(inst: integer); export;
|
|---|
| 77 | function libOpen:integer; export;
|
|---|
| 78 |
|
|---|
| 79 | function GetTCPError:string;
|
|---|
| 80 |
|
|---|
| 81 | {Secure Hash Algorithm functions, library SHA.DLL and local interfaces}
|
|---|
| 82 |
|
|---|
| 83 | function libGetLocalModule: PChar; export;
|
|---|
| 84 | function GetFileHash(fn: PChar): longint; export;
|
|---|
| 85 |
|
|---|
| 86 | implementation
|
|---|
| 87 |
|
|---|
| 88 | uses rpcconf1;
|
|---|
| 89 |
|
|---|
| 90 | {function shsTest: integer; far; external 'SHA';
|
|---|
| 91 | procedure shsHash(plain: PChar; size: integer;
|
|---|
| 92 | Hash: PChar); far; external 'SHA';} //Removed in P14
|
|---|
| 93 |
|
|---|
| 94 | {$R *.DFM}
|
|---|
| 95 |
|
|---|
| 96 |
|
|---|
| 97 |
|
|---|
| 98 | function libGetCurrentProcess: word;
|
|---|
| 99 | begin
|
|---|
| 100 | Result := GetCurrentProcess;
|
|---|
| 101 | end;
|
|---|
| 102 |
|
|---|
| 103 | function libGetLocalIP(inst: integer; var outcome: PChar): integer;
|
|---|
| 104 | var
|
|---|
| 105 | local: PChar;
|
|---|
| 106 | begin
|
|---|
| 107 | local := StrAlloc(255);
|
|---|
| 108 | gethostname( local, 255);
|
|---|
| 109 | Result := libGetHostIP1(inst, local, outcome);
|
|---|
| 110 | StrDispose(local);
|
|---|
| 111 | end;
|
|---|
| 112 |
|
|---|
| 113 | function libGetLocalModule: PChar;
|
|---|
| 114 | var
|
|---|
| 115 | tsk: THandle;
|
|---|
| 116 | name: PChar;
|
|---|
| 117 | begin
|
|---|
| 118 | tsk := GetCurrentProcess;
|
|---|
| 119 | name := StrAlloc(1024);
|
|---|
| 120 | GetModuleFilename(tsk, name, 1024);
|
|---|
| 121 | Result := name;
|
|---|
| 122 |
|
|---|
| 123 | end;
|
|---|
| 124 |
|
|---|
| 125 | function GetFileHash(fn: PChar): longint;
|
|---|
| 126 | var
|
|---|
| 127 | hFn: integer;
|
|---|
| 128 | finfo: TOFSTRUCT;
|
|---|
| 129 | bytesRead, status: longint;
|
|---|
| 130 | tBuf: PChar;
|
|---|
| 131 |
|
|---|
| 132 | begin
|
|---|
| 133 | tBuf := StrAlloc(160);
|
|---|
| 134 | hFn := OpenFile(fn, finfo, OF_READ);
|
|---|
| 135 | bytesRead := 0;
|
|---|
| 136 | status := _lread(hFn, tBuf, sizeof(tBuf));
|
|---|
| 137 | while status <> 0 do
|
|---|
| 138 | begin
|
|---|
| 139 | status := _lread(hFn, tBuf, sizeof(tBuf));
|
|---|
| 140 | inc(bytesRead,status);
|
|---|
| 141 | end;
|
|---|
| 142 | _lclose(hFn);
|
|---|
| 143 | StrDispose(tBuf);
|
|---|
| 144 | Result := bytesRead;
|
|---|
| 145 | end;
|
|---|
| 146 |
|
|---|
| 147 | function libOpen:integer;
|
|---|
| 148 | var
|
|---|
| 149 | inst: integer;
|
|---|
| 150 | WSData: TWSADATA;
|
|---|
| 151 | RPCFRM1: TRPCFRM1;
|
|---|
| 152 | begin
|
|---|
| 153 | inst := 1; {in this case, no DLL so instance is always 1}
|
|---|
| 154 | RPCFRM1 := TRPCFRM1.Create(nil); //P14
|
|---|
| 155 | with WRec[inst] do
|
|---|
| 156 | begin
|
|---|
| 157 | hWin := AllocateHWnd(RPCFRM1.wndproc);
|
|---|
| 158 |
|
|---|
| 159 | WSAStartUp(WINSOCK1_1, WSData);
|
|---|
| 160 | WSAUnhookBlockingHook;
|
|---|
| 161 |
|
|---|
| 162 | Result := inst;
|
|---|
| 163 | InUse := True;
|
|---|
| 164 | end;
|
|---|
| 165 | RPCFRM1.Release; //P14
|
|---|
| 166 | end;
|
|---|
| 167 |
|
|---|
| 168 | procedure libClose(inst: integer);
|
|---|
| 169 | begin
|
|---|
| 170 |
|
|---|
| 171 | with WRec[inst] do
|
|---|
| 172 | begin
|
|---|
| 173 | InUse := False;
|
|---|
| 174 | WSACleanup;
|
|---|
| 175 | DeallocateHWnd(hWin);
|
|---|
| 176 | end;
|
|---|
| 177 | end;
|
|---|
| 178 |
|
|---|
| 179 | function libGetHostIP1(inst: integer; HostName: PChar;
|
|---|
| 180 | var outcome: PChar): integer;
|
|---|
| 181 | var
|
|---|
| 182 | //RPCFRM1: TRPCFRM1; {P14}
|
|---|
| 183 | //wMsg: TMSG; {P14}
|
|---|
| 184 | //hWnd: THandle; {P14}
|
|---|
| 185 | ChangeCursor: Boolean;
|
|---|
| 186 |
|
|---|
| 187 | begin
|
|---|
| 188 |
|
|---|
| 189 | outcome[0] := #0;
|
|---|
| 190 |
|
|---|
| 191 | if Screen.Cursor = crDefault then
|
|---|
| 192 | ChangeCursor := True
|
|---|
| 193 | else
|
|---|
| 194 | ChangeCursor := False;
|
|---|
| 195 | if ChangeCursor then
|
|---|
| 196 | Screen.Cursor := crHourGlass;
|
|---|
| 197 |
|
|---|
| 198 | with WRec[inst] do
|
|---|
| 199 | begin
|
|---|
| 200 |
|
|---|
| 201 | if HostName[0] = #0 then
|
|---|
| 202 | begin
|
|---|
| 203 | StrCat(outcome,'No Name to Resolve!');
|
|---|
| 204 | Result := -1;
|
|---|
| 205 | exit;
|
|---|
| 206 | end;
|
|---|
| 207 |
|
|---|
| 208 | if CallWait = True then
|
|---|
| 209 | begin
|
|---|
| 210 | outcome[0] := #0;
|
|---|
| 211 | StrCat(outcome, 'Call in Progress');
|
|---|
| 212 | Result := -1;
|
|---|
| 213 | exit;
|
|---|
| 214 | end;
|
|---|
| 215 |
|
|---|
| 216 | if inet_addr(HostName) > INADDR_ANY then
|
|---|
| 217 | begin
|
|---|
| 218 | outcome := Hostname;
|
|---|
| 219 | Result := 0;
|
|---|
| 220 | if ChangeCursor then
|
|---|
| 221 | Screen.Cursor := crDefault;
|
|---|
| 222 | WSACleanup;
|
|---|
| 223 | exit;
|
|---|
| 224 | end;
|
|---|
| 225 |
|
|---|
| 226 | GetMem(pTCPResult, MAXGETHOSTSTRUCT+1);
|
|---|
| 227 | try
|
|---|
| 228 | begin
|
|---|
| 229 | CallWait := True;
|
|---|
| 230 | CallAbort := False;
|
|---|
| 231 | PHostEnt(pTCPResult)^.h_name := nil;
|
|---|
| 232 | hTCP := WSAAsyncGetHostByName(hWin, XWB_GHIP, HostName,
|
|---|
| 233 | pTCPResult, MAXGETHOSTSTRUCT );
|
|---|
| 234 | { loop while CallWait is True }
|
|---|
| 235 | CallAbort := False;
|
|---|
| 236 | while CallWait = True do
|
|---|
| 237 | Application.ProcessMessages;
|
|---|
| 238 | end;
|
|---|
| 239 | except on EInValidPointer do
|
|---|
| 240 | begin
|
|---|
| 241 | StrCat(outcome,'Error in GetHostByName');
|
|---|
| 242 | if ChangeCursor then
|
|---|
| 243 | Screen.Cursor := crDefault;
|
|---|
| 244 | end;
|
|---|
| 245 |
|
|---|
| 246 | end;
|
|---|
| 247 |
|
|---|
| 248 | FreeMem(pTCPResult, MAXGETHOSTSTRUCT+1);
|
|---|
| 249 | StrCopy(outcome,chrTemp);
|
|---|
| 250 | Result := 0;
|
|---|
| 251 | if ChangeCursor then
|
|---|
| 252 | Screen.Cursor := crDefault;
|
|---|
| 253 | end;
|
|---|
| 254 | end;
|
|---|
| 255 |
|
|---|
| 256 | (*procedure TRPCFRM1.XWBSELECT(var msgSock: TMessage);
|
|---|
| 257 | var
|
|---|
| 258 | noop: integer;
|
|---|
| 259 | begin
|
|---|
| 260 | case msgSock.lparam of
|
|---|
| 261 | FD_ACCEPT: {connection arrived}
|
|---|
| 262 | begin
|
|---|
| 263 | noop := 1;
|
|---|
| 264 | end;
|
|---|
| 265 | FD_CONNECT: {connection initiated}
|
|---|
| 266 | begin
|
|---|
| 267 | noop := 1;
|
|---|
| 268 | end;
|
|---|
| 269 | FD_READ: {data received, put in display}
|
|---|
| 270 | begin
|
|---|
| 271 | noop := 1;
|
|---|
| 272 | end;
|
|---|
| 273 | FD_CLOSE: {disconnection of accepted socket}
|
|---|
| 274 | begin
|
|---|
| 275 | noop := 1;
|
|---|
| 276 | end;
|
|---|
| 277 | else
|
|---|
| 278 | noop := 1;
|
|---|
| 279 | end;
|
|---|
| 280 | end;*) //Procedure removed in P14.
|
|---|
| 281 |
|
|---|
| 282 | procedure TRPCFRM1.WndProc(var Message : TMessage);
|
|---|
| 283 | begin
|
|---|
| 284 | with Message do
|
|---|
| 285 | case Msg of
|
|---|
| 286 | {XWB_SELECT : xwbSelect(Message);} //P14
|
|---|
| 287 | XWB_GHIP: xwbghip(Message);
|
|---|
| 288 | else
|
|---|
| 289 | DefWindowProc(WRec[1].hWin, Msg, wParam, lParam);
|
|---|
| 290 | {Inherited WndProc(Message);}
|
|---|
| 291 | end;
|
|---|
| 292 | end;
|
|---|
| 293 |
|
|---|
| 294 | procedure TRPCFRM1.XWBGHIP(var msgSock: TMessage);
|
|---|
| 295 | var
|
|---|
| 296 | TCPResult: PHostEnt;
|
|---|
| 297 | WSAError: integer;
|
|---|
| 298 | HostAddr: TSockaddr;
|
|---|
| 299 | inst: integer;
|
|---|
| 300 |
|
|---|
| 301 | begin
|
|---|
| 302 | inst := 1; {local case is always 1}
|
|---|
| 303 |
|
|---|
| 304 |
|
|---|
| 305 | with WRec[inst] do
|
|---|
| 306 | begin
|
|---|
| 307 |
|
|---|
| 308 | hTCP := msgSock.WParam;
|
|---|
| 309 |
|
|---|
| 310 | chrTemp := StrAlloc(512);
|
|---|
| 311 |
|
|---|
| 312 | CallWait := False;
|
|---|
| 313 | If CallAbort = True then { User aborted call }
|
|---|
| 314 | begin
|
|---|
| 315 | StrCopy(ChrTemp,'Abort!');
|
|---|
| 316 | exit;
|
|---|
| 317 | end;
|
|---|
| 318 |
|
|---|
| 319 | WSAError := WSAGetAsyncError(hTCP); { in case async call failed }
|
|---|
| 320 | If WSAError < 0 then
|
|---|
| 321 | begin
|
|---|
| 322 | StrPCopy(chrTemp,IntToStr(WSAError));
|
|---|
| 323 | exit;
|
|---|
| 324 | end;
|
|---|
| 325 |
|
|---|
| 326 | try
|
|---|
| 327 | begin
|
|---|
| 328 | TCPResult := PHostEnt(pTCPResult);
|
|---|
| 329 | StrTemp := '';
|
|---|
| 330 | if TCPResult^.h_name = nil then
|
|---|
| 331 | begin
|
|---|
| 332 | StrCopy(chrTemp, 'Unknown!');
|
|---|
| 333 | if rpcconfig <> nil then
|
|---|
| 334 | rpcconfig.panel4.Caption := StrPas(chrTemp);
|
|---|
| 335 | exit;
|
|---|
| 336 | end;
|
|---|
| 337 | {success, return resolved address}
|
|---|
| 338 | HostAddr.sin_addr.S_addr := longint(plongint(TCPResult^.h_addr_list^)^);
|
|---|
| 339 | chrTemp := inet_ntoa(HostAddr.sin_addr);
|
|---|
| 340 | end;
|
|---|
| 341 | except on EInValidPointer do StrCat(chrTemp, 'Error in GetHostByName');
|
|---|
| 342 | end;
|
|---|
| 343 | end;
|
|---|
| 344 | end;
|
|---|
| 345 |
|
|---|
| 346 | (*function libAbortCall(inst: integer): integer;
|
|---|
| 347 | var
|
|---|
| 348 | WSAError: integer;
|
|---|
| 349 | begin
|
|---|
| 350 |
|
|---|
| 351 | with WRec[inst] do
|
|---|
| 352 | begin
|
|---|
| 353 |
|
|---|
| 354 | WSAError := WSACancelAsyncRequest(hTCP);
|
|---|
| 355 | if WSAError = Socket_Error then
|
|---|
| 356 | begin
|
|---|
| 357 | WSAError := WSAGetLastError;
|
|---|
| 358 | CallWait := False;
|
|---|
| 359 | CallAbort := True;
|
|---|
| 360 | Result := WSAError;
|
|---|
| 361 | end;
|
|---|
| 362 |
|
|---|
| 363 | CallAbort := True;
|
|---|
| 364 | CallWait := False;
|
|---|
| 365 | Result := WSAError;
|
|---|
| 366 |
|
|---|
| 367 | end;
|
|---|
| 368 |
|
|---|
| 369 | end; *) //Removed in P14
|
|---|
| 370 |
|
|---|
| 371 | function GetTCPError:string;
|
|---|
| 372 | var
|
|---|
| 373 | x: string;
|
|---|
| 374 | r: integer;
|
|---|
| 375 |
|
|---|
| 376 | begin
|
|---|
| 377 | r := WSAGetLastError;
|
|---|
| 378 | Case r of
|
|---|
| 379 | WSAEINTR : x := 'WSAEINTR';
|
|---|
| 380 | WSAEBADF : x := 'WSAEINTR';
|
|---|
| 381 | WSAEFAULT : x := 'WSAEFAULT';
|
|---|
| 382 | WSAEINVAL : x := 'WSAEINVAL';
|
|---|
| 383 | WSAEMFILE : x := 'WSAEMFILE';
|
|---|
| 384 | WSAEWOULDBLOCK : x := 'WSAEWOULDBLOCK';
|
|---|
| 385 | WSAEINPROGRESS : x := 'WSAEINPROGRESS';
|
|---|
| 386 | WSAEALREADY : x := 'WSAEALREADY';
|
|---|
| 387 | WSAENOTSOCK : x := 'WSAENOTSOCK';
|
|---|
| 388 | WSAEDESTADDRREQ : x := 'WSAEDESTADDRREQ';
|
|---|
| 389 | WSAEMSGSIZE : x := 'WSAEMSGSIZE';
|
|---|
| 390 | WSAEPROTOTYPE : x := 'WSAEPROTOTYPE';
|
|---|
| 391 | WSAENOPROTOOPT : x := 'WSAENOPROTOOPT';
|
|---|
| 392 | WSAEPROTONOSUPPORT : x := 'WSAEPROTONOSUPPORT';
|
|---|
| 393 | WSAESOCKTNOSUPPORT : x := 'WSAESOCKTNOSUPPORT';
|
|---|
| 394 | WSAEOPNOTSUPP : x := 'WSAEOPNOTSUPP';
|
|---|
| 395 | WSAEPFNOSUPPORT : x := 'WSAEPFNOSUPPORT';
|
|---|
| 396 | WSAEAFNOSUPPORT : x := 'WSAEAFNOSUPPORT';
|
|---|
| 397 | WSAEADDRINUSE : x := 'WSAEADDRINUSE';
|
|---|
| 398 | WSAEADDRNOTAVAIL : x := 'WSAEADDRNOTAVAIL';
|
|---|
| 399 | WSAENETDOWN : x := 'WSAENETDOWN';
|
|---|
| 400 | WSAENETUNREACH : x := 'WSAENETUNREACH';
|
|---|
| 401 | WSAENETRESET : x := 'WSAENETRESET';
|
|---|
| 402 | WSAECONNABORTED : x := 'WSAECONNABORTED';
|
|---|
| 403 | WSAECONNRESET : x := 'WSAECONNRESET';
|
|---|
| 404 | WSAENOBUFS : x := 'WSAENOBUFS';
|
|---|
| 405 | WSAEISCONN : x := 'WSAEISCONN';
|
|---|
| 406 | WSAENOTCONN : x := 'WSAENOTCONN';
|
|---|
| 407 | WSAESHUTDOWN : x := 'WSAESHUTDOWN';
|
|---|
| 408 | WSAETOOMANYREFS : x := 'WSAETOOMANYREFS';
|
|---|
| 409 | WSAETIMEDOUT : x := 'WSAETIMEDOUT';
|
|---|
| 410 | WSAECONNREFUSED : x := 'WSAECONNREFUSED';
|
|---|
| 411 | WSAELOOP : x := 'WSAELOOP';
|
|---|
| 412 | WSAENAMETOOLONG : x := 'WSAENAMETOOLONG';
|
|---|
| 413 | WSAEHOSTDOWN : x := 'WSAEHOSTDOWN';
|
|---|
| 414 | WSAEHOSTUNREACH : x := 'WSAEHOSTUNREACH';
|
|---|
| 415 | WSAENOTEMPTY : x := 'WSAENOTEMPTY';
|
|---|
| 416 | WSAEPROCLIM : x := 'WSAEPROCLIM';
|
|---|
| 417 | WSAEUSERS : x := 'WSAEUSERS';
|
|---|
| 418 | WSAEDQUOT : x := 'WSAEDQUOT';
|
|---|
| 419 | WSAESTALE : x := 'WSAESTALE';
|
|---|
| 420 | WSAEREMOTE : x := 'WSAEREMOTE';
|
|---|
| 421 | WSASYSNOTREADY : x := 'WSASYSNOTREADY';
|
|---|
| 422 | WSAVERNOTSUPPORTED : x := 'WSAVERNOTSUPPORTED';
|
|---|
| 423 | WSANOTINITIALISED : x := 'WSANOTINITIALISED';
|
|---|
| 424 | WSAHOST_NOT_FOUND : x := 'WSAHOST_NOT_FOUND';
|
|---|
| 425 | WSATRY_AGAIN : x := 'WSATRY_AGAIN';
|
|---|
| 426 | WSANO_RECOVERY : x := 'WSANO_RECOVERY';
|
|---|
| 427 | WSANO_DATA : x := 'WSANO_DATA';
|
|---|
| 428 |
|
|---|
| 429 | else x := 'Unknown Error';
|
|---|
| 430 | end;
|
|---|
| 431 | Result := x + ' (' + IntToStr(r) + ')';
|
|---|
| 432 | end;
|
|---|
| 433 |
|
|---|
| 434 |
|
|---|
| 435 | end.
|
|---|
