qisocketc.pas

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

  Action: Integer;
begin
  Action := Data.Signature;
  if (Action and asMask) = asError then DoException(Data);
  try
    case (Action and asMask) of
      asInvoke: DoInvoke(Data);
      asGetID: DoGetIDsOfNames(Data);
      asCreateObject: DoCreateObject(Data);
      asFreeObject: DoFreeObject(Data);
      asGetServers: DoGetServerList(Data);
      asGetAppServers: DoGetAppServerList(Data);
    else
      if not DoCustomAction(Action and asMask, Data) then
        raise EInterpreterError.CreateResFmt(@SInvalidAction, [Action and asMask]);
    end;
  except
    on E: Exception do
    begin
      Data.Clear;
      WriteVariant(E.Message, Data);
      Data.Signature := ResultSig or asError;
      FSendDataBlock.Send(Data, False);
    end;
  end;
end;

procedure TQiDataBlockInterpreter.DoException(const Data: IDataBlock);
var
  VarFlags: TVarFlags;
begin
  raise Exception.Create(ReadVariant(VarFlags, Data));
end;

procedure TQiDataBlockInterpreter.DoGetAppServerList(const Data: IDataBlock);
var
  VList: OleVariant;
  List: TStringList;
  i: Integer;
begin
  Data.Clear;
  List := TStringList.Create;
  try
    GetMIDASAppServerList(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 asGetAppServers;
  FSendDataBlock.Send(Data, False);
end;

procedure TQiDataBlockInterpreter.DoGetServerList(const Data: IDataBlock);
var
  VList: OleVariant;
  List: TStringList;
  i: Integer;
begin
  Data.Clear;
  List := TStringList.Create;
  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 TQiDataBlockInterpreter.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 TQiDataBlockInterpreter.DoFreeObject(const Data: IDataBlock);
var
  VarFlags: TVarFlags;
begin
  try
    ReleaseObject(ReadVariant(VarFlags, Data));
  except
    { Don't return any exceptions }
  end;
end;

procedure TQiDataBlockInterpreter.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 TQiDataBlockInterpreter.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 TQiDataBlockInterpreter.DoCustomAction(Action: Integer;
  const Data: IDataBlock): Boolean;
begin
  Result := False;
end;

{ TQiDataDispatch }

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

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

function TQiDataDispatch.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 TQiDataDispatch.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;

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

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

{ TQiSocketTransConnection }

procedure TQiSocketTransConnection.AddRemoteServer(
  RServer: TQiRemoteServer);
begin
  if FRemoteServers.IndexOf(RServer)<0 then
    FRemoteServers.Add(RServer);
end;

constructor TQiSocketTransConnection.Create(AOwner: TComponent);
var
  Obj: ISendDataBlock;
begin
  inherited Create(AOwner);
  GetInterface(ISendDataBlock, Obj);
  FRemoteServers:= TObjectList.Create(False); 
  FSupportCallbacks := True;
  FAddress:='';
  FHost:='';
  FPort := 211;
end;

function TQiSocketTransConnection.CreateTransport: ITransport;
var
  SocketTransport: TQiSocketTransport;
begin
  if SupportCallbacks then
    if not LoadWinSock2 then raise Exception.CreateRes(@SNoWinSock2);
  if (FAddress = '') and (FHost = '') then
    raise ESocketConnectionError.CreateRes(@SNoAddress);
  SocketTransport := TQiSocketTransport.Create;
  SocketTransport.Host := FHost;
  SocketTransport.Address := FAddress;
  SocketTransport.Port := FPort;
  SocketTransport.NetEventsOwner:=Self;
  Result := SocketTransport as ITransport;
end;


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

procedure TQiSocketTransConnection.DoConnect;
begin
  try
    InternalOpen;    
  except
    InternalClose;
    raise;
  end;
end;

procedure TQiSocketTransConnection.DoDisconnect;
var
  i:Integer;
begin
  for i:=0 to FRemoteServers.Count-1 do
    TQiRemoteServer(FRemoteServers[i]).DoDisconnect;
  InternalClose;
end;

procedure TQiSocketTransConnection.DoError(E: Exception);
begin
  Raise E;
end;

procedure TQiSocketTransConnection.DoReceiveProgress(Sender: TObject;
  Position, Max: Integer);
begin
  if Assigned(FReceiveProgress) then FReceiveProgress(Self,Position,Max);
end;

function TQiSocketTransConnection.GetConnected: Boolean;
begin
  Result:=(FTransport<>nil) or ((FTransIntf<>nil) and FTransIntf.Connected);
end;

function TQiSocketTransConnection.GetHandle: THandle;
begin
  if FHandle = 0 then
    FHandle := AllocateHwnd(WndProc);
  Result := FHandle;
end;

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

function TQiSocketTransConnection.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 TQiSocketTransConnection.GetSupportCallbacks: Boolean;
begin
  Result:=FSupportCallbacks;
end;

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

procedure TQiSocketTransConnection.InternalOpen;
begin
  if FSupportCallbacks then
  begin
    FTransport := TQiTransportThread.Cre