dws2comconnector.pas

script language

{**********************************************************************}
{                                                                      }
{    "The contents of this file are subject to the Mozilla Public      }
{    License Version 1.1 (the "License"); you may not use this         }
{    file except in compliance with the License. You may obtain        }
{    a copy of the License at                                          }
{                                                                      }
{    http://www.mozilla.org/MPL/                                       }
{                                                                      }
{    Software distributed under the License is distributed on an       }
{    "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express       }
{    or implied. See the License for the specific language             }
{    governing rights and limitations under the License.               }
{                                                                      }
{    The Original Code is DelphiWebScriptII source code, released      }
{    January 1, 2001                                                   }
{                                                                      }
{    The Initial Developer of the Original Code is Matthias            }
{    Ackermann. Portions created by Matthias Ackermann are             }
{    Copyright (C) 2000 Matthias Ackermann, Switzerland. All           }
{    Rights Reserved.                                                  }
{                                                                      }
{    Contributor(s): Andreas Luleich.                                  }
{                                                                      }
{**********************************************************************}

{$I dws2.inc}

unit dws2ComConnector;

interface

uses
{$IFDEF NEWVARIANTS}
  Variants,
{$ENDIF}
  Classes, SysUtils, dws2Comp, dws2Symbols, dws2Exprs, SysConst;

const
  COM_ConnectorCaption = 'COM Connector 1.0';
  COM_UnitName = 'COM';

type
  Tdws2ComConnector = class(Tdws2AbstractUnit, IUnknown, IConnector)
  private
    function ConnectorCaption: string;
    function ConnectorName: string;
    function GetUnit(UnitName: string): IConnectorType;
  protected
    function GetUnitName: string; override;
    function GetUnitTable(SystemTable, UnitSyms: TSymbolTable): TSymbolTable; override;
  end;

implementation

uses
  dws2Strings, dws2Functions,
  Windows, ComObj, ComConst, ActiveX, AxCtrls;

type
  TCreateOleObjectFunc = class(TInternalFunction)
    procedure Execute; override;
  end;

  TComConnectorType = class(TInterfacedObject, IUnknown, IConnectorType)
  private
    FTable: TSymbolTable;
  protected
    { IConnectorType }
    function ConnectorCaption: string;
    function HasMethod(MethodName: string; Params: TConnectorParams; var TypSym:
      TSymbol): IConnectorCall;
    function HasMember(MemberName: string; var TypSym: TSymbol; IsWrite : Boolean): IConnectorMember;
    function HasIndex(PropName: string; Params: TConnectorParams; var TypSym: TSymbol; IsWrite : Boolean): IConnectorCall;
  public
    constructor Create(Table: TSymbolTable);
  end;

  TComConnectorCall = class(TInterfacedObject, IUnknown, IConnectorCall)
  private
    FDispId: TDispId;
    FIsInitialized: Boolean;
    FMethodName: WideString;
    FMethodType: Cardinal;
  protected
    function Call(const Base: Variant; Args: TConnectorArgs): TData;
  public
    constructor Create(MethodName: string; Params: TConnectorParams;
      MethodType: Cardinal = DISPATCH_METHOD);
  end;

  TComConnectorMember = class(TInterfacedObject, IUnknown, IConnectorMember)
  protected
    FDispId: TDispId;
    FIsInitialized: Boolean;
    FMemberName: WideString;
    procedure GetDispId(Disp: IDispatch);
    function Read(const Base: Variant): TData;
    procedure Write(const Base: Variant; Data: TData);
  public
    constructor Create(MemberName: string);
  end;

  TComVariantArraySymbol = class (TConnectorSymbol)
  public
    constructor Create(Name: string; ConnectorType: IConnectorType; Typ : TSymbol);
    procedure CopyData(FromData: TData; FromAddr: Integer; ToData: TData;
      ToAddr: Integer); override;
    function IsCompatible(TypSym: TSymbol): Boolean; override;
    procedure InitData(Dat: TData; Offset: Integer); override;
  end;

  IComVariantArrayLength = interface (IConnectorMember) end;
  IComVariantArrayHighBound = interface (IConnectorMember) end;
  IComVariantArrayLowBound = interface (IConnectorMember) end;
  IComVariantArrayDimCount = interface (IConnectorMember) end;
  IComVariantArrayReadIndex = interface (IConnectorCall) end;
  IComVariantArrayWriteIndex = interface (IConnectorCall) end;
  IComVariantArrayLengthCall = interface (IConnectorCall) end;
  IComVariantArrayHighBoundCall = interface (IConnectorCall) end;
  IComVariantArrayLowBoundCall = interface (IConnectorCall) end;

  TComVariantArrayType = class(TInterfacedObject, IUnknown, IConnectorType,
    IComVariantArrayReadIndex, IComVariantArrayWriteIndex,
    IComVariantArrayLength, IComVariantArrayDimCount,
    IComVariantArrayHighBound, IComVariantArrayLowBound,
    IComVariantArrayLowBoundCall, IComVariantArrayHighBoundCall,
    IComVariantArrayLengthCall)
  private
    FTable: TSymbolTable;
  protected
    function ReadLength(const Base: Variant): TData; overload;
    function ReadLowBound(const Base: Variant): TData; overload;
    function ReadHighBound(const Base: Variant): TData; overload;
    function ReadDimCount(const Base: Variant): TData;
    procedure WriteHighBound(const Base: Variant; Data: TData);
    function ReadIndex(const Base: Variant; Args: TConnectorArgs): TData;
    function WriteIndex(const Base: Variant; Args: TConnectorArgs): TData;
    function ReadLength(const Base: Variant; Args: TConnectorArgs): TData; overload;
    function ReadLowBound(const Base: Variant; Args: TConnectorArgs): TData; overload;
    function ReadHighBound(const Base: Variant; Args: TConnectorArgs): TData; overload;
    { IConnectorType }
    function ConnectorCaption: string;
    function HasMethod(MethodName: string; Params: TConnectorParams; var TypSym:
      TSymbol): IConnectorCall;
    function HasMember(MemberName: string; var TypSym: TSymbol; IsWrite : Boolean): IConnectorMember;
    function HasIndex(PropName: string; Params: TConnectorParams; var TypSym: TSymbol; IsWrite : Boolean): IConnectorCall;
    { IConnectorCall }
    function IComVariantArrayReadIndex.Call = ReadIndex;
    function IComVariantArrayWriteIndex.Call = WriteIndex;
    function IComVariantArrayLowBoundCall.Call = ReadLowBound;
    function IComVariantArrayHighBoundCall.Call = ReadHighBound;
    function IComVariantArrayLengthCall.Call = ReadLength;
    { IConnectorMember }
    function IComVariantArrayLength.Read = ReadLength;
    function IComVariantArrayHighBound.Read = ReadHighBound;
    function IComVariantArrayLowBound.Read = ReadLowBound;
    function IComVariantArrayDimCount.Read = ReadDimCount;
    procedure IComVariantArrayHighBound.Write = WriteHighBound;
    procedure Write(const Base: Variant; Data: TData);
  public
    constructor Create(Table: TSymbolTable);
  end;

{$IFNDEF DELPHI6up}

// this code was taken from Delphi 5 unit "System.pas"

const
  oleaut = 'oleaut32.dll';

const
  reVarNotArray       = 19;
  reVarArrayBounds    = 20;

procedure Error(errorCode: Byte);
var Msg : String;
begin
	case errorCode of
  	reVarNotArray : Msg := SVarNotArray;
    reVarArrayBounds : Msg := SVarArrayBounds;
  end;
	raise Exception.Create(Msg);
end;

function SafeArrayGetElement(VarArray: PVarArray; Indices,
  Data: Pointer): Integer; stdcall;
  external oleaut name 'SafeArrayGetElement';

function SafeArrayPtrOfIndex(VarArray: PVarArray; Indices: Pointer;
  var pvData: Pointer): HResult; stdcall;
  external oleaut name 'SafeArrayPtrOfIndex';

function SafeArrayPutElement(VarArray: PVarArray; Indices,
  Data: Pointer): Integer; stdcall;
  external oleaut name 'SafeArrayPutElement';

procedure VarStringToOleStr(var Dest: Variant; const Source: Variant);
var
  OleStrPtr: PWideChar;
begin
  OleStrPtr := StringToOleStr(string(TVarData(Source).VString));
  VarClear(Dest);
  TVarData(Dest).VType := varOleStr;
  TVarData(Dest).VOleStr := OleStrPtr;
end;

function GetVarArray(const A: Variant): PVarArray;
begin
  if TVarData(A).VType and varArray = 0 then Error(reVarNotArray);
  if TVarData(A).VType and varByRef <> 0 then
    Result := PVarArray(TVarData(A).VPointer^) else
    Result := TVarData(A).VArray;
end;

function _VarArrayGet(var A: Variant; IndexCount: Integer;
  Indices: Integer): Variant; cdecl;
var
  VarArrayPtr: PVarArray;
  VarType: Integer;
  P: Pointer;
begin
  if TVarData(A).VType and varArray = 0 then Error(reVarNotArray);
  VarArrayPtr := GetVarArray(A);
  if VarArrayPtr^.DimCount <> IndexCount then Error(reVarArrayBounds);
  VarType := TVarData(A).VType and varTypeMask;
  VarClear(Result);
  if VarType = varVariant then
  begin
    if SafeArrayPtrOfIndex(VarArrayPtr, @Indices, P) <> 0 then
      Error(reVarArrayBounds);
    Result := PVariant(P)^;
  end else
  begin
  if SafeArrayGetElement(VarArrayPtr, @Indices,
      @TVarData(Result).VPointer) <> 0 then Error(reVarArrayBounds);
    TVarData(Result).VType := VarType;
  end;
end;

procedure _VarArrayPut(var A: Variant; const Value: Variant;
  IndexCount: Integer; Indices: Integer); cdecl;
type
  TAnyPutArrayProc = procedure (var A: Variant; const Value: Variant; Index: Integer);
var
  VarArrayPtr: PVarArray;
  VarType: Integer;
  P: Pointer;
  Temp: TVarData;
begin
  if TVarData(A).VType and varArray = 0 then Error(reVarNotArray);
  VarArrayPtr := GetVarArray(A);
  if VarArrayPtr^.DimCount <> IndexCount then Error(reVarArrayBounds);
  VarType := TVarData(A).VType and varTypeMask;
  if (VarType = varVariant) and (TVarData(Value).VType <> varString) then
  begin
    if SafeArrayPtrOfIndex(VarArrayPtr, @Indices, P) <> 0 then
      Error(reVarArrayBounds);
    PVariant(P)^ := Value;
  end else
  begin
    Temp.VType := varEmpty;
    try
      if VarType = varVariant then
      begin
        VarStringToOleStr(Variant(Temp), Value);
        P := @Temp;
      end else
      begin
        VarCast(Variant(Temp), Value, VarType);
        case VarType of
          varOleStr, varDispatch, varUnknown:
            P := Temp.VPointer;
        else
          P := @Temp.VPointer;
        end;
      end;
      if SafeArrayPutElement(VarArrayPtr, @Indices, P) <> 0 then
        ; // Error(reVarArrayBounds);
    finally
      VarClear(Variant(Temp));
    end;
  end;
end;

function VarArrayGet(const A: Variant; const Indices: array of Integer): Variant;
asm
        {     ->EAX     Pointer to A            }
        {       EDX     Pointer to Indices      }
        {       ECX     High bound of Indices   }
        {       [EBP+8] Pointer to result       }

        PUSH    EBX

        MOV     EBX,ECX
        INC     EBX
        JLE     @@endLoop
@@loop:
        PUSH    [EDX+ECX*4].Integer
        DEC     ECX
        JNS     @@loop
@@endLoop:
        PUSH    EBX
        PUSH    EAX
        MOV     EAX,[EBP+8]
        PUSH    EAX
        CALL    _VarArrayGet
        LEA     ESP,[ESP+EBX*4+3*4]

        POP     EBX
end;

procedure VarArrayPut(var A: Variant; const Value: Variant; const Indices: array of Integer);
asm
        {     ->EAX     Pointer to A            }
        {       EDX     Pointer to Value        }
        {       ECX     Pointer to Indices      }
        {       [EBP+8] High bound of Indices   }

        PUSH    EBX

        MOV     EBX,[EBP+8]

        TEST    EBX,EBX
        JS      @@endLoop
@@loop:
        PUSH    [ECX+EBX*4].Integer
        DEC     EBX
        JNS     @@loop
@@endLoop:
        MOV     EBX,[EBP+8]
        INC     EBX
        PUSH    EBX
        PUSH    EDX
        PUSH    EAX
        CALL    _VarArrayPut
        LEA     ESP,[ESP+EBX*4+3*4]

        POP     EBX
end;

{$ENDIF}

{ Tdws2ComConnector }

function Tdws2ComConnector.ConnectorCaption: string;
begin
  Result := COM_ConnectorCaption;
end;

function Tdws2ComConnector.ConnectorName: string;
begin
  Result := COM_UnitName;
end;

function Tdws2ComConnector.GetUnit(UnitName: string): IConnectorType;
begin
  raise Exception.Create('Not supported');
end;

function Tdws2ComConnector.GetUnitName: string;
begin
  Result := COM_UnitName;
end;

function Tdws2ComConnector.GetUnitTable(SystemTable,
  UnitSyms: TSymbolTable): TSymbolTable;
var
  v: Variant;
  VariantSym : TSymbol;
begin
  Result := TSymbolTable.Create(SystemTable);
  VariantSym := SystemTable.FindSymbol('Variant');

  // Datatype of com-objects
  Result.AddSymbol(TConnectorSymbol.Create('ComVariant',
    TComConnectorType.Create(Result)));

  // Optional parameter for dispatch interfaces with unnamed arguments
  v := 0;
  PVarData(@v).VType := varError;
  Result.AddSymbol(TConstSymbol.Create('ComOpt', VariantSym, v));

  // Function to create a new COM-Object
  TCreateOleObjectFunc.Create(Result, 'CreateOleObject', ['ClassName', SYS_STRING],
    'ComVariant');

  Result.AddSymbol(TComVariantArraySymbol.Create('ComVariantArray',
    TComVariantArrayType.Create(Result),VariantSym));
end;

{ TCreateOleObjectFunc }

procedure TCreateOleObjectFunc.Execute;
begin
  Info['Result'] := CreateOleObject(Info['ClassName']);
end;

{ TComConnectorSymbol }

function TComConnectorType.ConnectorCaption: string;
begin
  Result := COM_ConnectorCaption;
end;

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

function TComConnectorType.HasIndex(PropName: string; Params: TConnectorParams;
  var TypSym: TSymbol; IsWrite : Boolean): IConnectorCall;
var
  x: Integer;
  isValid: Boolean;
  MethType : Cardinal;
begin
  isValid := True;
  for x := 0 to Length(Params) - 1 do
  begin
    if Params[x].TypSym.Size > 1 then
    begin
      isValid := False;
      Break;
    end;
  end;

  TypSym := FTable.FindSymbol('ComVariant');
  if isValid then
  begin
    if IsWrite then
      MethType := DISPATCH_PROPERTYPUT
    else
      MethType := DISPATCH_PROPERTYGET;
    Result := TComConnectorCall.Create(PropName, Params, MethType);
  end
  else
    Result := nil;
end;

function TComConnectorType.HasMember(MemberName: string;
  var TypSym: TSymbol; IsWrite : Boolean): IConnectorMember;
begin
  TypSym := FTable.FindSymbol('ComVariant');
  Result := TComConnectorMember.Create(MemberName);
end;

function TComConnectorType.HasMethod(MethodName: string;
  Params: TConnectorParams; var TypSym: TSymbol): IConnectorCall;
var
  x: Integer;
  isValid: Boolean;
begin
  isValid := True;
  for x := 0 to Length(Params) - 1 do
  begin