qisocketc.pas

QiMidas组件全代码版支持d2006 QiMidas组件全代码版支持d2006

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;


{ TQiSocketTransport }

constructor TQiSocketTransport.Create;
begin
  inherited Create;
  FInterceptor := nil;
  FEvent := 0;
end;

destructor TQiSocketTransport.Destroy;
begin
  FInterceptor := nil;
  SetConnected(False);
  inherited Destroy;
end;

function TQiSocketTransport.GetWaitEvent: THandle;
begin
  FEvent := WSACreateEvent;
  WSAEventSelect(FSocket.SocketHandle, FEvent, FD_READ or FD_CLOSE);
  Result := FEvent;
end;

function TQiSocketTransport.GetConnected: Boolean;
begin
  Result := (FSocket <> nil) and (FSocket.Connected);
end;

procedure TQiSocketTransport.SetConnected(Value: Boolean);
begin
  if GetConnected = Value then Exit;
  if Value then
  begin
    if (FAddress = '') and (FHost = '') then
      raise ESocketConnectionError.CreateRes(@SNoAddress);
    FClientSocket := TClientSocket.Create(nil);
    FClientSocket.ClientType := ctBlocking;
    FSocket := FClientSocket.Socket;
    FClientSocket.Port := FPort;
    if FAddress <> '' then
      FClientSocket.Address := FAddress else
      FClientSocket.Host := FHost;
    FClientSocket.Open;
  end else
  begin
    if FSocket <> nil then FSocket.Close;
    FSocket := nil;
    FreeAndNil(FClientSocket);
    if FEvent <> 0 then WSACloseEvent(FEvent);
    FEvent := 0;
  end;
end;

function TQiSocketTransport.Receive(WaitForInput: Boolean; Context: Integer): IDataBlock;
var
  RetLen, Sig, StreamLen, MaxReceive: Integer;
  P: Pointer;
  FDSet: TFDSet;
  TimeVal: PTimeVal;
  RetVal: Integer;

  bFirst: boolean;
  //make by ZhaoQuanqi  
  DSize: Integer;
  dzp: Pointer;
begin
  Result := nil;
  TimeVal := nil;
  FD_ZERO(FDSet);
  FD_SET(FSocket.SocketHandle, FDSet);
  if not WaitForInput then
  begin
    New(TimeVal);
    TimeVal.tv_sec := 0;
    TimeVal.tv_usec := 1;
  end;
  RetVal := select(0, @FDSet, nil, nil, TimeVal);
  if Assigned(TimeVal) then
    FreeMem(TimeVal);
  if RetVal = SOCKET_ERROR then
    raise ESocketConnectionError.Create(SysErrorMessage(WSAGetLastError));
  if (RetVal = 0) then Exit;

  RetLen := FSocket.ReceiveBuf(Sig, SizeOf(Sig));
  if RetLen <> SizeOf(Sig) then
    raise ESocketConnectionError.Create('数据读取错误，可能是连接被强行关闭!'); //CreateRes(@SSocketReadError);
  CheckSignature(Sig);
  RetLen := FSocket.ReceiveBuf(StreamLen, SizeOf(StreamLen));
  if RetLen = 0 then
    raise ESocketConnectionError.Create('数据读取错误，可能是连接被强行关闭!'); //CreateRes(@SSocketReadError);
  if RetLen <> SizeOf(StreamLen) then
    raise ESocketConnectionError.Create('数据读取错误，可能是连接被强行关闭!'); //CreateRes(@SSocketReadError);
  Result := TDataBlock.Create as IDataBlock;
  Result.Size := StreamLen;
  Result.Signature := Sig;
  P := Result.Memory;
  Inc(Integer(P), Result.BytesReserved);
 {this next line is for safety , because I detect one case where the code can't not read
  the first time, 60000 is tentative, maybe INFINITE is correct}
  MaxReceive:=0;
  if (StreamLen > 0) then
  begin
    MaxReceive:=StreamLen;
    WaitForSingleObject(FEvent, {INFINITE}60000);
  end;
 {the next line maybe I can don't use , but I keep it because the same case in first time}
  bFirst := True;

  while StreamLen > 0 do
  begin
    RetLen:=Min(40960,StreamLen);
    RetLen := FSocket.ReceiveBuf(P^, RetLen);
    if RetLen = 0 then
    begin
      {this next line is because If you retry you get the correct data!!}
      if not bFirst then 
          raise ESocketConnectionError.Create('数据读取错误，可能是连接被强行关闭!'); //CreateRes(@SSocketReadError);

      bFirst := False; 
    end; 

    if RetLen > 0 then
    begin
      Dec(StreamLen, RetLen);
      Inc(Integer(P), RetLen);
      if Assigned(FNetEventsOwner) then FNetEventsOwner.DoReceiveProgress(Self,MaxReceive-StreamLen,MaxReceive);
    end;

    {This is the CODE this the more important part of the fix}
    if StreamLen > 0 then {Only when you need mare than one recv, i fyou put this code before
                           reveivebuf you are an step delayed  and the connection don't close
                           or has many time to read , because  WSAResetEvent(FEvent) in caller
                           function!}
    begin
      {I wait for read, maybe you can change 90000 with INFINITE}
      if (WaitForSingleObject(FEvent, {INFINITE}60000) = WAIT_OBJECT_0) then
      begin
        WSAResetEvent(FEvent);{I reset the event, very important because Wait don't work}
      end
      else
      begin
        if Assigned(FNetEventsOwner) and FNetEventsOwner.GetSupportCallbacks then
           raise ESocketConnectionError.Create('Read Error Single Object Timeout');
      end;
    end;
  end;
  if StreamLen <> 0 then
    raise ESocketConnectionError.CreateRes(@SInvalidDataPacket);
  {make by ZhaoQuanqi}
  if Result.Size = 0 then Exit;
  try
    { Skip BytesReserved bytes of data }
    dzp:=nil;
    P := Pointer(Integer(Result.Memory) + Result.BytesReserved);
    DSize := PInteger(P)^;
    ZDecompress(Pointer(Integer(P) + SizeOf(DSize)),Result.Size - SizeOf(DSize),dzp,DSize,DSize);
    { Clear the datablock, then write the uncompressed data back into the
      datablock }
    Result.Clear;
    Result.Write(dzp^, DSize);
  finally
    FreeMem(dzp);
  end;
  {make by ZhaoQuanqi}
//  InterceptIncoming(Result);
end;

function TQiSocketTransport.Send(const Data: IDataBlock): Integer;
var
  ZP: Pointer;
//  Sizes: array[0..2] of Integer;
  Size,ZSize:Integer;
begin
  Result := 0;
  //InterceptOutgoing(Data);
  Size:=Data.Size;
  if Size>0 then
  begin
    ZP:=nil;
    try
      ZCompress(Pointer(Integer(Data.Memory) + Data.BytesReserved),Size,ZP,ZSize,zcFastest);
      Data.Clear;
      Data.Write(Size,SizeOf(Size));
      Data.Write(ZP^,ZSize);
    finally
      if ZP<>nil then FreeMem(ZP);
    end;
  end;
  FSocket.SendBuf(Data.Memory^, Data.Size + Data.BytesReserved);
  (*
  {make by ZhaoQuanqi}
   ZP:=nil;
   P:=Data.Memory;
  try
    ZSize:=0;
    Sizes[0]:=Integer(P^);
    Sizes[2]:=Data.Size;
    if Sizes[2]<>0 then ZCompress(Pointer(Integer(P) + Data.BytesReserved),Sizes[2],ZP,ZSize);
    Sizes[1]:=ZSize+SizeOf(Integer);
    FSocket.SendBuf(Sizes[0],SizeOf(Integer)*3);
    FSocket.SendBuf(ZP^,ZSize);
  finally
    if ZP<>nil then FreeMem(ZP);
  end;
  {make by ZhaoQuanqi}
  *)
end;
(*
function TQiSocketTransport.CheckInterceptor: Boolean;
var
  GUID: TGUID;
begin
  if not Assigned(FInterceptor) and (FInterceptGUID <> '') then
    if not FCreateAttempted then
    try
      FCreateAttempted := True;
      Guid := StringToGuid(FInterceptGUID);
      FInterceptor := CreateComObject(Guid) as IDataIntercept;
    except
      { raise no exception if the creating failed }
    end;
  Result := Assigned(FInterceptor);
end;

procedure TQiSocketTransport.InterceptIncoming(const Data: IDataBlock);
begin
  if CheckInterceptor then
    FInterceptor.DataIn(Data);
end;

procedure TQiSocketTransport.InterceptOutgoing(const Data: IDataBlock);
begin
  if CheckInterceptor then
    FInterceptor.DataOut(Data);
end;
*)
procedure TQiSocketTransport.SetNetEventsOwner(const Value: IQiNetEvents);
begin
  FNetEventsOwner := Value;
end;

{ TQiSocketConnection }

constructor TQiSocketConnection.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FPort := 211;
end;

function TQiSocketConnection.IsAddressStored: Boolean;
begin
  Result := (ObjectBroker = nil) and (Address <> '');
end;

procedure TQiSocketConnection.SetAddress(Value: string);
begin
  if Value <> '' then
    FHost := '';
  FAddress := Value;
end;

function TQiSocketConnection.IsHostStored: Boolean;
begin
  Result := (ObjectBroker = nil) and (Host <> '');
end;

procedure TQiSocketConnection.SetHost(Value: string);
begin
  if Value <> '' then
    FAddress := '';
  FHost := Value;
end;

function TQiSocketConnection.CreateTransport: ITransport;
var
  SocketTransport: TQiSocketTransport;
begin
  if SupportCallbacks then
    if not LoadWinSock2 then raise Exception.CreateRes(@SNoWinSock2);
  if (FAddress = '') and (FHost = '') then
    raise ESocketConnectionError.CreateRes(@SNoAddress);
  SocketTransport := TQiSocketTransport.Create;
  SocketTransport.Host := FHost;
  SocketTransport.Address := FAddress;
  SocketTransport.Port := FPort;
  SocketTransport.InterceptGUID := InterceptGUID;
  SocketTransport.NetEventsOwner:=Self;
  Result := SocketTransport as ITransport;
end;

procedure TQiSocketConnection.DoConnect;
var
  Comp: string;
  p, i: Integer;
begin
  if (ObjectBroker <> nil) then
  begin
    repeat
      if FAddress <> '' then
        Comp := FAddress else
      if FHost <> '' then
        Comp := FHost else
      if ServerGUID <> '' then
        Comp := ObjectBroker.GetComputerForGUID(GetServerCLSID) else
        Comp := ObjectBroker.GetComputerForProgID(ServerName);
      try
        p := ObjectBroker.GetPortForComputer(Comp);
        if p > 0 then
          FPort := p;
        p := 0;
        for i := 1 to Length(Comp) do
          if (Comp[i] in ['0'..'9', '.']) then
            Inc(p, Ord(Comp[i] = '.')) else
            break;
        if p <> 3 then
          Host := Comp else
          Address := Comp;
        inherited DoConnect;
        ObjectBroker.SetConnectStatus(Comp, True);
      except
        ObjectBroker.SetConnectStatus(Comp, False);
        FAddress := '';
        FHost := '';
      end;
    until Connected;
  end else
    inherited DoConnect;
end;

procedure TQiSocketConnection.SetReceiveProgress(
  const Value: TNetProgressEvent);
begin
  FReceiveProgress := Value;
end;

procedure TQiSocketConnection.DoReceiveProgress(Sender: TObject; Position,
  Max: Integer);
begin
  if Assigned(FReceiveProgress) then FReceiveProgress(Self,Position,Max);
end;

function TQiSocketConnection.GetSupportCallbacks: Boolean;
begin
  Result:=FSupportCallbacks;
end;

{ TQiStreamedConnection }

constructor TQiStreamedConnection.Create(AOwner: TComponent);
var
  Obj: ISendDataBlock;
begin
  inherited Create(AOwner);
  GetInterface(ISendDataBlock, Obj);
//  FInterpreter := TQiDataBlockInterpreter.Create(Self, SSockets);
  FSupportCallbacks := True;
end;

destructor TQiStreamedConnection.Destroy;
begin
  SetConnected(False);
  FInterpreter.Free;
  if FHandle <> 0 then DeallocateHWnd(FHandle);
  if Assigned(FTransport) then FTransport.OnTerminate := nil;
  FTransIntf := nil;
  inherited Destroy;
end;

function TQiStreamedConnection.GetInterceptGUID: string;
begin
  if (FInterceptGUID.D1 <> 0) or (FInterceptGUID.D2 <> 0) or (FInterceptGUID.D3 <> 0) then
    Result := GUIDToString(FInterceptGUID) else
    Result := '';
end;

procedure TQiStreamedConnection.SetInterceptGUID(const Value: string);
var
  InterceptName: PWideChar;
begin
  if not (csLoading in ComponentState) then
    SetConnected(False);
  if Value = '' then
    FillChar(FInterceptGUID, SizeOf(FInterceptGUID), 0)
  else
  begin
    FInterceptGUID := StringToGUID(Value);
    if ProgIDFromCLSID(FInterceptGUID, InterceptName) = 0 then
    begin
      FInterceptName := InterceptName;
      CoTaskMemFree(InterceptName);
    end;
  end;