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:
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:
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 
, 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:
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.