journaling/ibcontrols/IBLookupComboEditBox.pas

(*
 *  IBX For Lazarus (Firebird Express)
 *
 *  The contents of this file are subject to the Initial Developer's
 *  Public License Version 1.0 (the "License"); you may not use this
 *  file except in compliance with the License. You may obtain a copy
 *  of the License here:
 *
 *    http://www.firebirdsql.org/index.php?op=doc&id=idpl
 *
 *  Software distributed under the License is distributed on an "AS
 *  IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
 *  implied. See the License for the specific language governing rights
 *  and limitations under the License.
 *
 *  The Initial Developer of the Original Code is Tony Whyman.
 *
 *  The Original Code is (C) 2015 Tony Whyman, MWA Software
 *  (http://www.mwasoftware.co.uk).
 *
 *  All Rights Reserved.
 *
 *  Contributor(s): ______________________________________.
 *
*)
unit IBLookupComboEditBox;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, DbCtrls,
  ExtCtrls, IBSQLParser, DB, StdCtrls, IBCustomDataSet, LCLVersion;

type

  {TIBLookupComboEditBox is a TDBLookupComboBox descendent that implements "autocomplete"
   of typed in text and "autoinsert" of new entries. Autocomplete uses SQL manipulation
   to revise the available list and restrict it to items that are prefixed by the
   typed text (either case sensitive or case insenstive). Autoinsert allows a
   newly typed entry to be added to the list dataset and included in the available
   list items.    }

  TAutoInsert = procedure(Sender: TObject; aText: string; var NewKeyValue: variant) of object;
  TCanAutoInsert = procedure (Sender: TObject; aText: string; var Accept: boolean) of object;

  TIBLookupComboEditBox = class;

  { TIBLookupComboDataLink }

  TIBLookupComboDataLink = class(TDataLink)
  private
    FOwner: TIBLookupComboEditBox;
  protected
    procedure ActiveChanged; override;
    procedure RecordChanged(Field: TField); override;
    procedure UpdateData; override;
  public
    constructor Create(AOwner: TIBLookupComboEditBox);
  end;

  { TIBLookupControlLink }

  TIBLookupControlLink = class(TIBControlLink)
  private
    FOwner: TIBLookupComboEditBox;
  protected
    procedure UpdateSQL(Sender: TObject); override;
  public
    constructor Create(AOwner: TIBLookupComboEditBox);
  end;


  { TIBLookupComboEditBox }

  TIBLookupComboEditBox = class(TDBLookupComboBox)
  private
    FCanAutoInsert: TCanAutoInsert;
    { Private declarations }
    FDataLink: TIBLookupComboDataLink;
    FIBLookupControlLink: TIBLookupControlLink;
    FAutoComplete: boolean;
    FAutoInsert: boolean;
    FKeyPressInterval: integer;
    FOnCanAutoInsert: TCanAutoInsert;
    FRelationName: string;
    FTimer: TTimer;
    FFiltered: boolean;
    FOnAutoInsert: TAutoInsert;
    FOriginalTextValue: string;
    FUpdating: boolean;
    FInserting: boolean;
    FExiting: boolean;
    FForceAutoComplete: boolean;
    FInCheckAndInsert: boolean;
    FLastKeyValue: variant;
    FCurText: string;
    procedure DoActiveChanged(Data: PtrInt);
    function GetAutoCompleteText: TComboBoxAutoCompleteText;
    function GetListSource: TDataSource;
    function GetRelationNameQualifier: string;
    procedure HandleTimer(Sender: TObject);
    procedure IBControlLinkChanged;
    procedure ResetParser;
    procedure RecordChanged(Sender: TObject; aField: TField);
    procedure SetAutoCompleteText(AValue: TComboBoxAutoCompleteText);
    procedure SetListSource(AValue: TDataSource);
    procedure UpdateList;
    procedure UpdateSQL(Sender: TObject; Parser: TSelectSQLParser);
    procedure HandleEnter(Data: PtrInt);
    procedure UpdateLinkData(Sender: TObject);
  protected
    { Protected declarations }
    procedure ActiveChanged(Sender: TObject);
    procedure CheckAndInsert;
    procedure DoEnter; override;
    procedure DoExit; override;
    procedure KeyUp(var Key: Word; Shift: TShiftState); override;
    procedure Loaded; override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure SetItemIndex(const Val: integer); override;
    function SQLSafe(aText: string): string;
    procedure UpdateShowing; override;

  public
    { Public declarations }
    constructor Create(TheComponent: TComponent); override;
    destructor Destroy; override;
    procedure EditingDone; override;
  published
    { Published declarations }
    property AutoInsert: boolean read FAutoInsert write FAutoInsert;
    property AutoComplete: boolean read FAutoComplete write FAutoComplete default true;
    property AutoCompleteText: TComboBoxAutoCompleteText read GetAutoCompleteText
             write SetAutoCompleteText;
    property ItemHeight;
    property ItemWidth;
    property ListSource: TDataSource read GetListSource write SetListSource;
    property KeyPressInterval: integer read FKeyPressInterval write FKeyPressInterval default 200;
    property RelationName: string read FRelationName write FRelationName;
    property OnAutoInsert: TAutoInsert read FOnAutoInsert write FOnAutoInsert;
    property OnCanAutoInsert: TCanAutoInsert read FOnCanAutoInsert write FOnCanAutoInsert;
  end;


implementation

uses IBQuery, LCLType, Variants, LCLProc, LazUTF8;

{ TIBLookupControlLink }

constructor TIBLookupControlLink.Create(AOwner: TIBLookupComboEditBox);
begin
  inherited Create;
  FOwner := AOwner;
end;

procedure TIBLookupControlLink.UpdateSQL(Sender: TObject);
begin
  FOwner.UpdateSQL(self,TIBParserDataSet(Sender).Parser)
end;

{ TIBLookupComboDataLink }

procedure TIBLookupComboDataLink.ActiveChanged;
begin
  FOwner.ActiveChanged(self)
end;

procedure TIBLookupComboDataLink.RecordChanged(Field: TField);
begin
  FOwner.RecordChanged(self,Field);
end;

procedure TIBLookupComboDataLink.UpdateData;
begin
  FOwner.UpdateLinkData(self)
end;

constructor TIBLookupComboDataLink.Create(AOwner: TIBLookupComboEditBox);
begin
  inherited Create;
  FOwner := AOwner
end;

{ TIBLookupComboEditBox }

procedure TIBLookupComboEditBox.HandleTimer(Sender: TObject);
var ActiveState: boolean;
begin
  FTimer.Interval := 0;
  FFiltered := Text <> '';
  UpdateList
end;

procedure TIBLookupComboEditBox.IBControlLinkChanged;
begin
  if (ListSource <> nil) and (ListSource.DataSet <> nil) and (ListSource.DataSet is TIBParserDataSet) then
    FIBLookupControlLink.IBDataSet := TIBCustomDataSet(ListSource.DataSet)
  else
    FIBLookupControlLink.IBDataSet := nil;
end;

function TIBLookupComboEditBox.GetListSource: TDataSource;
begin
  Result := inherited ListSource;
end;

function TIBLookupComboEditBox.GetRelationNameQualifier: string;
begin
  if FRelationName <> '' then
     Result := FRelationName + '.'
  else
    Result := ''
end;

procedure TIBLookupComboEditBox.ActiveChanged(Sender: TObject);
begin
  if not FInserting and not FUpdating then
     Application.QueueAsyncCall(@DoActiveChanged,0);
  IBControlLinkChanged;
end;

procedure TIBLookupComboEditBox.DoActiveChanged(Data: PtrInt);
begin
  if AppDestroying in Application.Flags then Exit;

  if (DataSource = nil) and assigned(ListSource) and assigned(ListSource.DataSet)
     and ListSource.DataSet.Active   then
  begin
    begin
      if varIsNull(FLastKeyValue) and (ItemIndex = -1) then
        KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant
      else
      begin
        KeyValue := FLastKeyValue;
        UpdateData(self); {Force auto scroll}
        if varIsNull(KeyValue) then {Value not present}
          Text := ListSource.DataSet.FieldByName(ListField).AsString
      end;
    end;
  end
  else
  if (DataSource <> nil) and  assigned(DataSource.DataSet) and
                   (DataSource.DataSet.Active) and (DataField <> '') then
  begin
    ResetParser;
    KeyValue := Field.AsVariant;
  end
  else
    Text := '';
  FOriginalTextValue := Text;
end;

function TIBLookupComboEditBox.GetAutoCompleteText: TComboBoxAutoCompleteText;
begin
  Result := inherited AutoCompleteText;
  if AutoComplete then
     Result := Result + [cbactEnabled]
end;

procedure TIBLookupComboEditBox.ResetParser;
var curKeyValue: variant;
begin
  if FFiltered then
  begin
    FFiltered := false;
    curKeyValue := KeyValue;
    Text := ''; {Ensure full list}
    UpdateList;
    KeyValue := curKeyValue;
    UpdateData(self); {Force Scroll}
  end;
end;

procedure TIBLookupComboEditBox.RecordChanged(Sender: TObject; aField: TField);
begin
  {Make sure that we are in sync with other data controls}
  if DataSource = nil then
  begin
    KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
    if VarIsNull(KeyValue) then {Probable deletion}
    begin
      UpdateList;
      KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
    end;
  end;
end;

procedure TIBLookupComboEditBox.SetAutoCompleteText(
  AValue: TComboBoxAutoCompleteText);
begin
  if AValue <> AutoCompleteText then
  begin
    FAutoComplete := cbactEnabled in AValue;
    inherited AutoCompleteText := AValue - [cbactEnabled]
  end;
end;

procedure TIBLookupComboEditBox.SetListSource(AValue: TDataSource);
begin
  if AValue <> inherited ListSource then
  begin
    FDataLink.DataSource := AValue;
    inherited ListSource := AValue;
    IBControlLinkChanged;
  end;
end;

procedure TIBLookupComboEditBox.UpdateList;
{ Note: Algorithm taken from TCustomComboBox.KeyUp but modified to use the
  ListSource DataSet as the source for the autocomplete text. It also runs
  after a delay rather than immediately on keyup
}
var
  iSelStart: Integer; // char position
  sCompleteText, sPrefixText, sResultText: string;
begin
  if assigned(ListSource) and assigned(ListSource.DataSet) and (ListSource.DataSet is TIBCustomDataSet)
     and ListSource.DataSet.Active then
  begin
    FCurText := Text;
    FUpdating := true;
    try
         iSelStart := SelStart;//Capture original cursor position
         if ((iSelStart < UTF8Length(Text)) and
           (cbactEndOfLineComplete in AutoCompleteText)) then
                Exit;
         sPrefixText := UTF8Copy(Text, 1, iSelStart);
         ListSource.DataSet.Active := false;
         ListSource.DataSet.Active :=  true;
         Text := FCurText;
         if not FExiting and (FForceAutoComplete or Focused) and (FCurText <> '')then
         begin
           if ListSource.DataSet.Active and (ListSource.DataSet.RecordCount > 0) then
           begin
             sCompleteText := ListSource.DataSet.FieldByName(ListField).AsString;
             if (sCompleteText <> FCurText) then
             begin
               sResultText := sCompleteText;
               if ((cbactEndOfLineComplete in AutoCompleteText) and
                         (cbactRetainPrefixCase in AutoCompleteText)) then
               begin//Retain Prefix Character cases
                 UTF8Delete(sResultText, 1, iSelStart);
                 UTF8Insert(sPrefixText, sResultText, 1);
               end;
               Text := sResultText;
               SelStart := iSelStart;
               SelLength := UTF8Length(Text);
             end;
             KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
           end;
         end;
    finally
      FUpdating := false
    end;
  end;
end;

procedure TIBLookupComboEditBox.UpdateSQL(Sender: TObject;
  Parser: TSelectSQLParser);
var FieldPosition: integer;
    FilterText: string;
begin
  if FFiltered then
  begin
    if FUpdating then
      FilterText := FCurText
    else
      FilterText := Text;
    if cbactSearchCaseSensitive in AutoCompleteText then
      Parser.Add2WhereClause(GetRelationNameQualifier + '"' + ListField + '" Like ''' +
                                  SQLSafe(FilterText) + '%''')
    else
      Parser.Add2WhereClause('Upper(' + GetRelationNameQualifier + '"' +  ListField + '") Like Upper(''' +
                                  SQLSafe(FilterText) + '%'')');

    if cbactSearchAscending in AutoCompleteText then
    begin
      FieldPosition := Parser.GetFieldPosition(ListField);
      if FieldPosition = 0 then Exit;

      Parser.OrderByClause := IntToStr(FieldPosition) + ' ascending';
    end;
  end;
end;

procedure TIBLookupComboEditBox.HandleEnter(Data: PtrInt);
begin
  if AppDestroying in Application.Flags then Exit;
   SelectAll
end;

procedure TIBLookupComboEditBox.UpdateLinkData(Sender: TObject);
begin
  if FInserting then
    ListSource.DataSet.FieldByName(ListField).AsString := Text
end;

procedure TIBLookupComboEditBox.CheckAndInsert;
var Accept: boolean;
    NewKeyValue: variant;
begin
  if FInCheckAndInsert then Exit;
  FInCheckAndInsert := true;
  try
       if AutoInsert and (Text <> '') and assigned(ListSource) and assigned(ListSource.DataSet)
          and ListSource.DataSet.Active and (ListSource.DataSet.RecordCount = 0) then
       try
         {Is it OK to insert a new list member?}
         Accept := true;
         if assigned(FOnCanAutoInsert) then
            OnCanAutoInsert(self,Text,Accept);
         if not Accept then
         begin
           ResetParser;
           Text := FOriginalTextValue;
           SelectAll;
           Exit;
         end;

         FInserting := true;
         try
           {New Value}
           FFiltered := false;
           if assigned(FOnAutoInsert) then
           begin
             {In an OnAutoInsert handler, the client is expected to insert the new
              row into the List DataSet and to set the KeyValue property to the
              value of the primary key of the new row.}
             OnAutoInsert(self,Text,NewKeyValue);
           end
           else
           begin
             ListSource.DataSet.Append;
             {The new KeyValue should be determined by an external generator or
              in the "OnInsert" handler. If it is the same as the ListField, then
              it will be set from the UpdateLinkData method}
             try
               ListSource.DataSet.Post;
             except
               ListSource.DataSet.Cancel;
               raise;
             end;
             NewKeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
           end;
           Text := ''; {Ensure full list}
           UpdateList;
           KeyValue := NewKeyValue;
           UpdateData(nil); {Force sync with DataField}
         finally
           FInserting := false
         end;
       except
         Text := FOriginalTextValue;
         ResetParser;
         raise;
       end;
  finally
    FInCheckAndInsert := false
  end;
end;

procedure TIBLookupComboEditBox.DoEnter;
begin
  inherited DoEnter;
  FOriginalTextValue:= Text;
  ResetParser;
  Application.QueueAsyncCall(@HandleEnter,0);
end;

procedure TIBLookupComboEditBox.DoExit;
begin
  if FTimer.Interval <> 0 then
    HandleTimer(nil);
  FExiting := true;
  try
    CheckAndInsert;
    ResetParser;
    FTimer.Interval := 0;
  finally
    FExiting := false;
  end;
  inherited DoExit;
end;

procedure TIBLookupComboEditBox.KeyUp(var Key: Word; Shift: TShiftState);
begin
  inherited KeyUp(Key, Shift);
  if Key = VK_RETURN then
     EditingDone
  else
  if Key = VK_ESCAPE then
  begin
    SelStart := UTF8Length(Text);      {Ensure end of line selection}
    ResetParser;
    Text := FOriginalTextValue;
    SelectAll;
  end
  else
  begin
    FTimer.Interval := 0;
    if (IsEditableTextKey(Key) or (Key = VK_BACK))
       and AutoComplete and (Style <> csDropDownList) and
       (not (cbactEndOfLineComplete in AutoCompleteText) or (SelStart = UTF8Length(Text))) then
      FTimer.Interval := FKeyPressInterval;
  end;
end;

procedure TIBLookupComboEditBox.Loaded;
begin
  inherited Loaded;
  IBControlLinkChanged;
end;

procedure TIBLookupComboEditBox.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (AComponent = DataSource) then
    ListSource := nil;
end;

procedure TIBLookupComboEditBox.SetItemIndex(const Val: integer);
begin
  inherited SetItemIndex(Val);
  FLastKeyValue := KeyValue;
end;

function TIBLookupComboEditBox.SQLSafe(aText: string): string;
var I: integer;
begin
  Result := '';
  for I := 1 to length(aText) do
    if aText[I] = '''' then
      Result := Result + ''''''
    else
      Result := Result + aText[I];
end;

procedure TIBLookupComboEditBox.UpdateShowing;
begin
  inherited UpdateShowing;
  if Showing then {Ensure up-to-date as we were ignoring any changes}
    ActiveChanged(nil);
end;

constructor TIBLookupComboEditBox.Create(TheComponent: TComponent);
begin
  inherited Create(TheComponent);
  FDataLink := TIBLookupComboDataLink.Create(self);
  FIBLookupControlLink := TIBLookupControlLink.Create(self);
  FKeyPressInterval := 200;
  FAutoComplete := true;
  FTimer := TTimer.Create(nil);
  FTimer.Interval := 0;
  FTimer.OnTimer := @HandleTimer;
  FLastKeyValue := NULL;
end;

destructor TIBLookupComboEditBox.Destroy;
begin
  if assigned(FDataLink) then FDataLink.Free;
  if assigned(FIBLookupControlLink) then FIBLookupControlLink.Free;
  if assigned(FTimer) then FTimer.Free;
  inherited Destroy;
end;

procedure TIBLookupComboEditBox.EditingDone;
begin
  FForceAutoComplete := true;
  try
  if FTimer.Interval <> 0 then
    HandleTimer(nil);
  finally
    FForceAutoComplete := false;
  end;
  CheckAndInsert;
  inherited EditingDone;
end;

end.
Revision:	64
Committed:	Thu Jun 29 11:11:22 2017 UTC (7 years, 5 months ago) by tony
Content type:	text/x-pascal
Original Path:	*ibx/trunk/ibcontrols/IBLookupComboEditBox.pas*
File size:	17228 byte(s)
Log Message:	IBLookupComboEditBox: Avoid race condition when autocompleting text that occasionally results in autocomplete ignoring prefix text.
#	Content
1	(*
2	* IBX For Lazarus (Firebird Express)
3	*
4	* The contents of this file are subject to the Initial Developer's
5	* Public License Version 1.0 (the "License"); you may not use this
6	* file except in compliance with the License. You may obtain a copy
7	* of the License here:
8	*
9	* http://www.firebirdsql.org/index.php?op=doc&id=idpl
10	*
11	* Software distributed under the License is distributed on an "AS
12	* IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
13	* implied. See the License for the specific language governing rights
14	* and limitations under the License.
15	*
16	* The Initial Developer of the Original Code is Tony Whyman.
17	*
18	* The Original Code is (C) 2015 Tony Whyman, MWA Software
19	* (http://www.mwasoftware.co.uk).
20	*
21	* All Rights Reserved.
22	*
23	* Contributor(s): ______________________________________.
24	*
25	*)
26	unit IBLookupComboEditBox;
27
28	{$mode objfpc}{$H+}
29
30	interface
31
32	uses
33	Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, DbCtrls,
34	ExtCtrls, IBSQLParser, DB, StdCtrls, IBCustomDataSet, LCLVersion;
35
36	type
37
38	{TIBLookupComboEditBox is a TDBLookupComboBox descendent that implements "autocomplete"
39	of typed in text and "autoinsert" of new entries. Autocomplete uses SQL manipulation
40	to revise the available list and restrict it to items that are prefixed by the
41	typed text (either case sensitive or case insenstive). Autoinsert allows a
42	newly typed entry to be added to the list dataset and included in the available
43	list items. }
44
45	TAutoInsert = procedure(Sender: TObject; aText: string; var NewKeyValue: variant) of object;
46	TCanAutoInsert = procedure (Sender: TObject; aText: string; var Accept: boolean) of object;
47
48	TIBLookupComboEditBox = class;
49
50	{ TIBLookupComboDataLink }
51
52	TIBLookupComboDataLink = class(TDataLink)
53	private
54	FOwner: TIBLookupComboEditBox;
55	protected
56	procedure ActiveChanged; override;
57	procedure RecordChanged(Field: TField); override;
58	procedure UpdateData; override;
59	public
60	constructor Create(AOwner: TIBLookupComboEditBox);
61	end;
62
63	{ TIBLookupControlLink }
64
65	TIBLookupControlLink = class(TIBControlLink)
66	private
67	FOwner: TIBLookupComboEditBox;
68	protected
69	procedure UpdateSQL(Sender: TObject); override;
70	public
71	constructor Create(AOwner: TIBLookupComboEditBox);
72	end;
73
74
75	{ TIBLookupComboEditBox }
76
77	TIBLookupComboEditBox = class(TDBLookupComboBox)
78	private
79	FCanAutoInsert: TCanAutoInsert;
80	{ Private declarations }
81	FDataLink: TIBLookupComboDataLink;
82	FIBLookupControlLink: TIBLookupControlLink;
83	FAutoComplete: boolean;
84	FAutoInsert: boolean;
85	FKeyPressInterval: integer;
86	FOnCanAutoInsert: TCanAutoInsert;
87	FRelationName: string;
88	FTimer: TTimer;
89	FFiltered: boolean;
90	FOnAutoInsert: TAutoInsert;
91	FOriginalTextValue: string;
92	FUpdating: boolean;
93	FInserting: boolean;
94	FExiting: boolean;
95	FForceAutoComplete: boolean;
96	FInCheckAndInsert: boolean;
97	FLastKeyValue: variant;
98	FCurText: string;
99	procedure DoActiveChanged(Data: PtrInt);
100	function GetAutoCompleteText: TComboBoxAutoCompleteText;
101	function GetListSource: TDataSource;
102	function GetRelationNameQualifier: string;
103	procedure HandleTimer(Sender: TObject);
104	procedure IBControlLinkChanged;
105	procedure ResetParser;
106	procedure RecordChanged(Sender: TObject; aField: TField);
107	procedure SetAutoCompleteText(AValue: TComboBoxAutoCompleteText);
108	procedure SetListSource(AValue: TDataSource);
109	procedure UpdateList;
110	procedure UpdateSQL(Sender: TObject; Parser: TSelectSQLParser);
111	procedure HandleEnter(Data: PtrInt);
112	procedure UpdateLinkData(Sender: TObject);
113	protected
114	{ Protected declarations }
115	procedure ActiveChanged(Sender: TObject);
116	procedure CheckAndInsert;
117	procedure DoEnter; override;
118	procedure DoExit; override;
119	procedure KeyUp(var Key: Word; Shift: TShiftState); override;
120	procedure Loaded; override;
121	procedure Notification(AComponent: TComponent; Operation: TOperation); override;
122	procedure SetItemIndex(const Val: integer); override;
123	function SQLSafe(aText: string): string;
124	procedure UpdateShowing; override;
125
126	public
127	{ Public declarations }
128	constructor Create(TheComponent: TComponent); override;
129	destructor Destroy; override;
130	procedure EditingDone; override;
131	published
132	{ Published declarations }
133	property AutoInsert: boolean read FAutoInsert write FAutoInsert;
134	property AutoComplete: boolean read FAutoComplete write FAutoComplete default true;
135	property AutoCompleteText: TComboBoxAutoCompleteText read GetAutoCompleteText
136	write SetAutoCompleteText;
137	property ItemHeight;
138	property ItemWidth;
139	property ListSource: TDataSource read GetListSource write SetListSource;
140	property KeyPressInterval: integer read FKeyPressInterval write FKeyPressInterval default 200;
141	property RelationName: string read FRelationName write FRelationName;
142	property OnAutoInsert: TAutoInsert read FOnAutoInsert write FOnAutoInsert;
143	property OnCanAutoInsert: TCanAutoInsert read FOnCanAutoInsert write FOnCanAutoInsert;
144	end;
145
146
147	implementation
148
149	uses IBQuery, LCLType, Variants, LCLProc, LazUTF8;
150
151	{ TIBLookupControlLink }
152
153	constructor TIBLookupControlLink.Create(AOwner: TIBLookupComboEditBox);
154	begin
155	inherited Create;
156	FOwner := AOwner;
157	end;
158
159	procedure TIBLookupControlLink.UpdateSQL(Sender: TObject);
160	begin
161	FOwner.UpdateSQL(self,TIBParserDataSet(Sender).Parser)
162	end;
163
164	{ TIBLookupComboDataLink }
165
166	procedure TIBLookupComboDataLink.ActiveChanged;
167	begin
168	FOwner.ActiveChanged(self)
169	end;
170
171	procedure TIBLookupComboDataLink.RecordChanged(Field: TField);
172	begin
173	FOwner.RecordChanged(self,Field);
174	end;
175
176	procedure TIBLookupComboDataLink.UpdateData;
177	begin
178	FOwner.UpdateLinkData(self)
179	end;
180
181	constructor TIBLookupComboDataLink.Create(AOwner: TIBLookupComboEditBox);
182	begin
183	inherited Create;
184	FOwner := AOwner
185	end;
186
187	{ TIBLookupComboEditBox }
188
189	procedure TIBLookupComboEditBox.HandleTimer(Sender: TObject);
190	var ActiveState: boolean;
191	begin
192	FTimer.Interval := 0;
193	FFiltered := Text <> '';
194	UpdateList
195	end;
196
197	procedure TIBLookupComboEditBox.IBControlLinkChanged;
198	begin
199	if (ListSource <> nil) and (ListSource.DataSet <> nil) and (ListSource.DataSet is TIBParserDataSet) then
200	FIBLookupControlLink.IBDataSet := TIBCustomDataSet(ListSource.DataSet)
201	else
202	FIBLookupControlLink.IBDataSet := nil;
203	end;
204
205	function TIBLookupComboEditBox.GetListSource: TDataSource;
206	begin
207	Result := inherited ListSource;
208	end;
209
210	function TIBLookupComboEditBox.GetRelationNameQualifier: string;
211	begin
212	if FRelationName <> '' then
213	Result := FRelationName + '.'
214	else
215	Result := ''
216	end;
217
218	procedure TIBLookupComboEditBox.ActiveChanged(Sender: TObject);
219	begin
220	if not FInserting and not FUpdating then
221	Application.QueueAsyncCall(@DoActiveChanged,0);
222	IBControlLinkChanged;
223	end;
224
225	procedure TIBLookupComboEditBox.DoActiveChanged(Data: PtrInt);
226	begin
227	if AppDestroying in Application.Flags then Exit;
228
229	if (DataSource = nil) and assigned(ListSource) and assigned(ListSource.DataSet)
230	and ListSource.DataSet.Active then
231	begin
232	begin
233	if varIsNull(FLastKeyValue) and (ItemIndex = -1) then
234	KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant
235	else
236	begin
237	KeyValue := FLastKeyValue;
238	UpdateData(self); {Force auto scroll}
239	if varIsNull(KeyValue) then {Value not present}
240	Text := ListSource.DataSet.FieldByName(ListField).AsString
241	end;
242	end;
243	end
244	else
245	if (DataSource <> nil) and assigned(DataSource.DataSet) and
246	(DataSource.DataSet.Active) and (DataField <> '') then
247	begin
248	ResetParser;
249	KeyValue := Field.AsVariant;
250	end
251	else
252	Text := '';
253	FOriginalTextValue := Text;
254	end;
255
256	function TIBLookupComboEditBox.GetAutoCompleteText: TComboBoxAutoCompleteText;
257	begin
258	Result := inherited AutoCompleteText;
259	if AutoComplete then
260	Result := Result + [cbactEnabled]
261	end;
262
263	procedure TIBLookupComboEditBox.ResetParser;
264	var curKeyValue: variant;
265	begin
266	if FFiltered then
267	begin
268	FFiltered := false;
269	curKeyValue := KeyValue;
270	Text := ''; {Ensure full list}
271	UpdateList;
272	KeyValue := curKeyValue;
273	UpdateData(self); {Force Scroll}
274	end;
275	end;
276
277	procedure TIBLookupComboEditBox.RecordChanged(Sender: TObject; aField: TField);
278	begin
279	{Make sure that we are in sync with other data controls}
280	if DataSource = nil then
281	begin
282	KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
283	if VarIsNull(KeyValue) then {Probable deletion}
284	begin
285	UpdateList;
286	KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
287	end;
288	end;
289	end;
290
291	procedure TIBLookupComboEditBox.SetAutoCompleteText(
292	AValue: TComboBoxAutoCompleteText);
293	begin
294	if AValue <> AutoCompleteText then
295	begin
296	FAutoComplete := cbactEnabled in AValue;
297	inherited AutoCompleteText := AValue - [cbactEnabled]
298	end;
299	end;
300
301	procedure TIBLookupComboEditBox.SetListSource(AValue: TDataSource);
302	begin
303	if AValue <> inherited ListSource then
304	begin
305	FDataLink.DataSource := AValue;
306	inherited ListSource := AValue;
307	IBControlLinkChanged;
308	end;
309	end;
310
311	procedure TIBLookupComboEditBox.UpdateList;
312	{ Note: Algorithm taken from TCustomComboBox.KeyUp but modified to use the
313	ListSource DataSet as the source for the autocomplete text. It also runs
314	after a delay rather than immediately on keyup
315	}
316	var
317	iSelStart: Integer; // char position
318	sCompleteText, sPrefixText, sResultText: string;
319	begin
320	if assigned(ListSource) and assigned(ListSource.DataSet) and (ListSource.DataSet is TIBCustomDataSet)
321	and ListSource.DataSet.Active then
322	begin
323	FCurText := Text;
324	FUpdating := true;
325	try
326	iSelStart := SelStart;//Capture original cursor position
327	if ((iSelStart < UTF8Length(Text)) and
328	(cbactEndOfLineComplete in AutoCompleteText)) then
329	Exit;
330	sPrefixText := UTF8Copy(Text, 1, iSelStart);
331	ListSource.DataSet.Active := false;
332	ListSource.DataSet.Active := true;
333	Text := FCurText;
334	if not FExiting and (FForceAutoComplete or Focused) and (FCurText <> '')then
335	begin
336	if ListSource.DataSet.Active and (ListSource.DataSet.RecordCount > 0) then
337	begin
338	sCompleteText := ListSource.DataSet.FieldByName(ListField).AsString;
339	if (sCompleteText <> FCurText) then
340	begin
341	sResultText := sCompleteText;
342	if ((cbactEndOfLineComplete in AutoCompleteText) and
343	(cbactRetainPrefixCase in AutoCompleteText)) then
344	begin//Retain Prefix Character cases
345	UTF8Delete(sResultText, 1, iSelStart);
346	UTF8Insert(sPrefixText, sResultText, 1);
347	end;
348	Text := sResultText;
349	SelStart := iSelStart;
350	SelLength := UTF8Length(Text);
351	end;
352	KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
353	end;
354	end;
355	finally
356	FUpdating := false
357	end;
358	end;
359	end;
360
361	procedure TIBLookupComboEditBox.UpdateSQL(Sender: TObject;
362	Parser: TSelectSQLParser);
363	var FieldPosition: integer;
364	FilterText: string;
365	begin
366	if FFiltered then
367	begin
368	if FUpdating then
369	FilterText := FCurText
370	else
371	FilterText := Text;
372	if cbactSearchCaseSensitive in AutoCompleteText then
373	Parser.Add2WhereClause(GetRelationNameQualifier + '"' + ListField + '" Like ''' +
374	SQLSafe(FilterText) + '%''')
375	else
376	Parser.Add2WhereClause('Upper(' + GetRelationNameQualifier + '"' + ListField + '") Like Upper(''' +
377	SQLSafe(FilterText) + '%'')');
378
379	if cbactSearchAscending in AutoCompleteText then
380	begin
381	FieldPosition := Parser.GetFieldPosition(ListField);
382	if FieldPosition = 0 then Exit;
383
384	Parser.OrderByClause := IntToStr(FieldPosition) + ' ascending';
385	end;
386	end;
387	end;
388
389	procedure TIBLookupComboEditBox.HandleEnter(Data: PtrInt);
390	begin
391	if AppDestroying in Application.Flags then Exit;
392	SelectAll
393	end;
394
395	procedure TIBLookupComboEditBox.UpdateLinkData(Sender: TObject);
396	begin
397	if FInserting then
398	ListSource.DataSet.FieldByName(ListField).AsString := Text
399	end;
400
401	procedure TIBLookupComboEditBox.CheckAndInsert;
402	var Accept: boolean;
403	NewKeyValue: variant;
404	begin
405	if FInCheckAndInsert then Exit;
406	FInCheckAndInsert := true;
407	try
408	if AutoInsert and (Text <> '') and assigned(ListSource) and assigned(ListSource.DataSet)
409	and ListSource.DataSet.Active and (ListSource.DataSet.RecordCount = 0) then
410	try
411	{Is it OK to insert a new list member?}
412	Accept := true;
413	if assigned(FOnCanAutoInsert) then
414	OnCanAutoInsert(self,Text,Accept);
415	if not Accept then
416	begin
417	ResetParser;
418	Text := FOriginalTextValue;
419	SelectAll;
420	Exit;
421	end;
422
423	FInserting := true;
424	try
425	{New Value}
426	FFiltered := false;
427	if assigned(FOnAutoInsert) then
428	begin
429	{In an OnAutoInsert handler, the client is expected to insert the new
430	row into the List DataSet and to set the KeyValue property to the
431	value of the primary key of the new row.}
432	OnAutoInsert(self,Text,NewKeyValue);
433	end
434	else
435	begin
436	ListSource.DataSet.Append;
437	{The new KeyValue should be determined by an external generator or
438	in the "OnInsert" handler. If it is the same as the ListField, then
439	it will be set from the UpdateLinkData method}
440	try
441	ListSource.DataSet.Post;
442	except
443	ListSource.DataSet.Cancel;
444	raise;
445	end;
446	NewKeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
447	end;
448	Text := ''; {Ensure full list}
449	UpdateList;
450	KeyValue := NewKeyValue;
451	UpdateData(nil); {Force sync with DataField}
452	finally
453	FInserting := false
454	end;
455	except
456	Text := FOriginalTextValue;
457	ResetParser;
458	raise;
459	end;
460	finally
461	FInCheckAndInsert := false
462	end;
463	end;
464
465	procedure TIBLookupComboEditBox.DoEnter;
466	begin
467	inherited DoEnter;
468	FOriginalTextValue:= Text;
469	ResetParser;
470	Application.QueueAsyncCall(@HandleEnter,0);
471	end;
472
473	procedure TIBLookupComboEditBox.DoExit;
474	begin
475	if FTimer.Interval <> 0 then
476	HandleTimer(nil);
477	FExiting := true;
478	try
479	CheckAndInsert;
480	ResetParser;
481	FTimer.Interval := 0;
482	finally
483	FExiting := false;
484	end;
485	inherited DoExit;
486	end;
487
488	procedure TIBLookupComboEditBox.KeyUp(var Key: Word; Shift: TShiftState);
489	begin
490	inherited KeyUp(Key, Shift);
491	if Key = VK_RETURN then
492	EditingDone
493	else
494	if Key = VK_ESCAPE then
495	begin
496	SelStart := UTF8Length(Text); {Ensure end of line selection}
497	ResetParser;
498	Text := FOriginalTextValue;
499	SelectAll;
500	end
501	else
502	begin
503	FTimer.Interval := 0;
504	if (IsEditableTextKey(Key) or (Key = VK_BACK))
505	and AutoComplete and (Style <> csDropDownList) and
506	(not (cbactEndOfLineComplete in AutoCompleteText) or (SelStart = UTF8Length(Text))) then
507	FTimer.Interval := FKeyPressInterval;
508	end;
509	end;
510
511	procedure TIBLookupComboEditBox.Loaded;
512	begin
513	inherited Loaded;
514	IBControlLinkChanged;
515	end;
516
517	procedure TIBLookupComboEditBox.Notification(AComponent: TComponent;
518	Operation: TOperation);
519	begin
520	inherited Notification(AComponent, Operation);
521	if (Operation = opRemove) and (AComponent = DataSource) then
522	ListSource := nil;
523	end;
524
525	procedure TIBLookupComboEditBox.SetItemIndex(const Val: integer);
526	begin
527	inherited SetItemIndex(Val);
528	FLastKeyValue := KeyValue;
529	end;
530
531	function TIBLookupComboEditBox.SQLSafe(aText: string): string;
532	var I: integer;
533	begin
534	Result := '';
535	for I := 1 to length(aText) do
536	if aText[I] = '''' then
537	Result := Result + ''''''
538	else
539	Result := Result + aText[I];
540	end;
541
542	procedure TIBLookupComboEditBox.UpdateShowing;
543	begin
544	inherited UpdateShowing;
545	if Showing then {Ensure up-to-date as we were ignoring any changes}
546	ActiveChanged(nil);
547	end;
548
549	constructor TIBLookupComboEditBox.Create(TheComponent: TComponent);
550	begin
551	inherited Create(TheComponent);
552	FDataLink := TIBLookupComboDataLink.Create(self);
553	FIBLookupControlLink := TIBLookupControlLink.Create(self);
554	FKeyPressInterval := 200;
555	FAutoComplete := true;
556	FTimer := TTimer.Create(nil);
557	FTimer.Interval := 0;
558	FTimer.OnTimer := @HandleTimer;
559	FLastKeyValue := NULL;
560	end;
561
562	destructor TIBLookupComboEditBox.Destroy;
563	begin
564	if assigned(FDataLink) then FDataLink.Free;
565	if assigned(FIBLookupControlLink) then FIBLookupControlLink.Free;
566	if assigned(FTimer) then FTimer.Free;
567	inherited Destroy;
568	end;
569
570	procedure TIBLookupComboEditBox.EditingDone;
571	begin
572	FForceAutoComplete := true;
573	try
574	if FTimer.Interval <> 0 then
575	HandleTimer(nil);
576	finally
577	FForceAutoComplete := false;
578	end;
579	CheckAndInsert;
580	inherited EditingDone;
581	end;
582
583	end.