[F.o.x.]

У меня такая ситуация: понадобилось часть методов моего класса Tdm (наследника TDataModule) объявить в интерфейсах. И тут вдруг выясняется, что реализация IInterface у этого класса почему-то не работает или работает не до конца. Подсчет ссылок на объект не ведется.

Пришлось написать собственную реализацию IInterfece и после этого все наконец-то заработало!

Возникает вопрос: это такой баг или так и задумано?

Вот неполный текст модуля на всякий случай:

Код:

{=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\
|  ARZU - АИС "Расчет оплаты за аренду земельных участков"                     |                                                      |
|                                                                              |
|  Модуль: Logic.Connect                                                       |
|  Автор: GreyFox84 (greyfox84@list.ru)                                        |
|  Copyright: GreyFox84                                                        |
|  Дата: 02.05.2018                                                            |
|                                                                              |
|  Описание:                                                                   |
|     Модуль подключения к базе данных.                                        |
|     Класс Tdm реализует интерфейсы IDataBase и IAdminTools, создается        |
|     в единственном экземпляре и (неявно) служит фабрикой создания            |
|     сущностей - наследников TSelect.                                         |
|                                                                              |
\=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-}

unit ARZU.Logic.Connect;

interface

uses
  SysUtils, Classes, IBDatabase, DB, IBQuery, IBSQL,
  IBServices, IBCustomDataSet, Variants, DBInterfaces;

type

  TSelect = class(TIBQuery)
  protected
    fSearchFieldName: string;
    fSearchValue: Variant;
    function GetField(FieldName: string): TField;
  private
    fOnSelect: TNotifyEvent;
    procedure SelectAfterOpen(DataSet:TDataSet);
  public
    procedure ExecuteSQL(aSQL: string);
    function FindFirst(FieldName: string; Value: string): boolean;
    function FindNext: boolean;
    procedure FindReset;
    procedure RefreshRows;

    constructor Create; reintroduce; overload;

    property OnSelect:TNotifyEvent read fOnSelect write fOnSelect;
    property Field[FieldName: string]: TField read GetField;
  end;

  Tdm = class(TDataModule,IDataBase,IAdminTools)
    IBDB: TIBDatabase;
    RTransact: TIBTransaction;
    WTransact: TIBTransaction;
    myDML: TIBSQL;
    IBBackup: TIBBackupService;
    IBRestore: TIBRestoreService;
    QMetaData: TIBQuery;
    procedure DataModuleCreate(Sender: TObject);
  private
    { Private declarations }
    fRefCount: integer;
  public
    { Public declarations }
// IDataBase
    function GetGeneratorVal(GenName:string; Increment:integer):Int64;
    function GetMaxVal(TableName,FieldName:string):Int64;
    function ExecuteDML(aDML:string; aCommitTran: boolean):boolean;
    function ParamByName(ParamName:string): TIBXSQLVAR;
    function dbConnect(dbFileName,Usr,Pass:string):boolean;
    procedure dbDisconnect;
    function dbConnected: boolean;
// IAdminTools
    procedure dbBackup(FeedBack:TObject; bkpFileName:string);
    procedure dbRestore(FeedBack:TObject; bkpFileName:string);
// IInterface Переопределения, т.к. TDataModule
// является наследником TControl, а следовательно его
// реализация IInterface почему-то работает не до конца.
    function QueryInterface(const IID: TGUID; out Obj): HResult; override; stdcall;
    function _AddRef: Integer; overload; stdcall;
    function _Release: Integer; overload; stdcall;
  end;

function IDataModuleCreate(IID:TGUID; out Obj):HResult; stdcall;

var
  FloatFormatForSQL: TFormatSettings;

implementation

uses
  StrUtils, StdCtrls, Controls, UITypes, Dialogs, Windows, Forms,
  CustomizeDatasets;

var
  dm: Tdm;
  DmCreated: boolean = false;

{$R *.dfm}

{TSelect}

// ... Реализация методов TSelect

{Tdm}

function Tdm.dbConnect(dbFileName,Usr,Pass:string):boolean;
begin
  with dm.IBDB do begin
    DataBaseName:=dbFileName;
    Params.Clear;
    Params.Add('lc_ctype=WIN1251');
    Params.Add('user_name='+Usr);
    Params.Add('password='+Pass);
    LoginPrompt:=false;
  end;
  try
    dm.IBDB.Open;
  except
    on E:EDatabaseError do begin
      MessageDlg('Ошибка подключения к базе данных: '+E.Message,mtError,[mbOK],0);
      Result:=false;
      Exit;
    end;
  end;
  Result:=dm.IBDB.Connected;
end;

procedure Tdm.dbDisconnect;
begin
  if dm.WTransact.InTransaction then dm.WTransact.Rollback;
  if dm.RTransact.InTransaction then dm.RTransact.Commit;
  dm.IBDB.CloseDataSets;
  dm.IBDB.Close;
end;

function Tdm.ExecuteDML(aDML:string; aCommitTran:boolean):boolean;
begin
  dm.myDML.SQL.Text:=aDML;
  Result:=false;
  try
    if not dm.WTransact.InTransaction then  dm.WTransact.StartTransaction;
    dm.myDML.ExecQuery;
  except
    on E:Exception do begin
      dm.WTransact.Rollback;
      MessageDlg('Ошибка выполнения запроса:'+#10#13#10#13+aDML+#10#13#10#13+E.Message,mtError,[mbOK],0);
      Exit;
    end;
  end;
  if aCommitTran then dm.WTransact.Commit;
  Result:=true;
end;

procedure Tdm.DataModuleCreate(Sender: TObject);
begin
  fRefCount:=0;
  FloatFormatForSQL:=TFormatSettings.Create;
  FloatFormatForSQL.DecimalSeparator:='.';
end;

function Tdm.QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
begin
  if GetInterface(IID,Obj) then Result:=0
  else Result:=E_NOINTERFACE;
end;

function Tdm._AddRef:Integer; stdcall;
begin
  Inc(fRefCount);
  //MessageDlg('Cсылок на dm: '+IntToStr(fRefCount),mtInformation,[mbOk],0);
  Result:=fRefCount;
end;

function Tdm._Release: Integer; stdcall;
begin
  Dec(fRefCount);
  //MessageDlg('Cсылок на dm: '+IntToStr(fRefCount),mtInformation,[mbOk],0);
  Result:=fRefCount;
  if Result=0 then begin
    IBDB.Close;
    inherited Destroy;
  end;
end;

function Tdm.dbConnected: boolean;
begin
  dbConnected:=IBDB.Connected;
end;

// ... Реализация  остальных методов Tdm

function IDataModuleCreate(IID:TGUID; out Obj):HResult; stdcall;
begin
  if not DmCreated then begin
    dm:=Tdm.Create(nil);
    DmCreated:=true;
  end;
  Result:=dm.QueryInterface(IID,Obj);
end;

end.