function LoadWinSock2: Boolean;
procedure GetPacketInterceptorList(List: TStringList);

var
  WSACreateEvent: function: THandle stdcall;
  WSAResetEvent: function(hEvent: THandle): Boolean stdcall;
  WSACloseEvent: function(hEvent: THandle): Boolean stdcall;
  WSAEventSelect: function(s: TSocket; hEventObject: THandle; lNetworkEvents: Integer): Integer stdcall;

implementation

uses
  ActiveX, MidConst, RTLConsts, ZLibEx;

var
  hWinSock2: THandle;

{ Utility functions }

procedure CheckSignature(Sig: Integer);
begin
  if (Sig and $FF00 <> CallSig) and
     (Sig and $FF00 <> ResultSig) then
    raise Exception.CreateRes(@SInvalidDataPacket);
end;

function LoadWinSock2: Boolean;
const
  DLLName = 'ws2_32.dll';
begin
  Result := hWinSock2 > 0;
  if Result then Exit;
  hWinSock2 := LoadLibrary(PChar(DLLName));
  Result := hWinSock2 > 0;
  if Result then
  begin
    WSACreateEvent := GetProcAddress(hWinSock2, 'WSACreateEvent');
    WSAResetEvent := GetProcAddress(hWinSock2, 'WSAResetEvent');
    WSACloseEvent := GetProcAddress(hWinSock2, 'WSACloseEvent');
    WSAEventSelect := GetProcAddress(hWinSock2, 'WSAEventSelect');
  end;
end;

procedure GetPacketInterceptorList(List: TStringList);
var
  EnumGUID: IEnumGUID;
  Fetched: Cardinal;
  Guid: TGUID;
  Rslt: HResult;
  CatInfo: ICatInformation;
  I: Integer;
  ClassIDKey: HKey;
  S: string;
  Buffer: array[0..255] of Char;
begin
  List.Clear;
  Rslt := CoCreateInstance(CLSID_StdComponentCategoryMgr, nil,
    CLSCTX_INPROC_SERVER, ICatInformation, CatInfo);
  if Succeeded(Rslt) then
  begin
    OleCheck(CatInfo.EnumClassesOfCategories(1, @CATID_MIDASInterceptor, 0, nil, EnumGUID));
    while EnumGUID.Next(1, Guid, Fetched) = S_OK do
      List.Add(ClassIDToProgID(Guid));
  end else
  begin
    if RegOpenKey(HKEY_CLASSES_ROOT, 'CLSID', ClassIDKey) <> 0 then
      try
        I := 0;
        while RegEnumKey(ClassIDKey, I, Buffer, SizeOf(Buffer)) = 0 do
        begin
          S := Format(SCatImplKey,[Buffer, GUIDToString(CATID_MIDASInterceptor)]);
          List.Add(ClassIDToProgID(StringToGUID(Buffer)));
          Inc(I);
        end;
      finally
        RegCloseKey(ClassIDKey);
      end;
  end;
end;

procedure FreeWinSock2;
begin
  if hWinSock2 > 0 then
  begin
    WSACreateEvent := nil;
    WSAResetEvent := nil;
    WSACloseEvent := nil;
    WSAEventSelect := nil;
    FreeLibrary(hWinSock2);
  end;
  hWinSock2 := 0;
end;

procedure GetDataBrokerList(List: TStringList; const RegCheck: string);

  function OpenRegKey(Key: HKey; const SubKey: string): HKey;
  begin
    if Windows.RegOpenKey(Key, PChar(SubKey), Result) <> 0 then Result := 0;
  end;

  function EnumRegKey(Key: HKey; Index: Integer; var Value: string): Boolean;
  var
    Buffer: array[0..255] of Char;
  begin
    Result := False;
    if Windows.RegEnumKey(Key, Index, Buffer, SizeOf(Buffer)) = 0 then
    begin
      Value := Buffer;
      Result := True;
    end;
  end;

  function QueryRegKey(Key: HKey; const SubKey: string;
    var Value: string): Boolean;
  var
    BufSize: Longint;
    Buffer: array[0..255] of Char;
  begin
    Result := False;
    BufSize := SizeOf(Buffer);
    if Windows.RegQueryValue(Key, PChar(SubKey), Buffer, BufSize) = 0 then
    begin
      Value := Buffer;
      Result := True;
    end;
  end;

  procedure CloseRegKey(Key: HKey);
  begin
    RegCloseKey(Key);
  end;

var
  I: Integer;
  ClassIDKey: HKey;
  ClassID, S: string;
begin
  List.Clear;
  ClassIDKey := OpenRegKey(HKEY_CLASSES_ROOT, 'CLSID');
  if ClassIDKey <> 0 then
    try
      I := 0;
      while EnumRegKey(ClassIDKey, I, ClassID) do
      begin
        if RegCheck <> '' then
        begin
          QueryRegKey(ClassIDKey, ClassID + '\' + RegCheck, S);
          if S <> SFlagOn then continue;
        end;
        if not QueryRegKey(ClassIDKey, ClassID + '\Control', S) and
           QueryRegKey(ClassIDKey, ClassID + '\ProgID', S) and
           QueryRegKey(ClassIDKey, ClassID + '\TypeLib', S) and
           QueryRegKey(ClassIDKey, ClassID + '\Version', S) and
           QueryRegKey(ClassIDKey, ClassID + '\Borland DataBroker', S) then
          List.Add(ClassIDToProgID(StringToGUID(ClassID)));
        Inc(I);
      end;
    finally
      CloseRegKey(ClassIDKey);
    end;
end;

{ TDataBlock }

constructor TDataBlock.Create;
begin
  inherited Create;
  FIgnoreStream := False;
  FStream := TMemoryStream.Create;
  Clear;
end;

destructor TDataBlock.Destroy;
begin
  if not FIgnoreStream then
    FStream.Free;
  inherited Destroy;
end;

{ TDataBlock.IDataBlock }

function TDataBlock.GetBytesReserved: Integer;
begin
  Result := SizeOf(Integer) * 2;
end;

function TDataBlock.GetMemory: Pointer;
var
  DataSize: Integer;
begin
  FStream.Position := 4;
  DataSize := FStream.Size - BytesReserved;
  FStream.Write(DataSize, SizeOf(DataSize));
  Result := FStream.Memory;
end;

function TDataBlock.GetSize: Integer;
begin
  Result := FStream.Size - BytesReserved;
end;

procedure TDataBlock.SetSize(Value: Integer);
begin
  FStream.Size := Value + BytesReserved;
end;

function TDataBlock.GetStream: TStream;
var
  DataSize: Integer;
begin
  FStream.Position := 4;
  DataSize := FStream.Size - BytesReserved;
  FStream.Write(DataSize, SizeOf(DataSize));
  FStream.Position := 0;
  Result := FStream;
end;

function TDataBlock.GetSignature: Integer;
begin
  FStream.Position := 0;
  FStream.Read(Result, SizeOf(Result));
end;

procedure TDataBlock.SetSignature(Value: Integer);
begin
  FStream.Position := 0;
  FStream.Write(Value, SizeOf(Value));
end;

procedure TDataBlock.Clear;
begin
  FStream.Size := BytesReserved;
  FReadPos := BytesReserved;
  FWritePos := BytesReserved;
end;

function TDataBlock.Write(const Buffer; Count: Integer): Integer;
begin
  FStream.Position := FWritePos;
  Result := FStream.Write(Buffer, Count);
  FWritePos := FStream.Position;
end;

function TDataBlock.Read(var Buffer; Count: Integer): Integer;
begin
  FStream.Position := FReadPos;
  Result := FStream.Read(Buffer, Count);
  FReadPos := FStream.Position;
end;

procedure TDataBlock.IgnoreStream;
begin
  FIgnoreStream := True;
end;

function TDataBlock.InitData(Data: Pointer; DataLen: Integer; CheckLen: Boolean): Integer; stdcall;
var
  Sig: Integer;
  P: Pointer;
begin
  P := Data;
  if DataLen < MINDATAPACKETSIZE then
    raise Exception.CreateRes(@SInvalidDataPacket);
  Sig := Integer(P^);
  P := Pointer(Integer(Data) + SizeOf(Sig));
  CheckSignature(Sig);
  Signature := Sig;
  Result := Integer(P^);
  P := Pointer(Integer(P) + SizeOf(Result));
  if CheckLen then
  begin
    if (Result <> DataLen - MINDATAPACKETSIZE) then
      raise Exception.CreateRes(@SInvalidDataPacket);
    Size := Result;
    if Result > 0 then
      Write(P^, Result);
  end else
  begin
    Size := DataLen - MINDATAPACKETSIZE;
    if Size > 0 then
      Write(P^, Size);
  end;
end;

{ TDataBlockInterpreter }

const

  EasyArrayTypes = [varSmallInt, varInteger, varSingle, varDouble, varCurrency,
                    varDate, varBoolean, varShortInt, varByte, varWord, varLongWord];

  VariantSize: array[0..varLongWord] of Word  = (0, 0, SizeOf(SmallInt), SizeOf(Integer),
    SizeOf(Single), SizeOf(Double), SizeOf(Currency), SizeOf(TDateTime), 0, 0,
    SizeOf(Integer), SizeOf(WordBool), 0, 0, 0, 0, SizeOf(ShortInt), SizeOf(Byte),
    SizeOf(Word), SizeOf(LongWord));

constructor TDataBlockInterpreter.Create(SendDataBlock: ISendDataBlock; CheckRegValue: string);
begin
  inherited Create;
  FSendDataBlock := SendDataBlock;
  FDispatchList := TList.Create;
  FCheckRegValue := CheckRegValue;
end;

destructor TDataBlockInterpreter.Destroy;
var
  i: Integer;
begin
  for i := FDispatchList.Count - 1 downto 0 do
    TDataDispatch(FDispatchList[i]).FInterpreter := nil;
  FDispatchList.Free;
  FSendDataBlock := nil;
  inherited Destroy;
end;

procedure TDataBlockInterpreter.AddDispatch(Value: TDataDispatch);
begin
  if FDispatchList.IndexOf(Value) = -1 then
    FDispatchList.Add(Value);
end;

procedure TDataBlockInterpreter.RemoveDispatch(Value: TDataDispatch);
begin
  FDispatchList.Remove(Value);
end;

{ Variant conversion methods }

function TDataBlockInterpreter.GetVariantPointer(const Value: OleVariant): Pointer;
begin
  case VarType(Value) of
    varEmpty, varNull: Result := nil;
    varDispatch: Result := TVarData(Value).VDispatch;
    varVariant: Result := @Value;
    varUnknown: Result := TVarData(Value).VUnknown;
  else
    Result := @TVarData(Value).VPointer;
  end;
end;

procedure TDataBlockInterpreter.CopyDataByRef(const Source: TVarData; var Dest: TVarData);
var
  VType: Integer;
begin
  VType := Source.VType;
  if Source.VType and varArray = varArray then
  begin
    VarClear(OleVariant(Dest));
    SafeArrayCheck(SafeArrayCopy(PSafeArray(Source.VArray), PSafeArray(Dest.VArray)));
  end else
    case Source.VType and varTypeMask of
      varEmpty, varNull: ;
      varOleStr:
      begin
        if (Dest.VType and varTypeMask) <> varOleStr then
          Dest.VOleStr := SysAllocString(Source.VOleStr)
        else if (Dest.VType and varByRef) = varByRef then
          SysReallocString(PBStr(Dest.VOleStr)^,Source.VOleStr)
        else
          SysReallocString(Dest.VOleStr,Source.VOleStr);
      end;
      varDispatch: Dest.VDispatch := Source.VDispatch;
      varVariant: CopyDataByRef(PVarData(Source.VPointer)^, Dest);
      varUnknown: Dest.VUnknown := Source.VUnknown;
    else
      if Dest.VType = 0 then
        OleVariant(Dest) := OleVariant(Source)
      else if Dest.VType and varByRef = varByRef then
      begin
        VType := VType or varByRef;
        Move(Source.VPointer, Dest.VPointer^, VariantSize[Source.VType and varTypeMask]);
      end
      else
        Move(Source.VPointer, Dest.VPointer, VariantSize[Source.VType and varTypeMask]);
    end;
  Dest.VType := VType;
end;

function TDataBlockInterpreter.ReadArray(VType: Integer;
  const Data: IDataBlock): OleVariant;
var
  Flags: TVarFlags;
  LoDim, HiDim, Indices, Bounds: PIntArray;
  DimCount, VSize, i: Integer;
  {P: Pointer;}
  V: OleVariant;
  LSafeArray: PSafeArray;
  P: Pointer;
begin
  VarClear(Result);
  Data.Read(DimCount, SizeOf(DimCount));
  VSize := DimCount * SizeOf(Integer);
  GetMem(LoDim, VSize);
  try
    GetMem(HiDim, VSize);
    try
      Data.Read(LoDim^, VSize);
      Data.Read(HiDim^, VSize);
      GetMem(Bounds, VSize * 2);
      try
        for i := 0 to DimCount - 1 do
        begin
          Bounds[i * 2] := LoDim[i];
          Bounds[i * 2 + 1] := HiDim[i];
        end;
        Result := VarArrayCreate(Slice(Bounds^,DimCount * 2), VType and varTypeMask);
      finally
        FreeMem(Bounds);
      end;
      if VType and varTypeMask in EasyArrayTypes then
      begin
        Data.Read(VSize, SizeOf(VSize));
        P := VarArrayLock(Result);
        try
          Data.Read(P^, VSize);
        finally
          VarArrayUnlock(Result);
        end;
      end else
      begin
        LSafeArray := PSafeArray(TVarData(Result).VArray);
        GetMem(Indices, VSize);
        try
          FillChar(Indices^, VSize, 0);
          for I := 0 to DimCount - 1 do
            Indices[I] := LoDim[I];
          while True do
          begin
            V := ReadVariant(Flags, Data);
            if VType and varTypeMask = varVariant then
              SafeArrayCheck(SafeArrayPutElement(LSafeArray, Indices^, V))