oleauto.pas

这是不可多得的源代码

  if NamedArgCount <> 0 then
  begin
    Result := DISP_E_NONAMEDARGS;
    Exit;
  end;
  ArgCount := Params.cArgs;
  if ArgCount <> AutoEntry^.Params^.ParamCount then
  begin
    Result := DISP_E_BADPARAMCOUNT;
    Exit;
  end;
  Result := S_OK;
  StrCount := 0;
  for I := 0 to ArgCount - 1 do Args[I].VType := varEmpty;
  FillChar(ResVar, sizeof(ResVar), 0);
  ResVar.VType := varEmpty;
  try
    try
      if ArgCount <> 0 then
      begin
        ParamPtr := @Params.rgvarg^[ArgCount];
        ArgPtr := @Args;
        ArgIndex := 0;
        repeat
          Dec(Integer(ParamPtr), SizeOf(Variant));
          ArgType := AutoEntry^.Params^.ParamTypes[ArgIndex] and atTypeMask;
          VarFlag := AutoEntry^.Params^.ParamTypes[ArgIndex] and atByRef;
          if (ParamPtr^.VType = varError) and ((ArgType <> varVariant) or
            (VarFlag <> 0)) then
          begin
            Result := DISP_E_PARAMNOTOPTIONAL;
            Break;
          end;
          if VarFlag <> 0 then
          begin
            if ParamPtr^.VType <> (ArgType and atVarMask or varByRef) then
            begin
              Result := DISP_E_TYPEMISMATCH;
              Break;
            end;
            if ArgType = varStrArg then
            begin
              with Strings[StrCount] do
              begin
                PStr := nil;
                BStr := ParamPtr^.VPointer;
                OleStrToStrVar(BStr^, string(PStr));
                ArgPtr^.VType := varString or varByRef;
                ArgPtr^.VPointer := @PStr;
              end;
              Inc(StrCount);
            end else
            begin
              ArgPtr^.VType := ParamPtr^.VType;
              ArgPtr^.VPointer := ParamPtr^.VPointer;
            end;
          end else
          if ArgType = varVariant then
          begin
            ArgPtr^.VType := varVariant or varByRef;
            ArgPtr^.VPointer := ParamPtr;
          end else
          begin
            Result := VariantChangeTypeEx(PVariant(ArgPtr)^,
              PVariant(ParamPtr)^, LOCALE_USER_DEFAULT, 0,
              ArgType and atVarMask);
            if Result <> S_OK then Break;
            if ArgType = varStrArg then
            begin
              StringPtr := nil;
              OleStrToStrVar(ArgPtr^.VOleStr, string(StringPtr));
              VariantClear(PVariant(ArgPtr)^);
              ArgPtr^.VType := varString;
              ArgPtr^.VString := StringPtr;
            end;
          end;
          Inc(Integer(ArgPtr), SizeOf(Variant));
          Inc(ArgIndex);
        until ArgIndex = ArgCount;
        if Result <> S_OK then
        begin
          if ArgErr <> nil then ArgErr^ := ArgCount - ArgIndex - 1;
          Exit;
        end;
      end;
      InvokeMethod(AutoEntry, @Args, @ResVar);
      for J := 0 to StrCount - 1 do
        with Strings[J] do
        begin
          OleStr := StringToOleStr(string(PStr));
          SysFreeString(BStr^);
          BStr^ := OleStr;
        end;
      if VarResult <> nil then
        if ResVar.VType = varString then
        begin
          OleStr := StringToOleStr(string(ResVar.VString));
          VariantClear(VarResult^);
          PVarData(VarResult)^.VType := varOleStr;
          PVarData(VarResult)^.VOleStr := OleStr;
        end else
        begin
          VariantClear(VarResult^);
          Move(ResVar, VarResult^, SizeOf(Variant));
          ResVar.VType := varEmpty;
        end;
    finally
      for K := 0 to StrCount - 1 do string(Strings[K].PStr) := '';
      for K := 0 to ArgCount - 1 do VarClear(Variant(Args[K]));
      VarClear(Variant(ResVar));
    end;
  except
    if ExcepInfo <> nil then
    begin
      FillChar(ExcepInfo^, SizeOf(TExcepInfo), 0);
      GetExceptionInfo(ExceptObject, ExcepInfo^);
    end;
    Result := DISP_E_EXCEPTION;
  end;
end;

procedure TAutoObject.InvokeMethod(AutoEntry, Args, Result: Pointer);
var
  Instance, AutoData: Pointer;
asm
        PUSH    EBX
        PUSH    ESI
        PUSH    EDI
        MOV     Instance,EAX
        MOV     EBX,EDX
        MOV     ESI,[EBX].TAutoEntry.Params
        MOV     EDI,-2
        MOVZX   EAX,[ESI].TParamList.ParamCount
        OR      EAX,EAX
        JE      @CheckResult
        MOV     AutoData,EBX
        MOV     EBX,EAX
        MOV     ESI,ECX

@PushLoop:
        MOV     AX,[ESI].Word[0]
        CMP     EAX,varSingle
        JE      @Push4
        CMP     EAX,varDouble
        JE      @Push8
        CMP     EAX,varCurrency
        JE      @Push8
        CMP     EAX,varDate
        JE      @Push8
        INC     EDI
        JG      @Push4
        JE      @LoadECX

@LoadEDX:
        MOV     EDX,[ESI].Integer[8]
        JMP     @PushNext

@LoadECX:
        MOV     ECX,[ESI].Integer[8]
        JMP     @PushNext

@Push8:
        PUSH    [ESI].Integer[12]

@Push4:
        PUSH    [ESI].Integer[8]

@PushNext:
        ADD     ESI,16
        DEC     EBX
        JNE     @PushLoop
        MOV     EBX,AutoData
        MOV     ESI,[EBX].TAutoEntry.Params

@CheckResult:
        MOV     AL,[ESI].TParamList.ResType
        CMP     AL,varOleStr
        JE      @PassOleStrRes
        CMP     AL,varStrArg
        JE      @PassStringRes
        CMP     AL,varVariant
        JNE     @Invoke

@PassVarRes:
        MOV     EAX,Result
        JMP     @PassResult

@PassOleStrRes:
        MOV     EAX,Result
        MOV     [EAX].Word,varOleStr
        JMP     @PassStrRes

@PassStringRes:
        MOV     EAX,Result
        MOV     [EAX].Word,varString

@PassStrRes:
        ADD     EAX,8
        MOV     [EAX].Integer,0

@PassResult:
        INC     EDI
        JG      @ResultPush
        JE      @ResultECX

@ResultEDX:
        MOV     EDX,EAX
        JMP     @Invoke

@ResultECX:
        MOV     ECX,EAX
        JMP     @Invoke

@ResultPush:
        PUSH    EAX

@Invoke:
        MOV     EAX,Instance
        LEA     EDI,[EBX].TAutoEntry.Address
        TEST    [EBX].TAutoEntry.Flags,afVirtual
        JE      @CallMethod
        MOV     EDI,[EAX]
        ADD     EDI,[EBX].TAutoEntry.Address

@CallMethod:
        CALL    [EDI].Pointer
        MOV     EDX,Result
        MOV     CL,[ESI].TParamList.ResType
        AND     ECX,atVarMask
        JMP     @ResultTable.Pointer[ECX*4]

@ResultTable:
        DD      @ResNone
        DD      @ResNone
        DD      @ResInteger
        DD      @ResInteger
        DD      @ResSingle
        DD      @ResDouble
        DD      @ResCurrency
        DD      @ResDouble
        DD      @ResNone
        DD      @ResNone
        DD      @ResNone
        DD      @ResInteger
        DD      @ResNone

@ResSingle:
        FSTP    [EDX].Single[8]
        FWAIT
        JMP     @ResSetType

@ResDouble:
        FSTP    [EDX].Double[8]
        FWAIT
        JMP     @ResSetType

@ResCurrency:
        FISTP   [EDX].Currency[8]
        FWAIT
        JMP     @ResSetType

@ResInteger:
        MOV     [EDX].Integer[8],EAX

@ResSetType:
        MOV     [EDX].Word,CX

@ResNone:
        POP     EDI
        POP     ESI
        POP     EBX
end;

function TAutoObject.QueryInterface(const iid: TIID; var obj): HResult;
begin
  if IsEqualIID(iid, IID_IUnknown) or IsEqualIID(iid, IID_IDispatch) or
    IsEqualIID(iid, IID_IAutoDispatch) then
  begin
    Pointer(obj) := FAutoDispatch;
    AddRef;
    Result := S_OK;
  end else
  begin
    Pointer(obj) := nil;
    Result := E_NOINTERFACE;
  end;
end;

function TAutoObject.Release: Integer;
begin
  Dec(FRefCount);
  Result := FRefCount;
  if FRefCount = 0 then Free;
end;

{ TClassFactory }

constructor TClassFactory.Create(AutoClass: TAutoClass);
begin
  Inc(Automation.FClassFactoryCount);
  FRefCount := 1;
  FAutoClass := AutoClass;
end;

destructor TClassFactory.Destroy;
begin
  Dec(Automation.FClassFactoryCount);
end;

function TClassFactory.QueryInterface(const iid: TIID; var obj): HResult;
begin
  if IsEqualIID(iid, IID_IUnknown) or IsEqualIID(iid, IID_IClassFactory) then
  begin
    Pointer(obj) := Self;
    AddRef;
    Result := S_OK;
  end else
  begin
    Pointer(obj) := nil;
    Result := E_NOINTERFACE;
  end;
end;

function TClassFactory.AddRef: Longint;
begin
  Inc(FRefCount);
  Result := FRefCount;
end;

function TClassFactory.Release: Longint;
begin
  Dec(FRefCount);
  Result := FRefCount;
  if FRefCount = 0 then Free;
end;

function TClassFactory.CreateInstance(unkOuter: IUnknown; const iid: TIID;
  var obj): HResult;
var
  AutoObject: TAutoObject;
begin
  Pointer(obj) := nil;
  if unkOuter <> nil then
  begin
    Result := CLASS_E_NOAGGREGATION;
    Exit;
  end;
  try
    AutoObject := FAutoClass.Create;
  except
    Result := E_UNEXPECTED;
    Exit;
  end;
  Result := AutoObject.QueryInterface(iid, obj);
  AutoObject.Release;
end;

function TClassFactory.LockServer(fLock: BOOL): HResult;
begin
  Automation.CountAutoObject(fLock);
  Result := S_OK;
end;

{ TRegistryClass }

constructor TRegistryClass.Create(const AutoClassInfo: TAutoClassInfo);
const
  RegFlags: array[acSingleInstance..acMultiInstance] of Integer = (
    REGCLS_SINGLEUSE, REGCLS_MULTIPLEUSE);
var
  ClassFactory: TClassFactory;
begin
  FAutoClass := AutoClassInfo.AutoClass;
  FProgID := AutoClassInfo.ProgID;
  FClassID := StringToClassID(AutoClassInfo.ClassID);
  FDescription := AutoClassInfo.Description;
  FInstancing := AutoClassInfo.Instancing;
  if not Automation.IsInprocServer and (FInstancing <> acInternal) then
  begin
    ClassFactory := TClassFactory.Create(FAutoClass);
    CoRegisterClassObject(FClassID, ClassFactory, CLSCTX_LOCAL_SERVER,
      RegFlags[FInstancing], FRegister);
    ClassFactory.Release;
  end;
end;

destructor TRegistryClass.Destroy;
begin
  if FRegister <> 0 then CoRevokeClassObject(FRegister);
end;

procedure TRegistryClass.UpdateRegistry(Register: Boolean);
var
  ClassID, FileName: string;
  Buffer: array[0..261] of Char;
begin
  if FInstancing <> acInternal then
  begin
    ClassID := ClassIDToString(FClassID);
    SetString(FileName, Buffer, GetModuleFileName(HInstance, Buffer,
      SizeOf(Buffer)));
    if Register then
    begin
      CreateRegKey(FProgID, FDescription);
      CreateRegKey(FProgID + '\Clsid', ClassID);
      CreateRegKey('CLSID\' + ClassID, FDescription);
      CreateRegKey('CLSID\' + ClassID + '\ProgID', FProgID);
      CreateRegKey('CLSID\' + ClassID + '\' + GetServerKey, FileName);
    end else
    begin
      DeleteRegKey('CLSID\' + ClassID + '\' + GetServerKey);
      DeleteRegKey('CLSID\' + ClassID + '\ProgID');
      DeleteRegKey('CLSID\' + ClassID);
      DeleteRegKey(FProgID + '\Clsid');
      DeleteRegKey(FProgID);
    end;
  end;
end;

{ TAutomation }

var
  SaveInitProc: Pointer;

procedure InitAutomation;
begin
  if SaveInitProc <> nil then TProcedure(SaveInitProc);
  Automation.Initialize;
end;

constructor TAutomation.Create;
begin
  FIsInprocServer := IsLibrary;
  if FindCmdLineSwitch('AUTOMATION') or FindCmdLineSwitch('EMBEDDING') then
    FStartMode := smAutomation
  else if FindCmdLineSwitch('REGSERVER') then
    FStartMode := smRegServer
  else if FindCmdLineSwitch('UNREGSERVER') then
    FStartMode := smUnregServer;
end;

destructor TAutomation.Destroy;
var
  RegistryClass: TRegistryClass;
begin
  while FRegistryList <> nil do
  begin
    RegistryClass := FRegistryList;
    FRegistryList := RegistryClass.FNext;
    RegistryClass.Free;
  end;
end;

procedure TAutomation.CountAutoObject(Created: Boolean);
begin
  if Created then Inc(FAutoObjectCount) else
  begin
    Dec(FAutoObjectCount);
    if FAutoObjectCount = 0 then LastReleased;
  end;
end;

procedure TAutomation.Initialize;
begin
  UpdateRegistry(FStartMode <> smUnregServer);
  if FStartMode in [smRegServer, smUnregServer] then Halt;
end;

procedure TAutomation.LastReleased;
var
  Shutdown: Boolean;
begin
  if not FIsInprocServer then
  begin
    Shutdown := FStartMode = smAutomation;
    if Assigned(FOnLastRelease) then FOnLastRelease(Shutdown);
    if Shutdown then PostQuitMessage(0);
  end;
end;

procedure TAutomation.RegisterClass(const AutoClassInfo: TAutoClassInfo);
var
  RegistryClass: TRegistryClass;
begin
  RegistryClass := TRegistryClass.Create(AutoClassInfo);
  RegistryClass.FNext := FRegistryList;
  FRegistryList := RegistryClass;
end;

procedure TAutomation.UpdateRegistry(Register: Boolean);
var
  RegistryClass: TRegistryClass;
begin
  RegistryClass := FRegistryList;
  while RegistryClass <> nil do
  begin
    RegistryClass.UpdateRegistry(Register);
    RegistryClass := RegistryClass.FNext;
  end;
end;

initialization
begin
  OleInitialize(nil);
  Automation := TAutomation.Create;
  SaveInitProc := InitProc;
  InitProc := @InitAutomation;
end;

finalization
begin
  Automation.Free;
  OleUninitialize;
end;

end.