{ **************************************************************
	Package: XWB - Kernel RPCBroker
	Date Created: Sept 18, 1997 (Version 1.1)
	Site Name: Oakland, OI Field Office, Dept of Veteran Affairs
	Developers: Danila Manapsal, Don Craven, Raul Mendoza, Joel Ivey,
              Herlan Westra
	Description: Contains TRPCBroker and related components.
  Unit: Wsockc manages WinSock connections and creates/parses messages.
	Current Release: Version 1.1 Patch 60
*************************************************************** }

{ **************************************************
  Changes in v1.1.60 (HGW 11/19/2014) XWB*1.1*60
  1. Fixed data type for variable pLocalname
  2. Updated version 'BrokerVer'
  3. Updated error text for WinSock messages
  4. Symbol 'AnsiStrAlloc' is deprecated in Delphi XE4, moved to the AnsiStrings
     unit.
  5. Symbol 'StrDispose' is deprecated in Delphi XE4, moved to the AnsiStrings
     unit.
  6. Symbol 'StrLen' is deprecated in Delphi XE4, moved to the AnsiStrings unit.
  7. Symbol 'StrNew' is deprecated in Delphi XE4, moved to the AnsiStrings unit.
  8. Symbol 'StrPas' is deprecated in Delphi XE4, moved to the AnsiStrings unit.
  9. Upgraded from WinSock 1.1 to WinSock 2.2
  10. Removed blocking hook functions not supported in WinSock 2.2
  11. Combined redundant code in NetStart and NetStart1 into single function
      NetStart for IPv4/IPv6-dual stack connections.
  12. Added data structures and function definitions missing or incomplete for
      Delphi XE4 and XE5 implementation of WinSock 2.2 and IPv6.
  13. Wrapped a number of Windows APIs to be used with the updated data
      structures. Calling them from Delphi Winapi.Winsock2 RTL caused error for
      format of passed parameters.
  14. Made IPv6 changes in NetStart required by Microsoft:
     a. Used WSAConnectByName to establish a connection to a VistA server given
        a host name and port. IPv6 was not working with Delphi Winsock2 RTL due
        to variable type definitions. Wrapper function FWSAConnectByName created.
     b. Replaced gethostbyname function calls with calls to getaddrinfo Windows
        Sockets function. Not included in Delphi Winsock2 RTL. Wrapper function
        FGetAddrInfo created.
  15. Deprecated old-style broker which called back to client on a different
      port. VistA will continue to support the old-style broker for legacy
      applications, but it is no longer supported in new versions of the BDK.
  16. Resolved various compiler warnings regarding data type casting to
      prevent buffer overruns (potential security issue).

  Changes in v1.1.50 (JLI 6/24/2008) XWB*1.1*50
  1. Remedy ticket INC886661 fix returned error text that was illegible with
     changes to function TXWBWinsock.GetServerPacket (Remedy ticket documentation
     included in patch 60 patch description).

  Changes in v1.1.13 (JLI 8/23/2000) XWB*1.1*13
  1. Made changes to cursor dependent on current curson being crDefault so
     that the application can set it to a different cursor for long or
     repeated processes without the cursor 'flashing' repeatedly.

  Changes in v1.1.8 (REM 6/18/1999) XWB*1.1*8
  1. Update version 'BrokerVer'

  Changes in v1.1.6 (DPC 6/7/1999) XWB*1.1*6
  1. In tCall function, made changing cursor to hourglass conditional:
     don't do it if XWB IM HERE  RPC is being invoked.

  Changes in v1.1.4 (DCM 9/18/1998) XWB*1.1*4
  1. Changed the inet_addr line in NetStart to longint. Reason: true 64 bit
     types in Delphi 4
  2. Changed the hSocket line in NetStart to @. Reason: incompatible types
     when recompiling
  3. In NetStop, if socket <= 0, restore the default cursor. Reason: gave the
     impression of a busy process after the Kernel login process times out.
************************************************** }

unit Wsockc;
{*******************************************************************
  This implementation allows communications between Delphi forms and
  VistA servers through the use of the VistA RPC Broker.

  Usage: Put wsockc in your Uses clause of your Delphi form.  See additional
  specs for RPC Broker message formats.
  Programmer: Enrique Gomez - VA San Francisco ISC - April 1995
*******************************************************************}

//p60 - Explicitly define minimum Windows version, required by Windows API getaddrinfo
{$DEFINE MINWINXP}

interface

uses
  {System}
  AnsiStrings, SysUtils, Classes,
  {WinApi}
  Windows, WinTypes, WinProcs, WinSock2, //p60 Upgraded from WinSock 1.1 to WinSock 2.2
  {VA}
  Xwbut1, Trpcb, RpcbErr,
  {VCL}
  Dialogs, Forms, Controls, StdCtrls, ClipBrd;

const
  OneSecond = 0.000011574;
  //p60 - begin changes
  WS2_32_LIB      = 'ws2_32.dll'; // Windows Winsock 2.2 API source
  WinSockVer      = $0202;        // WinSock Version = 2.2
  AI_PASSIVE      = $00000001;    // Socket address will be used in bind() call
  AI_CANONNAME    = $00000002;    // Return canonical name in first ai_canonname
  AI_NUMERICHOST  = $00000004;    // Nodename must be a numeric address string
  AI_NUMERICSERV  = $00000008;    // Servicename must be a numeric port number
  AI_ALL          = $00000100;    // Query both IPv6 and IPv4 with AI_V4MAPPED
  AI_FQDN         = $00020000;    // Return the FQDN in ai_canonname
  AF_UNSPEC       = 0;            // IP version unspecified
  AF_INET         = 2;            // IPv4
  AF_INET6        = 23;           // IPv6
  PF_INET         = AF_INET;      // IPv4 protocol
  PF_INET6        = AF_INET6;     // IPv6 protocol
  IPV6_V6ONLY     = 27;           // Used to setsockopt for IPv4/IPv6 dual-stack
  //p60 - end changes
  DHCP_NAME = 'BROKERSERVER';
  M_DEBUG = True;
  M_NORMAL = False;
  BrokerVer = '1.160';
  Buffer64K = 65520;
  Buffer32K = 32767;
  Buffer24K = 24576;
  Buffer16K = 16384;
  Buffer8K = 8192;
  Buffer4K = 4096;
  DefBuffer = 256;
  DebugOn: boolean = False;
  XWBBASEERR = {WSABASEERR + 1} 20000;
  //Broker Application Error Constants
  XWB_NO_HEAP        = XWBBASEERR + 1;
  XWB_M_REJECT       = XWBBASEERR + 2;
  XWB_BadSignOn      = XWBBASEERR + 4;
  XWB_BadReads       = XWBBASEERR + 8;
  XWB_ExeNoMem       = XWBBASEERR + 100;
  XWB_ExeNoFile      = XWB_ExeNoMem +  2;
  XWB_ExeNoPath      = XWB_ExeNoMem +  3;
  XWB_ExeShare       = XWB_ExeNoMem +  5;
  XWB_ExeSepSeg      = XWB_ExeNoMem +  6;
  XWB_ExeLoMem       = XWB_ExeNoMem +  8;
  XWB_ExeWinVer      = XWB_ExeNoMem + 10;
  XWB_ExeBadExe      = XWB_ExeNoMem + 11;
  XWB_ExeDifOS       = XWB_ExeNoMem + 12;
  XWB_RpcNotReg      = XWBBASEERR + 201;

type
  //p60 Added WinSock2 IPv4/IPv6 data types that are inadequately or incompletely
  //    defined in Delph XE4 and XE5 Winapi.Winsock2 Run Time Library.
  //    Borrowed from Indy project and other sources, with local modifications.
  TSocket = Cardinal;
  in6_addr = record                            // in6_addr (IPv6)
    case Byte of
      0: (u6_addr8  : array[0..15] of Byte);
      1: (u6_addr16 : array[0..7] of Word);
  end;
  TIn6_Addr = in6_addr;
  PIn6_Addr = ^in6_addr;
  //    Structured type definition for sockaddr for IPv4 or IPv6
  SockAddr = record
    case u_short of      //u_short is a Word boundary (2-byte integer SmallInt)
      0: (sa_family    : u_short;              //generic sockaddr structure
          sa_data      : array[0..13] of AnsiChar);
      1: (sin_family   : short;              //IPv4 sockaddr_in structure
          sin_port     : u_short;
          sin_addr     : in_addr;
          sin_zero     : array[0..7] of AnsiChar);
      2: (sin6_family  : short;              //IPv6 sockaddr_in6 structure
          sin6_port    : u_short;
          sin6_flowinfo: u_long;
          sin6_addr    : in6_addr;
          sin6_scope_id: u_long);
  end;
  TSockAddr = SockAddr;
  PSockAddr = ^TSockAddr;
  LPSOCKADDR = ^TSockAddr;
  PAddrInfo = ^TAddrInfo;     // to support function FGetAddrInfo
  TAddrInfo = record
    ai_flags: Integer;
    ai_family: Integer;
    ai_socktype: Integer;
    ai_protocol: Integer;
    ai_addrlen: Cardinal;
    ai_canonname: PAnsiChar;
    ai_addr: PSockAddr;
    ai_next: PAddrInfo;
  end;
  //p60 end of special type declarations
  TXWBWinsock = class(TObject)
  private
    FCountWidth: Integer;
  public
    XNetCallPending, xFlush: Boolean;
    SocketError, XHookTimeOut: Integer;
    XNetTimerStart: TDateTime;
    BROKERSERVER: String;
    SecuritySegment, ApplicationSegment: String;
    IsConnected: Boolean;

    function NetCall(hSocket: TSocket; imsg: String): PChar; // JLI O90705
    function tCall(hSocket: TSocket; api, apVer: String; Parameters: TParams;
             var Sec, App: PChar; TimeOut: integer): PChar;
    function cRight( z: PChar;  n: longint): PChar;
    function cLeft( z: PChar; n: longint): PChar;
    function BuildApi ( n,p: string; f: longint): string;
    function BuildHdr ( wkid: string; winh: string; prch: string;
             wish: string): string;
    function BuildPar(hSocket: TSocket; api, RPCVer: string;
             const Parameters: TParams): string;
    function StrPack (n: string; p: integer): string;
    function VarPack(n: string): string;
    function NetStart(ForegroundM: boolean; Server: string; ListenerPort: integer;
             var hSocket: TSocket): integer;
    function NetworkConnect(ForegroundM: boolean; Server: string; ListenerPort,
             TimeOut: integer): Integer;
    function libNetCreate (lpWSData : TWSAData): integer;
    function libNetDestroy: integer;
    function GetServerPacket(hSocket: TSocket): string;

    procedure NetworkDisconnect(hSocket: TSocket);
    procedure NetStop(hSocket: TSocket);
    procedure CloseSockSystem(hSocket: TSocket; s: string);
    procedure NetError(Action: string; ErrType: integer);

    constructor Create;

    property CountWidth: Integer read FCountWidth write FCountWidth;
  end;
  function LPack(Str: String; NDigits: Integer): String;
  function SPack(Str: String): String;
  //These need to be public as they are used in other Kernel projects (such as
  //RPC Broker Client Agent) to implement IPv4/IPv6 dual-stack.
  function FAddrToString(Addr: TSockAddr): String;
  function FGetAddrInfo(nodename,servname: PAnsiChar; phints: PAddrInfo;
           out res: PAddrInfo): Integer; stdcall;
           external WS2_32_LIB name 'getaddrinfo'; //p60 Windows function wrapper
  function FWSAConnectByName(const s: TSocket; NodeName, ServiceName: PAnsiChar;
           var LocalAddressLength: Cardinal; var LocalAddress: TSockAddr;
           var RemoteAddressLength: Cardinal; var RemoteAddress: TSockAddr;
           const timeout: timeval; Reserved: LPWSAOVERLAPPED): LongBool; stdcall;
           external WS2_32_LIB name 'WSAConnectByNameA'; //p60 Windows function wrapper
  function Fconnect(s: TSocket; var name: TSockAddr; namelen: Integer): Integer; stdcall;
           external WS2_32_LIB name 'connect'; //p60 Windows function wrapper
  function Fgetsockname(s: TSocket; var name: TSockAddr; var namelen: Integer): Integer; stdcall;
           external WS2_32_LIB name 'getsockname'; //p60 Windows function wrapper
  function Fbind(s: TSocket; var name: TSockAddr; namelen: Integer): Integer; stdcall;
           external WS2_32_LIB name 'bind'; //p60 Windows function wrapper


var
  HookTimeOut: Integer;
  NetCallPending: Boolean;
  NetTimerStart: TDateTime;

implementation

  uses fDebugInfo;

{----------------------- LPack --------------------------
----------------------------------------------------------------}
function LPack(Str: String; NDigits: Integer): String;
var
  r: Integer;
  t: String;
  Width: Integer;
  Ex1: Exception;
begin
  r := Length(Str);
  // check for enough space in NDigits characters
  t := IntToStr(r);
  Width := Length(t);
  if NDigits < Width then
  begin
    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)+')');
    Raise Ex1;
  end; //if
  t := '000000000' + IntToStr(r);               {eg 11-1-96}
  Result := Copy(t, length(t)-(NDigits-1),length(t)) + Str;
end; //function LPack


{----------------------- SPack --------------------------
Prepends the length of the string in one byte to the value of Str,
thus Str must be less than 256 characters.
  e.g., SPack('DataValue')
  returns   #9 + 'DataValue'
----------------------------------------------------------------}
function SPack(Str: String): String;
var
  r: Integer;
  Ex1: Exception;
begin
  r := Length(Str);
  // check for enough space in one byte
  if r > 255 then
  begin
    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');
    Raise Ex1;
  end; //if
  Result := Char(r) + Str;
end; //function SPack


{----------------------- FAddrToString --------------------------
Take IP address in TSockAddr structure and return IPv4 or IPv6
address in string format.
----------------------------------------------------------------}
function FAddrToString(Addr: TSockAddr): String;
var
  Str: AnsiString;
  I: Integer;
begin
  Str := '';
  if Addr.sa_family = AF_INET6 then  //address is IPv6
  begin
    for I := 0 to 15 do
    begin
      Str := Str + AnsiString(IntToHex(Addr.sin6_addr.u6_addr8[I], 2));
      if (Frac(I/2) > 0) and (I < 15) then
        Str := Str + ':';
    end;
    //if IPv6 string is IPv4-mapped then set string to dotted decimal IPv4
    if AnsiCompareText(AnsiLeftStr(Str, 29), '0000:0000:0000:0000:0000:FFFF') = 0 then
    begin
      Str := '';
      for I := 12 to 15 do
      begin
        Str := Str + AnsiString(IntToStr(Addr.sin6_addr.u6_addr8[I]));
        if I < 15 then
          Str := Str + '.';
      end;
    end; //if address is IPv4-mapped
  end //if address is IPv6
  else //if address is IPv4
  begin
    Str := AnsiString(IntToStr(Addr.sin_addr.S_un_b.s_b1)) + '.'
         + AnsiString(IntToStr(Addr.sin_addr.S_un_b.s_b2)) + '.'
         + AnsiString(IntToStr(Addr.sin_addr.S_un_b.s_b3)) + '.'
         + AnsiString(IntToStr(Addr.sin_addr.S_un_b.s_b4));
  end; //if address is IPv4
  Result := Str;
end; //function FAddrToString


{----------------------- TXWBWinsock.libNetCreate --------------------------
----------------------------------------------------------------}
function TXWBWinsock.libNetCreate (lpWSData : TWSAData) : integer;
begin
  Result := WSAStartup(WinSockVer, lpWSData);
end; //function TXWBWinsock.libNetCreat


{----------------------- TXWBWinsock.libNetDestroy --------------------------
----------------------------------------------------------------}
function TXWBWinsock.libNetDestroy :integer;
begin
  WSACleanup;                 { -- shutdown TCP API};
  Result := 1;
end; //TXWBWinsock.libNetDestroy


{----------------------- TXWBWinsock.cRight --------------------------
----------------------------------------------------------------}
function TXWBWinsock.cRight;
var
  i,t: longint;
begin
  t := strlen(z);
  if n < t then
  begin
    for i := 0 to n do
      z[i] := z[t-n+i];
    z[n] := chr(0);
  end; //if
  cRight := z;
end; //function TXWBWinsock.cRight


{----------------------- TXWBWinsock.cLeft --------------------------
----------------------------------------------------------------}
function TXWBWinsock.cLeft;
var
  t: longint;
begin
  t := strlen(z);
  if n > t then
    n := t;
  z[n] := chr(0);
  cLeft := z;
end; //function TXBWinsock.cLeft


{----------------------- TXWBWinsock.BuildApi --------------------------
----------------------------------------------------------------}
function TXWBWinsock.BuildApi ( n,p: string; f: longint): string;
var
  x,s: string;
begin
  str(f,x);
  s := StrPack(p,5);
  result := StrPack(x + n + '^' + s,5);
end; //function TXWBWinsock.BuildApi


{----------------------- TXWBWinsock.NetworkConnect --------------------------
----------------------------------------------------------------}
function TXWBWinsock.NetworkConnect(ForegroundM: boolean; Server: string;
  ListenerPort, TimeOut: integer): Integer;
var
  status: integer;
  hSocket: TSocket;
begin
  xFlush := False;
  IsConnected := False;
  XHookTimeOut := TimeOut;
  try
  begin
    status := NetStart(ForeGroundM, Server, ListenerPort, hSocket);
  end; //try
  except
    on E: EBrokerError do
    begin
      raise;
    end //do
  end; //except
  if status = 0 then
    IsConnected := True;
  Result := hSocket;                  // return the newly established socket
end; //function TXWBWinsock.NetworkConnect


{----------------------- TXWBWinsock.NetworkDisconnect --------------------------
----------------------------------------------------------------}
procedure TXWBWinsock.NetworkDisconnect(hSocket: TSocket);
begin
  xFlush := False;
  if IsConnected then
    try
      NetStop(hSocket);
    except on EBrokerError do
      SocketError := WSACleanup;                //-- shutdown TCP API
  end; //if
end; //procedure TXWBWinsock.NetworkDisconnect


{----------------------- TXWBWinsock.BuildHdr --------------------------
----------------------------------------------------------------}
function TXWBWinsock.BuildHdr ( wkid: string; winh: string; prch: string; wish: string): string;
var
  t: string;
begin
  t := wkid + ';' + winh + ';' + prch + ';' + wish + ';';
  Result := StrPack(t,3);
end; //function TXWBWinsock.BuildHdr


{----------------------- TXWBWinsock.BuildPar --------------------------
Builds the RPC Broker call to be sent to the VistA server.
----------------------------------------------------------------}
function TXWBWinsock.BuildPar(hSocket: TSocket; api, RPCVer: string; const Parameters: TParams): string;
var
  i,ParamCount: integer;
  param: string;
  tResult: string;
  subscript: string;
  IsSeen: Boolean;
begin
  param := '5';
  if Parameters = nil then ParamCount := 0
  else ParamCount := Parameters.Count;
  for i := 0 to ParamCount - 1 do
  begin
    if Parameters[i].PType <> undefined then
    begin
      with Parameters[i] do
      begin
        if PType = literal then
          param := param + '0'+LPack(Value,CountWidth)+'f';      // 030107 new message protocol
        if PType = reference then
          param := param + '1'+LPack(Value,CountWidth)+'f';     // 030107 new message protocol
        if PType = empty then
          param := param + '4f';
        if (PType = list) or (PType = global) then
        begin
          if PType = list then      // 030107 new message protocol
            param := param + '2'
          else
            param := param + '3';
          IsSeen := False;
          subscript := Mult.First;
          while subscript <> '' do
          begin
            if IsSeen then
              param := param + 't';
            if Mult[subscript] = '' then
              Mult[subscript] := #1;
            param := param + LPack(subscript,CountWidth)+LPack(Mult[subscript],CountWidth);
            IsSeen := True;
            subscript := Mult.Order(subscript,1);
          end; //while subscript <> ''
          if not IsSeen then         // 040922 added to take care of list/global parameters with no values
            param := param + LPack('',CountWidth);
          param := param + 'f';
        end; //if (PType = list) or (PType = global)
        if PType = stream then
        begin
          param := param + '5' + LPack(Value,CountWidth) + 'f';
        end; //if PType = stream
      end; //with Parameters[i] do
    end; //if Parameters[i].PType <> undefined
  end; //for i := 0
  if param = '5' then
    param := param + '4f';
  tresult := '[XWB]' + '11' + IntToStr(CountWidth) + '0' + '2' + SPack(RPCVer) + SPack(api) + param + #4;
  Result := tresult;
end; //function TXWBWinsock.BuildPar


{----------------------- TXWBWinsock.StrPack --------------------------
----------------------------------------------------------------}
function TXWBWinsock.StrPack(n: string; p: integer): String;
var
  s,l: integer;
  t,x,zero: shortstring;
  y: string;
begin
  s := Length(n);
  fillchar(zero,p+1, '0');
  SetLength(zero, p);
  str(s,x);
  t := zero + x;
  l := length(x)+1;
  y := Copy(t, l , p);
  y := y + n;
  Result := y;
end; //function TXWBWinsock.StrPack


{----------------------- TXWBWinsock.VarPack --------------------------
----------------------------------------------------------------}
function TXWBWinsock.VarPack(n: string): string;
var
  s: integer;
begin
  if n = '' then
    n := '0';
  s := Length(n);
  SetLength(Result, s+2);
  Result := '|' + chr(s) + n;
end; //function TXWBWinsock.VarPack


{----------------------- TXWBWinsock.NetCall --------------------------
----------------------------------------------------------------}
function TXWBWinsock.NetCall(hSocket: TSocket; imsg: String): PChar; // JLI 090805
var
  BufSend, BufRecv, BufPtr: PAnsiChar;
  sBuf: string;
  OldTimeOut: integer;
  BytesRead, BytesLeft, BytesTotal: longint;
  TryNumber: Integer;
  BadXfer: Boolean;
  xString: String;
begin
  { -- clear receive buffer prior to sending rpc }
  if xFlush = True then
  begin
     OldTimeOut := HookTimeOut;
     HookTimeOut := 0;
     NetCallPending := True;
     BufRecv := PAnsiChar(StrAlloc(Buffer32k));
     NetTimerStart := Now;
     BytesRead := recv(hSocket, BufRecv^, Buffer32k, 0);
     if BytesRead > 0 then
       while BufRecv[BytesRead-1] <> #4 do
       begin
         BytesRead := recv(hSocket, BufRecv^, Buffer32k, 0);
       end; //while
     AnsiStrings.StrDispose(BufRecv); //p60
     xFlush := False;
     HookTimeOut := OldTimeOut;
  end; //if
  TryNumber := 0;
  BadXfer := True;
  { -- send message length + message to server }
  BufRecv := PAnsiChar(StrAlloc(Buffer32k));
  try // BufRecv
      BufSend := AnsiStrings.StrNew(PAnsiChar(AnsiString(imsg))); //p60
    try // BufSend
      Result := PChar('');
      while BadXfer and (TryNumber < 4) do
      begin
        NetCallPending := True;
        NetTimerStart := Now;
        TryNumber := TryNumber + 1;
        BadXfer := False;
        SocketError := send(hSocket, BufSend^, AnsiStrings.StrLen(BufSend),0); //p60
        if SocketError = SOCKET_ERROR then
          NetError('send', 0);
        BufRecv[0] := #0;
        try
          BufPtr := BufRecv;
          BytesLeft := Buffer32k;
          BytesTotal := 0;
         {Get Security and Application packets}
          SecuritySegment := GetServerPacket(hSocket);
          ApplicationSegment := GetServerPacket(hSocket);
          sBuf := '';
          { -- loop reading TCP buffer until server is finished sending reply }
          repeat
            BytesRead := recv(hSocket, BufPtr^, BytesLeft, 0);
            if BytesRead > 0 then
            begin
              if BufPtr[BytesRead-1] = #4 then
              begin
                sBuf := ConCat(sBuf, BufPtr);
              end //if BufPtr
              else
              begin
                BufPtr[BytesRead] := #0;
                sBuf := ConCat(sBuf, BufPtr);
              end; //else BufPtr
              Inc(BytesTotal, BytesRead);
            end; //if BytesRead > 0
            if BytesRead <= 0 then
            begin
              if BytesRead = SOCKET_ERROR then
                NetError('recv', 0)
              else
                NetError('connection lost', 0);
              break;
            end; //if BytesRead <= 0
          until BufPtr[BytesRead-1] = #4; //repeat
          sBuf := Copy(sBuf, 1, BytesTotal - 1);
          Result := StrAlloc(BytesTotal+1);
          StrCopy(Result, PChar(sBuf));
          if ApplicationSegment = 'U411' then
            BadXfer := True;
          NetCallPending := False;
        finally //try
          sBuf := '';
        end; //try
      end;
    finally //try BufSend
      AnsiStrings.StrDispose(BufSend); //p60
    end; //try BufSend
    if BadXfer then
    begin
      NetError(AnsiStrings.StrPas('Repeated Incomplete Reads on the server'), XWB_BadReads);  //p60
      Result := StrNew('');
    end; //if BadXfer
    { -- if there was on error on the server, display the error code }
    if AnsiChar(Result[0]) = #24 then
    begin
      xString := String(Result);           // JLI 090804
      xString := Copy(xString,2,Length(xString)); // JLI 090804
      NetError(xString, XWB_M_REJECT);
      Result := StrNew('');
    end; //if AnsiChar(Result[0]) = #24
  finally //try BufRecv
    AnsiStrings.StrDispose(BufRecv); //p60
  end; //try BufRecv
end; //function TXWBWinsock.NetCall


{----------------------- TXWBWinsock.tCall --------------------------
----------------------------------------------------------------}
function TXWBWinsock.tCall(hSocket: TSocket; api, apVer: String; Parameters: TParams;
         var Sec , App: PChar; TimeOut: integer ): PChar;
var
  tmp: string;
  ChangeCursor: Boolean;
begin
  HookTimeOut := TimeOut;
  if (string(Api) <> 'XWB IM HERE') and (Screen.Cursor = crDefault) then
    ChangeCursor  := True
  else
    ChangeCursor := False;
  if ChangeCursor then
    Screen.Cursor := crHourGlass;  //P6
  tmp := BuildPar(hSocket, api, apVer, Parameters);
  Result := NetCall(hSocket, tmp);
  StrPCopy(Sec, SecuritySegment);
  StrPCopy(App, ApplicationSegment);
  if ChangeCursor then
    Screen.Cursor := crDefault;
end; //function TXWBWinsock.tCall


{----------------------- TXWBWinsock.NetStart --------------------------
p60 rewrote NetStart to support IPv4/IPv6 dual-stack connections.
----------------------------------------------------------------}
function TXWBWinsock.NetStart (ForegroundM: boolean; Server: string;
         ListenerPort: integer; var hSocket: TSocket): integer;
var
  WinSockData: wsaData; //WinSock 2.2 info for Windows APIs
  ChangeCursor: Boolean;
  pLocalName, pVistAName, pListenerPort: PAnsiChar;
  pHint, pLocalResult, pVistAResult: PAddrInfo; //DNS lookup in getaddrinfo
  DNSLookup: Integer; //Success/fail for DNS lookup in getaddrinfo
  Connected: Boolean;
  LocalAddress, VistAAddress: TSockAddr;
  LocalAddressString: string;
  LocalAddressLength, VistAAddressLength: DWORD;
  Timeout: timeval;
  ipv6only: DWORD;
  y, tmp, upArrow, rAccept, rLost: string;
  tmpPchar: PChar;
  r: integer;
  lin: TLinger;
  s_lin: array [0..3] of AnsiChar absolute lin;
begin
  if Screen.Cursor = crDefault then
    ChangeCursor := True
  else
    ChangeCursor := False;
  if ChangeCursor then
    Screen.Cursor := crHourGlass;
  ipv6only := 0; //WinSock defaults to IPv6-only. We want both IPv4 and IPv6.
  upArrow := string('^');
  rAccept := string('accept');
  rLost := string('(connection lost)');
  //Set timeout value seconds.milliseconds to wait for a response from the server before aborting.
  //Per MSDN, value may be NULL. This might not be needed, or set it to NIL.
  Timeout.tv_sec := 5; //Seconds
  Timeout.tv_usec := 0; //Milliseconds
  //Initiate Windows WinSock DLL
  SocketError := WSAStartup(WinSockVer, WinSockData);
  if SocketError >0 then
    NetError('WSAStartup',0);
  NetCallPending := False;
  //Identify the VistA host (Server) by FQDN, IPv4 address, or IPv6 address
  pVistAName := PAnsiChar(AnsiString(Server));
  New(pHint);
  pHint.ai_flags := AI_CANONNAME + AI_ALL;
  pHint.ai_family := AF_UNSPEC;
  pHint.ai_socktype := SOCK_STREAM;
  pHint.ai_protocol := IPPROTO_TCP;
  pHint.ai_addrlen := 0;
  pHint.ai_canonname := NIL;
  pHint.ai_addr := NIL;
  pHint.ai_next := NIL;
  //Get canonical name for VistA (Server)
  DNSLookup := FGetAddrInfo(pVistAName, NIL, pHint, pVistAResult);
  if DNSLookup <> 0 then
    NetError('getaddrinfo (Server)',0);
  pVistAName := pVistAResult.ai_canonname; //Replace Server name with canonical name of server
  //Using AF_INET6 returns a dual-stack socket that can be used for both IPv4 and IPv6
  hSocket := socket(AF_INET6, SOCK_STREAM, IPPROTO_TCP);
  if hSocket = INVALID_SOCKET then
    NetError('socket',0);
  //Disable the IPV6_V6ONLY socket option to support IPv4/IPv6 dual-stack
  SocketError := setsockopt(hSocket, IPPROTO_IPV6, IPV6_V6ONLY, PAnsiChar(@ipv6only), SizeOf(ipv6only));
  if SocketError = SOCKET_ERROR then
    NetError ('setsocketopt (Local)',0);
  //Set address space sufficient for IPv4 or IPv6
  LocalAddressLength := SizeOf(SOCKADDR_STORAGE);
  VistAAddressLength := SizeOf(SOCKADDR_STORAGE);
  //Use WSAConnectByName to make the initial broker connection, trying all possible combinations.
  pListenerPort := PAnsiChar(AnsiString(IntToStr(ListenerPort)));
  Connected := FWSAConnectByName(hSocket, pVistAName, pListenerPort,
               LocalAddressLength, LocalAddress,
               VistAAddressLength, VistAAddress, Timeout, NIL);
  if not Connected then
    NetError('WSAConnectByName',0);
  //Get address of local system that was used to make connection
  LocalAddressString := FAddrToString(LocalAddress);
  //Get canonical name for local host (Client) for that address
  DNSLookup := FGetAddrInfo(PAnsiChar(AnsiString(LocalAddressString)), NIL, pHint, pLocalResult);
  if DNSLookup <> 0 then
    NetError('getaddrinfo (Client)',0);
  pLocalName := pLocalResult.ai_canonname;
  //Don't send an IPv6 address as a host name due to VistA x-ref "AS2" in SIGN-ON LOG
  if AnsiContainsStr(pLocalName,':') then
  begin
    DNSLookup := gethostname(pLocalName, 255); // get name of local system
    if DNSLookup > 0 then
      NetError ('gethostname (local)',0);
  end;
  y := '[XWB]' + '10' + IntToStr(CountWidth) + '0' + '4'+#$A + 'TCPConnect50'
       + LPack(LocalAddressString,CountWidth) + 'f0' + LPack(IntToStr(0),CountWidth)
       + 'f0' + LPack(String(pLocalName),CountWidth) + 'f' + #4;
  HookTimeOut := 30;
  tmpPChar := NetCall(hSocket, PChar(y));
  tmp := tmpPchar;
  StrDispose(tmpPchar);
  if CompareStr(tmp, rlost) = 0 then
  begin
    lin.l_onoff := 1;
    lin.l_linger := 0;
    SocketError := setsockopt(hSocket, SOL_SOCKET, SO_LINGER, s_lin, sizeof(lin));
    if SocketError = SOCKET_ERROR then
      NetError( 'setsockopt (connect)',0);
    closesocket(hSocket);
    WSACleanup;
    Result := 10002;
    exit;
  end; //if CompareStr
  r := CompareStr(tmp, rAccept);
  if r <> 0 then
    NetError ('NetCall',XWB_M_REJECT);
  if ChangeCursor then
    Screen.Cursor := crDefault;
  Dispose(pHint);
  NetStart := 0;
  // -- connection established, socket handle now in:  hSocket
end; //function TXWBWinsock.NetStart


{----------------------- TXWBWinsock.NetStop --------------------------
----------------------------------------------------------------}
procedure TXWBWinsock.NetStop(hSocket: TSocket);
var
  tmp: string;
  lin: TLinger;
  s_lin: array [0..3] of AnsiChar absolute lin;
  ChangeCursor: Boolean;
  tmpPChar: PChar;
  Str: String;
  x: array [0..15] of Char;
begin
  if not IsConnected then exit;
  if Screen.Cursor = crDefault then
    ChangeCursor := True
  else
    ChangeCursor := False;
  if ChangeCursor then
    Screen.Cursor := crHourGlass;
  if hSocket <= 0 then
  begin
    if ChangeCursor then
      screen.cursor := crDefault;
      exit;
  end; //if hSocket <= 0
  StrPcopy(x, StrPack(StrPack('#BYE#',5),5));
  Str := '[XWB]' + '10'+IntToStr(CountWidth)+'0' +'4'+#5+'#BYE#'+#4;
  if hSocket <> INVALID_SOCKET then
  begin
    tmpPChar := NetCall(hSocket,Str);
 	  tmp := tmpPChar;
    StrDispose(tmpPChar);
    lin.l_onoff := 1;                    { -- shut down the M handler};
    lin.l_linger := 0;
    SocketError := setsockopt(hSocket, SOL_SOCKET, SO_LINGER, s_lin, sizeof(lin));
    if SocketError = SOCKET_ERROR then
      NetError( 'setsockopt (connect)',0);
  	SocketError := closesocket(hSocket);  { -- close the socket}
  end;
  SocketError := WSAUnhookBlockingHook;     { -- restore the default mechanism}
  SocketError := WSACleanup;                { -- shutdown TCP API}
  if SocketError > 0 then
    NetError( 'WSACleanup',0);             { -- check blocking calls, etc.}
  if ChangeCursor then
    Screen.Cursor := crDefault;
  IsConnected := False;
end; //procedure TXWBWinsock.NetStop


{----------------------- TXWBWinsock.CloseSockSystem --------------------------
----------------------------------------------------------------}
procedure TXWBWinsock.CloseSockSystem(hSocket: TSocket; s: string);
var
   lin: TLinger;
   s_lin: array [0..3] of AnsiChar absolute lin;
begin
   lin.l_onoff := 1;
   lin.l_linger := 0;
   SocketError := setsockopt(hSocket, SOL_SOCKET, SO_LINGER, s_lin, sizeof(lin));
   if SocketError = SOCKET_ERROR then
     NetError( 'setsockopt (connect)',0);
     closesocket(hSocket);
     WSACleanup;
     ShowMessage(s);  //TODO See NetStop for SocketError := WSACleanup;
     halt(1);
end; //procedure TXWBWinsock.CloseSockSystem


{----------------------- TXWBWinsock.GetServerPacket --------------------------
----------------------------------------------------------------}
function TXWBWinsock.GetServerPacket(hSocket: TSocket): string;
var
  s,sb: PAnsiChar;
  buflen: integer;
begin
  s := AnsiStrings.AnsiStrAlloc(1); //p60
  s[0] := #0;
  buflen := recv(hSocket, s^, 1, 0); {get length of segment}
  if buflen = SOCKET_ERROR then   // 040720 code added to check for the timing problem if initial attempt to read during connection fails
  begin
    sleep(100);
    buflen := recv(hSocket, s^, 1, 0);
  end; //if
  if buflen = SOCKET_ERROR then
    NetError( 'recv',0);
  buflen := ord(s[0]);
  sb := AnsiStrings.AnsiStrAlloc(buflen+1); //p60
  sb[0] := #0;
  buflen := recv(hSocket, sb^, buflen, 0); {get security segment}
  if buflen = SOCKET_ERROR then
    NetError( 'recv',0);
  sb[buflen] := #0;
  Result := AnsiStrings.StrPas(sb); //p60
  AnsiStrings.StrDispose(sb); //p60
  AnsiStrings.StrDispose(s); //p60
end; //function TXWBWinsock.GetServerPacket


{----------------------- TXWBWinsock.Create --------------------------
----------------------------------------------------------------}
constructor TXWBWinsock.Create;
begin
  inherited;
  CountWidth := 3;
end; //constructor TXWBWinsock.Create


{----------------------- TXWBWinsock.NetError --------------------------
----------------------------------------------------------------}
procedure TXWBWinsock.NetError(Action: string; ErrType: integer);
var
  x,s: string;
  r: integer;
  BrokerError: EBrokerError;
  TimeOut: Double;
begin
  Screen.Cursor := crDefault;
  r := 0;
  if ErrType > 0 then r := ErrType;
  if ErrType = 0 then
  begin
    if NetcallPending then
    begin
      //Indicate WSAETIMEDOUT error instead of WSAEINTR when time out period expires
      if HookTimeOut > 0 then
      begin
        TimeOut := HookTimeOut * OneSecond;
        if Now > (NetTimerStart + TimeOut) then
          r := WSAETIMEDOUT;
      end; //if HookTimeOut >0
    end; //if NetcallPending
    if r = 0 then
      r := WSAGetLastError;
      if (r = WSAEINTR) or (r = WSAETIMEDOUT) then
        xFlush := True;
  end; //if ErrType = 0
  case r of
    WSAEINTR           : x := 'WSAEINTR - Interrupted function call.';
    WSAEBADF           : x := 'WSAEBADF - File handle is not valid.';
    WSAEACCES          : x := 'WXAEACCES - Permission denied.';
    WSAEFAULT          : x := 'WSAEFAULT - Bad address.';
    WSAEINVAL          : x := 'WSAEINVAL - Invalid argument.';
    WSAEMFILE          : x := 'WSAEMFILE - Too many open files.';
    WSAEWOULDBLOCK     : x := 'WSAEWOULDBLOCK - Resource temporarily unavailable.';
    WSAEINPROGRESS     : x := 'WSAEINPROGRESS - Operation now in progress.';
    WSAEALREADY        : x := 'WSAEALREADY - Operation already in progress.';
    WSAENOTSOCK        : x := 'WSAENOTSOCK - Socket operation on nonsocket.';
    WSAEDESTADDRREQ    : x := 'WSAEDESTADDRREQ - Destination address required.';
    WSAEMSGSIZE        : x := 'WSAEMSGSIZE - Message too long.';
    WSAEPROTOTYPE      : x := 'WSAEPROTOTYPE - Protocol wrong type for socket.';
    WSAENOPROTOOPT     : x := 'WSAENOPROTOOPT - Bad protocol option.';
    WSAEPROTONOSUPPORT : x := 'WSAEPROTONOSUPPORT - Protocol not supported.';
    WSAESOCKTNOSUPPORT : x := 'WSAESOCKTNOSUPPORT - Socket type not supported.';
    WSAEOPNOTSUPP      : x := 'WSAEOPNOTSUPP - Operation not supported.';
    WSAEPFNOSUPPORT    : x := 'WSAEPFNOSUPPORT - Protocol family not supported.';
    WSAEAFNOSUPPORT    : x := 'WSAEAFNOSUPPORT - Address family not supported by protocol family.';
    WSAEADDRINUSE      : x := 'WSAEADDRINUSE - Address already in use.';
    WSAEADDRNOTAVAIL   : x := 'WSAEADDRNOTAVAIL - Cannot assign requested address.';
    WSAENETDOWN        : x := 'WSAENETDOWN - Network is down.';
    WSAENETUNREACH     : x := 'WSAENETUNREACH - Network is unreachable.';
    WSAENETRESET       : x := 'WSAENETRESET - Network dropped connection on reset.';
    WSAECONNABORTED    : x := 'WSAECONNABORTED - Software caused connection abort.';
    WSAECONNRESET      : x := 'WSAECONNRESET - Connection reset by peer.';
    WSAENOBUFS         : x := 'WSAENOBUFS - No buffer space available.';
    WSAEISCONN         : x := 'WSAEISCONN - Socket is already connected.';
    WSAENOTCONN        : x := 'WSAENOTCONN - Socket is not connected.';
    WSAESHUTDOWN       : x := 'WSAESHUTDOWN - Cannot send after socket shutdown.';
    WSAETOOMANYREFS    : x := 'WSAETOOMANYREFS - Too many references.';
    WSAETIMEDOUT       : x := 'WSAETIMEDOUT - Connection timed out.';
    WSAECONNREFUSED    : x := 'WSAECONNREFUSED - Connection refused.';
    WSAELOOP           : x := 'WSAELOOP - Cannot translate name.';
    WSAENAMETOOLONG    : x := 'WSAENAMETOOLONG - Name too long.';
    WSAEHOSTDOWN       : x := 'WSAEHOSTDOWN - Host is down.';
    WSAEHOSTUNREACH    : x := 'WSAEHOSTUNREACH - No route to host.';
    WSAENOTEMPTY       : x := 'WSAENOTEMPTY - Directory not empty.';
    WSAEPROCLIM        : x := 'WSAEPROCLIM - Too many processes.';
    WSAEUSERS          : x := 'WSAEUSERS - User quota exceeded.';
    WSAEDQUOT          : x := 'WSAEDQUOT - Disk quota exceeded.';
    WSAESTALE          : x := 'WSAESTALE - Stale file handle reference.';
    WSAEREMOTE         : x := 'WSAEREMOTE - Item is remote.';
    WSASYSNOTREADY     : x := 'WSASYSNOTREADY - Network subsystem is unavailable.';
    WSAVERNOTSUPPORTED : x := 'WSAVERNOTSUPPORTED - Winsock.dll version out of range.';
    WSANOTINITIALISED  : x := 'WSANOTINITIALISED - Successful WSAStartup not yet performed.';
    WSATYPE_NOT_FOUND  : x := 'WSATYPE_NOT_FOUND - Class type not found.';
    WSAHOST_NOT_FOUND  : x := 'WSAHOST_NOT_FOUND - Host not found.';
    WSATRY_AGAIN       : x := 'WSATRY_AGAIN - Nonauthoritative host not found.';
    WSANO_RECOVERY     : x := 'WSANO_RECOVERY - This is a nonrecoverable error.';
    WSANO_DATA         : x := 'WSANO_DATA - Valid name, no data record of requested type.';

    XWB_NO_HEAP        : x := 'Insufficient Heap';
    XWB_M_REJECT       : x := 'M Error - Use ^XTER';
    XWB_BadReads       : x := 'Server unable to read input data correctly.';
    XWB_BadSignOn      : x := 'Sign-on was not completed.';
    XWB_ExeNoMem       : x := 'System was out of memory, executable file was corrupt, or relocations were invalid.';
    XWB_ExeNoFile      : x := 'File was not found.';
    XWB_ExeNoPath      : x := 'Path was not found.';
    XWB_ExeShare       : x := 'Attempt was made to dynamically link to a task,' +
                              ' or there was a sharing or network-protection error.';
    XWB_ExeSepSeg      : x := 'Library required separate data segments for each task.';
    XWB_ExeLoMem       : x := 'There was insufficient memory to start the application.';
    XWB_ExeWinVer      : x := 'Windows version was incorrect.';
    XWB_ExeBadExe      : x := 'Executable file was invalid.' +
                              ' Either it was not a Windows application or there was an error in the .EXE image.';
    XWB_ExeDifOS       : x := 'Application was designed for a different operating system.';
    XWB_RpcNotReg      : x := 'Remote procedure not registered to application.';
    XWB_BldConnectList : x := 'BrokerConnections list could not be created';
    XWB_NullRpcVer     : x := 'RpcVersion cannot be empty.' + #13 + 'Default is 0 (zero).';
    else x := IntToStr(r);
  end;
  if r = 0 then
    x := 'No error code returned';
  s := 'Error encountered.' + chr(13)+chr(10) + 'Function was: ' + Action + chr(13)+chr(10) + 'Error was: ' + x;
  BrokerError := EBrokerError.Create(s);
  BrokerError.Action := Action;
  BrokerError.Code := r;
  BrokerError.Mnemonic := x;
  raise BrokerError;
end; //procedure TXWBWinsock.NetError


end.

