wwpict.pas

胜天进销存源码,国产优秀的进销存

{
//
// Components : TwwPictureValidator
//
// Copyright (c) 1996-2001 by Woll2Woll Software
//
// Components : TwwPictureValidator
//
// Description: Implement Paradox style PictureMask support
//
}
{$R-}
//{$Warnings Off}
unit Wwpict;

interface

type

  TwwPicResult = (prComplete, prIncomplete, prEmpty, prError, prSyntax,
    prAmbiguous, prIncompNoFill);

  TwwPictureValidator = class
    Status: Word;
    Options: Word;
    Pic: PString;

   public
    constructor Create(const APic: string; AutoFill: Boolean);
    destructor Destroy; override; { add override 7/12/96}
    function IsValidInput(var S: string;
      SuppressFill: Boolean): Boolean; virtual;
    function IsValid(const S: string): Boolean; virtual;
    function Picture(var Input: string;
      AutoFill: Boolean): TwwPicResult; virtual;
    function isSyntaxError: boolean;
  end;

implementation

uses Windows, SysUtils;

const
   vsSyntax =  1;      { Error in the syntax }

  { Validator option flags }
  voFill     =  $0001;
  voTransfer =  $0002;
  voOnAppend =  $0004;

constructor TwwPictureValidator.Create(const APic: string;
  AutoFill: Boolean);
var
  S: String;
begin
  Status := 0;
  Options := 0;

  {$Warnings Off}
  Pic := NewStr(APic);
  {$Warnings On}
  Options := voOnAppend;
  if AutoFill then Options := Options or voFill;
  S := '';
  if Picture(S, False) <> prEmpty then
    Status := vsSyntax;
end;

destructor TwwPictureValidator.Destroy;
begin
  {$Warnings Off}
  DisposeStr(Pic);
  {$Warnings On}
  inherited Destroy;
end;

function TwwPictureValidator.isSyntaxError: boolean;
begin
   result:= (status=vsSyntax);
end;

function TwwPictureValidator.IsValidInput(var S: string;
  SuppressFill: Boolean): Boolean;
begin
  IsValidInput := (Pic = nil) or
     (Picture(S, (Options and voFill <> 0)  and not SuppressFill) <> prError);
end;

function TwwPictureValidator.IsValid(const S: string): Boolean;
var
  Str: String;
  Rslt: TwwPicResult;
begin
  Str := S;
  Rslt := Picture(Str, False);
  IsValid := (Pic = nil) or (Rslt = prComplete) or (Rslt = prEmpty);
end;

function IsNumber(ch: Char): Boolean;
begin
   result:= (ch>='0') and (ch<='9');
end;

function IsLetter(Ch: Char): Boolean;
begin
   result:= ((ch>='A') and (ch<='Z')) or
            ((ch>='a') and (ch<='z'));
end;

{function AnsiUpper(ch: char): boolean;
var temp: string[1];
begin
   temp:= AnsiUpperCase(ch);
   Ch := temp[1];
end;
}
function IsIntlLetter(Ch:char):Boolean;
begin
    result:= (IsLetter(Ch)) or (ord(ch)>128)
end;

function IsComplete(Rslt: TwwPicResult): Boolean;
begin
  IsComplete := Rslt in [prComplete, prAmbiguous];
end;

function IsIncomplete(Rslt: TwwPicResult): Boolean;
begin
  IsIncomplete := Rslt in [prIncomplete, prIncompNoFill];
end;

function TwwPictureValidator.Picture(var Input: string;
  AutoFill: Boolean): TwwPicResult;
var
  I, J: word;
  Rslt: TwwPicResult;
  Reprocess: Boolean;
  OrigInput: string;

  function Process(TermCh: word): TwwPicResult;
  var
    Rslt: TwwPicResult;
    Incomp: Boolean;
    OldI, OldJ, IncompJ, IncompI: word;
    skipAutoFill: Boolean;  {9/27/96 - Added to handle autofill and spaces in picture mask}

    { Consume input }
    procedure Consume(Ch: Char);
    begin
      Input[J] := Ch;
      Inc(J);
      Inc(I);
    end;

    { Skip a character or a picture group }
    procedure ToGroupEnd(var I: word; TermCh: word);
    var
      BrkLevel, BrcLevel: Integer;
    begin
      BrkLevel := 0;
      BrcLevel := 0;
      repeat
        if I = TermCh then Exit;
        case Pic^[I] of
          '[': Inc(BrkLevel);
          ']': Dec(BrkLevel);
          '{': Inc(BrcLevel);
          '}': Dec(BrcLevel);
          ';': Inc(I);
          '*':
            begin
              Inc(I);
              while IsNumber(Pic^[I]) do Inc(I);
              ToGroupEnd(I, Termch);
              Continue;
            end;
        end;
        Inc(I);
      until (BrkLevel <= 0) and (BrcLevel <= 0);
    end;

    procedure ToParensEnd(var I: word);
    var
      BrkLevel, BrcLevel: Integer;
    begin
      BrkLevel := 0;
      BrcLevel := 1;
      repeat
        if I = TermCh then Exit;
        case Pic^[I] of
          '[': Inc(BrkLevel);
          ']': Dec(BrkLevel);
          '{': Inc(BrcLevel);
          '}': Dec(BrcLevel);
          ';': Inc(I);
          '*':
            begin
              Inc(I);
              while IsNumber(Pic^[I]) do Inc(I);
              ToGroupEnd(I, TermCh);
              Continue;
            end;
        end;
        Inc(I);
      until (BrkLevel = 0) and (BrcLevel = 0);
    end;

    { Find the a comma separator }
    function SkipToComma: Boolean;
    begin
      repeat ToGroupEnd(I, TermCh) until (I = TermCh) or (Pic^[I] = ',');
      if I<=length(Pic^) then
         if Pic^[I] = ',' then Inc(I);
      SkipToComma := I < TermCh;
    end;

    { Calclate the end of a group }
    function CalcTerm: word;
    var
      K: word;
    begin
      K := I;
      ToGroupEnd(K, TermCh);
      CalcTerm := K;
    end;

    { The next group is repeated X times }
    function Iteration: TwwPicResult;
    var
      Itr, K, L: word;
      Rslt: TwwPicResult;
      NewTermCh: word;
      LastJ: word;
    begin
      Itr := 0;
      Rslt:= prEmpty; { Make compiler happy about being initialized }
{      Iteration := prError;}

      Inc(I);  { Skip '*' }

      { Retrieve number }
      while IsNumber(Pic^[I]) do
      begin
        Itr := Itr * 10 + word(Pic^[I]) - word('0');
        Inc(I);
      end;

      if I > TermCh then
      begin
        Result:= prSyntax;
        Exit;
      end;

      K := I;
      NewTermCh := CalcTerm;

      { If Itr is 0 allow any number, otherwise enforce the number }
      if Itr <> 0 then
      begin
        for L := 1 to Itr do
        begin
          I := K;
          Rslt := Process(NewTermCh);
          if not IsComplete(Rslt) then
          begin
            { Empty means incomplete since all are required }
            if (Rslt = prEmpty) then
            begin
               if(Pic^[i]='[') then Rslt:= prComplete    {Whole Iteration is Optional - !!!}
               else Rslt := prIncomplete;
            end;
            Result:= Rslt;
            Exit;
          end;
        end;
      end
      else
      begin
        repeat
          I := K;
          LastJ:= J;
          Rslt := Process(NewTermCh);
          if (J=LastJ) then break;   { Have not consumed any }
        until not IsComplete(Rslt);
        if (Rslt = prEmpty) or (Rslt = prError) then
        begin
          Inc(I);
          Rslt := prAmbiguous;
        end;
      end;
      I := NewTermCh;
      Result:= Rslt;
    end;

    { Process a picture group }
    function Group: TwwPicResult;
    var
      Rslt: TwwPicResult;
      TermCh: word;
    begin
      TermCh := CalcTerm;
      Inc(I);
      Rslt := Process(TermCh - 1);
      if not IsIncomplete(Rslt) then I := TermCh;
      Group := Rslt;
    end;

    function CheckComplete(Rslt: TwwPicResult; startGroup, EndGroup: integer): TwwPicResult; forward;

    function isOptionalParensGroup(startGroup, EndGroup: integer): boolean;
    var tempStartGroup, tempEndGroup: integer;
      function GetSubGroup(startGroup: integer; var tempEndGroup: integer): Boolean;
      var curPos: word;
      begin