sconnect.pas

在Midas数据库编程中

  try
    GetDataBrokerList(List, FCheckRegValue);
    if List.Count > 0 then
    begin
      VList := VarArrayCreate([0, List.Count - 1], varOleStr);
      for i := 0 to List.Count - 1 do
        VList[i] := List[i];
    end else
      VList := NULL;
  finally
    List.Free;
  end;
  WriteVariant(VList, Data);
  Data.Signature := ResultSig or asGetServers;
  FSendDataBlock.Send(Data, False);
end;

procedure TDataBlockInterpreter.DoCreateObject(const Data: IDataBlock);
var
  V: OleVariant;
  VarFlags: TVarFlags;
  I: Integer;
begin
  V := CreateObject(ReadVariant(VarFlags, Data));
  Data.Clear;
  I := TVarData(V).VType;
  if (I and varTypeMask) = varInteger then
  begin
    I := varDispatch;
    Data.Write(I, SizeOf(Integer));
    I := V;
    Data.Write(I, SizeOf(Integer));
  end else
    WriteVariant(V, Data);
  Data.Signature := ResultSig or asCreateObject;
  FSendDataBlock.Send(Data, False);
end;

procedure TDataBlockInterpreter.DoFreeObject(const Data: IDataBlock);
var
  VarFlags: TVarFlags;
begin
  try
    ReleaseObject(ReadVariant(VarFlags, Data));
  except
    { Don't return any exceptions }
  end;
end;

procedure TDataBlockInterpreter.DoGetIDsOfNames(const Data: IDataBlock);
var
  ObjID, RetVal, DispID: Integer;
  Disp: IDispatch;
  W: WideString;
  VarFlags: TVarFlags;
begin
  ObjID := ReadVariant(VarFlags, Data);
  Disp := LockObject(ObjID);
  try
    W := ReadVariant(VarFlags, Data);
    Data.Clear;
    RetVal := Disp.GetIDsOfNames(GUID_NULL, @W, 1, 0, @DispID);
  finally
    UnlockObject(ObjID, Disp);
  end;
  WriteVariant(RetVal, Data);
  if RetVal = S_OK then
    WriteVariant(DispID, Data);
  Data.Signature := ResultSig or asGetID;
  FSendDataBlock.Send(Data, False);
end;

procedure TDataBlockInterpreter.DoInvoke(const Data: IDataBlock);
var
  ExcepInfo: TExcepInfo;
  DispParams: TDispParams;
  ObjID, DispID, Flags, i: Integer;
  RetVal: HRESULT;
  ExpectResult: Boolean;
  VarFlags: TVarFlags;
  Disp: IDispatch;
  VarList: PVariantArray;
  V: OleVariant;
begin
  VarList := nil;
  FillChar(ExcepInfo, SizeOf(ExcepInfo), 0);
  FillChar(DispParams, SizeOf(DispParams), 0);
  ObjID := ReadVariant(VarFlags, Data);
  Disp := LockObject(ObjID);
  try
    DispID := ReadVariant(VarFlags, Data);
    Flags := ReadVariant(VarFlags, Data);
    ExpectResult := ReadVariant(VarFlags, Data);
    DispParams.cArgs := ReadVariant(VarFlags, Data);
    DispParams.cNamedArgs := ReadVariant(VarFlags, Data);
    try
      DispParams.rgdispidNamedArgs := nil;
      if DispParams.cNamedArgs > 0 then
      begin
        GetMem(DispParams.rgdispidNamedArgs, DispParams.cNamedArgs * SizeOf(Integer));
        for i := 0 to DispParams.cNamedArgs - 1 do
          DispParams.rgdispidNamedArgs[i] := ReadVariant(VarFlags, Data);
      end;
      if DispParams.cArgs > 0 then
      begin
        GetMem(DispParams.rgvarg, DispParams.cArgs * SizeOf(TVariantArg));
        GetMem(VarList, DispParams.cArgs * SizeOf(OleVariant));
        Initialize(VarList^, DispParams.cArgs);
        for i := 0 to DispParams.cArgs - 1 do
        begin
          VarList[i] := ReadVariant(VarFlags, Data);
          if vfByRef in VarFlags then
          begin
            if vfVariant in VarFlags then
            begin
              DispParams.rgvarg[i].vt := varVariant or varByRef;
              TVarData(DispParams.rgvarg[i]).VPointer := @VarList[i];
            end else
            begin
              DispParams.rgvarg[i].vt := VarType(VarList[i]) or varByRef;
              TVarData(DispParams.rgvarg[i]).VPointer := GetVariantPointer(VarList[i]);
            end;
          end else
            DispParams.rgvarg[i] := TVariantArg(VarList[i]);
        end;
      end;
      Data.Clear;
      RetVal := Disp.Invoke(DispID, GUID_NULL, 0, Flags, DispParams, @V, @ExcepInfo, nil);
      WriteVariant(RetVal, Data);
      if RetVal = DISP_E_EXCEPTION then
      begin
        WriteVariant(ExcepInfo.scode, Data);
        WriteVariant(ExcepInfo.bstrDescription, Data);
      end;
      if DispParams.rgvarg <> nil then
      begin
        for i := 0 to DispParams.cArgs - 1 do
          if DispParams.rgvarg[i].vt and varByRef = varByRef then
            WriteVariant(OleVariant(DispParams.rgvarg[i]), Data);
      end;
      if ExpectResult then WriteVariant(V, Data);
      Data.Signature := ResultSig or asInvoke;
      FSendDataBlock.Send(Data, False);
    finally
      if DispParams.rgdispidNamedArgs <> nil then
        FreeMem(DispParams.rgdispidNamedArgs);
      if VarList <> nil then
      begin
        Finalize(VarList^, DispParams.cArgs);
        FreeMem(VarList);
      end;
      if DispParams.rgvarg <> nil then
        FreeMem(DispParams.rgvarg);
    end;
  finally
    UnlockObject(ObjID, Disp);
  end;
end;

function TDataBlockInterpreter.DoCustomAction(Action: Integer;
  const Data: IDataBlock): Boolean;
begin
  Result := False;
end;

{ TDataDispatch }

constructor TDataDispatch.Create(Interpreter: TCustomDataBlockInterpreter; DispatchIndex: Integer);
begin
  inherited Create;
  FDispatchIndex := DispatchIndex;
  FInterpreter := Interpreter;
  Interpreter.AddDispatch(Self);
end;

destructor TDataDispatch.Destroy;
begin
  if Assigned(FInterpreter) then
  begin
    FInterpreter.CallFreeObject(FDispatchIndex);
    FInterpreter.RemoveDispatch(Self);
  end;
  inherited Destroy;
end;

{ TDataDispatch.IDispatch }

function TDataDispatch.GetTypeInfoCount(out Count: Integer): HResult; stdcall;
begin
  Count := 0;
  Result := S_OK;
end;

function TDataDispatch.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
begin
  Result := E_NOTIMPL;
end;

function TDataDispatch.GetIDsOfNames(const IID: TGUID; Names: Pointer;
  NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
begin
  Result := FInterpreter.CallGetIDsOfNames(FDispatchIndex, IID, Names, NameCount,
    LocaleID, DispIDs);
end;

function TDataDispatch.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
begin
  Result := FInterpreter.CallInvoke(FDispatchIndex, DispID, IID, LocaleID, Flags,
    Params, VarResult, ExcepInfo, ArgErr);
end;


{ TTransportThread }

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

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

procedure TTransportThread.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;

{ TStreamedConnection }

constructor TStreamedConnection.Create(AOwner: TComponent);
var
  Obj: ISendDataBlock;
begin
  inherited Create(AOwner);
  GetInterface(ISendDataBlock, Obj);
//  FInterpreter := TDataBlockInterpreter.Create(Self, SSockets);
  FSupportCallbacks := True;
end;

destructor TStreamedConnection.Destroy;
begin
  SetConnected(False);
  FInterpreter.Free;
  if FHandle <> 0 then DeallocateHWnd(FHandle);
  if Assigned(FTransport) then FTransport.OnTerminate := nil;
  FTransIntf := nil;
  inherited Destroy;
end;

function TStreamedConnection.GetInterceptGUID: string;
begin
  if (FInterceptGUID.D1 <> 0) or (FInterceptGUID.D2 <> 0) or (FInterceptGUID.D3 <> 0) then
    Result := GUIDToString(FInterceptGUID) else
    Result := '';
end;

procedure TStreamedConnection.SetInterceptGUID(const Value: string);
var
  InterceptName: PWideChar;
begin
  if not (csLoading in ComponentState) then
    SetConnected(False);
  if Value = '' then
    FillChar(FInterceptGUID, SizeOf(FInterceptGUID), 0)
  else
  begin
    FInterceptGUID := StringToGUID(Value);
    if ProgIDFromCLSID(FInterceptGUID, InterceptName) = 0 then
    begin
      FInterceptName := InterceptName;
      CoTaskMemFree(InterceptName);
    end;
  end;
end;

procedure TStreamedConnection.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 TStreamedConnection.SetSupportCallbacks(Value: Boolean);
begin
  if Connected then Connected := False;
  FSupportCallbacks := Value;
end;

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

procedure TStreamedConnection.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 TStreamedConnection.GetServerList: OleVariant;
var
  DidConnect: Boolean;
begin
  DidConnect := not Connected;
  if DidConnect then InternalOpen;
  try
    Result := Interpreter.CallGetServerList;