sconnect.pas

在Midas数据库编程中

  finally
    if DidConnect then InternalClose;
  end;
end;

function TStreamedConnection.GetInterceptorList: OleVariant;
var
  List: TStringList;
  i: Integer;
begin
  Result := NULL;
  List := TStringList.Create;
  try
    GetPacketInterceptorList(List);
    if List.Count > 0 then
    begin
      Result := VarArrayCreate([0, List.Count - 1], varOleStr);
      for i := 0 to List.Count - 1 do
        Result[i] := List[i];
    end;
  finally
    List.Free;
  end;
end;

function TStreamedConnection.GetHandle: THandle;
begin
  if FHandle = 0 then
    FHandle := AllocateHwnd(WndProc);
  Result := FHandle;
end;

procedure TStreamedConnection.WndProc(var Message: TMessage);
begin
  try
    Dispatch(Message);
  except
    if Assigned(ApplicationHandleException) then
      ApplicationHandleException(Self);
  end;
end;

procedure TStreamedConnection.ThreadReceivedStream(var Message: TMessage);
var
  Data: IDataBlock;
begin
  Data := IDataBlock(Message.lParam);
  Data._Release;
  Interpreter.InterpretData(Data);
end;

procedure TStreamedConnection.ThreadException(var Message: TMessage);
begin
  DoError(Exception(Message.lParam));
end;

procedure TStreamedConnection.DoError(E: Exception);
begin
  raise E;
end;

procedure TStreamedConnection.TransportTerminated(Sender: TObject);
begin
  FTransport := nil;
  SetConnected(False);
end;

procedure TStreamedConnection.DoConnect;
var
  TempStr: string;
begin
  try
    if ServerGUID <> '' then
      TempStr := ServerGUID else
      TempStr := ServerName;
    if TempStr = '' then
      raise Exception.CreateResFmt(@SServerNameBlank, [Name]);
    InternalOpen;
    SetAppServer(Interpreter.CallCreateObject(TempStr));
  except
    InternalClose;
    raise;
  end;
end;

procedure TStreamedConnection.DoDisconnect;
begin
  inherited DoDisconnect;
  InternalClose;
end;

function TStreamedConnection.CreateTransport: ITransport;
begin
  Result := nil;
end;

function TStreamedConnection.GetInterpreter: TCustomDataBlockInterpreter;
begin
  if not Assigned(FInterpreter) then
    FInterpreter := TDataBlockInterpreter.Create(Self, SSockets);
  Result := FInterpreter;
end;

{ TStreamedConnection.IUnknown }

function TStreamedConnection.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  if GetInterface(IID, Obj) then Result := 0 else Result := E_NOINTERFACE;
end;

function TStreamedConnection._AddRef: Integer;
begin
  Inc(FRefCount);
  Result := FRefCount;
end;

function TStreamedConnection._Release: Integer;
begin
  Dec(FRefCount);
  Result := FRefCount;
end;

{ TStreamedConnection.ISendDataBlock }

function TStreamedConnection.Send(const Data: IDataBlock; WaitForResult: Boolean): IDataBlock;
var
  Msg: TMsg;
  Context: Integer;
begin
  if FSupportCallbacks then
  begin
    if not Assigned(FTransport) then Exit;
    Data._AddRef;
    PostThreadMessage(FTransport.ThreadID, THREAD_SENDSTREAM, Ord(WaitForResult),
      Integer(Pointer(Data)));
    if WaitForResult then
      while True do
      begin
        if GetMessage(Msg, FHandle, THREAD_RECEIVEDSTREAM, THREAD_EXCEPTION) then
        begin
          if Msg.message = THREAD_RECEIVEDSTREAM then
          begin
            Result := IDataBlock(Msg.lParam);
            Result._Release;
            if (Result.Signature and ResultSig) = ResultSig then
              break else
              Interpreter.InterpretData(Result);
          end
          else if Msg.Message <> WM_NULL then
            DoError(Exception(Msg.lParam))
          else
            raise Exception.CreateRes(@SReturnError);
        end else
          raise Exception.CreateRes(@SReturnError);
      end
    else
      GetMessage(Msg, FHandle, THREAD_SENDNOTIFY, THREAD_SENDNOTIFY);
  end else
  begin
    if not Assigned(FTransIntf) then Exit;
    Context := FTransIntf.Send(Data);
    Result := FTransIntf.Receive(WaitForResult, Context);
  end;
  if Assigned(Result) and ((Result.Signature and asMask) = asError) then
    Interpreter.InterpretData(Result);
end;

{ TSocketTransport }

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

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

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

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

procedure TSocketTransport.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
    FSocket.Close;
    FClientSocket.Free;
    if FEvent <> 0 then WSACloseEvent(FEvent);
  end;
end;

function TSocketTransport.Receive(WaitForInput: Boolean; Context: Integer): IDataBlock;
var
  RetLen, Sig, StreamLen: Integer;
  P: Pointer;
  FDSet: TFDSet;
  TimeVal: PTimeVal;
  RetVal: Integer;
  bFirst: boolean; {##Fix By Manuel Parma [e-mail]}
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.CreateRes(@SSocketReadError);
  CheckSignature(Sig);
  RetLen := FSocket.ReceiveBuf(StreamLen, SizeOf(StreamLen));
  if RetLen = 0 then
    raise ESocketConnectionError.CreateRes(@SSocketReadError);
  if RetLen <> SizeOf(StreamLen) then
    raise ESocketConnectionError.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}
  if (StreamLen > 0) then  WaitForSingleObject(FEvent, INFINITE{60000});{##Fix By Manuel Parma [e-mail]}
 {the next line maybe I can don't use , but I keep it because the same case in first time}
  bFirst := True; {##Fix By Manuel Parma [e-mail]}

  while StreamLen > 0 do
  begin
    RetLen := FSocket.ReceiveBuf(P^, StreamLen);
    if RetLen = 0 then
    begin {##Fix By Manuel Parma [e-mail]}
      {this next line is because If you retry you get the correct data!!}
      if not bFirst then {##Fix By Manuel Parma [e-mail]}
          raise ESocketConnectionError.CreateRes(@SSocketReadError);

      bFirst := False; {##Fix By Manuel Parma [e-mail]}
    end; {##Fix By Manuel Parma [e-mail]}

    if RetLen > 0 then
    begin
      Dec(StreamLen, RetLen);
      Inc(Integer(P), RetLen);
    end;

    {##Fix By Manuel Parma [e-mail]}
    {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{90000}) = WAIT_OBJECT_0) then
      begin
        WSAResetEvent(FEvent);{I reset the event, very important because Wait don't work}
      end
      else
      begin
        raise ESocketConnectionError.Create('Read Error Single Object Timeout');
      end;
    end;
    {##End Fix By Manuel Parma [e-mail]}


  end;
  if StreamLen <> 0 then
    raise ESocketConnectionError.CreateRes(@SInvalidDataPacket);
  InterceptIncoming(Result);
end;

function TSocketTransport.Send(const Data: IDataBlock): Integer;
var
  P: Pointer;
begin
  Result := 0;
  InterceptOutgoing(Data);
  P := Data.Memory;
  FSocket.SendBuf(P^, Data.Size + Data.BytesReserved);
end;

function TSocketTransport.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 TSocketTransport.InterceptIncoming(const Data: IDataBlock);
begin
  if CheckInterceptor then
    FInterceptor.DataIn(Data);
end;

procedure TSocketTransport.InterceptOutgoing(const Data: IDataBlock);
begin
  if CheckInterceptor then
    FInterceptor.DataOut(Data);
end;

{ TSocketConnection }

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

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

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

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

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

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

procedure TSocketConnection.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 := '';