[Back to PARSING SWAG index] [Back to Main SWAG index] [Original]

    UNIT match;

     (*  DESCRIPTION :
      * 12 tests of character sets
      * 8  new string operators
      * Pattern matching  and mask checking

         RELEASE     :  2.0
         DATE        :  09/08/93
         AUTHOR      :  Fernand LEMOINE
                        rue du Collge 34
                        B-6200 CHATELET
                        BELGIQUE
         All code granted to the public domain
         Questions and comments are welcome
         REQUIREMENT :  Turbo Pascal 4.0 or later
                        OPSTRING,OPABSFLD (Object Professional) from
                           Turbo Power Software
         Compatible with Borland Pascal protected mode
      *)

    INTERFACE
    CONST
      NullNumber = - MaxInt;      (* reserved for future use *)
      BlankChar      : SET OF Char = [#32];
      UpperOnlyset   : SET of Char = ['A'..'Z',#32,#128,#142..#144,
                                      #153,#154,#165];
      LowerOnlyset   : SET of Char = ['a'..'z',#32,#129..#141,#145,#147..#152,
                                     #160..#164];
      ForeignSet     : SET of Char = [#128..#154,#160..#167];
      CntrlSet       : SET of Char = [#0..#31,#127];
      PunctSet       : SET of Char = [#33,#39..#41,#44..#47,#58..#59,#63];
      GraphicSet     : SET of Char = [#176..#223];
      PrintOnlyset   : SET of Char = [#32..#126,#128..#254];
      SpecificSet :    SET OF Char = []; (* must be modified by user *)
      Delims :         SET OF Char = [' ', ',', '/'];
      ProperSet :      SET OF Char = [' ', '-'];

    TYPE
      MatchOperator = (like, nsequal, between, not_between,
                       into, not_into, pattern, mask);

    (* Does the string S contain ONLY Alphabetic characters ? *)
    FUNCTION IsAlphabetic(S : String) : Boolean;
    (* Does the string S contain ONLY upper case characters ? *)
    FUNCTION IsUpperCase(S : String) : Boolean;
    (* Does the string S contain ONLY lower case characters ? *)
    FUNCTION IsLowerCase(S : String) : Boolean;
    (* Are the first characters of a name or a first name into S
        a upper case  character,
        and the others  lower case  characters ? *)
    FUNCTION IsMixedCase(S : String) : Boolean;
    (* Does the string S contain ONLY a space    character  ? *)
    FUNCTION IsSpace(S : String) : Boolean;
    (* Does the string S contain ONLY a null character ('') ? *)
    FUNCTION IsNullString(S : String) : Boolean;
    (* Does the string S contain ONLY a null     number     ? *)
    FUNCTION IsNullNumber(N : Real) : Boolean;
    (* Does the string S contain ONLY a number ('0'.. '9'   ? *)
    FUNCTION IsNumber(S : String) : Boolean;
    (* Does the string S contain ONLY number
                                     space, minus and comma characters ? *)
    FUNCTION IsDigit(S : String) : Boolean;
    (* Does the string S contain ONLY number,space, minus and comma
                                     'E' or 'e'  characters  ? *)
    FUNCTION IsScientific(S : String) : Boolean;
    (* Does the string S contain ONLY number and 'A'..'F' characters ? *)
    FUNCTION IsXdigit(S : String) : Boolean;
    (* Does the string S contain ONLY characters in an user-defined set ? *)
    FUNCTION IsSpecific(S : String) : Boolean;

    (*      The string S is compared  with the string P  by a match operator :

        like        : phonetic comparison
        nsequal     : not strictly equal ---> no difference between upper and
                      lower case, neither trailing nor leading spaces
        between     : between lower and upper limit
        not_between : negation of BETWEEN
        into        : selection in a value list
        not_into    : negation of INTO
        pattern     : matching a pattern with wildcards
                      * : any single character
                      ? : any series of characters
                      ~ : NOT
        mask;       : enables selected position of a field to be checked for a
                      specific content
          '-' : position that is not to be checked
          'A' : check for alphabetic characters ( upper or lower case)
          'a' : check for upper case alphabetic characters
          'l' : check for lower case alphabetic characters
          'K' : check for hexadecimal content
          '@' : check for number;
          '#' : check for digit;
          'E' : check for number in exponential notation
          'B' : check for blank
          '%' : check for percent
          'f' : check for foreign characters
          'u' : check for punctuation ! ' ( ) , - . / : ; ?
          'g' : check for semi-graphic characters
          'o' : check for control characters
          'p' : check for any printing characters
          'B' : check for characters in BooleanSet
          'Y' : check for characters in YesNoSet
     *)

    FUNCTION DMatch(S : String; op : MatchOperator; P : String) : Boolean;

    IMPLEMENTATION
    USES opstring, opabsfld;
    VAR
      tmp : Boolean;
      errormask : Byte;

      (*-------------------------   String handling  ------------------------------------------------*)

      FUNCTION IsAlphabetic(S : String) : Boolean;
      VAR
        i : Byte;
      BEGIN
        tmp := True; i := 1;
        WHILE (i <= Length(S)) AND tmp DO
        BEGIN
          tmp := S[i] IN AlphaOnlySet; Inc(i);
        END;
        IsAlphabetic := tmp;
      END;

      FUNCTION IsUpperCase(S : String) : Boolean;
      VAR
        i : Byte;
      BEGIN
        tmp := True; i := 1;
        WHILE (i <= Length(S)) AND tmp DO
        BEGIN
          tmp := S[i] IN UpperOnlyset; Inc(i);
        END;
        IsUpperCase := tmp;
      END;

      FUNCTION IsLowerCase(S : String) : Boolean;
      VAR
        i : Byte;
      BEGIN
        tmp := True; i := 1;
        WHILE (i <= Length(S)) AND tmp DO
        BEGIN
          tmp := S[i] IN LowerOnlyset; Inc(i);
        END;
        IsLowerCase := tmp;
      END;

      FUNCTION IsMixedCase(S : String) : Boolean;
      VAR
        noword, nopos1, nopos2, i : Byte;
        inter : String;
      BEGIN
        noword := WordCount(S, ProperSet);
        tmp := True; i := 1;
        WHILE (i <= noword) AND tmp DO
        BEGIN
          nopos1 := WordPosition(i, S, ProperSet);
          IF i < noword THEN
            nopos2 := (WordPosition(i + 1, S, ProperSet) - 2)
          ELSE
            nopos2 := Length(S);
          inter := Copy(S, nopos1, nopos2);
          tmp := IsUpperCase(inter[1]);
          IF tmp THEN
          BEGIN
            Delete(inter, 1, 1);
            tmp := IsLowerCase(inter);
          END;
          Inc(i, 1);
        END;
        IsMixedCase := tmp;
      END;

      FUNCTION IsSpace(S : String) : Boolean;
      BEGIN
        IF S <> '' THEN
          IsSpace := S = CharStr(' ', Length(S))
        ELSE
          IsSpace := False;
      END;

      FUNCTION IsNullString(S : String) : Boolean;
      BEGIN
        IsNullString := S = '';
      END;

      FUNCTION IsNullNumber(N : Real) : Boolean;
      BEGIN
        IsNullNumber := N = NullNumber;
      END;

      FUNCTION IsNumber(S : String) : Boolean;
      VAR
        i : Byte;
      BEGIN
        tmp := True; i := 1;
        WHILE (i <= Length(S)) AND tmp DO
        BEGIN
          tmp := S[i] IN (NumberOnlySet - BlankChar); Inc(i);
        END;
        IsNumber := tmp;
      END;

      FUNCTION IsDigit(S : String) : Boolean;
      VAR
        i : Byte;
      BEGIN
        tmp := True; i := 1;
        WHILE (i <= Length(S)) AND tmp DO
        BEGIN
          tmp := S[i] IN DigitOnlySet; Inc(i);
        END;
        IsDigit := tmp;
      END;

      FUNCTION IsScientific(S : String) : Boolean;
      VAR
        i : Byte;
      BEGIN
        tmp := True; i := 1;
        WHILE (i <= Length(S)) AND tmp DO
        BEGIN
          tmp := S[i] IN ScientificSet; Inc(i);
        END;
        IsScientific := tmp;
      END;

      FUNCTION IsXdigit(S : String) : Boolean;
      VAR
        i : Byte;
      BEGIN
        tmp := True; i := 1;
        WHILE (i <= Length(S)) AND tmp DO
        BEGIN
          tmp := S[i] IN HexOnlySet; Inc(i);
        END;
        IsXdigit := tmp;
      END;

      FUNCTION IsSpecific(S : String) : Boolean;
      VAR
        i : Byte;
      BEGIN
        tmp := True; i := 1;
        WHILE (i <= Length(S)) AND tmp DO
        BEGIN
          tmp := S[i] IN SpecificSet; Inc(i);
        END;
        IsSpecific := tmp;
      END;

      (*-------------------------   Pattern matching ------------------------------------------------*)

      FUNCTION DMatch(S : String; op : MatchOperator; P : String) : Boolean;
      VAR
        S1, S2, S3 : String;
        Compar : compareType;
        Ind, J, N, Nprime : Byte;
        except : Boolean;

        FUNCTION PtInterr(S, P : String) : Boolean;
        VAR
          tmp : Boolean;
          i : Byte;

        BEGIN
          tmp := True; i := 1;
          WHILE (i <= Length(S)) AND tmp DO
          BEGIN
            IF P[i] <> '?' THEN
            BEGIN
              tmp := S[i] = P[i];
            END;
            Inc(i);
          END;
          PtInterr := tmp;
        END;

        FUNCTION Aster(S, P : String) : Boolean;
        VAR N : Byte;
        BEGIN
          tmp := True;
          N := Pos('*', P);
          IF N = 1 THEN
          BEGIN
            Delete(P, 1, 1);
            tmp := PtInterr(Copy(S, Length(S) -
                                 Length(P) + 1, Length(P)), P);
            Aster := tmp;
          END;

          IF N = Length(P) THEN
          BEGIN
            Delete(P, Length(P), 1);
            tmp := PtInterr(Copy(S, 1, Length(P)), P);
            Aster := tmp;
          END;
        END;

      BEGIN
        tmp := True;
        CASE op OF
          like : DMatch := Soundex(S) = Soundex(P);
          nsequal :
            BEGIN
              S1 := Trim(S); S2 := Trim(P);
              Compar := CompUCString(S1, S2);
              DMatch := Compar = equal;
            END;
          between :
            BEGIN
              N := WordPosition(2, P, Delims);
              DMatch := (Copy(P, 1, N - 2) < S)
              AND (S < Copy(P, N, (Length(P) - N + 1)));
            END;
          not_between :
            BEGIN
              N := WordPosition(2, P, Delims);
              DMatch := (S < Copy(P, 1, N - 2))
              OR (S > Copy(P, N, (Length(P) - N + 1)));
            END;

          into :
            BEGIN
              tmp := False; J := 1;
              Ind := WordCount(P, Delims);
              WHILE (J <= Ind) AND NOT tmp DO
              BEGIN
                N := WordPosition(J, P, Delims);
                IF J < Ind THEN
                BEGIN
                  Nprime := WordPosition(J + 1, P, Delims);
                  tmp := S = Copy(P, N, Nprime - N - 1);
                END
                ELSE
                  tmp := S = Copy(P, N, (Length(P) - N + 1));
                Inc(J);
              END;
              DMatch := tmp;
            END;

          not_into :
            BEGIN
              tmp := True; J := 1;
              Ind := WordCount(P, Delims);
              WHILE (J <= Ind) AND tmp DO
              BEGIN
                N := WordPosition(J, P, Delims);
                IF J < Ind THEN
                BEGIN
                  Nprime := WordPosition(J + 1, P, Delims);
                  tmp := S <> Copy(P, N, Nprime - N - 1);
                END
                ELSE
                  tmp := S <> Copy(P, N, (Length(P) - N + 1));
                Inc(J);
              END;
              DMatch := tmp;
            END;

          pattern :
            BEGIN

              except := Copy(P, 1, 1) = '~';
              IF except THEN Delete(P, 1, 1);
              N := Pos('*', P);
              Nprime := Pos('*', Copy(P, N + 1, Length(P) - N)) + N;
              IF Nprime > N THEN
                tmp := Pos(Copy(P, N + 1, Nprime - N - 1), S) <> 0
              ELSE
                IF Pos('*', P) <> 0 THEN
                  tmp := Aster(S, P)
              ELSE
                IF Pos('?', P) <> 0 THEN
                  tmp := PtInterr(S, P)
              ELSE
                tmp := S = P;
              IF except THEN DMatch := NOT tmp
              ELSE DMatch := tmp;
            END;

          mask :
            BEGIN
              tmp := True; J := 1; errormask := 0;
              WHILE (J <= Length(P)) AND tmp DO
              BEGIN
                CASE P[J] OF
                  '-' : BEGIN END;
                  'A' : tmp := S[J] IN AlphaOnlySet;
                  'a' : tmp := S[J] IN UpperOnlyset;
                  'l' : tmp := S[J] IN LowerOnlyset;
                  'K' : tmp := S[J] IN HexOnlySet;
                  '@' : tmp := S[J] IN NumberOnlySet - BlankChar;
                  '#' : tmp := S[J] IN DigitOnlySet;
                  'E' : tmp := S[J] IN ScientificSet;
                  'B' : tmp := S[J] IN BlankChar;
                  '%' : tmp := S[J] = '%';
                  'f' : tmp := S[J] IN ForeignSet;
                  'u' : tmp := S[J] IN PunctSet;
                  'g' : tmp := S[J] IN GraphicSet;
                  'o' : tmp := S[J] IN CntrlSet;
                  'p' : tmp := S[J] IN PrintOnlyset;
                  'B' : tmp := S[J] IN BooleanSet;
                  'Y' : tmp := S[J] IN YesNoSet;
                END;
                IF tmp = False THEN errormask := J;
                Inc(J);
              END;
              DMatch := tmp;
            END;
        END;
      END;

    END.

    {  ----------------  DEMO PROGRAM ------------- }

    program demmatch;
    (* Demonstration program for use of match unit *)

    uses crt,match;
    var

      S,S1,S2  : string;
      OK : boolean;

    begin
      clrscr;
      S := 'Jean Lemonier';
      Writeln('Demo match unit ');writeln;
      Writeln (' Jean Lemonier');
      Writeln ('Alphabetic ? ',IsAlphabetic (S));
      Writeln ('Upper case ? ',IsUpperCase  (S));
      Writeln ('Mixed case ? ',IsMixedcase  (S));

      Writeln;
      Writeln( '154.5');writeln;
      S2 :=  '154.5';
      Writeln ('Number ? ',IsNumber (S2));
      Writeln ('Digit  ? ',IsDigit  (S2));

      S1:= ' Jean LEMONIER  '; S2 := 'Je';
      Writeln;
      Writeln('Equivalent ',S, ' ',S1 ,'? ',Dmatch(S,nsequal,S1));
      Writeln('Je*,pattern,',s, '? ',Dmatch(S,pattern,'Je*'));
      Writeln('De*,pattern,',s, '? ',Dmatch(S,pattern,'De*'));
      Writeln('*er,pattern,',s, '? ',Dmatch(S,pattern,'*er'));
      Writeln('????? Lemonier,pattern,',s, '? ',
              Dmatch(S,pattern,'????? Lemonier'));
      Writeln('???? Lemonier,pattern,',s, '? ',
              Dmatch(S,pattern,'???? Lemonier'));
      Writeln('ll,mask ',s2, '? ',Dmatch(S2,mask,'ll'));
      Writeln('al,mask ',s2, '? ',Dmatch(S2,mask,'al'));
      delay(2500);
    end.

[Back to PARSING SWAG index] [Back to Main SWAG index] [Original]