source: cprs/branches/GUI-config/BDK32/Source/Wsockc.pas@ 881

Last change on this file since 881 was 476, checked in by Kevin Toppenberg, 16 years ago

New WorldVistA Config Utility
File size: 52.9 KB
RevLine 
[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: manages Winsock connections and creates/parses
7 messages
8 Current Release: Version 1.1 Patch 40 (Sept. 22, 2004)
9*************************************************************** }
10
11unit Wsockc;
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 Changes in v1.1.8 (REM -- 6/18/99) -- XWB*1.1*8
19 Update version 'BrokerVer'.
20
21 Changes in v1.1.6 (DPC -- 6/7/99) -- XWB*1.1*6
22 In tCall function, made changing cursor to hourglass conditional:
23 don't do it if XWB IM HERE RPC is being invoked.
24
25 Changes in V1.1.4 (DCM - 9/18/98)-XWB*1.1*4
26 1. Changed the ff line in NetStart from:
27 if inet_addr(PChar(Server)) <> INADDR_NONE then
28 to
29 if inet_addr(PChar(Server)) <> longint(INADDR_NONE) then
30 Reason: true 64 bit types in Delphi 4
31 2. Changed the ff line in NetStart from:
32 $else
33 hSocket := accept(hSocketListen, DHCPHost, AddrLen);{ -- returns new socket
34 to
35 $else
36 hSocket := accept(hSocketListen, @DHCPHost, @AddrLen);{ -- returns new socket
37 Reason: Incompatible types when recompiling
38 3. In NetStop, if socket <= 0, restore the default cursor.
39 Reason: Gave the impression of a busy process after the Kernel login
40 process timesout.
41
42 Changes in V1.1T3 [Feb 5, 1997]
43 1. Connect string now includes workstation name. This is used by kernel
44 security.
45 2. Code is 32bit compliant for Delphi 2.0
46 3. A great majority of PChars changed to default string (ansi-string)
47 4. Reading is done in 32k chunks during a loop. Intermediate data is
48 buffered into a string. At the end, a PChar is allocated and
49 returned to maintain compatibility with the original broker interface.
50 It is expected that shortly this will change once the broker component
51 changes its usage of tcall to expect a string return. Total read
52 can now exceed 32K up to workstation OS limits.
53 5. Creation of Hostent and Address structures has been streamlined.
54
55 Changes in V1.0T12
56 1. Inclusion of hSocket as a parameter on most API calls
57
58
59 Changes in V1.0T11
60 1. Reference parameter type is included. i.e. $J will be evaluated rather
61 than sending "$J".
62 2. Fully integrated with the TRPCB component interface.
63 3. This low level module is now called from an intermediate DLL.
64
65 Changes in V1.0T10
66 1. Fixed various memory leaks.
67
68 Changes in V1.0T9
69 1. Supports word processing fields.
70 2. Added a new exception type EBrokerError. This is raised when errors occur
71 in NetCall, NetworkConnect, and NetworkDisconnect
72
73 Changes in V1.0T8
74 1. Fix a problem in BuildPar in the case of a single list parameter with many
75 entries.
76 2. List parameters (arrays) can be large up to 65520 bytes
77 3. Introduction of sCallV and tCallV which use the Delphi Pascal open array
78 syntax (sCallFV and tCallV developed by Kevin Meldrum)
79 4. A new brokerDataRec type, null has been introduced to represent M calls
80 with no parameters, i.e. D FUN^LIB().
81 5. If you want to send a null parameter "", i.e. D FUN^LIB(""), Value
82 should be set to ''.
83 6. Fixed bug where a single ^ passed to sCall would generate error (confused
84 as a global reference.
85 7. Fixed a bug where a first position dot (.) in a literal parameter would
86 cause an error at the server end.
87 8. Fixed a bug where null strings (as white space in a memo box for example)
88 would not be correctly received at the server.
89
90 Changes in V1.0T7
91 1. Procedure NetworkConnect has been changed to Function NetworkConnect
92 returning BOOL
93 2. global variable IsConnected (BOOL) can be used to determine connection
94 state
95 3. Function cRight has been fixed to preserve head pointer to input PChar
96 string
97 4. New message format which includes length calculations for input parameters
98
99 *******************************************************************
100 A 32-bit high level interface to the Winsock API in Delphi Pascal.
101
102 This implementation allows communications between Delphi forms and
103 DHCP back end servers through the use of the DHCP Request Broker.
104
105 Usage: Put wsock in your Uses clause of your Delphi form. See additional
106 specs for Request Broker message formats, etc.
107 Programmer: Enrique Gomez - VA San Francisco ISC - April 1995
108}
109
110
111interface
112
113Uses
114SysUtils, winsock, xwbut1, WinProcs, Wintypes,
115classes, dialogs, forms, controls,
116stdctrls, ClipBrd, Trpcb, RpcbErr;
117
118type
119 TXWBWinsock = class(TObject)
120 private
121 FCountWidth: Integer;
122 FIsBackwardsCompatible: Boolean;
123 FOldConnectionOnly: Boolean;
124 public
125 XNetCallPending, xFlush: boolean;
126 SocketError, XHookTimeOut: integer;
127 XNetTimerStart: TDateTime;
128 BROKERSERVER: string;
129 SecuritySegment, ApplicationSegment: string;
130 IsConnected: Boolean;
131// NetBlockingHookVar: Function(): Bool; export;
132 function NetCall(hSocket: integer; imsg: string): PChar;
133 function tCall(hSocket: integer; api, apVer: String; Parameters: TParams;
134 var Sec, App: PChar; TimeOut: integer): PChar;
135 function cRight( z: PChar; n: longint): PChar;
136 function cLeft( z: PChar; n: longint): PChar;
137 function BuildApi ( n,p: string; f: longint): string;
138 function BuildHdr ( wkid: string; winh: string; prch: string;
139 wish: string): string;
140 function BuildPar(hSocket: integer; api, RPCVer: string;
141 const Parameters: TParams): string;
142 function StrPack ( n: string; p: integer): string;
143 function VarPack(n: string): string;
144 function NetStart(ForegroundM: boolean; Server: string; ListenerPort: integer;
145 var hSocket: integer): integer;
146 function NetworkConnect(ForegroundM: boolean; Server: string; ListenerPort,
147 TimeOut: integer): Integer;
148 function libSynGetHostIP(s: string): string;
149 function libNetCreate (lpWSData : TWSAData) : integer;
150 function libNetDestroy: integer;
151 function GetServerPacket(hSocket: integer): string;
152// function NetBlockingHook: BOOL; export;
153
154 procedure NetworkDisconnect(hSocket: integer);
155 procedure NetStop(hSocket: integer);
156 procedure CloseSockSystem(hSocket: integer; s: string);
157 constructor Create;
158
159 procedure NetError(Action: string; ErrType: integer);
160function NetStart1(ForegroundM: boolean; Server: string; ListenerPort: integer;
161 var hSocket: integer): Integer; virtual;
162 function BuildPar1(hSocket: integer; api, RPCVer: string; const Parameters:
163 TParams): String; virtual;
164 property CountWidth: Integer read FCountWidth write FCountWidth;
165 property IsBackwardsCompatible: Boolean read FIsBackwardsCompatible write
166 FIsBackwardsCompatible;
167 property OldConnectionOnly: Boolean read FOldConnectionOnly write
168 FOldConnectionOnly;
169 end;
170
171function LPack(Str: String; NDigits: Integer): String;
172
173function SPack(Str: String): String;
174
175function NetBlockingHook: BOOL; export;
176
177var
178 HookTimeOut: Integer;
179 NetCallPending: Boolean;
180 NetTimerStart: TDateTime;
181
182Const
183 WINSOCK1_1 = $0101;
184 DHCP_NAME = 'BROKERSERVER';
185 M_DEBUG = True;
186 M_NORMAL = False;
187 BrokerVer = '1.108';
188 Buffer64K = 65520;
189 Buffer32K = 32767;
190 Buffer24K = 24576;
191 Buffer16K = 16384;
192 Buffer8K = 8192;
193 Buffer4K = 4096;
194 DefBuffer = 256;
195 DebugOn: boolean = False;
196 XWBBASEERR = {WSABASEERR + 1} 20000;
197
198{Broker Application Error Constants}
199 XWB_NO_HEAP = XWBBASEERR + 1;
200 XWB_M_REJECT = XWBBASEERR + 2;
201 XWB_BadSignOn = XWBBASEERR + 4;
202 XWB_BadReads = XWBBASEERR + 8;
203 XWB_ExeNoMem = XWBBASEERR + 100;
204 XWB_ExeNoFile = XWB_ExeNoMem + 2;
205 XWB_ExeNoPath = XWB_ExeNoMem + 3;
206 XWB_ExeShare = XWB_ExeNoMem + 5;
207 XWB_ExeSepSeg = XWB_ExeNoMem + 6;
208 XWB_ExeLoMem = XWB_ExeNoMem + 8;
209 XWB_ExeWinVer = XWB_ExeNoMem + 10;
210 XWB_ExeBadExe = XWB_ExeNoMem + 11;
211 XWB_ExeDifOS = XWB_ExeNoMem + 12;
212 XWB_RpcNotReg = XWBBASEERR + 201;
213
214implementation
215
216 uses fDebugInfo; {P36} //, TRPCB;
217
218var
219 Prefix: String;
220
221{
222 function LPack
223 Prepends the length of the string in NDigits characters to the value of Str
224
225 e.g., LPack('DataValue',4)
226 returns '0009DataValue'
227}
228function LPack(Str: String; NDigits: Integer): String;
229Var
230 r: Integer;
231 t: String;
232 Width: Integer;
233 Ex1: Exception;
234begin
235 r := Length(Str);
236 // check for enough space in NDigits characters
237 t := IntToStr(r);
238 Width := Length(t);
239 if NDigits < Width then
240 begin
241 Ex1 := Exception.Create('In generation of message to server, call to LPack where Length of string of '+IntToStr(Width)+' chars exceeds number of chars for output length ('+IntToStr(NDigits)+')');
242 Raise Ex1;
243 end;
244 t := '000000000' + IntToStr(r); {eg 11-1-96}
245 Result := Copy(t, length(t)-(NDigits-1),length(t)) + Str;
246end;
247
248{
249 function SPack
250 Prepends the length of the string in one byte to the value of Str, thus Str must be less than 256 characters.
251
252 e.g., SPack('DataValue')
253 returns #9 + 'DataValue'
254}
255function SPack(Str: String): String;
256Var
257 r: Integer;
258 Ex1: Exception;
259begin
260 r := Length(Str);
261 // check for enough space in one byte
262 if r > 255 then
263 begin
264 Ex1 := Exception.Create('In generation of message to server, call to SPack with Length of string of '+IntToStr(r)+' chars which exceeds max of 255 chars');
265 Raise Ex1;
266 end;
267// t := Byte(r);
268 Result := Char(r) + Str;
269end;
270
271
272function TXWBWinsock.libNetCreate (lpWSData : TWSAData) : integer;
273begin
274 Result := WSAStartup(WINSOCK1_1, lpWSData); {hard coded for Winsock
275 version 1.1}
276end;
277
278function TXWBWinsock.libNetDestroy :integer;
279begin
280 WSAUnhookBlockingHook; { -- restore the default mechanism};
281 WSACleanup; { -- shutdown TCP API};
282 Result := 1;
283end;
284
285function TXWBWinsock.libSynGetHostIP(s: string): string;
286var
287 HostName: PChar;
288 HostAddr: TSockAddr;
289 TCPResult: PHostEnt;
290 test: longint;
291 ChangeCursor: Boolean;
292begin
293 { -- set up a hook for blocking calls so there is no automatic DoEvents
294 in the background }
295 xFlush := False;
296 NetTimerStart := Now;
297 NetCallPending := True;
298 HookTimeOut := XHookTimeOut;
299 WSASetBlockingHook(@NetBlockingHook);
300
301 if Screen.Cursor = crDefault then
302 ChangeCursor := True
303 else
304 ChangeCursor := False;
305 if ChangeCursor then
306 Screen.Cursor := crHourGlass;
307 HostName := StrNew(PChar(s));
308 test := inet_addr(HostName);
309 if test > INADDR_ANY then
310 begin
311 Result := s;
312 StrDispose(Hostname);
313 if ChangeCursor then
314 Screen.Cursor := crDefault;
315 exit;
316 end;
317
318 try
319 begin
320 TCPResult := gethostbyname(HostName);
321 if TCPResult = nil then
322 begin
323 if ChangeCursor then
324 Screen.Cursor := crDefault;
325 WSAUnhookBlockingHook;
326 Result := '';
327 StrDispose(HostName);
328 exit;
329 end;
330
331 HostAddr.sin_addr.S_addr := longint(plongint(TCPResult^.h_addr_list^)^);
332
333 end;
334 except on EInvalidPointer do
335 begin
336 Result := '';
337 Screen.Cursor := crDefault;
338 StrDispose(HostName);
339 exit;
340 end;
341 end;
342 if ChangeCursor then
343 Screen.Cursor := crDefault;
344 WSAUnhookBlockingHook;
345 Result := StrPas(inet_ntoa(HostAddr.sin_addr));
346 StrDispose(HostName);
347end;
348
349function TXWBWinsock.cRight;
350var
351 i,t: longint;
352begin
353 t := strlen(z);
354 if n < t then
355 begin
356 for i := 0 to n do
357 z[i] := z[t-n+i];
358 z[n] := chr(0);
359 end;
360 cRight := z;
361end;
362
363function TXWBWinsock.cLeft;
364var
365 t: longint;
366begin
367 t := strlen(z);
368 if n > t then n := t;
369 z[n] := chr(0);
370 cLeft := z;
371end;
372
373function TXWBWinsock.BuildApi ( n,p: string; f: longint): string;
374Var
375 x,s: string;
376begin
377 str(f,x);
378 s := StrPack(p,5);
379 result := StrPack(x + n + '^' + s,5);
380end;
381
382function TXWBWinsock.NetworkConnect(ForegroundM: boolean; Server: string;
383 ListenerPort, TimeOut: integer): Integer;
384var
385 status: integer;
386 hSocket: integer;
387 BrokerError: EBrokerError;
388begin
389 Prefix := '[XWB]';
390 xFlush := False;
391 IsConnected := False;
392 XHookTimeOut := TimeOut;
393 if not OldConnectionOnly then
394 try
395 status := NetStart(ForeGroundM, server, ListenerPort, hSocket);
396 except
397 on E: EBrokerError do
398 begin
399 if IsBackwardsCompatible then // remove DSM specific error message, and just go with any error
400 begin
401 status := NetStart1(ForeGroundM, server, ListenerPort, hSocket);
402 end
403 else if ((Pos('connection lost',E.Message) > 0) // DSM
404 or ((Pos('recv',E.Message) > 0) and (Pos('WSAECONNRESET',E.Message) > 0))) then // Cache
405 begin
406 BrokerError := EBrokerError.Create('Broker requires a UCX or single connection protocol and this port uses the callback protocol.'+' The application is specified to be non-backwards compatible. Installing patch XWB*1.1*35 and activating this port number for UCX connections will correct the problem.');
407 raise BrokerError;
408 end
409 else
410 raise;
411 end;
412 end
413 else // OldConnectionOnly
414 status := NetStart1(ForeGroundM, server, ListenerPort, hSocket);
415
416 if status = 0 then IsConnected := True;
417 Result := hSocket; {return the newly established socket}
418end;
419
420procedure TXWBWinsock.NetworkDisconnect(hSocket: integer);
421begin
422 xFlush := False;
423 if IsConnected then
424 try
425 NetStop(hSocket);
426 except on EBrokerError do
427 begin
428 SocketError := WSAUnhookBlockingHook; { -- rest deflt mechanism}
429 SocketError := WSACleanup; { -- shutdown TCP API}
430 end;
431 end;
432
433end;
434
435function TXWBWinsock.BuildHdr ( wkid: string; winh: string; prch: string;
436 wish: string): string;
437Var
438 t: string;
439begin
440 t := wkid + ';' + winh + ';' + prch + ';' + wish + ';';
441 Result := StrPack(t,3);
442end;
443
444function TXWBWinsock.BuildPar(hSocket: integer; api, RPCVer: string;
445 const Parameters: TParams): string;
446var
447 i,ParamCount: integer;
448 param: string;
449 tResult: string;
450 subscript: string;
451 IsSeen: Boolean;
452 BrokerError: EBrokerError;
453 Str: String;
454begin
455 param := '5';
456 if Parameters = nil then ParamCount := 0
457 else ParamCount := Parameters.Count;
458 for i := 0 to ParamCount - 1 do
459 begin
460 if Parameters[i].PType <> undefined then
461 begin
462 // Make sure that new parameter types are only used with non-callback server.
463 if IsBackwardsCompatible and ((Parameters[i].PType = global) or (Parameters[i].PType = empty) or (Parameters[i].PType = stream)) then
464 begin
465 if Parameters[i].PType = global then
466 Str := 'global'
467 else if Parameters[i].PType = empty then
468 Str := 'empty'
469 else
470 Str := 'stream';
471 BrokerError := EBrokerError.Create('Use of ' + Str + ' parameter type requires setting the TRPCBroker IsBackwardsCompatible property to FALSE');
472 raise BrokerError;
473 end;
474 with Parameters[i] do
475 begin
476// if PType= null then
477// param:='';
478
479 if PType = literal then
480 param := param + '0'+LPack(Value,CountWidth)+'f'; // 030107 new message protocol
481
482 if PType = reference then
483 param := param + '1'+LPack(Value,CountWidth)+'f'; // 030107 new message protocol
484
485 if PType = empty then
486 param := param + '4f';
487
488 if (PType = list) or (PType = global) then
489 begin
490 if PType = list then // 030107 new message protocol
491 param := param + '2'
492 else
493 param := param + '3';
494 IsSeen := False;
495 subscript := Mult.First;
496 while subscript <> '' do
497 begin
498 if IsSeen then
499 param := param + 't';
500 if Mult[subscript] = '' then
501 Mult[subscript] := #1;
502 param := param + LPack(subscript,CountWidth)+LPack(Mult[subscript],CountWidth);
503 IsSeen := True;
504 subscript := Mult.Order(subscript,1);
505 end; // while subscript <> ''
506 if not IsSeen then // 040922 added to take care of list/global parameters with no values
507 param := param + LPack('',CountWidth);
508 param := param + 'f';
509 end;
510 if PType = stream then
511 begin
512 param := param + '5' + LPack(Value,CountWidth) + 'f';
513 end;
514 end; // with Parameters[i] do
515 end; // if Parameters[i].PType <> undefined
516 end; // for i := 0
517 if param = '5' then
518 param := param + '4f';
519
520 tresult := Prefix + '11' + IntToStr(CountWidth) + '0' + '2' + SPack(RPCVer) + SPack(api) + param + #4;
521
522// Application.ProcessMessages; // removed 040716 jli not needed and may impact some programs
523
524 Result := tresult;
525end;
526{ // previous message protocol
527 sin := TStringList.Create;
528 sin.clear;
529 x := '';
530 param := '';
531 arr := 0;
532 if Parameters = nil then ParamCount := 0
533 else ParamCount := Parameters.Count;
534 for i := 0 to ParamCount - 1 do
535 if Parameters[i].PType <> undefined then begin
536 with Parameters[i] do begin
537
538// if PType= null then
539// param:='';
540
541 if PType = literal then
542 param := param + strpack('0' + Value,3);
543 if PType = reference then
544 param := param + strpack('1' + Value,3);
545 if (PType = list) or (PType = global) then begin
546 Value := '.x';
547 param := param + strpack('2' + Value,3);
548 if Pos('.',Value) >0 then
549 x := Copy(Value,2,length(Value));
550// if PType = wordproc then dec(last);
551 subscript := Mult.First;
552 while subscript <> '' do begin
553 if Mult[subscript] = '' then Mult[subscript] := #1;
554 sin.Add(StrPack(subscript,3) + StrPack(Mult[subscript],3));
555 subscript := Mult.Order(subscript,1);
556 end; // while
557 sin.Add('000');
558 arr := 1;
559 end; // if
560 end; // with
561 end; // if
562
563param := Copy(param,1,Length(param));
564tsize := 0;
565
566tResult := '';
567tout := '';
568
569hdr := BuildHdr('XWB','','','');
570strout := strpack(hdr + BuildApi(api,param,arr),5);
571num :=0;
572
573RPCVersion := '';
574RPCVersion := VarPack(RPCVer);
575
576if sin.Count-1 > 0 then num := sin.Count-1;
577
578if num > 0 then
579 begin
580 for i := 0 to num do
581 tsize := tsize + length(sin.strings[i]);
582 x := '00000' + IntToStr(tsize + length(strout)+ length(RPCVersion));
583 end;
584if num = 0 then
585 begin
586 x := '00000' + IntToStr(length(strout)+ length(RPCVersion));
587 end;
588
589psize := x;
590psize := Copy(psize,length(psize)-5,5);
591tResult := psize;
592tResult := ConCat(tResult, RPCVersion);
593tout := strout;
594tResult := ConCat(tResult, tout);
595
596if num > 0 then
597 begin
598 for i := 0 to num do
599 tResult := ConCat(tResult, sin.strings[i]);
600 end;
601
602sin.free;
603
604frmBrokerExample.Edit1.Text := tResult;
605
606Result := tResult; // return result
607end;
608}
609
610function TXWBWinsock.StrPack(n: string; p: integer): String;
611Var
612 s,l: integer;
613 t,x,zero: shortstring;
614 y: string;
615begin
616
617 s := Length(n);
618 fillchar(zero,p+1, '0');
619 SetLength(zero, p);
620 str(s,x);
621 t := zero + x;
622 l := length(x)+1;
623 y := Copy(t, l , p);
624 y := y + n;
625 Result := y;
626end;
627
628function TXWBWinsock.VarPack(n: string): string;
629var
630 s: integer;
631begin
632 if n = '' then
633 n := '0';
634 s := Length(n);
635 SetLength(Result, s+2);
636 Result := '|' + chr(s) + n;
637end;
638
639const
640 OneSecond = 0.000011574;
641
642function NetBlockingHook: BOOL;
643var
644 TimeOut: double;
645 //TimeOut = 30 * OneSecond;
646
647begin
648 if HookTimeOut > 0 then
649 TimeOut := HookTimeOut * OneSecond
650 else
651 TimeOut := OneSecond / 20;
652 Result := False;
653 if NetCallPending then
654 if Now > (NetTimerStart + TimeOut) then WSACancelBlockingCall;
655end;
656
657function TXWBWinsock.NetCall(hSocket: integer; imsg: string): PChar;
658var
659 BufSend, BufRecv, BufPtr: PChar;
660 sBuf: string;
661 OldTimeOut: integer;
662 BytesRead, BytesLeft, BytesTotal: longint;
663 TryNumber: Integer;
664 BadXfer: Boolean;
665 xString: String;
666begin
667
668 { -- clear receive buffer prior to sending rpc }
669 if xFlush = True then begin
670 OldTimeOut := HookTimeOut;
671 HookTimeOut := 0;
672 WSASetBlockingHook(@NetBlockingHook);
673 NetCallPending := True;
674 BufRecv := StrAlloc(Buffer32k);
675 NetTimerStart := Now;
676 BytesRead := recv(hSocket, BufRecv^, Buffer32k, 0);
677 if BytesRead > 0 then
678 while BufRecv[BytesRead-1] <> #4 do begin
679 BytesRead := recv(hSocket, BufRecv^, Buffer32k, 0);
680 end;
681 StrDispose(BufRecv);
682 xFlush := False;
683 //Buf := nil; //P14
684 HookTimeOut := OldTimeOut;
685 end;
686 { -- provide variables for blocking hook }
687
688 TryNumber := 0;
689 BadXfer := True;
690
691
692 { -- send message length + message to server }
693
694 //BytesTotal := length(Prefix) + length(imsg) + 1 // p14
695 //Buf := StrAlloc(BytesTotal);
696 //Buf[0] := #0;
697
698 if Prefix = '[XWB]' then
699 BufSend := StrNew(PChar({Prefix +} imsg)) //; //moved in P14
700 else
701 BufSend := StrNew(PChar({Prefix +} imsg));
702 BufRecv := StrAlloc(Buffer32k);
703 Result := PChar('');
704// try
705 while BadXfer and (TryNumber < 4) do
706 begin
707 NetCallPending := True;
708 NetTimerStart := Now;
709 TryNumber := TryNumber + 1;
710 BadXfer := False;
711 {Clipboard.SetTextBuf(buf);
712 ShowMessage('In Clipboard');}
713 SocketError := send(hSocket, BufSend^, StrLen(BufSend), 0);
714 if SocketError = SOCKET_ERROR then
715 NetError('send', 0);
716{
717 finally
718 StrDispose(Buf);
719 //Buf := nil; //P14
720 end;
721}
722 BufRecv[0] := #0;
723 try
724 BufPtr := BufRecv;
725 BytesLeft := Buffer32k;
726 BytesTotal := 0;
727
728 {Get Security and Application packets}
729 SecuritySegment := GetServerPacket(hSocket);
730 ApplicationSegment := GetServerPacket(hSocket);
731 sBuf := '';
732 { -- loop reading TCP buffer until server is finished sending reply }
733
734 repeat
735 BytesRead := recv(hSocket, BufPtr^, BytesLeft, 0);
736
737 if BytesRead > 0 then begin
738 if BufPtr[BytesRead-1] = #4 then
739 begin
740 sBuf := ConCat(sBuf, BufPtr);
741 end
742 else
743 begin
744 BufPtr[BytesRead] := #0;
745 sBuf := ConCat(sBuf, BufPtr);
746 end;
747 Inc(BytesTotal, BytesRead);
748 end;
749
750 if BytesRead <= 0 then
751 begin
752 if BytesRead = SOCKET_ERROR then
753 NetError('recv', 0)
754 else
755 NetError('connection lost', 0);
756 break;
757 end;
758 until BufPtr[BytesRead-1] = #4;
759 sBuf := Copy(sBuf, 1, BytesTotal - 1);
760 StrDispose(BufRecv);
761 BufRecv := StrAlloc(BytesTotal+1); // cause of many memory leaks
762 StrCopy(BufRecv, PChar(sBuf));
763 Result := BufRecv;
764 if ApplicationSegment = 'U411' then
765 BadXfer := True;
766 NetCallPending := False;
767 finally
768 sBuf := '';
769 end;
770 end;
771
772 if BadXfer then
773 begin
774 StrDispose(BufRecv);
775 NetError(StrPas('Repeated Incomplete Reads on the server'), XWB_BadReads);
776 Result := StrNew('');
777 end;
778
779 { -- if there was on error on the server, display the error code }
780
781 if Result[0] = #24 then
782 begin
783 xString := StrPas(@Result[1]);
784 StrDispose(BufRecv);
785 NetError(xString, XWB_M_REJECT);
786// NetCall := #0;
787 Result := StrNew('');
788 end;
789end;
790
791function TXWBWinsock.tCall(hSocket: integer; api, apVer: String; Parameters: TParams;
792 var Sec , App: PChar; TimeOut: integer ): PChar;
793var
794 tmp: string;
795 ChangeCursor: Boolean;
796begin
797 HookTimeOut := TimeOut;
798 if (string(Api) <> 'XWB IM HERE') and (Screen.Cursor = crDefault) then
799 ChangeCursor := True
800 else
801 ChangeCursor := False;
802 if ChangeCursor then
803 Screen.Cursor := crHourGlass; //P6
804
805 if Prefix = '[XWB]' then
806 tmp := BuildPar(hSocket, api, apVer, Parameters)
807 else
808 tmp := BuildPar1(hSocket, api, apVer, Parameters);
809
810// xFlush := True; // Have it clear input buffers prior to call
811 Result := NetCall(hSocket, tmp);
812 StrPCopy(Sec, SecuritySegment);
813 StrPCopy(App, ApplicationSegment);
814 if ChangeCursor then
815 Screen.Cursor := crDefault;
816end;
817
818
819function TXWBWinsock.NetStart (ForegroundM: boolean; Server: string;
820 ListenerPort: integer; var hSocket: integer): integer;
821Var
822 WinSockData: TWSADATA;
823 LocalHost, DHCPHost: TSockAddr;
824 LocalName, workstation, pDHCPName: string;
825 y, tmp, upArrow, rAccept, rLost: string;
826 tmpPchar: PChar;
827 pLocalname: array [0..255] of char;
828 r: integer;
829 HostBuf,DHCPBuf: PHostEnt;
830 lin: TLinger;
831 s_lin: array [0..3] of char absolute lin;
832 ChangeCursor: Boolean;
833begin
834{ ForegroundM is a boolean value, TRUE means the M handling process is
835 running interactively a pointer rather than passing address length
836 by value) }
837
838 { -- initialize Windows Sockets API for this task }
839 if Screen.Cursor = crDefault then
840 ChangeCursor := True
841 else
842 ChangeCursor := False;
843 if ChangeCursor then
844 Screen.Cursor := crHourGlass;
845 upArrow := string('^');
846 rAccept := string('accept');
847 rLost := string('(connection lost)');
848
849 SocketError := WSAStartup(WINSOCK1_1, WinSockData);
850 If SocketError >0 Then
851 NetError( 'WSAStartup',0);
852
853 { -- set up a hook for blocking calls so there is no automatic DoEvents
854 in the background }
855 NetCallPending := False;
856 if ForeGroundM = False then if WSASetBlockingHook(@NetBlockingHook) = nil
857 then NetError('WSASetBlockingHook',0);
858
859 { -- establish HostEnt and Address structure for local machine}
860 SocketError := gethostname(pLocalName, 255); { -- name of local system}
861 If SocketError >0 Then
862 NetError ('gethostname (local)',0);
863 HostBuf := gethostbyname(pLocalName); { -- info for local name}
864 If HostBuf = nil Then
865 NetError( 'gethostbyname',0);
866 LocalHost.sin_addr.S_addr := longint(plongint(HostBuf^.h_addr_list^)^);
867 LocalName := inet_ntoa(LocalHost.sin_addr);
868 workstation := string(HostBuf.h_name);
869
870 { -- establish HostEnt and Address structure for remote machine }
871 if inet_addr(PChar(Server)) <> longint(INADDR_NONE) then
872 begin
873 DHCPHost.sin_addr.S_addr := inet_addr(PChar(Server));
874 DHCPBuf := gethostbyaddr(@DHCPHost.sin_addr.S_addr,sizeof(DHCPHost),PF_INET);
875 end
876 else
877 DHCPBuf := gethostbyname(PChar(Server)); { -- info for DHCP system}
878
879 If DHCPBuf = nil Then
880 begin
881 { modification to take care of problems with 10-dot addresses that weren't registered - solution found by Shawn Hardenbrook }
882// NetError ('Error Identifying Remote Host ' + Server,0);
883// NetStart := 10001;
884// exit;
885 DHCPHost.sin_addr.S_addr := inet_addr(PChar(Server));
886 pDHCPName := 'UNKNOWN';
887 end
888 else
889 begin;
890 DHCPHost.sin_addr.S_addr := longint(plongint(DHCPBuf^.h_addr_list^)^);
891 pDHCPName := inet_ntoa(DHCPHost.sin_addr);
892 end;
893 DHCPHost.sin_family := PF_INET; { -- internet address type}
894 DHCPHost.sin_port := htons(ListenerPort); { -- port to connect to}
895
896 { -- make connection to DHCP }
897 hSocket := socket(PF_INET, SOCK_STREAM, IPPROTO_TCP);
898 If hSocket = INVALID_SOCKET Then
899 NetError( 'socket',0);
900
901 SocketError := connect(hSocket, DHCPHost, SizeOf(DHCPHost));
902 If SocketError = SOCKET_ERROR Then
903 NetError( 'connect',0);
904 HookTimeOut := 30;
905
906 { -- remove setup of hSocketListen
907
908// establish local IP now that connection is done
909 AddrLen := SizeOf(LocalHost);
910 SocketError := getsockname(hSocket, LocalHost, AddrLen);
911 if SocketError = SOCKET_ERROR then
912 NetError ('getsockname',0);
913 LocalName := inet_ntoa(LocalHost.sin_addr);
914
915// -- set up listening socket for DHCP return connect
916 hSocketListen := socket(PF_INET, SOCK_STREAM, IPPROTO_TCP); // -- new socket
917 If hSocketListen = INVALID_SOCKET Then
918 NetError ('socket (listening)',0);
919
920 LocalHost.sin_family := PF_INET; // -- internet address type
921 LocalHost.sin_port := 0; // -- local listening port
922 SocketError := bind(hSocketListen, LocalHost,
923 SizeOf(LocalHost)); // -- bind socket to address
924 If SocketError = SOCKET_ERROR Then
925 NetError( 'bind',0);
926
927 AddrLen := sizeof(LocalHost);
928 SocketError := getsockname(hSocketListen, LocalHost,
929 AddrLen); // -- get listening port #
930 If SocketError = SOCKET_ERROR Then
931 NetError( 'getsockname',0);
932 LocalPort := ntohs(LocalHost.sin_port); // -- put in proper byte order
933
934 SocketError := listen(hSocketListen, 1); // -- put socket in listen mode
935 If SocketError = SOCKET_ERROR Then
936 NetError( 'listen',0);
937}
938 { -- send IP address + port + workstation name and wait for OK : eg 1-30-97}
939{
940 RPCVersion := VarPack(BrokerVer); // eg 11-1-96
941 x := string('TCPconnect^');
942 x := ConCat(x, LocalName, upArrow); // local ip address
943 t := IntToStr(LocalPort); // callback port
944 x := ConCat(x, t, upArrow, workstation, upArrow); // workstation name
945 r := length(x) + length(RPCVersion) + 5;
946 t := string('00000') + IntToStr(r); // eg 11-1-96
947 y := Copy(t, length(t)-4,length(t));
948 y := ConCat(y, RPCVersion, StrPack(x,5)); // rpc version
949}
950 { new protocol 030107 }
951
952// y := '[XWB]10' +IntToStr(CountWidth)+ '0' + '4'+#$A+'TCPConnect50'+ LPack(LocalName,CountWidth)+'f0'+LPack(IntToStr(LocalPort),CountWidth)+'f0'+LPack(workstation,CountWidth)+'f'+#4;
953 y := Prefix + '10' +IntToStr(CountWidth)+ '0' + '4'+#$A +'TCPConnect50'+ LPack(LocalName,CountWidth)+'f0'+LPack(IntToStr(0),CountWidth)+'f0'+LPack(workstation,CountWidth)+'f'+#4;
954
955{ // need to remove selecting port etc from client, since it will now be handled on the server P36
956
957 if ForeGroundM = True then
958 begin
959 if ChangeCursor then
960 Screen.Cursor := crDefault;
961 t := 'Start M job D EN^XWBTCP' + #13 + #10 + 'Addr = ' +
962 LocalName + #13 + #10 + 'Port = ' + IntToStr(LocalPort);
963
964 frmDebugInfo := TfrmDebugInfo.Create(Application.MainForm);
965 try
966 frmDebugInfo.lblDebugInfo.Caption := t;
967 ShowApplicationAndFocusOK(Application);
968 frmDebugInfo.ShowModal;
969 finally
970 frmDebugInfo.Free
971 end;
972
973// ShowMessage(t); //TODO
974 end;
975} // remove debug mode from client
976
977 tmpPChar := NetCall(hSocket, PChar(y)); {eg 11-1-96}
978 tmp := tmpPchar;
979 StrDispose(tmpPchar);
980 if CompareStr(tmp, rlost) = 0 then
981 begin
982 lin.l_onoff := 1;
983 lin.l_linger := 0;
984
985 SocketError := setsockopt(hSocket, SOL_SOCKET, SO_LINGER,
986 s_lin, sizeof(lin));
987 If SocketError = SOCKET_ERROR Then
988 NetError( 'setsockopt (connect)',0);
989
990 closesocket(hSocket);
991 WSACleanup;
992 Result := 10002;
993 exit;
994 end;
995 r := CompareStr(tmp, rAccept);
996 If r <> 0 Then
997 NetError ('NetCall',XWB_M_REJECT);
998{ // JLI 021217 remove disconnect and reconnect code -- use UCX connection directly.
999 lin.l_onoff := 1;
1000 lin.l_linger := 0;
1001
1002 SocketError := setsockopt(hSocket, SOL_SOCKET, SO_LINGER,
1003 s_lin, sizeof(lin));
1004 If SocketError = SOCKET_ERROR Then
1005 NetError( 'setsockopt (connect)',0);
1006 SocketError := closesocket(hSocket); { -- done with this socket
1007 If SocketError > 0 Then
1008 NetError( 'closesocket',0);
1009
1010 { -- wait for connect from DHCP and accept it - (uses blocking call)
1011 AddrLen := SizeOf(DHCPHost);
1012 hSocket := accept(hSocketListen, @DHCPHost, @AddrLen);{ -- returns new socket
1013 If hSocket = INVALID_SOCKET Then
1014 begin
1015 NetError( 'accept',0);
1016 end;
1017
1018 lin.l_onoff := 1;
1019 lin.l_linger := 0;
1020
1021 SocketError := setsockopt(hSocketListen, SOL_SOCKET, SO_LINGER,
1022 s_lin, sizeof(lin));
1023 If SocketError = SOCKET_ERROR Then
1024 NetError( 'setsockopt (connect)',0);
1025
1026 SocketError := closesocket(hSocketListen); // -- done with listen skt
1027
1028 If SocketError > 0 Then
1029 begin
1030 NetError ('closesocket (listening)',0);
1031 end;
1032} // JLI 12/17/02 end of section commented out
1033
1034 if ChangeCursor then
1035 Screen.Cursor := crDefault;
1036 NetStart := 0;
1037{ -- connection established, socket handle now in: hSocket
1038 ifrmWinSock.txtStatus := 'socket obtained' *** }
1039end;
1040
1041function TXWBWinsock.NetStart1(ForegroundM: boolean; Server: string;
1042 ListenerPort: integer; var hSocket: integer): Integer;
1043Var
1044 WinSockData: TWSADATA;
1045 LocalHost, DHCPHost: TSockAddr;
1046 LocalName, t, workstation, pDHCPName: string;
1047 x, y, tmp,RPCVersion, upArrow, rAccept, rLost: string;
1048 tmpPchar: PChar;
1049 pLocalname: array [0..255] of char;
1050 LocalPort, AddrLen, hSocketListen,r: integer;
1051 HostBuf,DHCPBuf: PHostEnt;
1052 lin: TLinger;
1053 s_lin: array [0..3] of char absolute lin;
1054 ChangeCursor: Boolean;
1055begin
1056 Prefix := '{XWB}';
1057{ ForegroundM is a boolean value, TRUE means the M handling process is
1058 running interactively a pointer rather than passing address length
1059 by value) }
1060
1061 { -- initialize Windows Sockets API for this task }
1062 if Screen.Cursor = crDefault then
1063 ChangeCursor := True
1064 else
1065 ChangeCursor := False;
1066 if ChangeCursor then
1067 Screen.Cursor := crHourGlass;
1068 upArrow := string('^');
1069 rAccept := string('accept');
1070 rLost := string('(connection lost)');
1071
1072 SocketError := WSAStartup(WINSOCK1_1, WinSockData);
1073 If SocketError >0 Then
1074 NetError( 'WSAStartup',0);
1075
1076 { -- set up a hook for blocking calls so there is no automatic DoEvents
1077 in the background }
1078 NetCallPending := False;
1079 if ForeGroundM = False then if WSASetBlockingHook(@NetBlockingHook) = nil
1080 then NetError('WSASetBlockingHook',0);
1081
1082 { -- establish HostEnt and Address structure for local machine}
1083 SocketError := gethostname(pLocalName, 255); { -- name of local system}
1084 If SocketError >0 Then
1085 NetError ('gethostname (local)',0);
1086 HostBuf := gethostbyname(pLocalName); { -- info for local name}
1087 If HostBuf = nil Then
1088 NetError( 'gethostbyname',0);
1089 LocalHost.sin_addr.S_addr := longint(plongint(HostBuf^.h_addr_list^)^);
1090 LocalName := inet_ntoa(LocalHost.sin_addr);
1091 workstation := string(HostBuf.h_name);
1092
1093 { -- establish HostEnt and Address structure for remote machine }
1094 if inet_addr(PChar(Server)) <> longint(INADDR_NONE) then
1095 begin
1096 DHCPHost.sin_addr.S_addr := inet_addr(PChar(Server));
1097 DHCPBuf := gethostbyaddr(@DHCPHost.sin_addr.S_addr,sizeof(DHCPHost),PF_INET);
1098 end
1099 else
1100 DHCPBuf := gethostbyname(PChar(Server)); { -- info for DHCP system}
1101
1102 If DHCPBuf = nil Then
1103 begin
1104 { modification to take care of problems with 10-dot addresses that weren't registered - solution found by Shawn Hardenbrook }
1105// NetError ('Error Identifying Remote Host ' + Server,0);
1106// NetStart := 10001;
1107// exit;
1108 DHCPHost.sin_addr.S_addr := inet_addr(PChar(Server));
1109 pDHCPName := 'UNKNOWN';
1110 end
1111 else
1112 begin;
1113 DHCPHost.sin_addr.S_addr := longint(plongint(DHCPBuf^.h_addr_list^)^);
1114 pDHCPName := inet_ntoa(DHCPHost.sin_addr);
1115 end;
1116 DHCPHost.sin_family := PF_INET; { -- internet address type}
1117 DHCPHost.sin_port := htons(ListenerPort); { -- port to connect to}
1118
1119 { -- make connection to DHCP }
1120 hSocket := socket(PF_INET, SOCK_STREAM, IPPROTO_TCP);
1121 If hSocket = INVALID_SOCKET Then
1122 NetError( 'socket',0);
1123
1124 SocketError := connect(hSocket, DHCPHost, SizeOf(DHCPHost));
1125 If SocketError = SOCKET_ERROR Then
1126 NetError( 'connect',0);
1127
1128 {establish local IP now that connection is done}
1129 AddrLen := SizeOf(LocalHost);
1130 SocketError := getsockname(hSocket, LocalHost, AddrLen);
1131 if SocketError = SOCKET_ERROR then
1132 NetError ('getsockname',0);
1133 LocalName := inet_ntoa(LocalHost.sin_addr);
1134
1135// { -- set up listening socket for DHCP return connect }
1136 hSocketListen := socket(PF_INET, SOCK_STREAM, IPPROTO_TCP); // -- new socket
1137 If hSocketListen = INVALID_SOCKET Then
1138 NetError ('socket (listening)',0);
1139
1140 LocalHost.sin_family := PF_INET; // -- internet address type
1141 LocalHost.sin_port := 0; // -- local listening port
1142 SocketError := bind(hSocketListen, LocalHost,
1143 SizeOf(LocalHost)); // -- bind socket to address
1144 If SocketError = SOCKET_ERROR Then
1145 NetError( 'bind',0);
1146
1147 AddrLen := sizeof(LocalHost);
1148 SocketError := getsockname(hSocketListen, LocalHost,
1149 AddrLen); // -- get listening port #
1150 If SocketError = SOCKET_ERROR Then
1151 NetError( 'getsockname',0);
1152 LocalPort := ntohs(LocalHost.sin_port); // -- put in proper byte order
1153
1154 SocketError := listen(hSocketListen, 1); // -- put socket in listen mode
1155 If SocketError = SOCKET_ERROR Then
1156 NetError( 'listen',0);
1157
1158 { -- send IP address + port + workstation name and wait for OK : eg 1-30-97}
1159
1160 RPCVersion := VarPack(BrokerVer); // eg 11-1-96
1161 x := string('TCPconnect^');
1162 x := ConCat(x, LocalName, upArrow); // local ip address
1163 t := IntToStr(LocalPort); // callback port
1164 x := ConCat(x, t, upArrow, workstation, upArrow); // workstation name
1165 r := length(x) + length(RPCVersion) + 5;
1166 t := string('00000') + IntToStr(r); // eg 11-1-96
1167 y := Copy(t, length(t)-4,length(t));
1168 y := ConCat(y, RPCVersion, StrPack(x,5)); // rpc version
1169 y := Prefix + y;
1170 { new protocol 030107 }
1171
1172// y := '[XWB]10' +IntToStr(CountWidth)+ '0' + '4'+#$A+'TCPConnect50'+ LPack(LocalName,CountWidth)+'f0'+LPack(IntToStr(LocalPort),CountWidth)+'f0'+LPack(workstation,CountWidth)+'f'+#4;
1173// y := '[XWB]10' +IntToStr(CountWidth)+ '0' + '4'+#$A+'TCPConnect50'+ LPack(LocalName,CountWidth)+'f0'+LPack(IntToStr(0),CountWidth)+'f0'+LPack(workstation,CountWidth)+'f'+#4;
1174
1175 // need to remove selecting port etc from client, since it will now be handled on the server P36
1176
1177 if ForeGroundM = True then
1178 begin
1179 if ChangeCursor then
1180 Screen.Cursor := crDefault;
1181 t := 'Start M job D EN^XWBTCP' + #13 + #10 + 'Addr = ' +
1182 LocalName + #13 + #10 + 'Port = ' + IntToStr(LocalPort);
1183
1184 frmDebugInfo := TfrmDebugInfo.Create(Application.MainForm);
1185 try
1186 frmDebugInfo.lblDebugInfo.Caption := t;
1187 ShowApplicationAndFocusOK(Application);
1188 frmDebugInfo.ShowModal;
1189 finally
1190 frmDebugInfo.Free
1191 end;
1192
1193// ShowMessage(t); //TODO
1194 end;
1195 // remove debug mode from client
1196
1197 tmpPChar := NetCall(hSocket, PChar(y)); {eg 11-1-96}
1198 tmp := tmpPchar;
1199 StrDispose(tmpPchar);
1200 if CompareStr(tmp, rlost) = 0 then
1201 begin
1202 lin.l_onoff := 1;
1203 lin.l_linger := 0;
1204
1205 SocketError := setsockopt(hSocket, SOL_SOCKET, SO_LINGER,
1206 s_lin, sizeof(lin));
1207 If SocketError = SOCKET_ERROR Then
1208 NetError( 'setsockopt (connect)',0);
1209
1210 closesocket(hSocket);
1211 WSACleanup;
1212 Result := 10002;
1213 exit;
1214 end;
1215 r := CompareStr(tmp, rAccept);
1216 If r <> 0 Then
1217 NetError ('NetCall',XWB_M_REJECT);
1218 // JLI 021217 remove disconnect and reconnect code -- use UCX connection directly.
1219 lin.l_onoff := 1;
1220 lin.l_linger := 0;
1221
1222 SocketError := setsockopt(hSocket, SOL_SOCKET, SO_LINGER,
1223 s_lin, sizeof(lin));
1224 If SocketError = SOCKET_ERROR Then
1225 NetError( 'setsockopt (connect)',0);
1226 SocketError := closesocket(hSocket); // -- done with this socket
1227 If SocketError > 0 Then
1228 NetError( 'closesocket',0);
1229
1230 // -- wait for connect from DHCP and accept it - (uses blocking call)
1231 AddrLen := SizeOf(DHCPHost);
1232 hSocket := accept(hSocketListen, @DHCPHost, @AddrLen); // -- returns new socket
1233 If hSocket = INVALID_SOCKET Then
1234 begin
1235 NetError( 'accept',0);
1236 end;
1237
1238 lin.l_onoff := 1;
1239 lin.l_linger := 0;
1240
1241 SocketError := setsockopt(hSocketListen, SOL_SOCKET, SO_LINGER,
1242 s_lin, sizeof(lin));
1243 If SocketError = SOCKET_ERROR Then
1244 NetError( 'setsockopt (connect)',0);
1245
1246 SocketError := closesocket(hSocketListen); // -- done with listen skt
1247
1248 If SocketError > 0 Then
1249 begin
1250 NetError ('closesocket (listening)',0);
1251 end;
1252 // JLI 12/17/02 end of section commented out
1253
1254 if ChangeCursor then
1255 Screen.Cursor := crDefault;
1256 NetStart1 := 0;
1257{ -- connection established, socket handle now in: hSocket
1258 ifrmWinSock.txtStatus := 'socket obtained' *** }
1259end;
1260
1261
1262procedure TXWBWinsock.NetStop(hSocket: integer);
1263Var
1264 tmp: string;
1265 lin: TLinger;
1266 s_lin: array [0..3] of char absolute lin;
1267 ChangeCursor: Boolean;
1268 tmpPChar: PChar;
1269 Str: String;
1270 x: array [0..15] of Char;
1271begin
1272 if not IsConnected then exit;
1273 if Screen.Cursor = crDefault then
1274 ChangeCursor := True
1275 else
1276 ChangeCursor := False;
1277 if ChangeCursor then
1278 Screen.Cursor := crHourGlass;
1279 if hSocket <= 0 then
1280 begin
1281 if ChangeCursor then
1282 screen.cursor := crDefault;
1283 exit;
1284 end;
1285
1286 StrPcopy(x, StrPack(StrPack('#BYE#',5),5));
1287
1288 { convert to new message protocol 030107 }
1289 if Prefix = '[XWB]' then
1290 Str := Prefix + '10'+IntToStr(CountWidth)+'0' +'4'+#5+'#BYE#'+#4
1291 else
1292 Str := Prefix + x;
1293 If hSocket <> INVALID_SOCKET Then
1294 begin
1295 tmpPChar := NetCall(hSocket,Str);
1296// tmpPChar := NetCall(hSocket, x);
1297 tmp := tmpPChar;
1298 StrDispose(tmpPChar);
1299 lin.l_onoff := 1; { -- shut down the M handler};
1300 lin.l_linger := 0;
1301
1302 SocketError := setsockopt(hSocket, SOL_SOCKET, SO_LINGER,
1303 s_lin, sizeof(lin));
1304 If SocketError = SOCKET_ERROR Then
1305 NetError( 'setsockopt (connect)',0);
1306
1307 SocketError := closesocket(hSocket); { -- close the socket}
1308 end;
1309
1310 SocketError := WSAUnhookBlockingHook; { -- restore the default mechanism}
1311 SocketError := WSACleanup; { -- shutdown TCP API}
1312 If SocketError > 0 Then
1313 NetError( 'WSACleanup',0); { -- check blocking calls, etc.}
1314 if ChangeCursor then
1315 Screen.Cursor := crDefault;
1316 IsConnected := False;
1317end;
1318
1319
1320procedure TXWBWinsock.CloseSockSystem(hSocket: integer; s: string);
1321var
1322 lin: TLinger;
1323 s_lin: array [0..3] of char absolute lin;
1324begin
1325 lin.l_onoff := 1;
1326 lin.l_linger := 0;
1327
1328 SocketError := setsockopt(hSocket, SOL_SOCKET, SO_LINGER,
1329 s_lin, sizeof(lin));
1330 If SocketError = SOCKET_ERROR Then
1331 NetError( 'setsockopt (connect)',0);
1332
1333 closesocket(hSocket);
1334 WSACleanup;
1335 ShowMessage(s); //TODO
1336 halt(1);
1337end;
1338
1339function TXWBWinsock.GetServerPacket(hSocket: integer): string;
1340var
1341 s,sb: PChar;
1342 buflen: integer;
1343begin
1344 s := StrAlloc(1);
1345 s[0] := #0;
1346 buflen := recv(hSocket, s^, 1, 0); {get length of segment}
1347 if buflen = SOCKET_ERROR Then // 040720 code added to check for the timing problem if initial attempt to read during connection fails
1348 begin
1349 sleep(100);
1350 buflen := recv(hSocket, s^, 1, 0);
1351 end;
1352 if buflen = SOCKET_ERROR then
1353 NetError( 'recv',0);
1354 buflen := ord(s[0]);
1355 sb := StrAlloc(buflen+1);
1356 sb[0] := #0;
1357 buflen := recv(hSocket, sb^, buflen, 0); {get security segment}
1358 if buflen = SOCKET_ERROR Then
1359 NetError( 'recv',0);
1360 sb[buflen] := #0;
1361 Result := StrPas(sb);
1362 StrDispose(sb);
1363 StrDispose(s);
1364end;
1365
1366constructor TXWBWinsock.Create;
1367begin
1368 inherited;
1369// NetBlockingHookVar := NetBlockingHook;
1370 CountWidth := 3;
1371end;
1372
1373procedure TXWBWinsock.NetError(Action: string; ErrType: integer);
1374var
1375 x,s: string;
1376 r: integer;
1377 BrokerError: EBrokerError;
1378 TimeOut: Double;
1379begin
1380 Screen.Cursor := crDefault;
1381 r := 0;
1382 if ErrType > 0 then r := ErrType;
1383 if ErrType = 0 then
1384 begin
1385 // P36
1386 // code added to indicate WSAETIMEDOUT error instead of WSAEINTR
1387 // when time out period exceeded. WSAEINTR error is misleading
1388 // since the server is still active, but took too long
1389 if NetcallPending then
1390 begin
1391 if HookTimeOut > 0 then
1392 begin
1393 TimeOut := HookTimeOut * OneSecond;
1394 if Now > (NetTimerStart + TimeOut) then
1395 r := WSAETIMEDOUT;
1396 end;
1397 end;
1398 if r = 0 then
1399 r := WSAGetLastError;
1400 if (r = WSAEINTR) or (r = WSAETIMEDOUT) then xFlush := True;
1401 if WSAIsBlocking = True then WSACancelBlockingCall; // JLI 021210
1402 end;
1403 Case r of
1404 WSAEINTR : x := 'WSAEINTR';
1405 WSAEBADF : x := 'WSAEINTR';
1406 WSAEFAULT : x := 'WSAEFAULT';
1407 WSAEINVAL : x := 'WSAEINVAL';
1408 WSAEMFILE : x := 'WSAEMFILE';
1409 WSAEWOULDBLOCK : x := 'WSAEWOULDBLOCK';
1410 WSAEINPROGRESS : x := 'WSAEINPROGRESS';
1411 WSAEALREADY : x := 'WSAEALREADY';
1412 WSAENOTSOCK : x := 'WSAENOTSOCK';
1413 WSAEDESTADDRREQ : x := 'WSAEDESTADDRREQ';
1414 WSAEMSGSIZE : x := 'WSAEMSGSIZE';
1415 WSAEPROTOTYPE : x := 'WSAEPROTOTYPE';
1416 WSAENOPROTOOPT : x := 'WSAENOPROTOOPT';
1417 WSAEPROTONOSUPPORT : x := 'WSAEPROTONOSUPPORT';
1418 WSAESOCKTNOSUPPORT : x := 'WSAESOCKTNOSUPPORT';
1419 WSAEOPNOTSUPP : x := 'WSAEOPNOTSUPP';
1420 WSAEPFNOSUPPORT : x := 'WSAEPFNOSUPPORT';
1421 WSAEAFNOSUPPORT : x := 'WSAEAFNOSUPPORT';
1422 WSAEADDRINUSE : x := 'WSAEADDRINUSE';
1423 WSAEADDRNOTAVAIL : x := 'WSAEADDRNOTAVAIL';
1424 WSAENETDOWN : x := 'WSAENETDOWN';
1425 WSAENETUNREACH : x := 'WSAENETUNREACH';
1426 WSAENETRESET : x := 'WSAENETRESET';
1427 WSAECONNABORTED : x := 'WSAECONNABORTED';
1428 WSAECONNRESET : x := 'WSAECONNRESET';
1429 WSAENOBUFS : x := 'WSAENOBUFS';
1430 WSAEISCONN : x := 'WSAEISCONN';
1431 WSAENOTCONN : x := 'WSAENOTCONN';
1432 WSAESHUTDOWN : x := 'WSAESHUTDOWN';
1433 WSAETOOMANYREFS : x := 'WSAETOOMANYREFS';
1434 WSAETIMEDOUT : x := 'WSAETIMEDOUT';
1435 WSAECONNREFUSED : x := 'WSAECONNREFUSED';
1436 WSAELOOP : x := 'WSAELOOP';
1437 WSAENAMETOOLONG : x := 'WSAENAMETOOLONG';
1438 WSAEHOSTDOWN : x := 'WSAEHOSTDOWN';
1439 WSAEHOSTUNREACH : x := 'WSAEHOSTUNREACH';
1440 WSAENOTEMPTY : x := 'WSAENOTEMPTY';
1441 WSAEPROCLIM : x := 'WSAEPROCLIM';
1442 WSAEUSERS : x := 'WSAEUSERS';
1443 WSAEDQUOT : x := 'WSAEDQUOT';
1444 WSAESTALE : x := 'WSAESTALE';
1445 WSAEREMOTE : x := 'WSAEREMOTE';
1446 WSASYSNOTREADY : x := 'WSASYSNOTREADY';
1447 WSAVERNOTSUPPORTED : x := 'WSAVERNOTSUPPORTED';
1448 WSANOTINITIALISED : x := 'WSANOTINITIALISED';
1449 WSAHOST_NOT_FOUND : x := 'WSAHOST_NOT_FOUND';
1450 WSATRY_AGAIN : x := 'WSATRY_AGAIN';
1451 WSANO_RECOVERY : x := 'WSANO_RECOVERY';
1452 WSANO_DATA : x := 'WSANO_DATA';
1453
1454 XWB_NO_HEAP : x := 'Insufficient Heap';
1455 XWB_M_REJECT : x := 'M Error - Use ^XTER';
1456 XWB_BadReads : x := 'Server unable to read input data correctly.';
1457 XWB_BadSignOn : x := 'Sign-on was not completed.';
1458 XWB_ExeNoMem : x := 'System was out of memory, executable file was corrupt, or relocations were invalid.';
1459 XWB_ExeNoFile : x := 'File was not found.';
1460 XWB_ExeNoPath : x := 'Path was not found.';
1461 XWB_ExeShare : x := 'Attempt was made to dynamically link to a task,' +
1462 ' or there was a sharing or network-protection error.';
1463 XWB_ExeSepSeg : x := 'Library required separate data segments for each task.';
1464 XWB_ExeLoMem : x := 'There was insufficient memory to start the application.';
1465 XWB_ExeWinVer : x := 'Windows version was incorrect.';
1466 XWB_ExeBadExe : x := 'Executable file was invalid.' +
1467 ' Either it was not a Windows application or there was an error in the .EXE image.';
1468 XWB_ExeDifOS : x := 'Application was designed for a different operating system.';
1469 XWB_RpcNotReg : X := 'Remote procedure not registered to application.';
1470 XWB_BldConnectList : x := 'BrokerConnections list could not be created';
1471 XWB_NullRpcVer : x := 'RpcVersion cannot be empty.' + #13 + 'Default is 0 (zero).';
1472 else x := IntToStr(r);
1473 end;
1474 s := 'Error encountered.' + chr(13)+chr(10) + 'Function was: ' + Action + chr(13)+chr(10) + 'Error was: ' + x;
1475 BrokerError := EBrokerError.Create(s);
1476 BrokerError.Action := Action;
1477 BrokerError.Code := r;
1478 BrokerError.Mnemonic := x;
1479 raise BrokerError;
1480end;
1481
1482function TXWBWinsock.BuildPar1(hSocket: integer; api, RPCVer: string; const
1483 Parameters: TParams): String;
1484var
1485 i,ParamCount: integer;
1486 num: integer;
1487 tsize: longint;
1488 arr: LongInt;
1489 param,x,hdr,strout: string;
1490 tout,psize,tResult,RPCVersion: string;
1491 sin: TStringList;
1492 subscript: string;
1493begin
1494 sin := TStringList.Create;
1495 sin.clear;
1496 x := '';
1497 param := '';
1498 arr := 0;
1499 if Parameters = nil then ParamCount := 0
1500 else ParamCount := Parameters.Count;
1501 for i := 0 to ParamCount - 1 do
1502 if Parameters[i].PType <> undefined then begin
1503 with Parameters[i] do begin
1504
1505 {if PType= null then
1506 param:='';}
1507
1508 if PType = literal then
1509 param := param + strpack('0' + Value,3);
1510
1511 if PType = reference then
1512 param := param + strpack('1' + Value,3);
1513
1514 if (PType = list) {or (PType = wordproc)} then begin
1515 Value := '.x';
1516 param := param + strpack('2' + Value,3);
1517 if Pos('.',Value) >0 then
1518 x := Copy(Value,2,length(Value));
1519 {if PType = wordproc then dec(last);}
1520 subscript := Mult.First;
1521 while subscript <> '' do begin
1522 if Mult[subscript] = '' then Mult[subscript] := #1;
1523 sin.Add(StrPack(subscript,3) + StrPack(Mult[subscript],3));
1524 subscript := Mult.Order(subscript,1);
1525 end{while};
1526 sin.Add('000');
1527 arr := 1;
1528 end{if};
1529 end{with};
1530 end{if};
1531
1532 param := Copy(param,1,Length(param));
1533 tsize := 0;
1534
1535 tResult := '';
1536 tout := '';
1537
1538 hdr := BuildHdr('XWB','','','');
1539 strout := strpack(hdr + BuildApi(api,param,arr),5);
1540// num :=0; // JLI 040608 to correct handling of empty arrays
1541
1542 RPCVersion := '';
1543 RPCVersion := VarPack(RPCVer);
1544
1545 {if sin.Count-1 > 0 then} num := sin.Count-1; // JLI 040608 to correct handling of empty arrays
1546// if sin.Count-1 > 0 then num := sin.Count-1;
1547
1548
1549 if {num} sin.Count > 0 then // JLI 040608 to correct handling of empty arrays
1550// if num > 0 then
1551 begin
1552 for i := 0 to num do
1553 tsize := tsize + length(sin.strings[i]);
1554 x := '00000' + IntToStr(tsize + length(strout)+ length(RPCVersion));
1555 end;
1556 if {num} sin.Count = 0 then // JLI 040608 to correct handling of empty arrays
1557// if num = 0 then
1558 begin
1559 x := '00000' + IntToStr(length(strout)+ length(RPCVersion));
1560 end;
1561
1562 psize := x;
1563 psize := Copy(psize,length(psize)-5,5);
1564 tResult := psize;
1565 tResult := ConCat(tResult, RPCVersion);
1566 tout := strout;
1567 tResult := ConCat(tResult, tout);
1568
1569 if {num} sin.Count > 0 then // JLI 040608 to correct handling of empty arrays
1570// if num > 0 then
1571 begin
1572 for i := 0 to num do
1573 tResult := ConCat(tResult, sin.strings[i]);
1574 end;
1575
1576 sin.free;
1577
1578 Result := Prefix + tResult; {return result}
1579
1580end;
1581
1582end.
1583
1584
1585
Note: See TracBrowser for help on using the repository browser.