sconnect.pas

这是不可多得的源代码

    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
    if FSocket <> nil then FSocket.Close;
    FSocket := nil;
    FreeAndNil(FClientSocket);
    if FEvent <> 0 then WSACloseEvent(FEvent);
    FEvent := 0;
  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;
  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);
  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 := (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 := '';
      end;
    until Connected;
  end else
    inherited DoConnect;
end;

{ TWebConnection }

constructor TWebConnection.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FInterpreter := TDataBlockInterpreter.Create(Self, SWeb);
  SupportCallbacks := False;
  FInetRoot := nil;
  FInetConnect := nil;
  FAgent := 'DataSnap';
  URL := SDefaultURL;
end;

destructor TWebConnection.Destroy;
begin
  SetConnected(False);
  FInterpreter.Free;
  inherited Destroy;
end;

function TWebConnection.GetInterpreter: TCustomDataBlockInterpreter;
begin
  if not Assigned(FInterpreter) then
    FInterpreter := TDataBlockInterpreter.Create(Self, SWeb);
  Result := FInterpreter;
end;
procedure TWebConnection.SetURL(const Value: string);
var
  URLComp: TURLComponents;
  P: PChar;
begin
  SetConnected(False);
  if FURL = Value then Exit;
  if Value <> '' then
  begin
    FillChar(URLComp, SizeOf(URLComp), 0);
    URLComp.dwStructSize := SizeOf(URLComp);
    URLComp.dwSchemeLength := 1;
    URLComp.dwHostNameLength := 1;
    URLComp.dwURLPathLength := 1;
    P := PChar(Value);
    InternetCrackUrl(P, 0, 0, URLComp);
    if not (URLComp.nScheme in [INTERNET_SCHEME_HTTP, INTERNET_SCHEME_HTTPS]) then
      raise Exception.CreateRes(@SInvalidURL);
    FURLScheme := URLComp.nScheme;
    FURLPort := URLComp.nPort;
    FURLHost := Copy(Value, URLComp.lpszHostName - P + 1, URLComp.dwHostNameLength);
    FURLSite := Copy(Value, URLComp.lpszUrlPath - P + 1, URLComp.dwUrlPathLength);
  end