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

# 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.