Chip 2001 October/Chip_2001-10_cd1.bin/zkuste/delphi/kolekce/d456/DCSLIB25.ZIP/DCMaskTools.pas

Pascal/Delphi Source File | 2001-05-23 | 17KB | 637 lines

{
 BUSINESS CONSULTING
 s a i n t - p e t e r s b u r g

         Components Library for Borland Delphi 4.x, 5.x
         Copyright (c) 1998-2001 Alex'EM

}
unit DCMaskTools;

(*
 ⌠ε≡∞α≥ ∞α±ΩΦ Σδ  ΓΓεΣα
   'L'  - ┴≤ΩΓ√ , ═┼╬┴╒╬─╚╠█┼ φα ΣαφφεΘ ∩ετΦ÷ΦΦ
        Γετ∞εµφ√ ±δσΣ≤∙Φσ Γα≡Φαφ≥√ τα∩Φ±Φ:
          a. L          - δ■ß√σ ß≤ΩΓ√
          ß. L[a1a2.. ] - Σε∩≤±≥Φ∞√ ≥εδⁿΩε ß≤ΩΓ√ + [a1, a2, ...]
          Γ. L(a1a2.. ) - Σε∩≤±≥Φ∞√ δ■ß√σ ß≤ΩΓ√ τα Φ±Ωδ■≈σφΦσ∞ [a1, a2, ...]

   'l'  - ┴≤ΩΓ√, ∩ετΦ÷Φ  Ωε≥ε≡α  φσ εß τα≥σδⁿφα
        Γετ∞εµφ√ ±δσΣ≤∙Φσ Γα≡Φαφ≥√ τα∩Φ±Φ:
          a. l
          ß. l[a1a2.. ] - Σε∩≤±≥Φ∞√ ≥εδⁿΩε ß≤ΩΓ√ + [a1, a2, ...]
          Γ. l(a1a2.. )

   'A'  - ┴≤ΩΓ√ Φ ÷Φ⌠≡√, ═┼╬┴╒╬─╚╠█┼ φα ΣαφφεΘ ∩ετΦ÷ΦΦ
        Γετ∞εµφ√ ±δσΣ≤∙Φσ Γα≡Φαφ≥√ τα∩Φ±Φ:
          a. A
          ß. A[a1a2.. ] - Σε∩≤±≥Φ∞√ ≥εδⁿΩε ß≤ΩΓ√ + [a1, a2, ...]
          Γ. A(a1a2.. )

   'a'  - ┴≤ΩΓ√ Φ ÷Φ⌠≡√, ∩ετΦ÷Φ  Ωε≥ε≡α  φσ εß τα≥σδⁿφα
        Γετ∞εµφ√ ±δσΣ≤∙Φσ Γα≡Φαφ≥√ τα∩Φ±Φ:
          a. a
          ß. a[a1a2.. ]
          Γ. a(a1a2.. )

   '╤'  - ╨ατ≡σ°σφ√ δ■ß√σ ±Φ∞Γεδ√
        Γετ∞εµφ√ ±δσΣ≤∙Φσ Γα≡Φαφ≥√ τα∩Φ±Φ:
          a. ╤
          ß. ╤[a1a2.. ] - Σε∩≤±≥Φ∞√ ≥εδⁿΩε ÷Φ⌠≡√[a1, a2, ...]
          Γ. ╤(a1a2.. )

   '±'  - ╨ατ≡σ°σφ√ δ■ß√σ ±Φ∞Γεδ√
        Γετ∞εµφ√ ±δσΣ≤∙Φσ Γα≡Φαφ≥√ τα∩Φ±Φ:
          a. ±
          ß. ±[a1a2.. ] - [a1, a2, ...]
          Γ. ╤(a1a2.. )

   '0'  - ╓Φ⌠≡√, ═┼╬┴╒╬─╚╠█┼ φα ΣαφφεΘ ∩ετΦ÷ΦΦ
        Γετ∞εµφ√ ±δσΣ≤∙Φσ Γα≡Φαφ≥√ τα∩Φ±Φ:
          a. 0
          ß. 0[a1a2.. ] - Σε∩≤±≥Φ∞√ ≥εδⁿΩε ÷Φ⌠≡√[a1, a2, ...]
          Γ. 0(a1a2.. )

   '9'  - ╓Φ⌠≡√, ∩ετΦ÷Φ  Ωε≥ε≡α  φσ εß τα≥σδⁿφα
        Γετ∞εµφ√ ±δσΣ≤∙Φσ Γα≡Φαφ≥√ τα∩Φ±Φ:
          a. 9
          ß. 9[a1a2.. ]
          Γ. 9(a1a2.. )

   '!'  - ╤∩σ÷╤Φ∞Γεδ (∩ε±δσ φσπε ΦΣσ≥ ±Φ∞Γεδ, Ωε≥ε≡√Θ ∩εΣ±≥αΓδ σ≥±  αΓ≥ε∞α≥Φ≈σ±ΩΦ)
        Γετ∞εµφ√ ±δσΣ≤∙Φσ Γα≡Φαφ≥√ τα∩Φ±Φ:
          a. !c1          - σΣΦφΦ≈φ√Θ ±Φ∞Γεδ
          ß. ![c1c2.. ]   - ∩ε±δσΣεΓα≥σδⁿφε±≥ⁿ ±Φ∞ΓεδεΓ
          Γ. !(±1±2.. )r1 - Σε∩≤±≥Φ∞√ ±1,c2 - εφΦ τα∞σ∙α■≥±  φα r1

   '<u>', '</u>'  - ┬±σ ΓΓεΣΦ∞√σ ±Φ∞Γεδ√ ß≤Σ≤≥ ∩≡σεß≡ατεΓ√Γα≥ⁿ±  Γ Γσ≡⌡φΦΘ ≡σπΦ±≥≡
   '<l>', '</l>'  - ┬±σ ΓΓεΣΦ∞√σ ±Φ∞Γεδ√ ß≤Σ≤≥ ∩≡σεß≡ατεΓ√Γα≥ⁿ±  Γ φΦµφΦΘ ≡σπΦ±≥≡

   '{<≈Φ±δε ∩εΓ≥ε≡σφΦΘ>}' - ╧ε±δσ Γ±σ⌡ ⌠ε≡∞α≥εΓ Σε∩≤±≥ΦΓε ταΣαφΦσ ΩεδδΦ≈σ±≥Γα ∩εΓ≥ε≡σφΦΘ
       ex:
          a. 9{18}!.9{2}
          ß. 9{18}!(.,).9{2}
          Γ. a[IVXLMC]{10}

   P.S. Γφ≤≥≡Φ ±ΩεßεΩ [], () Σε∩≤±≥Φ∞ τφαΩ '#' - ∩εΩατ√Γασ≥, ≈≥ε ±δσΣε∞ τα φΦ∞ ΦΣσ≥ ±Φ∞Γεδ
        ∩ε±δσΣεΓα≥σδⁿφε±≥Φ, α φσ ±∩σ÷±Φ∞Γεδ (αΩ≥≤αδⁿφε Σδ  ±Φ∞ΓεδεΓ ']' Φ ')')
*)

interface

type
  TMaskCharSet = set of Char;
  TMaskOption  = (moUpperCase, moLowerCase, moRequired);
  TMaskOptions = set of TMaskOption;
  TMaskType    = (mtMask, mtSymbol);

  TMaskItem = packed record
    case MaskType: TMaskType of
      mtMask:
        (MChars: set of Char;
         Options: TMaskOptions;
         Exclude: boolean);
      mtSymbol:
        (SChars: set of Char;
         Symbol: Char;
         Replace: boolean);
  end;

  PEditMasks_tag = ^TEditMasks;
  TEditMasks = packed array [0..0] of TMaskItem;

  TEditMask = packed record
    Capacity: smallint;
    Count: smallint;
    Masks: PEditMasks_tag;
  end;

procedure EMSetCapacity(var EditMask: TEditMask; Capacity: smallint);
procedure EMAddItem(var EditMask: TEditMask; MaskItem: TMaskItem);
procedure EMClear(var EditMask: TEditMask);
procedure EMInitStruct(Value: string; var EditMask: TEditMask);

function EMMatches(var Value: string; EditMask: TEditMask; SkipSymbols: boolean;
  var SymbolsCount: integer; FullMask: boolean; var MaskEnd: integer): integer;

function EMDeleteChar(var Value: string; EditMask: TEditMask;
  SelStart, SelEnd: integer): integer;

procedure EMInsertChar(var Value: string; InsertStr: string; EditMask: TEditMask;
  var SelStart, SelEnd: integer);

procedure EMCompeteChar(var Value: string; EditMask: TEditMask; MaskEnd: integer;
  var SelStart, SelEnd: integer);

procedure EMClearSymbols(var Value: string; EditMask: TEditMask; MaskEnd: integer;
  var SelStart: integer);

implementation

uses SysUtils, Windows;

procedure EMSetCapacity(var EditMask: TEditMask; Capacity: smallint);
begin
  ReallocMem(EditMask.Masks, Capacity*SizeOf(TMaskItem));
  EditMask.Capacity := Capacity;
end;

procedure EMClear(var EditMask: TEditMask);
begin
  ReallocMem(EditMask.Masks, 0);
  EditMask.Capacity := 0;
  EditMask.Count    := 0;
end;

procedure EMAddItem(var EditMask: TEditMask; MaskItem: TMaskItem);
begin
  with EditMask do
  begin
    if Count = Capacity then EMSetCapacity(EditMask, Capacity + 4);
    Masks[Count] := MaskItem;
    Inc(Count);
  end;
end;

procedure EMInitStruct(Value: string; var EditMask: TEditMask);
 const
   Numbers: TMaskCharSet = ['0'..'9'];
   Letters: TMaskCharSet = ['A'..'Z', 'a'..'z', Chr($C0)..Chr($FF), Chr($A8), Chr($B8)];

 var
  P: PChar;
  MaskState: TMaskOptions;
  SCount: integer;

  procedure ScanTag(AddTag: boolean);
  begin
    Inc(P);
    while not(P^ in [#0, '>']) do
    begin
      case P^ of
        'u':
          if AddTag then
            MaskState := MaskState + [moUpperCase]
          else
            MaskState := MaskState - [moUpperCase];
        'l':
          if AddTag then
            MaskState := MaskState + [moLowerCase]
          else
            MaskState := MaskState - [moLowerCase];
        '/':
          if AddTag then
          begin
            ScanTag(False);
            Exit;
          end;
      end;
      Inc(P);
    end;
    if P^ = '>' then Inc(P);
  end;

  procedure ScanSymbol(Sequence: boolean);
   var
    ScanChars: TMaskCharSet;

    procedure AddSymbol(Symbol: Char; AReplace: boolean = False);
      var
       MaskItem: TMaskItem;
    begin
      MaskItem.MaskType := mtSymbol;
      MaskItem.Symbol   := Symbol;
      MaskItem.SChars   := ScanChars;
      MaskItem.Replace  := AReplace;
      EMAddItem(EditMask, MaskItem);
    end;

  begin
    if not Sequence then SCount := 0;
    Inc(P);
    if not Sequence and (P^ = '(') then
    begin
      inc(P);
      ScanChars := [];
      while not(P^ in [')', #0]) do
      begin
        if P^ = '#' then Inc(P);
        ScanChars := ScanChars + [P^];
        inc(P);
      end;
      if (P^ = ')') and ((P+1)^ <> #0) then
      begin
        inc(P);
        AddSymbol(P^, True);
        inc(P);
      end;
      Exit;
    end;

    while not(P^ in [#0, ']']) do
    begin
      case P^ of
        '[':
          begin
            if not Sequence then
            begin
              ScanSymbol(True);
              Exit;
            end
            else AddSymbol(P^);
          end;
        '#':
          begin
            if (P+1)^ <> #0 then
            begin
              Inc(P);
              AddSymbol(P^);
              if not Sequence then
              begin
                Inc(P);
                Break;
              end;
            end;
          end;
        else begin
          AddSymbol(P^);
          if not Sequence then
          begin
            Inc(P);
            Break;
          end;
        end;
      end;
      Inc(P);
    end;
    if P^ = ']' then
    begin
      if not Sequence then AddSymbol(P^);
      Inc(P);
    end;
  end;

  procedure ScanMaskChar(Chars: TMaskCharSet);
   var
    MaskItem: TMaskItem;
    ScanChars: TMaskCharSet;

    procedure AddMaskItem;
     var
      sValue: string;
      i: integer;
    begin
      if P^ = '{' then
      begin
        Inc(P);
        sValue := '';
        while P^ <> #0 do
        begin
          if P^ = '}' then
          begin
            for i := 1 to StrToIntDef(sValue, 0) do
            EMAddItem(EditMask, MaskItem);
            Break;
          end;
          sValue := sValue + P^;
          Inc(P);
        end;
      end
      else
         EMAddItem(EditMask, MaskItem);
    end;

  begin
    ScanChars := [];
    MaskItem.Options := MaskState;
    MaskItem.MaskType := mtMask;
    MaskItem.Exclude := False;

    Inc(P);
    if P^ in ['[', '('] then
    begin
      if P^ = '[' then MaskItem.Exclude := False else MaskItem.Exclude := True;
      Inc(P);
      while P^ <> #0 do
      begin
        case P^ of
          '#':
            begin
              if (P+1)^ <> #0 then
              begin
                Inc(P);
                ScanChars := ScanChars + [P^];
              end;
            end;
          ']':
            if not MaskItem.Exclude then
            begin
              Inc(P); Break;
            end
            else
              ScanChars := ScanChars + [P^];
          ')':
            if MaskItem.Exclude then
            begin
              Inc(P); Break;
            end
            else
              ScanChars := ScanChars + [P^];
          else
            ScanChars := ScanChars + [P^];
        end;
        Inc(P);
      end;
      if Chars <> [] then
      begin
        MaskItem.Exclude  := False;
        if MaskItem.Exclude then
          ScanChars := Chars - ScanChars
        else
          ScanChars := Chars + ScanChars
      end;

      MaskItem.MChars := ScanChars;
      AddMaskItem;
    end
    else begin
      MaskItem.MChars := Chars;
      AddMaskItem;
    end;
  end;

begin
  P := PChar(Value);
  EMClear(EditMask);
  MaskState := [];

  while P^ <> #0 do
  begin
    case P^ of
      'L', 'l':
        begin
          if P^ = 'L' then
            MaskState := MaskState + [moRequired]
          else
            MaskState := MaskState - [moRequired];
          ScanMaskChar(Letters);
        end;
      'A', 'a':
        begin
          if P^ = 'A' then
            MaskState := MaskState + [moRequired]
          else
            MaskState := MaskState - [moRequired];
          ScanMaskChar(Letters + Numbers);
        end;
      'C', 'c':
        begin
          if P^ = 'C' then
            MaskState := MaskState + [moRequired]
          else
            MaskState := MaskState - [moRequired];
          ScanMaskChar([]);
        end;
      '0', '9':
        begin
          if P^ = '0' then
            MaskState := MaskState + [moRequired]
          else
            MaskState := MaskState - [moRequired];
          ScanMaskChar(Numbers);
        end;
      '!': ScanSymbol(False);
      '<': ScanTag(True);
      else
        Inc(P);
    end;
  end;
end;

function EMMatches(var Value: string; EditMask: TEditMask; SkipSymbols: boolean;
  var SymbolsCount: integer; FullMask: boolean; var MaskEnd: integer): integer;
 var
  StartPos: integer;
  Text: string;

  function MatchesEditMask(var StartPos: integer): boolean;
   var
    P: PChar;
    i : integer;

    function GetMaskChar(Index: integer; C: Char): Char;
    begin
      with EditMask.Masks[Index] do
      begin
        if (MaskType = mtSymbol) and Replace then C := Symbol;
        if moLowerCase in Options then C := AnsiLowerCase(String(C))[1];
        if moUpperCase in Options then C := AnsiUpperCase(String(C))[1];
      end;
      Result := C;
    end;

    function ValidChar(C: Char; MaskItem: TMaskItem): boolean;
    begin
      case MaskItem.MaskType of
        mtSymbol:
          begin
            if MaskItem.Replace then
              Result := C in MaskItem.SChars
            else
              Result := (C = MaskItem.Symbol);
          end;
        mtMask:
          begin
            if MaskItem.Exclude then
              Result := not(C in MaskItem.MChars)
            else
              Result := ((MaskItem.MChars = []) or (C in MaskItem.MChars));
          end;
        else
          Result := False;
      end;
    end;

    function RequiredChar(i: integer): boolean;
    begin
      with EditMask do
        Result := (Masks[i].MaskType = mtMask) and (moRequired in Masks[i].Options) or
                  (Masks[i].MaskType = mtSymbol);
    end;

  begin
    SymbolsCount := 0;
    Result := False;
    Text   := '';
    P := PChar(Value);
    i := StartPos;
    with EditMask do while not Result and (P^ <> #0) and (i < Count) do
    begin
      if SkipSymbols then
      begin
        while (Masks[i].MaskType = mtSymbol) and (i < Count) do
        begin
          Inc(i);
          Inc(SymbolsCount);
        end;
      end;

      if i < Count then
      begin
        if ValidChar(P^, Masks[i]) then
        begin
          Text := Text + GetMaskChar(i, P^);
          Inc(P); Inc(i);
        end
        else begin
          if not RequiredChar(i) then
          begin
            if (StartPos = 0) and not RequiredChar(StartPos) then Inc(StartPos);
            Inc(i)
          end
          else begin
            if not RequiredChar(StartPos) then
            begin
              StartPos := StartPos + 1;
              Result   := MatchesEditMask(StartPos);
              Exit;
            end
            else Break;
          end;
        end;
      end;
    end;
    MaskEnd := i;
    if not Result and (P^ = #0) then with EditMask do
    begin
      if (i <> Count) and FullMask then
      begin
        while not((Masks[i].MaskType = mtMask) and (moRequired in Masks[i].Options)) and
              (i < Count) do Inc(i);
        if i <> Count then
        begin
          if (Masks[StartPos].MaskType = mtMask) and not(moRequired in Masks[StartPos].Options) then
          begin
            StartPos := StartPos + 1;
            Result   := MatchesEditMask(StartPos);
          end;
        end
        else
          Result := True;
      end
      else
        Result := True;
    end;
  end;

begin
  StartPos := 0;
  MaskEnd  := 0;
  if MatchesEditMask(StartPos) then
  begin
    Result := StartPos;
    Value  := Text;
  end
  else
    Result := -1;
end;


function EMDeleteChar(var Value: string; EditMask: TEditMask; SelStart, SelEnd: integer): integer;
 var
  Text: string;
  MaskStart, SymbolsCount, MaskEnd: integer;
begin
  Text := Value;
  if SelEnd - SelStart = 0 then
    Delete(Text, SelStart + 1, 1)
  else
    Delete(Text, SelStart + 1, SelEnd - SelStart);

  MaskStart := EMMatches(Text, EditMask, False, SymbolsCount, False, MaskEnd);
  while (MaskStart = -1) and (Length(Text) > 0) do
  begin
    if Length(Text) > (SelStart + 1) then
      Delete(Text, SelStart + 1, 1)
    else
      Delete(Text, Length(Text), 1);
    MaskStart := EMMatches(Text, EditMask, False, SymbolsCount, False, MaskEnd);
  end;
  Value  := Text;
  if MaskStart > -1 then
    Result := MaskEnd
  else
    Result := 0;
end;

procedure EMCompeteChar(var Value: string; EditMask: TEditMask; MaskEnd: integer;
  var SelStart, SelEnd: integer);
begin
  if MaskEnd < EditMask.Count then
  with EditMask do begin
    while (MaskEnd < Count) and (Masks[MaskEnd].MaskType = mtSymbol) do
    begin
      Value := Value + Masks[MaskEnd].Symbol;
      Inc(SelStart);
      Inc(SelEnd);
      Inc(MaskEnd);
    end;
  end;
end;

procedure EMInsertChar(var Value: string; InsertStr: string; EditMask: TEditMask;
  var SelStart, SelEnd: integer);
 var
  Text: string;
  MaskStart, SymbolsCount, MaskEnd, Offset: integer;

  function GetSource(Source, S: string; Index, Offset: integer): string;
  begin
    if Offset > 0 then S := Copy(S, 1, Length(S) -Offset);
    Result := Source;
    Insert(S, Result, Index);
  end;

begin
  if SelStart < SelEnd then
  begin
    Delete(Value, SelStart + 1, SelEnd - SelStart);
    SelEnd := SelStart;
  end;

  Text := GetSource(Value, InsertStr, SelStart+1, 0);
  MaskStart := EMMatches(Text, EditMask, False, SymbolsCount, False, MaskEnd);

  if MaskStart = -1 then
  begin
    Offset := 1;
    while (MaskStart = -1) and (Length(InsertStr) > Offset)do
    begin
      Text := GetSource(Value, InsertStr, SelStart+1, Offset);
      MaskStart := EMMatches(Text, EditMask, False, SymbolsCount, False, MaskEnd);
      Inc(Offset);
    end;
  end
  else begin
    Value := Text;
    SelStart := SelStart+Length(InsertStr);
  end;
  if MaskStart > -1 then EMCompeteChar(Value, EditMask, MaskEnd, SelStart, SelEnd);
end;

procedure EMClearSymbols(var Value: string; EditMask: TEditMask; MaskEnd: integer;
  var SelStart: integer);
 var
  i: integer;
begin
  i := MaskEnd;
  with EditMask do
  begin
    while (i >= 0) and (Masks[i].MaskType = mtSymbol) do Dec(i);
    if (i >= 0) and (i <> MaskEnd) then Delete(Value, Length(Value) - MaskEnd + i, MaskEnd - i + 1);
  end;
end;

end.