sconnect.pas

这是一个三层的进销存系统

      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
    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)
//    else
//    Datain(Data);
end;

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


var
  ZlibFlag: array[1..4] of Char = ('Z', 'L', 'I', 'B');
  zFlag: Integer absolute ZlibFlag;

{procedure TSocketTransport.DataIn(const Data: IDataBlock);
var
  m, Size: Integer;
  InStream, OutStream: TMemoryStream;
  ZStream: TZDecompressionStream;
  p: Pointer;
begin
  InStream := nil;
  try
    // Skip BytesReserved bytes of data
    p := Pointer(Integer(Data.Memory) + Data.BytesReserved);
    Size := PInteger(p)^;
    p := Pointer(Integer(p) + SizeOf(Size));
    m := PInteger(p)^;
    if m <> zFlag then Exit;
    FUseZlib := True;
    Size := Size - 4;
    if Size <= 0 then Exit;
    p := Pointer(Integer(p) + SizeOf(m));
    InStream := TMemoryStream.Create;
    InStream.Write(p^, Data.Size - SizeOf(Size) - SizeOf(m));
    OutStream := TMemoryStream.Create;
    try
      InStream.Position := 0;
      ZStream := TZDecompressionStream.Create(InStream);
      try
        OutStream.CopyFrom(ZStream, Size);
      finally
        ZStream.Free;
      end;
      // Clear the datablock, then write the uncompressed data back into the datablock
      Data.Clear;
      Data.Write(OutStream.Memory^, OutStream.Size);
    finally
      if Assigned(OutStream) then OutStream.Free;
    end;
  finally
    if Assigned(InStream) then InStream.Free;
  end;
end;

procedure TSocketTransport.DataOut(const Data: IDataBlock);
var
  InStream, OutStream: TMemoryStream;
  ZStream: TZCompressionStream;
  Size: Integer;
begin
  InStream := nil;
  if not FUseZlib then Exit;
  try
    InStream := TMemoryStream.Create;
    // Skip BytesReserved bytes of data
    InStream.Write(Pointer(Integer(Data.Memory) + Data.BytesReserved)^, Data.Size);
    Size := InStream.Size;
    if Size = 0 then Exit;
    OutStream := TMemoryStream.Create;
    try
      ZStream := TZCompressionStream.Create(OutStream, zcFastest);
      try
        ZStream.CopyFrom(InStream, 0);
      finally
        ZStream.Free;
      end;
    // Clear the datablock, then write the compressed data back into the datablock
      Data.Clear;
      Size := Size + 4;
      Data.Write(Size, SizeOf(Integer));
      Data.Write(zFlag, SizeOf(Integer));
      Data.Write(OutStream.Memory^, OutStream.Size);
    finally
      OutStream.Free;
    end;
  finally
    if Assigned(InStream) then InStream.Free;
  end;
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 a