sconnect.pas

在Midas数据库编程中

          for I := 0 to DimCount - 1 do
            Indices[I] := LoDim[I];
          while True do
          begin
            V := ReadVariant(Flags, Data);
            if VType and varTypeMask = varVariant then
              OleCheck(SafeArrayPutElement(LSafeArray, Indices^, V)) else
              OleCheck(SafeArrayPutElement(LSafeArray, Indices^, TVarData(V).VPointer^));
            Inc(Indices[DimCount - 1]);
            if Indices[DimCount - 1] > HiDim[DimCount - 1] then
              for i := DimCount - 1 downto 0 do
                if Indices[i] > HiDim[i] then
                begin
                  if i = 0 then Exit;
                  Inc(Indices[i - 1]);
                  Indices[i] := LoDim[i];
                end;
          end;
        finally
          FreeMem(Indices);
        end;
      end;
    finally
      FreeMem(HiDim);
    end;
  finally
    FreeMem(LoDim);
  end;
end;

procedure TDataBlockInterpreter.WriteArray(const Value: OleVariant;
  const Data: IDataBlock);
var
  LVarData: TVarData;
  VType: Integer;
  VSize, i, DimCount, ElemSize: Integer;
  LSafeArray: PSafeArray;
  LoDim, HiDim, Indices: PIntArray;
  V: OleVariant;
  P: Pointer;
begin
  LVarData := FindVarData(Value)^;
  VType := LVarData.VType;
  LSafeArray := PSafeArray(LVarData.VPointer);
                         
  Data.Write(VType, SizeOf(Integer));
  DimCount := VarArrayDimCount(Value);
  Data.Write(DimCount, SizeOf(DimCount));
  VSize := SizeOf(Integer) * DimCount;
  GetMem(LoDim, VSize);
  try
    GetMem(HiDim, VSize);
    try
      for i := 1 to DimCount do
      begin
        LoDim[i - 1] := VarArrayLowBound(Value, i);
        HiDim[i - 1] := VarArrayHighBound(Value, i);
      end;
      Data.Write(LoDim^,VSize);
      Data.Write(HiDim^,VSize);
      if VType and varTypeMask in EasyArrayTypes then
      begin
        ElemSize := SafeArrayGetElemSize(LSafeArray);
        VSize := 1;
        for i := 0 to DimCount - 1 do
          VSize := (HiDim[i] - LoDim[i] + 1) * VSize;
        VSize := VSize * ElemSize;
        P := VarArrayLock(Value);
        try
          Data.Write(VSize, SizeOf(VSize));
          Data.Write(P^,VSize);
        finally
          VarArrayUnlock(Value);
        end;
      end else
      begin
        GetMem(Indices, VSize);
        try
          for I := 0 to DimCount - 1 do
            Indices[I] := LoDim[I];
          while True do
          begin
            if VType and varTypeMask <> varVariant then
            begin
              OleCheck(SafeArrayGetElement(LSafeArray, Indices^, TVarData(V).VPointer));
              TVarData(V).VType := VType and varTypeMask;
            end else
              OleCheck(SafeArrayGetElement(LSafeArray, Indices^, V));
            WriteVariant(V, Data);
            Inc(Indices[DimCount - 1]);
            if Indices[DimCount - 1] > HiDim[DimCount - 1] then
              for i := DimCount - 1 downto 0 do
                if Indices[i] > HiDim[i] then
                begin
                  if i = 0 then Exit;
                  Inc(Indices[i - 1]);
                  Indices[i] := LoDim[i];
                end;
          end;
        finally
          FreeMem(Indices);
        end;
      end;
    finally
      FreeMem(HiDim);
    end;
  finally
    FreeMem(LoDim);
  end;
end;

function TDataBlockInterpreter.ReadVariant(out Flags: TVarFlags;
  const Data: IDataBlock): OleVariant;
var
  I, VType: Integer;
  W: WideString;
  TmpFlags: TVarFlags;
begin
  VarClear(Result);
  Flags := [];
  Data.Read(VType, SizeOf(VType));
  if VType and varByRef = varByRef then
    Include(Flags, vfByRef);
  if VType = varByRef then
  begin
    Include(Flags, vfVariant);
    Result := ReadVariant(TmpFlags, Data);
    Exit;
  end;
  if vfByRef in Flags then
    VType := VType xor varByRef;
  if (VType and varArray) = varArray then
    Result := ReadArray(VType, Data) else
  case VType and varTypeMask of
    varEmpty: VarClear(Result);
    varNull: Result := NULL;
    varOleStr:
    begin
      Data.Read(I, SizeOf(Integer));
      SetLength(W, I);
      Data.Read(W[1], I * 2);
      Result := W;
    end;
    varDispatch:
    begin
      Data.Read(I, SizeOf(Integer));
      Result := TDataDispatch.Create(Self, I) as IDispatch;
    end;
    varUnknown:
      raise EInterpreterError.CreateResFmt(@SBadVariantType,[IntToHex(VType,4)]);
  else
    TVarData(Result).VType := VType;
    Data.Read(TVarData(Result).VPointer, VariantSize[VType and varTypeMask]);
  end;
end;

function TDataBlockInterpreter.CanCreateObject(const ClassID: TGUID): Boolean;
begin
  Result := (FCheckRegValue = '') or
    (GetRegStringValue(SClsid + GuidToString(ClassID), FCheckRegValue) = SFlagOn);
end;

function TDataBlockInterpreter.InternalCreateObject(const ClassID: TGUID): OleVariant;
var
  Unk: IUnknown;
begin
  OleCheck(CoCreateInstance(ClassID, nil, CLSCTX_INPROC_SERVER or
    CLSCTX_LOCAL_SERVER or CLSCTX_REMOTE_SERVER, IUnknown, Unk));
  Result := Unk as IDispatch;
end;

function TDataBlockInterpreter.CreateObject(const Name: string): OleVariant;
var
  ClassID: TGUID;
begin
  if (Name[1] = '{') and (Name[Length(Name)] = '}') then
    ClassID := StringToGUID(Name) else
    ClassID := ProgIDToClassID(Name);
  if CanCreateObject(ClassID) then
    Result := InternalCreateObject(ClassID) else
    raise Exception.CreateResFmt(@SObjectNotAvailable, [GuidToString(ClassID)]);
end;

function TDataBlockInterpreter.StoreObject(const Value: OleVariant): Integer;
begin
  if not VarIsArray(FDispList) then
    FDispList := VarArrayCreate([0,10], varVariant);
  Result := 0;
  while Result <= VarArrayHighBound(FDispList, 1) do
    if VarIsClear(FDispList[Result]) then break else Inc(Result);
  if Result > VarArrayHighBound(FDispList, 1) then
    VarArrayRedim(FDispList, Result + 10);
  FDispList[Result] := Value;
end;

function TDataBlockInterpreter.LockObject(ID: Integer): IDispatch;
begin
  Result := FDispList[ID];
end;

procedure TDataBlockInterpreter.UnlockObject(ID: Integer; const Disp: IDispatch);
begin
end;

procedure TDataBlockInterpreter.ReleaseObject(ID: Integer);
begin
  if (ID >= 0) and (VarIsArray(FDispList)) and
     (ID < VarArrayHighBound(FDispList, 1)) then
    FDispList[ID] := UNASSIGNED;
end;

procedure TDataBlockInterpreter.WriteVariant(const Value: OleVariant;
  const Data: IDataBlock);
var
  I, VType: Integer;
  W: WideString;
begin
  VType := VarType(Value);
  if VType and varArray <> 0 then
    WriteArray(Value, Data)
  else
    case (VType and varTypeMask) of
      varEmpty, varNull:
        Data.Write(VType, SizeOf(Integer));
      varOleStr:
      begin
        W := WideString(Value);
        I := Length(W);
        Data.Write(VType, SizeOf(Integer));
        Data.Write(I,SizeOf(Integer));
        Data.Write(W[1], I * 2);
      end;
      varDispatch:
      begin
        if VType and varByRef = varByRef then
          raise EInterpreterError.CreateResFmt(@SBadVariantType,[IntToHex(VType,4)]);
        I := StoreObject(Value);
        Data.Write(VType, SizeOf(Integer));
        Data.Write(I, SizeOf(Integer));
      end;
      varVariant:
      begin
        if VType and varByRef <> varByRef then
          raise EInterpreterError.CreateResFmt(@SBadVariantType,[IntToHex(VType,4)]);
        I := varByRef;
        Data.Write(I, SizeOf(Integer));
        WriteVariant(Variant(TVarData(Value).VPointer^), Data);
      end;
      varUnknown:
        raise EInterpreterError.CreateResFmt(@SBadVariantType,[IntToHex(VType,4)]);
    else
      Data.Write(VType, SizeOf(Integer));
      if VType and varByRef = varByRef then
        Data.Write(TVarData(Value).VPointer^, VariantSize[VType and varTypeMask])
      else
        Data.Write(TVarData(Value).VPointer, VariantSize[VType and varTypeMask]);
    end;
end;

{ Sending Calls }

function TDataBlockInterpreter.CallGetServerList: OleVariant;
var
  Flags: TVarFlags;
  Data: IDataBlock;
begin
  Data := TDataBlock.Create as IDataBlock;
  Data.Signature := CallSig or asGetAppServers;
  Data := FSendDataBlock.Send(Data, True);
  Result := ReadVariant(Flags, Data);
end;

function TDataBlockInterpreter.CallCreateObject(Name: string): OleVariant;
var
  Flags: TVarFlags;
  Data: IDataBlock;
begin
  Data := TDataBlock.Create as IDataBlock;
  WriteVariant(Name, Data);
  Data.Signature := CallSig or asCreateObject;
  Data := FSendDataBlock.Send(Data, True);
  Result := ReadVariant(Flags, Data);
end;

procedure TDataBlockInterpreter.CallFreeObject(DispatchIndex: Integer);
var
  Data: IDataBlock;
begin
  Data := TDataBlock.Create as IDataBlock;
  WriteVariant(DispatchIndex, Data);
  Data.Signature := CallSig or asFreeObject;
  FSendDataBlock.Send(Data, False);
end;

function TDataBlockInterpreter.CallGetIDsOfNames(DispatchIndex: Integer;
  const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer;
  DispIDs: Pointer): HResult; stdcall;
var
  Flags: TVarFlags;
  Data: IDataBlock;
begin
  if NameCount <> 1 then
    Result := E_NOTIMPL else
  begin
    Data := TDataBlock.Create as IDataBlock;
    WriteVariant(DispatchIndex, Data);
    WriteVariant(WideString(POleStrList(Names)^[0]), Data);
    Data.Signature := CallSig or asGetID;
    Data := FSendDataBlock.Send(Data, True);
    Result := ReadVariant(Flags, Data);
    if Result = S_OK then
      PDispIdList(DispIDs)^[0] := ReadVariant(Flags, Data);
  end;
end;

function TDataBlockInterpreter.CallInvoke(DispatchIndex, DispID: Integer; const IID: TGUID; LocaleID: Integer;
  Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
var
  VarFlags: TVarFlags;
  PDest: PVarData;
  i: Integer;
  Data: IDataBlock;
begin
  Data := TDataBlock.Create as IDataBlock;
  WriteVariant(DispatchIndex, Data);
  WriteVariant(DispID, Data);
  WriteVariant(Flags, Data);
  WriteVariant(VarResult <> nil, Data);
  WriteVariant(PDispParams(@Params).cArgs, Data);
  WriteVariant(PDispParams(@Params).cNamedArgs, Data);
  for i := 0 to PDispParams(@Params).cNamedArgs - 1 do
    WriteVariant(PDispParams(@Params).rgdispidNamedArgs[i], Data);
  for i := 0 to PDispParams(@Params).cArgs - 1 do
    WriteVariant(OleVariant(PDispParams(@Params).rgvarg^[i]), Data);
  Data.Signature := CallSig or asInvoke;
  Data := FSendDataBlock.Send(Data, True);
  Result := ReadVariant(VarFlags, Data);
  if (Result = DISP_E_EXCEPTION) then
  begin
    PExcepInfo(ExcepInfo).scode := ReadVariant(VarFlags, Data);
    PExcepInfo(ExcepInfo).bstrDescription := ReadVariant(VarFlags, Data);
  end;
  for i := 0 to PDispParams(@Params).cArgs - 1 do
    with PDispParams(@Params)^ do
      if rgvarg^[i].vt and varByRef = varByRef then
      begin
        if rgvarg^[i].vt = (varByRef or varVariant) then
          PDest := @TVarData(TVarData(rgvarg^[i]).VPointer^)
        else
          PDest := @TVarData(rgvarg^[i]);
        CopyDataByRef(TVarData(ReadVariant(VarFlags, Data)), PDest^);
      end;
  if VarResult <> nil then
    PVariant(VarResult)^ := ReadVariant(VarFlags, Data);
end;

{ Receiving Calls }

procedure TDataBlockInterpreter.InterpretData(const Data: IDataBlock);
var
  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 TDataBlockInterpreter.DoException(const Data: IDataBlock);
var
  VarFlags: TVarFlags;
begin
  raise Exception.Create(ReadVariant(VarFlags, Data));
end;

procedure TDataBlockInterpreter.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 TDataBlockInterpreter.DoGetServerList(const Data: IDataBlock);
var
  VList: OleVariant;
  List: TStringList;
  i: Integer;
begin
  Data.Clear;
  List := TStringList.Create;