ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/ibcontrols/IBLookupComboEditBox.pas
Revision: 64
Committed: Thu Jun 29 11:11:22 2017 UTC (6 years, 9 months ago) by tony
Content type: text/x-pascal
File size: 17228 byte(s)
Log Message:
IBLookupComboEditBox: Avoid race condition when autocompleting text that occasionally results in autocomplete ignoring prefix text.

File Contents

# User Rev Content
1 tony 21 (*
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 tony 23 * The Original Code is (C) 2015 Tony Whyman, MWA Software
19 tony 21 * (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 tony 41 ExtCtrls, IBSQLParser, DB, StdCtrls, IBCustomDataSet, LCLVersion;
35 tony 21
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 tony 27 { TIBLookupControlLink }
64 tony 21
65 tony 27 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 tony 21 { TIBLookupComboEditBox }
76    
77     TIBLookupComboEditBox = class(TDBLookupComboBox)
78     private
79     FCanAutoInsert: TCanAutoInsert;
80     { Private declarations }
81     FDataLink: TIBLookupComboDataLink;
82 tony 27 FIBLookupControlLink: TIBLookupControlLink;
83 tony 21 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 tony 35 FForceAutoComplete: boolean;
96     FInCheckAndInsert: boolean;
97 tony 21 FLastKeyValue: variant;
98 tony 64 FCurText: string;
99 tony 21 procedure DoActiveChanged(Data: PtrInt);
100     function GetAutoCompleteText: TComboBoxAutoCompleteText;
101     function GetListSource: TDataSource;
102     function GetRelationNameQualifier: string;
103     procedure HandleTimer(Sender: TObject);
104 tony 27 procedure IBControlLinkChanged;
105 tony 21 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 tony 29 procedure Loaded; override;
121 tony 27 procedure Notification(AComponent: TComponent; Operation: TOperation); override;
122 tony 21 procedure SetItemIndex(const Val: integer); override;
123 tony 27 function SQLSafe(aText: string): string;
124 tony 21 procedure UpdateShowing; override;
125 tony 27
126 tony 21 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 tony 27 property KeyPressInterval: integer read FKeyPressInterval write FKeyPressInterval default 200;
141 tony 21 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 tony 41 uses IBQuery, LCLType, Variants, LCLProc, LazUTF8;
150 tony 21
151 tony 27 { TIBLookupControlLink }
152 tony 21
153 tony 27 constructor TIBLookupControlLink.Create(AOwner: TIBLookupComboEditBox);
154 tony 21 begin
155 tony 27 inherited Create;
156     FOwner := AOwner;
157 tony 21 end;
158    
159 tony 27 procedure TIBLookupControlLink.UpdateSQL(Sender: TObject);
160 tony 21 begin
161 tony 27 FOwner.UpdateSQL(self,TIBParserDataSet(Sender).Parser)
162     end;
163 tony 21
164 tony 27 { TIBLookupComboDataLink }
165    
166     procedure TIBLookupComboDataLink.ActiveChanged;
167     begin
168     FOwner.ActiveChanged(self)
169 tony 21 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 tony 27 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 tony 21 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 tony 27 IBControlLinkChanged;
223 tony 21 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 tony 27 var curKeyValue: variant;
265 tony 21 begin
266     if FFiltered then
267     begin
268     FFiltered := false;
269 tony 27 curKeyValue := KeyValue;
270     Text := ''; {Ensure full list}
271 tony 21 UpdateList;
272 tony 27 KeyValue := curKeyValue;
273 tony 21 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 tony 27 IBControlLinkChanged;
308 tony 21 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 tony 64 FCurText := Text;
324 tony 21 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 tony 64 Text := FCurText;
334     if not FExiting and (FForceAutoComplete or Focused) and (FCurText <> '')then
335 tony 21 begin
336     if ListSource.DataSet.Active and (ListSource.DataSet.RecordCount > 0) then
337     begin
338     sCompleteText := ListSource.DataSet.FieldByName(ListField).AsString;
339 tony 64 if (sCompleteText <> FCurText) then
340 tony 21 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 tony 31 KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
353 tony 21 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 tony 64 FilterText: string;
365 tony 21 begin
366     if FFiltered then
367     begin
368 tony 64 if FUpdating then
369     FilterText := FCurText
370     else
371     FilterText := Text;
372 tony 21 if cbactSearchCaseSensitive in AutoCompleteText then
373 tony 27 Parser.Add2WhereClause(GetRelationNameQualifier + '"' + ListField + '" Like ''' +
374 tony 64 SQLSafe(FilterText) + '%''')
375 tony 21 else
376 tony 39 Parser.Add2WhereClause('Upper(' + GetRelationNameQualifier + '"' + ListField + '") Like Upper(''' +
377 tony 64 SQLSafe(FilterText) + '%'')');
378 tony 21
379 tony 41 if cbactSearchAscending in AutoCompleteText then
380     begin
381     FieldPosition := Parser.GetFieldPosition(ListField);
382     if FieldPosition = 0 then Exit;
383 tony 21
384 tony 41 Parser.OrderByClause := IntToStr(FieldPosition) + ' ascending';
385     end;
386 tony 21 end;
387     end;
388    
389     procedure TIBLookupComboEditBox.HandleEnter(Data: PtrInt);
390     begin
391 tony 31 if AppDestroying in Application.Flags then Exit;
392 tony 27 SelectAll
393 tony 21 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 tony 35 if FInCheckAndInsert then Exit;
406     FInCheckAndInsert := true;
407 tony 21 try
408 tony 35 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 tony 21
423 tony 35 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 tony 21 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 tony 31 if FTimer.Interval <> 0 then
476     HandleTimer(nil);
477 tony 21 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 tony 35 begin
503 tony 29 FTimer.Interval := 0;
504 tony 35 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 tony 21 end;
510    
511 tony 29 procedure TIBLookupComboEditBox.Loaded;
512     begin
513     inherited Loaded;
514     IBControlLinkChanged;
515     end;
516    
517 tony 27 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 tony 21 procedure TIBLookupComboEditBox.SetItemIndex(const Val: integer);
526     begin
527     inherited SetItemIndex(Val);
528     FLastKeyValue := KeyValue;
529     end;
530    
531 tony 27 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 tony 21 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 tony 27 FIBLookupControlLink := TIBLookupControlLink.Create(self);
554     FKeyPressInterval := 200;
555 tony 21 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 tony 27 if assigned(FIBLookupControlLink) then FIBLookupControlLink.Free;
566 tony 21 if assigned(FTimer) then FTimer.Free;
567     inherited Destroy;
568     end;
569    
570     procedure TIBLookupComboEditBox.EditingDone;
571     begin
572 tony 35 FForceAutoComplete := true;
573     try
574     if FTimer.Interval <> 0 then
575     HandleTimer(nil);
576     finally
577     FForceAutoComplete := false;
578     end;
579 tony 21 CheckAndInsert;
580     inherited EditingDone;
581     end;
582    
583     end.