1{
2 /***************************************************************************
3                                 maskedit.pp
4                                 -----------
5                           Component Library Code
6
7 ***************************************************************************/
8
9 *****************************************************************************
10  This file is part of the Lazarus Component Library (LCL)
11
12  See the file COPYING.modifiedLGPL.txt, included in this distribution,
13  for details about the license.
14 *****************************************************************************
15}
16
17
18{
19ToDo List:
20 - Better handling of cut/clear/paste messages
21
22Bugs:
23 - The Delphi helpt text says that a '_' in EditMask will insert a blank in the text.
24   However all versions of Delphi up to D2010 treat it as a literal '_' (unless
25   specified in the 3rd field of a multifield EditMask), so I rewrote parts to make it behave like
26   that also.
27   If, in the future, Delphi actually treats '_' as a blank, we'll re-implement it, for that
28   purpose I did not remove the concerning code, but commented it out
29
30Known Utf8 related issues: (Oktober 2012, BB)
31 - Utf8 also has what is called de-composed code-points:
32   For example the "LATIN SMALL LETTER E WITH DIAERESIS" can be represented with a single codepoint
33   (U+00EB), but also by the sequence of codepoints  LATIN SMALL LETTER E (U+0065) +  COMBINING DIAERESIS (U+0308)
34   The latter form is not handled correctly ATM, but also does not occur much "in the wild"
35   (See discussion at the forum: http://forum.lazarus.freepascal.org/index.php/topic,10530.0.html)
36 - Some valid Utf8 sequences do not represent any visible character.
37   I have not been able to test how this affects the maskedit unit.
38
39
40Different behaviour than Delphi, but by design (October 2009, BB)
41 - In SetText in Delphi, when MaskNoSave is in EditMask, it is possible to set text longer then the mask
42   allowes for. I disallowed that, because it corrupts internal cursor placement etc.
43 - SetEditText is not Delphi compatible. Delphi allows setting any text in the control, leaving the control
44   in an unrecoverable state, where it is impossible to leave the control because the text can never be validated
45   (too short, too long, overwritten maskliterals). The app wil crash as a result of this.
46   I have decided to disallow this:
47   - EditText is truncated, or padded with ClearChar if necessary so that Utf8Length(EditText) = FMaskLength
48   - Restore all MaskLiterals in the text
49}
50
51unit MaskEdit;
52
53{$mode objfpc}{$H+}
54
55interface
56
57uses
58  Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs,
59  ExtCtrls, StdCtrls, LMessages, Clipbrd, LCLType, LCLProc, LCLStrConsts, LazUtf8;
60
61const
62  { Mask Type }
63  cMask_SpecialChar   = '\'; // after this you can set an arbitrary char
64  cMask_UpperCase     = '>'; // after this the chars is in upper case
65  cMask_LowerCase     = '<'; // after this the chars is in lower case
66  cMask_Letter        = 'l'; // only a letter but not necessary
67  cMask_LetterFixed   = 'L'; // only a letter
68  cMask_AlphaNum      = 'a'; // an alphanumeric char (['A'..'Z','a..'z','0'..'9']) but not necessary
69  cMask_AlphaNumFixed = 'A'; // an alphanumeric char
70  cMask_AllChars      = 'c'; // any Utf8 char but not necessary
71  cMask_AllCharsFixed = 'C'; // any Utf8 char #32 - #255
72  cMask_Number        = '9'; // only a number but not necessary
73  cMask_NumberFixed   = '0'; // only a number
74  cMask_NumberPlusMin = '#'; // only a number or + or -, but not necessary
75  cMask_HourSeparator = ':'; // automatically put the hour separator char
76  cMask_DateSeparator = '/'; // automatically but the date separator char
77{ cMask_SpaceOnly     = '_'; // automatically put a space          //not Delphi compatible        }
78  cMask_NoLeadingBlanks = '!'; //Trim leading blanks, otherwise trim trailing blanks from the data
79
80  {Delphi compatibility: user can change these at runtime}
81  DefaultBlank: Char = '_';
82  MaskFieldSeparator: Char = ';';
83  MaskNoSave: Char = '0';
84
85type
86  { Type for mask (internal) }
87  tMaskedType = (Char_Start,
88                 Char_Number,
89                 Char_NumberFixed,
90                 Char_NumberPlusMin,
91                 Char_Letter,
92                 Char_LetterFixed,
93                 Char_LetterUpCase,
94                 Char_LetterDownCase,
95                 Char_LetterFixedUpCase,
96                 Char_LetterFixedDownCase,
97                 Char_AlphaNum,
98                 Char_AlphaNumFixed,
99                 Char_AlphaNumUpCase,
100                 Char_AlphaNumDownCase,
101                 Char_AlphaNumFixedUpCase,
102                 Char_AlphaNumFixedDownCase,
103                 Char_All,
104                 Char_AllFixed,
105                 Char_AllUpCase,
106                 Char_AllDownCase,
107                 Char_AllFixedUpCase,
108                 Char_AllFixedDownCase,
109                {Char_Space,                 //not Delphi compatible, see notes above  }
110                 Char_HourSeparator,
111                 Char_DateSeparator,
112                 Char_Stop);
113
114
115  TInternalMask = array[1..255] of TUtf8Char;
116  TMaskeditTrimType = (metTrimLeft, metTrimRight);
117
118  { Exception class }
119type
120  EDBEditError = class(Exception);
121  //Utf8 handling errors
122  EInvalidUtf8 = class(Exception);
123  EInvalidCodePoint = class(EInvalidUtf8);
124
125const
126  SInvalidCodePoint = 'The (hexadecimal) sequence %s is not a valid UTF8 codepoint.';
127
128
129{ ***********************************************************************************************
130
131 Please leave in this note until it no longer applies!
132
133 FOR ANYONE WHO CARES TO FIX/ENHANCE THIS CODE:
134
135 Since we want total control over anything that is done to the text in the control
136 we have to take into consideration the fact that currently we cannot prevent
137 cutting/pasting/clearing or dragging selected text in the control, these are handled by the OS
138 and text is changed before we can prevent it.
139 Not all widgetsets currently handle the messages for cut/paste/clear. Actually we would
140 like to have a LM_BEFORE_PASTE (etc.) message...
141 If we allow the OS to cut/clear/paste etc. a situation can occur where mask-literals in the
142 control are changed with random chars (and cannot be undone) or text is shorter or larger than
143 the editmask calls for, which again cannot be undone.
144
145
146 So, as a horrible hack I decided  to only allow changing of the text if we coded
147 this change ourself. This is done by setting the FChangeAllowed field to True before any
148 write action (in RealSetTextWhileMasked() ).
149 We try to intercept the messages for cut/paste/copy/clear and perform the appropriate
150 actions instead.
151 If this fails, then in TextChanged we check and will see that FChangeAllowed = False
152 and we will undo the changes made.
153
154 To make this undo possible it is necessary to set FCurrentText every time you set
155 the text in the control!
156 This is achieved in RealSetTextWhileMasked() only, so please note:
157 !! It is unsafe to make a call to RealSetText unless done so via RealSetTextWhileMasked() !!!
158
159 (Bart Broersma, januari 2009)
160
161 ************************************************************************************************ }
162
163
164 { TCustomMaskEdit }
165
166 Type
167
168  TCustomMaskEdit = Class(TCustomEdit)
169  private
170    FRealMask        : String;            // Real mask inserted
171    FMask            : TInternalMask;     // Actual internal mask
172    FMaskLength      : Integer;           // Length of internal mask
173    FFirstFreePos    : Integer;           // First position where user can enter text
174    FMaskSave        : Boolean;           // Save mask as part of the data
175    FTrimType        : TMaskEditTrimType; // Trim leading or trailing spaces in GetText
176    FSpaceChar       : Char;              // Char for space (default '_')
177    FCurrentText     : TCaption;          // FCurrentText is our backup. See notes above!
178    FTextOnEnter     : String;            // Text when user enters the control, used for Reset()
179    FCursorPos       : Integer;           // Current caret position
180    FChangeAllowed   : Boolean;           // We do not allow text changes by the OS (cut/clear via context menu)
181    FInitialText     : String;            // Text set in the formdesigner (must be handled in Loaded)
182    FInitialMask     : String;            // EditMask set in the formdesigner (must be handled in Loaded)
183    FSettingInitialText: Boolean;
184    FValidationFailed: Boolean;           // Flag used in DoEnter
185    FMaskIsPushed    : Boolean;
186    FSavedMask       : TInternalMask;
187    FSavedMaskLength : Integer;
188    FTextChangedBySetText: Boolean;
189    FInRealSetTextWhileMasked: Boolean;
190
191    procedure ClearInternalMask(out AMask: TInternalMask; out ALengthIndicator: Integer);
192    procedure AddToMask(Value: TUtf8Char);
193    function GetModified: Boolean;
194    procedure SetMask(Value : String);
195    function  GetIsMasked : Boolean;
196    procedure SetModified(AValue: Boolean);
197    procedure SetSpaceChar(Value : Char);
198
199    procedure SetCursorPos;
200    procedure SelectNextChar;
201    procedure SelectPrevChar;
202    procedure SelectFirstChar;
203    procedure GotoEnd;
204    procedure JumpToNextDot(Dot: Char);
205    function  HasSelection: Boolean;
206    function  HasExtSelection: Boolean;
207
208    Function  CharToMask(UCh : TUtf8Char) : tMaskedType;
209    Function  MaskToChar(Value : tMaskedType) : Char;
210    Function  IsMaskChar(Ch : TUtf8Char) : Boolean;
211    Function  IsLiteral(Ch: TUtf8Char): Boolean;
212    function  TextIsValid(const Value: String): Boolean;
213    function  CharMatchesMask(const Ch: TUtf8Char; const Position: Integer): Boolean;
214    function  ClearChar(Position : Integer) : TUtf8Char;
215
216    procedure RealSetTextWhileMasked(const Value: TCaption); //See notes above!
217    procedure InsertChar(Ch : TUtf8Char);
218    Function  CanInsertChar(Position : Integer; Var Ch : TUtf8Char; IsPasting: Boolean = False) : Boolean;
219    procedure DeleteSelected;
220    procedure DeleteChars(NextChar : Boolean);
221  protected
222    function ApplyMaskToText(Value: TCaption): TCaption;
223    function CanShowEmulatedTextHint: Boolean; override;
224    function DisableMask(const NewText: String): Boolean;
225    function RestoreMask(const NewText: String): Boolean;
226    procedure RealSetText(const AValue: TCaption); override;
227    function RealGetText: TCaption; override;
228    Function GetTextWithoutMask(Value: TCaption) : TCaption;
229    function GetTextWithoutSpaceChar(Value: TCaption) : TCaption;
230    Procedure SetTextApplyMask(Value: TCaption);
231    function  GetEditText: string; virtual;
232    procedure SetEditText(const AValue: string);
233
234    procedure GetSel(out _SelStart: Integer; out _SelStop: Integer);
235    procedure SetSel(const _SelStart: Integer; _SelStop: Integer);
236    procedure TextChanged; override;
237    procedure Change; override;
238    procedure SetCharCase(Value: TEditCharCase);
239    function GetCharCase: TEditCharCase;
240    procedure SetMaxLength(Value: Integer);
241    function GetMaxLength: Integer;
242    procedure SetNumbersOnly(Value: Boolean); override;
243    procedure Loaded; override;
244
245    procedure LMPasteFromClip(var Message: TLMessage); message LM_PASTE;
246    procedure LMCutToClip(var Message: TLMessage); message LM_CUT;
247    procedure LMClearSel(var Message: TLMessage); message LM_CLEAR;
248
249    function  EditCanModify: Boolean; virtual;
250    procedure Reset; virtual;
251    procedure DoEnter; override;
252    procedure DoExit; override;
253    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
254    procedure HandleKeyPress(var Key: TUtf8Char);
255    procedure KeyPress(var Key: Char); override;
256    procedure Utf8KeyPress(var UTF8Key: TUTF8Char); override;
257    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
258
259    procedure CheckCursor;
260    property EditText: string read GetEditText write SetEditText;
261    property IsMasked: Boolean read GetIsMasked;
262    property SpaceChar: Char read FSpaceChar write SetSpaceChar;
263    property MaxLength: Integer read GetMaxLength write SetMaxLength;
264    property CharCase: TEditCharCase read GetCharCase write SetCharCase;
265    property EditMask: string read FRealMask write SetMask;
266  public
267    procedure CutToClipBoard; override;
268    procedure PasteFromClipBoard; override;
269    { Required methods }
270    constructor Create(TheOwner : TComponent); override;
271    procedure Clear;
272    procedure ValidateEdit; virtual;
273    property Modified: Boolean read GetModified write SetModified;
274  end;
275
276  { TMaskEdit }
277
278  TMaskEdit = class(TCustomMaskEdit)
279  public
280    property IsMasked;
281    property EditText;
282  published
283    property Align;
284    property Alignment;
285    property Anchors;
286    property AutoSelect;
287    property AutoSize;
288    property BiDiMode;
289    property BorderSpacing;
290    property BorderStyle;
291    property CharCase;
292    property Color;
293    property Constraints;
294    property DragCursor;
295    property DragKind;
296    property DragMode;
297    property Enabled;
298    property Font;
299    property MaxLength;
300    property ParentBiDiMode;
301    property ParentColor;
302    property ParentFont;
303    property ParentShowHint;
304    property PopupMenu;
305    property ReadOnly;
306    property ShowHint;
307    property TabOrder;
308    property TabStop;
309    property Visible;
310    property OnChange;
311    property OnClick;
312    property OnDblClick;
313    property OnDragDrop;
314    property OnDragOver;
315    property OnEditingDone;
316    property OnEndDock;
317    property OnEndDrag;
318    property OnEnter;
319    property OnExit;
320    property OnKeyDown;
321    property OnKeyPress;
322    property OnKeyUp;
323    property OnMouseDown;
324    property OnMouseEnter;
325    property OnMouseLeave;
326    property OnMouseMove;
327    property OnMouseUp;
328    property OnMouseWheel;
329    property OnMouseWheelDown;
330    property OnMouseWheelUp;
331    property OnStartDock;
332    property OnStartDrag;
333    property OnUTF8KeyPress;
334    property EditMask;
335    property Text;
336    property TextHint;
337    property SpaceChar;
338  end;
339
340function FormatMaskText(const AEditMask: string; const Value: string ): string;
341procedure SplitEditMask(AEditMask: String; out AMaskPart: String; out AMaskSave: Boolean; out ASpaceChar: Char);
342
343procedure Register;
344
345implementation
346
347
348//Define this to prevent validation when the control looses focus
349{ $DEFINE MASKEDIT_NOVALIDATEONEXIT}
350
351{$ifdef debug_maskedit}
352// For debugging purposes only
353const
354  MaskCharToChar: array[tMaskedType] of Char = (#0, cMask_Number, cMask_NumberFixed, cMask_NumberPlusMin,
355     cMask_Letter, cMask_LetterFixed, cMask_Letter, cMask_Letter, cMask_LetterFixed, cMask_LetterFixed,
356     cMask_AlphaNum, cMask_AlphaNumFixed, cMask_AlphaNum, cMask_AlphaNum, cMask_AlphaNumFixed, cMask_AlphaNumFixed,
357     cMask_AllChars, cMask_AllCharsFixed, cMask_AllChars, cMask_AllChars, cMask_AllCharsFixed, cMask_AllCharsFixed,
358     (*cMask_SpaceOnly,*) cMask_HourSeparator, cMask_DateSeparator, #0);
359{$endif}
360
361const
362  Period = '.';
363  Comma = ',';
364
365//Utf8 helper functions
366
367function GetCodePoint(const S: String; const Index: PtrInt): TUTF8Char;
368//equivalent for Result := S[Index], but for Utf8 encoded strings
369var
370  p: PChar;
371  PLen: PtrInt;
372  Res: AnsiString; //intermediate needed for PChar -> String -> ShortString assignement
373begin
374  Result := '';
375  p := UTF8CodepointStart(PChar(S), Length(S), Index - 1); //zero-based call
376  //determine the length in bytes of this UTF-8 character
377  PLen := UTF8CodepointSize(p);
378  Res := p;
379  //Set correct length for Result (otherwise it returns all chars up to the end of the original string)
380  SetLength(Res,PLen);
381  Result := Res;
382end;
383
384function StringToHex(S: String): String;
385var
386  i: Integer;
387begin
388  Result := '';
389  for i := 1 to length(S) do Result := Result + '$' + IntToHex(Ord(S[i]),2);
390end;
391
392procedure SetCodePoint(var S: String; const Index: PtrInt; CodePoint: TUTF8Char);
393//equivalent for S[Index] := CodePoint, but for Utf8 encoded strings
394var
395  OldCP: TUTF8Char;
396begin
397  if (Index > Utf8Length(S)) then Exit;
398  if (Utf8Length(CodePoint) <> 1) then Raise EInvalidCodePoint.Create(Format(SInvalidCodepoint,[StringToHex(CodePoint)]));
399  OldCP := GetCodePoint(S, Index);
400  if (OldCP = CodePoint) then Exit;
401  Utf8Delete(S, Index, 1);
402  Utf8Insert(CodePoint, S, Index);
403end;
404
405
406
407function FormatMaskText(const AEditMask: string; const Value: string): string;
408var
409  CME: TCustomMaskEdit;
410begin
411  CME := TCustomMaskEdit.Create(nil);
412  try
413    CME.EditMask := AEditMask;
414    if CME.IsMasked then
415    begin
416      Result := CME.ApplyMaskToText(Value);
417      //Delphi 7 leaves in the mask regardless of the "MaskSave" value in the specified EditMaske
418      //but SpaceChar must be replaced by #32
419      Result := CME.GetTextWithoutSpaceChar(Result);
420    end
421    else
422      Result := Value;
423  finally
424    CME.Free;
425  end;
426end;
427
428procedure SplitEditMask(AEditMask: String; out AMaskPart: String; out AMaskSave: Boolean; out ASpaceChar: Char);
429{
430  Retrieve the separate fields for a given EditMask:
431  Given an AEditMask of '999.999;0;_'  it will return
432  - AMaskPart = '999.999'
433  - AMaskSave = False
434  - ASpaceChar = '_'
435}
436begin
437  {
438    First see if AEditMask is multifield and if we can extract a value for
439    AMaskSave and/or ASpaceChar
440    If so, extract and remove from AMask (so we know that the remaining part of
441    AMask _IS_ the mask to be set)
442
443    A value for SpaceChar is only valid if also a value for MaskSave is specified
444    (as by Delphi specifications), so Mask must be at least 4 characters
445    These must be the last 2 or 4 characters of EditMask (and there must not be
446    an escape character in front!)
447  }
448  //Assume no SpaceChar and no MaskSave is defined in new mask, so first set it to DefaultBlank and True
449  ASpaceChar := DefaultBlank;
450  AMaskSave := True;
451  //MaskFieldseparator, MaskNoSave, SpaceChar and cMask_SpecialChar are defined as Char (=AnsiChar)
452  //so in this case we can use Length (instead of Utf8length) and iterate single chars in the string
453  if (Length(AEditMask) >= 4) and (AEditMask[Length(AEditMask)-1] = MaskFieldSeparator) and
454     (AEditMask[Length(AEditMask)-3] = MaskFieldSeparator) and
455     (AEditMask[Length(AEditMask)-2] <> cMask_SpecialChar) and
456     //Length = 4 is OK (AEditMask = ";1;_" for example), but if Length > 4 there must be no escape charater in front
457     ((Length(AEditMask) = 4) or ((Length(AEditMask) > 4) and (AEditMask[Length(AEditMask)-4] <> cMask_SpecialChar))) then
458  begin
459    ASpaceChar := AEditMask[Length(AEditMask)];
460    AMaskSave := (AEditMask[Length(AEditMask)-2] <> MaskNosave);
461    System.Delete(AEditMask,Length(AEditMask)-3,4);
462  end
463  //If not both FMaskSave and FSPaceChar are specified, then see if only FMaskSave is specified
464  else if (Length(AEditMask) >= 2) and (AEditMask[Length(AEditMask)-1] = MaskFieldSeparator) and
465          //Length = 2 is OK, but if Length > 2 there must be no escape charater in front
466          ((Length(AEditMask) = 2) or ((Length(AEditMask) > 2) and (AEditMask[Length(AEditMask)-2] <> cMask_SpecialChar))) then
467  begin
468    AMaskSave := (AEditMask[Length(AEditMask)] <> MaskNoSave);
469    //Remove this bit from Mask
470    System.Delete(AEditMask,Length(AEditMask)-1,2);
471  end;
472  //Whatever is left of AEditMask at this point is the MaskPart
473  AMaskPart := AEditMask;
474end;
475
476
477// Create object
478constructor TCustomMaskEdit.Create(TheOwner: TComponent);
479begin
480  FSettingInitialText := False;
481  FTextChangedBySetText := False;
482  FInRealSetTextWhileMasked := False;
483  FRealMask      := '';
484  ClearInternalMask(FMask, FMaskLength);
485  ClearInternalMask(FSavedMask, FSavedMaskLength);
486  FSpaceChar     := '_';
487  FMaskSave      := True;
488  FChangeAllowed := False;
489  FTrimType      := metTrimRight;
490  Inherited Create(TheOwner);
491  FCurrentText   := Inherited RealGetText;
492  FTextOnEnter   := Inherited RealGetText;
493  FInitialText   := '';
494  FInitialMask   := '';
495  FValidationFailed := False;
496  FMaskIsPushed := False;
497end;
498
499procedure TCustomMaskEdit.ClearInternalMask(out AMask: TInternalMask; out ALengthIndicator: Integer);
500begin
501  {$PUSH}{$HINTS OFF}
502  FillChar(AMask, SizeOf(TInternalMask), 0);
503  ALengthIndicator := 0;
504  {$POP}
505end;
506
507procedure TCustomMaskEdit.AddToMask(Value: TUtf8Char);
508begin
509  Inc(FMaskLength);
510  FMask[FMaskLength] := Value;
511end;
512
513function TCustomMaskEdit.GetModified: Boolean;
514begin
515  //This will make Modified = False inside OnChange when text is set by code
516  //TCustomEdit.RealSetText sets Modified to False.
517  //We handle all input in RealSetTextWhileMasked (which eventually calls RealSetText),
518  //so inside RealSetTextWhileMasked Modified must be True,
519  //unless we called RealSetTextWhileMasked from SetTextApplyMask, in that case it must be False,
520  //in all other cases just return inherited value
521  if FTextChangedBySetText then
522    Result := False
523  else
524  begin
525    if FInRealSetTextWhileMasked then
526      Result := True
527    else
528      Result := inherited Modified;
529  end;
530end;
531
532// Prepare the real internal Mask
533procedure TCustomMaskEdit.SetMask(Value : String);
534Var
535  S            : ShortString;
536  I            : Integer;
537  InUp, InDown : Boolean;
538  Special      : Boolean;
539  CP           : TUtf8Char;
540begin
541  //Setting Mask while loading has unexpected and unwanted side-effects
542  if (csLoading in ComponentState) then
543  begin
544    FInitialMask := Value;
545    Exit;
546  end;
547  if FRealMask <> Value then
548  begin
549    FRealMask := Value;
550    FValidationFailed := False;
551    FMaskIsPushed := False;
552    ClearInternalMask(FMask, FMaskLength);
553    ClearInternalMask(FSavedMask, FSavedMaskLength);
554
555    SplitEditMask(FRealMask, Value, FMaskSave, FSpaceChar);
556
557    // Construct Actual Internal Mask
558    // init
559    FTrimType := metTrimRight;
560    // Init: No UpCase, No LowerCase, No Special Char
561    InUp      := False;
562    InDown    := False;
563    Special   := False;
564    S         := Value;
565    for I := 1 To Utf8Length(S) do
566    begin
567      CP := GetCodePoint(S,I);
568      // Must insert a special char
569      if Special then
570      begin
571        AddToMask(CP);
572        Special := False;
573      end
574      else
575      begin
576        // Check the char to insert
577
578        case CP Of
579             cMask_SpecialChar: Special := True;
580             cMask_UpperCase: begin
581               if (I > 1) and (GetCodePoint(S,I-1) = cMask_LowerCase) then
582               begin// encountered <>, so no case checking after this
583                 InUp := False;
584                 InDown := False
585               end else
586               begin
587                 InUp    := True;
588                 InDown := False;
589               end;
590             end;
591
592             cMask_LowerCase: begin
593                InDown  := True;
594                InUp := False;
595                // <> is catched by next cMask_Uppercase
596             end;
597
598             cMask_Letter: begin
599                if InUp
600                then
601                  AddToMask(MaskToChar(Char_LetterUpCase))
602                else
603                  if InDown
604                  then
605                    AddToMask(MaskToChar(Char_LetterDownCase))
606                  else
607                    AddToMask(MaskToChar(Char_Letter))
608             end;
609
610             cMask_LetterFixed: begin
611                if InUp
612                then
613                  AddToMask(MaskToChar(Char_LetterFixedUpCase))
614                else
615                  if InDown
616                  then
617                    AddToMask(MaskToChar(Char_LetterFixedDownCase))
618                  else
619                    AddToMask(MaskToChar(Char_LetterFixed))
620             end;
621
622             cMask_AlphaNum: begin
623                 if InUp
624                 then
625                   AddToMask(MaskToChar(Char_AlphaNumUpcase))
626                 else
627                   if InDown
628                   then
629                     AddToMask(MaskToChar(Char_AlphaNumDownCase))
630                   else
631                     AddToMask(MaskToChar(Char_AlphaNum))
632             end;
633
634             cMask_AlphaNumFixed: begin
635                 if InUp
636                 then
637                   AddToMask(MaskToChar(Char_AlphaNumFixedUpcase))
638                 else
639                   if InDown
640                   then
641                     AddToMask(MaskToChar(Char_AlphaNumFixedDownCase))
642                   else
643                     AddToMask(MaskToChar(Char_AlphaNumFixed))
644             end;
645
646             cMask_AllChars: begin
647                if InUp
648                then
649                  AddToMask(MaskToChar(Char_AllUpCase))
650                else
651                  if InDown
652                  then
653                    AddToMask(MaskToChar(Char_AllDownCase))
654                  else
655                    AddToMask(MaskToChar(Char_All))
656             end;
657
658             cMask_AllCharsFixed: begin
659                if InUp
660                then
661                  AddToMask(MaskToChar(Char_AllFixedUpCase))
662                else
663                  if InDown
664                  then
665                    AddToMask(MaskToChar(Char_AllFixedDownCase))
666                  else
667                    AddToMask(MaskToChar(Char_AllFixed))
668             end;
669
670             cMask_Number: AddToMask(MaskToChar(Char_Number));
671
672             cMask_NumberFixed: AddToMask(MaskToChar(Char_NumberFixed));
673
674             cMask_NumberPlusMin: AddToMask(MaskToChar(Char_NumberPlusMin));
675
676             cMask_HourSeparator: AddToMask(MaskToChar(Char_HourSeparator));
677
678             cMask_DateSeparator: AddToMask(MaskToChar(Char_DateSeparator));
679
680            {cMask_SpaceOnly: AddToMask(MaskToChar(Char_Space)); //not Delphi compatible, see remarks above}
681
682             cMask_NoLeadingBlanks:
683             begin
684               FTrimType := metTrimLeft;
685             end;
686
687             else
688             begin
689               //It's a MaskLiteral
690               AddToMask(CP);
691             end;
692        end;
693      end;
694    end;
695    FFirstFreePos := 1;
696    //Determine first position where text can be entered (needed for DeleteChars()
697    while (FFirstFreePos <= FMaskLength) and IsLiteral(FMask[FFirstFreePos])  do Inc(FFirstFreePos);
698    if (FMaskLength > 0) then
699    begin
700      SetCharCase(ecNormal);
701      SetNumbersOnly(False);
702    end;
703    //SetMaxLegth must be before Clear, otherwise Clear uses old MaxLength value!
704    SetMaxLength(FMaskLength);
705    Clear;
706    FTextOnEnter := inherited RealGetText;
707  end;
708end;
709
710
711// Return if mask is selected
712function TCustomMaskEdit.GetIsMasked : Boolean;
713begin
714  Result := (FMaskLength > 0);
715end;
716
717procedure TCustomMaskEdit.SetModified(AValue: Boolean);
718begin
719  inherited Modified := AValue;
720end;
721
722
723// Set the current Space Char
724procedure TCustomMaskEdit.SetSpaceChar(Value : Char);
725Var
726  S      : String;
727  I      : Integer;
728  OldValue: TUtf8Char;
729Begin
730  if (Value <> FSpaceChar) And
731  ((Not IsMaskChar(Value)) {or (CharToMask(Value) = Char_Space)}) then
732  begin
733    OldValue := FSpaceChar;
734    FSpaceChar := Value;
735    if IsMasked then
736    begin
737      S := inherited RealGetText;
738      for I := 1 to Utf8Length(S) do
739      begin
740        if (GetCodePoint(S,i) = OldValue) and (not IsLiteral(FMask[i])) then SetCodePoint(S,i,FSpaceChar);
741        //also update FTextOnEnter to reflect new SpaceChar!
742        if (GetCodePoint(FTextOnEnter,i) = OldValue) and (not IsLiteral(FMask[i])) then SetCodePoint(FTextOnEnter,i,FSpaceChar);
743      end;
744      //FCurrentText := S;
745      RealSetTextWhileMasked(S);
746      CheckCursor;
747    end;
748  end;
749end;
750
751
752
753
754// Set the cursor position and select the char in the control
755procedure TCustomMaskEdit.SetCursorPos;
756begin
757  //no need to do this when in designmode, it actually looks silly if we do
758  if not (csDesigning in ComponentState) then
759  begin
760    if FCursorPos < 0 then FCursorPos := 0
761    else if FCursorPos  > FMaskLength then FCursorPos := FMaskLength;
762    if (FCursorPos + 1 > FMaskLength) or not Focused then
763      SetSel(FCursorPos, FCursorPos)
764    else
765      SetSel(FCursorPos, FCursorPos + 1);
766  end;
767end;
768
769//Move to next char, skip any mask-literals
770procedure TCustomMaskEdit.SelectNextChar;
771begin
772  if (FCursorPos + 1) > FMaskLength then Exit;
773  Inc(FCursorPos);
774  While (FCursorPos + 1 < FMaskLength) and (IsLiteral(FMask[FCursorPos + 1])) do
775  begin
776    Inc(FCursorPos);
777  end;
778  if IsLiteral(FMask[FCursorPos + 1]) then Inc(FCursorPos);
779  SetCursorPos;
780end;
781
782//Move to previous char, skip any mask-literals
783procedure TCustomMaskEdit.SelectPrevChar;
784var
785  P: LongInt;
786  AStart: Integer;
787  AStop: Integer;
788begin
789  GetSel(AStart, AStop);
790  if (FCursorPos = 0) and (AStop - AStart <= 1) then Exit;
791  P := FCursorPos;
792  Dec(FCursorPos);
793  While (FCursorPos > 0) and IsLiteral(FMask[FCursorPos + 1]) do
794  begin
795    Dec(FCursorPos);
796  end;
797  if (FCursorPos = 0) and (P <> 0) and IsLiteral(FMask[FCursorPos + 1]) then FCursorPos := P;
798  SetCursorPos;
799end;
800
801
802procedure TCustomMaskEdit.SelectFirstChar;
803begin
804  FCursorPos := 0;
805  SetCursorPos;
806end;
807
808procedure TCustomMaskEdit.GotoEnd;
809begin
810  FCursorPos := FMaskLength;
811  SetCursorPos;
812end;
813
814//Jump to next period or comma if possible, otherwise do nothing
815procedure TCustomMaskEdit.JumpToNextDot(Dot: Char);
816{
817  Jumping occurs only if
818  - Dot must be in the mask
819  - There is a Dot after the current cursorposition
820  - If the mask contains both periods and comma's, only the first one
821    is jumpable
822  - There is no literal after the next dot
823  - The next dot is not the last character in the mask
824}
825  function MaskPos(Sub: TUtf8Char; Start: Integer): Integer;
826  var
827    i: Integer;
828  begin
829    Result := 0;
830    for i := Start to FMaskLength do
831    begin
832      if (FMask[i] = Sub) then
833      begin
834        Result := i;
835        exit;
836      end;
837    end;
838  end;
839
840var
841  HasNextDot, HasCommaAndPeriod, CanJump: Boolean;
842  P, P2: Integer;
843begin
844  if not (Dot in [Period, Comma]) then Exit;
845  P := MaskPos(Dot, FCursorPos + 1);
846  HasNextDot := P > 0;
847  If (Dot = Period) then
848  begin
849    P2 := MaskPos(Comma, 1);
850    HasCommaAndPeriod := HasNextDot and (P2 >0)
851  end
852  else
853  begin
854    P2 := MaskPos(Period, 1);
855    HasCommaAndPeriod := HasNextDot and (P2 >0);
856  end;
857  if HasCommaAndPeriod then
858  begin
859    //When mask has both period and comma only the first occurence is jumpable
860    if P2 < P then HasNextDot := False;
861  end;
862  CanJump := HasNextDot and (P < FMaskLength) and (not IsLiteral(FMask[P+1]));
863  if CanJump then
864  begin
865    FCursorPos := P;
866    SetCursorPos;
867  end;
868end;
869
870function TCustomMaskEdit.HasSelection: Boolean;
871begin
872  Result := (GetSelLength() > 0);
873end;
874
875//Return True if Selection > 1, this influences the handling of Backspace
876function TCustomMaskEdit.HasExtSelection: Boolean;
877begin
878  Result := (GetSelLength() > 1);
879end;
880
881
882// Get the current selection
883procedure TCustomMaskEdit.GetSel(out _SelStart: Integer; out _SelStop: Integer);
884begin
885  _SelStart:= GetSelStart();
886  _SelStop:= _SelStart + GetSelLength();
887end;
888
889// Set the current selection
890procedure TCustomMaskEdit.SetSel(const _SelStart: Integer; _SelStop: Integer);
891begin
892  //in GTK if SelLength <> 0 then setting SelLength also changes SelStart
893  SetSelLength(0);
894  SetSelStart(_SelStart);
895  SetSelLength(_SelStop - _SelStart);
896end;
897
898
899// Transform a single char in a MaskType
900function TCustomMaskEdit.CharToMask(UCh: TUtf8Char): tMaskedType;
901var
902  Ch: Char;
903Begin
904  Result := Char_Start;
905  if (Length(UCh) <> 1) then exit;
906  Ch := UCh[1];
907  if (Ord(Ch) > Ord(Char_Start)) and
908     (Ord(Ch) < Ord(Char_Stop) )
909     then
910       Result := tMaskedType(Ord(Ch));
911End;
912
913
914// Trasform a single MaskType into a char
915function TCustomMaskEdit.MaskToChar(Value: tMaskedType): Char;
916Begin
917  Result := Char(Ord(Value));
918End;
919
920
921// Return if the char passed is a valid MaskType char
922function TCustomMaskEdit.IsMaskChar(Ch: TUtf8Char): Boolean;
923Begin
924  Result := (CharToMask(Ch) <> Char_Start);
925End;
926
927
928//Return if the char passed is a literal (so it cannot be altered)
929function TCustomMaskEdit.IsLiteral(Ch: TUtf8Char): Boolean;
930begin
931  Result := (not IsMaskChar(Ch)) or
932    (IsMaskChar(Ch) and (CharToMask(Ch) in [Char_HourSeparator, Char_DateSeparator{, Char_Space}]))
933end;
934
935
936//Return if Value matches the EditMask
937function TCustomMaskEdit.TextIsValid(const Value: String): Boolean;
938var
939  i: Integer;
940begin
941  Result := False;
942  if (Utf8Length(Value) <> FMaskLength) then
943  begin
944    //DebugLn('  Utf8Length(Value) = ',DbgS(Utf8Length(Value)),' FMaskLength = ',DbgS(FMaskLength));
945    Exit; //Actually should never happen??
946  end;
947  for i := 1 to FMaskLength do
948  begin
949    if not CharMatchesMask(GetCodePoint(Value, i), i) then Exit;
950  end;
951  Result := True;
952end;
953
954
955function TCustomMaskEdit.CharMatchesMask(const Ch: TUtf8Char; const Position: Integer): Boolean;
956var
957  Current: tMaskedType;
958  Ok: Boolean;
959begin
960  Result := False;
961  if (Position < 1) or (Position > FMaskLength) then Exit;
962  Current := CharToMask(FMask[Position]);
963  case Current Of
964    Char_Number              : OK := (Length(Ch) = 1) and (Ch[1] In ['0'..'9',#32]);
965    Char_NumberFixed         : OK := (Length(Ch) = 1) and (Ch[1] In ['0'..'9']);
966    Char_NumberPlusMin       : OK := (Length(Ch) = 1) and (Ch[1] in ['0'..'9','+','-',#32]);
967    Char_Letter              : OK := (Length(Ch) = 1) and (Ch[1] In ['a'..'z', 'A'..'Z',#32]);
968    Char_LetterFixed         : OK := (Length(Ch) = 1) and (Ch[1] In ['a'..'z', 'A'..'Z']);
969    Char_LetterUpCase        : OK := (Length(Ch) = 1) and (Ch[1] In ['A'..'Z',#32]);
970    Char_LetterDownCase      : OK := (Length(Ch) = 1) and (Ch[1] In ['a'..'z',#32]);
971    Char_LetterFixedUpCase   : OK := (Length(Ch) = 1) and (Ch[1] In ['A'..'Z']);
972    Char_LetterFixedDownCase : OK := (Length(Ch) = 1) and (Ch[1] In ['a'..'z']);
973    Char_AlphaNum            : OK := (Length(Ch) = 1) and (Ch[1] in ['a'..'z', 'A'..'Z', '0'..'9',#32]);
974    Char_AlphaNumFixed       : OK := (Length(Ch) = 1) and (Ch[1] in ['a'..'z', 'A'..'Z', '0'..'9']);
975    Char_AlphaNumUpCase      : OK := (Length(Ch) = 1) and (Ch[1] in ['A'..'Z', '0'..'9',#32]);
976    Char_AlphaNumDownCase    : OK := (Length(Ch) = 1) and (Ch[1] in ['a'..'z', '0'..'9',#32]);
977    Char_AlphaNumFixedUpCase : OK := (Length(Ch) = 1) and (Ch[1] in ['A'..'Z', '0'..'9']);
978    Char_AlphaNumFixedDowncase:OK := (Length(Ch) = 1) and (Ch[1] in ['a'..'z', '0'..'9']);
979    //ToDo: make this UTF8 compatible, for now
980    //limit this to lower ASCII set
981    Char_All                 : OK := True; //Ch in [#32..#126]; //True;
982    Char_AllFixed            : OK := True; //Ch in [#32..#126]; //True;
983    Char_AllUpCase           : OK := True; //Ch in [#32..#126]; // (Utf8UpperCase(Ch) = Ch);             ???????
984    Char_AllDownCase         : OK := True; //Ch in [#32..#126]; // (Utf8LowerCase(Ch) = Ch);             ???????
985    Char_AllFixedUpCase      : OK := True; //Ch in [#32..#126]; // (Utf8UpperCase(Ch) = Ch);             ???????
986    Char_AllFixedDownCase    : OK := True; //Ch in [#32..#126]; // (Utf8LowerCase(Ch) = Ch);             ???????
987   {Char_Space               : OK := (Length(Ch) = 1) and (Ch in [' ', '_']);  //not Delphi compatible, see notes above}
988    Char_HourSeparator       : OK := (Ch = DefaultFormatSettings.TimeSeparator);
989    Char_DateSeparator       : OK := (Ch = DefaultFormatSettings.DateSeparator);
990    else//it's a literal
991    begin
992      OK := (Ch = FMask[Position]);
993    end;
994  end;//case
995  //DebugLn('Position = ',DbgS(Position),' Current = ',MaskCharToChar[Current],' Ch = "',Ch,'" Ok = ',DbgS(Ok));
996  Result := Ok;
997end;
998
999
1000//Set text in the control with FChangeAllowed flag set appropriately
1001procedure TCustomMaskEdit.RealSetTextWhileMasked(const Value: TCaption);
1002begin
1003  if (Value <> inherited RealGetText) then
1004  begin
1005    FInRealSetTextWhileMasked := True;
1006    FChangeAllowed := True;
1007    FCurrentText := Value;
1008    //protect resetting FChangeAllowed := False against unhandled exceptions in user's
1009    //OnChange, otherwise risk leaving the control in an "unsafe" state regarding text changes
1010    try
1011      Inherited RealSetText(Value);
1012    finally
1013      FChangeAllowed := False;
1014      FInRealSetTextWhileMasked := False;
1015    end;//finally
1016  end;
1017end;
1018
1019// Save current mask, then disable mask
1020// This gives developers the possibility to set any text in the control _without_ messing up the control
1021// Wether or not the function succeeds: NewText will be set as the new text of the control
1022// No need to save FMaskSave and FTrimtype, they are only set in SetMask, which sets MaskIsPushed := False
1023function TCustomMaskEdit.DisableMask(const NewText: String): Boolean;
1024begin
1025  if IsMasked and (not FMaskIsPushed) then
1026  begin
1027    ClearInternalMask(FSavedMask, FSavedMaskLength);
1028    System.Move(FMask[1], FSavedMask[1], SizeOf(TInternalMask));
1029    FSavedMaskLength := FMaskLength;
1030    ClearInternalMask(FMask, FMaskLength);
1031    FMaskIsPushed := True;
1032    SetMaxLength(0);
1033    Result := True;
1034  end
1035  else
1036  begin
1037    Result := False;
1038  end;
1039  Text := NewText;
1040end;
1041
1042// Restore a saved mask
1043function TCustomMaskEdit.RestoreMask(const NewText: String): Boolean;
1044begin
1045  if FMaskIsPushed and (not IsMasked) then
1046  begin
1047    FMaskIsPushed := False;
1048    SetCharCase(ecNormal);
1049    ClearInternalMask(FMask, FMaskLength);
1050    System.Move(FSavedMask[1], FMask[1], SizeOf(TInternalMask));
1051    FMaskLength := FSavedMaskLength;
1052    ClearInternalMask(FSavedMask, FSavedMaskLength);
1053    SetMaxLength(FMaskLength);
1054    FTextOnEnter := inherited RealGetText;
1055    Result := True;
1056  end
1057  else
1058  begin
1059    Result := False;
1060  end;
1061  // if NewText = old Text AND the control is now masked,
1062  // then "Text := NewText" will do nothing,
1063  // and NO mask will appear, so Clear first ...
1064  if IsMasked then Clear;
1065  Text := NewText;
1066end;
1067
1068procedure TCustomMaskEdit.RealSetText(const AValue: TCaption);
1069begin
1070  //Setting Text while loading has unwanted side-effects
1071  if (csLoading in ComponentState) {and (not FSettingInitialText)} then
1072  begin
1073    FInitialText := AValue;
1074    Exit;
1075  end;
1076  if not IsMasked then
1077    inherited RealSetText(AValue)
1078  else
1079    SetTextApplyMask(AValue);
1080end;
1081
1082function TCustomMaskEdit.RealGetText: TCaption;
1083begin
1084  Result := inherited RealGetText;  //don't call GetEditText here (issue #0026924)
1085  if IsMasked then
1086    Result := GetTextWithoutMask(Result);
1087end;
1088
1089// Set the actual Text
1090procedure TCustomMaskEdit.SetTextApplyMask(Value: TCaption);
1091var
1092  S: TCaption;
1093Begin
1094  if IsMasked then
1095  begin
1096    try
1097      FTextChangedBySetText := True;
1098      if (Value = '') then
1099      begin
1100        Clear;
1101        Exit;
1102      end;
1103      S := ApplyMaskToText(Value);
1104      RealSetTextWhileMasked(S);
1105    finally
1106      FTextChangedBySetText := False;
1107    end; //try..finally
1108  end//Ismasked
1109  else
1110  begin//not IsMasked
1111    RealSetTextWhileMasked(Value);
1112  end;
1113End;
1114
1115
1116function TCustomMaskEdit.GetEditText: string;
1117begin
1118  Result := Inherited RealGetText;
1119end;
1120
1121
1122
1123procedure TCustomMaskEdit.SetEditText(const AValue: string);
1124//Note: This is not Delphi compatible, but by design
1125//Delphi lets you just set EditText of any length, which is extremely dangerous!
1126var
1127  S: String;
1128  i: Integer;
1129  {$if fpc_fullversion < 30202}
1130  OldS: String;
1131  ULen: PtrInt;
1132  ClearCh: TUTF8Char;
1133  {$endif}
1134begin
1135  if (not IsMasked) then
1136  begin
1137    Inherited RealsetText(AValue);
1138  end
1139  else
1140  begin
1141    //Make sure we don't copy more or less text into the control than FMask allows for
1142    S := Utf8Copy(AValue, 1, FMaskLength);
1143    //Restore all MaskLiterals, or we will potentially leave the control
1144    //in an unrecoverable state, eventually crashing the app
1145    for i := 1 to Utf8Length(S) do
1146      if IsLiteral(FMask[i]) then SetCodePoint(S,i,ClearChar(i));
1147    //Pad resulting string with ClearChar if text is too short
1148    {$if fpc_fullversion >= 30202}
1149    while Utf8Length(S) < FMaskLength do S := S + ClearChar(Utf8Length(S)+1);
1150    {$else}
1151    //workaround for fpc issue #0038337
1152    //Utf8Length(S) corrupts S, so concatenation with ClearChar() fails, leading to an endless loop.
1153    //See issue #0038505
1154    while Utf8Length(S) < FMaskLength do
1155    begin
1156      OldS := S;
1157      ULen := Utf8Length(S);
1158      ClearCh := ClearChar(Ulen+1);
1159      //DbgOut(['TCustomMaskEdit.SetEditText: S="',S,'", Utf8Length(S)=',ULen,', FMaskLength=',FMaskLength,', ClearChar(',Ulen+1,')=',ClearCh]);
1160      S := OldS + ClearCh;
1161      //debugln(' --> S:',S);
1162    end;
1163    {$endif}
1164    RealSetTextWhileMasked(S);
1165  end;
1166end;
1167
1168
1169// Clear (virtually) a single Utf8 char in position Position
1170function TCustomMaskEdit.ClearChar(Position : Integer) : TUtf8Char;
1171begin
1172  Result := FMask[Position];
1173  //For Delphi compatibilty, only literals remain, all others will be blanked
1174  case CharToMask(FMask[Position]) Of
1175    Char_Number,
1176    Char_NumberFixed,
1177    Char_NumberPlusMin,
1178    Char_Letter,
1179    Char_LetterFixed,
1180    Char_LetterUpCase,
1181    Char_LetterDownCase,
1182    Char_LetterFixedUpCase,
1183    Char_LetterFixedDownCase,
1184    Char_AlphaNum,
1185    Char_AlphaNumFixed,
1186    Char_AlphaNumUpCase,
1187    Char_AlphaNumDownCase,
1188    Char_AlphaNumFixedUpcase,
1189    Char_AlphaNuMFixedDownCase,
1190    Char_All,
1191    Char_AllFixed,
1192    Char_AllUpCase,
1193    Char_AllDownCase,
1194    Char_AllFixedUpCase,
1195    Char_AllFixedDownCase     : Result := FSpaceChar;
1196    {Char_Space               : Result := #32; //FSpaceChar?; //not Delphi compatible, see notes above}
1197     Char_HourSeparator       : Result := DefaultFormatSettings.TimeSeparator;
1198     Char_DateSeparator       : Result := DefaultFormatSettings.DateSeparator;
1199  end;
1200end;
1201
1202
1203
1204//Insert a single Utf8 char at the current position of the cursor
1205procedure TCustomMaskEdit.InsertChar(Ch : TUtf8Char);
1206Var
1207  S: String;
1208  i, SelectionStart, SelectionStop: Integer;
1209begin
1210  if CanInsertChar(FCursorPos + 1, Ch) then
1211  begin
1212    S := inherited RealGetText;
1213    if HasSelection then
1214    begin
1215      //replace slection with blank chars
1216      //don't do this via DeleteChars(True), since it will do an unneccesary
1217      //update of the control and 2 TextChanged's are triggerd for every char we enter
1218      GetSel(SelectionStart, SelectionStop);
1219      for i := SelectionStart + 1 to SelectionStop do SetCodePoint(S, i, ClearChar(i));
1220    end;
1221    SetCodePoint(S, FCursorPos + 1, Ch);
1222    RealSetTextWhileMasked(S);
1223    SelectNextChar;
1224  end
1225  else
1226  //If we have a selection > 1 (and cannot insert) then Delete the selected text: Delphi compatibility
1227  if HasExtSelection then DeleteSelected;
1228end;
1229
1230
1231//Check if a Utf8 char can be inserted at position Position, also do case conversion if necessary
1232function TCustomMaskEdit.CanInsertChar(Position: Integer; var Ch: TUtf8Char;
1233  IsPasting: Boolean = False): Boolean;
1234Var
1235  Current : tMaskedType;
1236Begin
1237  Current := CharToMask(FMask[Position]);
1238  Result  := False;
1239
1240  // If in UpCase convert the input char
1241  if (Current = Char_LetterUpCase     ) Or
1242     (Current = Char_LetterFixedUpCase) Or
1243     (Current = Char_AllUpCase        ) Or
1244     (Current = Char_AllFixedUpCase   ) or
1245     (Current = Char_AlphaNumUpcase   ) or
1246     (Current = Char_AlphaNumFixedUpCase)
1247     then
1248       Ch := Utf8UpperCase(Ch);
1249
1250  // If in LowerCase convert the input char
1251  if (Current = Char_LetterDownCase     ) Or
1252     (Current = Char_LetterFixedDownCase) Or
1253     (Current = Char_AllDownCase        ) Or
1254     (Current = Char_AllFixedDownCase   ) or
1255     (Current = Char_AlphaNumDownCase   ) or
1256     (Current = Char_AlphaNumFixedDownCase )
1257     then
1258       Ch := Utf8LowerCase(Ch);
1259
1260  // Check the input (check the valid range)
1261  case Current Of
1262       Char_Number              : Result := (Length(Ch) = 1) and (Ch[1] In ['0'..'9']);
1263       Char_NumberFixed         : Result := (Length(Ch) = 1) and (Ch[1] In ['0'..'9']);
1264       Char_NumberPlusMin       : Result := (Length(Ch) = 1) and (Ch[1] in ['0'..'9','+','-',#32]); //yes Delphi allows a space here
1265       Char_Letter              : Result := (Length(Ch) = 1) and (Ch[1] In ['a'..'z', 'A'..'Z']);
1266       Char_LetterFixed         : Result := (Length(Ch) = 1) and (Ch[1] In ['a'..'z', 'A'..'Z']);
1267       Char_LetterUpCase        : Result := (Length(Ch) = 1) and (Ch[1] In ['A'..'Z']);
1268       Char_LetterDownCase      : Result := (Length(Ch) = 1) and (Ch[1] In ['a'..'z']);
1269       Char_LetterFixedUpCase   : Result := (Length(Ch) = 1) and (Ch[1] In ['A'..'Z']);
1270       Char_LetterFixedDownCase : Result := (Length(Ch) = 1) and (Ch[1] In ['a'..'z']);
1271       Char_AlphaNum            : Result := (Length(Ch) = 1) and (Ch[1] in ['a'..'z', 'A'..'Z', '0'..'9']);
1272       Char_AlphaNumFixed       : Result := (Length(Ch) = 1) and (Ch[1] in ['a'..'z', 'A'..'Z', '0'..'9']);
1273       Char_AlphaNumUpCase      : Result := (Length(Ch) = 1) and (Ch[1] in ['A'..'Z', '0'..'9']);
1274       Char_AlphaNumDownCase    : Result := (Length(Ch) = 1) and (Ch[1] in ['a'..'z', '0'..'9']);
1275       Char_AlphaNumFixedUpCase : Result := (Length(Ch) = 1) and (Ch[1] in ['A'..'Z', '0'..'9']);
1276       Char_AlphaNumFixedDowncase:Result := (Length(Ch) = 1) and (Ch[1] in ['a'..'z', '0'..'9']);
1277       Char_All                 : Result := True;
1278       Char_AllFixed            : Result := True;
1279       Char_AllUpCase           : Result := True;
1280       Char_AllDownCase         : Result := True;
1281       Char_AllFixedUpCase      : Result := True;
1282       Char_AllFixedDownCase    : Result := True;
1283      {Char_Space               : Result := Ch in [' ', '_'];  //not Delphi compatible, see notes above}
1284       Char_HourSeparator       : Result := (Ch = DefaultFormatSettings.TimeSeparator);
1285       Char_DateSeparator       : Result := (Ch = DefaultFormatSettings.DateSeparator);
1286  end;
1287  //while typing a space iis not allowed in these cases, whilst pasting Delphi allows it nevertheless
1288  if not Result and IsPasting and (Ch = #32) and
1289    (Current in [Char_Number, Char_Letter, Char_LetterUpCase, Char_LetterDownCase,
1290                 Char_AlphaNum, Char_AlphaNumUpCase, Char_AlphaNumDownCase]) then
1291    Result := True;
1292
1293end;
1294
1295
1296// Delete selected chars
1297procedure TCustomMaskEdit.DeleteSelected;
1298Var
1299  SelectionStart, SelectionStop, I : Integer;
1300  S: String;
1301begin
1302  if not HasSelection then Exit;
1303  GetSel(SelectionStart, SelectionStop);
1304  S := inherited RealGetText;
1305  for i := SelectionStart + 1 to SelectionStop do SetCodePoint(S, i,ClearChar(i));
1306  RealSetTextWhileMasked(S);
1307  SetCursorPos;
1308end;
1309
1310
1311// Delete a single char from position
1312procedure TCustomMaskEdit.DeleteChars(NextChar : Boolean);
1313begin
1314  if NextChar then
1315  begin//VK_DELETE
1316    if HasSelection then DeleteSelected
1317    else
1318    begin
1319      //cannot delete beyond length of string
1320      if FCursorPos < FMaskLength then
1321      begin
1322        //This will select the appropriate char in the control
1323        SetCursorPos;
1324        DeleteSelected;
1325      end;
1326    end;
1327  end
1328  else
1329  begin//VK_BACK
1330    //if selected text > 1 char then delete selection
1331    if HasExtSelection then DeleteSelected
1332    else
1333    begin
1334      //cannot backspace if we are at beginning of string, or if all chars in front are MaskLiterals
1335      if FCursorPos > FFirstFreePos - 1 then
1336      begin
1337        //This will select the previous character
1338        //If there are MaskLiterals just in front of the current position, they will be skipped
1339        //and the character in front of them will be deleted (Delphi compatibility)
1340        SelectPrevChar;
1341        DeleteSelected;
1342      end;
1343    end;
1344  end;
1345end;
1346
1347function TCustomMaskEdit.ApplyMaskToText(Value: TCaption): TCaption;
1348{ This tries to mimic Delphi behaviour (D3):
1349  - if mask contains no literals text is set, if necessary padded with blanks,
1350    LTR or RTL depending on FTrimType
1351  - if mask contains literals then we search for matching literals in text and
1352    process each "segment" between matching maskliterals, trimming or padding
1353    LTR or RTL depending on FTrimType, until there is no more matching maskliteral
1354    Some examples to clarify:
1355    EditMask        Text to be set    Result
1356    99              1                 1_
1357    !99             1                 _1
1358    cc-cc           1-2               1_-2_
1359    !cc-cc          1-2               _1-_2
1360    cc-cc@cc        1-2@3             1_-2_@3_
1361                    12@3              12-__@__
1362    cc-cc@cc        123-456@789       12-45@78
1363    !cc-cc@cc       123-456@789       23-56@89
1364    This feauture seems to be invented for easy use of dates:
1365
1366    99/99/00        23/1/2009         23/1_/20  <- if your locale DateSeparator = '/'
1367    !99/99/00       23/1/2009         23/_1/09  <- if your locale DateSeparator = '/'
1368
1369  - The resulting text will always have length = FMaskLength
1370  - The text that is set, does not need to validate
1371}
1372//Helper functions
1373  Function FindNextMaskLiteral(const StartAt: Integer; out FoundAt: Integer; out ALiteral: TUtf8Char): Boolean;
1374  var i: Integer;
1375  begin
1376    Result := False;
1377    for i := StartAt to FMaskLength do
1378    begin
1379      if IsLiteral(FMask[i]) then
1380      begin
1381        FoundAt := i;
1382        ALiteral := ClearChar(i);
1383        Result := True;
1384        Exit;
1385      end;
1386    end;
1387  end;
1388  Function FindMatchingLiteral(const Value: String; const ALiteral: TUtf8Char; out FoundAt: Integer): Boolean;
1389  begin
1390    FoundAt := Utf8Pos(ALiteral, Value);
1391    Result := (FoundAt > 0);
1392  end;
1393
1394Var
1395  S                   : String;
1396  I, J                : Integer;
1397  mPrevLit, mNextLit  : Integer; //Position of Previous and Next literal in FMask
1398  vNextLit            : Integer; //Position of next matching literal in Value
1399  HasNextLiteral,
1400  HasMatchingLiteral,
1401  Stop                : Boolean;
1402  Literal             : TUtf8Char;
1403  Sub                 : String;
1404begin
1405  //First setup a "blank" string that contains all literals in the mask
1406  if not IsMasked then
1407  begin
1408    Result := Value;
1409    Exit;
1410  end;
1411  S := '';
1412  for I := 1 To FMaskLength do  S := S + ClearChar(I);
1413
1414  if FMaskSave then
1415  begin
1416    mPrevLit := 0;
1417    Stop := False;
1418    HasNextLiteral := FindNextMaskLiteral(mPrevLit+1, mNextLit, Literal);
1419    //if FMask starts with a literal, then the first CodePoint of Value must be that literal
1420    if HasNextLiteral and (mNextLit = 1) and (GetCodePoint(Value, 1) <> Literal) then Stop := True;
1421    //debugln('HasNextLiteral = ',dbgs(hasnextliteral),', Stop = ',dbgs(stop));
1422    While not Stop do
1423    begin
1424      if HasNextLiteral then
1425      begin
1426        HasMatchingLiteral := FindMatchingLiteral(Value, Literal, vNextLit);
1427        //debugln('mPrevLit = ',dbgs(mprevlit),' mNextLit = ',dbgs(mnextlit));
1428        //debugln('HasMatchingLiteral = ',dbgs(hasmatchingliteral));
1429        if HasMatchingLiteral then
1430        begin
1431          //debugln('vNextLit = ',dbgs(vnextlit));
1432          Sub := Utf8Copy(Value, 1, vNextLit - 1); //Copy up to, but not including matching literal
1433          Utf8Delete(Value, 1, vNextLit); //Remove this bit from Value (including matching literal)
1434          if (Utf8Length(Value) = 0) then Stop := True;
1435          //debugln('Sub = "',Sub,'", Value = "',Value,'"');
1436        end
1437        else
1438        begin//HasMatchingLiteral = False
1439          Stop := True;
1440          Sub := Value;
1441          Value := '';
1442          //debugln('Sub = "',Sub,'", Value = "',Value,'"');
1443        end;
1444        //fill S between vPrevLit + 1 and vNextLit - 1, LTR or RTL depending on FTrimType
1445        if (FTrimType = metTrimRight) then
1446        begin
1447          j := 1;
1448          for i := (mPrevLit + 1) to (mNextLit - 1) do
1449          begin
1450            if (J > Utf8Length(Sub)) then Break;
1451            if (GetCodePoint(Sub,j) = #32) then SetCodePoint(S,i,FSpaceChar) else SetcodePoint(S,i,GetCodePoint(Sub,j));
1452            Inc(j);
1453          end;
1454        end
1455        else
1456        begin//FTrimType = metTrimLeft
1457          j := Utf8Length(Sub);
1458          for i := (mNextLit - 1) downto (mPrevLit + 1) do
1459          begin
1460            if (j < 1) then Break;
1461            if (GetCodePoint(Sub,j) = #32) then SetCodePoint(S,i,FSpaceChar) else SetCodePoint(S,i, GetCodePoint(Sub,j));
1462            Dec(j);
1463          end;
1464        end;
1465        //debugln('S = ',S);
1466      end
1467      else
1468      begin//HasNextLiteral = False
1469        //debugln('No more MaskLiterals at this point');
1470        //debugln('mPrevLit = ',dbgs(mprevlit));
1471        Stop := True;
1472        Sub := Value;
1473        Value := '';
1474        //debugln('Sub = "',Sub,'", Value = "',Value,'"');
1475        //fill S from vPrevLit + 1 until end of FMask, LTR or RTL depending on FTrimType
1476        if (FTrimType = metTrimRight) then
1477        begin
1478          j := 1;
1479          for i := (mPrevLit + 1) to FMaskLength do
1480          begin
1481            //debugln('  i = ',dbgs(i),'  j = ',dbgs(j));
1482            if (j > Utf8Length(Sub)) then Break;
1483            if (GetCodePoint(Sub,j) = #32) then SetCodePoint(S,i,FSpaceChar) else SetCodePoint(S,i, GetCodePoint(Sub,j));
1484            //debugln('  Sub[j] = "',Sub[j],'" -> S = ',S);
1485            Inc(j);
1486          end;
1487        end
1488        else
1489        begin//FTrimType = metTrimLeft
1490          j := Utf8Length(Sub);
1491          for i := FMaskLength downto (mPrevLit + 1) do
1492          begin
1493            //debugln('  i = ',dbgs(i),'  j = ',dbgs(j));
1494            if (j < 1) then Break;
1495            if (GetCodePoint(Sub,j) = #32) then SetCodePoint(S,i,FSpaceChar) else SetCodePoint(S,i, GetCodePoint(Sub,j));
1496            //debugln('  Sub[j] = "',Sub[j],'" -> S = ',S);
1497            Dec(j);
1498          end;
1499        end;
1500        //debugln('S = ',S);
1501      end;
1502      //debugln('Stop = ',dbgs(stop));
1503      if not Stop then
1504      begin
1505        mPrevLit := mNextLit;
1506        HasNextLiteral := FindNextMaskLiteral(mPrevLit + 1, mNextLit, Literal);
1507      end;
1508    end;//while not Stop
1509  end//FMaskSave = True
1510  else
1511  begin//FMaskSave = False
1512    if FTrimType = metTrimRight then
1513    begin
1514      //fill text from left to rigth, skipping MaskLiterals
1515      j := 1;
1516      for i := 1 to FMaskLength do
1517      begin
1518        if not IsLiteral(FMask[i]) then
1519        begin
1520          if (GetCodePoint(Value,j) = #32) then SetCodePoint(S,i,FSpaceChar) else SetCodePoint(S,i, GetCodePoint(Value,j));
1521          Inc(j);
1522          if j > Utf8Length(Value) then Break;
1523        end;
1524      end;
1525    end
1526    else
1527    begin
1528      //fill text from right to left, skipping MaskLiterals
1529      j := Utf8Length(Value);
1530      for i := FMaskLength downto 1 do
1531      begin
1532        if not IsLiteral(FMask[i]) then
1533        begin
1534          if (GetCodePoint(Value,j) = #32) then SetCodePoint(S,i,FSpaceChar) else SetCodePoint(S,i, GetCodePoint(Value,j));
1535          Dec(j);
1536          if j < 1 then Break;
1537        end;
1538      end;
1539    end;
1540  end;//FMaskSave = False
1541  Result := S;
1542end;
1543
1544function TCustomMaskEdit.CanShowEmulatedTextHint: Boolean;
1545begin
1546  if IsMasked then
1547    Result := False
1548  else
1549    Result := inherited CanShowEmulatedTextHint;
1550end;
1551
1552
1553
1554// Get the actual Text
1555function TCustomMaskEdit.GetTextWithoutMask(Value: TCaption): TCaption;
1556{
1557  Replace al FSPaceChars with #32
1558  If FMaskSave = False then do trimming of spaces and remove all maskliterals
1559}
1560var
1561  S: String;
1562  i: Integer;
1563Begin
1564  S := StringReplace(Value, FSpaceChar, #32, [rfReplaceAll]);
1565  //FSpaceChar can be used as a literal in the mask, so put it back
1566  for i := 1 to FMaskLength do
1567  begin
1568    if IsLiteral(FMask[i]) and (FMask[i] = FSpaceChar) then
1569    begin
1570      SetCodePoint(S, i, FSpaceChar);
1571    end;
1572  end;
1573  if not FMaskSave then
1574  begin
1575    for i := 1 to FMaskLength do
1576    begin
1577      if IsLiteral(FMask[i]) then SetCodePoint(S, i, #1); //We know this char can never be in Text, so this is safe
1578    end;
1579    S := StringReplace(S, #1, '', [rfReplaceAll]);
1580    //Trimming only occurs if FMaskSave = False
1581    case FTrimType of
1582      metTrimLeft : S := TrimLeft(S);
1583      metTrimRight: S := TrimRight(S);
1584    end;//case
1585  end;
1586  Result := S;
1587End;
1588
1589{
1590  Replace al FSPaceChars with #32
1591  Leave all mask literals in place
1592  Needed by FormatMaskText
1593}
1594function TCustomMaskEdit.GetTextWithoutSpaceChar(Value: TCaption): TCaption;
1595var
1596  i: Integer;
1597Begin
1598  Result := StringReplace(Value, FSpaceChar, #32, [rfReplaceAll]);
1599  //FSpaceChar can be used as a literal in the mask, so put it back
1600  for i := 1 to FMaskLength do
1601  begin
1602    if IsLiteral(FMask[i]) and (FMask[i] = FSpaceChar) then
1603    begin
1604      SetCodePoint(Result, i, FSpaceChar);
1605    end;
1606  end;
1607end;
1608
1609
1610// Respond to Text Changed message
1611procedure TCustomMaskEdit.TextChanged;
1612{ Purpose: to avoid messing up the control by
1613  - cut/paste/clear via OS context menu
1614    (we try to catch these messages and handle them,
1615    but this is not garantueed to work)
1616  - dragging selected text in the control with the mouse
1617  If one of these happens, then the internal logic of cursorpositioning,
1618  inserting characters is messed up.
1619  So, we simply restore the text from our backup: FCurrenText
1620}
1621begin
1622  if (not IsMasked) or FChangeAllowed then
1623  begin
1624    Inherited TextChanged;
1625  end
1626  else
1627  begin//Undo changes: restore with value of FCurrentText
1628    //we do not call inherited TextChanged here, because the following RealSetTextWhileMasked
1629    //will trigger TextChanged with FChangeAllowed = True and inherited TextChanged is called then
1630    RealSetTextWhileMasked(FCurrentText);
1631    //Reset cursor to last known position
1632    SetCursorPos;
1633  end;
1634end;
1635
1636procedure TCustomMaskEdit.Change;
1637begin
1638  //suppress OnChange when setting initiall values.
1639  if not FSettingInitialText then inherited Change;
1640end;
1641
1642procedure TCustomMaskEdit.SetCharCase(Value: TEditCharCase);
1643begin
1644  if IsMasked then
1645  begin
1646    if (GetCharCase <> ecNormal) then inherited CharCase := ecNormal;
1647  end
1648  else
1649  begin
1650    inherited CharCase := Value;
1651  end;
1652end;
1653
1654function TCustomMaskEdit.GetCharCase: TEditCharCase;
1655begin
1656  Result := inherited CharCase;
1657end;
1658
1659procedure TCustomMaskEdit.SetMaxLength(Value: Integer);
1660begin
1661  if IsMasked then
1662  begin
1663    inherited MaxLength := FMaskLength;
1664  end
1665  else
1666  begin
1667    inherited MaxLength := Value;
1668  end;
1669end;
1670
1671function TCustomMaskEdit.GetMaxLength: Integer;
1672begin
1673  Result := inherited Maxlength;
1674end;
1675
1676procedure TCustomMaskEdit.SetNumbersOnly(Value: Boolean);
1677begin
1678  if not IsMasked then
1679    inherited SetNumbersOnly(Value)
1680  else
1681    //NumersOnly interferes with masking
1682    inherited SetNumbersOnly(False);
1683end;
1684
1685procedure TCustomMaskEdit.Loaded;
1686begin
1687  inherited Loaded;
1688  FSettingInitialText := True;
1689  if (FInitialMask <> '') then SetMask(FInitialMask);
1690  if (FInitialText <> '') then SetTextApplyMask(FInitialText);
1691  FSettingInitialText := False;
1692end;
1693
1694
1695// Respond to Paste message
1696procedure TCustomMaskEdit.LMPasteFromClip(var Message: TLMessage);
1697begin
1698  if (not IsMasked) or (ReadOnly) then
1699  begin
1700    Inherited ;
1701    Exit;
1702  end;
1703  //We handle this message ourself
1704  Message.Result := 0;
1705  PasteFromClipBoard;
1706end;
1707
1708
1709
1710// Respond to Cut message
1711procedure TCustomMaskEdit.LMCutToClip(var Message: TLMessage);
1712begin
1713  if not IsMasked then
1714  begin
1715    inherited;
1716    Exit;
1717  end;
1718  //We handle this message ourself
1719  Message.Result := 0;
1720  CutToClipBoard;
1721end;
1722
1723
1724// Respond to Clear message
1725procedure TCustomMaskEdit.LMClearSel(var Message: TLMessage);
1726begin
1727  //DebugLn('TCustomMaskEdit.LMClearSel');
1728  if not IsMasked then
1729  begin
1730    inherited;
1731    Exit;
1732  end;
1733  //We handle this message ourself
1734  Message.Result := 0;
1735  DeleteSelected;
1736end;
1737
1738function TCustomMaskEdit.EditCanModify: Boolean;
1739begin
1740  Result := True;
1741end;
1742
1743
1744
1745procedure TCustomMaskEdit.Reset;
1746//Implements an Undo mechanisme from the moment of entering the control
1747begin
1748  if IsMasked and (not ReadOnly) then
1749  begin
1750    RealSetTextWhileMasked(FTextOnEnter);
1751  end;
1752end;
1753
1754//Moved from CMEnter message handler
1755procedure TCustomMaskEdit.DoEnter;
1756begin
1757  inherited DoEnter;
1758  if IsMasked then
1759  begin
1760    //debugln('TCustomMaskEdit.DoEnter: FValidationFailed = ',DbgS(FValidationFailed));
1761    FCursorPos := GetSelStart;
1762    //Only save FTextOnEnter if validation did not fail in last DoExit that occurred
1763    if not FValidationFailed then
1764      FTextOnEnter := inherited RealGetText
1765    else
1766      FValidationFailed := False;
1767    Modified := False;
1768    if (AutoSelect and not (csLButtonDown in ControlState)) then
1769    begin
1770      SelectAll;
1771      FCursorPos := GetSelStart;
1772    end
1773    else
1774    begin
1775    if ((FCursorPos = 0) and (IsLiteral(FMask[1]))) then
1776      //On entering select first editable char
1777      SelectNextChar
1778    else
1779      SetCursorPos;
1780    end;
1781  end;
1782end;
1783
1784
1785
1786procedure TCustomMaskEdit.DoExit;
1787begin
1788  //debugln('TCustomMaskEdit.DoExit: FValidationFailed = ',DbgS(FValidationFailed));
1789  //First give OnExit a change to prevent a EDBEditError
1790  inherited DoExit;
1791  {$IFNDEF MASKEDIT_NOVALIDATEONEXIT}
1792  //Do not validate if FValidationFailed, or risk raising an exception while the previous exception was
1793  //not handled, resulting in an application crash
1794  if IsMasked and (FTextOnEnter <> inherited RealGetText) then
1795  begin
1796    //assume failure
1797    try
1798      //debugln('TCustomMaskedit.DoExit: try ValidateEdit');
1799      if (not FValidationFailed) then
1800      begin
1801        ValidateEdit;
1802        FValidationFailed := False;
1803      end ;
1804    finally
1805      //also check if control can be focussed, otherwise risk an exception while
1806      //handling an exception, issue #0030482
1807      if FValidationFailed and CanSetFocus then
1808      begin
1809        //debugln('TCustomMaskedit.DoExit: Validation failed');
1810        SetFocus;
1811        SelectAll;
1812      end;
1813    end;
1814  end;
1815  {$ENDIF}
1816end;
1817
1818
1819
1820// Single key down procedure
1821procedure TCustomMaskEdit.KeyDown(var Key: Word; Shift: TShiftState);
1822begin
1823  Inherited KeyDown(Key, Shift);
1824  // Not masked -> old procedure
1825  if not IsMasked then
1826  begin
1827    Exit;
1828  end;
1829  FCursorPos := GetSelStart;
1830  // shift and arrowkey -> old procedure
1831  if (ssShift in Shift) then
1832  begin
1833    if (Key = VK_LEFT) or (Key = VK_RIGHT) or
1834       (Key = VK_HOME) or (Key = VK_END) then
1835    begin
1836      Exit;
1837    end;
1838  end;
1839  //Escape Key
1840  if (Key = VK_ESCAPE) and (Shift = []) then
1841  begin
1842    if ((inherited RealGetText) <> FTextOnEnter) then
1843    begin
1844      Reset;
1845      Key := 0;
1846      Exit;
1847    end;
1848  end;
1849  //Handle clipboard and delete/backspace keys
1850  if (Key = VK_DELETE) then
1851  begin
1852    if not ReadOnly then
1853    begin
1854      if (Shift = [ssShift]) then
1855      begin//Cut
1856        CutToClipBoard;
1857      end
1858      else if (Shift = [ssModifier]) then
1859      begin//Clear
1860        DeleteSelected;
1861      end
1862      else if (Shift = []) then
1863      begin//Plain Delete
1864        //DeleteChars also works if SelLength = 0
1865        DeleteChars(True);
1866      end;
1867      Key := 0;
1868      Exit;
1869    end;
1870  end;
1871  if (Key = VK_BACK) then
1872  begin
1873    if not ReadOnly then
1874    begin
1875      if (Shift = [ssCtrl]) then
1876      begin//Clear
1877        DeleteSelected;
1878      end
1879      else
1880      if (Shift = [ssShift]) then
1881      begin
1882        CutToClipBoard;
1883      end
1884      else
1885      if (Shift = []) then
1886      begin
1887        DeleteChars(False);
1888      end;
1889      Key := 0;
1890      Exit;
1891    end;
1892  end;
1893  if (Key = VK_INSERT) then
1894  begin//Copy or Paste
1895    if (Shift = [ssShift]) then
1896    begin//Paste
1897      if not ReadOnly then
1898      begin
1899        PasteFromClipBoard;
1900      end;
1901    end
1902    else if (Shift = [ssModifier]) then
1903    begin//Copy
1904      CopyToClipBoard;
1905    end;
1906    Key := 0;
1907    Exit;
1908  end;
1909  if (Key = VK_C) and (Shift = [ssModifier]) then
1910  begin//Copy
1911    CopyToClipBoard;
1912    Key := 0;
1913    Exit;
1914  end;
1915  if (Key = VK_X) and (Shift = [ssModifier]) then
1916  begin//Cut
1917    if not ReadOnly then
1918    begin
1919      CutToClipBoard;
1920      Key := 0;
1921      Exit;
1922    end;
1923  end;
1924  if (Key = VK_V) and (Shift = [ssModifier]) then
1925  begin//Paste
1926    if not ReadOnly then
1927    begin
1928      PasteFromClipBoard;
1929      Key := 0;
1930      Exit;
1931    end;
1932  end;
1933
1934  // Cursor movement
1935  //ATM we handle Ctrl+ArrowKey as if it were just ArrowKey
1936  if (Key = VK_LEFT) then
1937  begin
1938    SelectPrevChar;
1939    Key := 0;
1940    Exit;
1941  end;
1942  if (Key = VK_RIGHT) then
1943  begin
1944    SelectNextChar;
1945    Key := 0;
1946    Exit;
1947  end;
1948  if (Key = VK_HOME) then
1949  begin
1950    SelectFirstChar;
1951    Key := 0;
1952    Exit;
1953  end;
1954  if (Key = VK_END) then
1955  begin
1956    GotoEnd;
1957    Key := 0;
1958    Exit;
1959  end;
1960  // Cursor Up/Down -> not valid
1961  if (Key = VK_UP) or (Key = VK_DOWN) then
1962  begin
1963    Key := 0;
1964    Exit;
1965  end;
1966end;
1967
1968
1969//Handle all keys from KeyPress and Utf8KeyPress here
1970procedure TCustomMaskEdit.HandleKeyPress(var Key: TUtf8Char);
1971begin
1972  if (not IsMasked) or ReadOnly then
1973  begin
1974    Exit;
1975  end;
1976  FCursorPos := GetSelStart;
1977  //If the cursor is on a MaskLiteral then go to the next writable position if a key is pressed (Delphi compatibility)
1978  if IsLiteral(FMask[FCursorPos + 1]) then
1979  begin
1980    SelectNextChar;
1981    Key := EmptyStr;
1982  end
1983  else
1984  // Insert a char
1985  if  not ((Length(Key) = 1) and (Key[1] in [#0..#31])) then
1986  begin
1987    if ((Key = Period) or (Key = Comma)) and not (CanInsertChar(FCursorPos + 1, Key)) then
1988    begin//Try to jump to next period or comma, if at all possible
1989      JumpToNextDot(Key[1]);
1990    end
1991    else
1992    begin//any other key
1993      InsertChar(Key);
1994    end;
1995    //We really need to "eat" all keys we handle ourselves
1996    //(or widgetset will insert char second time)
1997    Key:= EmptyStr;
1998  end;
1999end;
2000
2001
2002procedure TCustomMaskEdit.KeyPress(var Key: Char);
2003var
2004  Utf8Key: TUtf8Char;
2005begin
2006  inherited KeyPress(Key);
2007  Utf8Key := Key;
2008  //All keys are handled in HandleKeyPress, which sets Utf8Key to ''
2009  HandleKeyPress(Utf8Key);
2010  if (Length(Utf8Key) = 0) then Key := #0;
2011end;
2012
2013procedure TCustomMaskEdit.Utf8KeyPress(var UTF8Key: TUTF8Char);
2014begin
2015  inherited Utf8KeyPress(UTF8Key);
2016  //All keys are handled in HandleKeyPress, which sets Utf8Key to ''
2017  //In Utf8KeyPress do this only for Utf8 sequences, otherwise KeyPress is never called
2018  //because after this Utf8Key = ''
2019  if (Length(Utf8Key) > 1) then HandleKeyPress(Utf8Key);
2020end;
2021
2022
2023//Moved form LMMButtonUp message handler
2024procedure TCustomMaskEdit.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
2025  Y: Integer);
2026begin
2027  inherited MouseUp(Button, Shift, X, Y);
2028  if IsMasked then
2029  begin
2030    FCursorPos := GetSelStart;
2031    if not HasSelection then SetCursorPos;
2032  end;
2033end;
2034
2035procedure TCustomMaskEdit.CheckCursor;
2036begin
2037  if IsMasked then
2038    SetCursorPos;
2039end;
2040
2041procedure TCustomMaskEdit.CutToClipBoard;
2042begin
2043  if not IsMasked then
2044  begin
2045    inherited CutToClipBoard;
2046    Exit;
2047  end;
2048  CopyToClipBoard;
2049  DeleteSelected;
2050end;
2051
2052procedure TCustomMaskEdit.PasteFromClipBoard;
2053{
2054  Paste only allowed chars, skip literals in the mask
2055  e.g. if cliptext = '1234' and mask = '00:00' then result will be '12:34'
2056}
2057var
2058  ClipText, S: String;
2059  P, i: LongInt;
2060  CP: TUTF8Char;
2061begin
2062  if not IsMasked then
2063  begin
2064    inherited PasteFromClipBoard;
2065    Exit;
2066  end;
2067 if Clipboard.HasFormat(CF_TEXT) then
2068 begin
2069   //debugln('TCustomMaskEdit.PasteFromClipBoard A');
2070   ClipText := ClipBoard.AsText;
2071   if (Utf8Length(ClipText) > 0) then
2072   begin
2073     P := FCursorPos + 1;
2074     DeleteSelected;
2075     S := inherited RealGetText;
2076     i := 1;
2077     //debugln('TCustomMaskEdit.PasteFromClipBoard B:');
2078     //debugln('  P = ',dbgs(p));
2079     //debugln('  S = ',s);
2080     //debugln('  ClipText = ',ClipText);
2081     while (P <= FMaskLength) and (i <= Utf8Length(ClipText)) do
2082     begin
2083       //Skip any literal
2084       while (P < FMaskLength) and (IsLiteral(FMask[P])) do Inc(P);
2085       //debugln('TCustomMaskEdit.PasteFromClipBoard C: P = ',DbgS(p));
2086       //Skip any char in ClipText that cannot be inserted at current position
2087       CP := GetCodePoint(ClipText,i);
2088       //Replace all control characters with spaces
2089       if (Length(CP) = 1) and (CP[1] in [#0..#31]) then CP := #32;
2090       while (i < Utf8Length(ClipText)) and (not CanInsertChar(P, CP, True)) do
2091       begin
2092         Inc(i);
2093         CP := GetCodePoint(ClipText,i);
2094       end;
2095       if CanInsertChar(P, CP, True) then
2096       begin
2097         SetCodePoint(S,P,CP);
2098         Inc(P);
2099         Inc(i);
2100       end
2101       else
2102         Break;
2103     end;
2104     RealSetTextWhileMasked(S);
2105     SetCursorPos;
2106   end;
2107 end;
2108end;
2109
2110
2111// Clear the controll
2112procedure TCustomMaskEdit.Clear;
2113Var
2114  S : ShortString;
2115  I : Integer;
2116begin
2117  if IsMasked then
2118  begin
2119    S  := '';
2120    for I := 1 To FMaskLength do S := S + ClearChar(I);
2121    RealSetTextWhileMasked(S);
2122    FCursorPos := 0;
2123    SetCursorPos;
2124  end
2125  else Inherited Clear;
2126end;
2127
2128
2129
2130procedure TCustomMaskEdit.ValidateEdit;
2131var
2132  S: String;
2133  _MaskSave: Boolean;
2134begin
2135  //Only validate if IsMasked
2136  if IsMasked then
2137  begin
2138    {
2139     if FMaskSave = False then literal and spaces are trimmed from Text
2140     and TextIsValid might wrongly return False
2141     We need the text with literals and FSpaceChar translated to #32
2142    }
2143    _MaskSave := FMaskSave;
2144    FMaskSave := True;
2145    S := Text;
2146    FMaskSave := _MaskSave;
2147    if not TextIsValid(S) then
2148    begin
2149      SetCursorPos;
2150      FValidationFailed := True;
2151      Raise EDBEditError.Create(SMaskEditNoMatch);
2152    end;
2153  end;
2154end;
2155
2156
2157{ Component registration procedure }
2158procedure Register;
2159begin
2160  RegisterComponents('Additional',[TMaskEdit]);
2161end;
2162
2163
2164initialization
2165  RegisterPropertyToSkip(TCustomMaskEdit, 'TextHintFontColor','Used in a previous version of Lazarus','');
2166  RegisterPropertyToSkip(TCustomMaskEdit, 'TextHintFontStyle','Used in a previous version of Lazarus','');
2167
2168end.
2169