qisocketc.pas

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

end;

procedure TQiStreamedConnection.SetInterceptName(const Value: string);
begin
  if Value <> FInterceptName then
  begin
    if not (csLoading in ComponentState) then
    begin
      SetConnected(False);
      if CLSIDFromProgID(PWideChar(WideString(Value)), FInterceptGUID) <> 0 then
        FillChar(FInterceptGUID, SizeOf(FInterceptGUID), 0);
    end;
    FInterceptName := Value;
  end;
end;

procedure TQiStreamedConnection.SetSupportCallbacks(Value: Boolean);
begin
  if Connected then Connected := False;
  FSupportCallbacks := Value;
end;

procedure TQiStreamedConnection.InternalOpen;
begin
  if FSupportCallbacks then
  begin
    FTransport := TQiTransportThread.Create(Handle, CreateTransport);
    FTransport.OnTerminate := TransportTerminated;
    WaitForSingleObject(FTransport.Semaphore, INFINITE);
  end else
  begin
    FTransIntf := CreateTransport;
    FTransIntf.SetConnected(True);
  end;
end;

procedure TQiStreamedConnection.InternalClose;
begin
  if Assigned(FTransport) then
  begin
    FTransport.OnTerminate := nil;
    FTransport.Terminate;
    PostThreadMessage(FTransport.ThreadID, WM_USER, 0, 0);
    if Assigned(FTransport.FTransport) then
      WaitForSingleObject(FTransport.Handle, 180000);
    FTransport := nil;
  end else
  if Assigned(FTransIntf) then
  begin
    FTransIntf.Connected := False;
    FTransIntf := nil;
  end;
end;

function TQiStreamedConnection.GetServerList: OleVariant;
var
  DidConnect: Boolean;
begin
  DidConnect := not Connected;
  if DidConnect then InternalOpen;
  try
    Result := Interpreter.CallGetServerList;
  finally
    if DidConnect then InternalClose;
  end;
end;

function TQiStreamedConnection.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 TQiStreamedConnection.GetHandle: THandle;
begin
  if FHandle = 0 then
    FHandle := AllocateHwnd(WndProc);
  Result := FHandle;
end;

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

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

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

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

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

procedure TQiStreamedConnection.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 TQiStreamedConnection.DoDisconnect;
begin
  inherited DoDisconnect;
  InternalClose;
end;

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

function TQiStreamedConnection.GetInterpreter: TQiCustomDataBlockInterpreter;
begin
  if not Assigned(FInterpreter) then
    FInterpreter := TQiDataBlockInterpreter.Create(Self, SSockets);
  Result := FInterpreter;
end;

{ TQiStreamedConnection.IUnknown }

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

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

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

{ TQiStreamedConnection.ISendDataBlock }

function TQiStreamedConnection.Send(const Data: IDataBlock; WaitForResult: Boolean): IDataBlock;
var
  Msg: TMsg;
  Context: Integer;
begin
  FLastActiveTime:=Now;
  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);
  FLastActiveTime:=Now;
end;

{ TQiTransportThread }

constructor TQiTransportThread.Create(AHandle: THandle; Transport: ITransport);
begin
  FParentHandle := AHandle;
  FTransport := Transport;
  FreeOnTerminate := True;
  FSemaphore := CreateSemaphore(nil, 0, 1, nil);
  inherited Create(False);
end;

destructor TQiTransportThread.Destroy;
begin
  CloseHandle(FSemaphore);
  inherited Destroy;
end;

procedure TQiTransportThread.Execute;

  procedure SynchronizeException;
  var
    SendException: TObject;
  begin
    SendException := AcquireExceptionObject;
    if Assigned(FTransport) and (SendException is ESocketConnectionError) then
      FTransport.Connected := False;
    PostMessage(FParentHandle, THREAD_EXCEPTION, 0, Integer(Pointer(SendException)));
  end;

var
  msg: TMsg;
  Data: IDataBlock;
  Event: THandle;
  Context: Integer;
begin
  CoInitialize(nil);
  try
    PeekMessage(msg, 0, WM_USER, WM_USER, PM_NOREMOVE);
    ReleaseSemaphore(FSemaphore, 1, nil);
    try
      FTransport.Connected := True;
      try
        Event := FTransport.GetWaitEvent;
        while not Terminated and FTransport.Connected do
        try
          case MsgWaitForMultipleObjects(1, Event, False, INFINITE, QS_ALLINPUT) of
            WAIT_OBJECT_0:
            begin
              WSAResetEvent(Event);
              Data := FTransport.Receive(False, 0);
              if Assigned(Data) then
              begin
                Data._AddRef;
                PostMessage(FParentHandle, THREAD_RECEIVEDSTREAM, 0, Integer(Pointer(Data)));
                Data := nil;
              end;
            end;
            WAIT_OBJECT_0 + 1:
            begin
              while PeekMessage(msg, 0, 0, 0, PM_REMOVE) do
              begin
                if (msg.hwnd = 0) then
                  case msg.message of
                    THREAD_SENDSTREAM:
                    begin
                      Data := IDataBlock(msg.lParam);
                      Data._Release;
                      Context := FTransport.Send(Data);
                      if msg.wParam = 1 then
                      begin
                        Data := FTransport.Receive(True, Context);
                        Data._AddRef;
                        PostMessage(FParentHandle, THREAD_RECEIVEDSTREAM, 0, Integer(Pointer(Data)));
                        Data := nil;
                      end else
                        PostMessage(FParentHandle, THREAD_SENDNOTIFY, 0, 0);
                    end;
                    THREAD_REPLACETRANSPORT:
                    begin
                      FTransport := ITransport(msg.lParam);
                      FTransport._Release;
                    end;
                  else
                    DispatchMessage(msg);
                  end
                else
                  DispatchMessage(msg);
              end;
            end;
          end;
        except
          SynchronizeException;
        end;
      finally
        Data := nil;
        FTransport.Connected := False;
      end;
    except
      SynchronizeException;
    end;
  finally
    FTransport := nil;
    CoUninitialize();
  end;
end;

{ TQiDataBlockInterpreter }

const

  EasyArrayTypes = [varSmallInt, varInteger, varSingle, varDouble, varCurrency,
                    varDate, varBoolean, varShortInt, varByte, varWord, varLongWord];

  VariantSize: array[0..varLongWord] of Word  = (0, 0, SizeOf(SmallInt), SizeOf(Integer),
    SizeOf(Single), SizeOf(Double), SizeOf(Currency), SizeOf(TDateTime), 0, 0,
    SizeOf(Integer), SizeOf(WordBool), 0, 0, 0, 0, SizeOf(ShortInt), SizeOf(Byte),
    SizeOf(Word), SizeOf(LongWord));

constructor TQiDataBlockInterpreter.Create(SendDataBlock: ISendDataBlock; CheckRegValue: string);
begin
  inherited Create;
  FSendDataBlock := SendDataBlock;
  FDispatchList := TList.Create;
  FCheckRegValue := CheckRegValue;
end;

destructor TQiDataBlockInterpreter.Destroy;
var
  i: Integer;
begin
  for i := FDispatchList.Count - 1 downto 0 do
    TQiDataDispatch(FDispatchList[i]).FInterpreter := nil;
  FDispatchList.Free;
  FSendDataBlock := nil;
  inherited Destroy;
end;

procedure TQiDataBlockInterpreter.AddDispatch(Value: TQiDataDispatch);
begin
  if FDispatchList.IndexOf(Value) = -1 then
    FDispatchList.Add(Value);
end;

procedure TQiDataBlockInterpreter.RemoveDispatch(Value: TQiDataDispatch);
begin
  FDispatchList.Remove(Value);
end;

{ Variant conversion methods }

function TQiDataBlockInterpreter.GetVariantPointer(const Value: OleVariant): Pointer;
begin
  case VarType(Value) of
    varEmpty, varNull: Result := nil;
    varDispatch: Result := TVarData(Value).VDispatch;
    varVariant: Result := @Value;
    varUnknown: Result := TVarData(Value).VUnknown;
  else
    Result := @TVarData(Value).VPointer;
  end;
end;

procedure TQiDataBlockInterpreter.CopyDataByRef(const Source: TVarData; var Dest: TVarData);
var
  VType: Integer;
begin
  VType := Source.VType;
  if Source.VType and varArray = varArray then
  begin
    VarClear(OleVariant(Dest));
    SafeArrayCheck(SafeArrayCopy(PSafeArray(Source.VArray), PSafeArray(Dest.VArray)));
  end else
    case Source.VType and varTypeMask of
      varEmpty, varNull: ;
      varOleStr:
      begin
        if (Dest.VType and varTypeMask) <> varOleStr then
          Dest.VOleStr := SysAllocString(Source.VOleStr)
        else if (Dest.VType and varByRef) = varByRef then
          SysReallocString(PBStr(Dest.VOleStr)^,Source.VOleStr)
        else
          SysReallocString(Dest.VOleStr,Source.VOleStr);
      end;
      varDispatch: Dest.VDispatch := Source.VDispatch;
      varVariant: CopyDataByRef(PVarData(Source.VPointer)^, Dest);
      varUnknown: Dest.VUnknown := Source.VUnknown;
    else
      if Dest.VType = 0 then