freepascal.compiler/fvision/validate.pas

{ $Id$ }
{********[ SOURCE FILE OF GRAPHICAL FREE VISION ]**********}
{                                                          }
{   System independent GRAPHICAL clone of VALIDATE.PAS     }
{                                                          }
{   Interface Copyright (c) 1992 Borland International     }
{                                                          }
{   Copyright (c) 1996, 1997, 1998, 1999 by Leon de Boer   }
{   [email protected]                                        }
{                                                          }
{****************[ THIS CODE IS FREEWARE ]*****************}
{                                                          }
{     This sourcecode is released for the purpose to       }
{   promote the pascal language on all platforms. You may  }
{   redistribute it and/or modify with the following       }
{   DISCLAIMER.                                            }
{                                                          }
{     This SOURCE CODE is distributed "AS IS" WITHOUT      }
{   WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR     }
{   ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED.     }
{                                                          }
{*****************[ SUPPORTED PLATFORMS ]******************}
{     16 and 32 Bit compilers                              }
{        DOS      - Turbo Pascal 7.0 +      (16 Bit)       }
{        DPMI     - Turbo Pascal 7.0 +      (16 Bit)       }
{                 - FPC 0.9912+ (GO32V2)    (32 Bit)       }
{        WINDOWS  - Turbo Pascal 7.0 +      (16 Bit)       }
{                 - Delphi 1.0+             (16 Bit)       }
{        WIN95/NT - Delphi 2.0+             (32 Bit)       }
{                 - Virtual Pascal 2.0+     (32 Bit)       }
{                 - Speedsoft Sybil 2.0+    (32 Bit)       }
{                 - FPC 0.9912+             (32 Bit)       }
{        OS2      - Virtual Pascal 1.0+     (32 Bit)       }
{                                                          }
{******************[ REVISION HISTORY ]********************}
{  Version  Date        Fix                                }
{  -------  ---------   ---------------------------------  }
{  1.00     12 Jun 96   Initial DOS/DPMI code released.    }
{  1.10     29 Aug 97   Platform.inc sort added.           }
{  1.20     13 Oct 97   Delphi3 32 bit code added.         }
{  1.30     11 May 98   Virtual pascal 2.0 code added.     }
{  1.40     10 Jul 99   Sybil 2.0 code added               }
{  1.41     03 Nov 99   FPC windows code added             }
{**********************************************************}

UNIT Validate;

{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
                                  INTERFACE
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}

{====Include file to sort compiler platform out =====================}
{$I Platform.inc}
{====================================================================}

{==== Compiler directives ===========================================}

{$IFNDEF PPC_FPC}{ FPC doesn't support these switches }
  {$F-} { Short calls are okay }
  {$A+} { Word Align Data }
  {$B-} { Allow short circuit boolean evaluations }
  {$O+} { This unit may be overlaid }
  {$G+} { 286 Code optimization - if you're on an 8088 get a real computer }
  {$P-} { Normal string variables }
  {$N-} { No 80x87 code generation }
  {$E+} { Emulation is on }
{$ENDIF}

{$X+} { Extended syntax is ok }
{$R-} { Disable range checking }
{$S-} { Disable Stack Checking }
{$I-} { Disable IO Checking }
{$Q-} { Disable Overflow Checking }
{$V-} { Turn off strict VAR strings }
{====================================================================}

USES FVCommon, Objects;                                 { GFV standard units }

{***************************************************************************}
{                              PUBLIC CONSTANTS                             }
{***************************************************************************}

{---------------------------------------------------------------------------}
{                         VALIDATOR STATUS CONSTANTS                        }
{---------------------------------------------------------------------------}
CONST
   vsOk     = 0;                                      { Validator ok }
   vsSyntax = 1;                                      { Validator sytax err }

{---------------------------------------------------------------------------}
{                           VALIDATOR OPTION MASKS                          }
{---------------------------------------------------------------------------}
CONST
   voFill     = $0001;                                { Validator fill }
   voTransfer = $0002;                                { Validator transfer }
   voOnAppend = $0004;                                { Validator append }
   voReserved = $00F8;                                { Clear above flags }

{***************************************************************************}
{                            RECORD DEFINITIONS                             }
{***************************************************************************}

{---------------------------------------------------------------------------}
{                        VALIDATOR TRANSFER CONSTANTS                       }
{---------------------------------------------------------------------------}
TYPE
   TVTransfer = (vtDataSize, vtSetData, vtGetData);   { Transfer states }

{---------------------------------------------------------------------------}
{                    PICTURE VALIDATOR RESULT CONSTANTS                     }
{---------------------------------------------------------------------------}
TYPE
   TPicResult = (prComplete, prIncomplete, prEmpty, prError, prSyntax,
     prAmbiguous, prIncompNoFill);

{***************************************************************************}
{                            OBJECT DEFINITIONS                             }
{***************************************************************************}

{---------------------------------------------------------------------------}
{                TValidator OBJECT - VALIDATOR ANCESTOR OBJECT              }
{---------------------------------------------------------------------------}
TYPE
   TValidator = OBJECT (TObject)
         Status : Word;                               { Validator status }
         Options: Word;                               { Validator options }
      CONSTRUCTOR Load (Var S: TStream);
      FUNCTION Valid(CONST S: String): Boolean;
      FUNCTION IsValid (CONST S: String): Boolean; Virtual;
      FUNCTION IsValidInput (Var S: String;
        SuppressFill: Boolean): Boolean; Virtual;
      FUNCTION Transfer (Var S: String; Buffer: Pointer;
        Flag: TVTransfer): Word; Virtual;
      PROCEDURE Error; Virtual;
      PROCEDURE Store (Var S: TStream);
   END;
   PValidator = ^TValidator;

{---------------------------------------------------------------------------}
{           TPictureValidator OBJECT - PICTURE VALIDATOR OBJECT             }
{---------------------------------------------------------------------------}
TYPE
   TPXPictureValidator = OBJECT (TValidator)
         Pic: PString;                                { Picture filename }
      CONSTRUCTOR Init (Const APic: String; AutoFill: Boolean);
      CONSTRUCTOR Load (Var S: TStream);
      DESTRUCTOR Done; Virtual;
      FUNCTION IsValid (Const S: String): Boolean; Virtual;
      FUNCTION IsValidInput (Var S: String;
        SuppressFill: Boolean): Boolean; Virtual;
      FUNCTION Picture (Var Input: String;
        AutoFill: Boolean): TPicResult; Virtual;
      PROCEDURE Error; Virtual;
      PROCEDURE Store (Var S: TStream);
   END;
   PPXPictureValidator = ^TPXPictureValidator;

TYPE CharSet = TCharSet;

{---------------------------------------------------------------------------}
{            TFilterValidator OBJECT - FILTER VALIDATOR OBJECT              }
{---------------------------------------------------------------------------}
TYPE
   TFilterValidator = OBJECT (TValidator)
         ValidChars: CharSet;                         { Valid char set }
      CONSTRUCTOR Init (AValidChars: CharSet);
      CONSTRUCTOR Load (Var S: TStream);
      FUNCTION IsValid (CONST S: String): Boolean; Virtual;
      FUNCTION IsValidInput (Var S: String;
        SuppressFill: Boolean): Boolean; Virtual;
      PROCEDURE Error; Virtual;
      PROCEDURE Store (Var S: TStream);
   END;
   PFilterValidator = ^TFilterValidator;

{---------------------------------------------------------------------------}
{             TRangeValidator OBJECT - RANGE VALIDATOR OBJECT               }
{---------------------------------------------------------------------------}
TYPE
   TRangeValidator = OBJECT (TFilterValidator)
         Min: LongInt;                                { Min valid value }
         Max: LongInt;                                { Max valid value }
      CONSTRUCTOR Init(AMin, AMax: LongInt);
      CONSTRUCTOR Load (Var S: TStream);
      FUNCTION IsValid (Const S: String): Boolean; Virtual;
      FUNCTION Transfer (Var S: String; Buffer: Pointer;
        Flag: TVTransfer): Word; Virtual;
      PROCEDURE Error; Virtual;
      PROCEDURE Store (Var S: TStream);
   END;
   PRangeValidator = ^TRangeValidator;

{---------------------------------------------------------------------------}
{            TLookUpValidator OBJECT - LOOKUP VALIDATOR OBJECT              }
{---------------------------------------------------------------------------}
TYPE
   TLookupValidator = OBJECT (TValidator)
      FUNCTION IsValid (Const S: String): Boolean;                   Virtual;
      FUNCTION Lookup (Const S: String): Boolean;                    Virtual;
   END;
   PLookupValidator = ^TLookupValidator;

{---------------------------------------------------------------------------}
{      TStringLookUpValidator OBJECT - STRING LOOKUP VALIDATOR OBJECT       }
{---------------------------------------------------------------------------}
TYPE
   TStringLookupValidator = OBJECT (TLookupValidator)
         Strings: PStringCollection;
      CONSTRUCTOR Init (AStrings: PStringCollection);
      CONSTRUCTOR Load (Var S: TStream);
      DESTRUCTOR Done;                                               Virtual;
      FUNCTION Lookup (Const S: String): Boolean;                    Virtual;
      PROCEDURE Error;                                               Virtual;
      PROCEDURE NewStringList (AStrings: PStringCollection);
      PROCEDURE Store (Var S: TStream);
   END;
   PStringLookupValidator = ^TStringLookupValidator;

{***************************************************************************}
{                            INTERFACE ROUTINES                             }
{***************************************************************************}

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{                           OBJECT REGISTER ROUTINES                        }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{-RegisterValidate---------------------------------------------------
Calls RegisterType for each of the object types defined in this unit.
18May98 LdB
---------------------------------------------------------------------}
PROCEDURE RegisterValidate;

{***************************************************************************}
{                           OBJECT REGISTRATION                             }
{***************************************************************************}

{---------------------------------------------------------------------------}
{                 TPXPictureValidator STREAM REGISTRATION                   }
{---------------------------------------------------------------------------}
CONST
   RPXPictureValidator: TStreamRec = (
     ObjType: 80;                                     { Register id = 80 }
     {$IFDEF BP_VMTLink}                              { BP style VMT link }
     VmtLink: Ofs(TypeOf(TPXPictureValidator)^);
     {$ELSE}                                          { Alt style VMT link }
     VmtLink: TypeOf(TPXPictureValidator);
     {$ENDIF}
     Load: @TPXPictureValidator.Load;                 { Object load method }
     Store: @TPXPictureValidator.Store                { Object store method }
   );

{---------------------------------------------------------------------------}
{                  TFilterValidator STREAM REGISTRATION                     }
{---------------------------------------------------------------------------}
CONST
   RFilterValidator: TStreamRec = (
     ObjType: 81;                                     { Register id = 81 }
     {$IFDEF BP_VMTLink}                              { BP style VMT link }
     VmtLink: Ofs(TypeOf(TFilterValidator)^);
     {$ELSE}                                          { Alt style VMT link }
     VmtLink: TypeOf(TFilterValidator);
     {$ENDIF}
     Load: @TFilterValidator.Load;                    { Object load method }
     Store: @TFilterValidator.Store                   { Object store method }
   );

{---------------------------------------------------------------------------}
{                   TRangeValidator STREAM REGISTRATION                     }
{---------------------------------------------------------------------------}
CONST
   RRangeValidator: TStreamRec = (
     ObjType: 82;                                     { Register id = 82 }
     {$IFDEF BP_VMTLink}                              { BP style VMT link }
     VmtLink: Ofs(TypeOf(TRangeValidator)^);
     {$ELSE}                                          { Alt style VMT link }
     VmtLink: TypeOf(TRangeValidator);
     {$ENDIF}
     Load: @TRangeValidator.Load;                     { Object load method }
     Store: @TRangeValidator.Store                    { Object store method }
   );

{---------------------------------------------------------------------------}
{                TStringLookupValidator STREAM REGISTRATION                 }
{---------------------------------------------------------------------------}
CONST
   RStringLookupValidator: TStreamRec = (
     ObjType: 83;                                     { Register id = 83 }
     {$IFDEF BP_VMTLink}                              { BP style VMT link }
     VmtLink: Ofs(TypeOf(TStringLookupValidator)^);
     {$ELSE}                                          { Alt style VMT link }
     VmtLink: TypeOf(TStringLookupValidator);
     {$ENDIF}
     Load: @TStringLookupValidator.Load;              { Object load method }
     Store: @TStringLookupValidator.Store             { Object store method }
   );

{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
                                IMPLEMENTATION
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}

USES MsgBox;                                          { GFV standard unit }

{***************************************************************************}
{                              PRIVATE ROUTINES                             }
{***************************************************************************}

{---------------------------------------------------------------------------}
{  IsNumber -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB          }
{---------------------------------------------------------------------------}
FUNCTION IsNumber (Chr: Char): Boolean;
BEGIN
   If (Chr >= '0') AND (Chr <= '9') Then              { Check if '0..9' }
     IsNumber := True Else IsNumber := False;         { Return result }
END;

{---------------------------------------------------------------------------}
{  IsLetter -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB          }
{---------------------------------------------------------------------------}
FUNCTION IsLetter (Chr: Char): Boolean;
BEGIN
   Chr := Char(Ord(Chr) AND $DF);                     { Lower to upper case }
   If (Chr >= 'A') AND (Chr <='Z') Then               { Check if A..Z }
     IsLetter := True Else IsLetter := False;         { Return result }
END;

{---------------------------------------------------------------------------}
{  IsComplete -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB        }
{---------------------------------------------------------------------------}
FUNCTION IsComplete (Rslt: TPicResult): Boolean;
BEGIN
   IsComplete := Rslt IN [prComplete, prAmbiguous];   { Return if complete }
END;

{---------------------------------------------------------------------------}
{  IsInComplete -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB      }
{---------------------------------------------------------------------------}
FUNCTION IsIncomplete (Rslt: TPicResult): Boolean;
BEGIN
   IsIncomplete := Rslt IN
     [prIncomplete, prIncompNoFill];                  { Return if incomplete }
END;

{---------------------------------------------------------------------------}
{  NumChar -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB           }
{---------------------------------------------------------------------------}
FUNCTION NumChar (Chr: Char; Const S: String): Byte;
VAR I, Total: Byte;
BEGIN
   Total := 0;                                        { Zero total }
   For I := 1 To Length(S) Do                         { For entire string }
     If (S[I] = Chr) Then Inc(Total);                 { Count matches of Chr }
   NumChar := Total;                                  { Return char count }
END;

{---------------------------------------------------------------------------}
{  IsSpecial -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB         }
{---------------------------------------------------------------------------}
FUNCTION IsSpecial (Chr: Char; Const Special: String): Boolean;
VAR Rslt: Boolean; I: Byte;
BEGIN
   Rslt := False;                                     { Preset false result }
   For I := 1 To Length(Special) Do
     If (Special[I] = Chr) Then Rslt := True;         { Character found }
   IsSpecial := Rslt;                                 { Return result }
END;

{***************************************************************************}
{                               OBJECT METHODS                              }
{***************************************************************************}

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{                         TValidator OBJECT METHODS                         }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

{--TValidator---------------------------------------------------------------}
{  Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB              }
{---------------------------------------------------------------------------}
CONSTRUCTOR TValidator.Load (Var S:TStream);
BEGIN
   Inherited Init;                                    { Call ancestor }
   S.Read(Options, SizeOf(Options));                  { Read option masks }
END;

{--TValidator---------------------------------------------------------------}
{  Valid -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB             }
{---------------------------------------------------------------------------}
FUNCTION TValidator.Valid (Const S: String): Boolean;
BEGIN
   Valid := False;                                    { Preset false result }
   If Not IsValid(S) Then Error                       { Check for error }
     Else Valid := True;                              { Return valid result }
END;

{--TValidator---------------------------------------------------------------}
{  IsValid -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB           }
{---------------------------------------------------------------------------}
FUNCTION TValidator.IsValid (Const S: String): Boolean;
BEGIN
   IsValid := True;                                   { Default return valid }
END;

{--TValidator---------------------------------------------------------------}
{  IsValidInput -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB      }
{---------------------------------------------------------------------------}
FUNCTION TValidator.IsValidInput (Var S: String; SuppressFill: Boolean): Boolean;
BEGIN
   IsValidInput := True;                              { Default return true }
END;

{--TValidator---------------------------------------------------------------}
{  Transfer -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB          }
{---------------------------------------------------------------------------}
FUNCTION TValidator.Transfer (Var S: String; Buffer: Pointer;
  Flag: TVTransfer): Word;
BEGIN
   Transfer := 0;                                     { Default return zero }
END;

{--TValidator---------------------------------------------------------------}
{  Error -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB             }
{---------------------------------------------------------------------------}
PROCEDURE TValidator.Error;
BEGIN                                                 { Abstract method }
END;

{--TValidator---------------------------------------------------------------}
{  Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB             }
{---------------------------------------------------------------------------}
PROCEDURE TValidator.Store (Var S: TStream);
BEGIN
   S.Write(Options, SizeOf(Options));                 { Write options }
END;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{                    TPXPictureValidator OBJECT METHODS                     }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

{--TPXPictureValidator------------------------------------------------------}
{  Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB              }
{---------------------------------------------------------------------------}
CONSTRUCTOR TPXPictureValidator.Init (Const APic: String; AutoFill: Boolean);
VAR S: String;
BEGIN
   Inherited Init;                                    { Call ancestor }
   Pic := NewStr(APic);                               { Hold filename }
   Options := voOnAppend;                             { Preset option mask }
   If AutoFill Then Options := Options OR voFill;     { Check/set fill mask }
   S := '';                                           { Create empty string }
   If (Picture(S, False) <> prEmpty) Then             { Check for empty }
     Status := vsSyntax;                              { Set error mask }
END;

{--TPXPictureValidator------------------------------------------------------}
{  Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB              }
{---------------------------------------------------------------------------}
CONSTRUCTOR TPXPictureValidator.Load (Var S: TStream);
BEGIN
   Inherited Load(S);                                 { Call ancestor }
   Pic := S.ReadStr;                                  { Read filename }
END;

{--TPXPictureValidator------------------------------------------------------}
{  Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB              }
{---------------------------------------------------------------------------}
DESTRUCTOR TPXPictureValidator.Done;
BEGIN
   If (Pic <> Nil) Then DisposeStr(Pic);              { Dispose of filename }
   Inherited Done;                                    { Call ancestor }
END;

{--TPXPictureValidator------------------------------------------------------}
{  IsValid -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB           }
{---------------------------------------------------------------------------}
FUNCTION TPXPictureValidator.IsValid (Const S: String): Boolean;
VAR Str: String; Rslt: TPicResult;
BEGIN
   Str := S;                                          { Transfer string }
   Rslt := Picture(Str, False);                       { Check for picture }
   IsValid := (Pic = nil) OR (Rslt = prComplete) OR
     (Rslt = prEmpty);                                { Return result }
END;

{--TPXPictureValidator------------------------------------------------------}
{  IsValidInput -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB      }
{---------------------------------------------------------------------------}
FUNCTION TPXPictureValidator.IsValidInput (Var S: String;
  SuppressFill: Boolean): Boolean;
BEGIN
   IsValidInput := (Pic = Nil) OR (Picture(S,
    (Options AND voFill <> 0)  AND NOT SuppressFill)
     <> prError);                                     { Return input result }
END;

{--TPXPictureValidator------------------------------------------------------}
{  Picture -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB           }
{---------------------------------------------------------------------------}
FUNCTION TPXPictureValidator.Picture (Var Input: String; AutoFill: Boolean): TPicResult;
VAR I, J: Byte; Rslt: TPicResult; Reprocess: Boolean;

   FUNCTION Process (TermCh: Byte): TPicResult;
   VAR Rslt: TPicResult; Incomp: Boolean; OldI, OldJ, IncompJ, IncompI: Byte;

     PROCEDURE Consume (Ch: Char);
     BEGIN
       Input[J] := Ch;                                { Return character }
       Inc(J);                                        { Inc count J }
       Inc(I);                                        { Inc count I }
     END;

     PROCEDURE ToGroupEnd (Var I: Byte);
     VAR BrkLevel, BrcLevel: Integer;
     BEGIN
       BrkLevel := 0;                                 { Zero bracket level }
       BrcLevel := 0;                                 { Zero bracket level }
       Repeat
         If (I <> TermCh) Then Begin                  { Not end }
           Case Pic^[I] Of
             '[': Inc(BrkLevel);                      { Inc bracket level }
             ']': Dec(BrkLevel);                      { Dec bracket level }
             '{': Inc(BrcLevel);                      { Inc bracket level }
             '}': Dec(BrcLevel);                      { Dec bracket level }
             ';': Inc(I);                             { Next character }
             '*': Begin
                 Inc(I);                              { Next character }
                 While IsNumber(Pic^[I]) Do Inc(I);   { Search for text }
                 ToGroupEnd(I);                       { Move to group end }
                 Continue;                            { Now continue }
               End;
           End;
           Inc(I);                                    { Next character }
         End;
       Until ((BrkLevel = 0) AND (BrcLevel = 0)) OR   { Both levels must be 0 }
       (I = TermCh);                                  { Terminal character }
     END;

     FUNCTION SkipToComma: Boolean;
     BEGIN
       Repeat
         ToGroupEnd(I);                               { Find group end }
       Until (I = TermCh) OR (Pic^[I] = ',');         { Terminator found }
       If (Pic^[I] = ',') Then Inc(I);                { Comma so continue }
       SkipToComma := (I < TermCh);                   { Return result }
     END;

     FUNCTION CalcTerm: Byte;
     VAR K: Byte;
     BEGIN
       K := I;                                        { Hold count }
       ToGroupEnd(K);                                 { Find group end }
       CalcTerm := K;                                 { Return count }
     END;

     FUNCTION Iteration: TPicResult;
     VAR Itr, K, L: Byte; Rslt: TPicResult; NewTermCh: Byte;
     BEGIN
       Itr := 0;                                      { Zero iteration }
       Iteration := prError;                          { Preset error result }
       Inc(I);                                        { Skip '*' character }
       While (IsNumber(Pic^[I])) Do Begin             { Entry is a number }
         Itr := Itr * 10 + Byte(Pic^[I]) - Byte('0'); { Convert to number }
         Inc(I);                                      { Next character }
       End;
       If (I <= TermCh) Then Begin                    { Not end of name }
         K := I;                                      { Hold count }
         NewTermCh := CalcTerm;                       { Calc next terminator }
         If (Itr <> 0) Then Begin
           For L := 1 To Itr Do Begin                 { For each character }
             I := K;                                  { Reset count }
             Rslt := Process(NewTermCh);              { Process new entry }
             If (NOT IsComplete(Rslt)) Then Begin     { Not empty }
               If (Rslt = prEmpty) Then               { Check result }
                 Rslt := prIncomplete;                { Return incomplete }
               Iteration := Rslt;                     { Return result }
               Exit;                                  { Now exit }
             End;
           End;
         End Else Begin
           Repeat
             I := K;                                  { Hold count }
             Rslt := Process(NewTermCh);              { Process new entry }
           Until (NOT IsComplete(Rslt));              { Until complete }
           If (Rslt = prEmpty) OR (Rslt = prError)    { Check for any error }
           Then Begin
             Inc(I);                                  { Next character }
             Rslt := prAmbiguous;                     { Return result }
           End;
         End;
         I := NewTermCh;                              { Find next name }
       End Else Rslt := prSyntax;                     { Completed }
       Iteration := Rslt;                             { Return result }
     END;

     FUNCTION Group: TPicResult;
     VAR Rslt: TPicResult; TermCh: Byte;
     BEGIN
       TermCh := CalcTerm;                            { Calc new term }
       Inc(I);                                        { Next character }
       Rslt := Process(TermCh - 1);                   { Process the name }
       If (NOT IsIncomplete(Rslt)) Then I := TermCh;  { Did not complete }
       Group := Rslt;                                 { Return result }
     END;

     FUNCTION CheckComplete (Rslt: TPicResult): TPicResult;
     VAR J: Byte;
     BEGIN
       J := I;                                        { Hold count }
       If IsIncomplete(Rslt) Then Begin               { Check if complete }
         While True Do
           Case Pic^[J] Of
             '[': ToGroupEnd(J);                      { Find name end }
             '*': If (IsNumber(Pic^[J + 1]) = False)
               Then Begin
                 Inc(J);                              { Next name }
                 ToGroupEnd(J);                       { Find name end }
               End Else Break;
             Else Break;
           End;
         If (J = TermCh) Then Rslt := prAmbiguous;    { End of name }
       End;
       CheckComplete := Rslt;                         { Return result }
     END;

     FUNCTION Scan: TPicResult;
     VAR Ch: Char; Rslt: TPicResult;
     BEGIN
       Scan := prError;                               { Preset return error }
       Rslt := prEmpty;                               { Preset empty result }
       While (I <> TermCh) AND (Pic^[I] <> ',')       { For each entry }
       Do Begin
         If (J > Length(Input)) Then Begin            { Move beyond length }
           Scan := CheckComplete(Rslt);               { Return result }
           Exit;                                      { Now exit }
         End;
         Ch := Input[J];                              { Fetch character }
         Case Pic^[I] of
           '#': If (NOT IsNumber(Ch)) Then Exit       { Check is a number }
               Else Consume(Ch);                      { Transfer number }
           '?': If (NOT IsLetter(Ch)) Then Exit       { Check is a letter }
               Else Consume(Ch);                      { Transfer character }
           '&': If (NOT IsLetter(Ch)) Then Exit       { Check is a letter }
               Else Consume(UpCase(Ch));              { Transfer character }
           '!': Consume(UpCase(Ch));                  { Transfer character }
           '@': Consume(Ch);                          { Transfer character }
           '*': Begin
             Rslt := Iteration;                       { Now re-iterate }
             If (NOT IsComplete(Rslt)) Then Begin     { Check not complete }
               Scan := Rslt;                          { Return result }
               Exit;                                  { Now exit }
             End;
             If (Rslt = prError) Then                 { Check for error }
               Rslt := prAmbiguous;                   { Return ambiguous }
           End;
           '{': Begin
             Rslt := Group;                           { Return group }
             If (NOT IsComplete(Rslt)) Then Begin     { Not incomplete check }
               Scan := Rslt;                          { Return result }
               Exit;                                  { Now exit }
             End;
           End;
           '[': Begin
             Rslt := Group;                           { Return group }
             If IsIncomplete(Rslt) Then Begin         { Incomplete check }
               Scan := Rslt;                          { Return result }
               Exit;                                  { Now exit }
             End;
             If (Rslt = prError) Then                 { Check for error }
               Rslt := prAmbiguous;                   { Return ambiguous }
           End;
           Else If Pic^[I] = ';' Then Inc(I);         { Move fwd for follow }
           If (UpCase(Pic^[I]) <> UpCase(Ch)) Then    { Characters differ }
             If (Ch = ' ') Then Ch := Pic^[I]         { Ignore space }
             Else Exit;
           Consume(Pic^[I]);                          { Consume character }
         End; { Case }
         If (Rslt = prAmbiguous) Then                 { If ambiguous result }
           Rslt := prIncompNoFill                     { Set incomplete fill }
           Else Rslt := prIncomplete;                 { Set incomplete }
       End;{ While}
       If (Rslt = prIncompNoFill) Then                { Check incomp fill }
         Scan := prAmbiguous Else                     { Return ambiguous }
         Scan := prComplete;                          { Return completed }
     END;

   BEGIN
     Incomp := False;                                 { Clear incomplete }
     InCompJ:=0;                                      { set to avoid a warning }
     OldI := I;                                       { Hold I count }
     OldJ := J;                                       { Hold J count }
     Repeat
       Rslt := Scan;                                  { Scan names }
       If (Rslt IN [prComplete, prAmbiguous]) AND
       Incomp AND (J < IncompJ) Then Begin            { Check if complete }
         Rslt := prIncomplete;                        { Return result }
         J := IncompJ;                                { Return position }
       End;
       If ((Rslt = prError) OR (Rslt = prIncomplete)) { Check no errors }
       Then Begin
         Process := Rslt;                             { Hold result }
         If ((NOT Incomp) AND (Rslt = prIncomplete))  { Check complete }
         Then Begin
           Incomp := True;                            { Set incomplete }
           IncompI := I;                              { Set current position }
           IncompJ := J;                              { Set current position }
         End;
         I := OldI;                                   { Restore held value }
         J := OldJ;                                   { Restore held value }
         If (NOT SkipToComma) Then Begin              { Check not comma }
           If Incomp Then Begin                       { Check incomplete }
             Process := prIncomplete;                 { Set incomplete mask }
             I := IncompI;                            { Hold incomp position }
             J := IncompJ;                            { Hold incomp position }
           End;
           Exit;                                      { Now exit }
         End;
         OldI := I;                                   { Hold position }
       End;
     Until (Rslt <> prError) AND                      { Check for error }
       (Rslt <> prIncomplete);                        { Incomplete load }
     If (Rslt = prComplete) AND Incomp Then           { Complete load }
       Process := prAmbiguous Else                    { Return completed }
       Process := Rslt;                               { Return result }
   END;

   FUNCTION SyntaxCheck: Boolean;
   VAR I, BrkLevel, BrcLevel: Integer;
   Begin
     SyntaxCheck := False;                            { Preset false result }
     If (Pic^ <> '') AND (Pic^[Length(Pic^)] <> ';')  { Name is valid }
     AND ((Pic^[Length(Pic^)] = '*') AND
     (Pic^[Length(Pic^) - 1] <> ';') = False)         { Not wildcard list }
     Then Begin
       I := 1;                                        { Set count to 1 }
       BrkLevel := 0;                                 { Zero bracket level }
       BrcLevel := 0;                                 { Zero bracket level }
       While (I <= Length(Pic^)) Do Begin             { For each character }
         Case Pic^[I] Of
           '[': Inc(BrkLevel);                        { Inc bracket level }
           ']': Dec(BrkLevel);                        { Dec bracket level }
           '{': Inc(BrcLevel);                        { Inc bracket level }
           '}': Dec(BrcLevel);                        { Dec bracket level }
           ';': Inc(I);                               { Next character }
         End;
         Inc(I);                                      { Next character }
       End;
       If (BrkLevel = 0) AND (BrcLevel = 0) Then      { Check both levels 0 }
         SyntaxCheck := True;                         { Return true syntax }
     End;
   End;

BEGIN
   Picture := prSyntax;                               { Preset error default }
   If SyntaxCheck Then Begin                          { Check syntax }
     Picture := prEmpty;                              { Preset picture empty }
     If (Input <> '') Then Begin                      { We have an input }
       J := 1;                                        { Set J count to 1 }
       I := 1;                                        { Set I count to 1 }
       Rslt := Process(Length(Pic^) + 1);             { Set end of name }
       If (Rslt <> prError) AND (Rslt <> prSyntax) AND
        (J <= Length(Input)) Then Rslt := prError;    { Check for any error }
       If (Rslt = prIncomplete) AND AutoFill          { Check autofill flags }
       Then Begin
         Reprocess := False;                          { Set reprocess false }
         while (I <= Length(Pic^)) AND (NOT           { Not at end of name }
         IsSpecial(Pic^[I], '#?&!@*{}[],'#0))         { No special chars }
         DO Begin
           If Pic^[I] = ';' Then Inc(I);              { Check for next mark }
           Input := Input + Pic^[I];                  { Move to that name }
           Inc(I);                                    { Inc count }
           Reprocess := True;                         { Set reprocess flag }
         End;
         J := 1;                                      { Set J count to 1 }
         I := 1;                                      { Set I count to 1 }
         If Reprocess Then                            { Check for reprocess }
           Rslt := Process(Length(Pic^) + 1);         { Move to next name }
       End;
       If (Rslt = prAmbiguous) Then                   { Result ambiguous }
         Picture := prComplete Else                   { Return completed }
         If (Rslt = prInCompNoFill) Then              { Result incomplete }
           Picture := prIncomplete Else               { Return incomplete }
             Picture := Rslt;                         { Return result }
     End;
   End;
END;

{--TPXPictureValidator------------------------------------------------------}
{  Error -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB             }
{---------------------------------------------------------------------------}
PROCEDURE TPXPictureValidator.Error;
CONST PXErrMsg = 'Input does not conform to picture:';
VAR S: String;
BEGIN
   If (Pic <> Nil) Then S := Pic^ Else S := 'No name';{ Transfer filename }
   MessageBox(PxErrMsg + #13' %s', @S,  mfError OR
     mfOKButton);                                     { Message box }
END;

{--TPXPictureValidator------------------------------------------------------}
{  Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB             }
{---------------------------------------------------------------------------}
PROCEDURE TPXPictureValidator.Store (Var S: TStream);
BEGIN
  TValidator.Store(S);                                { TValidator.store call }
  S.WriteStr(Pic);                                    { Write filename }
END;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{                     TFilterValidator OBJECT METHODS                       }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

{--TFilterValidator---------------------------------------------------------}
{  Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB              }
{---------------------------------------------------------------------------}
CONSTRUCTOR TFilterValidator.Init (AValidChars: CharSet);
BEGIN
   Inherited Init;                                    { Call ancestor }
   ValidChars := AValidChars;                         { Hold valid char set }
END;

{--TFilterValidator---------------------------------------------------------}
{  Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB              }
{---------------------------------------------------------------------------}
CONSTRUCTOR TFilterValidator.Load (Var S: TStream);
BEGIN
   Inherited Load(S);                                 { Call ancestor }
   S.Read(ValidChars, SizeOf(ValidChars));            { Read valid char set }
END;

{--TFilterValidator---------------------------------------------------------}
{  IsValid -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB           }
{---------------------------------------------------------------------------}
FUNCTION TFilterValidator.IsValid (Const S: String): Boolean;
VAR I: Integer;
BEGIN
   I := 1;                                            { Start at position 1 }
   While S[I] In ValidChars Do Inc(I);                { Check each char }
   If (I > Length(S)) Then IsValid := True Else       { All characters valid }
     IsValid := False;                                { Invalid characters }
END;

{--TFilterValidator---------------------------------------------------------}
{  IsValidInput -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB      }
{---------------------------------------------------------------------------}
FUNCTION TFilterValidator.IsValidInput (Var S: String; SuppressFill: Boolean): Boolean;
VAR I: Integer;
BEGIN
   I := 1;                                            { Start at position 1 }
   While S[I] In ValidChars Do Inc(I);                { Check each char }
   If (I > Length(S)) Then IsValidInput := True       { All characters valid }
     Else IsValidInput := False;                      { Invalid characters }
END;

{--TFilterValidator---------------------------------------------------------}
{  Error -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB             }
{---------------------------------------------------------------------------}
PROCEDURE TFilterValidator.Error;
CONST PXErrMsg = 'Invalid character in input';
BEGIN
   MessageBox(PXErrMsg, Nil, mfError OR mfOKButton);  { Show error message }
END;

{--TFilterValidator---------------------------------------------------------}
{  Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB             }
{---------------------------------------------------------------------------}
PROCEDURE TFilterValidator.Store (Var S: TStream);
BEGIN
   TValidator.Store(S);                               { TValidator.Store call }
   S.Write(ValidChars, SizeOf(ValidChars));           { Write valid char set }
END;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{                      TRangeValidator OBJECT METHODS                       }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

{--TRangeValidator----------------------------------------------------------}
{  Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB              }
{---------------------------------------------------------------------------}
CONSTRUCTOR TRangeValidator.Init (AMin, AMax: LongInt);
BEGIN
   Inherited Init(['0'..'9','+','-']);                { Call ancestor }
   If (AMin >= 0) Then                                { Check min value > 0 }
     ValidChars := ValidChars - ['-'];                { Is so no negatives }
   Min := AMin;                                       { Hold min value }
   Max := AMax;                                       { Hold max value }
END;

{--TRangeValidator----------------------------------------------------------}
{  Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB              }
{---------------------------------------------------------------------------}
CONSTRUCTOR TRangeValidator.Load (Var S: TStream);
BEGIN
   Inherited Load(S);                                 { Call ancestor }
   S.Read(Min, SizeOf(Min));                          { Read min value }
   S.Read(Max, SizeOf(Max));                          { Read max value }
END;

{--TRangeValidator----------------------------------------------------------}
{  IsValid -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB           }
{---------------------------------------------------------------------------}
FUNCTION TRangeValidator.IsValid (Const S: String): Boolean;
VAR Value: LongInt; Code: Sw_Integer;
BEGIN
   IsValid := False;                                  { Preset false result }
   If Inherited IsValid(S) Then Begin                 { Call ancestor }
     Val(S, Value, Code);                             { Convert to number }
     If (Value >= Min) AND (Value <= Max)             { With valid range }
       AND (Code = 0) Then IsValid := True;           { No illegal chars }
   End;
END;

{--TRangeValidator----------------------------------------------------------}
{  Transfer -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB          }
{---------------------------------------------------------------------------}
FUNCTION TRangeValidator.Transfer (Var S: String; Buffer: Pointer; Flag: TVTransfer): Word;
VAR Value: LongInt; Code: Sw_Integer;
BEGIN
   If (Options AND voTransfer <> 0) Then Begin        { Tranfer mask set }
     Transfer := SizeOf(Value);                       { Transfer a longint }
     Case Flag Of
       vtGetData: Begin
         Val(S, Value, Code);                         { Convert s to number }
         LongInt(Buffer^) := Value;                   { Transfer result }
       End;
       vtSetData: Str(LongInt(Buffer^), S);           { Convert to string s }
     End;
   End Else Transfer := 0;                            { No transfer = zero }
END;

{--TRangeValidator----------------------------------------------------------}
{  Error -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB             }
{---------------------------------------------------------------------------}
PROCEDURE TRangeValidator.Error;
CONST PXErrMsg = 'Value not in the range';
VAR Params: Array[0..1] Of Longint;
BEGIN
   Params[0] := Min;                                  { Transfer min value }
   Params[1] := Max;                                  { Transfer max value }
   MessageBox(PXErrMsg+' %d to %d', @Params,
     mfError OR mfOKButton);                          { Display message }
END;

{--TRangeValidator----------------------------------------------------------}
{  Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB             }
{---------------------------------------------------------------------------}
PROCEDURE TRangeValidator.Store (Var S: TStream);
BEGIN
   TFilterValidator.Store(S);                         { TFilterValidator.Store }
   S.Write(Min, SizeOf(Min));                         { Write min value }
   S.Write(Max, SizeOf(Max));                         { Write max value }
END;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{                      TLookUpValidator OBJECT METHODS                      }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

{--TLookUpValidator---------------------------------------------------------}
{  IsValid -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB           }
{---------------------------------------------------------------------------}
FUNCTION TLookUpValidator.IsValid (Const S: String): Boolean;
BEGIN
   IsValid := LookUp(S);                              { Check for string }
END;

{--TLookUpValidator---------------------------------------------------------}
{  LookUp -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB            }
{---------------------------------------------------------------------------}
FUNCTION TLookupValidator.Lookup (Const S: String): Boolean;
BEGIN
   Lookup := True;                                    { Default return true }
END;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{                   TStringLookUpValidator OBJECT METHODS                   }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

{--TStringLookUpValidator---------------------------------------------------}
{  Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB              }
{---------------------------------------------------------------------------}
CONSTRUCTOR TStringLookUpValidator.Init (AStrings: PStringCollection);
BEGIN
   Inherited Init;                                    { Call ancestor }
   Strings := AStrings;                               { Hold string list }
END;

{--TStringLookUpValidator---------------------------------------------------}
{  Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB              }
{---------------------------------------------------------------------------}
CONSTRUCTOR TStringLookUpValidator.Load (Var S: TStream);
BEGIN
   Inherited Load(S);                                 { Call ancestor }
   Strings := PStringCollection(S.Get);               { Fecth string list }
END;

{--TStringLookUpValidator---------------------------------------------------}
{  Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB              }
{---------------------------------------------------------------------------}
DESTRUCTOR TStringLookUpValidator.Done;
BEGIN
   NewStringList(Nil);                                { Dispsoe string list }
   Inherited Done;                                    { Call ancestor }
END;

{--TStringLookUpValidator---------------------------------------------------}
{  Lookup -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB            }
{---------------------------------------------------------------------------}
FUNCTION TStringLookUpValidator.Lookup (Const S: String): Boolean;
{$IFDEF PPC_VIRTUAL} VAR Index: LongInt; {$ELSE} VAR Index: sw_Integer; {$ENDIF}
BEGIN
   Lookup := False;                                   { Preset false return }
   If (Strings <> Nil) Then
     Lookup := Strings^.Search(@S, Index);            { Search for string }
END;

{--TStringLookUpValidator---------------------------------------------------}
{  Error -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB             }
{---------------------------------------------------------------------------}
PROCEDURE TStringLookUpValidator.Error;
CONST PXErrMsg = 'Input not in valid-list';
BEGIN
   MessageBox(PXErrMsg, Nil, mfError OR mfOKButton);  { Display message }
END;

{--TStringLookUpValidator---------------------------------------------------}
{  NewStringList -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB     }
{---------------------------------------------------------------------------}
PROCEDURE TStringLookUpValidator.NewStringList (AStrings: PStringCollection);
BEGIN
   If (Strings <> Nil) Then Dispose(Strings, Done);   { Free old string list }
   Strings := AStrings;                               { Hold new string list }
END;

{--TStringLookUpValidator---------------------------------------------------}
{  Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB             }
{---------------------------------------------------------------------------}
PROCEDURE TStringLookUpValidator.Store (Var S: TStream);
BEGIN
   TLookupValidator.Store(S);                         { TlookupValidator call }
   S.Put(Strings);                                    { Now store strings }
END;

{***************************************************************************}
{                            INTERFACE ROUTINES                             }
{***************************************************************************}

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{                           OBJECT REGISTER ROUTINES                        }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

{---------------------------------------------------------------------------}
{  RegisterValidate -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 18May98 LdB  }
{---------------------------------------------------------------------------}
PROCEDURE RegisterValidate;
BEGIN
   RegisterType(RPXPictureValidator);                 { Register viewer }
   RegisterType(RFilterValidator);                    { Register filter }
   RegisterType(RRangeValidator);                     { Register validator }
   RegisterType(RStringLookupValidator);              { Register str lookup }
END;

END.

{
 $Log$
 Revision 1.8  2002-10-17 11:24:17  pierre
  * Clean up the Load/Store routines so they are endian independent

 Revision 1.7  2002/09/09 08:14:48  pierre
  * remove virtual modifer from store methods

 Revision 1.6  2002/09/07 15:06:38  peter
   * old logs removed and tabs fixed

}