source: cprs/trunk/BDK50/BDK32_P50/Source/wsockc.pas@ 1705

Last change on this file since 1705 was 1678, checked in by healthsevak, 10 years ago

Added this new version of Broker component libraries while updating the working copy to CPRS version 28

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