CacheObject: SetOutput в Delphi

Основной механизм соединения с Cache' при построении клиент-серверных систем и традиционных средств разработки класса Delphi, Borland C++ Builder и других - это ActiveX-комплект CacheObject.

При его использовании без VB может быть потеряна функциональность callback, а именно так называемый механизм получения терминального вывода процесса. В VB используется конструкция

set CacheFactory = CreateObject("CacheObject.Factory")
CacheFactory.SetOutput( TextBox)

Здесь TextBox - это компонент многострочного вывода.

При вызове на сервере метода какого-либо класса, который возвращает информацию не в виде возврата функции, а отправляя в текущее устройство вывода, например, $System.OBJ.ExportCDL(), объект CacheFactory перенаправляет вывод в компонент VB, указанный в SetOutput. Поскольку в Delphi и BCB нет бейсикового textbox, возникает проблема.

Ее решение заключается в имитации компонента, который в бейсиковом варианте передается в SetOutput. Для ActiveX компонента это выглядит естественным образом как некий IDispatch - объект. То есть для получения такого терминально-ориентированного вывода нужно «подсунуть» некий объект, реализующий IDispatch интерфейс и который по правилам и соглашениям IDispatch воспроизведет ту функциональность бейсикового textbox, которую использует CacheObject.

Реализация IDispatch на BCB и Delphi не сложна, достаточно следовать документации, описывающей создание automation-объектов. Для получения активации нам нужно реализовать функции IDispatch.

TSetOutput = class ( TInterfacedObject, IDispatch)
protected
  function GetTypeInfoCount(
    out Count: Integer): HResult; stdcall;
  function GetTypeInfo(
    Index, LocaleID: Integer; out TypeInfo):
    HResult; stdcall;
  function GetIDsOfNames(
    const IID: TGUID; Names: Pointer;
    NameCount, LocaleID: Integer; DispIDs: Pointer):
    HResult; stdcall;
  function Invoke(
    DispID: Integer; const IID: TGUID; LocaleID: Integer;
    Flags: Word; var Params; VarResult, ExcepInfo,
    ArgErr: Pointer): HResult; stdcall;
end;  

Как показывает анализ поведения создаваемого объекта этого класса, компонент CacheObject.Factory использует только свойство Text. Поэтому достаточно реализовать поддержку только его: в обработчике GetIDsOfNames сообщить первый свободный dispid

function TSetOutput.GetIDsOfNames(
  const IID: TGUID; Names: Pointer;
  NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
type
  TDispIDsArray = array[0..0] of TDISPID;
  PDispIDsArray = ^TDispIDsArray;
var
  IDs: PDispIDsArray absolute DispIDs;
  Name: WideString;
begin
  if NameCount > 1 then Result := DISP_E_UNKNOWNNAME
  else
    if NameCount < 1 then Result := E_INVALIDARG
    else Result := S_OK;
  if NameCount = 1 then
  begin
      Name := PWideChar(Names^);
      if UpperCase(Name) = 'TEXT' then IDs[0] := 1
      else Result := DISP_E_UNKNOWNNAME;
  end;
end;

и в обработчике Invoke просто вызвать перенаправление из IDispatch - объекта в обычный дельфийский объект с помощью вызова устанавливаемого обработчикка события.

function TSetOutput.Invoke(
  DispID: Integer; const IID: TGUID;
  LocaleID: Integer; Flags: Word; 
  var Params; VarResult, ExcepInfo,
  ArgErr: Pointer): HResult;
var
  P: TDISPPARAMS absolute Params;
  V: ^Variant absolute VarResult;
  S: string;
begin
  if DispID = 1 then
  begin
    case Flags of
      DISPATCH_PROPERTYGET:
        begin
          V^ := Variant( '');
        end;
      DISPATCH_PROPERTYPUT:
        if Assigned( CacheOutput) then
        begin
          S := OleVariant( P.rgvarg[ 0]);
          CacheOutput( S);
        end;
    end;
    Result := S_OK;
  end
  else
    Result := DISP_E_MEMBERNOTFOUND;
end;

Программный интерфейс компонента TSetOutput выполнен таким образом, чтобы его можно было использовать как есть, просто добавив пару строк кода к своему приложению и написав обработчик события в обычном дельфийском стиле, например если есть форма с кнопкой и одним компонентом многострочного редактора, а на сервере есть класс вида

class August.NewClass3
{
  super = %RegisteredObject;
  method Dump
  {
    code =
    [
      w 123,!
      w 456,!
      q
    ]
  }
  method GetDate
  {
    returntype = %String;
    code =
    [
      q $zdt($h,2)
    ]
  }
}

То для демонстрации получения callback-функциональности можно использовать такой код:

  procedure TForm1.Button1Click(Sender: TObject);
  var
    CacheFactory: Variant;
    SetOutput: TSetOutput;
    Obj: Variant;
  begin
    CacheFactory := CreateOleObject('CacheObject.Factory');
    CacheFactory.Connect( CacheFactory.ConnectDlg());
    SetOutput := TSetOutput.Create( OnCacheOutput);
    CacheFactory.SetOutput( SetOutput as IDispatch);
    Obj := CacheFactory.New( 'August.NewClass3');
    Memo1.Lines.Add( Obj.GetDate);
    Obj.Dump;
    CacheFactory.SetOutput( NULL);
    SetOutput.Free;
  end;

Где используется обработчик событий составленный по обычным дельфийским соглашениям:

  procedure TForm1.OnCacheOutput(CacheString: string);
  begin
    Memo1.Text := Memo1.Text + CacheString;
  end;

В приведенной реализации компонент TSetOutput не реализует в действительности методы AddRef и Release, поскольку предназначен для работы скорее в качестве стандартного дельфийского объекта, который и создается и удаляется кодом, контролируемым программистом. Отметим, что класс допускает переназначение обработчика события на другой. Приведенный код проверялся на Cache' 5. По сообщениям других программистов, в Cache' 4 такой подход также работает.