dws2comconnector.pas

script language

    if Params[x].TypSym.Size > 1 then
    begin
      isValid := False;
      Break;
    end;
  end;

  TypSym := FTable.FindSymbol('ComVariant');
  if isValid then
  begin
    Result := TComConnectorCall.Create(MethodName, Params);
  end
  else
    Result := nil;
end;

const
  MaxDispArgs = 64;

type
  POleParams = ^TOleParams;
  TOleParams = array [0..MaxDispArgs - 1] of PVariant;

function DispatchInvoke(const Dispatch: IDispatch; InvKind, ArgCount, NamedArgCount: Byte;
  DispIDs: PDispIDList; PParams: POleParams; PResult: PVariant): HResult;
type
  TStringDesc = record
    BStr: PWideChar;
    PStr: PString;
  end;
var
  x, argType, strCount: Integer;
  dispParams: TDispParams;
  excepInfo: TExcepInfo;
  strings: array[0..MaxDispArgs - 1] of TStringDesc;
  argPtr: PVariantArg;
  args: array[0..MaxDispArgs - 1] of TVariantArg;
  DispID : Integer;
begin
  strCount := 0;
  Result := S_OK;

  // Fill in the dispParams struct
  try
    if ArgCount <> 0 then
    begin
      for x := 0 to ArgCount - 1 do
      begin
        argPtr := @args[ArgCount - x - 1];
        argType := PVarData(PParams[x]).VType and varTypeMask;
        case argType of
          varInteger:
            begin
              argPtr.vt := VT_I4 or VT_BYREF;
              argPtr.plVal := @TVarData(PParams[x]^).VInteger;
            end;
          varDouble:
            begin
              argPtr.vt := VT_R8 or VT_BYREF;
              argPtr.pdblVal := @TVarData(PParams[x]^).VDouble;
            end;
          varBoolean:
            begin
              argPtr.vt := VT_BOOL or VT_BYREF;
              argPtr.pbool := @TVarData(PParams[x]^).VBoolean;
            end;
          varDate:
            begin
              argPtr.vt := VT_DATE or VT_BYREF;
              argPtr.pdate := @TVarData(PParams[x]^).VDate;
            end;
          varString:
            begin
              // Transform Delphi-strings to OLE-strings
              with strings[strCount] do
              begin
                BStr := StringToOleStr(string(PVarData(PParams[x]).VString));
                PStr := @(PVarData(PParams[x]).VString);
                argPtr.vt := VT_BSTR or VT_BYREF;
                argPtr.pbstrVal := @BStr;
              end;
              Inc(strCount);
            end;
          varOleStr:
            begin
              argPtr.vt := VT_BSTR or VT_BYREF;
              argPtr.pbstrVal := @TVarData(PParams[x]^).VOleStr;
            end;
          varDispatch:
            begin
              argPtr.vt := VT_DISPATCH or VT_BYREF;
              argPtr.pdispVal := @TVarData(PParams[x]^).VDispatch;
            end;
          varError:
            begin
              argPtr.vt := VT_ERROR;
              argPtr.scode := DISP_E_PARAMNOTFOUND;
            end;
          varVariant, varEmpty, varNull:
            begin
              argPtr.vt := varVariant or VT_BYREF;
              argPtr.pvarVal := PParams[x];
            end;
        else
          raise Exception.CreateFmt('Invalid data type (%d) for DWSII Com-Wrapper!', [argType]);
        end;
      end;
    end;
    DispParams.rgvarg := @args;
    DispParams.cArgs := ArgCount;

    DispID := DispIDs[0];

    if InvKind = DISPATCH_PROPERTYPUT then
    begin
      if Args[0].vt and varTypeMask = varDispatch then
        InvKind := DISPATCH_PROPERTYPUTREF;
      DispParams.rgdispidNamedArgs := DispIDs; // = @DispIDs[0]
      DispParams.cNamedArgs := NamedArgCount + 1;
      DispIDs[0] := DISPID_PROPERTYPUT;
    end
    else begin
      DispParams.rgdispidNamedArgs := @DispIDs[1];
      DispParams.cNamedArgs := NamedArgCount;
    end;

    try
      // Invoke COM Method
      Result := Dispatch.Invoke(DispID, GUID_NULL, 0, InvKind, dispParams,
        PResult, @excepInfo, nil);
    finally
      DispIDs[0] := DispID; // reset
    end;

    if Result = 0 then begin
      for x := strCount - 1 downto 0 do
        with strings[x] do
          if PStr <> nil then OleStrToStrVar(BStr, PStr^);
    end;

  finally
    for x := strCount - 1 downto 0 do
      SysFreeString(strings[x].BStr);
  end;
end;

{ TComConnectorCall }

function TComConnectorCall.Call(const Base: Variant; Args: TConnectorArgs): TData;
const
  maxOleArgs = 64;
var
  x: Integer;
  paramData: array [0..maxOleArgs - 1] of Pointer;
  disp: IDispatch;
  pMethodName: PWideChar;
begin
  for x := 0 to Length(Args) - 1 do
    paramData[x] := @Args[x][0];

  disp := Base;

  if not FIsInitialized then
  begin
    pMethodName := PWideChar(FMethodName);
    // Get DISPID of this method
    OleCheck(disp.GetIDsOfNames(GUID_NULL, @pMethodName, 1, LOCALE_SYSTEM_DEFAULT, @FDispId));
    FIsInitialized := True;
  end;

  SetLength(Result, 1);
  OleCheck(DispatchInvoke(disp, FMethodType,
    Length(Args), 0, @FDispId, @paramData, @Result[0]));
end;

constructor TComConnectorCall.Create(MethodName: string; Params: TConnectorParams;
  MethodType: Cardinal);
begin
  FMethodName := MethodName;
  FMethodType := MethodType;
end;

{ TComConnectorMember }

constructor TComConnectorMember.Create(MemberName: string);
begin
  FMemberName := MemberName;
end;

procedure TComConnectorMember.GetDispId(Disp: IDispatch);
var
  pMemberName: PWideChar;
begin
  pMemberName := PWideChar(FMemberName);
  OleCheck(disp.GetIDsOfNames(GUID_NULL, @pMemberName, 1, LOCALE_SYSTEM_DEFAULT, @FDispId));
  FIsInitialized := True;
end;

function TComConnectorMember.Read(const Base: Variant): TData;
begin
  if not FIsInitialized then
    GetDispId(Base);
  SetLength(Result, 1);
  Result[0] := GetDispatchPropValue(IDispatch(Base), FDispID);
end;

procedure TComConnectorMember.Write(const Base: Variant; Data: TData);
begin
  if not FIsInitialized then
    GetDispId(Base);
  SetDispatchPropValue(IDispatch(Base), FDispId, Data[0]);
end;

{ TComVariantArrayType }

function TComVariantArrayType.ReadIndex(const Base: Variant;
  Args: TConnectorArgs): TData;
var
  Indices : array of Integer;
  x,ArgCount : Integer;
begin
  ArgCount := Length(Args);
  SetLength(Result,1);
  SetLength(Indices,ArgCount);
  for x := 0 to ArgCount - 1 do
    Indices[x] := Args[x][0];
  VarCopy(Result[0],VarArrayGet(Base,Indices));
end;


function TComVariantArrayType.WriteIndex(const Base: Variant;
  Args: TConnectorArgs): TData;
var
  BaseRef : Variant;
  x,ArgCount : Integer;
  Indices : array of Integer;
begin
  ArgCount := Length(Args) - 1;
  SetLength(Indices,ArgCount);
  for x := 0 to ArgCount - 1 do
    Indices[x] := Args[x][0];
  BaseRef := VarArrayRef(Base); // need var-ref
  VarArrayPut(BaseRef,Args[ArgCount][0],Indices)
end;

function TComVariantArrayType.ConnectorCaption: string;
begin
  result := 'ComVariantArray';
end;

constructor TComVariantArrayType.Create(Table: TSymbolTable);
begin
  inherited Create;
  FTable := Table;
end;

function TComVariantArrayType.HasIndex(PropName: string; Params: TConnectorParams;
  var TypSym: TSymbol; IsWrite : Boolean): IConnectorCall;
var
  SymInteger : TSymbol;
  SymVariant : TSymbol;
  x, l : Integer;
begin
  result := nil;

  SymVariant := FTable.FindSymbol(SYS_VARIANT);
  SymInteger := FTable.FindSymbol(SYS_INTEGER);

  l := Length(Params);
  if IsWrite then begin
    Dec(l); // Last Parameter is Put-Value
    if not SymVariant.IsCompatible(Params[l].TypSym) then
      Exit;
  end;

  // Check Integer Indices
  x := 0;
  while (x < l) and SymInteger.IsCompatible(Params[x].TypSym) do
    Inc(x);

  if x < l then
    Exit;

  if IsWrite then begin
    TypSym := nil;
    result := IComVariantArrayWriteIndex(Self);
  end
  else begin
    TypSym := SymVariant;
    result := IComVariantArrayReadIndex(Self);
  end;
end;

function TComVariantArrayType.HasMember(MemberName: string;
  var TypSym: TSymbol; IsWrite : Boolean): IConnectorMember;
begin
  if SameText(MemberName,'high') then begin
    result := IComVariantArrayHighBound(Self);
    TypSym := FTable.FindSymbol(SYS_INTEGER);
  end
  else if IsWrite then
    result := nil
  else begin
    if SameText(MemberName,'length') then begin
      result := IComVariantArrayLength(Self);
      TypSym := FTable.FindSymbol(SYS_INTEGER);
    end
    else if SameText(MemberName,'low') then begin
      result := IComVariantArrayLowBound(Self);
      TypSym := FTable.FindSymbol(SYS_INTEGER);
    end
    else if SameText(MemberName,'dimcount') then begin
      result := IComVariantArrayDimCount(Self);
      TypSym := FTable.FindSymbol(SYS_INTEGER);
    end
    else
      result := nil;
  end;
end;

function TComVariantArrayType.HasMethod(MethodName: string;
  Params: TConnectorParams; var TypSym: TSymbol): IConnectorCall;
begin
  if (Length(Params) = 1) and
     FTable.FindSymbol(SYS_INTEGER).IsCompatible(Params[0].TypSym) then begin
    if SameText(MethodName,'length') then begin
      result := IComVariantArrayLengthCall(Self);
      TypSym := FTable.FindSymbol(SYS_INTEGER);
    end
    else if SameText(MethodName,'low') then begin
      result := IComVariantArrayLowBoundCall(Self);
      TypSym := FTable.FindSymbol(SYS_INTEGER);
    end
    else if SameText(MethodName,'high') then begin
      result := IComVariantArrayHighBoundCall(Self);
      TypSym := FTable.FindSymbol(SYS_INTEGER);
    end
    else
      result := nil;
  end
  else
    result := nil;
end;

function TComVariantArrayType.ReadHighBound(const Base: Variant): TData;
begin
  SetLength(Result,1);
  Result[0] := VarArrayHighBound(Base,1);
end;

function TComVariantArrayType.ReadLength(const Base: Variant): TData;
begin
  SetLength(Result,1);
  Result[0] := VarArrayHighBound(Base,1) - VarArrayLowBound(Base,1) + 1;
end;

function TComVariantArrayType.ReadLowBound(const Base: Variant): TData;
begin
  SetLength(Result,1);
  Result[0] := VarArrayLowBound(Base,1);
end;

procedure TComVariantArrayType.Write(const Base: Variant; Data: TData);
begin
  Assert(False); // we should never com here
end;

function TComVariantArrayType.ReadDimCount(const Base: Variant): TData;
begin
  SetLength(Result,1);
  Result[0] := VarArrayDimCount(Base);
end;

procedure TComVariantArrayType.WriteHighBound(const Base: Variant; Data: TData);
var
  BaseRef : Variant;
  x : Integer;
begin
  x := Data[0];
  BaseRef := VarArrayRef(Base);
  VarArrayRedim(BaseRef,x);
end;

function TComVariantArrayType.ReadHighBound(const Base: Variant;
  Args: TConnectorArgs): TData;
begin
  SetLength(Result,1);
  Result[0] := VarArrayHighBound(Base,Args[0][0]);
end;

function TComVariantArrayType.ReadLength(const Base: Variant;
  Args: TConnectorArgs): TData;
var x : Integer;
begin
  x := Args[0][0];
  SetLength(Result,1);
  Result[0] := VarArrayHighBound(Base,x) - VarArrayLowBound(Base,x) + 1;
end;

function TComVariantArrayType.ReadLowBound(const Base: Variant;
  Args: TConnectorArgs): TData;
begin
  SetLength(Result,1);
  Result[0] := VarArrayLowBound(Base,Args[0][0]);
end;

{ TComVariantArraySymbol }

function TComVariantArraySymbol.IsCompatible(TypSym: TSymbol): Boolean;
begin
  // only accept comvariantarray or std-arrays or variants
  Result := (Self = TypSym) or
            (TypSym is TBaseSymbol) and (TBaseSymbol(TypSym).Id = TypVariantID) or
            (typSym is TCustomArraySymbol) and Typ.IsCompatible(typSym.Typ);
end;

procedure TComVariantArraySymbol.CopyData(FromData: TData; FromAddr: Integer; ToData: TData;
  ToAddr: Integer);
var
  x: Integer;
  len: Integer;
  adr, siz: Integer;
  dat: TData;
begin
  adr := FromAddr;
  dat := FromData;
  if VarIsNull(dat[adr]) or VarIsEmpty(dat[adr]) or VarIsArray(dat[adr]) then begin
    VarCopy(ToData[ToAddr],dat[adr]);          // := ComVariantArray or initial
  end
  else begin                                                 // := CustomArray
    adr := dat[adr]; // !! must change if array layout changes !!
    len := dat[adr];
    siz := dat[adr + 1];
    ToData[ToAddr] := VarArrayCreate([0,len-1],varVariant);
    Inc(adr,2);
    for x := 0 to len - 1 do begin
      ToData[ToAddr][x] := dat[adr];
      Inc(adr,siz);
    end;
  end;
end;

constructor TComVariantArraySymbol.Create(Name: string;
  ConnectorType: IConnectorType; Typ: TSymbol);
begin
  inherited Create(Name,ConnectorType);
  Self.Typ := Typ;
end;

procedure TComVariantArraySymbol.InitData(Dat: TData; Offset: Integer);
begin
  Dat[Offset] := VarArrayCreate([0,-1],varVariant); // empty array
end;

end.