* New version of maskutils by Bart Broersma (+testcase), bug ID #30020

git-svn-id: trunk@34498 -

.gitattributes

@@ -2076,6 +2076,7 @@ packages/fcl-base/src/wtex.pp svneol=native#text/plain
 packages/fcl-base/tests/fclbase-unittests.lpi svneol=native#text/plain
 packages/fcl-base/tests/fclbase-unittests.pp svneol=native#text/plain
 packages/fcl-base/tests/tchashlist.pp svneol=native#text/plain
+packages/fcl-base/tests/tcmaskutils.pp svneol=native#text/plain
 packages/fcl-base/tests/testexprpars.pp svneol=native#text/plain
 packages/fcl-base/tests/tests_fptemplate.pp svneol=native#text/plain
 packages/fcl-base/texts/fptemplate.txt svneol=native#text/plain

packages/fcl-base/src/maskutils.pp

@@ -1,15 +1,14 @@
 {
- /***************************************************************************
-                                  maskutils.pas
-                                  ---------
-
- ***************************************************************************/
+ ***************************************************************************
+                    maskutils.pas:    Author: Bart Broersma
+ ***************************************************************************}
 
+{
  *****************************************************************************
  *                                                                           *
- *  This file is part of the Lazarus Component Library (LCL)                 *
+ *  This file is part of the Free Component Library (FCL)                    *
  *                                                                           *
- *  See the file COPYING.modifiedLGPL, included in this distribution,        *
+ *  See the file COPYING.FPC, included in this distribution,                 *
  *  for details about the copyright.                                         *
  *                                                                           *
  *  This program is distributed in the hope that it will be useful,          *
@@ -17,583 +16,825 @@
  *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                     *
  *                                                                           *
  *****************************************************************************
- 
-
- Author: Boguslaw Brandys
- 
- Abstract:
-    FormatMaskText implementation
- 
 }
 
 
 unit maskutils;
 
 {$mode objfpc}{$H+}
-{.$define DebugMaskUtils}
-
-
-
+{.$define debug_maskutils}
 
 interface
 
 uses
-Classes
-,SysUtils
- {$ifdef DebugMaskUtils}
-,lclproc
- {$endif};
-
+  Classes, SysUtils;
 
 
-function FormatMaskText(const EditMask: string; const Value: string): string;
+function FormatMaskText(const EditMask: string; const AValue: string): string;
 function FormatMaskInput(const EditMask: string): string;
-function MaskDoFormatText(const EditMask: string; const Value: string; Blank: Char): string;
-
+function MaskDoFormatText(const EditMask: string; const AValue: string; ASpaceChar: Char): string;
 
 
 type
-  TStepState =
-  (
-  stLeading,  //? not used currently
-  stUpper,    //use uppercase
-  stLower,    //use lowercase
-  stSpecial,  //use escape character
-  stArbitrary //put arbitrary character
-  );
-
-  TParseState = set of TStepState;
-  
   TEditMask = type string;
+  TMaskeditTrimType = (metTrimLeft, metTrimRight);
+
+  { Type for mask (internal) }
+  tMaskedType = (Char_Start,
+                 Char_Number,
+                 Char_NumberFixed,
+                 Char_NumberPlusMin,
+                 Char_Letter,
+                 Char_LetterFixed,
+                 Char_LetterUpCase,
+                 Char_LetterDownCase,
+                 Char_LetterFixedUpCase,
+                 Char_LetterFixedDownCase,
+                 Char_AlphaNum,
+                 Char_AlphaNumFixed,
+                 Char_AlphaNumUpCase,
+                 Char_AlphaNumDownCase,
+                 Char_AlphaNumFixedUpCase,
+                 Char_AlphaNumFixedDownCase,
+                 Char_All,
+                 Char_AllFixed,
+                 Char_AllUpCase,
+                 Char_AllDownCase,
+                 Char_AllFixedUpCase,
+                 Char_AllFixedDownCase,
+                 Char_HourSeparator,
+                 Char_DateSeparator,
+                 Char_Stop);
+
 
 { TMaskUtils }
 
 type
   TMaskUtils = class(TObject)
   private
-    FValue: string;
-    SourcePosition,Position : Integer;
-    FEditMask,FMask : string;
-    SourceVal,ExitVal : string;
-    FMatched : Boolean;
-    FMissChar : Char;
-    State : TParseState;
-    procedure EvaluateExit;
-    procedure EvaluateMissing;
-    procedure DoFillRest;
-    procedure DoLiteral;
-    procedure DoLiteralInputMask;
-    procedure DoToken;
-    procedure DoTokenInputMask;
-    procedure DoUpper;
-    procedure DoLower;
-    procedure DoNumeric(Required : Boolean);
-    procedure DoAlpha(Required : Boolean);
-    procedure DoAlphaNumeric(Required : Boolean);
-    procedure DoNumericPlusMinus;
-    procedure DoArbitrary(Required : Boolean);
-    procedure DoTime;
-    procedure DoDate;
-    function GetInputMask: string;
-    procedure SetMask(const AValue: string);
-    procedure SetValue(const AValue: string);
+    FRealMask: String;
+    FMask: String;  // internal representatio of the mask
+    FValue: String;
+    FMaskLength: Integer;
+    FMaskSave: Boolean;
+    FSpaceChar: Char;
+    FTrimType: TMaskeditTrimType;
+    procedure AddToMask(Ch: Char);
+    function  MaskToChar(AValue: tMaskedType) : Char;
+    function  CharToMask(Ch: Char) : tMaskedType;
+
+    function  CharMatchesMask(const Ch: Char; const Position: Integer): Boolean;
+    function  ClearChar(Position : Integer) : Char;
+    procedure SetMask(AValue: String);
+    function GetInputMask: String;
+    function GetTextWithoutMask(AValue: String) : String;
+    function GetTextWithoutSpaceChar(AValue: String) : String;
+    function  IsLiteral(Ch: Char): Boolean;
+    function  IsMaskChar(Ch : Char) : Boolean;
+    procedure SetValue(AValue: String);
+    function  TextIsValid(const AValue: String): Boolean;
   protected
-    procedure RaiseError;
-    procedure ExtractMask;
-    function MaskPtr : Char;
-    function SourcePtr : Char;
-    property Matched: Boolean read FMatched write FMatched;
-    property MissChar: Char read FMissChar write FMissChar;
+    function ApplyMaskToText(AValue: String): String;
   public
-    function ValidateInput : string;
-    property Mask : string read FEditMask write SetMask;
-    property Value : string read FValue write SetValue;
-    property InputMask : string read GetInputMask;
+    function ValidateInput : String;
+    function TryValidateInput(out ValidatedString: String): Boolean;
+    property Mask : String read FRealMask write SetMask;
+    property Value : String read FValue write SetValue;
+    property InputMask : String read GetInputMask;
   end;
 
 
-
-
-
 implementation
 
-
 resourcestring
-
-//exInvalidMaskValue = 'Input mask value incorrect';
-exInvalidMaskValue = 'FormatMaskText function failed!';
-//replace above text when all bugs will be fixed!
-
-
-
-
-
-
-
-
-function IsNumeric(const C : Char) : Boolean;
-begin
-  Result := C In ['0'..'9'];
-end;
-
-
-
-function IsAlpha(const C : Char) : Boolean;
-begin
-  //Fix it later if better way is possible
-  Result := AnsiUpperCase(C) <> AnsiLowerCase(C);
-end;
-
-
-function IsToken(const C : Char) : Boolean;
+  exInvalidMaskValue = 'FormatMaskText function failed!';
+  exValidationFailed = 'TMaskUtils.ValidateInput failed.';
+
+const
+  { Mask Type }
+  cMask_SpecialChar   = '\'; // after this you can set an arbitrary char
+  cMask_UpperCase     = '>'; // after this the chars is in upper case
+  cMask_LowerCase     = '<'; // after this the chars is in lower case
+  cMask_Letter        = 'l'; // only a letter but not necessary
+  cMask_LetterFixed   = 'L'; // only a letter
+  cMask_AlphaNum      = 'a'; // an alphanumeric char (['A'..'Z','a..'z','0'..'9']) but not necessary
+  cMask_AlphaNumFixed = 'A'; // an alphanumeric char
+  cMask_AllChars      = 'c'; // any Utf8 char but not necessary
+  cMask_AllCharsFixed = 'C'; // any Utf8 char #32 - #255
+  cMask_Number        = '9'; // only a number but not necessary
+  cMask_NumberFixed   = '0'; // only a number
+  cMask_NumberPlusMin = '#'; // only a number or + or -, but not necessary
+  cMask_HourSeparator = ':'; // automatically put the hour separator char
+  cMask_DateSeparator = '/'; // automatically but the date separator char
+{ cMask_SpaceOnly     = '_'; // automatically put a space          //not Delphi compatible        }
+  cMask_NoLeadingBlanks = '!'; //Trim leading blanks, otherwise trim trailing blanks from the data
+
+  {Delphi compatibility: user can change these at runtime}
+  DefaultBlank: Char = '_';
+  MaskFieldSeparator: Char = ';';
+  MaskNoSave: Char = '0';
+
+
+
+
+
+procedure SplitEditMask(AEditMask: String; out AMaskPart: String; out AMaskSave: Boolean; out ASpaceChar: Char);
+{
+  Retrieve the separate fields for a given EditMask:
+  Given an AEditMask of '999.999;0;_'  it will return
+  - AMaskPart = '999.999'
+  - AMaskSave = False
+  - ASpaceChar = '_'
+}
 begin
-  Result := C In ['!','>','<','\','L','l','A','a','C','c','0','9','#',':',
-            '/',';'];
+  {
+    First see if AEditMask is multifield and if we can extract a value for
+    AMaskSave and/or ASpaceChar
+    If so, extract and remove from AMask (so we know that the remaining part of
+    AMask _IS_ the mask to be set)
+
+    A value for SpaceChar is only valid if also a value for MaskSave is specified
+    (as by Delphi specifications), so Mask must be at least 4 characters
+    These must be the last 2 or 4 characters of EditMask (and there must not be
+    an escape character in front!)
+  }
+  //Assume no SpaceChar and no MaskSave is defined in new mask, so first set it to DefaultBlank and True
+  ASpaceChar := DefaultBlank;
+  AMaskSave := True;
+  //MaskFieldseparator, MaskNoSave, SpaceChar and cMask_SpecialChar are defined as Char (=AnsiChar)
+  //so in this case we can use Length (instead of Utf8length) and iterate single chars in the string
+  if (Length(AEditMask) >= 4) and (AEditMask[Length(AEditMask)-1] = MaskFieldSeparator) and
+     (AEditMask[Length(AEditMask)-3] = MaskFieldSeparator) and
+     (AEditMask[Length(AEditMask)-2] <> cMask_SpecialChar) and
+     //Length = 4 is OK (AEditMask = ";1;_" for example), but if Length > 4 there must be no escape charater in front
+     ((Length(AEditMask) = 4) or ((Length(AEditMask) > 4) and (AEditMask[Length(AEditMask)-4] <> cMask_SpecialChar))) then
+  begin
+    ASpaceChar := AEditMask[Length(AEditMask)];
+    AMaskSave := (AEditMask[Length(AEditMask)-2] <> MaskNosave);
+    System.Delete(AEditMask,Length(AEditMask)-3,4);
+  end
+  //If not both FMaskSave and FSPaceChar are specified, then see if only FMaskSave is specified
+  else if (Length(AEditMask) >= 2) and (AEditMask[Length(AEditMask)-1] = MaskFieldSeparator) and
+          //Length = 2 is OK, but if Length > 2 there must be no escape charater in front
+          ((Length(AEditMask) = 2) or ((Length(AEditMask) > 2) and (AEditMask[Length(AEditMask)-2] <> cMask_SpecialChar))) then
+  begin
+    AMaskSave := (AEditMask[Length(AEditMask)] <> MaskNoSave);
+    //Remove this bit from Mask
+    System.Delete(AEditMask,Length(AEditMask)-1,2);
+  end;
+  //Whatever is left of AEditMask at this point is the MaskPart
+  AMaskPart := AEditMask;
 end;
 
 
 
-{ TMaskUtils }
-
-
-
 
-
-procedure TMaskUtils.SetMask(const AValue: string);
-begin
-  if FEditMask = AValue then Exit;
-  FEditMask := AValue;
-  ExtractMask;
-end;
-
-procedure TMaskUtils.SetValue(const AValue: string);
+function FormatMaskText(const EditMask: string; const AValue: string): string;
+var
+  Mu: TMaskUtils;
 begin
-  if SourceVal=AValue then exit;
-  SourceVal := AValue;
+  Mu := TMaskUtils.Create;
+  try
+    Mu.Mask := EditMask;
+    Mu.Value := AValue;
+    Result := Mu.ApplyMaskToText(AValue);
+    Result := Mu.GetTextWithoutSpaceChar(Result);
+  finally
+    Mu.Free;
+  end;
 end;
 
-
-
-function TMaskUtils.ValidateInput : string;
+function FormatMaskInput(const EditMask: string): string;
+var
+  Mu : TMaskUtils;
 begin
- {Prepare}
-  ExitVal := '';
-  Position := 1;
-  SourcePosition := 1;
-  State := [];
-
- {Process}
-  while (Position <= Length(FMask)) do
-    begin
-      if (IsToken(MaskPtr) and not (stSpecial In State)) then
-       DoToken
-      else
-        DoLiteral;
-
-      Inc(Position);
-    end;
-
-  DoFillRest;
-  Result := ExitVal;
+  Result := '';
+  Mu := TMaskUtils.Create;
+  try
+    Mu.Mask := EditMask;
+    Result := Mu.InputMask;
+  finally
+    Mu.Free;
+  end;
 end;
 
-
-
-
-
-
-procedure TMaskUtils.EvaluateMissing;
+{
+  Format Value string using EditMask, dont use 2d and 3d fields of EditMask,
+  set own SpaceChar and MaskSave = True ('1')
+}
+function MaskDoFormatText(const EditMask: string; const AValue: string; ASpaceChar: Char): string;
+var
+  Mu : TMaskUtils;
+  AMaskPart: String;
+  OldMaskSave: Boolean;
+  OldSpaceChar: Char;
 begin
-  ExitVal := ExitVal + MissChar;
-  Inc(SourcePosition);
+  Result := '';
+  SplitEditMask(EditMask, AMaskPart, OldMaskSave, OldSpaceChar);
+  Mu := TMaskUtils.Create;
+  try
+    Mu.Mask := AMaskPart + ';1;'+ASpaceChar;
+    Mu.Value := AValue;
+    Result := Mu.ValidateInput;
+  finally
+    Mu.Free;
+  end;
 end;
 
+{ TMaskUtils }
 
-procedure TMaskUtils.RaiseError;inline;
+procedure TMaskUtils.AddToMask(Ch: Char);
 begin
-  if SourcePosition > Length(SourceVal) then
-    EvaluateMissing
-  else
-    raise Exception.CreateFmtHelp(exInvalidMaskValue,[],Position);
+  FMask := FMask + Ch;
+  FMaskLength := Length(FMask);
 end;
 
-
-
-function TMaskUtils.MaskPtr : Char;
+function TMaskUtils.MaskToChar(AValue: tMaskedType): Char;
 begin
-  Result := FMask[Position];
+  Result := Char(Ord(AValue));
 end;
 
-
-
-function TMaskUtils.SourcePtr : Char;
+function TMaskUtils.CharToMask(Ch: Char): tMaskedType;
 begin
-  if SourcePosition <= Length(SourceVal) then
-    Result := SourceVal[SourcePosition]
-  else Result := #0;
+  Result := Char_Start;
+  if (Ord(Ch) > Ord(Char_Start)) and
+     (Ord(Ch) < Ord(Char_Stop) )
+     then
+       Result := tMaskedType(Ord(Ch));
 end;
 
-
-
-
-
-
-{Extract mask from input parameter}
-procedure TMaskUtils.ExtractMask;
+function TMaskUtils.CharMatchesMask(const Ch: Char; const Position: Integer): Boolean;
 var
-  P : Integer;
-  s : string;
+  Current: tMaskedType;
+  Ok: Boolean;
 begin
-  { TODO:  Implement clear, UTF8 compliant parsing ? }
-  MissChar := #32;
-  Matched := false;
-  s := Copy(FEditMask,1,Length(FEditMask));
-  P := LastDelimiter(';',s);
-  if P = 0 then FMask := s
-  else
+  Result := False;
+  if (Position < 1) or (Position > FMaskLength) then Exit;
+  Current := CharToMask(FMask[Position]);
+  case Current Of
+    Char_Number              : OK := (Ch in ['0'..'9',#32]);
+    Char_NumberFixed         : OK := (Ch in ['0'..'9']);
+    Char_NumberPlusMin       : OK := (Ch in ['0'..'9','+','-',#32]);
+    Char_Letter              : OK := (Ch in ['a'..'z', 'A'..'Z',#32]);
+    Char_LetterFixed         : OK := (Ch in ['a'..'z', 'A'..'Z']);
+    Char_LetterUpCase        : OK := (Ch in ['A'..'Z',#32]);
+    Char_LetterDownCase      : OK := (Ch in ['a'..'z',#32]);
+    Char_LetterFixedUpCase   : OK := (Ch in ['A'..'Z']);
+    Char_LetterFixedDownCase : OK := (Ch in ['a'..'z']);
+    Char_AlphaNum            : OK := (Ch in ['a'..'z', 'A'..'Z', '0'..'9',#32]);
+    Char_AlphaNumFixed       : OK := (Ch in ['a'..'z', 'A'..'Z', '0'..'9']);
+    Char_AlphaNumUpCase      : OK := (Ch in ['A'..'Z', '0'..'9',#32]);
+    Char_AlphaNumDownCase    : OK := (Ch in ['a'..'z', '0'..'9',#32]);
+    Char_AlphaNumFixedUpCase : OK := (Ch in ['A'..'Z', '0'..'9']);
+    Char_AlphaNumFixedDowncase:OK := (Ch in ['a'..'z', '0'..'9']);
+    Char_All                 : OK := True; //Ch in [#32..#126]; //True;
+    Char_AllFixed            : OK := True; //Ch in [#32..#126]; //True;
+    Char_AllUpCase           : OK := True; //Ch in [#32..#126]; // (Utf8UpperCase(Ch) = Ch);             ???????
+    Char_AllDownCase         : OK := True; //Ch in [#32..#126]; // (Utf8LowerCase(Ch) = Ch);             ???????
+    Char_AllFixedUpCase      : OK := True; //Ch in [#32..#126]; // (Utf8UpperCase(Ch) = Ch);             ???????
+    Char_AllFixedDownCase    : OK := True; //Ch in [#32..#126]; // (Utf8LowerCase(Ch) = Ch);             ???????
+   {Char_Space               : OK := (Length(Ch) = 1) and (Ch in [' ', '_']);  //not Delphi compatible, see notes above}
+    Char_HourSeparator       : OK := (Ch = DefaultFormatSettings.TimeSeparator);
+    Char_DateSeparator       : OK := (Ch = DefaultFormatSettings.DateSeparator);
+    else//it's a literal
     begin
-      MissChar := PChar(Copy(s,P+1,1))^;
-      Delete(s,P,2);
-      P := LastDelimiter(';',s);
-      Matched := (Copy(s,P+1,1) <> '0');
-      Delete(s,P,2);
-      FMask := s;
+      OK := (Ch = FMask[Position]);
     end;
+  end;//case
+  //DebugLn('Position = ',DbgS(Position),' Current = ',MaskCharToChar[Current],' Ch = "',Ch,'" Ok = ',DbgS(Ok));
+  Result := Ok;
 end;
 
-
-
-
-procedure TMaskUtils.EvaluateExit;
+// Clear (virtually) a single char in position Position
+function TMaskUtils.ClearChar(Position: Integer): Char;
 begin
-  if stUpper in State then
-   ExitVal := ExitVal + UpperCase(SourcePtr)
-  else
-    if stLower in State then
-     ExitVal := ExitVal + LowerCase(SourcePtr)
-  else
-    ExitVal := ExitVal + SourcePtr;
-  Inc(SourcePosition);
+  Result := FMask[Position];
+  //For Delphi compatibilty, only literals remain, all others will be blanked
+  case CharToMask(FMask[Position]) Of
+    Char_Number,
+    Char_NumberFixed,
+    Char_NumberPlusMin,
+    Char_Letter,
+    Char_LetterFixed,
+    Char_LetterUpCase,
+    Char_LetterDownCase,
+    Char_LetterFixedUpCase,
+    Char_LetterFixedDownCase,
+    Char_AlphaNum,
+    Char_AlphaNumFixed,
+    Char_AlphaNumUpCase,
+    Char_AlphaNumDownCase,
+    Char_AlphaNumFixedUpcase,
+    Char_AlphaNuMFixedDownCase,
+    Char_All,
+    Char_AllFixed,
+    Char_AllUpCase,
+    Char_AllDownCase,
+    Char_AllFixedUpCase,
+    Char_AllFixedDownCase: Result := FSpaceChar;
+    Char_HourSeparator: Result := DefaultFormatSettings.TimeSeparator;
+    Char_DateSeparator: Result := DefaultFormatSettings.DateSeparator;
+  end;
 end;
 
 
-
-
-procedure TMaskUtils.DoUpper;
+procedure TMaskUtils.SetMask(AValue: String);
+Var
+  S, AMaskPart : String;
+  I            : Integer;
+  InUp, InDown : Boolean;
+  Special      : Boolean;
+  Ch           : Char;
 begin
- {$ifdef DebugMaskUtils}
-  DebugLn(['DoUpper',',Position=',Position]);
- {$endif}
-  if stLower in State then
-   Exclude(State,stLower)
-  else
-    Include(State,stUpper);
-
-  {Ugly check for '<>' sequence. Is that required ?}
-  if (Position > 1) and (FMask[Position-1] = '<') then
+  if FRealMask <> AValue then
+  begin
+    FRealMask := AValue;
+    FMask := '';
+    SplitEditMask(FRealMask, AMaskPart, FMaskSave, FSpaceChar);
+
+    // Construct Actual Internal Mask
+    // init
+    FTrimType := metTrimRight;
+    // Init: No UpCase, No LowerCase, No Special Char
+    InUp      := False;
+    InDown    := False;
+    Special   := False;
+    S         := AMaskPart;
+    for I := 1 to Length(S) do
     begin
-      Exclude(State,stLower);
-      Exclude(State,stUpper);
+      Ch := S[I];
+      // Must insert a special char
+      if Special then
+      begin
+        AddToMask(Ch);
+        Special := False;
+      end
+      else
+      begin
+        // Check the char to insert
+
+        case Ch Of
+             cMask_SpecialChar: Special := True;
+             cMask_UpperCase: begin
+               if (I > 1) and (S[I-1] = cMask_LowerCase) then
+               begin// encountered <>, so no case checking after this
+                 InUp := False;
+                 InDown := False
+               end else
+               begin
+                 InUp    := True;
+                 InDown := False;
+               end;
+             end;
+
+             cMask_LowerCase: begin
+                InDown  := True;
+                InUp := False;
+                // <> is catched by next cMask_Uppercase
+             end;
+
+             cMask_Letter: begin
+                if InUp
+                then
+                  AddToMask(MaskToChar(Char_LetterUpCase))
+                else
+                  if InDown
+                  then
+                    AddToMask(MaskToChar(Char_LetterDownCase))
+                  else
+                    AddToMask(MaskToChar(Char_Letter))
+             end;
+
+             cMask_LetterFixed: begin
+                if InUp
+                then
+                  AddToMask(MaskToChar(Char_LetterFixedUpCase))
+                else
+                  if InDown
+                  then
+                    AddToMask(MaskToChar(Char_LetterFixedDownCase))
+                  else
+                    AddToMask(MaskToChar(Char_LetterFixed))
+             end;
+
+             cMask_AlphaNum: begin
+                 if InUp
+                 then
+                   AddToMask(MaskToChar(Char_AlphaNumUpcase))
+                 else
+                   if InDown
+                   then
+                     AddToMask(MaskToChar(Char_AlphaNumDownCase))
+                   else
+                     AddToMask(MaskToChar(Char_AlphaNum))
+             end;
+
+             cMask_AlphaNumFixed: begin
+                 if InUp
+                 then
+                   AddToMask(MaskToChar(Char_AlphaNumFixedUpcase))
+                 else
+                   if InDown
+                   then
+                     AddToMask(MaskToChar(Char_AlphaNumFixedDownCase))
+                   else
+                     AddToMask(MaskToChar(Char_AlphaNumFixed))
+             end;
+
+             cMask_AllChars: begin
+                if InUp
+                then
+                  AddToMask(MaskToChar(Char_AllUpCase))
+                else
+                  if InDown
+                  then
+                    AddToMask(MaskToChar(Char_AllDownCase))
+                  else
+                    AddToMask(MaskToChar(Char_All))
+             end;
+
+             cMask_AllCharsFixed: begin
+                if InUp
+                then
+                  AddToMask(MaskToChar(Char_AllFixedUpCase))
+                else
+                  if InDown
+                  then
+                    AddToMask(MaskToChar(Char_AllFixedDownCase))
+                  else
+                    AddToMask(MaskToChar(Char_AllFixed))
+             end;
+
+             cMask_Number: AddToMask(MaskToChar(Char_Number));
+
+             cMask_NumberFixed: AddToMask(MaskToChar(Char_NumberFixed));
+
+             cMask_NumberPlusMin: AddToMask(MaskToChar(Char_NumberPlusMin));
+
+             cMask_HourSeparator: AddToMask(MaskToChar(Char_HourSeparator));
+
+             cMask_DateSeparator: AddToMask(MaskToChar(Char_DateSeparator));
+
+             cMask_NoLeadingBlanks:
+             begin
+               FTrimType := metTrimLeft;
+             end;
+
+             else
+             begin
+               //It's a MaskLiteral
+               AddToMask(Ch);
+             end;
+        end;
+      end;
     end;
-end;
-
-procedure TMaskUtils.DoLower;
-begin
- {$ifdef DebugMaskUtils}
-  DebugLn(['DoLower',',Position=',Position]);
- {$endif}
-  if stUpper in State then
-   Exclude(State,stUpper)
-  else
-    Include(State,stLower);
+  end;
 end;
 
 
-procedure TMaskUtils.DoAlphaNumeric(Required : Boolean);
+function TMaskUtils.GetInputMask: String;
+var
+  i: Integer;
 begin
- {$ifdef DebugMaskUtils}
-  DebugLn(['DoAlphaNumeric',',Position=',Position]);
- {$endif}
-  if Required then
-    begin
-      if (IsAlpha(SourcePtr) or IsNumeric(SourcePtr)) then EvaluateExit
-      else
-        RaiseError;
-    end
-  else
-    begin
-      if (IsAlpha(SourcePtr) or IsNumeric(SourcePtr)) then EvaluateExit
-      else
-        EvaluateMissing;
+  Result := '';
+  for i := 1 to length(FMask) do
+  begin
+    case CharToMask(FMask[i]) of
+      Char_Number,
+      Char_NumberFixed,
+      Char_NumberPlusMin,
+      Char_Letter,
+      Char_LetterFixed,
+      Char_LetterUpCase,
+      Char_LetterDownCase,
+      Char_LetterFixedUpCase,
+      Char_LetterFixedDownCase,
+      Char_AlphaNum,
+      Char_AlphaNumFixed,
+      Char_AlphaNumUpCase,
+      Char_AlphaNumDownCase,
+      Char_AlphaNumFixedUpCase,
+      Char_AlphaNumFixedDownCase,
+      Char_All,
+      Char_AllFixed,
+      Char_AllUpCase,
+      Char_AllDownCase,
+      Char_AllFixedUpCase,
+      Char_AllFixedDownCase: Result := Result + #32;
+      Char_HourSeparator: Result := Result + DefaultFormatSettings.TimeSeparator;
+      Char_DateSeparator: Result := Result + DefaultFormatSettings.DateSeparator;
+      else Result := Result + FMask[i];   //it's a literal
     end;
-
+  end;
 end;
 
-procedure TMaskUtils.DoArbitrary(Required : Boolean);
-begin
- {$ifdef DebugMaskUtils}
-  DebugLn(['DoArbitrary',',Position=',Position]);
- {$endif}
-  Include(State,stArbitrary);
-  if Required then
+function TMaskUtils.GetTextWithoutMask(AValue: String): String;
+{
+  Replace al FSPaceChars with #32
+  If FMaskSave = False then do trimming of spaces and remove all maskliterals
+}
+var
+  S: String;
+  i: Integer;
+Begin
+  S := StringReplace(AValue, FSpaceChar, #32, [rfReplaceAll]);
+  //FSpaceChar can be used as a literal in the mask, so put it back
+  for i := 1 to FMaskLength do
+  begin
+    if IsLiteral(FMask[i]) and (FMask[i] = FSpaceChar) then
     begin
-      if Position > Length(SourceVal) then  RaiseError;
-    end
-  else
+      S[i] := FSpaceChar;
+    end;
+  end;
+  if not FMaskSave then
+  begin
+    for i := 1 to FMaskLength do
     begin
-      if Position > Length(SourceVal) then  EvaluateMissing
-      else
-        EvaluateExit;
+      if IsLiteral(FMask[i]) then S[i] := #1;
     end;
-end;
+    S := StringReplace(S, #1, '', [rfReplaceAll]);
+    //Trimming only occurs if FMaskSave = False
+    case FTrimType of
+      metTrimLeft : S := TrimLeft(S);
+      metTrimRight: S := TrimRight(S);
+    end;//case
+  end;
+  Result := S;
+End;
 
 
-procedure TMaskUtils.DoNumeric(Required : Boolean);
+function TMaskUtils.GetTextWithoutSpaceChar(AValue: String): String;
+var
+  i: Integer;
 begin
- {$ifdef DebugMaskUtils}
-  DebugLn(['DoNumeric',',Position=',Position]);
- {$endif}
-  if Required then
-    begin
-      if IsNumeric(SourcePtr) then EvaluateExit
-      else
-        RaiseError;
-    end
-  else
+  Result := StringReplace(AValue, FSpaceChar, #32, [rfReplaceAll]);
+  //FSpaceChar can be used as a literal in the mask, so put it back
+  for i := 1 to FMaskLength do
+  begin
+    if IsLiteral(FMask[i]) and (FMask[i] = FSpaceChar) then
     begin
-      if IsNumeric(SourcePtr) then EvaluateExit
-      else
-        EvaluateMissing;
+      Result[i] := FSpaceChar;
     end;
+  end;
 end;
 
-procedure TMaskUtils.DoNumericPlusMinus;
+function TMaskUtils.IsLiteral(Ch: Char): Boolean;
 begin
- {$ifdef DebugMaskUtils}
-  DebugLn(['DoNumericPlusMinus',',Position=',Position]);
- {$endif}
-  if (IsNumeric(SourcePtr)) or
-     (SourcePtr = '+') or
-     (SourcePtr = '-') then
-     EvaluateExit
-  else
-    EvaluateMissing;
+  Result := (not IsMaskChar(Ch)) or
+    (IsMaskChar(Ch) and (CharToMask(Ch) in [Char_HourSeparator, Char_DateSeparator]))
 end;
 
-
-procedure TMaskUtils.DoTime;
+function TMaskUtils.IsMaskChar(Ch: Char): Boolean;
 begin
- {$ifdef DebugMaskUtils}
-  DebugLn(['DoTime',',Position=',Position]);
- {$endif}
-  ExitVal := ExitVal + TimeSeparator;
+  Result := (CharToMask(Ch) <> Char_Start);
 end;
 
-
-
-procedure TMaskUtils.DoDate;
+procedure TMaskUtils.SetValue(AValue: String);
 begin
- {$ifdef DebugMaskUtils}
-  DebugLn(['DoDate',',Position=',Position]);
- {$endif}
-  ExitVal := ExitVal + DateSeparator;
+  if FValue = AValue then Exit;
+  FValue := AValue;
 end;
 
-function TMaskUtils.GetInputMask: string;
+function TMaskUtils.TextIsValid(const AValue: String): Boolean;
+var
+  i: Integer;
 begin
- {Prepare}
-  ExitVal := '';
-  Position := 1;
-  State := [];
-
- {Process}
-  while (Position <= Length(FMask)) do
+  Result := False;
+  if (Length(AValue) <> FMaskLength) then
+  begin
+    {$ifdef debug_maskutils}
+    writeln('Length(AValue) = ',Length(AValue),' FMaskLength = ',FMaskLength);
+    {$endif}
+    Exit; //Actually should never happen??
+  end;
+  for i := 1 to FMaskLength do
+  begin
+    if not CharMatchesMask(AValue[i], i) then
     begin
-      if (IsToken(MaskPtr) and not (stSpecial In State)) then
-       DoTokenInputMask
-      else
-        DoLiteralInputMask;
-
-      Inc(Position);
+      {$ifdef debug_maskutils}
+      writeln('Fail: CharMatchesMask(',AValue[i],',',i,')  [',AValue,']');
+      {$endif}
+      Exit;
     end;
-
-  Result := ExitVal;
+  end;
+  Result := True;
 end;
 
-
-
-
-
-procedure TMaskUtils.DoAlpha(Required : Boolean);
-begin
- {$ifdef DebugMaskUtils}
-  DebugLn(['DoAlpha',',Position=',Position]);
- {$endif}
-  if Required then
-    begin
-      if IsAlpha(SourcePtr) then
-      EvaluateExit
-      else
-        RaiseError;
-    end
-  else
+function TMaskUtils.ApplyMaskToText(AValue: String): String;
+{ This tries to mimic Delphi behaviour (D3):
+  - if mask contains no literals text is set, if necessary padded with blanks,
+    LTR or RTL depending on FTrimType
+  - if mask contains literals then we search for matching literals in text and
+    process each "segment" between matching maskliterals, trimming or padding
+    LTR or RTL depending on FTrimType, until there is no more matching maskliteral
+    Some examples to clarify:
+    EditMask        Text to be set    Result
+    99              1                 1_
+    !99             1                 _1
+    cc-cc           1-2               1_-2_
+    !cc-cc          1-2               _1-_2
+    cc-cc@cc        1-2@3             1_-2_@3_
+                    12@3              12-__@__
+    cc-cc@cc        123-456@789       12-45@78
+    !cc-cc@cc       123-456@789       23-56@89
+    This feauture seems to be invented for easy use of dates:
+
+    99/99/00        23/1/2009         23/1_/20  <- if your locale DateSeparator = '/'
+    !99/99/00       23/1/2009         23/_1/09  <- if your locale DateSeparator = '/'
+
+  - The resulting text will always have length = FMaskLength
+  - The text that is set, does not need to validate
+}
+//Helper functions
+  Function FindNextMaskLiteral(const StartAt: Integer; out FoundAt: Integer; out ALiteral: Char): Boolean;
+  var i: Integer;
+  begin
+    Result := False;
+    for i := StartAt to FMaskLength do
     begin
-      if IsAlpha(SourcePtr) then
-      EvaluateExit
-      else
-        EvaluateMissing;
+      if IsLiteral(FMask[i]) then
+      begin
+        FoundAt := i;
+        ALiteral := ClearChar(i);
+        Result := True;
+        Exit;
+      end;
     end;
-end;
-
-
-procedure TMaskUtils.DoToken;
-begin
-  if stArbitrary in State then Exclude(State,stArbitrary);
-
-  case MaskPtr of
-    '!' : Include(State,stLeading);
-    '>' : DoUpper;
-    '<' : DoLower;
-    '\' : Include(State,stSpecial);
-    'L' : DoAlpha(true);
-    'l' : DoAlpha(false);
-    'A' : DoAlphaNumeric(true);
-    'a' : DoAlphaNumeric(false);
-    'C' : DoArbitrary(true);
-    'c' : DoArbitrary(false);
-    '0' : DoNumeric(true);
-    '9' : DoNumeric(false);
-    '#' : DoNumericPlusMinus;
-    ':' : DoTime;
-    '/' : DoDate;
   end;
-
-end;
-
-
-
-procedure TMaskUtils.DoTokenInputMask;
-begin
-
-  case MaskPtr of
-    '!',
-    '>',
-    '<' : ;{nothing}
-    '\' : Include(State,stSpecial);
-    'L',
-    'l',
-    'A',
-    'a',
-    'C',
-    'c',
-    '0',
-    '9',
-    '#' : ExitVal := ExitVal + MissChar;
-    ':' : DoTime;
-    '/' : DoDate;
+  Function FindMatchingLiteral(const Value: String; const ALiteral: Char; out FoundAt: Integer): Boolean;
+  begin
+    FoundAt := Pos(ALiteral, Value);
+    Result := (FoundAt > 0);
   end;
 
-end;
-
-
-procedure TMaskUtils.DoLiteral;
-begin
- {$ifdef DebugMaskUtils}
-  DebugLn(['DoLiteral',',Position=',Position]);
- {$endif}
-  if stSpecial in State then
-   Exclude(State,stSpecial);
-  if Matched and (MaskPtr <> SourcePtr) then
-   RaiseError;
-  if Matched or not (IsAlpha(SourcePtr) or IsNumeric(SourcePtr)) then
-   Inc(SourcePosition);
-  ExitVal := ExitVal + MaskPtr;
-end;
-
-
-procedure TMaskUtils.DoLiteralInputMask;
+Var
+  S                   : String;
+  I, J                : Integer;
+  mPrevLit, mNextLit  : Integer; //Position of Previous and Next literal in FMask
+  vNextLit            : Integer; //Position of next matching literal in AValue
+  HasNextLiteral,
+  HasMatchingLiteral,
+  Stop                : Boolean;
+  Literal             : Char;
+  Sub                 : String;
 begin
-  if stSpecial in State then
-   Exclude(State,stSpecial);
-  ExitVal := ExitVal + MaskPtr;
-end;
-
-
-
-procedure TMaskUtils.DoFillRest;
-var
-  i : Integer;
-begin
-
-{Fill rest of exit value because source is longer then mask
-and the last mask character permit arbitrary char.
-Compatibility with delphi}
-
-  if (stArbitrary in State) then
+  //First setup a "blank" string that contains all literals in the mask
+  S := '';
+  for I := 1 To FMaskLength do  S := S + ClearChar(I);
+
+  if FMaskSave then
+  begin
+    mPrevLit := 0;
+    Stop := False;
+    HasNextLiteral := FindNextMaskLiteral(mPrevLit+1, mNextLit, Literal);
+    //if FMask starts with a literal, then the first CodePoint of AValue must be that literal
+    if HasNextLiteral and (mNextLit = 1) and (AValue[1] <> Literal) then Stop := True;
+    //debugln('HasNextLiteral = ',dbgs(hasnextliteral),', Stop = ',dbgs(stop));
+    While not Stop do
+    begin
+      if HasNextLiteral then
+      begin
+        HasMatchingLiteral := FindMatchingLiteral(AValue, Literal, vNextLit);
+        //debugln('mPrevLit = ',dbgs(mprevlit),' mNextLit = ',dbgs(mnextlit));
+        //debugln('HasMatchingLiteral = ',dbgs(hasmatchingliteral));
+        if HasMatchingLiteral then
+        begin
+          //debugln('vNextLit = ',dbgs(vnextlit));
+          Sub := Copy(AValue, 1, vNextLit - 1); //Copy up to, but not including matching literal
+          Delete(AValue, 1, vNextLit); //Remove this bit from AValue (including matching literal)
+          if (Length(AValue) = 0) then Stop := True;
+          //debugln('Sub = "',Sub,'", Value = "',AValue,'"');
+        end
+        else
+        begin//HasMatchingLiteral = False
+          Stop := True;
+          Sub := AValue;
+          AValue := '';
+          //debugln('Sub = "',Sub,'", Value = "',AValue,'"');
+        end;
+        //fill S between vPrevLit + 1 and vNextLit - 1, LTR or RTL depending on FTrimType
+        if (FTrimType = metTrimRight) then
+        begin
+          j := 1;
+          for i := (mPrevLit + 1) to (mNextLit - 1) do
+          begin
+            if (J > Length(Sub)) then Break;
+            if (Sub[j] = #32) then S[i] := FSpaceChar else S[i] := Sub[j];
+            Inc(j);
+          end;
+        end
+        else
+        begin//FTrimType = metTrimLeft
+          j := Length(Sub);
+          for i := (mNextLit - 1) downto (mPrevLit + 1) do
+          begin
+            if (j < 1) then Break;
+            if (Sub[j] = #32) then S[i] := FSpaceChar else S[i] :=  Sub[j];
+            Dec(j);
+          end;
+        end;
+        //debugln('S = ',S);
+      end
+      else
+      begin//HasNextLiteral = False
+        //debugln('No more MaskLiterals at this point');
+        //debugln('mPrevLit = ',dbgs(mprevlit));
+        Stop := True;
+        Sub := AValue;
+        AValue := '';
+        //debugln('Sub = "',Sub,'", Value = "',AValue,'"');
+        //fill S from vPrevLit + 1 until end of FMask, LTR or RTL depending on FTrimType
+        if (FTrimType = metTrimRight) then
+        begin
+          j := 1;
+          for i := (mPrevLit + 1) to FMaskLength do
+          begin
+            //debugln('  i = ',dbgs(i),'  j = ',dbgs(j));
+            if (j > Length(Sub)) then Break;
+            if (Sub[j] = #32) then S[i] := FSpaceChar else S[i] := Sub[j];
+            //debugln('  Sub[j] = "',Sub[j],'" -> S = ',S);
+            Inc(j);
+          end;
+        end
+        else
+        begin//FTrimType = metTrimLeft
+          j := Length(Sub);
+          for i := FMaskLength downto (mPrevLit + 1) do
+          begin
+            //debugln('  i = ',dbgs(i),'  j = ',dbgs(j));
+            if (j < 1) then Break;
+            if (Sub[j] = #32) then S[i] := FSpaceChar else S[i] := Sub[j];
+            //debugln('  Sub[j] = "',Sub[j],'" -> S = ',S);
+            Dec(j);
+          end;
+        end;
+        //debugln('S = ',S);
+      end;
+      //debugln('Stop = ',dbgs(stop));
+      if not Stop then
+      begin
+        mPrevLit := mNextLit;
+        HasNextLiteral := FindNextMaskLiteral(mPrevLit + 1, mNextLit, Literal);
+      end;
+    end;//while not Stop
+  end//FMaskSave = True
+  else
+  begin//FMaskSave = False
+    if FTrimType = metTrimRight then
+    begin
+      //fill text from left to rigth, skipping MaskLiterals
+      j := 1;
+      for i := 1 to FMaskLength do
+      begin
+        if not IsLiteral(FMask[i]) then
+        begin
+          if (AValue[j] = #32) then S[i]:= FSpaceChar else S[i] := AValue[j];
+          Inc(j);
+          if j > Length(AValue) then Break;
+        end;
+      end;
+    end
+    else
     begin
-      i := Length(SourceVal) - Length(FMask);
-      while i >= 0 do
+      //fill text from right to left, skipping MaskLiterals
+      j := Length(AValue);
+      for i := FMaskLength downto 1 do
+      begin
+        if not IsLiteral(FMask[i]) then
         begin
-          EvaluateExit;
-          Dec(i);
+          if (AValue[j] = #32) then S[i] := FSpaceChar else S[i] := AValue[j];
+          Dec(j);
+          if j < 1 then Break;
         end;
+      end;
     end;
+  end;//FMaskSave = False
+  Result := S;
 end;
 
-
-
-
-function FormatMaskText(const EditMask: string; const Value: string): string;
-var
-  msk : TMaskUtils;
+function TMaskUtils.ValidateInput: String;
 begin
-  Result := '';
-  msk := TMaskUtils.Create;
-  try
-    msk.Mask := EditMask;
-    msk.Value := Value;
-    Result := msk.ValidateInput;
-  finally
-    msk.Free;
-  end;
+  if not TryValidateInput(Result) then
+    raise Exception.Create(exValidationFailed);
 end;
 
-{Returns preprocessed mask (without escape characters, with currect locale date
-and time separators) }
-function FormatMaskInput(const EditMask: string): string;
+function TMaskUtils.TryValidateInput(out ValidatedString: String): Boolean;
 var
-  msk : TMaskUtils;
+  SMaskApplied, SMaskRemoved: String;
+  _MaskSave: Boolean;
 begin
-  Result := '';
-  msk := TMaskUtils.Create;
-  try
-    msk.Mask := EditMask;
-    Result := msk.InputMask;
-  finally
-    msk.Free;
-  end;
+  _MaskSave := FMaskSave;
+  //Note: applying the mask and then removing it is not reciprocal!
+  SMaskApplied := ApplyMaskToText(Value);
+  FMaskSave := True;
+  SMaskRemoved := GetTextWithoutMask(SMaskApplied);
+  FMaskSave := _MaskSave;
+  Result := TextIsValid(SMaskRemoved);
+  if Result then
+    ValidatedString := GetTextWithoutSpaceChar(SMaskApplied);
 end;
 
-{
-  Format Value string using EditMask, dont use 2d and 3d fields of EditMask,
-  set own Blank char and Matched = False
-}
-function MaskDoFormatText(const EditMask: string; const Value: string; Blank: Char): string;
-var
-  msk : TMaskUtils;
-begin
-  Result := '';
-  msk := TMaskUtils.Create;
-  try
-    msk.Mask := EditMask;
-    msk.Value := Value;
-    msk.Matched := False;
-    msk.MissChar := Blank;
-    Result := msk.ValidateInput;
-  finally
-    msk.Free;
-  end;
-end;
+
 
 end.
 

packages/fcl-base/tests/fclbase-unittests.lpi

@@ -30,7 +30,7 @@
     <RunParams>
       <local>
         <FormatVersion Value="1"/>
-        <CommandLineParams Value="--suite=TTestParserVariables.TestVariable31"/>
+        <CommandLineParams Value="--suite=TTestExpressionScanner.TestNumber"/>
       </local>
     </RunParams>
     <Units Count="3">

packages/fcl-base/tests/fclbase-unittests.pp

@@ -4,7 +4,7 @@ program fclbase_unittests;
 
 uses
   Classes, consoletestrunner, tests_fptemplate, tchashlist,
-  testexprpars;
+  testexprpars, tcmaskutils;
 
 var
   Application: TTestRunner;

packages/fcl-base/tests/tcmaskutils.pp

@@ -0,0 +1,31 @@
+unit tcmaskutils;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, fpcunit;
+
+Type
+
+  { TTestMaskUtils }
+
+  TTestMaskUtils = Class(TTestCase)
+  Published
+    Procedure Test1;
+  end;
+
+implementation
+
+{ TTestMaskUtils }
+
+procedure TTestMaskUtils.Test1;
+begin
+  AssertEquals('H1H357-K808K-44616-YK8720',FormatMaskText('!>cccccc\-ccccc\-ccccc\-cccccc;0;*', 'H1H357K808K44616YK8720'))
+end;
+
+initialization
+  RegisterTest(TTestMaskUtils);
+end.
+