A (Delphi) bug’s life

Chi lavora con Delphi probabilmente sa che il matrimonio tra Delphi e InterBase/Firebird è un matrimonio d’amore. Se avete avuto modo di apprezzare la flessibilità del componente TIBDataSet, che consente di definire statement separati per le operazioni di SELECT, INSERT, UPDATE e DELETE, in contrapposizione all’opacità dei componenti ADO, che celano gran parte della complessità a vantaggio della facilità d’uso ma a discapito di una maggior granularità di controllo da parte del programmatore, fiuuuu che frase, se avete avuto modo di apprezzare tutto ciò, dicevo, sapete di cosa parlo.

Ma come in tutti i matrimoni d’amore, si da il caso che i due coniugi non siano perfetti (altrimenti non sarebbe amore, ma convenienza, non trovate?).
Ed ecco che, dopo tanti anni di sviluppo con il mio linguaggio e il mio database preferito, mi accorgo pochi giorni fa di un bug che affligge la libreria InterBase fornita in stock con RAD Studio 2010, e che io non esito a definire colossale. La faccio breve: i TField associati ad un oggetto TIBDataSet non reagiscono correttamente al metodo Clear, a meno che siano del tipo TIBStringField, e come conseguenza può risultare impossibile attribuire loro il valore NULL.
Non mi credete, vero? Seguitemi.
Iniziamo con il creare un database, e al suo interno una semplice tabella:

create generator g_tabella;
create table tabella (
    id int,
    x bigint
);
commit;

Creiamo poi una semplice applicazione VCL; buttiamo sulla form un oggetto TIBDatabase, una TIBTransaction, un TIBDataSet e un bel bottone. Facciamo puntare il nostro TIBDatabase al database appena creato, colleghiamo la TIBTransaction con il database e il dataset.
Settiamo le query dell’oggetto TIBDataSet:

SelectSQL -> SELECT ID, X FROM TABELLA
InsertSQL -> INSERT INTO TABELLA (ID, X) VALUES (:ID, :X)
ModifySQL -> UPDATE TABELLA SET ID = :ID, X = :X WHERE ID = :OLD_ID
DeleteSQL -> DELETE FROM TABELLA WHERE ID = :OLD_ID
RefreshSQL -> SELECT ID, X FROM TABELLA WHERE ID = :ID

Infine settiamo il GeneratorField del dataset.
Segue il listato del file DFM, per i più pigri:

object Form2: TForm2
  Left = 0
  Top = 0
  Caption = 'Form2'
  ClientHeight = 226
  ClientWidth = 400
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object Button1: TButton
    Left = 88
    Top = 112
    Width = 209
    Height = 57
    Caption = 'Button1'
    TabOrder = 0
    OnClick = Button1Click
  end
  object IBDataSet1: TIBDataSet
    Database = IBDatabase1
    Transaction = IBTransaction1
    DeleteSQL.Strings = (
      'DELETE FROM TABELLA WHERE ID = :OLD_ID')
    InsertSQL.Strings = (
      'INSERT INTO TABELLA (ID, X) VALUES (:ID, :X)')
    RefreshSQL.Strings = (
      'SELECT ID, X FROM TABELLA WHERE ID = :ID')
    SelectSQL.Strings = (
      'SELECT ID, X FROM TABELLA')
    ModifySQL.Strings = (
      'UPDATE TABELLA SET ID = :ID, X = :X WHERE ID = :OLD_ID')
    GeneratorField.Field = 'ID'
    GeneratorField.Generator = 'G_TABELLA'
    Left = 264
    Top = 48
    object IBDataSet1ID: TIntegerField
      FieldName = 'ID'
      Origin = '"TABELLA"."ID"'
    end
    object IBDataSet1X: TLargeintField
      FieldName = 'X'
      Origin = '"TABELLA"."X"'
    end
  end
  object IBDatabase1: TIBDatabase
    Connected = True
    DatabaseName = 'D:\fbdata\TEST.FDB'
    Params.Strings = (
      'user_name=SYSDBA'
      'password=masterkey'
      'lc_ctype=UTF8')
    LoginPrompt = False
    AfterConnect = IBDatabase1AfterConnect
    BeforeDisconnect = IBDatabase1BeforeDisconnect
    Left = 96
    Top = 48
  end
  object IBTransaction1: TIBTransaction
    Active = True
    DefaultDatabase = IBDatabase1
    Params.Strings = (
      'read_committed'
      'rec_version'
      'nowait')
    Left = 184
    Top = 48
  end
end

Assegniamo un handler all’evento OnClick del bottone:

procedure TForm2.Button1Click(Sender: TObject);
begin
  IBDataSet1.Append;
  IBDataSet1X.AsLargeInt := 12345;
  IBDataSet1.Post;

  ShowMessage('X ha valore ' + IntToStr(IBDataSet1X.AsLargeInt));

  IBDataSet1.Edit;
  IBDataSet1X.Clear;
  IBDataSet1.Post;

  if IBDataSet1X.IsNull then
    ShowMessage('X ha ora valore NULL')
  else
    ShowMessage('X ha ancora valore ' + IntToStr(IBDataSet1X.AsLargeInt) + '!!!');
end;

Ecco cosa stiamo facendo nel metodo OnClick: creiamo un nuovo record, assegniamo il valore 12345 al campo X, salviamo. Quindi riapriamo il record in modifica, tentiamo di rendere NULL il campo X, salviamo. Dovremmo ottenere il messaggio “X ha ora valore NULL”, e invece ecco cosa accade:
Fin qui tutto ok...
...boom!
Per scoprire cosa sta accadendo, dobbiamo addentrarci nel labirinto di chiamate innescate dal metodo Clear. Con il debugger attivo non è difficile. È sufficiente compilare con i file DCU di debug, e saremo in grado di eseguire lo step dentro alle funzioni di libreria:
Abilitare la compilazione con i DCU di debug
Con un po’ di pazienza, ecco che arriviamo alla procedura TIBCustomDataSet.InternalSetFieldData:

procedure TIBCustomDataSet.InternalSetFieldData(Field: TField; Buffer: Pointer);
var
  Buff, TmpBuff: TRecordBuffer;
begin
  Buff := GetActiveBuf;
  if Field.FieldNo < 0 then
  begin
    TmpBuff := Buff + FRecordSize + Field.Offset;
    Boolean(TmpBuff[0]) := LongBool(Buffer);
    if Boolean(TmpBuff[0]) then
      Move(Buffer^, TmpBuff[1], Field.DataSize);
    WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
  end
  else
  begin
    CheckEditState;
    with PRecordData(Buff)^ do
    begin
      { If inserting, Adjust record position }
      AdjustRecordOnInsert(Buff);
      if (FMappedFieldPosition[Field.FieldNo - 1] > 0) and
         (FMappedFieldPosition[Field.FieldNo - 1] <= rdFieldCount) then
      begin
        Field.Validate(Buffer);
        if (Buffer = nil) or
           (Field is TIBStringField) and (PChar(Buffer)[0] = #0) then
          if TIBStringField(Field).EmptyAsNull then
            rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdIsNull := True
          else
          begin
            rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataLength := 0;
            rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdIsNull := False;
          end
        else
        begin
          Move(Buffer^, Buff[rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataOfs],
                 rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataSize);
          if (rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataType = SQL_TEXT) or
             (rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataType = SQL_VARYING) then
            rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataLength := StrLen(PChar(Buffer)) * 2;
          rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdIsNull := False;
          if rdUpdateStatus = usUnmodified then
          begin
            if CachedUpdates then
            begin
              FUpdatesPending := True;
              if State = dsInsert then
                rdCachedUpdateStatus := cusInserted
              else if State = dsEdit then
                rdCachedUpdateStatus := cusModified;
            end;

            if State = dsInsert then
              rdUpdateStatus := usInserted
            else
              rdUpdateStatus := usModified;
          end;
          WriteRecordCache(rdRecordNumber, Buff);
          SetModified(True);
        end;
      end;
    end;
  end;
  if not (State in [dsCalcFields, dsFilter, dsNewValue]) then
      DataEvent(deFieldChange, Longint(Field));
end;

L'occhio attento ha già scovato il grossolano errore. Ecco invece la spiegazione per i miopi:

        ...
        if (Buffer = nil) or
           (Field is TIBStringField) and (PChar(Buffer)[0] = #0) then
          if TIBStringField(Field).EmptyAsNull then
            rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdIsNull := True
          else
          begin
            rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataLength := 0;
            rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdIsNull := False;
          end
        else
        ...

Cosa succede se Buffer = nil (cosa che accade per esempio se si arriva qui dal metodo Clear) ma Field non è un TIBStringField? Succede che il cast statico TIBStringField(Field) non ha senso, e l'espressione TIBStringField(Field).EmptyAsNull sta restituendo chissà quale valore, visto che sta trattando come TIBStringField un oggetto che non lo è. Ecco perché all'inizio ho detto "può risultare impossibile attribuire loro il valore NULL": il comportamento di questa porzione di codice è alquanto imprevedibile.
Che fare? Abbiamo il sorgente, ma la lungimirante Embarcadero non ci ha fornito tutti i file necessari per fare un rebuild del package. E, se anche riuscissimo nell'impresa, non è detto che non finiamo con il rompere qualcos'altro, cosa molto probabile ad esempio se ci fosse qualche altro package che dipende da questo. Qualcuno ha mai provato a installare in RAD Studio 2010 un aggiornamento delle librerie Indy? Ecco, se ci avete provato sapete di cosa sto parlando.
Quality Central, dite? ROTFL. No, dobbiamo arrangiarci. Andreas Hausladen docet. Dopo lunghe e penose riflessioni wc, sono giunto ad una soluzione: creare un mio package, contenente un clone corretto del componente TIBDataSet. Mettiamoci al lavoro.
Innanzitutto, osserviamo che non ci interessa clonare l'intero componente. Ci basterebbe risalire nello stack delle chiamate partendo dalla funzione incriminata, fino a trovarne una che sia dichiarata virtual. Possiamo quindi creare una classe discendente da TIBDataSet e farne l'override, in modo da dirottare l'esecuzione sulla nostra versione di InternalSetFieldData.
Con poco sforzo, troviamo che le due funzioni da noi cercate si trovano proprio nel progenitore di tutti i dataset: TDataSet.

    procedure SetFieldData(Field: TField; Buffer: Pointer); overload; virtual;
    procedure SetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean); overload; virtual;

L'override viene fatto nella classe TIBCustomDataSet, che è la superclasse più prossima di TIBDataSet:

    procedure SetFieldData(Field : TField; Buffer : Pointer); override;
    procedure SetFieldData(Field : TField; Buffer : Pointer;
      NativeFormat : Boolean); overload; override;

Eccone l'implementazione:

procedure TIBCustomDataSet.SetFieldData(Field: TField; Buffer: Pointer);
var
  lTempCurr : System.Currency;
begin
  if (Field.DataType = ftBCD) and (Buffer <> nil) then
  begin
    BCDToCurr(TBCD(Buffer^), lTempCurr);
    InternalSetFieldData(Field, @lTempCurr);
  end
  else
    InternalSetFieldData(Field, Buffer);
end;

procedure TIBCustomDataSet.SetFieldData(Field: TField; Buffer: Pointer;
  NativeFormat: Boolean);
begin
  if (not NativeFormat) and (Field.DataType = ftBCD) then
    InternalSetfieldData(Field, Buffer)
  else
    inherited SetFieldData(Field, buffer, NativeFormat);
end;

Bingo! Ecco il grip di cui avevamo bisogno. Battezziamo il nostro nuovo componente TWrapIBDataSet, deriviamolo da TIBDataSet, dichiariamo tutte le proprietà published, dichiariamo l'override delle due funzioni e creiamo la nostra versione corretta di InternalSetFieldData:

unit IBWrapObjs;

interface

uses Classes, SysUtils, Windows, IBCustomDataSet, IBQuery, IBSQL, DB, IBDatabase,
  IBExternals, IBHeader, IBIntf, FMTBcd;

type
  TWrapIBDataSet = class(TIBDataSet)
  published
    { TIBCustomDataSet }
    property BufferChunks;
    property CachedUpdates;
    property DeleteSQL;
    property InsertSQL;
    property RefreshSQL;
    property SelectSQL;
    property ModifySQL;
    property ParamCheck;
    property UniDirectional;
    property Filtered;
    property GeneratorField;
    property BeforeDatabaseDisconnect;
    property AfterDatabaseDisconnect;
    property DatabaseFree;
    property BeforeTransactionEnd;
    property AfterTransactionEnd;
    property TransactionFree;
    property UpdateObject;

    { TIBDataSet }
    property Active;
    property AutoCalcFields;
    property DataSource;
    property AfterCancel;
    property AfterClose;
    property AfterDelete;
    property AfterEdit;
    property AfterInsert;
    property AfterOpen;
    property AfterPost;
    property AfterScroll;
    property BeforeCancel;
    property BeforeClose;
    property BeforeDelete;
    property BeforeEdit;
    property BeforeInsert;
    property BeforeOpen;
    property BeforePost;
    property BeforeScroll;
    property OnCalcFields;
    property OnDeleteError;
    property OnEditError;
    property OnFilterRecord;
    property OnNewRecord;
    property OnPostError;

  protected
    procedure SetFieldData(Field : TField; Buffer : Pointer); override;
    procedure SetFieldData(Field : TField; Buffer : Pointer;
      NativeFormat : Boolean); overload; override;

  private
    procedure InternalSetFieldData(Field: TField; Buffer: Pointer);
  end;

implementation

{ TWrapIBDataSet }

procedure TWrapIBDataSet.SetFieldData(Field: TField; Buffer: Pointer);
var
  lTempCurr : System.Currency;
begin
  if (Field.DataType = ftBCD) and (Buffer <> nil) then
  begin
    BCDToCurr(TBCD(Buffer^), lTempCurr);
    InternalSetFieldData(Field, @lTempCurr);
  end
  else
    InternalSetFieldData(Field, Buffer);
end;

procedure TWrapIBDataSet.SetFieldData(Field: TField; Buffer: Pointer;
  NativeFormat: Boolean);
begin
  if (not NativeFormat) and (Field.DataType = ftBCD) then
    InternalSetfieldData(Field, Buffer)
  else
    inherited SetFieldData(Field, buffer, NativeFormat);
end;

procedure TWrapIBDataSet.InternalSetFieldData(Field: TField; Buffer: Pointer);
var
  Buff, TmpBuff: TRecordBuffer;
  isString: Boolean;
begin
  Buff := GetActiveBuf;
  if Field.FieldNo < 0 then
  begin
    TmpBuff := Buff + FRecordSize + Field.Offset;
    Boolean(TmpBuff[0]) := LongBool(Buffer);
    if Boolean(TmpBuff[0]) then
      Move(Buffer^, TmpBuff[1], Field.DataSize);
    WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
  end
  else
  begin
    CheckEditState;
    with PRecordData(Buff)^ do
    begin
      { If inserting, Adjust record position }
      AdjustRecordOnInsert(Buff);
      if (FMappedFieldPosition[Field.FieldNo - 1] > 0) and
         (FMappedFieldPosition[Field.FieldNo - 1] <= rdFieldCount) then
      begin
        Field.Validate(Buffer);
        {
        //ecco la porzione di codice by Embarcadero...
        //se Buffer = nil ma Field NON è un TIBStringField,
        //allora TIBStringField(Field).EmptyAsNull chissà
        //a cosa diavolo sta puntando...
        if (Buffer = nil) or
           (Field is TIBStringField) and (PChar(Buffer)[0] = #0) then
          if TIBStringField(Field).EmptyAsNull then
            rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdIsNull := True
          else
          begin
            rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataLength := 0;
            rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdIsNull := False;
          end
        else
        }
        isString := Field is TIBStringField;
        if (Buffer = nil) or
           isString and (PChar(Buffer)[0] = #0) then
          if not isString or TIBStringField(Field).EmptyAsNull then
            rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdIsNull := True
          else
          begin
            rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataLength := 0;
            rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdIsNull := False;
          end
        else
        begin
          Move(Buffer^, Buff[rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataOfs],
                 rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataSize);
          if (rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataType = SQL_TEXT) or
             (rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataType = SQL_VARYING) then
            rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataLength := StrLen(PChar(Buffer)) * 2;
          rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdIsNull := False;
          if rdUpdateStatus = usUnmodified then
          begin
            if CachedUpdates then
            begin
              FUpdatesPending := True;
              if State = dsInsert then
                rdCachedUpdateStatus := cusInserted
              else if State = dsEdit then
                rdCachedUpdateStatus := cusModified;
            end;

            if State = dsInsert then
              rdUpdateStatus := usInserted
            else
              rdUpdateStatus := usModified;
          end;
          WriteRecordCache(rdRecordNumber, Buff);
          SetModified(True);
        end;
      end;
    end;
  end;
  if not (State in [dsCalcFields, dsFilter, dsNewValue]) then
      DataEvent(deFieldChange, Longint(Field));
end;

end.

Creiamo un package di runtime:

package IBWrapper;

{$R *.res}
{$ALIGN 8}
{$ASSERTIONS ON}
{$BOOLEVAL OFF}
{$DEBUGINFO ON}
{$EXTENDEDSYNTAX ON}
{$IMPORTEDDATA ON}
{$IOCHECKS ON}
{$LOCALSYMBOLS ON}
{$LONGSTRINGS ON}
{$OPENSTRINGS ON}
{$OPTIMIZATION ON}
{$OVERFLOWCHECKS OFF}
{$RANGECHECKS OFF}
{$REFERENCEINFO ON}
{$SAFEDIVIDE OFF}
{$STACKFRAMES OFF}
{$TYPEDADDRESS OFF}
{$VARSTRINGCHECKS ON}
{$WRITEABLECONST OFF}
{$MINENUMSIZE 1}
{$IMAGEBASE $400000}
{$DESCRIPTION 'Interbase Objects Wrappers Runtime Package'}
{$RUNONLY}
{$IMPLICITBUILD ON}

requires
  ibxpress,
  rtl;

contains
  IBWrapObjs in 'IBWrapObjs.pas';

end.

Poi creiamo il design time package:

package dclIBWrapper;

{$R *.res}
{$ALIGN 8}
{$ASSERTIONS ON}
{$BOOLEVAL OFF}
{$DEBUGINFO ON}
{$EXTENDEDSYNTAX ON}
{$IMPORTEDDATA ON}
{$IOCHECKS ON}
{$LOCALSYMBOLS ON}
{$LONGSTRINGS ON}
{$OPENSTRINGS ON}
{$OPTIMIZATION ON}
{$OVERFLOWCHECKS OFF}
{$RANGECHECKS OFF}
{$REFERENCEINFO ON}
{$SAFEDIVIDE OFF}
{$STACKFRAMES OFF}
{$TYPEDADDRESS OFF}
{$VARSTRINGCHECKS ON}
{$WRITEABLECONST OFF}
{$MINENUMSIZE 1}
{$IMAGEBASE $400000}
{$DESCRIPTION 'Interbase Objects Wrappers Designtime Package'}
{$DESIGNONLY}
{$IMPLICITBUILD ON}

requires
  IBWrapper,
  designide,
  rtl,
  dclib;

contains
  IBWrapReg in 'IBWrapReg.pas';

end.
unit IBWrapReg;

interface

uses IBWrapObjs, Classes, DesignIntf, DesignEditors, StrEdit, DBReg,
  SysUtils, IBUpdateSQLEditor, IBWrapEdit, Controls, Forms, IBXConst;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Interbase (Wrapper)', [TWrapIBDataSet]);
end;

end.

Non ci resta che compilare e installare il package. Giusto? Sbagliato, ovviamente. Il compilatore da 57 errori, o giù di lì. Perché? Be', abbiamo fatto i conti senza l'oste: noi non abbiamo accesso ai campi e ai metodi privati di TIBCustomDataSet che ci servirebbero nella nostra versione customizzata di InternalSetFieldData. FRecordSize, FMappedFieldPosition, eccetera per noi sono inaccessibili.
Inaccessibili?!? Questa parola non esiste. Noi non ci arrendiamo. Chi si arrende è un pappamolla, un formaggino, una vongola senza guscio!
Dunque, sappiamo che per Delphi (a differenza del C++) la parola chiave private ha effetto solo al di fuori della unit in cui è utilizzata. Dentro la medesima unit, nulla è privato. Possiamo anche sapere qual è la posizione relativa dei campi che ci interessano in relazione al puntatore Self; lo sappiamo perché abbiamo il sorgente di TIBCustomDataSet.
Possiamo quindi creare una nostra classe locale, che abbia il medesimo layout in memoria di TIBCustomDataSet, e accedere ai campi privati attraverso di essa.
Ecco come:

{ creiamo una nostra classe TIBCustomDataSetHack che è identica a TIBCustomDataSet. }
type
  {$HINTS OFF}
  TIBCustomDataSetHack = class(TWideDataSet)
  private
    FNeedsRefresh: Boolean;
    FForcedRefresh: Boolean;
    FIBLoaded: Boolean;
    FBase: TIBBase;
    FBlobCacheOffset: Integer;
    FBlobStreamList: TList;
    FBufferChunks: Integer;
    FBufferCache,
    FOldBufferCache: TRecordBuffer;
    FBufferChunkSize,
    FCacheSize,
    FOldCacheSize: Integer;
    FFilterBuffer: TRecordBuffer;
    FBPos,
    FOBPos,
    FBEnd,
    FOBEnd: DWord;
    FCachedUpdates: Boolean;
    FCalcFieldsOffset: Integer;
    FCurrentRecord: Long;
    FDeletedRecords: Long;
    FModelBuffer,
    FOldBuffer, FTempBuffer: TRecordBuffer;
    FOpen: Boolean;
    FInternalPrepared: Boolean;
    FQDelete,
    FQInsert,
    FQRefresh,
    FQSelect,
    FQModify: TIBSQL;
    FRecordBufferSize: Integer;
    FRecordCount: Integer;
    FRecordSize: Integer;
    FUniDirectional: Boolean;
    FUpdateMode: TUpdateMode;
    FUpdateObject: TIBDataSetUpdateObject;
    FParamCheck: Boolean;
    FUpdatesPending: Boolean;
    FUpdateRecordTypes: TIBUpdateRecordTypes;
    FMappedFieldPosition: array of Integer;
    FDataLink: TIBDataLink;
    FStreamedActive : Boolean;
    FLiveMode: TLiveModes;
    FGeneratorField: TIBGeneratorField;
    FRowsAffected: Integer;

    FBeforeDatabaseDisconnect,
    FAfterDatabaseDisconnect,
    FDatabaseFree: TNotifyEvent;
    FOnUpdateError: TIBUpdateErrorEvent;
    FOnUpdateRecord: TIBUpdateRecordEvent;
    FBeforeTransactionEnd,
    FAfterTransactionEnd,
    FTransactionFree: TNotifyEvent;
    FGDSLibrary : IGDSLibrary;
  end;
  {$HINTS ON}

Notare l'uso della direttiva {$HINTS OFF} per mettere a tacere gli warning del compilatore in questa porzione di codice.
Ci resta da fare solo una cosa: trovare il modo di accedere ai metodi privati, ovvero TIBCustomDataSet.CheckEditState, TIBCustomDataSet.AdjustRecordOnInsert e TIBCustomDataSet.WriteRecordCache.
In questo difficile compito ci vengono in aiuto i class helper. I class helper sono dei costrutti che ci consentono di estendere una classe esistente, aggiungendo metodi e campi a piacimento. Possiamo quindi definire un class helper per TIBCustomDataSet, che ci consenta di scovare l'indirizzo delle funzioni di nostro interesse. Poi, con un po' di assembler, inseriremo le chiamate nella nostra funzione patchata. Ecco come:

unit IBWrapObjs;

interface

...

type
  TIBCustomDataSetHelper = class helper for TIBCustomDataSet
    function GetWriteRecordCacheAddress: Pointer;
    function GetCheckEditStateAddress: Pointer;
    function GetAdjustRecordOnInsertAddress: Pointer;
  end;

implementation

...

type
  TWriteRecordCache = procedure(RecordNumber: Integer; Buffer: TRecordBuffer) of object;
  TCheckEditState = procedure of object;
  TAdjustRecordOnInsert = procedure(Buffer: Pointer) of object;

var
  fnWriteRecordCache: Pointer;
  fnCheckEditState: Pointer;
  fnAdjustRecordOnInsert: Pointer;

function TIBCustomDataSetHelper.GetAdjustRecordOnInsertAddress: Pointer;
var
  MethodPtr: TAdjustRecordOnInsert;
begin
  MethodPtr := Self.AdjustRecordOnInsert;
  Result := TMethod(MethodPtr).Code;
end;

function TIBCustomDataSetHelper.GetCheckEditStateAddress: Pointer;
var
  MethodPtr: TCheckEditState;
begin
  MethodPtr := Self.CheckEditState;
  Result := TMethod(MethodPtr).Code;
end;

function TIBCustomDataSetHelper.GetWriteRecordCacheAddress: Pointer;
var
  MethodPtr: TWriteRecordCache;
begin
  MethodPtr := Self.WriteRecordCache;
  Result := TMethod(MethodPtr).Code;
end;

initialization
  fnWriteRecordCache := TIBCustomDataSet(nil).GetWriteRecordCacheAddress;
  fnCheckEditState := TIBCustomDataSet(nil).GetCheckEditStateAddress;
  fnAdjustRecordOnInsert := TIBCustomDataSet(nil).GetAdjustRecordOnInsertAddress;

end.

Bene, non ci resta che definire tre funzioni private: CheckEditState, AdjustRecordOnInsert, WriteRecordCache. Esse chiameranno, usando un po' di assembler, le vere funzioni implementate in TIBCustomDataSet:

type
  TWrapIBDataSet = class(TIBDataSet)

  ...

  private
    procedure AdjustRecordOnInsert(Buffer: Pointer);
    procedure CheckEditState;
    procedure WriteRecordCache(RecordNumber: Integer; Buffer: TRecordBuffer);
  end;

Ecco l'implementazione:

procedure TWrapIBDataSet.AdjustRecordOnInsert(Buffer: Pointer);
asm
  push  EAX
  push  EDX
  mov   EAX, Self
  mov   EDX, Buffer
  call  fnAdjustRecordOnInsert
  pop   EDX
  pop   EAX
end;

procedure TWrapIBDataSet.CheckEditState;
asm
  push  EAX
  mov   EAX, Self
  call  fnCheckEditState
  pop   EAX
end;

procedure TWrapIBDataSet.WriteRecordCache(RecordNumber: Integer;
  Buffer: TRecordBuffer);
asm
  push  EAX
  push  EDX
  push  ECX
  mov   EAX, Self
  mov   EDX, RecordNumber
  mov   ECX, Buffer
  call  fnWriteRecordCache
  pop   ECX
  pop   EDX
  pop   EAX
end;

Ora modifichiamo InternalSetFieldData come segue:

procedure TWrapIBDataSet.InternalSetFieldData(Field: TField; Buffer: Pointer);
var
  Buff, TmpBuff: TRecordBuffer;
  hack: TIBCustomDataSetHack;
  isString: Boolean;
begin
  hack := TIBCustomDataSetHack(Self);

  Buff := GetActiveBuf;
  if Field.FieldNo < 0 then
  begin
    TmpBuff := Buff + hack.FRecordSize + Field.Offset;
    Boolean(TmpBuff[0]) := LongBool(Buffer);
    if Boolean(TmpBuff[0]) then
      Move(Buffer^, TmpBuff[1], Field.DataSize);
    WriteRecordCache(PRecordData(Buff)^.rdRecordNumber, Buff);
  end
  else
  begin
    CheckEditState;
    with PRecordData(Buff)^ do
    begin
      { If inserting, Adjust record position }
      AdjustRecordOnInsert(Buff);
      if (hack.FMappedFieldPosition[Field.FieldNo - 1] > 0) and
         (hack.FMappedFieldPosition[Field.FieldNo - 1] <= rdFieldCount) then
      begin
        Field.Validate(Buffer);
        {
        //ecco la porzione di codice by Embarcadero...
        //se Buffer = nil ma Field NON è un TIBStringField,
        //allora TIBStringField(Field).EmptyAsNull chissà
        //a cosa diavolo sta puntando...
        if (Buffer = nil) or
           (Field is TIBStringField) and (PChar(Buffer)[0] = #0) then
          if TIBStringField(Field).EmptyAsNull then
            rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdIsNull := True
          else
          begin
            rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdDataLength := 0;
            rdFields[FMappedFieldPosition[Field.FieldNo - 1]].fdIsNull := False;
          end
        else
        }
        isString := Field is TIBStringField;
        if (Buffer = nil) or
           isString and (PChar(Buffer)[0] = #0) then
          //trattiamo in modo speciale solo i TIBStringField
          if not isString or TIBStringField(Field).EmptyAsNull then
            rdFields[hack.FMappedFieldPosition[Field.FieldNo - 1]].fdIsNull := True
          else
          begin
            rdFields[hack.FMappedFieldPosition[Field.FieldNo - 1]].fdDataLength := 0;
            rdFields[hack.FMappedFieldPosition[Field.FieldNo - 1]].fdIsNull := False;
          end
        else
        begin
          Move(Buffer^, Buff[rdFields[hack.FMappedFieldPosition[Field.FieldNo - 1]].fdDataOfs],
                 rdFields[hack.FMappedFieldPosition[Field.FieldNo - 1]].fdDataSize);
          if (rdFields[hack.FMappedFieldPosition[Field.FieldNo - 1]].fdDataType = SQL_TEXT) or
             (rdFields[hack.FMappedFieldPosition[Field.FieldNo - 1]].fdDataType = SQL_VARYING) then
            rdFields[hack.FMappedFieldPosition[Field.FieldNo - 1]].fdDataLength := StrLen(PChar(Buffer)) * 2;
          rdFields[hack.FMappedFieldPosition[Field.FieldNo - 1]].fdIsNull := False;
          if rdUpdateStatus = usUnmodified then
          begin
            if CachedUpdates then
            begin
              hack.FUpdatesPending := True;
              if State = dsInsert then
                rdCachedUpdateStatus := cusInserted
              else if State = dsEdit then
                rdCachedUpdateStatus := cusModified;
            end;

            if State = dsInsert then
              rdUpdateStatus := usInserted
            else
              rdUpdateStatus := usModified;
          end;
          WriteRecordCache(rdRecordNumber, Buff);
          SetModified(True);
        end;
      end;
    end;
  end;
  if not (State in [dsCalcFields, dsFilter, dsNewValue]) then
      DataEvent(deFieldChange, Longint(Field));
end;

Visto cosa abbiamo fatto? Abbiamo preso un riferimento a noi stessi (Self) e abbiamo detto al compilatore di trattarlo come se fosse un TIBCustomDataSetHack. A questo punto possiamo accedere a tutti i campi che desideriamo attraverso il puntatore a hack; le locazioni di memoria che raggiungiamo sono quelle corrette (quelle relative ai campi di TIBCustomDataSet, non di TIBCustomDataSetHack), perché un TIBCustomDataSet ha una forma identica a quella di un TIBCustomDataSetHack, ma noi stiamo lavorando su un oggetto che è, in effetti, un TIBCustomDataSet!
Inoltre, grazie all'helper, abbiamo recuperato l'indirizzo delle funzioni che ci servivano, e le abbiamo chiamate "abusivamente" usando un po' di assembler.
Bene, compiliamo il runtime package e installiamo il design time package nell'IDE.
Ora riprendiamo il nostro progetto di test, e sostituiamo il TIBDataSet con un TWrapIBDataSet. Possiamo usare un editor di testo sul file .pas e sul file .dfm, per una sostituzione veloce.
Nel file dfm:

...
  object IBDataSet1: TWrapIBDataSet
...

Nel file pas:

...
type
  TForm2 = class(TForm)
    IBDataSet1: TWrapIBDataSet;
...

Compiliamo il test, eseguiamo:
Come prima...
...più di prima, ti amerò!
Vittoria! Abbiamo dovuto adottare un paio di trucchi piuttosto sporchi, ma come si dice: in guerra e in amore tutto è lecito!
Buona programmazione a tutti.

Lascia un commento

Il tuo indirizzo email non sarà pubblicato. I campi obbligatori sono contrassegnati *

*