Locate and LocateEx bug

[abadia]

The new binary search feature is great, but I found a little problem.
The process fails When we search with more than one field and the index used is partially compatible and the record to be found is the current or the first one.

I've seen that the search procedure is made in two blocks:

• The first block executes the whole search if the search is fully compatible with the index;
• If there is no index or the index is fully incompatible, the second block executes the whole search;
• However, when the index is partially compatible, the first block executes it until it's possible, leaving the rest to the second block;

The problem is that the second block always expects the dataset to be in BOF (Data.Bof) (that is before the first item on that object implementation) and executes the NEXT method, that in this case, will set the cursor to the first record. But when the search was partially done by the first block (partially compatible index), the second block will the set the cursor to the next record, leading the process to fail, if the record that corresponds to the search is the same record that the first block left.

There is a fix to this problem attached to copy of this message sent by e-mail. This fix removes the need of finding the dataset in BOF for the second block.
This fix also solves the incoherence between the Locate and LocateEx methods. The LocateEx method with the lxNext parameter starts the search from the actual record, as documented.

Source code to test:

Code: Select all

program LocateBug;

uses
  Forms, StdCtrls, DB, MemDS, VirtualTable, DBGrids, Variants;

var
  Frm: TForm;
  Lbl: TCustomLabel;
  DBGrd: TDBGrid;
  DtSrc: TDataSource;
  VrtTbl: TVirtualTable;
  Btn: TButton;

type
  TLabelHelper = class helper for TCustomLabel
    procedure AddLog(S: string);
  end;

procedure TLabelHelper.AddLog(S: string);
begin
  if Caption = '' then
    Self.Caption := S
  else
    Self.Caption := Self.Caption + #13#10 + S;
end;

type
  TTeste = class helper for TForm
    procedure Test(Sernder: TObject);
  end;

procedure TTeste.Test(Sernder: TObject);
var
  V: Variant;

  procedure DoTest(const Description, IndexFields: string);
  begin
    Lbl.AddLog(Description);
    VrtTbl.IndexFieldNames := IndexFields;
    if VrtTbl.Locate('Codigo;Nome', V, []) then
      Lbl.AddLog('Ok')
    else
      Lbl.AddLog('Fail');
  end;

begin
  V := VarArrayOf([1, 'Abadia']);
  Lbl.Caption := 'Abadia';
  DoTest('*** Without index', '');
  DoTest('*** With patial index', 'Codigo');
  DoTest('*** With full compatible index', 'Codigo;Nome');
  DoTest('*** With full incompatible index', 'Funcao');

  V := VarArrayOf([2, 'Gustavo']);
  Lbl.AddLog('Gustavo');
  DoTest('*** Without index', '');
  DoTest('*** With patial index', 'Codigo');
  DoTest('*** With full compatible index', 'Codigo;Nome');
  DoTest('*** With full incompatible index', 'Funcao');
end;

begin
  Application.Initialize;
  Application.CreateForm(TForm, Frm);
  Frm.Caption := 'Locate and LocateEx Bug';
  Frm.ClientHeight := 430;
  Frm.ClientWidth := 426;

  VrtTbl := TVirtualTable.Create(Frm);
  VrtTbl.FieldDefs.Add('Codigo', ftInteger);
  VrtTbl.FieldDefs.Add('Nome', ftString, 50);
  VrtTbl.FieldDefs.Add('Funcao', ftString, 50);
  VrtTbl.Active := True;
  VrtTbl.AppendRecord([1, 'Abadia', 'Delphi Programmer']);
  VrtTbl.AppendRecord([2, 'Gustavo', 'External Support']);
  VrtTbl.AppendRecord([3, 'Matheus', 'Java Programmer']);
  VrtTbl.AppendRecord([4, 'Roberto', 'Internal Support']);

  DtSrc := TDataSource.Create(Frm);
  DtSrc.DataSet := VrtTbl;

  Lbl := TLabel.Create(Frm);
  Lbl.Parent := Frm;
  Lbl.Left := 96;
  Lbl.Top := 147;
  Lbl.Width := 313;
  Lbl.Height := 270;
  TLabel(Lbl).AutoSize := False;

  DBGrd := TDBGrid.Create(Frm);
  DBGrd.Parent := Frm;
  DBGrd.Left := 8;
  DBGrd.Top := 16;
  DBGrd.Width := 401;
  DBGrd.Height := 120;
  DBGrd.Anchors := [akLeft, akTop, akRight];
  DBGrd.DataSource := DtSrc;

  Btn := TButton.Create(Frm);
  Btn.Parent := Frm;
  Btn.Left := 8;
  Btn.Top := 142;
  Btn.Width := 75;
  Btn.Height := 25;
  Btn.Caption := 'Test';
  Btn.OnClick := Frm.Test;

  Application.Run;
end.

[Antaeus]

Thank you for such detailed information. We have reproduced this problem fixed and fixed it. This fix will be included in the next SDAC build. Please watch for announcements at the forum.

[abadia]

Could you notify me when the next build with this fix will be released?

We have lots of failures caused by this bug and we don't even know when our problems will be fixed with the next build.

Yours sincerely.

[Antaeus]

The next SDAC build will be released in few days. Please watch for announcements at the forum.

[PaulT2]

Following on from abadia's post, I may well be seeing the same problem.

I am using build 4.35.1.15 18-feb-08 of SDAC and am having issues with LocateEx, specifically when a fully compatible set of index fields are in place when using the LocateEx on a virtual table.

I've quickly modified abadia's program below to show my issue. Can you confirm if this is a genuine problem, or am I making incorrect assumptions about how to use LocateEx with IndexFieldNames ? I have been assuming that the 18-feb build contained a fix to abadia's issue ?

Regards,
Paul.

program LocateBug;

uses
Forms, StdCtrls, DB, MemDS, VirtualTable, DBGrids, Variants,Controls,MemData,SysUtils;

var
Frm: TForm;
Lbl: TCustomLabel;
DBGrd: TDBGrid;
DtSrc: TDataSource;
VrtTbl: TVirtualTable;
Btn: TButton;

type
TLabelHelper = class helper for TCustomLabel
procedure AddLog(S: string);
end;

procedure TLabelHelper.AddLog(S: string);
begin
if Caption = '' then
Self.Caption := S
else
Self.Caption := Self.Caption + #13#10 + S;
end;

type
TTeste = class helper for TForm
procedure Test(Sernder: TObject);
end;

procedure TTeste.Test(Sernder: TObject);
var
V: Variant;

procedure DoTest(const Description, IndexFields: string);
var iCounter : integer;
Found : boolean;
begin
VrtTbl.IndexFieldNames := IndexFields;
VrtTbl.First;
Found := VrtTbl.LocateEx('Model;NodeType;GID;IssueId', V, []);
iCounter := 0;
while Found do
begin
inc(iCounter);
case iCounter = 5 of
true : break
end;
Found := VrtTbl.LocateEx('Model;NodeType;GID;IssueId', V, [lxNext]);
end;
Lbl.AddLog(Description + ' : ' + IntToStr(iCounter));
end;

begin
VrtTbl.Clear;
VrtTbl.AppendRecord([0,0,1,1,1]);

// Should return 1 for each
V := VarArrayOf([0,0,1,1]);
DoTest('*** Without index', '');
DoTest('*** With patial index', 'Model');
DoTest('*** With full compatible index', 'Model;NodeType;GID;IssueId'); // This is the problem one
DoTest('*** With full incompatible index', 'IssueId');

VrtTbl.Clear;
VrtTbl.AppendRecord([0,0,1,1,1]);
VrtTbl.AppendRecord([0,0,1,1,2]);
VrtTbl.AppendRecord([0,0,1,2,1]);
VrtTbl.AppendRecord([0,0,1,3,2]);
VrtTbl.AppendRecord([0,0,1,4,3]);

// Should return 2 for each
V := VarArrayOf([0,0,1,1]);
DoTest('*** Without index', '');
DoTest('*** With patial index', 'Model');
DoTest('*** With full compatible index', 'Model;NodeType;GID;IssueId');
DoTest('*** With full incompatible index', 'IssueId');

VrtTbl.Clear;
VrtTbl.AppendRecord([0,0,1,1,1]);
VrtTbl.AppendRecord([0,0,1,1,2]);
VrtTbl.AppendRecord([0,0,1,2,1]);
VrtTbl.AppendRecord([0,0,1,1,3]);
VrtTbl.AppendRecord([0,0,1,1,4]);

// Should return 4 for each
V := VarArrayOf([0,0,1,1]);
DoTest('*** Without index', '');
DoTest('*** With patial index', 'Model');
DoTest('*** With full compatible index', 'Model;NodeType;GID;IssueId');
DoTest('*** With full incompatible index', 'IssueId');
end;

begin
Application.Initialize;
Application.CreateForm(TForm, Frm);
Frm.Caption := 'Locate and LocateEx Bug';
Frm.ClientHeight := 430;
Frm.ClientWidth := 426;

VrtTbl := TVirtualTable.Create(Frm);
VrtTbl.FieldDefs.Add('Model', ftInteger);
VrtTbl.FieldDefs.Add('NodeType', ftInteger);
VrtTbl.FieldDefs.Add('GID', ftInteger);
VrtTbl.FieldDefs.Add('IssueId', ftInteger);
VrtTbl.FieldDefs.Add('CategoryColourId', ftInteger);
VrtTbl.Active := True;

DtSrc := TDataSource.Create(Frm);
DtSrc.DataSet := VrtTbl;

Lbl := TLabel.Create(Frm);
Lbl.Parent := Frm;
Lbl.Left := 96;
Lbl.Top := 147;
Lbl.Width := 313;
Lbl.Height := 270;
TLabel(Lbl).AutoSize := False;

DBGrd := TDBGrid.Create(Frm);
DBGrd.Parent := Frm;
DBGrd.Left := 8;
DBGrd.Top := 16;
DBGrd.Width := 401;
DBGrd.Height := 120;
DBGrd.Anchors := [akLeft, akTop, akRight];
DBGrd.DataSource := DtSrc;

Btn := TButton.Create(Frm);
Btn.Parent := Frm;
Btn.Left := 8;
Btn.Top := 142;
Btn.Width := 75;
Btn.Height := 25;
Btn.Caption := 'Test';
Btn.OnClick := Frm.Test;

Application.Run;
end.

[Plash]

We have fixed this problem. The fix will be included in the next build of SDAC.