sconnect.pas

一般的数据库管理系统 uses Classes, SConnectEx, TltConst, ExtCtrls, MMSystem, Types, windows, TltLogic , Sy

  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
//  MessageBox(0, '连接服务失败','', MB_OK or MB_ICONERROR);
  raise E;
end;

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

procedure TStreamedConnection.DoConnect;
var
  TempStr: string;
begin
  try
    InternalOpen;
//    FConnected := (Interpreter as ).CallGetIDsOfNames()
  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
            DoError(Exception(Msg.lParam));
        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;

function TStreamedConnection.GetConnected: Boolean;
begin
  if SupportCallbacks then
  begin
    Result := (FTransport<>nil) and (FTransport.FTransport.Connected);
  end
  else
    Result := (FTransIntf<>nil) and( FTransIntf.Connected);
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;
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 else
  begin
    New(TimeVal);
    TimeVal.tv_sec := 5;
    TimeVal.tv_usec := 0;
  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) and WaitForInput then
    raise ESocketConnectionError.Create('数据读取超时!');
  if (RetVal = 0) then Exit;
  RetLen := FSocket.ReceiveBuf(Sig, SizeOf(Sig));
  if RetLen <> SizeOf(Sig) then
    raise ESocketConnectionError.CreateRes(@SSocketReadError);
  if (Sig and CallSig <> CallSig) and
     (Sig and ResultSig <> ResultSig) then
    raise Exception.CreateRes(@SInvalidDataPacket);
  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);
  while StreamLen > 0 do
  begin
    RetLen := FSocket.ReceiveBuf(P^, StreamLen);
    if RetLen = 0 then
      raise ESocketConnectionError.CreateRes(@SSocketReadError);
    if RetLen > 0 then
    begin
      Dec(StreamLen, RetLen);
      Inc(Integer(P), RetLen);
    end;
  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 := (Address <> '');
end;

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

function TSocketConnection.IsHostStored: Boolean;
begin
  Result :=(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;
      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 or SupportCallbacks);
  end
  // else
   // inherited DoConnect;
end;


{ TPacketInterceptFactory }

procedure TPacketInterceptFactory.UpdateRegistry(Register: Boolean);
var
  CatReg: ICatRegister;
  Rslt: HResult;
  CatInfo: TCATEGORYINFO;
  Description: string;
begin
  inherited UpdateRegistry(Register);

  Rslt := CoCreateInstance(CLSID_StdComponentCategoryMgr, nil,
    CLSCTX_INPROC_SERVER, ICatRegister, CatReg);
  if Succeeded(Rslt) then
  begin
    if Register then
    begin
      CatInfo.catid := CATID_MIDASInterceptor;
      CatInfo.lcid := $0409;
      StringToWideChar(MIDASInterceptor_CatDesc, CatInfo.szDescription,
        Length(MIDASInterceptor_CatDesc) + 1);
      OleCheck(CatReg.RegisterCategories(1, @CatInfo));
      OleCheck(CatReg.RegisterClassImplCategories(ClassID, 1, @CATID_MIDASInterceptor));
    end else
    begin
      OleCheck(CatReg.UnRegisterClassImplCategories(ClassID, 1, @CATID_MIDASInterceptor));
      DeleteRegKey(Format(SClsid + SCatImplBaseKey, [GUIDToString(ClassID)]));
    end;
  end else
  begin
    if Register then
    begin
      CreateRegKey('Component Categories\' + GUIDToString(CATID_MIDASInterceptor), '409', MIDASInterceptor_CatDesc);
      CreateRegKey(Format(SClsid + SCatImplKey, [GUIDToString(ClassID), GUIDToString(CATID_MIDASInterceptor)]), '', '');
    end else
    begin
      DeleteRegKey(Format(SClsid + SCatImplKey, [GUIDToString(Cl